git.iko.soy/elk
on ed48cd2 help sign in
elk/src/Type/Inference.hs
101 lines 3.3 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 AST.Module as Module
9import qualified AST.Type as Type
10import qualified AST.Variable as Var
11import qualified Reporting.Annotation as A
12import qualified Reporting.Error.Type as Error
13import qualified Type.Constrain.Expression as TcExpr
14import qualified Type.Environment as Env
15import qualified Type.Solve as Solve
16import qualified Type.State as TS
17import qualified Type.Type as T
19import System.IO.Unsafe
20 -- Maybe possible to switch over to ST instead of IO.
21 -- I don't think that'd be worthwhile though.
24infer
25 :: Interfaces
26 -> Module.CanonicalModule
27 -> Except [A.Located Error.Error] (Map.Map String Type.Canonical)
28infer interfaces modul =
29 either throwError return $ unsafePerformIO $ runExceptT $
30 do (header, constraint) <-
31 liftIO (genConstraints interfaces modul)
33 state <- Solve.solve constraint
35 let header' = Map.delete "::" header
36 let types = Map.map A.drop (Map.difference (TS.sSavedEnv state) header')
38 liftIO (Traverse.traverse T.toSrcType types)
41genConstraints
42 :: Interfaces
43 -> Module.CanonicalModule
44 -> IO (Env.TypeDict, T.TypeConstraint)
45genConstraints interfaces modul =
46 do env <-
47 Env.initialEnvironment (canonicalizeAdts interfaces modul)
49 ctors <-
50 forM (Map.keys (Env.constructor 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.variable T.Flexible
64 constraint <-
65 TcExpr.constrain env (program (body modul)) (T.varN fvar)
67 return (header, environ constraint)
70canonicalizeValues
71 :: Env.Environment
72 -> (Module.Name, Interface)
73 -> IO [(String, ([T.Variable], T.Type))]
74canonicalizeValues env (moduleName, iface) =
75 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
76 do tipe' <- Env.instantiateType env tipe Map.empty
77 return (Module.nameToString moduleName ++ "." ++ name, tipe')
80canonicalizeAdts :: Interfaces -> Module.CanonicalModule -> [CanonicalAdt]
81canonicalizeAdts interfaces modul =
82 localAdts ++ importedAdts
83 where
84 localAdts :: [CanonicalAdt]
85 localAdts = format (Module.names modul, datatypes (body modul))
87 importedAdts :: [CanonicalAdt]
88 importedAdts = concatMap (format . second iAdts) (Map.toList interfaces)
90 format :: (Module.Name, Module.ADTs) -> [CanonicalAdt]
91 format (home, adts) =
92 map canonical (Map.toList adts)
93 where
94 canonical :: (String, AdtInfo String) -> CanonicalAdt
95 canonical (name, (tvars, ctors)) =
96 ( toVar name
97 , (tvars, map (first toVar) ctors)
98 )
100 toVar :: String -> Var.Canonical
101 toVar = Var.Canonical (Var.Module home)