git.iko.soy/elk
on c19ccfe help sign in
elk/compiler/Type/Inference.hs
66 lines 2.6 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.Constrain.Declaration as TcDecl
9import qualified Type.Solve as Solve
11import SourceSyntax.Module
12import qualified SourceSyntax.Expression as Expr
13import SourceSyntax.PrettyPrint
14import Text.PrettyPrint
15import qualified Type.State as TS
16import Control.Monad.State
17import Control.Arrow (second)
18import Transform.SortDefinitions as Sort
20import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
21 -- the IO monad. Not sure if that'd be worthwhile.
24infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)
25infer interfaces' modul = unsafePerformIO $ do
26 let localImports = Map.fromList (imports modul)
27 interfaces = Map.intersectionWithKey canonicalize localImports interfaces'
29-- mapM print (concatMap iAdts (Map.elems interfaces))
31 env <- Env.initialEnvironment (datatypes modul ++ concatMap iAdts (Map.elems interfaces))
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 let locals = Map.intersectionWithKey combine localImports interfaces
37 combine name importMethod interface =
38 let tipes = iTypes interface in
39 case importMethod of
40 As alias -> Map.mapKeys (\v -> alias ++ "." ++ v) tipes
41 Hiding hidens -> foldr Map.delete tipes hidens
42 Importing visibles ->
43 Map.intersection tipes (Map.fromList [ (v,()) | v <- visibles ])
45-- mapM print (map Map.toList $ Map.elems locals)
46-- mapM print (imports modul)
48 importedVars <-
49 forM (concatMap Map.toList $ Map.elems locals) $ \(name,tipe) ->
50 (,) name `fmap` Env.instantiateTypeWithContext env tipe Map.empty
52 let allTypes = ctors ++ importedVars
53 vars = concatMap (fst . snd) allTypes
54 header = Map.map snd (Map.fromList allTypes)
55 environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
57 fvar <- T.var T.Flexible
58 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)
59 --print =<< T.extraPretty constraint
61 state <- execStateT (Solve.solve constraint) TS.initialState
62 let errors = TS.sErrors state
63 if null errors
64 then return $ Right (Map.difference (TS.sSavedEnv state) header)
65 else Left `fmap` sequence errors