git.iko.soy/elk
on 0d6fcaa help sign in
elk/src/Type/Inference.hs
96 lines 3.4 kB history raw
1module Type.Inference where
3import Control.Arrow (first, second)
4import Control.Monad.State (execStateT, forM)
5import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)
6import qualified Data.Map as Map
7import Text.PrettyPrint
9import qualified AST.Annotation as A
10import AST.Module as Module
11import AST.Type (CanonicalType)
12import qualified AST.Variable as Var
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 :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)
26infer interfaces modul =
27 unsafePerformIO $ runErrorT $
28 do (header, constraint) <- genConstraints interfaces modul
30 state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
32 () <- case TS.sHint state of
33 hints@(_:_) -> throwError hints
34 [] -> return ()
36 let header' = Map.delete "::" header
37 types = Map.difference (TS.sSavedEnv state) header'
39 Check.effectTypes types
42genConstraints
43 :: Interfaces
44 -> CanonicalModule
45 -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)
46genConstraints interfaces modul =
47 do env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)
49 ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do
50 (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name
51 return (name, (vars, foldr (T.==>) result args))
53 importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
55 let allTypes = concat (ctors : importedVars)
56 vars = concatMap (fst . snd) allTypes
57 header = Map.map snd (Map.fromList allTypes)
58 environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]
60 fvar <- liftIO $ T.variable T.Flexible
61 c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)
62 return (header, environ c)
65canonicalizeValues
66 :: Env.Environment
67 -> (Module.Name, Interface)
68 -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]
69canonicalizeValues env (moduleName, iface) =
70 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
71 do tipe' <- Env.instantiateType env tipe Map.empty
72 return (Module.nameToString moduleName ++ "." ++ name, tipe')
75canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]
76canonicalizeAdts interfaces modul =
77 localAdts ++ importedAdts
78 where
79 localAdts :: [CanonicalAdt]
80 localAdts = format (Module.names modul, datatypes (body modul))
82 importedAdts :: [CanonicalAdt]
83 importedAdts = concatMap (format . second iAdts) (Map.toList interfaces)
85 format :: (Module.Name, Module.ADTs) -> [CanonicalAdt]
86 format (home, adts) =
87 map canonical (Map.toList adts)
88 where
89 canonical :: (String, AdtInfo String) -> CanonicalAdt
90 canonical (name, (tvars, ctors)) =
91 ( toVar name
92 , (tvars, map (first toVar) ctors)
93 )
95 toVar :: String -> Var.Canonical
96 toVar = Var.Canonical (Var.Module home)