git.iko.soy/elk
on 2297bbf help sign in
elk/src/Type/Inference.hs
109 lines 3.4 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.Module.Name as ModuleName
10import qualified AST.Type as Type
11import qualified AST.Variable as Var
12import qualified Reporting.Annotation as A
13import qualified Reporting.Error.Type as Error
14import qualified Type.Constrain.Expression as TcExpr
15import qualified Type.Environment as Env
16import qualified Type.Solve as Solve
17import qualified Type.State as TS
18import qualified Type.Type as T
20import System.IO.Unsafe
21 -- Maybe possible to switch over to ST instead of IO.
22 -- I don't think that'd be worthwhile though.
25infer
26 :: Module.Interfaces
27 -> Module.CanonicalModule
28 -> Except [A.Located Error.Error] (Map.Map String Type.Canonical)
29infer interfaces modul =
30 either throwError return $ unsafePerformIO $ runExceptT $
31 do (header, constraint) <-
32 liftIO (genConstraints interfaces modul)
34 state <- Solve.solve constraint
36 let header' = Map.delete "::" header
37 let types = Map.map A.drop (Map.difference (TS.sSavedEnv state) header')
39 liftIO (Traverse.traverse T.toSrcType types)
42genConstraints
43 :: Module.Interfaces
44 -> Module.CanonicalModule
45 -> IO (Env.TypeDict, T.TypeConstraint)
46genConstraints interfaces modul =
47 do env <-
48 Env.initialEnvironment (canonicalizeAdts interfaces modul)
50 ctors <-
51 forM (Map.keys (Env.constructor env)) $ \name ->
52 do (_, vars, args, result) <- Env.freshDataScheme env name
53 return (name, (vars, foldr (T.==>) result args))
55 importedVars <-
56 mapM (canonicalizeValues env) (Map.toList interfaces)
58 let allTypes = concat (ctors : importedVars)
59 let vars = concatMap (fst . snd) allTypes
60 let header = Map.map snd (Map.fromList allTypes)
61 let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]
63 fvar <- T.variable T.Flexible
65 constraint <-
66 TcExpr.constrain env (program (body modul)) (T.varN fvar)
68 return (header, environ constraint)
71canonicalizeValues
72 :: Env.Environment
73 -> (ModuleName.Canonical, Interface)
74 -> IO [(String, ([T.Variable], T.Type))]
75canonicalizeValues env (moduleName, iface) =
76 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
77 do tipe' <- Env.instantiateType env tipe Map.empty
78 return
79 ( ModuleName.canonicalToString moduleName ++ "." ++ name
80 , tipe'
81 )
84canonicalizeAdts :: Module.Interfaces -> Module.CanonicalModule -> [CanonicalAdt]
85canonicalizeAdts interfaces modul =
86 localAdts ++ importedAdts
87 where
88 localAdts :: [CanonicalAdt]
89 localAdts =
90 format (Module.name modul, datatypes (body modul))
92 importedAdts :: [CanonicalAdt]
93 importedAdts =
94 concatMap (format . second iAdts) (Map.toList interfaces)
97format :: (ModuleName.Canonical, Module.ADTs) -> [CanonicalAdt]
98format (home, adts) =
99 map canonical (Map.toList adts)
100 where
101 canonical :: (String, AdtInfo String) -> CanonicalAdt
102 canonical (name, (tvars, ctors)) =
103 ( toVar name
104 , (tvars, map (first toVar) ctors)
105 )
107 toVar :: String -> Var.Canonical
108 toVar name =
109 Var.fromModule home name