@@ -11,11 +11,13 @@ import qualified Type.Solve as Solve
1111import AST.Module as Module
1212import AST.Annotation (noneNoDocs)
1313import AST.Type (CanonicalType)
14+import qualified AST.Variable as Var
1415import Text.PrettyPrint
1516import qualified Type.State as TS
1617import qualified Type.ExtraChecks as Check
18+import Control.Arrow (first, second)
1719import Control.Monad.State (execStateT, forM)
18−import Control.Monad.Error (runErrorT, liftIO)
20+import Control.Monad.Error (ErrorT, runErrorT, liftIO)
1921import qualified Type.Alias as Alias
2022
2123import 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
2527infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)
2628infer interfaces modul = unsafePerformIO $ do
2729 let moduleBody = body modul
28− adts = Map.unions (datatypes moduleBody : map iAdts (Map.elems interfaces))
29− env <- Env.initialEnvironment adts
30+
31+ env <- Env.initialEnvironment (canonicalizeAdts interfaces modul)
3032 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
3133 do (_, vars, args, result) <- Env.freshDataScheme env name
3234 return (name, (vars, foldr (T.==>) result args))
3335
3436 attemptConstraint <- runErrorT $ do
35− importedVars <-
36− forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->
37− (,) name `fmap` Env.instantiateType env tipe Map.empty
37+ importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
3838
39− let allTypes = ctors ++ importedVars
39+ let allTypes = concat (ctors : importedVars)
4040 vars = concatMap (fst . snd) allTypes
4141 header = Map.map snd (Map.fromList allTypes)
4242 environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
@@ -53,5 +53,38 @@ infer interfaces modul = unsafePerformIO $ do
5353 case TS.sErrors state of
5454 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
5555 [] -> case Check.portTypes rules (program moduleBody) of
56− Right () -> Check.mainType rules (Map.difference (TS.sSavedEnv state) header)
5756 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'
61+
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')
68+
69+canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]
70+canonicalizeAdts interfaces modul =
71+ localAdts ++ importedAdts
72+ where
73+ localAdts :: [CanonicalAdt]
74+ localAdts = format (Module.getName modul, datatypes (body modul))
75+
76+ importedAdts :: [CanonicalAdt]
77+ importedAdts = concatMap (format . second iAdts) (Map.toList interfaces)
78+
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+ )
88+
89+ toVar :: String -> Var.Canonical
90+ toVar = Var.Canonical (Var.Module home)