@@ -1,41 +1,133 @@
11module Type.Environment where
22
3+import Control.Applicative ((<$>), (<*>))
4+import Control.Monad
5+import qualified Control.Monad.State as State
6+import qualified Data.Traversable as Traverse
37import qualified Data.Map as Map
48import Data.Map ((!))
59import qualified Data.UnionFind.IO as UF
610
11+import qualified SourceSyntax.Type as Src
712import Type.Type
813
914data Environment = Environment {
10− constructor :: Map.Map String ([Variable], Type),
11− builtin :: Map.Map String Type,
15+ constructor :: Map.Map String (IO (Int, [Variable], Type)),
16+ types :: Map.Map String Type,
1217 value :: Map.Map String Type
1318}
1419
15−initialEnvironment :: IO Environment
16−initialEnvironment = do
17− let mkPair name = fmap ((,) name . VarN) (namedVar name)
18− list <- mkPair "[_]"
19− int <- mkPair "Int"
20− prims <- mapM mkPair ["Float","Char","Bool","Element"]
21− let builtins = list : int : prims
22−
23− cons <- do v <- flexibleVar
24− let vlist = TermN (App1 (snd list) (VarN v))
25− return ([v], VarN v ==> vlist ==> vlist)
26−
27− nil <- do v <- flexibleVar
28− return ([v], TermN (App1 (snd list) (VarN v)))
29−
30− let add = snd int ==> snd int ==> snd int
20+initialEnvironment :: [(String, [String], [(String,[Src.Type])])] -> IO Environment
21+initialEnvironment datatypes = do
22+ types <- makeTypes datatypes
3123
3224 return $ Environment {
33− constructor = Map.fromList [("::", cons), ("[]", nil)],
34− builtin = Map.fromList builtins,
35− value = Map.empty -- Map.fromList [("+", add)]
25+ constructor = makeConstructors types datatypes,
26+ types = types,
27+ value = Map.empty
3628 }
3729
30+makeTypes datatypes =
31+ Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
32+ where
33+ nameAndKind (name, tvars, _) = (name, length tvars)
34+
35+ makeCtor (name, kind) = do
36+ ctor <- VarN <$> namedVar name
37+ return (name, ctor)
38+
39+ tuple n = ("_Tuple" ++ show n, n)
40+
41+ kind n names = map (\name -> (name, n)) names
42+
43+ builtins :: [(String,Int)]
44+ builtins = concat [ map tuple [0..10]
45+ , kind 1 ["_List","Maybe","Signal"]
46+ , kind 0 ["Int","Float","Char","Bool","Element"]
47+ ]
48+
49+makeConstructors types datatypes =
50+ Map.union (Map.fromList builtins) (Map.unions $ map (instances dummyEnv) datatypes)
51+ where
52+ dummyEnv = Environment { constructor=Map.empty, types=types, value=Map.empty }
53+
54+ list t = (types ! "_List") <| t
55+ maybe t = (types ! "Maybe") <| t
56+
57+ inst :: Int -> Int -> ([Type] -> Type) -> IO (Int, [Variable], Type)
58+ inst kind numTVars tipe = do
59+ vars <- forM [1..numTVars] $ \_ -> flexibleVar
60+ return (kind, vars, tipe $ map VarN vars)
61+
62+ tupleCtor n =
63+ let name = "_Tuple" ++ show n
64+ in (name, inst n n $ \vs -> foldr (==>) (foldl (<|) (types ! name) vs) vs)
65+
66+ builtins :: [ (String, IO (Int, [Variable], Type)) ]
67+ builtins = [ ("Nothing", inst 0 1 $ \ [t] -> maybe t)
68+ , ("Just" , inst 1 1 $ \ [t] -> t ==> maybe t)
69+ , ("[]" , inst 0 1 $ \ [t] -> list t)
70+ , ("::" , inst 2 1 $ \ [t] -> t ==> list t ==> list t)
71+ ] ++ map tupleCtor [0..10]
72+
73+
74+
3875get :: Environment -> (Environment -> Map.Map String a) -> String -> a
3976get env subDict key = Map.findWithDefault err key (subDict env)
4077 where
41− err = error $ "Could not find '" ++ key ++ "' in the type environment."
78+ err = error $ "Could not find '" ++ key ++ "' in the type environment."
79+
80+
81+freshDataScheme :: Environment -> String -> IO (Int, [Variable], Type)
82+freshDataScheme env name = do
83+ putStr "fresh " >> putStrLn name
84+ get env constructor name
85+
86+
87+instances :: Environment
88+ -> (String, [String], [(String, [Src.Type])])
89+ -> Map.Map String (IO (Int, [Variable], Type))
90+instances env (name, tvars, ctors) = Map.fromList $ map go ctors
91+ where
92+ tipe = Src.Data name (map Src.Var tvars)
93+
94+ go (ctor, tipes) = (,) ctor $ do
95+ let funcType = foldr Src.Lambda tipe tipes
96+ (vars, ttype) <- instantiateTypeWithContext env funcType Map.empty
97+ return (length tipes, vars, ttype)
98+
99+instantiateType :: Environment -> Src.Type -> IO Type
100+instantiateType env sourceType =
101+ snd <$> instantiateTypeWithContext env sourceType Map.empty
102+
103+instantiateTypeWithContext :: Environment
104+ -> Src.Type
105+ -> Map.Map String Variable
106+ -> IO ([Variable], Type)
107+instantiateTypeWithContext env sourceType dict =
108+ do (tipe, dict') <- State.runStateT (go sourceType) dict
109+ return (Map.elems dict', tipe)
110+ where
111+ go :: Src.Type -> State.StateT (Map.Map String Variable) IO Type
112+ go sourceType =
113+ case sourceType of
114+ Src.Lambda t1 t2 -> TermN <$> (Fun1 <$> go t1 <*> go t2)
115+
116+ Src.Var x -> do
117+ dict <- State.get
118+ case Map.lookup x dict of
119+ Just var -> return (VarN var)
120+ Nothing -> do
121+ var <- State.liftIO $ namedVar x -- should this be Constant or Flexible?
122+ State.put (Map.insert x var dict)
123+ return (VarN var)
124+
125+ Src.Data name ts -> do
126+ State.liftIO $ putStr "instantiate " >> putStrLn name
127+ ts' <- mapM go ts
128+ return $ foldr (\t result -> TermN $ App1 t result) (get env types name) ts'
129+
130+ Src.EmptyRecord -> return (TermN EmptyRecord1)
131+
132+ Src.Record fields ext ->
133+ TermN <$> (Record1 <$> Traverse.traverse (mapM go) fields <*> go ext)