git.iko.soy/elk
on fb08d70 help sign in
elk/src/Type/Inference.hs
109 lines 3.5 kB history raw
1module Type.Inference where
3import Control.Arrow (first, second)
4import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError, withExceptT)
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.ExtraChecks as Check
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 :: Interfaces
27 -> 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.difference (TS.sSavedEnv state) header'
39 srcTypes <-
40 liftIO (Traverse.traverse T.toSrcType types)
42 withExceptT
43 (\tipe -> [A.A (error "TODO:infer") (Error.BadMain tipe)])
44 (Check.mainType srcTypes)
46 return srcTypes
49genConstraints
50 :: Interfaces
51 -> CanonicalModule
52 -> IO (Env.TypeDict, T.TypeConstraint)
53genConstraints interfaces modul =
54 do env <-
55 Env.initialEnvironment (canonicalizeAdts interfaces modul)
57 ctors <-
58 forM (Map.keys (Env.constructor env)) $ \name ->
59 do (_, vars, args, result) <- Env.freshDataScheme env name
60 return (name, (vars, foldr (T.==>) result args))
62 importedVars <-
63 mapM (canonicalizeValues env) (Map.toList interfaces)
65 let allTypes = concat (ctors : importedVars)
66 let vars = concatMap (fst . snd) allTypes
67 let header = Map.map snd (Map.fromList allTypes)
68 let environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
70 fvar <- T.variable T.Flexible
72 constraint <-
73 TcExpr.constrain env (program (body modul)) (T.varN fvar)
75 return (header, environ constraint)
78canonicalizeValues
79 :: Env.Environment
80 -> (Module.Name, Interface)
81 -> IO [(String, ([T.Variable], T.Type))]
82canonicalizeValues env (moduleName, iface) =
83 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
84 do tipe' <- Env.instantiateType env tipe Map.empty
85 return (Module.nameToString moduleName ++ "." ++ name, tipe')
88canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]
89canonicalizeAdts interfaces modul =
90 localAdts ++ importedAdts
91 where
92 localAdts :: [CanonicalAdt]
93 localAdts = format (Module.names modul, datatypes (body modul))
95 importedAdts :: [CanonicalAdt]
96 importedAdts = concatMap (format . second iAdts) (Map.toList interfaces)
98 format :: (Module.Name, Module.ADTs) -> [CanonicalAdt]
99 format (home, adts) =
100 map canonical (Map.toList adts)
101 where
102 canonical :: (String, AdtInfo String) -> CanonicalAdt
103 canonical (name, (tvars, ctors)) =
104 ( toVar name
105 , (tvars, map (first toVar) ctors)
106 )
108 toVar :: String -> Var.Canonical
109 toVar = Var.Canonical (Var.Module home)