git.iko.soy/elk
on 98f3d69 help sign in
elk/src/Type/Inference.hs
108 lines 3.5 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 qualified 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.Canonical
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.Canonical
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 (Module.program (Module.info modul)) (T.VarN fvar)
67 return (header, environ constraint)
70canonicalizeValues
71 :: Env.Environment
72 -> (ModuleName.Canonical, Module.Interface)
73 -> IO [(String, ([T.Variable], T.Type))]
74canonicalizeValues env (moduleName, iface) =
75 forM (Map.toList (Module.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.Canonical -> [Module.CanonicalUnion]
84canonicalizeUnions interfaces (Module.Module name _ info) =
85 localUnions ++ importedUnions
86 where
87 localUnions :: [Module.CanonicalUnion]
88 localUnions =
89 format (name, Module.unions info)
91 importedUnions :: [Module.CanonicalUnion]
92 importedUnions =
93 concatMap (format . second Module.iUnions) (Map.toList interfaces)
96format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]
97format (home, adts) =
98 map canonical (Map.toList adts)
99 where
100 canonical :: (String, Module.UnionInfo String) -> Module.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