git.iko.soy/elk
on 52e43bb help sign in
elk/src/Type/Inference.hs
112 lines 3.6 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.Constrain.Expression as TcExpr
17import qualified Type.Environment as Env
18import qualified Type.Solve as Solve
19import qualified Type.State as TS
20import qualified Type.Type as T
22import System.IO.Unsafe
23 -- Maybe possible to switch over to ST instead of IO.
24 -- I don't think that'd be worthwhile though.
27infer
28 :: Module.Interfaces
29 -> Module.Canonical
30 -> Except [A.Located Error.Error] (Map.Map Text Type.Canonical)
31infer interfaces modul =
32 either throwError return $ unsafePerformIO $ runExceptT $
33 do (header, constraint) <-
34 liftIO (genConstraints interfaces modul)
36 state <- Solve.solve constraint
38 let header' = Map.delete "::" header
39 let types = Map.map A.drop (Map.difference (TS.sSavedEnv state) header')
41 liftIO (traverse T.toSrcType types)
44genConstraints
45 :: Module.Interfaces
46 -> Module.Canonical
47 -> IO (Map.Map Text T.Type, T.Constraint)
48genConstraints interfaces modul =
49 do let env = Env.initialize (canonicalizeUnions interfaces modul)
51 ctors <-
52 forM (Env.ctorNames env) $ \name ->
53 do (_, vars, args, result) <- Env.freshDataScheme env name
54 return (name, (vars, foldr (T.==>) result args))
56 importedVars <-
57 mapM (canonicalizeValues env) (Map.toList interfaces)
59 let allTypes = concat (ctors : importedVars)
60 let vars = concatMap (fst . snd) allTypes
61 let header = Map.map snd (Map.fromList allTypes)
62 let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]
64 fvar <- T.mkVar Nothing
66 constraint <-
67 TcExpr.constrain env (Module.program (Module.info modul)) (T.VarN fvar)
69 return (header, environ constraint)
72canonicalizeValues
73 :: Env.Env
74 -> (ModuleName.Canonical, Module.Interface)
75 -> IO [(Text, ([T.Variable], T.Type))]
76canonicalizeValues env (moduleName, iface) =
77 forM (Map.toList (Module.iTypes iface)) $ \(name, tipe) ->
78 do (flexType, flexVars) <- Env.instantiateType T.Flex env tipe
79 return
80 ( ModuleName.canonicalToText moduleName <> "." <> name
81 , ( Map.elems flexVars
82 , flexType
83 )
84 )
87canonicalizeUnions :: Module.Interfaces -> Module.Canonical -> [Module.CanonicalUnion]
88canonicalizeUnions interfaces (Module.Module name info) =
89 localUnions ++ importedUnions
90 where
91 localUnions :: [Module.CanonicalUnion]
92 localUnions =
93 format (name, Module.unions info)
95 importedUnions :: [Module.CanonicalUnion]
96 importedUnions =
97 concatMap (format . second Module.iUnions) (Map.toList interfaces)
100format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]
101format (home, unions) =
102 map canonical (Map.toList unions)
103 where
104 canonical :: (Text, Module.UnionInfo Text) -> Module.CanonicalUnion
105 canonical (name, (tvars, ctors)) =
106 ( toVar name
107 , (tvars, map (first toVar) ctors)
108 )
110 toVar :: Text -> Var.Canonical
111 toVar name =
112 Var.fromModule home name