@@ -12,21 +12,21 @@ import qualified Data.Map as Map
1212import Data.List (isPrefixOf)
1313import qualified Text.PrettyPrint as PP
1414
15−import AST.Module (ADTs)
1615import qualified AST.Type as T
1716import qualified AST.Variable as V
17+import AST.Module (CanonicalAdt, AdtInfo)
1818import Type.Type
1919
2020type TypeDict = Map.Map String Type
2121type VarDict = Map.Map String Variable
2222
23−data Environment = Environment {
24− constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
25− types :: TypeDict,
26− value :: TypeDict
27−}
23+data Environment = Environment
24+ { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))
25+ , types :: TypeDict
26+ , value :: TypeDict
27+ }
2828
29−initialEnvironment :: ADTs -> IO Environment
29+initialEnvironment :: [CanonicalAdt] -> IO Environment
3030initialEnvironment datatypes = do
3131 types <- makeTypes datatypes
3232 let env = Environment
@@ -36,27 +36,35 @@ initialEnvironment datatypes = do
3636 }
3737 return $ env { constructor = makeConstructors env datatypes }
3838
39−makeTypes :: ADTs -> IO TypeDict
39+makeTypes :: [CanonicalAdt] -> IO TypeDict
4040makeTypes 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)
41+ do adts <- mapM makeImported datatypes
42+ bs <- mapM makeBuiltin builtins
43+ return (Map.fromList (adts ++ bs))
4444 where
45− make name _ = VarN <$> namedVar Constant name
45+ makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
46+ makeImported (var, _) = do
47+ tvar <- namedVar Constant var
48+ return (V.toString var, VarN tvar)
4649
47− tuple n = ("_Tuple" ++ show n, n)
50+ makeBuiltin :: (String, Int) -> IO (String, Type)
51+ makeBuiltin (name, _) = do
52+ name' <- namedVar Constant (V.builtin name)
53+ return (name, VarN name')
4854
49− kind n names = map (\name -> (name, n)) names
50−
51− builtins :: [(String,Int)]
55+ builtins :: [(String, Int)]
5256 builtins = concat [ map tuple [0..9]
5357 , kind 1 ["_List"]
5458 , kind 0 ["Int","Float","Char","String","Bool"]
5559 ]
60+ where
61+ tuple n = ("_Tuple" ++ show n, n)
62+ kind n names = map (\name -> (name, n)) names
63+
5664
5765
5866makeConstructors :: Environment
59− -> ADTs
67+ -> [CanonicalAdt]
6068 -> Map.Map String (IO (Int, [Variable], [Type], Type))
6169makeConstructors env datatypes = Map.fromList builtins
6270 where
@@ -76,30 +84,32 @@ makeConstructors env datatypes = Map.fromList builtins
7684 builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
7785 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
7886 ] ++ map tupleCtor [0..9]
79− ++ concatMap (ctorToType env) (Map.toList datatypes)
87+ ++ concatMap (ctorToType env) datatypes
8088
8189
82−--ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
90+ctorToType :: Environment
91+ -> (V.Canonical, AdtInfo V.Canonical)
92+ -> [(String, IO (Int, [Variable], [Type], Type))]
8393ctorToType env (name, (tvars, ctors)) =
84− zip (map fst ctors) (map inst ctors)
94+ zip (map (V.toString . fst) ctors) (map inst ctors)
8595 where
86− inst :: (String, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
96+ inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
8797 inst ctor = do
8898 ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
8999 return (length args, Map.elems dict, args, tipe)
90100
91101
92− go :: (String, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
102+ go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
93103 go (_, args) = do
94104 types <- mapM (instantiator env) args
95− returnType <- instantiator env (T.Data (error "name") (map T.Var tvars))
105+ returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
96106 return (types, returnType)
97107
98108
99109get :: Environment -> (Environment -> Map.Map String a) -> String -> a
100110get env subDict key = Map.findWithDefault err key (subDict env)
101111 where
102− err = error $ "\nCould not find type constructor '" ++ key ++ "' while checking types."
112+ err = error $ "Could not find type constructor '" ++ key ++ "' while checking types."
103113
104114
105115freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
@@ -128,7 +138,7 @@ instantiator env sourceType = go sourceType
128138 case Map.lookup x dict of
129139 Just v -> return (VarN v)
130140 Nothing ->
131− do var <- State.liftIO $ namedVar flex x
141+ do var <- State.liftIO $ namedVar flex (V.local x)
132142 State.put (Map.insert x var dict)
133143 return (VarN var)
134144 where
@@ -137,12 +147,18 @@ instantiator env sourceType = go sourceType
137147 | "appendable" `isPrefixOf` x = Is Appendable
138148 | otherwise = Flexible
139149
140− T.Data name ts -> do
150+ T.Aliased _ t -> go t
151+
152+ T.Type var ->
153+ case Map.lookup (V.toString var) (types env) of
154+ Just t -> return t
155+ Nothing -> error $ "Could not find type constructor '" ++
156+ V.toString var ++ "' while checking types."
157+
158+ T.App t ts -> do
159+ t' <- go t
141160 ts' <- mapM go ts
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."
161+ return $ foldl (<|) t' ts'
146162
147163 T.Record fields ext -> do
148164 fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)