git.iko.soy/elk
on ab17521 help sign in
elk/compiler/Type/Environment.hs
152 lines 5.6 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Type.Environment where
4import Control.Applicative ((<$>), (<*>))
5import Control.Exception (try, SomeException)
6import Control.Monad
7import Control.Monad.Trans.Error (ErrorList(..))
8import Control.Monad.Error (ErrorT, throwError, liftIO)
9import qualified Control.Monad.State as State
10import qualified Data.Traversable as Traverse
11import qualified Data.Map as Map
12import Data.List (isPrefixOf)
13import qualified Text.PrettyPrint as PP
15import AST.Module (ADTs)
16import qualified AST.Type as T
17import qualified AST.Variable as V
18import Type.Type
20type TypeDict = Map.Map String Type
21type VarDict = Map.Map String Variable
23data Environment = Environment {
24 constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
25 types :: TypeDict,
26 value :: TypeDict
29initialEnvironment :: ADTs -> IO Environment
30initialEnvironment datatypes = do
31 types <- makeTypes datatypes
32 let env = Environment
33 { constructor = Map.empty
34 , value = Map.empty
35 , types = types
36 }
37 return $ env { constructor = makeConstructors env datatypes }
39makeTypes :: ADTs -> IO TypeDict
40makeTypes 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)
44 where
45 make name _ = VarN <$> namedVar Constant name
47 tuple n = ("_Tuple" ++ show n, n)
49 kind n names = map (\name -> (name, n)) names
51 builtins :: [(String,Int)]
52 builtins = concat [ map tuple [0..9]
53 , kind 1 ["_List"]
54 , kind 0 ["Int","Float","Char","String","Bool"]
55 ]
58makeConstructors :: Environment
59 -> ADTs
60 -> Map.Map String (IO (Int, [Variable], [Type], Type))
61makeConstructors env datatypes = Map.fromList builtins
62 where
63 list t = (types env Map.! "_List") <| t
65 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
66 inst numTVars tipe = do
67 vars <- forM [1..numTVars] $ \_ -> var Flexible
68 let (args, result) = tipe (map VarN vars)
69 return (length args, vars, args, result)
71 tupleCtor n =
72 let name = "_Tuple" ++ show n
73 in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))
75 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]
76 builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
77 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
78 ] ++ map tupleCtor [0..9]
79 ++ concatMap (ctorToType env) (Map.toList datatypes)
82--ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
83ctorToType env (name, (tvars, ctors)) =
84 zip (map fst ctors) (map inst ctors)
85 where
86 inst :: (String, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
87 inst ctor = do
88 ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
89 return (length args, Map.elems dict, args, tipe)
92 go :: (String, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
93 go (_, args) = do
94 types <- mapM (instantiator env) args
95 returnType <- instantiator env (T.Data (error "name") (map T.Var tvars))
96 return (types, returnType)
99get :: Environment -> (Environment -> Map.Map String a) -> String -> a
100get env subDict key = Map.findWithDefault err key (subDict env)
101 where
102 err = error $ "\nCould not find type constructor '" ++ key ++ "' while checking types."
105freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
106freshDataScheme env name = get env constructor name
108instance ErrorList PP.Doc where
109 listMsg str = [PP.text str]
111instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)
112instantiateType env sourceType dict =
113 do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)
114 case result :: Either SomeException (Type, VarDict) of
115 Left someError -> throwError [ PP.text $ show someError ]
116 Right (tipe, dict') -> return (Map.elems dict', tipe)
118instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type
119instantiator env sourceType = go sourceType
120 where
121 go :: T.CanonicalType -> State.StateT VarDict IO Type
122 go sourceType =
123 case sourceType of
124 T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2
126 T.Var x -> do
127 dict <- State.get
128 case Map.lookup x dict of
129 Just v -> return (VarN v)
130 Nothing ->
131 do var <- State.liftIO $ namedVar flex x
132 State.put (Map.insert x var dict)
133 return (VarN var)
134 where
135 flex | "number" `isPrefixOf` x = Is Number
136 | "comparable" `isPrefixOf` x = Is Comparable
137 | "appendable" `isPrefixOf` x = Is Appendable
138 | otherwise = Flexible
140 T.Data name ts -> do
141 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."
147 T.Record fields ext -> do
148 fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
149 ext' <- case ext of
150 Nothing -> return $ TermN EmptyRecord1
151 Just x -> go x
152 return $ TermN (Record1 fields' ext')