@@ -1,147 +1,180 @@
11{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
23module Type.Environment
34 ( Env
5+ , Dict
46 , initialize
5− , getType, freshDataScheme, ctorNames
7+ , get, getType, freshDataScheme, ctorNames
68 , addValues
79 , instantiateType
810 )
911 where
1012
13+import Control.Monad (foldM)
1114import qualified Control.Monad.State as State
12−import Data.Map ((!))
15+import qualified Data.List as List
1316import qualified Data.Map as Map
1417import qualified Data.Set as Set
18+import qualified Data.Text as Text
19+import Data.Text (Text)
1520
1621import qualified AST.Type as T
17−import qualified AST.Variable as V
22+import qualified AST.Variable as Var
1823import qualified AST.Module as Module
1924import Type.Type
2025
2126
22−type TypeDict = Map.Map String Type
23−type VarDict = Map.Map String Variable
2427
28+-- ENVIRONMENT
2529
26−data Env = Env
27− { _constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))
28− , _types :: TypeDict
29− , _value :: TypeDict
30+
31+data Env =
32+ Env
33+ { _ctor :: Dict Instantiator
34+ , _types :: Dict Type
35+ , _value :: Dict Type
3036 }
3137
3238
39+type Instantiator =
40+ IO (Int, [Variable], [Type], Type)
41+
42+
43+type Dict a =
44+ Map.Map Text a
45+
46+
3347initialize :: [Module.CanonicalUnion] -> IO Env
34−initialize datatypes =
35− do types <- makeTypes datatypes
48+initialize unions =
49+ do types <- makeTypes unions
3650 let env =
3751 Env
38− { _constructor = Map.empty
52+ { _ctor = Map.empty
3953 , _value = Map.empty
4054 , _types = types
4155 }
42− return $ env { _constructor = makeConstructors env datatypes }
56+ return $ env { _ctor = makeCtors env unions }
4357
4458
45−makeTypes :: [Module.CanonicalUnion] -> IO TypeDict
46−makeTypes datatypes =
47− do unions <- mapM makeImported datatypes
48− bs <- mapM makeBuiltin builtins
49− return (Map.fromList (unions ++ bs))
50− where
51− makeImported :: (V.Canonical, Module.UnionInfo V.Canonical) -> IO (String, Type)
52− makeImported (name, _) =
53− do tvar <- mkAtom name
54− return (V.toString name, VarN tvar)
5559
56− makeBuiltin :: (String, Int) -> IO (String, Type)
57− makeBuiltin (name, _) =
58− do name' <- mkAtom (V.builtin name)
59− return (name, VarN name')
60+-- TYPES
6061
61− builtins :: [(String, Int)]
62− builtins =
63− concat
64− [ map tuple [0..9]
65− , kind 1 ["List"]
66− , kind 0 ["Int","Float","Char","String","Bool"]
67− ]
68− where
69− tuple n = ("_Tuple" ++ show n, n)
70− kind n names = map (\name -> (name, n)) names
71−
72−
73−makeConstructors
74− :: Env
75− -> [Module.CanonicalUnion]
76− -> Map.Map String (IO (Int, [Variable], [Type], Type))
77−makeConstructors env datatypes =
78− Map.fromList builtins
62+
63+makeTypes :: [Module.CanonicalUnion] -> IO (Dict Type)
64+makeTypes unions =
65+ do builtinDict <- Map.fromList <$> mapM makeBuiltin builtinTypes
66+ foldM addImported builtinDict unions
67+
68+
69+addImported :: Dict Type -> (Var.Canonical, unionInfo) -> IO (Dict Type)
70+addImported dict ( var, _ ) =
71+ do atom <- mkAtom var
72+ return (Map.insert (Var.toText var) (VarN atom) dict)
73+
74+
75+makeBuiltin :: (Text, Int) -> IO (Text, Type)
76+makeBuiltin (name, _) =
77+ do atom <- mkAtom (Var.builtin name)
78+ return (name, VarN atom)
79+
80+
81+builtinTypes :: [(Text, Int)]
82+builtinTypes =
83+ concat
84+ [ map tuple [0..9]
85+ , kind 1 ["List"]
86+ , kind 0 ["Int","Float","Char","String","Bool"]
87+ ]
7988 where
89+ tuple n = ( Text.pack ("_Tuple" ++ show n), n )
90+ kind n names = map (\name -> (name, n)) names
91+
92+
93+
94+-- CONSTRUCTORS
95+
96+
97+makeCtors :: Env -> [Module.CanonicalUnion] -> Dict Instantiator
98+makeCtors env unions =
99+ let
80100 list t =
81− (_types env ! "List") <| t
101+ getType env "List" <| t
82102
83− inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
103+ inst :: Int -> ([Type] -> ([Type], Type)) -> Instantiator
84104 inst numTVars tipe =
85105 do vars <- mapM (\_ -> mkVar Nothing) [1..numTVars]
86106 let (args, result) = tipe (map (VarN) vars)
87107 return (length args, vars, args, result)
88108
89109 tupleCtor n =
90− let name = "_Tuple" ++ show n
91− in (name, inst n $ \vs -> (vs, foldl (<|) (_types env ! name) vs))
110+ let
111+ name =
112+ Text.pack ("_Tuple" ++ show n)
113+ in
114+ (name, inst n $ \vs -> (vs, foldl (<|) (getType env name) vs))
92115
93− builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
116+ builtins :: Dict Instantiator
94117 builtins =
118+ Map.fromList $
95119 [ ("[]", inst 1 $ \ [t] -> ([], list t))
96120 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
97− ] ++ map tupleCtor [0..9]
98− ++ concatMap (ctorToType env) datatypes
121+ ]
122+ ++ map tupleCtor [0..9]
123+ in
124+ List.foldl' (makeCtorsHelp env) builtins unions
99125
100126
101−ctorToType
102− :: Env
103− -> (V.Canonical, Module.UnionInfo V.Canonical)
104− -> [(String, IO (Int, [Variable], [Type], Type))]
105−ctorToType env (name, (tvars, ctors)) =
106− zip (map (V.toString . fst) ctors) (map inst ctors)
107− where
108− inst :: (V.Canonical, [T.Canonical]) -> IO (Int, [Variable], [Type], Type)
109− inst ctor =
110− do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
111− return (length args, Map.elems dict, args, tipe)
127+type VarDict =
128+ Map.Map Text Variable
112129
113130
114− go :: (V.Canonical, [T.Canonical]) -> State.StateT VarDict IO ([Type], Type)
115− go (_, args) =
131+makeCtorsHelp :: Env -> Dict Instantiator -> Module.CanonicalUnion -> Dict Instantiator
132+makeCtorsHelp env constructorDict ( var, (rawTypeVars, ctors) ) =
133+ let
134+ inst :: Dict Instantiator -> (Var.Canonical, [T.Canonical]) -> Dict Instantiator
135+ inst ctorDict (name, rawArgs) =
136+ Map.insert
137+ (Var.toText name)
138+ ( do ((args, tipe), dict) <- State.runStateT (go rawArgs) Map.empty
139+ return ( length args, Map.elems dict, args, tipe )
140+ )
141+ ctorDict
142+
143+ tvars =
144+ map T.Var rawTypeVars
145+
146+ go :: [T.Canonical] -> State.StateT VarDict IO ([Type], Type)
147+ go args =
116148 do types <- mapM (instantiator Flex env) args
117− returnType <- instantiator Flex env (T.App (T.Type name) (map T.Var tvars))
149+ returnType <- instantiator Flex env (T.App (T.Type var) tvars)
118150 return (types, returnType)
151+ in
152+ List.foldl' inst constructorDict ctors
119153
120154
121155
122156-- ACCESS TYPES
123157
124158
125−get :: (Env -> Map.Map String a) -> Env -> String -> a
126−get subDict env key =
127− Map.findWithDefault (error msg) key (subDict env)
128− where
129− msg = "Could not find type constructor `" ++ key ++ "` while checking types."
159+{-# INLINE get #-}
160+get :: Dict a -> Text -> a
161+get dict var =
162+ dict Map.! var
130163
131164
132−getType :: Env -> String -> Type
133−getType =
134− get _types
165+getType :: Env -> Text -> Type
166+getType env var =
167+ get (_types env) var
135168
136169
137−freshDataScheme :: Env -> String -> IO (Int, [Variable], [Type], Type)
138−freshDataScheme =
139− get _constructor
170+freshDataScheme :: Env -> Text -> Instantiator
171+freshDataScheme env var =
172+ get (_ctor env) var
140173
141174
142−ctorNames :: Env -> [String]
175+ctorNames :: Env -> [Text]
143176ctorNames env =
144− Map.keys (_constructor env)
177+ Map.keys (_ctor env)
145178
146179
147180
@@ -167,7 +200,7 @@ instantiator flex env sourceType =
167200 instantiatorHelp flex env Set.empty sourceType
168201
169202
170−instantiatorHelp :: Flex -> Env -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type
203+instantiatorHelp :: Flex -> Env -> Set.Set Text -> T.Canonical -> State.StateT VarDict IO Type
171204instantiatorHelp flex env aliasVars sourceType =
172205 let
173206 go =
@@ -198,7 +231,7 @@ instantiatorHelp flex env aliasVars sourceType =
198231 return (VarN variable)
199232
200233 T.Aliased name args aliasType ->
201− do targs <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args
234+ do targs <- traverse (traverse go) args
202235 realType <-
203236 case aliasType of
204237 T.Filled tipe ->
@@ -210,18 +243,11 @@ instantiatorHelp flex env aliasVars sourceType =
210243 return (AliasN name targs realType)
211244
212245 T.Type name ->
213− case Map.lookup (V.toString name) (_types env) of
214− Just tipe ->
215− return tipe
216−
217− Nothing ->
218− error $
219− "Could not find type constructor `" ++
220− V.toString name ++ "` while checking types."
246+ return (getType env (Var.toText name))
221247
222248 T.App func args ->
223249 do tfunc <- go func
224− targs <- mapM go args
250+ targs <- traverse go args
225251 return $ foldl (<|) tfunc targs
226252
227253 T.Record fields ext ->