git.iko.soy/elk
on master help sign in
Improve indentation in Type.Environment
d608aa6Evan Czaplicki
src/Type/Environment.hs+119−86
compare with master
unifiedsplit
@@ -15,153 +15,186 @@ import qualified AST.Variable as V
15import AST.Module (CanonicalAdt, AdtInfo)
15import AST.Module (CanonicalAdt, AdtInfo)
16import Type.Type
16import Type.Type
17
17
18+
18type TypeDict = Map.Map String Type
19type TypeDict = Map.Map String Type
19type VarDict = Map.Map String Variable
20type VarDict = Map.Map String Variable
20
21
22+
21data Environment = Environment
23data Environment = Environment
22 { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))
24 { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))
23 , types :: TypeDict
25 , types :: TypeDict
24 , value :: TypeDict
26 , value :: TypeDict
25 }
27 }
26
28
29+
27initialEnvironment :: [CanonicalAdt] -> IO Environment
30initialEnvironment :: [CanonicalAdt] -> IO Environment
28−initialEnvironment datatypes = do
31+initialEnvironment datatypes =
29− types <- makeTypes datatypes
32+ do types <- makeTypes datatypes
33+ let env =
30− let env = Environment
34+ Environment
31 { constructor = Map.empty
35 { constructor = Map.empty
32 , value = Map.empty
36 , value = Map.empty
33 , types = types
37 , types = types
34 }
38 }
35− return $ env { constructor = makeConstructors env datatypes }
39+ return $ env { constructor = makeConstructors env datatypes }
40+
36
41
37makeTypes :: [CanonicalAdt] -> IO TypeDict
42makeTypes :: [CanonicalAdt] -> IO TypeDict
38makeTypes datatypes =
43makeTypes datatypes =
39− do adts <- mapM makeImported datatypes
44+ do adts <- mapM makeImported datatypes
40− bs <- mapM makeBuiltin builtins
45+ bs <- mapM makeBuiltin builtins
41− return (Map.fromList (adts ++ bs))
46+ return (Map.fromList (adts ++ bs))
42 where
47 where
43 makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
48 makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
44− makeImported (var, _) = do
49+ makeImported (var, _) =
45− tvar <- namedVar Constant var
50+ do tvar <- namedVar Constant var
46− return (V.toString var, varN tvar)
51+ return (V.toString var, varN tvar)
47
52
48 makeBuiltin :: (String, Int) -> IO (String, Type)
53 makeBuiltin :: (String, Int) -> IO (String, Type)
49− makeBuiltin (name, _) = do
54+ makeBuiltin (name, _) =
50− name' <- namedVar Constant (V.builtin name)
55+ do name' <- namedVar Constant (V.builtin name)
51− return (name, varN name')
56+ return (name, varN name')
52
57
53 builtins :: [(String, Int)]
58 builtins :: [(String, Int)]
59+ builtins =
60+ concat
54− builtins = concat [ map tuple [0..9]
61+ [ map tuple [0..9]
55− , kind 1 ["List"]
62+ , kind 1 ["List"]
56− , kind 0 ["Int","Float","Char","String","Bool"]
63+ , kind 0 ["Int","Float","Char","String","Bool"]
57− ]
64+ ]
58 where
65 where
59 tuple n = ("_Tuple" ++ show n, n)
66 tuple n = ("_Tuple" ++ show n, n)
60 kind n names = map (\name -> (name, n)) names
67 kind n names = map (\name -> (name, n)) names
61
68
62
69
63−
70+makeConstructors
64−makeConstructors :: Environment
71+ :: Environment
65− -> [CanonicalAdt]
72+ -> [CanonicalAdt]
66− -> Map.Map String (IO (Int, [Variable], [Type], Type))
73+ -> Map.Map String (IO (Int, [Variable], [Type], Type))
67−makeConstructors env datatypes = Map.fromList builtins
74+makeConstructors env datatypes =
75+ Map.fromList builtins
68 where
76 where
77+ list t =
69− list t = (types env Map.! "List") <| t
78+ (types env Map.! "List") <| t
70
79
71 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
80 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
72− inst numTVars tipe = do
81+ inst numTVars tipe =
73− vars <- forM [1..numTVars] $ \_ -> variable Flexible
82+ do vars <- forM [1..numTVars] $ \_ -> variable Flexible
74− let (args, result) = tipe (map (varN) vars)
83+ let (args, result) = tipe (map (varN) vars)
75− return (length args, vars, args, result)
84+ return (length args, vars, args, result)
76
85
77 tupleCtor n =
86 tupleCtor n =
78 let name = "_Tuple" ++ show n
87 let name = "_Tuple" ++ show n
79 in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
88 in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
80−
89+
81 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
90 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
91+ builtins =
82− builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
92+ [ ("[]", inst 1 $ \ [t] -> ([], list t))
83− , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
93+ , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
84− ] ++ map tupleCtor [0..9]
94+ ] ++ map tupleCtor [0..9]
85− ++ concatMap (ctorToType env) datatypes
95+ ++ concatMap (ctorToType env) datatypes
86
96
87
97
98+ctorToType
88−ctorToType :: Environment
99+ :: Environment
89− -> (V.Canonical, AdtInfo V.Canonical)
100+ -> (V.Canonical, AdtInfo V.Canonical)
90− -> [(String, IO (Int, [Variable], [Type], Type))]
101+ -> [(String, IO (Int, [Variable], [Type], Type))]
91ctorToType env (name, (tvars, ctors)) =
102ctorToType env (name, (tvars, ctors)) =
92 zip (map (V.toString . fst) ctors) (map inst ctors)
103 zip (map (V.toString . fst) ctors) (map inst ctors)
93 where
104 where
94 inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
105 inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
95− inst ctor = do
106+ inst ctor =
96− ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
107+ do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
97− return (length args, Map.elems dict, args, tipe)
108+ return (length args, Map.elems dict, args, tipe)
98−
109+
99
110
100 go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
111 go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
101− go (_, args) = do
112+ go (_, args) =
102− types <- mapM (instantiator env) args
113+ do types <- mapM (instantiator env) args
103− returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
114+ returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
104− return (types, returnType)
115+ return (types, returnType)
105
116
106
117
107get :: Environment -> (Environment -> Map.Map String a) -> String -> a
118get :: Environment -> (Environment -> Map.Map String a) -> String -> a
119+get env subDict key =
108−get env subDict key = Map.findWithDefault (error msg) key (subDict env)
120+ Map.findWithDefault (error msg) key (subDict env)
109 where
121 where
110 msg = "Could not find type constructor '" ++ key ++ "' while checking types."
122 msg = "Could not find type constructor '" ++ key ++ "' while checking types."
111
123
112
124
125+freshDataScheme
126+ :: Environment
127+ -> String
113−freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
128+ -> IO (Int, [Variable], [Type], Type)
114−freshDataScheme env name = get env constructor name
129+freshDataScheme env name =
130+ get env constructor name
131+
115
132
133+instantiateType
134+ :: Environment
135+ -> T.CanonicalType
136+ -> VarDict
116−instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
137+ -> ErrorT [PP.Doc] IO ([Variable], Type)
117instantiateType env sourceType dict =
138instantiateType env sourceType dict =
118− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
139+ do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
119− case result :: Either SomeException (Type, VarDict) of
140+ case result :: Either SomeException (Type, VarDict) of
141+ Left someError ->
120− Left someError -> throwError [ PP.text $ show someError ]
142+ throwError [ PP.text $ show someError ]
121− Right (tipe, dict') -> return (Map.elems dict', tipe)
122
143
144+ Right (tipe, dict') ->
145+ return (Map.elems dict', tipe)
146+
147+
148+instantiator
149+ :: Environment
150+ -> T.CanonicalType
123−instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type
151+ -> State.StateT VarDict IO Type
124−instantiator env sourceType = go sourceType
152+instantiator env sourceType =
153+ go sourceType
125 where
154 where
126 go :: T.CanonicalType -> State.StateT VarDict IO Type
155 go :: T.CanonicalType -> State.StateT VarDict IO Type
127 go sourceType =
156 go sourceType =
128 case sourceType of
157 case sourceType of
129− T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
158+ T.Lambda t1 t2 ->
130−
159+ (==>) <$> go t1 <*> go t2
160+
131− T.Var x -> do
161+ T.Var x ->
132− dict <- State.get
162+ do dict <- State.get
133− case Map.lookup x dict of
163+ case Map.lookup x dict of
134− Just v -> return (varN v)
164+ Just v -> return (varN v)
135− Nothing ->
165+ Nothing ->
136− do v <- State.liftIO $ namedVar flex (V.local x)
166+ do v <- State.liftIO $ namedVar flex (V.local x)
137− State.put (Map.insert x v dict)
167+ State.put (Map.insert x v dict)
138− return (varN v)
168+ return (varN v)
139− where
169+ where
140− flex | "number" `isPrefixOf` x = Is Number
170+ flex | "number" `isPrefixOf` x = Is Number
141− | "comparable" `isPrefixOf` x = Is Comparable
171+ | "comparable" `isPrefixOf` x = Is Comparable
142− | "appendable" `isPrefixOf` x = Is Appendable
172+ | "appendable" `isPrefixOf` x = Is Appendable
143− | otherwise = Flexible
173+ | otherwise = Flexible
144−
174+
145− T.Aliased name t -> do
175+ T.Aliased name t ->
146− t' <- go t
176+ do t' <- go t
147− case t' of
177+ case t' of
148− VarN _ v -> return (VarN (Just name) v)
178+ VarN _ v -> return (VarN (Just name) v)
149− TermN _ term -> return (TermN (Just name) term)
179+ TermN _ term -> return (TermN (Just name) term)
150
180
151 T.Type name ->
181 T.Type name ->
152 case Map.lookup (V.toString name) (types env) of
182 case Map.lookup (V.toString name) (types env) of
153 Just t -> return t
183 Just t -> return t
184+ Nothing ->
185+ error $
154− Nothing -> error $ "Could not find type constructor '" ++
186+ "Could not find type constructor '" ++
155− V.toString name ++ "' while checking types."
187+ V.toString name ++ "' while checking types."
156−
188+
157− T.App t ts -> do
189+ T.App t ts ->
158− t' <- go t
190+ do t' <- go t
159− ts' <- mapM go ts
191+ ts' <- mapM go ts
160− return $ foldl (<|) t' ts'
192+ return $ foldl (<|) t' ts'
161−
193+
162− T.Record fields ext -> do
194+ T.Record fields ext ->
163− fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
195+ do fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
196+ ext' <-
164− ext' <- case ext of
197+ case ext of
165 Nothing -> return $ termN EmptyRecord1
198 Nothing -> return $ termN EmptyRecord1
166 Just x -> go x
199 Just x -> go x
167− return $ termN (Record1 fields' ext')
200+ return $ termN (Record1 fields' ext')