finally get around to fixing issue #9!

src/Type/Infer.hs

@@ -1672,7 +1672,8 @@ getTypeName tp
 
 inferBranch :: PatternKind -> Maybe (Type,Range) -> Type -> Range -> [Name] -> Branch Type -> Inf ([(Type,Effect)],Core.Branch)
 inferBranch patkind propagated matchType matchRange matchedNames branch@(Branch pattern guards)
-  = inferPattern patkind matchType (getRange branch) pattern (
+  = -- trace ("inferBranch: " ++ show matchType) $
+    inferPattern patkind matchType (getRange branch) pattern (
     \pcore gcores ->
        do when (rangeNull /= getRange pattern) $
             -- check for unused pattern bindings
@@ -1749,7 +1750,7 @@ inferPattern :: HasTypeVar a => PatternKind -> Type -> Range -> Pattern Type ->
                   -> ([(Name,NameInfo)] -> Inf ([(Type,Effect)],a))
                   -> Inf ([(Type,Effect)],b)
 inferPattern patkind matchType branchRange (PatCon name patterns0 nameRange range) withPattern inferGuards
-  = do (qname,gconTp,repr,coninfo) <- resolveConPatternName name (length patterns0) range
+  = do (qname,gconTp,repr,coninfo) <- resolveConPatternName name matchType (length patterns0) range
        addRangeInfo nameRange (RM.Id qname (RM.NICon gconTp (conInfoDoc coninfo)) [] False)
        -- traceDoc $ \env -> text "inferPattern.constructor:" <+> pretty qname <.> text ":" <+> ppType env gconTp
 

src/Type/InferMonad.hs

@@ -901,10 +901,33 @@ resolveConName name mbType range
   = do (qname,tp,info) <- resolveNameEx isInfoCon Nothing name (maybeToContext mbType) range  range
        return (qname,tp,infoRepr info,infoCon info)
 
-resolveConPatternName :: Name -> Int -> Range -> Inf (Name,Type,Core.ConRepr,ConInfo)
-resolveConPatternName name patternCount range
-  = do (qname,tp,info) <- resolveNameEx isInfoCon Nothing name ctx range  range
-       return (qname,tp,infoRepr info,infoCon info)
+getDataTpName :: Type -> Maybe Name
+getDataTpName tp = 
+  let tp' = expandSyn tp in
+  case splitPredType tp of
+    (_,_,TCon tcon) -> Just $ typeconName tcon
+    (_,_,TApp (TCon tcon) _) -> Just $ typeconName tcon
+    _ -> 
+      case splitFunScheme tp of
+        Just (_, _, _, _, TCon tcon) -> Just $ typeconName tcon
+        Just (_, _, _, _, TApp (TCon tcon) _) -> Just $ typeconName tcon
+        _ -> -- trace ("TypeCon not found " ++ show tp) $ 
+              Nothing
+
+resolveConPatternName :: Name -> Type -> Int -> Range -> Inf (Name,Type,Core.ConRepr,ConInfo)
+resolveConPatternName name expected patternCount range
+  = do case getDataTpName expected of 
+          Just nm -> do
+            (qname,tp,info) <- resolveNameEx (\ni -> 
+                  isInfoCon ni && 
+                    (case ni of -- Check for exact type name match since we have the expected type
+                        InfoCon {infoCon = ConInfo{conInfoTypeName = tname}} -> nm == tname
+                        _ -> False)
+                ) Nothing name ctx range  range
+            return (qname,tp,infoRepr info,infoCon info)
+          _ -> do
+            (qname,tp,info) <- resolveNameEx isInfoCon Nothing name ctx range range
+            return (qname,tp,infoRepr info,infoCon info)
   where
     ctx = if patternCount > 0 then CtxFunArgs True {-partial?-} patternCount [] Nothing else CtxNone
 

test/Spec.hs

@@ -14,6 +14,7 @@ import Text.JSON
 import Test.Hspec
 import Test.Hspec.Core.Runner
 import Test.Hspec.Core.Formatters hiding (Error)
+import Debug.Trace (trace)
 
 commonFlags :: [String]
 commonFlags = ["-c", "-v0", "--console=raw",
@@ -27,7 +28,7 @@ data Mode = Test | New | Update
   deriving (Eq, Ord, Show)
 
 
-data Options = Options{ mode :: Mode, cabal :: Bool, sysghc:: Bool, opt :: Int, target :: String, par :: Bool, rebuild :: Bool }
+data Options = Options{ mode :: Mode, cabal :: Bool, sysghc:: Bool, opt :: Int, target :: String, par :: Bool, rebuild :: Bool } deriving Show
 
 optionsDefault = Options Test False False 0 "" True False
 
@@ -37,6 +38,9 @@ data Cfg = Cfg{ flags   :: [String],
                 fexclude:: !(String -> Bool)
               }
 
+showCfg (Cfg flags options exclude _)
+  = "Cfg " ++ show flags ++ " " ++ show options ++ " " ++ show exclude
+
 makeCfg :: [String] -> Options -> [String] -> Cfg
 makeCfg flags options []
   = Cfg flags options [] (\s -> False)
@@ -155,6 +159,7 @@ makeTest cfg fp
            when shouldRun $
              it (takeBaseName fp) $ do
                kokaDir <- getCurrentDirectory
+               -- trace ("running: " ++ fp ++ " " ++ showCfg cfg) $ return ()
                out <- runKoka cfg kokaDir fp
                unless (mode (options cfg) == Test) $ (withBinaryFile expectedFile WriteMode (\h -> hPutStr h out)) -- writeFile expectedFile out
                expected <- testSanitize kokaDir <$> readFile expectedFile

test/type/match-constructor.kk

@@ -0,0 +1,25 @@
+// Issue: https://github.com/koka-lang/koka/issues/9
+
+type bar
+  bar/Foo
+
+type foo
+  foo/Foo
+
+type bar2<a>
+  bar2/Foo2(a: a)
+
+type foo2<a>
+  foo2/Foo2(a: a)
+
+fun foo/to-int(x: foo): int
+  match x
+    Foo -> 1
+
+fun foo2/to-int(x: foo2<int>): int
+  match x
+    Foo2(y) -> y
+
+fun main()
+  foo/Foo.to-int.println
+  foo2/Foo2(0).to-int.println

test/type/match-constructor.kk.out

@@ -0,0 +1,9 @@
+type/match-constructor/bar/Foo: bar
+type/match-constructor/bar2/Foo2: forall<a> (a : a) -> bar2<a>
+type/match-constructor/bar2/a: forall<a> (bar2 : bar2<a>) -> a
+type/match-constructor/foo/Foo: foo
+type/match-constructor/foo/to-int: (x : foo) -> int
+type/match-constructor/foo2/Foo2: forall<a> (a : a) -> foo2<a>
+type/match-constructor/foo2/a: forall<a> (foo2 : foo2<a>) -> a
+type/match-constructor/foo2/to-int: (x : foo2<int>) -> int
+type/match-constructor/main: () -> console ()