@@ -8,8 +8,8 @@ import qualified Type.Environment as Env
88import qualified Type.Constrain.Expression as TcExpr
99import qualified Type.Solve as Solve
1010
11+import qualified AST.Annotation as A
1112import AST.Module as Module
12−import AST.Annotation (noneNoDocs)
1313import AST.Type (CanonicalType)
1414import qualified AST.Variable as Var
1515import Text.PrettyPrint
@@ -17,45 +17,50 @@ import qualified Type.State as TS
1717import qualified Type.ExtraChecks as Check
1818import Control.Arrow (first, second)
1919import Control.Monad.State (execStateT, forM)
20−import Control.Monad.Error (ErrorT, runErrorT, liftIO)
20+import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)
2121
2222import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
2323 -- the IO monad. I don't think that'd be worthwhile.
2424
2525
2626infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)
27−infer interfaces modul = unsafePerformIO $ do
28− let moduleBody = body modul
29−
30− env <- Env.initialEnvironment (canonicalizeAdts interfaces modul)
31− ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
32− do (_, vars, args, result) <- Env.freshDataScheme env name
33− return (name, (vars, foldr (T.==>) result args))
34−
35− attemptConstraint <- runErrorT $ do
36− importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
37−
38− let allTypes = concat (ctors : importedVars)
39− vars = concatMap (fst . snd) allTypes
40− header = Map.map snd (Map.fromList allTypes)
41− environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
42−
43− fvar <- liftIO $ T.variable T.Flexible
44− c <- TcExpr.constrain env (program moduleBody) (T.varN fvar)
45− return (header, environ c)
46−
47− case attemptConstraint of
48− Left err -> return $ Left err
49− Right (header, constraint) -> do
50− state <- execStateT (Solve.solve constraint) TS.initialState
51− case TS.sErrors state of
52− errors@(_:_) -> return (Left errors)
53− [] -> case Check.portTypes (program moduleBody) of
54− Left err -> return (Left err)
55− Right () -> Check.mainType types
56− where
57− header' = Map.delete "::" header
58− types = Map.difference (TS.sSavedEnv state) header'
27+infer interfaces modul = unsafePerformIO $ runErrorT $ do
28+ (header, constraint) <- genConstraints interfaces modul
29+
30+ state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
31+
32+ () <- case TS.sErrors state of
33+ errors@(_:_) -> throwError errors
34+ [] -> return ()
35+
36+ () <- Check.portTypes (program (body modul))
37+
38+ let header' = Map.delete "::" header
39+ types = Map.difference (TS.sSavedEnv state) header'
40+
41+ Check.mainType types
42+
43+
44+genConstraints :: Interfaces -> CanonicalModule
45+ -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)
46+genConstraints interfaces modul = do
47+ env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)
48+
49+ ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do
50+ (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name
51+ return (name, (vars, foldr (T.==>) result args))
52+
53+ importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
54+
55+ let allTypes = concat (ctors : importedVars)
56+ vars = concatMap (fst . snd) allTypes
57+ header = Map.map snd (Map.fromList allTypes)
58+ environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]
59+
60+ fvar <- liftIO $ T.variable T.Flexible
61+ c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)
62+ return (header, environ c)
63+
5964
6065canonicalizeValues :: Env.Environment -> (String, Interface)
6166 -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]