git.iko.soy/elk
on bdfaa69 help sign in
elk/src/Type/Inference.hs
99 lines 3.5 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Type.Inference where
4import qualified Data.Map as Map
6import qualified Type.Type as T
7import qualified Type.Environment as Env
8import qualified Type.Constrain.Expression as TcExpr
9import qualified Type.Solve as Solve
11import qualified AST.Annotation as A
12import AST.Module as Module
13import AST.Type (CanonicalType)
14import qualified AST.Variable as Var
15import Text.PrettyPrint
16import qualified Type.State as TS
17import qualified Type.ExtraChecks as Check
18import Control.Arrow (first, second)
19import Control.Monad.State (execStateT, forM)
20import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)
22import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
23 -- the IO monad. I don't think that'd be worthwhile.
26infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)
27infer interfaces modul =
28 unsafePerformIO $ runErrorT $
29 do (header, constraint) <- genConstraints interfaces modul
31 state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
33 () <- case TS.sErrors state of
34 errors@(_:_) -> throwError errors
35 [] -> return ()
37 () <- Check.portTypes (program (body modul))
39 let header' = Map.delete "::" header
40 types = Map.difference (TS.sSavedEnv state) header'
42 Check.mainType types
45genConstraints
46 :: Interfaces
47 -> CanonicalModule
48 -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)
49genConstraints interfaces modul =
50 do env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)
52 ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do
53 (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name
54 return (name, (vars, foldr (T.==>) result args))
56 importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
58 let allTypes = concat (ctors : importedVars)
59 vars = concatMap (fst . snd) allTypes
60 header = Map.map snd (Map.fromList allTypes)
61 environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]
63 fvar <- liftIO $ T.variable T.Flexible
64 c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)
65 return (header, environ c)
68canonicalizeValues
69 :: Env.Environment
70 -> (Module.Name, Interface)
71 -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]
72canonicalizeValues env (moduleName, iface) =
73 forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
74 do tipe' <- Env.instantiateType env tipe Map.empty
75 return (Module.nameToString moduleName ++ "." ++ name, tipe')
78canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]
79canonicalizeAdts interfaces modul =
80 localAdts ++ importedAdts
81 where
82 localAdts :: [CanonicalAdt]
83 localAdts = format (Module.names modul, datatypes (body modul))
85 importedAdts :: [CanonicalAdt]
86 importedAdts = concatMap (format . second iAdts) (Map.toList interfaces)
88 format :: (Module.Name, Module.ADTs) -> [CanonicalAdt]
89 format (home, adts) =
90 map canonical (Map.toList adts)
91 where
92 canonical :: (String, AdtInfo String) -> CanonicalAdt
93 canonical (name, (tvars, ctors)) =
94 ( toVar name
95 , (tvars, map (first toVar) ctors)
96 )
98 toVar :: String -> Var.Canonical
99 toVar = Var.Canonical (Var.Module home)