git.iko.soy/elk
on 64becec help sign in
elk/compiler/Type/Inference.hs
90 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 AST.Module as Module
12import AST.Annotation (noneNoDocs)
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)
21import qualified Type.Alias as Alias
23import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
24 -- the IO monad. I don't think that'd be worthwhile.
27infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)
28infer interfaces modul = unsafePerformIO $ do
29 let moduleBody = body modul
31 env <- Env.initialEnvironment (canonicalizeAdts interfaces modul)
32 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
33 do (_, vars, args, result) <- Env.freshDataScheme env name
34 return (name, (vars, foldr (T.==>) result args))
36 attemptConstraint <- runErrorT $ do
37 importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
39 let allTypes = concat (ctors : importedVars)
40 vars = concatMap (fst . snd) allTypes
41 header = Map.map snd (Map.fromList allTypes)
42 environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
44 fvar <- liftIO $ T.var T.Flexible
45 c <- TcExpr.constrain env (program moduleBody) (T.VarN fvar)
46 return (header, environ c)
48 case attemptConstraint of
49 Left err -> return $ Left err
50 Right (header, constraint) -> do
51 state <- execStateT (Solve.solve constraint) TS.initialState
52 let rules = Alias.rules interfaces (aliases moduleBody) (imports modul)
53 case TS.sErrors state of
54 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
55 [] -> case Check.portTypes rules (program moduleBody) of
56 Left err -> return (Left err)
57 Right () -> Check.mainType rules types
58 where
59 header' = Map.delete "::" header
60 types = Map.difference (TS.sSavedEnv state) header'
62canonicalizeValues :: Env.Environment -> (String, Interface)
63 -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]
64canonicalizeValues env (moduleName, iface) =
65 forM (Map.toList (iTypes iface)) $ \(name,tipe) -> do
66 tipe' <- Env.instantiateType env tipe Map.empty
67 return (moduleName ++ "." ++ name, tipe')
69canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]
70canonicalizeAdts interfaces modul =
71 localAdts ++ importedAdts
72 where
73 localAdts :: [CanonicalAdt]
74 localAdts = format (Module.getName modul, datatypes (body modul))
76 importedAdts :: [CanonicalAdt]
77 importedAdts = concatMap (format . second iAdts) (Map.toList interfaces)
79 format :: (String, Module.ADTs) -> [CanonicalAdt]
80 format (home, adts) =
81 map canonical (Map.toList adts)
82 where
83 canonical :: (String, AdtInfo String) -> CanonicalAdt
84 canonical (name, (tvars, ctors)) =
85 ( toVar name
86 , (tvars, map (first toVar) ctors)
87 )
89 toVar :: String -> Var.Canonical
90 toVar = Var.Canonical (Var.Module home)