git.iko.soy/elk
on 86148e8 help sign in
elk/src/Type/Inference.hs
128 lines 4.1 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Type.Inference where
4import Control.Arrow (first, second)
5import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)
6import qualified Data.Map.Strict as Map
7import qualified Data.Set as Set
8import Data.Monoid ((<>))
9import Data.Text (Text)
11import qualified AST.Module as Module
12import qualified AST.Module.Name as ModuleName
13import qualified AST.Type as Type
14import qualified AST.Variable as Var
15import qualified Reporting.Annotation as A
16import qualified Reporting.Error.Type as Error
17import qualified Type.Constraint as T
18import qualified Type.Constrain.Expression as TcExpr
19import qualified Type.Environment as Env
20import qualified Type.Solve as Solve
21import qualified Type.State as TS
22import qualified Type.Type as T
24import System.IO.Unsafe
25 -- Maybe possible to switch over to ST instead of IO.
26 -- I don't think that'd be worthwhile though.
29infer
30 :: Module.Interfaces
31 -> Module.Canonical
32 -> Except [A.Located Error.Error] (Map.Map Text Type.Canonical)
33infer interfaces modul =
34 either throwError return $ unsafePerformIO $ runExceptT $
35 do (header, constraint) <-
36 liftIO (genConstraints interfaces modul)
38 state <- Solve.solve constraint
40 let header' = Map.delete "::" header
41 let types = Map.map A.drop (Map.difference (TS._savedEnv state) header')
43 liftIO (traverse T.toSrcType types)
46genConstraints
47 :: Module.Interfaces
48 -> Module.Canonical
49 -> IO (Map.Map Text T.Type, T.Constraint)
50genConstraints allInterfaces modul@(Module.Module _ info) =
51 do let directDeps = toDirectDeps (Set.fromList (Module.imports info)) allInterfaces
52 let env = Env.initialize (canonicalizeUnions directDeps modul)
54 ctors <-
55 {-# SCC elm_compiler_mk_ctor_types #-}
56 forM (Env.ctorNames env) $ \name ->
57 do (_, vars, args, result) <- Env.freshDataScheme env name
58 return (name, (vars, foldr T.FunN result args))
60 importedVars <- mapM (canonicalizeValues env) directDeps
62 let allTypes = concat (ctors : importedVars)
63 let vars = concatMap (fst . snd) allTypes
64 let header = Map.map snd (Map.fromList allTypes)
65 let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]
67 fvar <- T.mkFlexVar
69 constraint <-
70 {-# SCC elm_compiler_constrain #-}
71 TcExpr.constrain env (Module.program info) (T.VarN fvar)
73 return (header, environ constraint)
76toDirectDeps :: Set.Set ModuleName.Raw -> Module.Interfaces -> [(ModuleName.Canonical, Module.Interface)]
77toDirectDeps imports interfaces =
78 let
79 isDirect (ModuleName.Canonical _ name, _) =
80 Set.member name imports
81 in
82 filter isDirect (Map.toList interfaces)
85canonicalizeValues
86 :: Env.Env
87 -> (ModuleName.Canonical, Module.Interface)
88 -> IO [(Text, ([T.Variable], T.Type))]
89canonicalizeValues env (moduleName, iface) =
90 forM (Map.toList (Module.iTypes iface)) $ \(name, tipe) ->
91 do (flexType, flexVars) <- Env.instantiateFlex env tipe
92 return
93 ( ModuleName.canonicalToText moduleName <> "." <> name
94 , ( Map.elems flexVars
95 , flexType
96 )
97 )
100canonicalizeUnions
101 :: [(ModuleName.Canonical, Module.Interface)]
102 -> Module.Canonical
103 -> [Module.CanonicalUnion]
104canonicalizeUnions directDeps (Module.Module name info) =
105 localUnions ++ importedUnions
106 where
107 localUnions :: [Module.CanonicalUnion]
108 localUnions =
109 format (name, Module.unions info)
111 importedUnions :: [Module.CanonicalUnion]
112 importedUnions =
113 concatMap (format . second Module.iUnions) directDeps
116format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]
117format (home, unions) =
118 map canonical (Map.toList unions)
119 where
120 canonical :: (Text, Module.UnionInfo Text) -> Module.CanonicalUnion
121 canonical (name, (tvars, ctors)) =
122 ( toVar name
123 , (tvars, map (first toVar) ctors)
124 )
126 toVar :: Text -> Var.Canonical
127 toVar name =
128 Var.fromModule home name