compiler/Type/Inference.hs · elk

on 40ea6df help sign in

elk/compiler/Type/Inference.hs

52 lines 2.1 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 as Module

12import qualified SourceSyntax.Expression as Expr

13import SourceSyntax.Location (Located, noneNoDocs)

14import SourceSyntax.PrettyPrint

15import SourceSyntax.Type (Type)

16import Text.PrettyPrint

17import qualified Type.State as TS

18import Type.ExtraChecks (extraChecks)

19import Control.Monad.State

20import Control.Arrow (second)

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 -> MetadataModule t v -> Either [Doc] (Map.Map String Type)

28infer interfaces modul = unsafePerformIO $ do

29 env <- Env.initialEnvironment

30 (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

31 (aliases modul ++ concatMap iAliases (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 importedVars <-

37 forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->

38 (,) name `fmap` Env.instantiateType env tipe Map.empty

40 let allTypes = ctors ++ importedVars

41 vars = concatMap (fst . snd) allTypes

42 header = Map.map snd (Map.fromList allTypes)

43 environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]

45 fvar <- T.var T.Flexible

46 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)

48 state <- execStateT (Solve.solve constraint) TS.initialState

49 let rules = Alias.rules interfaces modul

50 case TS.sErrors state of

51 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

52 [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)