@@ -12,8 +12,9 @@ import qualified Data.Map as Map
1212import Data.List (isPrefixOf)
1313import qualified Text.PrettyPrint as PP
1414
15−import qualified AST.Type as Src
16−import AST.Module (ADT, Alias)
15+import AST.Module (ADTs)
16+import qualified AST.Type as T
17+import qualified AST.Variable as V
1718import Type.Type
1819
1920type TypeDict = Map.Map String Type
@@ -21,32 +22,27 @@ type VarDict = Map.Map String Variable
2122
2223data Environment = Environment {
2324 constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
24− aliases :: Map.Map String ([String], Src.Type),
2525 types :: TypeDict,
2626 value :: TypeDict
2727}
2828
29−initialEnvironment :: [ADT] -> [Alias] -> IO Environment
30−initialEnvironment datatypes aliases = do
29+initialEnvironment :: ADTs -> IO Environment
30+initialEnvironment datatypes = do
3131 types <- makeTypes datatypes
32− let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases
33− env = Environment {
34− constructor = Map.empty,
35− value = Map.empty,
36− types = types,
37− aliases = aliases' }
38−
32+ let env = Environment
33+ { constructor = Map.empty
34+ , value = Map.empty
35+ , types = types
36+ }
3937 return $ env { constructor = makeConstructors env datatypes }
4038
41−makeTypes :: [ADT] -> IO TypeDict
42−makeTypes datatypes =
43− Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
39+makeTypes :: ADTs -> IO TypeDict
40+makeTypes datatypes =
41+ do adts <- Traverse.sequence (Map.mapWithKey make datatypes)
42+ bs <- Map.fromList . zip (map fst builtins) <$> mapM (uncurry make) builtins
43+ return (Map.union adts bs)
4444 where
45− nameAndKind (name, tvars, _) = (name, length tvars)
46−
47− makeCtor (name, _) = do
48− ctor <- VarN <$> namedVar Constant name
49− return (name, ctor)
45+ make name _ = VarN <$> namedVar Constant name
5046
5147 tuple n = ("_Tuple" ++ show n, n)
5248
@@ -60,7 +56,7 @@ makeTypes datatypes =
6056
6157
6258makeConstructors :: Environment
63− -> [ADT]
59+ -> ADTs
6460 -> Map.Map String (IO (Int, [Variable], [Type], Type))
6561makeConstructors env datatypes = Map.fromList builtins
6662 where
@@ -80,23 +76,23 @@ makeConstructors env datatypes = Map.fromList builtins
8076 builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
8177 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
8278 ] ++ map tupleCtor [0..9]
83− ++ concatMap (ctorToType env) datatypes
79+ ++ concatMap (ctorToType env) (Map.toList datatypes)
8480
8581
86−ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
87−ctorToType env (name, tvars, ctors) =
82+--ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
83+ctorToType env (name, (tvars, ctors)) =
8884 zip (map fst ctors) (map inst ctors)
8985 where
90− inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)
86+ inst :: (String, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
9187 inst ctor = do
92− ((args, tipe), (dict,_)) <- State.runStateT (go ctor) (Map.empty, Map.empty)
88+ ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
9389 return (length args, Map.elems dict, args, tipe)
9490
9591
96− go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)
92+ go :: (String, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
9793 go (_, args) = do
9894 types <- mapM (instantiator env) args
99− returnType <- instantiator env (Src.Data name (map Src.Var tvars))
95+ returnType <- instantiator env (T.Data (error "name") (map T.Var tvars))
10096 return (types, returnType)
10197
10298
@@ -112,30 +108,28 @@ freshDataScheme env name = get env constructor name
112108instance ErrorList PP.Doc where
113109 listMsg str = [PP.text str]
114110
115−instantiateType :: Environment -> Src.Type -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
111+instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
116112instantiateType env sourceType dict =
117− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) (dict, Map.empty))
118− case result :: Either SomeException (Type, (VarDict, TypeDict)) of
113+ do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
114+ case result :: Either SomeException (Type, VarDict) of
119115 Left someError -> throwError [ PP.text $ show someError ]
120− Right (tipe, (dict',_)) -> return (Map.elems dict', tipe)
116+ Right (tipe, dict') -> return (Map.elems dict', tipe)
121117
122−instantiator :: Environment -> Src.Type
123− -> State.StateT (VarDict, TypeDict) IO Type
118+instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type
124119instantiator env sourceType = go sourceType
125120 where
126− go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type
121+ go :: T.CanonicalType -> State.StateT VarDict IO Type
127122 go sourceType =
128123 case sourceType of
129− Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
130−
131− Src.Var x -> do
132− (dict, aliases) <- State.get
133− case (Map.lookup x dict, Map.lookup x aliases) of
134− (_, Just t) -> return t
135− (Just v, _) -> return (VarN v)
136− _ ->
124+ T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
125+
126+ T.Var x -> do
127+ dict <- State.get
128+ case Map.lookup x dict of
129+ Just v -> return (VarN v)
130+ Nothing ->
137131 do var <- State.liftIO $ namedVar flex x
138− State.put (Map.insert x var dict, aliases)
132+ State.put (Map.insert x var dict)
139133 return (VarN var)
140134 where
141135 flex | "number" `isPrefixOf` x = Is Number
@@ -143,28 +137,16 @@ instantiator env sourceType = go sourceType
143137 | "appendable" `isPrefixOf` x = Is Appendable
144138 | otherwise = Flexible
145139
146− Src.Data name ts -> do
140+ T.Data name ts -> do
147141 ts' <- mapM go ts
148− case (Map.lookup name (types env), Map.lookup name (aliases env)) of
149− (Just t, _) -> return $ foldl (<|) t ts'
150− (_, Just (tvars, t)) ->
151− let tvarLen = length tvars
152− msg = "\nType alias '" ++ name ++ "' expects " ++ show tvarLen ++
153− " type argument" ++ (if tvarLen == 1 then "" else "s") ++
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− let aliases' = Map.union (Map.fromList $ zip tvars ts') aliases
158− State.put (dict, aliases')
159− t' <- go t
160− State.put (dict, aliases)
161− return t'
162− _ -> error $ "\nCould not find type constructor '" ++
163− name ++ "' while checking types."
164−
165− Src.Record fields ext -> do
166− fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)
142+ case Map.lookup (V.toString name) (types env) of
143+ Just t -> return $ foldl (<|) t ts'
144+ Nothing -> error $ "\nCould not find type constructor '" ++
145+ V.toString name ++ "' while checking types."
146+
147+ T.Record fields ext -> do
148+ fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
167149 ext' <- case ext of
168150 Nothing -> return $ TermN EmptyRecord1
169− Just x -> go (Src.Var x)
151+ Just x -> go x
170152 return $ TermN (Record1 fields' ext')