2013-07-15 22:38:31 +00:00
|
|
|
module Type.Inference where
|
|
|
|
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
|
|
import qualified Type.Type as T
|
|
|
|
import qualified Type.Environment as Env
|
|
|
|
import qualified Type.Constrain.Expression as TcExpr
|
|
|
|
import qualified Type.Constrain.Declaration as TcDecl
|
|
|
|
import qualified Type.Solve as Solve
|
|
|
|
|
|
|
|
import SourceSyntax.Module
|
2013-07-16 19:42:37 +00:00
|
|
|
import qualified SourceSyntax.Expression as Expr
|
2013-07-19 16:02:24 +00:00
|
|
|
import SourceSyntax.PrettyPrint
|
2013-07-15 22:38:31 +00:00
|
|
|
import Text.PrettyPrint
|
|
|
|
import qualified Type.State as TS
|
|
|
|
import Control.Monad.State
|
2013-07-17 17:29:27 +00:00
|
|
|
import Control.Arrow (second)
|
2013-07-15 22:38:31 +00:00
|
|
|
import Transform.SortDefinitions as Sort
|
|
|
|
|
2013-07-16 12:52:50 +00:00
|
|
|
import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
|
|
|
|
-- the IO monad. Not sure if that'd be worthwhile.
|
2013-07-15 22:38:31 +00:00
|
|
|
|
2013-07-17 17:29:27 +00:00
|
|
|
|
2013-07-21 20:50:48 +00:00
|
|
|
infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)
|
|
|
|
infer interfaces modul = unsafePerformIO $ do
|
2013-07-17 17:29:27 +00:00
|
|
|
env <- Env.initialEnvironment (datatypes modul)
|
2013-07-15 22:38:31 +00:00
|
|
|
var <- T.flexibleVar
|
2013-07-17 17:29:27 +00:00
|
|
|
ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
|
|
|
|
do (_, vars, tipe) <- Env.freshDataScheme env name
|
|
|
|
return (name, (vars, tipe))
|
|
|
|
|
2013-07-21 22:23:26 +00:00
|
|
|
let combine name importMethod interface =
|
|
|
|
let tipes = iTypes interface in
|
|
|
|
case importMethod of
|
|
|
|
As alias -> Map.mapKeys (\v -> alias ++ "." ++ v) tipes
|
|
|
|
Hiding hidens -> foldr Map.delete tipes hidens
|
|
|
|
Importing visibles ->
|
|
|
|
Map.intersection tipes (Map.fromList [ (v,()) | v <- visibles ])
|
|
|
|
|
|
|
|
locals = Map.intersectionWithKey combine (Map.fromList (imports modul)) interfaces
|
|
|
|
|
|
|
|
mapM print (imports modul)
|
|
|
|
|
2013-07-21 20:50:48 +00:00
|
|
|
importedVars <-
|
2013-07-21 22:23:26 +00:00
|
|
|
forM (concatMap Map.toList $ Map.elems locals) $ \(name,tipe) ->
|
2013-07-21 20:50:48 +00:00
|
|
|
(,) name `fmap` Env.instantiateTypeWithContext env tipe Map.empty
|
|
|
|
|
|
|
|
let allTypes = ctors ++ importedVars
|
|
|
|
vars = concatMap (fst . snd) allTypes
|
|
|
|
header = Map.map snd (Map.fromList allTypes)
|
2013-07-17 17:29:27 +00:00
|
|
|
environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
|
2013-07-19 16:02:24 +00:00
|
|
|
constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN var)
|
2013-07-21 20:50:48 +00:00
|
|
|
-- print =<< T.extraPretty constraint
|
2013-07-19 16:02:24 +00:00
|
|
|
state <- execStateT (Solve.solve constraint) TS.initialState
|
|
|
|
let errors = TS.sErrors state
|
2013-07-15 22:38:31 +00:00
|
|
|
if null errors
|
2013-07-19 16:02:24 +00:00
|
|
|
then return $ Right (Map.difference (TS.sSavedEnv state) header)
|
2013-07-15 22:38:31 +00:00
|
|
|
else Left `fmap` sequence errors
|
|
|
|
|