git.iko.soy/elk
on master help sign in
Fix issue in which patterns could become too general
802be96Evan Czaplicki
compiler/Type/Constrain/Pattern.hs+4−6
compare with master
unifiedsplit
@@ -41,16 +41,14 @@ constrain env pattern tipe =
41 }
41 }
42
42
43 PData name patterns -> do
43 PData name patterns -> do
44− (kind, cvars, ctipe) <- freshDataScheme env name
44+ (kind, cvars, args, result) <- freshDataScheme env name
45− tvars <- mapM (\_ -> VarN <$> flexibleVar) [1..kind]
46− let tipe' = foldr (==>) tipe tvars
47− msg = concat [ "Constructor '", name, "' expects ", show kind
45+ let msg = concat [ "Constructor '", name, "' expects ", show kind
48 , " argument", if kind == 1 then "" else "s"
46 , " argument", if kind == 1 then "" else "s"
49 , " but was given ", show (length patterns), "." ]
47 , " but was given ", show (length patterns), "." ]
50 if length patterns /= kind then error msg else do
48 if length patterns /= kind then error msg else do
51− fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns tvars)
49+ fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
52 return $ fragment {
50 return $ fragment {
53− typeConstraint = typeConstraint fragment /\ tipe' === ctipe,
51+ typeConstraint = typeConstraint fragment /\ tipe === result,
54 vars = cvars ++ vars fragment
52 vars = cvars ++ vars fragment
55 }
53 }
56
54
compiler/Type/Environment.hs+12−11
@@ -12,7 +12,7 @@ import qualified SourceSyntax.Type as Src
12import Type.Type
12import Type.Type
13
13
14data Environment = Environment {
14data Environment = Environment {
15− constructor :: Map.Map String (IO (Int, [Variable], Type)),
15+ constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
16 types :: Map.Map String Type,
16 types :: Map.Map String Type,
17 value :: Map.Map String Type
17 value :: Map.Map String Type
18}
18}
@@ -48,26 +48,27 @@ makeTypes datatypes =
48 ]
48 ]
49
49
50
50
51−makeConstructors :: Map.Map String Type -> Map.Map String (IO (Int, [Variable], Type))
51+makeConstructors :: Map.Map String Type -> Map.Map String (IO (Int, [Variable], [Type], Type))
52makeConstructors types = Map.fromList builtins
52makeConstructors types = Map.fromList builtins
53 where
53 where
54 list t = (types ! "_List") <| t
54 list t = (types ! "_List") <| t
55 maybe t = (types ! "Maybe") <| t
55 maybe t = (types ! "Maybe") <| t
56
56
57− inst :: Int -> Int -> ([Type] -> Type) -> IO (Int, [Variable], Type)
57+ inst :: Int -> Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
58 inst kind numTVars tipe = do
58 inst kind numTVars tipe = do
59 vars <- forM [1..numTVars] $ \_ -> flexibleVar
59 vars <- forM [1..numTVars] $ \_ -> flexibleVar
60− return (kind, vars, tipe $ map VarN vars)
60+ let (args, result) = tipe (map VarN vars)
61+ return (kind, vars, args, result)
61
62
62 tupleCtor n =
63 tupleCtor n =
63 let name = "_Tuple" ++ show n
64 let name = "_Tuple" ++ show n
64− in (name, inst n n $ \vs -> foldr (==>) (foldl (<|) (types ! name) vs) vs)
65+ in (name, inst n n $ \vs -> (vs, foldl (<|) (types ! name) vs))
65
66
66− builtins :: [ (String, IO (Int, [Variable], Type)) ]
67+ builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
67− builtins = [ ("Nothing", inst 0 1 $ \ [t] -> maybe t)
68+ builtins = [ ("Nothing", inst 0 1 $ \ [t] -> ([], maybe t))
68− , ("Just" , inst 1 1 $ \ [t] -> t ==> maybe t)
69+ , ("Just" , inst 1 1 $ \ [t] -> ([t], maybe t))
69− , ("[]" , inst 0 1 $ \ [t] -> list t)
70+ , ("[]" , inst 0 1 $ \ [t] -> ([], list t))
70− , ("::" , inst 2 1 $ \ [t] -> t ==> list t ==> list t)
71+ , ("::" , inst 2 1 $ \ [t] -> ([t, list t], list t))
71 ] ++ map tupleCtor [0..9]
72 ] ++ map tupleCtor [0..9]
72
73
73
74
@@ -77,7 +78,7 @@ get env subDict key = Map.findWithDefault err key (subDict env)
77 err = error $ "Could not find '" ++ key ++ "' in the type environment."
78 err = error $ "Could not find '" ++ key ++ "' in the type environment."
78
79
79
80
80−freshDataScheme :: Environment -> String -> IO (Int, [Variable], Type)
81+freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
81freshDataScheme env name = get env constructor name
82freshDataScheme env name = get env constructor name
82
83
83
84
compiler/Type/Inference.hs+5−3
@@ -31,8 +31,8 @@ infer interfaces' modul = unsafePerformIO $ do
31 env <- Env.initialEnvironment (datatypes modul ++ concatMap iAdts (Map.elems interfaces))
31 env <- Env.initialEnvironment (datatypes modul ++ concatMap iAdts (Map.elems interfaces))
32 var <- T.flexibleVar
32 var <- T.flexibleVar
33 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
33 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
34− do (_, vars, tipe) <- Env.freshDataScheme env name
34+ do (_, vars, args, result) <- Env.freshDataScheme env name
35− return (name, (vars, tipe))
35+ return (name, (vars, foldr (T.==>) result args))
36
36
37 let locals = Map.intersectionWithKey combine localImports interfaces
37 let locals = Map.intersectionWithKey combine localImports interfaces
38 combine name importMethod interface =
38 combine name importMethod interface =
@@ -54,8 +54,10 @@ infer interfaces' modul = unsafePerformIO $ do
54 vars = concatMap (fst . snd) allTypes
54 vars = concatMap (fst . snd) allTypes
55 header = Map.map snd (Map.fromList allTypes)
55 header = Map.map snd (Map.fromList allTypes)
56 environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
56 environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
57+
57 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN var)
58 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN var)
58−-- print =<< T.extraPretty constraint
59+ print =<< T.extraPretty constraint
60+
59 state <- execStateT (Solve.solve constraint) TS.initialState
61 state <- execStateT (Solve.solve constraint) TS.initialState
60 let errors = TS.sErrors state
62 let errors = TS.sErrors state
61 if null errors
63 if null errors