git.iko.soy/elk
on master help sign in
Refactor type environment
a3a7b3eEvan Czaplicki
compiler/Type/Constrain/Expression.hs+5−35
compare with master
unifiedsplit
@@ -3,7 +3,6 @@ module Type.Constrain.Expression where
3import qualified Data.List as List
3import qualified Data.List as List
4import qualified Data.Map as Map
4import qualified Data.Map as Map
5import qualified Data.Set as Set
5import qualified Data.Set as Set
6−import Data.Map ((!))
7import Control.Arrow (second)
6import Control.Arrow (second)
8import Control.Applicative ((<$>),(<*>))
7import Control.Applicative ((<$>),(<*>))
9import qualified Control.Monad as Monad
8import qualified Control.Monad as Monad
@@ -33,7 +32,7 @@ test str =
33 case iParse expr "" str of
32 case iParse expr "" str of
34 Left err -> error $ "Parse error at " ++ show err
33 Left err -> error $ "Parse error at " ++ show err
35 Right expression -> do
34 Right expression -> do
36− env <- Env.initialEnvironment
35+ env <- Env.initialEnvironment []
37 var <- flexibleVar
36 var <- flexibleVar
38 let expr = SD.sortDefs expression
37 let expr = SD.sortDefs expression
39 print (pretty expr)
38 print (pretty expr)
@@ -50,7 +49,7 @@ test str =
50
49
51constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint
50constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint
52constrain env (L _ _ expr) tipe =
51constrain env (L _ _ expr) tipe =
53− let list t = TermN (App1 (Env.get env Env.builtin "[_]") t) in
52+ let list t = TermN (App1 (Env.get env Env.types "_List") t) in
54 case expr of
53 case expr of
55 Literal lit -> return $ Literal.constrain env lit tipe
54 Literal lit -> return $ Literal.constrain env lit tipe
56
55
@@ -91,7 +90,7 @@ constrain env (L _ _ expr) tipe =
91
90
92 MultiIf branches -> CAnd <$> mapM constrain' branches
91 MultiIf branches -> CAnd <$> mapM constrain' branches
93 where
92 where
94− bool = Env.get env Env.builtin "Bool"
93+ bool = Env.get env Env.types "Bool"
95 constrain' (b,e) = do
94 constrain' (b,e) = do
96 cb <- constrain env b bool
95 cb <- constrain env b bool
97 ce <- constrain env e tipe
96 ce <- constrain env e tipe
@@ -165,7 +164,7 @@ constrain env (L _ _ expr) tipe =
165 return ((name, v), c)
164 return ((name, v), c)
166
165
167 Markdown _ ->
166 Markdown _ ->
168− return $ tipe === Env.get env Env.builtin "Element"
167+ return $ tipe === Env.get env Env.types "Element"
169
168
170 Let defs body ->
169 Let defs body ->
171 do c <- constrain env body tipe
170 do c <- constrain env body tipe
@@ -187,7 +186,7 @@ constrainDef env info (pattern, expr, maybeTipe) =
187 do flexiVars <- mapM (\_ -> flexibleVar) qs
186 do flexiVars <- mapM (\_ -> flexibleVar) qs
188 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
187 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
189 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
188 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
190− typ <- instantiateType tipe
189+ typ <- Env.instantiateType env tipe
191 let scheme = Scheme { rigidQuantifiers = [],
190 let scheme = Scheme { rigidQuantifiers = [],
192 flexibleQuantifiers = flexiVars,
191 flexibleQuantifiers = flexiVars,
193 constraint = CTrue,
192 constraint = CTrue,
@@ -216,35 +215,6 @@ constrainDef env info (pattern, expr, maybeTipe) =
216 , c1 )
215 , c1 )
217
216
218
217
219−instantiateType :: SrcT.Type -> IO Type
220−instantiateType sourceType = instantiateTypeWithContext sourceType Map.empty
221−
222−instantiateTypeWithContext :: SrcT.Type -> Map.Map String Variable -> IO Type
223−instantiateTypeWithContext sourceType dict = evalStateT (go sourceType) dict
224− where
225− go :: SrcT.Type -> StateT (Map.Map String Variable) IO Type
226− go sourceType =
227− case sourceType of
228− SrcT.Lambda t1 t2 -> TermN <$> (Fun1 <$> go t1 <*> go t2)
229−
230− SrcT.Var x -> do
231− dict <- get
232− case Map.lookup x dict of
233− Just var -> return (VarN var)
234− Nothing -> do
235− var <- liftIO $ namedVar x -- should this be Constant or Flexible?
236− put (Map.insert x var dict)
237− return (VarN var)
238−
239− SrcT.Data name ts -> do
240− ts' <- mapM go ts
241− return $ foldr (\t result -> TermN $ App1 t result) (error "not sure how to look this up yet") ts'
242−
243− SrcT.EmptyRecord -> return (TermN EmptyRecord1)
244−
245− SrcT.Record fields ext ->
246− TermN <$> (Record1 <$> traverse (mapM go) fields <*> go ext)
247−
248expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)
218expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)
249 -> [(Pattern, LExpr t v, Maybe SrcT.Type)]
219 -> [(Pattern, LExpr t v, Maybe SrcT.Type)]
250expandPattern triple@(pattern, lexpr, maybeType) =
220expandPattern triple@(pattern, lexpr, maybeType) =
compiler/Type/Constrain/Literal.hs+1−1
@@ -10,7 +10,7 @@ import Type.Environment as Env
10
10
11constrain :: Environment -> Literal -> Type -> TypeConstraint
11constrain :: Environment -> Literal -> Type -> TypeConstraint
12constrain env literal tipe =
12constrain env literal tipe =
13− let prim name = Env.get env builtin name in
13+ let prim name = Env.get env Env.types name in
14 case literal of
14 case literal of
15 IntNum _ -> tipe === prim "Int"
15 IntNum _ -> tipe === prim "Int"
16 FloatNum _ -> tipe === prim "Float"
16 FloatNum _ -> tipe === prim "Float"
compiler/Type/Constrain/Pattern.hs+8−34
@@ -41,13 +41,15 @@ constrain env pattern tipe =
41 }
41 }
42
42
43 PData name patterns -> do
43 PData name patterns -> do
44− (cvars, ctipe) <- freshDataScheme env name
44+ (kind, cvars, ctipe) <- freshDataScheme env name
45− let (argTypes, resultType) = flattenFunction ctipe
45+ let tvars = map VarN cvars
46− msg = "Constructor '" ++ name ++ "' expects " ++ show (length argTypes) ++ " arguments."
46+ msg = concat [ "Constructor '", name, "' expects ", show kind
47+ , " argument", if kind == 1 then "" else "s"
48+ , " but was given ", show (length patterns), "." ]
47− if length patterns /= length argTypes then error msg else do
49+ if length patterns /= kind then error msg else do
48− fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns argTypes)
50+ fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns tvars)
49 return $ fragment {
51 return $ fragment {
50− typeConstraint = typeConstraint fragment /\ tipe === resultType,
52+ typeConstraint = typeConstraint fragment /\ tipe === ctipe,
51 vars = cvars ++ vars fragment
53 vars = cvars ++ vars fragment
52 }
54 }
53
55
@@ -60,31 +62,3 @@ constrain env pattern tipe =
60 vars = map snd pairs,
62 vars = map snd pairs,
61 typeConstraint = c
63 typeConstraint = c
62 }
64 }
63−
64−freshDataScheme :: Environment -> [Char] -> IO ([Variable], Type)
65−freshDataScheme env name =
66− do let (vars, tipe) = Env.get env constructor name
67− freshVars <- mapM (\_ -> flexibleVar) vars
68− let assocList = zip vars freshVars
69− return (freshVars, substitute assocList tipe)
70−
71−substitute :: Eq a => [(a, a)] -> TermN a -> TermN a
72−substitute assocs tipe =
73− case tipe of
74− VarN x -> VarN (Maybe.fromMaybe x (List.lookup x assocs))
75− TermN t -> TermN $
76− case t of
77− App1 a b -> App1 (substitute assocs a) (substitute assocs b)
78− Fun1 a b -> Fun1 (substitute assocs a) (substitute assocs b)
79− Var1 v -> Var1 (substitute assocs v)
80− EmptyRecord1 -> EmptyRecord1
81− Record1 fields extension ->
82− Record1 (Map.map (map $ substitute assocs) fields)
83− (substitute assocs extension)
84−
85−flattenFunction :: TermN t -> ([TermN t], TermN t)
86−flattenFunction = go []
87− where go args tipe =
88− case tipe of
89− TermN (Fun1 a b) -> go (a:args) b
90− _ -> (reverse args, tipe)
compiler/Type/Environment.hs+114−22
@@ -1,41 +1,133 @@
1module Type.Environment where
1module Type.Environment where
2
2
3+import Control.Applicative ((<$>), (<*>))
4+import Control.Monad
5+import qualified Control.Monad.State as State
6+import qualified Data.Traversable as Traverse
3import qualified Data.Map as Map
7import qualified Data.Map as Map
4import Data.Map ((!))
8import Data.Map ((!))
5import qualified Data.UnionFind.IO as UF
9import qualified Data.UnionFind.IO as UF
6
10
11+import qualified SourceSyntax.Type as Src
7import Type.Type
12import Type.Type
8
13
9data Environment = Environment {
14data Environment = Environment {
10− constructor :: Map.Map String ([Variable], Type),
15+ constructor :: Map.Map String (IO (Int, [Variable], Type)),
11− builtin :: Map.Map String Type,
16+ types :: Map.Map String Type,
12 value :: Map.Map String Type
17 value :: Map.Map String Type
13}
18}
14
19
15−initialEnvironment :: IO Environment
20+initialEnvironment :: [(String, [String], [(String,[Src.Type])])] -> IO Environment
16−initialEnvironment = do
21+initialEnvironment datatypes = do
17− let mkPair name = fmap ((,) name . VarN) (namedVar name)
22+ types <- makeTypes datatypes
18− list <- mkPair "[_]"
19− int <- mkPair "Int"
20− prims <- mapM mkPair ["Float","Char","Bool","Element"]
21− let builtins = list : int : prims
22−
23− cons <- do v <- flexibleVar
24− let vlist = TermN (App1 (snd list) (VarN v))
25− return ([v], VarN v ==> vlist ==> vlist)
26−
27− nil <- do v <- flexibleVar
28− return ([v], TermN (App1 (snd list) (VarN v)))
29−
30− let add = snd int ==> snd int ==> snd int
31
23
32 return $ Environment {
24 return $ Environment {
33− constructor = Map.fromList [("::", cons), ("[]", nil)],
25+ constructor = makeConstructors types datatypes,
34− builtin = Map.fromList builtins,
26+ types = types,
35− value = Map.empty -- Map.fromList [("+", add)]
27+ value = Map.empty
36 }
28 }
37
29
30+makeTypes datatypes =
31+ Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
32+ where
33+ nameAndKind (name, tvars, _) = (name, length tvars)
34+
35+ makeCtor (name, kind) = do
36+ ctor <- VarN <$> namedVar name
37+ return (name, ctor)
38+
39+ tuple n = ("_Tuple" ++ show n, n)
40+
41+ kind n names = map (\name -> (name, n)) names
42+
43+ builtins :: [(String,Int)]
44+ builtins = concat [ map tuple [0..10]
45+ , kind 1 ["_List","Maybe","Signal"]
46+ , kind 0 ["Int","Float","Char","Bool","Element"]
47+ ]
48+
49+makeConstructors types datatypes =
50+ Map.union (Map.fromList builtins) (Map.unions $ map (instances dummyEnv) datatypes)
51+ where
52+ dummyEnv = Environment { constructor=Map.empty, types=types, value=Map.empty }
53+
54+ list t = (types ! "_List") <| t
55+ maybe t = (types ! "Maybe") <| t
56+
57+ inst :: Int -> Int -> ([Type] -> Type) -> IO (Int, [Variable], Type)
58+ inst kind numTVars tipe = do
59+ vars <- forM [1..numTVars] $ \_ -> flexibleVar
60+ return (kind, vars, tipe $ map VarN vars)
61+
62+ tupleCtor n =
63+ let name = "_Tuple" ++ show n
64+ in (name, inst n n $ \vs -> foldr (==>) (foldl (<|) (types ! name) vs) vs)
65+
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)
71+ ] ++ map tupleCtor [0..10]
72+
73+
74+
38get :: Environment -> (Environment -> Map.Map String a) -> String -> a
75get :: Environment -> (Environment -> Map.Map String a) -> String -> a
39get env subDict key = Map.findWithDefault err key (subDict env)
76get env subDict key = Map.findWithDefault err key (subDict env)
40 where
77 where
41− err = error $ "Could not find '" ++ key ++ "' in the type environment."
78+ err = error $ "Could not find '" ++ key ++ "' in the type environment."
79+
80+
81+freshDataScheme :: Environment -> String -> IO (Int, [Variable], Type)
82+freshDataScheme env name = do
83+ putStr "fresh " >> putStrLn name
84+ get env constructor name
85+
86+
87+instances :: Environment
88+ -> (String, [String], [(String, [Src.Type])])
89+ -> Map.Map String (IO (Int, [Variable], Type))
90+instances env (name, tvars, ctors) = Map.fromList $ map go ctors
91+ where
92+ tipe = Src.Data name (map Src.Var tvars)
93+
94+ go (ctor, tipes) = (,) ctor $ do
95+ let funcType = foldr Src.Lambda tipe tipes
96+ (vars, ttype) <- instantiateTypeWithContext env funcType Map.empty
97+ return (length tipes, vars, ttype)
98+
99+instantiateType :: Environment -> Src.Type -> IO Type
100+instantiateType env sourceType =
101+ snd <$> instantiateTypeWithContext env sourceType Map.empty
102+
103+instantiateTypeWithContext :: Environment
104+ -> Src.Type
105+ -> Map.Map String Variable
106+ -> IO ([Variable], Type)
107+instantiateTypeWithContext env sourceType dict =
108+ do (tipe, dict') <- State.runStateT (go sourceType) dict
109+ return (Map.elems dict', tipe)
110+ where
111+ go :: Src.Type -> State.StateT (Map.Map String Variable) IO Type
112+ go sourceType =
113+ case sourceType of
114+ Src.Lambda t1 t2 -> TermN <$> (Fun1 <$> go t1 <*> go t2)
115+
116+ Src.Var x -> do
117+ dict <- State.get
118+ case Map.lookup x dict of
119+ Just var -> return (VarN var)
120+ Nothing -> do
121+ var <- State.liftIO $ namedVar x -- should this be Constant or Flexible?
122+ State.put (Map.insert x var dict)
123+ return (VarN var)
124+
125+ Src.Data name ts -> do
126+ State.liftIO $ putStr "instantiate " >> putStrLn name
127+ ts' <- mapM go ts
128+ return $ foldr (\t result -> TermN $ App1 t result) (get env types name) ts'
129+
130+ Src.EmptyRecord -> return (TermN EmptyRecord1)
131+
132+ Src.Record fields ext ->
133+ TermN <$> (Record1 <$> Traverse.traverse (mapM go) fields <*> go ext)
compiler/Type/Inference.hs+12−2
@@ -13,17 +13,27 @@ import qualified SourceSyntax.Expression as Expr
13import Text.PrettyPrint
13import Text.PrettyPrint
14import qualified Type.State as TS
14import qualified Type.State as TS
15import Control.Monad.State
15import Control.Monad.State
16+import Control.Arrow (second)
16import Transform.SortDefinitions as Sort
17import Transform.SortDefinitions as Sort
17
18
18import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
19import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
19 -- the IO monad. Not sure if that'd be worthwhile.
20 -- the IO monad. Not sure if that'd be worthwhile.
20
21
22+
21infer :: MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)
23infer :: MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)
22infer modul = unsafePerformIO $ do
24infer modul = unsafePerformIO $ do
23− env <- Env.initialEnvironment
25+ env <- Env.initialEnvironment (datatypes modul)
24 var <- T.flexibleVar
26 var <- T.flexibleVar
27+ ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
28+ do (_, vars, tipe) <- Env.freshDataScheme env name
29+ return (name, (vars, tipe))
30+
25 let expr = Expr.dummyLet $ defs modul
31 let expr = Expr.dummyLet $ defs modul
32+ vars = concatMap (fst . snd) ctors
33+ header = Map.map snd (Map.fromList ctors)
34+ environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
26− constraint <- TcExpr.constrain env expr (T.VarN var)
35+ constraint <- environ `fmap` TcExpr.constrain env expr (T.VarN var)
36+ print =<< T.extraPretty constraint
27 (env,_,_,errors) <- execStateT (Solve.solve constraint) TS.initialState
37 (env,_,_,errors) <- execStateT (Solve.solve constraint) TS.initialState
28 if null errors
38 if null errors
29 then return $ Right env
39 then return $ Right env