git.iko.soy/elk
on fe1e5d2 help sign in
elk/src/Type/Inference.hs
108 lines 3.4 kB history raw
1module Type.Inference where
3import Control.Arrow (first, second)
4import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)
5import qualified Data.Map as Map
6import qualified Data.Traversable as Traverse
8import AST.Module as Module
9import qualified AST.Module.Name as ModuleName
10import qualified AST.Type as Type
11import qualified AST.Variable as Var
12import qualified Reporting.Annotation as A
13import qualified Reporting.Error.Type as Error
14import qualified Type.Constrain.Expression as TcExpr
15import qualified Type.Environment as Env
16import qualified Type.Solve as Solve
17import qualified Type.State as TS
18import qualified Type.Type as T
20import System.IO.Unsafe
21 -- Maybe possible to switch over to ST instead of IO.
22 -- I don't think that'd be worthwhile though.
25infer
26 :: Module.Interfaces
27 -> Module.CanonicalModule
28 -> Except [A.Located Error.Error] (Map.Map String Type.Canonical)
29infer interfaces modul =
30 either throwError return $ unsafePerformIO $ runExceptT $
31 do (header, constraint) <-
32 liftIO (genConstraints interfaces modul)
34 state <- Solve.solve constraint
36 let header' = Map.delete "::" header
37 let types = Map.map A.drop (Map.difference (TS.sSavedEnv state) header')
39 liftIO (Traverse.traverse T.toSrcType types)
42genConstraints
43 :: Module.Interfaces
44 -> Module.CanonicalModule
45 -> IO (Map.Map String T.Type, T.TypeConstraint)
46genConstraints interfaces modul =
47 do env <- Env.initialize (canonicalizeUnions interfaces modul)
49 ctors <-
50 forM (Env.ctorNames env) $ \name ->
51 do (_, vars, args, result) <- Env.freshDataScheme env name
52 return (name, (vars, foldr (T.==>) result args))
54 importedVars <-
55 mapM (canonicalizeValues env) (Map.toList interfaces)
57 let allTypes = concat (ctors : importedVars)
58 let vars = concatMap (fst . snd) allTypes
59 let header = Map.map snd (Map.fromList allTypes)
60 let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]
62 fvar <- T.mkVar Nothing
64 constraint <-
65 TcExpr.constrain env (program (body modul)) (T.VarN fvar)
67 return (header, environ constraint)
70canonicalizeValues
71 :: Env.Environment
72 -> (ModuleName.Canonical, Interface)
73 -> IO [(String, ([T.Variable], T.Type))]
74canonicalizeValues env (moduleName, iface) =
75 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
76 do tipe' <- Env.instantiateType env tipe Map.empty
77 return
78 ( ModuleName.canonicalToString moduleName ++ "." ++ name
79 , tipe'
80 )
83canonicalizeUnions :: Module.Interfaces -> Module.CanonicalModule -> [CanonicalUnion]
84canonicalizeUnions interfaces modul =
85 localUnions ++ importedUnions
86 where
87 localUnions :: [CanonicalUnion]
88 localUnions =
89 format (Module.name modul, unions (body modul))
91 importedUnions :: [CanonicalUnion]
92 importedUnions =
93 concatMap (format . second iUnions) (Map.toList interfaces)
96format :: (ModuleName.Canonical, Module.Unions) -> [CanonicalUnion]
97format (home, adts) =
98 map canonical (Map.toList adts)
99 where
100 canonical :: (String, UnionInfo String) -> CanonicalUnion
101 canonical (name, (tvars, ctors)) =
102 ( toVar name
103 , (tvars, map (first toVar) ctors)
104 )
106 toVar :: String -> Var.Canonical
107 toVar name =
108 Var.fromModule home name