git.iko.soy/elk
on 317f80e help sign in
elk/src/Type/Inference.hs
98 lines 3.4 kB history raw
1module Type.Inference where
3import qualified Data.Map as Map
5import qualified Type.Type as T
6import qualified Type.Environment as Env
7import qualified Type.Constrain.Expression as TcExpr
8import qualified Type.Solve as Solve
10import qualified AST.Annotation as A
11import AST.Module as Module
12import AST.Type (CanonicalType)
13import qualified AST.Variable as Var
14import Text.PrettyPrint
15import qualified Type.State as TS
16import qualified Type.ExtraChecks as Check
17import Control.Arrow (first, second)
18import Control.Monad.State (execStateT, forM)
19import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)
21import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
22 -- the IO monad. I don't think that'd be worthwhile.
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.sErrors state of
33 errors@(_:_) -> throwError errors
34 [] -> return ()
36 () <- Check.portTypes (program (body modul))
38 let header' = Map.delete "::" header
39 types = Map.difference (TS.sSavedEnv state) header'
41 Check.mainType types
44genConstraints
45 :: Interfaces
46 -> CanonicalModule
47 -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)
48genConstraints interfaces modul =
49 do env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)
51 ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do
52 (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name
53 return (name, (vars, foldr (T.==>) result args))
55 importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
57 let allTypes = concat (ctors : importedVars)
58 vars = concatMap (fst . snd) allTypes
59 header = Map.map snd (Map.fromList allTypes)
60 environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]
62 fvar <- liftIO $ T.variable T.Flexible
63 c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)
64 return (header, environ c)
67canonicalizeValues
68 :: Env.Environment
69 -> (Module.Name, Interface)
70 -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]
71canonicalizeValues env (moduleName, iface) =
72 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
73 do tipe' <- Env.instantiateType env tipe Map.empty
74 return (Module.nameToString moduleName ++ "." ++ name, tipe')
77canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]
78canonicalizeAdts interfaces modul =
79 localAdts ++ importedAdts
80 where
81 localAdts :: [CanonicalAdt]
82 localAdts = format (Module.names modul, datatypes (body modul))
84 importedAdts :: [CanonicalAdt]
85 importedAdts = concatMap (format . second iAdts) (Map.toList interfaces)
87 format :: (Module.Name, Module.ADTs) -> [CanonicalAdt]
88 format (home, adts) =
89 map canonical (Map.toList adts)
90 where
91 canonical :: (String, AdtInfo String) -> CanonicalAdt
92 canonical (name, (tvars, ctors)) =
93 ( toVar name
94 , (tvars, map (first toVar) ctors)
95 )
97 toVar :: String -> Var.Canonical
98 toVar = Var.Canonical (Var.Module home)