@@ -11,11 +11,13 @@ import qualified Type.Solve as Solve
11import AST.Module as Module
11import AST.Module as Module
12import AST.Annotation (noneNoDocs)
12import AST.Annotation (noneNoDocs)
13import AST.Type (CanonicalType)
13import AST.Type (CanonicalType)
14+import qualified AST.Variable as Var
14import Text.PrettyPrint
15import Text.PrettyPrint
15import qualified Type.State as TS
16import qualified Type.State as TS
16import qualified Type.ExtraChecks as Check
17import qualified Type.ExtraChecks as Check
18+import Control.Arrow (first, second)
17import Control.Monad.State (execStateT, forM)
19import Control.Monad.State (execStateT, forM)
18−import Control.Monad.Error (runErrorT, liftIO)
20+import Control.Monad.Error (ErrorT, runErrorT, liftIO)
19import qualified Type.Alias as Alias
21import qualified Type.Alias as Alias
21import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
23import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
@@ -25,18 +27,16 @@ import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
25infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)
27infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)
26infer interfaces modul = unsafePerformIO $ do
28infer interfaces modul = unsafePerformIO $ do
27 let moduleBody = body modul
29 let moduleBody = body modul
28− adts = Map.unions (datatypes moduleBody : map iAdts (Map.elems interfaces))
30+
29− env <- Env.initialEnvironment adts
31+ env <- Env.initialEnvironment (canonicalizeAdts interfaces modul)
30 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
32 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
31 do (_, vars, args, result) <- Env.freshDataScheme env name
33 do (_, vars, args, result) <- Env.freshDataScheme env name
32 return (name, (vars, foldr (T.==>) result args))
34 return (name, (vars, foldr (T.==>) result args))
34 attemptConstraint <- runErrorT $ do
36 attemptConstraint <- runErrorT $ do
35− importedVars <-
37+ importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
36− forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->
37− (,) name `fmap` Env.instantiateType env tipe Map.empty
39− let allTypes = ctors ++ importedVars
39+ let allTypes = concat (ctors : importedVars)
40 vars = concatMap (fst . snd) allTypes
40 vars = concatMap (fst . snd) allTypes
41 header = Map.map snd (Map.fromList allTypes)
41 header = Map.map snd (Map.fromList allTypes)
42 environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
42 environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
@@ -53,5 +53,38 @@ infer interfaces modul = unsafePerformIO $ do
53 case TS.sErrors state of
53 case TS.sErrors state of
54 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
54 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
55 [] -> case Check.portTypes rules (program moduleBody) of
55 [] -> case Check.portTypes rules (program moduleBody) of
56− Right () -> Check.mainType rules (Map.difference (TS.sSavedEnv state) header)
57 Left err -> return (Left err)
56 Left err -> return (Left err)
57+ Right () -> Check.mainType rules types
59+ header' = Map.delete "::" header
60+ types = Map.difference (TS.sSavedEnv state) header'
62+canonicalizeValues :: Env.Environment -> (String, Interface)
63+ -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]
64+canonicalizeValues 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')
69+canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]
70+canonicalizeAdts interfaces modul =
71+ localAdts ++ importedAdts
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)
83+ canonical :: (String, AdtInfo String) -> CanonicalAdt
84+ canonical (name, (tvars, ctors)) =
86+ , (tvars, map (first toVar) ctors)
89+ toVar :: String -> Var.Canonical
90+ toVar = Var.Canonical (Var.Module home)