git.iko.soy/elk
on c5b225d help sign in
elk/src/Type/Inference.hs
110 lines 3.6 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.Env
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 (flexType, flexVars) <- Env.instantiateType T.Flex env tipe
77 return
78 ( ModuleName.canonicalToString moduleName ++ "." ++ name
79 , ( Map.elems flexVars
80 , flexType
81 )
82 )
85canonicalizeUnions :: Module.Interfaces -> Module.Canonical -> [Module.CanonicalUnion]
86canonicalizeUnions interfaces (Module.Module name _ info) =
87 localUnions ++ importedUnions
88 where
89 localUnions :: [Module.CanonicalUnion]
90 localUnions =
91 format (name, Module.unions info)
93 importedUnions :: [Module.CanonicalUnion]
94 importedUnions =
95 concatMap (format . second Module.iUnions) (Map.toList interfaces)
98format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]
99format (home, adts) =
100 map canonical (Map.toList adts)
101 where
102 canonical :: (String, Module.UnionInfo String) -> Module.CanonicalUnion
103 canonical (name, (tvars, ctors)) =
104 ( toVar name
105 , (tvars, map (first toVar) ctors)
106 )
108 toVar :: String -> Var.Canonical
109 toVar name =
110 Var.fromModule home name