git.iko.soy/elk
on 0765fde help sign in
elk/src/Type/Inference.hs
116 lines 3.8 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 as Map
7import Data.Monoid ((<>))
8import Data.Text (Text)
10import qualified AST.Module as Module
11import qualified AST.Module.Name as ModuleName
12import qualified AST.Type as Type
13import qualified AST.Variable as Var
14import qualified Reporting.Annotation as A
15import qualified Reporting.Error.Type as Error
16import qualified Type.Constraint as T
17import qualified Type.Constrain.Expression as TcExpr
18import qualified Type.Environment as Env
19import qualified Type.Solve as Solve
20import qualified Type.State as TS
21import qualified Type.Type as T
23import System.IO.Unsafe
24 -- Maybe possible to switch over to ST instead of IO.
25 -- I don't think that'd be worthwhile though.
28infer
29 :: Module.Interfaces
30 -> Module.Canonical
31 -> Except [A.Located Error.Error] (Map.Map Text Type.Canonical)
32infer interfaces modul =
33 either throwError return $ unsafePerformIO $ runExceptT $
34 do (header, constraint) <-
35 liftIO (genConstraints interfaces modul)
37 state <- Solve.solve constraint
39 let header' = Map.delete "::" header
40 let types = Map.map A.drop (Map.difference (TS._savedEnv state) header')
42 liftIO (traverse T.toSrcType types)
45genConstraints
46 :: Module.Interfaces
47 -> Module.Canonical
48 -> IO (Map.Map Text T.Type, T.Constraint)
49genConstraints interfaces modul =
50 do let env = Env.initialize (canonicalizeUnions interfaces modul)
52 ctors <-
53 {-# SCC elm_compiler_mk_ctor_types #-}
54 forM (Env.ctorNames env) $ \name ->
55 do (_, vars, args, result) <- Env.freshDataScheme env name
56 return (name, (vars, foldr T.FunN result args))
58 importedVars <-
59 {-# SCC elm_compiler_mk_value_types #-}
60 mapM (canonicalizeValues env) (Map.toList interfaces)
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 (Module.info modul)) (T.VarN fvar)
73 return (header, environ constraint)
76canonicalizeValues
77 :: Env.Env
78 -> (ModuleName.Canonical, Module.Interface)
79 -> IO [(Text, ([T.Variable], T.Type))]
80canonicalizeValues env (moduleName, iface) =
81 forM (Map.toList (Module.iTypes iface)) $ \(name, tipe) ->
82 do (flexType, flexVars) <- Env.instantiateType T.Flex env tipe
83 return
84 ( ModuleName.canonicalToText moduleName <> "." <> name
85 , ( Map.elems flexVars
86 , flexType
87 )
88 )
91canonicalizeUnions :: Module.Interfaces -> Module.Canonical -> [Module.CanonicalUnion]
92canonicalizeUnions interfaces (Module.Module name info) =
93 localUnions ++ importedUnions
94 where
95 localUnions :: [Module.CanonicalUnion]
96 localUnions =
97 format (name, Module.unions info)
99 importedUnions :: [Module.CanonicalUnion]
100 importedUnions =
101 concatMap (format . second Module.iUnions) (Map.toList interfaces)
104format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]
105format (home, unions) =
106 map canonical (Map.toList unions)
107 where
108 canonical :: (Text, Module.UnionInfo Text) -> Module.CanonicalUnion
109 canonical (name, (tvars, ctors)) =
110 ( toVar name
111 , (tvars, map (first toVar) ctors)
112 )
114 toVar :: Text -> Var.Canonical
115 toVar name =
116 Var.fromModule home name