@@ -15,153 +15,186 @@ import qualified AST.Variable as V
1515import AST.Module (CanonicalAdt, AdtInfo)
1616import Type.Type
1717
18+
1819type TypeDict = Map.Map String Type
1920type VarDict = Map.Map String Variable
2021
22+
2123data Environment = Environment
2224 { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))
2325 , types :: TypeDict
2426 , value :: TypeDict
2527 }
2628
29+
2730initialEnvironment :: [CanonicalAdt] -> IO Environment
28−initialEnvironment datatypes = do
29− types <- makeTypes datatypes
30− let env = Environment
31+initialEnvironment datatypes =
32+ do types <- makeTypes datatypes
33+ let env =
34+ Environment
3135 { constructor = Map.empty
3236 , value = Map.empty
3337 , types = types
3438 }
35− return $ env { constructor = makeConstructors env datatypes }
39+ return $ env { constructor = makeConstructors env datatypes }
40+
3641
3742makeTypes :: [CanonicalAdt] -> IO TypeDict
3843makeTypes datatypes =
39− do adts <- mapM makeImported datatypes
40− bs <- mapM makeBuiltin builtins
41− return (Map.fromList (adts ++ bs))
44+ do adts <- mapM makeImported datatypes
45+ bs <- mapM makeBuiltin builtins
46+ return (Map.fromList (adts ++ bs))
4247 where
4348 makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
44− makeImported (var, _) = do
45− tvar <- namedVar Constant var
46− return (V.toString var, varN tvar)
49+ makeImported (var, _) =
50+ do tvar <- namedVar Constant var
51+ return (V.toString var, varN tvar)
4752
4853 makeBuiltin :: (String, Int) -> IO (String, Type)
49− makeBuiltin (name, _) = do
50− name' <- namedVar Constant (V.builtin name)
51− return (name, varN name')
54+ makeBuiltin (name, _) =
55+ do name' <- namedVar Constant (V.builtin name)
56+ return (name, varN name')
5257
5358 builtins :: [(String, Int)]
54− builtins = concat [ map tuple [0..9]
55− , kind 1 ["List"]
56− , kind 0 ["Int","Float","Char","String","Bool"]
57− ]
59+ builtins =
60+ concat
61+ [ map tuple [0..9]
62+ , kind 1 ["List"]
63+ , kind 0 ["Int","Float","Char","String","Bool"]
64+ ]
5865 where
5966 tuple n = ("_Tuple" ++ show n, n)
6067 kind n names = map (\name -> (name, n)) names
6168
6269
63−
64−makeConstructors :: Environment
65− -> [CanonicalAdt]
66− -> Map.Map String (IO (Int, [Variable], [Type], Type))
67−makeConstructors env datatypes = Map.fromList builtins
70+makeConstructors
71+ :: Environment
72+ -> [CanonicalAdt]
73+ -> Map.Map String (IO (Int, [Variable], [Type], Type))
74+makeConstructors env datatypes =
75+ Map.fromList builtins
6876 where
69− list t = (types env Map.! "List") <| t
77+ list t =
78+ (types env Map.! "List") <| t
7079
7180 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
72− inst numTVars tipe = do
73− vars <- forM [1..numTVars] $ \_ -> variable Flexible
74− let (args, result) = tipe (map (varN) vars)
75− return (length args, vars, args, result)
81+ inst numTVars tipe =
82+ do vars <- forM [1..numTVars] $ \_ -> variable Flexible
83+ let (args, result) = tipe (map (varN) vars)
84+ return (length args, vars, args, result)
7685
7786 tupleCtor n =
7887 let name = "_Tuple" ++ show n
7988 in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
80−
89+
8190 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
82− builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
83− , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
84− ] ++ map tupleCtor [0..9]
85− ++ concatMap (ctorToType env) datatypes
91+ builtins =
92+ [ ("[]", inst 1 $ \ [t] -> ([], list t))
93+ , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
94+ ] ++ map tupleCtor [0..9]
95+ ++ concatMap (ctorToType env) datatypes
8696
8797
88−ctorToType :: Environment
89− -> (V.Canonical, AdtInfo V.Canonical)
90− -> [(String, IO (Int, [Variable], [Type], Type))]
98+ctorToType
99+ :: Environment
100+ -> (V.Canonical, AdtInfo V.Canonical)
101+ -> [(String, IO (Int, [Variable], [Type], Type))]
91102ctorToType env (name, (tvars, ctors)) =
92103 zip (map (V.toString . fst) ctors) (map inst ctors)
93104 where
94105 inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
95− inst ctor = do
96− ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
97− return (length args, Map.elems dict, args, tipe)
98−
106+ inst ctor =
107+ do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
108+ return (length args, Map.elems dict, args, tipe)
109+
99110
100111 go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
101− go (_, args) = do
102− types <- mapM (instantiator env) args
103− returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
104− return (types, returnType)
112+ go (_, args) =
113+ do types <- mapM (instantiator env) args
114+ returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
115+ return (types, returnType)
105116
106117
107118get :: Environment -> (Environment -> Map.Map String a) -> String -> a
108−get env subDict key = Map.findWithDefault (error msg) key (subDict env)
119+get env subDict key =
120+ Map.findWithDefault (error msg) key (subDict env)
109121 where
110122 msg = "Could not find type constructor '" ++ key ++ "' while checking types."
111123
112124
113−freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
114−freshDataScheme env name = get env constructor name
125+freshDataScheme
126+ :: Environment
127+ -> String
128+ -> IO (Int, [Variable], [Type], Type)
129+freshDataScheme env name =
130+ get env constructor name
131+
115132
116−instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
133+instantiateType
134+ :: Environment
135+ -> T.CanonicalType
136+ -> VarDict
137+ -> ErrorT [PP.Doc] IO ([Variable], Type)
117138instantiateType env sourceType dict =
118− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
119− case result :: Either SomeException (Type, VarDict) of
120− Left someError -> throwError [ PP.text $ show someError ]
121− Right (tipe, dict') -> return (Map.elems dict', tipe)
139+ do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
140+ case result :: Either SomeException (Type, VarDict) of
141+ Left someError ->
142+ throwError [ PP.text $ show someError ]
122143
123−instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type
124−instantiator env sourceType = go sourceType
144+ Right (tipe, dict') ->
145+ return (Map.elems dict', tipe)
146+
147+
148+instantiator
149+ :: Environment
150+ -> T.CanonicalType
151+ -> State.StateT VarDict IO Type
152+instantiator env sourceType =
153+ go sourceType
125154 where
126155 go :: T.CanonicalType -> State.StateT VarDict IO Type
127156 go sourceType =
128157 case sourceType of
129− T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
130−
131− T.Var x -> do
132− dict <- State.get
133− case Map.lookup x dict of
134− Just v -> return (varN v)
135− Nothing ->
136− do v <- State.liftIO $ namedVar flex (V.local x)
137− State.put (Map.insert x v dict)
138− return (varN v)
139− where
140− flex | "number" `isPrefixOf` x = Is Number
141− | "comparable" `isPrefixOf` x = Is Comparable
142− | "appendable" `isPrefixOf` x = Is Appendable
143− | otherwise = Flexible
144−
145− T.Aliased name t -> do
146− t' <- go t
147− case t' of
148− VarN _ v -> return (VarN (Just name) v)
149− TermN _ term -> return (TermN (Just name) term)
158+ T.Lambda t1 t2 ->
159+ (==>) <$> go t1 <*> go t2
160+
161+ T.Var x ->
162+ do dict <- State.get
163+ case Map.lookup x dict of
164+ Just v -> return (varN v)
165+ Nothing ->
166+ do v <- State.liftIO $ namedVar flex (V.local x)
167+ State.put (Map.insert x v dict)
168+ return (varN v)
169+ where
170+ flex | "number" `isPrefixOf` x = Is Number
171+ | "comparable" `isPrefixOf` x = Is Comparable
172+ | "appendable" `isPrefixOf` x = Is Appendable
173+ | otherwise = Flexible
174+
175+ T.Aliased name t ->
176+ do t' <- go t
177+ case t' of
178+ VarN _ v -> return (VarN (Just name) v)
179+ TermN _ term -> return (TermN (Just name) term)
150180
151181 T.Type name ->
152182 case Map.lookup (V.toString name) (types env) of
153183 Just t -> return t
154− Nothing -> error $ "Could not find type constructor '" ++
155− V.toString name ++ "' while checking types."
156−
157− T.App t ts -> do
158− t' <- go t
159− ts' <- mapM go ts
160− return $ foldl (<|) t' ts'
161−
162− T.Record fields ext -> do
163− fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
164− ext' <- case ext of
184+ Nothing ->
185+ error $
186+ "Could not find type constructor '" ++
187+ V.toString name ++ "' while checking types."
188+
189+ T.App t ts ->
190+ do t' <- go t
191+ ts' <- mapM go ts
192+ return $ foldl (<|) t' ts'
193+
194+ T.Record fields ext ->
195+ do fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
196+ ext' <-
197+ case ext of
165198 Nothing -> return $ termN EmptyRecord1
166199 Just x -> go x
167− return $ termN (Record1 fields' ext')
200+ return $ termN (Record1 fields' ext')