git.iko.soy/elk
on 1433e40 help sign in
elk/src/Type/Inference.hs
113 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.TypeConstraint)
48genConstraints interfaces modul =
49 do env <-
50 Env.initialize (canonicalizeUnions interfaces modul)
52 ctors <-
53 forM (Env.ctorNames env) $ \name ->
54 do (_, vars, args, result) <- Env.freshDataScheme env name
55 return (name, (vars, foldr (T.==>) result args))
57 importedVars <-
58 mapM (canonicalizeValues env) (Map.toList interfaces)
60 let allTypes = concat (ctors : importedVars)
61 let vars = concatMap (fst . snd) allTypes
62 let header = Map.map snd (Map.fromList allTypes)
63 let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]
65 fvar <- T.mkVar Nothing
67 constraint <-
68 TcExpr.constrain env (Module.program (Module.info modul)) (T.VarN fvar)
70 return (header, environ constraint)
73canonicalizeValues
74 :: Env.Env
75 -> (ModuleName.Canonical, Module.Interface)
76 -> IO [(Text, ([T.Variable], T.Type))]
77canonicalizeValues env (moduleName, iface) =
78 forM (Map.toList (Module.iTypes iface)) $ \(name, tipe) ->
79 do (flexType, flexVars) <- Env.instantiateType T.Flex env tipe
80 return
81 ( ModuleName.canonicalToText moduleName <> "." <> name
82 , ( Map.elems flexVars
83 , flexType
84 )
85 )
88canonicalizeUnions :: Module.Interfaces -> Module.Canonical -> [Module.CanonicalUnion]
89canonicalizeUnions interfaces (Module.Module name _ info) =
90 localUnions ++ importedUnions
91 where
92 localUnions :: [Module.CanonicalUnion]
93 localUnions =
94 format (name, Module.unions info)
96 importedUnions :: [Module.CanonicalUnion]
97 importedUnions =
98 concatMap (format . second Module.iUnions) (Map.toList interfaces)
101format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]
102format (home, unions) =
103 map canonical (Map.toList unions)
104 where
105 canonical :: (Text, Module.UnionInfo Text) -> Module.CanonicalUnion
106 canonical (name, (tvars, ctors)) =
107 ( toVar name
108 , (tvars, map (first toVar) ctors)
109 )
111 toVar :: Text -> Var.Canonical
112 toVar name =
113 Var.fromModule home name