git.iko.soy/elk
on master help sign in
Fix issue in which patterns could become too general
commit802be96e5765214f7a5ed1a4e4a9f02d757af734 authorEvan Czaplicki <info@elm-lang.org> dateTue 23 Jul 2013, 15:32 (13 years ago) parent175798f
3 files changed+21−20
compare with master
unifiedsplit
compiler/Type/Constrain/Pattern.hs+4−6 compiler/Type/Environment.hs+12−11 compiler/Type/Inference.hs+5−3
compiler/Type/Constrain/Pattern.hs+4−6
@@ -41,16 +41,14 @@ constrain env pattern tipe =
4141 }
4242
4343 PData name patterns -> do
44− (kind, cvars, ctipe) <- freshDataScheme env name
45− tvars <- mapM (\_ -> VarN <$> flexibleVar) [1..kind]
46− let tipe' = foldr (==>) tipe tvars
47− msg = concat [ "Constructor '", name, "' expects ", show kind
44+ (kind, cvars, args, result) <- freshDataScheme env name
45+ let msg = concat [ "Constructor '", name, "' expects ", show kind
4846 , " argument", if kind == 1 then "" else "s"
4947 , " but was given ", show (length patterns), "." ]
5048 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)
5250 return $ fragment {
53− typeConstraint = typeConstraint fragment /\ tipe' === ctipe,
51+ typeConstraint = typeConstraint fragment /\ tipe === result,
5452 vars = cvars ++ vars fragment
5553 }
5654
compiler/Type/Environment.hs+12−11
@@ -12,7 +12,7 @@ import qualified SourceSyntax.Type as Src
1212import Type.Type
1313
1414data Environment = Environment {
15− constructor :: Map.Map String (IO (Int, [Variable], Type)),
15+ constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
1616 types :: Map.Map String Type,
1717 value :: Map.Map String Type
1818}
@@ -48,26 +48,27 @@ makeTypes datatypes =
4848 ]
4949
5050
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))
5252makeConstructors types = Map.fromList builtins
5353 where
5454 list t = (types ! "_List") <| t
5555 maybe t = (types ! "Maybe") <| t
5656
57− inst :: Int -> Int -> ([Type] -> Type) -> IO (Int, [Variable], Type)
57+ inst :: Int -> Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
5858 inst kind numTVars tipe = do
5959 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)
6162
6263 tupleCtor n =
6364 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))
6566
66− builtins :: [ (String, IO (Int, [Variable], Type)) ]
67− builtins = [ ("Nothing", inst 0 1 $ \ [t] -> maybe t)
68− , ("Just" , inst 1 1 $ \ [t] -> t ==> maybe t)
69− , ("[]" , inst 0 1 $ \ [t] -> list t)
70− , ("::" , inst 2 1 $ \ [t] -> t ==> list t ==> list t)
67+ builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
68+ builtins = [ ("Nothing", inst 0 1 $ \ [t] -> ([], maybe t))
69+ , ("Just" , inst 1 1 $ \ [t] -> ([t], maybe t))
70+ , ("[]" , inst 0 1 $ \ [t] -> ([], list t))
71+ , ("::" , inst 2 1 $ \ [t] -> ([t, list t], list t))
7172 ] ++ map tupleCtor [0..9]
7273
7374
@@ -77,7 +78,7 @@ get env subDict key = Map.findWithDefault err key (subDict env)
7778 err = error $ "Could not find '" ++ key ++ "' in the type environment."
7879
7980
80−freshDataScheme :: Environment -> String -> IO (Int, [Variable], Type)
81+freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
8182freshDataScheme env name = get env constructor name
8283
8384
compiler/Type/Inference.hs+5−3
@@ -31,8 +31,8 @@ infer interfaces' modul = unsafePerformIO $ do
3131 env <- Env.initialEnvironment (datatypes modul ++ concatMap iAdts (Map.elems interfaces))
3232 var <- T.flexibleVar
3333 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
34− do (_, vars, tipe) <- Env.freshDataScheme env name
35− return (name, (vars, tipe))
34+ do (_, vars, args, result) <- Env.freshDataScheme env name
35+ return (name, (vars, foldr (T.==>) result args))
3636
3737 let locals = Map.intersectionWithKey combine localImports interfaces
3838 combine name importMethod interface =
@@ -54,8 +54,10 @@ infer interfaces' modul = unsafePerformIO $ do
5454 vars = concatMap (fst . snd) allTypes
5555 header = Map.map snd (Map.fromList allTypes)
5656 environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
57+
5758 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN var)
58−-- print =<< T.extraPretty constraint
59+ print =<< T.extraPretty constraint
60+
5961 state <- execStateT (Solve.solve constraint) TS.initialState
6062 let errors = TS.sErrors state
6163 if null errors