@@ -13,23 +13,29 @@ import qualified SourceSyntax.Type as Src
1313import SourceSyntax.Module (ADT)
1414import Type.Type
1515
16+type TypeDict = Map.Map String Type
17+type VarDict = Map.Map String Variable
18+
1619data Environment = Environment {
1720 constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
18− types :: Map.Map String Type,
19− value :: Map.Map String Type
21+ aliases :: Map.Map String ([String], Src.Type),
22+ types :: TypeDict,
23+ value :: TypeDict
2024}
2125
22−initialEnvironment :: [ADT] -> IO Environment
23−initialEnvironment datatypes = do
26+initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment
27+initialEnvironment datatypes aliases = do
2428 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' }
2535
26− return $ Environment {
27− constructor = makeConstructors types datatypes,
28− types = types,
29− value = Map.empty
30− }
36+ return $ env { constructor = makeConstructors env datatypes }
3137
32−makeTypes :: [ADT] -> IO (Map.Map String Type)
38+makeTypes :: [ADT] -> IO TypeDict
3339makeTypes datatypes =
3440 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
3541 where
@@ -51,12 +57,12 @@ makeTypes datatypes =
5157 ]
5258
5359
54−makeConstructors :: Map.Map String Type
60+makeConstructors :: Environment
5561 -> [ADT]
5662 -> Map.Map String (IO (Int, [Variable], [Type], Type))
57−makeConstructors types datatypes = Map.fromList builtins
63+makeConstructors env datatypes = Map.fromList builtins
5864 where
59− list t = (types ! "_List") <| t
65+ list t = (types env ! "_List") <| t
6066
6167 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
6268 inst numTVars tipe = do
@@ -66,15 +72,14 @@ makeConstructors types datatypes = Map.fromList builtins
6672
6773 tupleCtor n =
6874 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))
7076
7177 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
7278 builtins = [ ("[]" , inst 1 $ \ [t] -> ([], list t))
7379 , ("::" , inst 1 $ \ [t] -> ([t, list t], list t))
7480 ] ++ map tupleCtor [0..9]
75− ++ concatMap (ctorToType tempEnv) datatypes
81+ ++ concatMap (ctorToType env) datatypes
7682
77− tempEnv = Environment { types = types, constructor = Map.empty, value = Map.empty }
7883
7984ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
8085ctorToType env (name, tvars, ctors) =
@@ -82,11 +87,11 @@ ctorToType env (name, tvars, ctors) =
8287 where
8388 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)
8489 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)
8691 return (length args, Map.elems dict, args, tipe)
8792
8893
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)
9095 go (ctor, args) = do
9196 types <- mapM (instantiator env) args
9297 returnType <- instantiator env (Src.Data name (map Src.Var tvars))
@@ -96,46 +101,61 @@ ctorToType env (name, tvars, ctors) =
96101get :: Environment -> (Environment -> Map.Map String a) -> String -> a
97102get env subDict key = Map.findWithDefault err key (subDict env)
98103 where
99− err = error $ "Could not find '" ++ key ++ "' in the type environment."
104+ err = error $ "Could not find type constructor '" ++ key ++ "' while checking types."
100105
101106
102107freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
103108freshDataScheme env name = get env constructor name
104109
105110instantiateType ::
106− Environment -> Src.Type -> Map.Map String Variable -> IO ([Variable], Type)
111+ Environment -> Src.Type -> VarDict -> IO ([Variable], Type)
107112instantiateType 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)
109114 return (Map.elems dict', tipe)
110115
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
112118instantiator env sourceType = go sourceType
113119 where
114− go :: Src.Type -> State.StateT (Map.Map String Variable) IO Type
120+ go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type
115121 go sourceType =
116122 case sourceType of
117123 Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
118124
119125 Src.Var x -> do
120− dict <- State.get
126+ (dict, aliases) <- State.get
121127 case Map.lookup x dict of
122128 Just var -> return (VarN var)
123129 Nothing ->
124− do var <- State.liftIO $ namedVar flex x
125− State.put (Map.insert x var dict)
126− return (VarN var)
127− where
128− flex | "number" `isPrefixOf` x = Is Number
129− | "comparable" `isPrefixOf` x = Is Comparable
130− | "appendable" `isPrefixOf` x = Is Appendable
131− | otherwise = Flexible
130+ case Map.lookup x aliases of
131+ Just t -> return t
132+ Nothing ->
133+ do var <- State.liftIO $ namedVar flex x
134+ State.put (Map.insert x var dict, aliases)
135+ return (VarN var)
136+ where
137+ flex | "number" `isPrefixOf` x = Is Number
138+ | "comparable" `isPrefixOf` x = Is Comparable
139+ | "appendable" `isPrefixOf` x = Is Appendable
140+ | otherwise = Flexible
132141
133142 Src.Data "String" [] ->
134143 return (get env types "_List" <| get env types "Char")
135144
136145 Src.Data name ts -> do
137146 ts' <- mapM go ts
138− return $ foldl (<|) (get env types name) ts'
147+ case Map.lookup name (types env) of
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
139159
140160 Src.EmptyRecord -> return (TermN EmptyRecord1)
141161