git.iko.soy/elk
on master help sign in
Resolve type aliases in `instantiator`
0f85a2fEvan Czaplicki
compiler/Type/Environment.hs+53−33
compare with master
unifiedsplit
@@ -13,23 +13,29 @@ import qualified SourceSyntax.Type as Src
13import SourceSyntax.Module (ADT)
13import SourceSyntax.Module (ADT)
14import Type.Type
14import Type.Type
15
15
16+type TypeDict = Map.Map String Type
17+type VarDict = Map.Map String Variable
18+
16data Environment = Environment {
19data Environment = Environment {
17 constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
20 constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
18− types :: Map.Map String Type,
21+ aliases :: Map.Map String ([String], Src.Type),
19− value :: Map.Map String Type
22+ types :: TypeDict,
23+ value :: TypeDict
20}
24}
21
25
22−initialEnvironment :: [ADT] -> IO Environment
26+initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment
23−initialEnvironment datatypes = do
27+initialEnvironment datatypes aliases = do
24 types <- makeTypes datatypes
28 types <- makeTypes datatypes
29+ let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases
30+ env = Environment {
31+ constructor = Map.empty,
32+ value = Map.empty,
33+ types = types,
34+ aliases = aliases' }
25
35
26− return $ Environment {
27− constructor = makeConstructors types datatypes,
36+ return $ env { constructor = makeConstructors env datatypes }
28− types = types,
29− value = Map.empty
30− }
31
37
32−makeTypes :: [ADT] -> IO (Map.Map String Type)
38+makeTypes :: [ADT] -> IO TypeDict
33makeTypes datatypes =
39makeTypes datatypes =
34 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
40 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
35 where
41 where
@@ -51,12 +57,12 @@ makeTypes datatypes =
51 ]
57 ]
52
58
53
59
54−makeConstructors :: Map.Map String Type
60+makeConstructors :: Environment
55 -> [ADT]
61 -> [ADT]
56 -> Map.Map String (IO (Int, [Variable], [Type], Type))
62 -> Map.Map String (IO (Int, [Variable], [Type], Type))
57−makeConstructors types datatypes = Map.fromList builtins
63+makeConstructors env datatypes = Map.fromList builtins
58 where
64 where
59− list t = (types ! "_List") <| t
65+ list t = (types env ! "_List") <| t
60
66
61 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
67 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
62 inst numTVars tipe = do
68 inst numTVars tipe = do
@@ -66,15 +72,14 @@ makeConstructors types datatypes = Map.fromList builtins
66
72
67 tupleCtor n =
73 tupleCtor n =
68 let name = "_Tuple" ++ show n
74 let name = "_Tuple" ++ show n
69− in (name, inst n $ \vs -> (vs, foldl (<|) (types ! name) vs))
75+ in (name, inst n $ \vs -> (vs, foldl (<|) (types env ! name) vs))
70
76
71 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
77 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
72 builtins = [ ("[]" , inst 1 $ \ [t] -> ([], list t))
78 builtins = [ ("[]" , inst 1 $ \ [t] -> ([], list t))
73 , ("::" , inst 1 $ \ [t] -> ([t, list t], list t))
79 , ("::" , inst 1 $ \ [t] -> ([t, list t], list t))
74 ] ++ map tupleCtor [0..9]
80 ] ++ map tupleCtor [0..9]
75− ++ concatMap (ctorToType tempEnv) datatypes
81+ ++ concatMap (ctorToType env) datatypes
76
82
77− tempEnv = Environment { types = types, constructor = Map.empty, value = Map.empty }
78
83
79ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
84ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
80ctorToType env (name, tvars, ctors) =
85ctorToType env (name, tvars, ctors) =
@@ -82,11 +87,11 @@ ctorToType env (name, tvars, ctors) =
82 where
87 where
83 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)
88 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)
84 inst ctor = do
89 inst ctor = do
85− ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
90+ ((args, tipe), (dict,_)) <- State.runStateT (go ctor) (Map.empty, Map.empty)
86 return (length args, Map.elems dict, args, tipe)
91 return (length args, Map.elems dict, args, tipe)
87
92
88
93
89− go :: (String, [Src.Type]) -> State.StateT (Map.Map String Variable) IO ([Type], Type)
94+ go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)
90 go (ctor, args) = do
95 go (ctor, args) = do
91 types <- mapM (instantiator env) args
96 types <- mapM (instantiator env) args
92 returnType <- instantiator env (Src.Data name (map Src.Var tvars))
97 returnType <- instantiator env (Src.Data name (map Src.Var tvars))
@@ -96,46 +101,61 @@ ctorToType env (name, tvars, ctors) =
96get :: Environment -> (Environment -> Map.Map String a) -> String -> a
101get :: Environment -> (Environment -> Map.Map String a) -> String -> a
97get env subDict key = Map.findWithDefault err key (subDict env)
102get env subDict key = Map.findWithDefault err key (subDict env)
98 where
103 where
99− err = error $ "Could not find '" ++ key ++ "' in the type environment."
104+ err = error $ "Could not find type constructor '" ++ key ++ "' while checking types."
100
105
101
106
102freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
107freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
103freshDataScheme env name = get env constructor name
108freshDataScheme env name = get env constructor name
104
109
105instantiateType ::
110instantiateType ::
106− Environment -> Src.Type -> Map.Map String Variable -> IO ([Variable], Type)
111+ Environment -> Src.Type -> VarDict -> IO ([Variable], Type)
107instantiateType env sourceType dict =
112instantiateType env sourceType dict =
108− do (tipe, dict') <- State.runStateT (instantiator env sourceType) dict
113+ do (tipe, (dict',_)) <- State.runStateT (instantiator env sourceType) (dict, Map.empty)
109 return (Map.elems dict', tipe)
114 return (Map.elems dict', tipe)
110
115
111−instantiator :: Environment -> Src.Type -> State.StateT (Map.Map String Variable) IO Type
116+instantiator :: Environment -> Src.Type
117+ -> State.StateT (VarDict, TypeDict) IO Type
112instantiator env sourceType = go sourceType
118instantiator env sourceType = go sourceType
113 where
119 where
114− go :: Src.Type -> State.StateT (Map.Map String Variable) IO Type
120+ go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type
115 go sourceType =
121 go sourceType =
116 case sourceType of
122 case sourceType of
117 Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
123 Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
118
124
119 Src.Var x -> do
125 Src.Var x -> do
120− dict <- State.get
126+ (dict, aliases) <- State.get
121 case Map.lookup x dict of
127 case Map.lookup x dict of
122 Just var -> return (VarN var)
128 Just var -> return (VarN var)
123 Nothing ->
129 Nothing ->
130+ case Map.lookup x aliases of
131+ Just t -> return t
132+ Nothing ->
124− do var <- State.liftIO $ namedVar flex x
133+ do var <- State.liftIO $ namedVar flex x
125− State.put (Map.insert x var dict)
134+ State.put (Map.insert x var dict, aliases)
126− return (VarN var)
135+ return (VarN var)
127− where
136+ where
128− flex | "number" `isPrefixOf` x = Is Number
137+ flex | "number" `isPrefixOf` x = Is Number
129− | "comparable" `isPrefixOf` x = Is Comparable
138+ | "comparable" `isPrefixOf` x = Is Comparable
130− | "appendable" `isPrefixOf` x = Is Appendable
139+ | "appendable" `isPrefixOf` x = Is Appendable
131− | otherwise = Flexible
140+ | otherwise = Flexible
132
141
133 Src.Data "String" [] ->
142 Src.Data "String" [] ->
134 return (get env types "_List" <| get env types "Char")
143 return (get env types "_List" <| get env types "Char")
135
144
136 Src.Data name ts -> do
145 Src.Data name ts -> do
137 ts' <- mapM go ts
146 ts' <- mapM go ts
147+ case Map.lookup name (types env) of
138− return $ foldl (<|) (get env types name) ts'
148+ Just t -> return $ foldl (<|) t ts'
149+ Nothing ->
150+ case Map.lookup name (aliases env) of
151+ Nothing -> error $ "Could not find type constructor '" ++ name ++ "' while checking types."
152+ Just (tvars, t) ->
153+ let msg = "Type alias '" ++ name ++ "' expects " ++ show (length tvars) ++
154+ " but was given " ++ show (length ts')
155+ in if length ts' /= length tvars then error msg else
156+ do (dict, aliases) <- State.get
157+ State.put (dict, Map.union aliases . Map.fromList $ zip tvars ts')
158+ go t
139
159
140 Src.EmptyRecord -> return (TermN EmptyRecord1)
160 Src.EmptyRecord -> return (TermN EmptyRecord1)
141
161
compiler/Type/Inference.hs+1−1
@@ -29,7 +29,7 @@ infer interfaces' modul = unsafePerformIO $ do
29
29
30-- mapM print (concatMap iAdts (Map.elems interfaces))
30-- mapM print (concatMap iAdts (Map.elems interfaces))
31
31
32− env <- Env.initialEnvironment (datatypes modul ++ concatMap iAdts (Map.elems interfaces))
32+ env <- Env.initialEnvironment (datatypes modul ++ concatMap iAdts (Map.elems interfaces)) (aliases modul)
33 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
33 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
34 do (_, vars, args, result) <- Env.freshDataScheme env name
34 do (_, vars, args, result) <- Env.freshDataScheme env name
35 return (name, (vars, foldr (T.==>) result args))
35 return (name, (vars, foldr (T.==>) result args))