git.iko.soy/elk
on master help sign in
cosmetic: make "infer" more clear with ErrorT
6c3be9bEvan Czaplicki
compiler/Type/ExtraChecks.hs+13−8
compare with master
unifiedsplit
@@ -7,6 +7,7 @@ successfully. At that point we still need to do occurs checks and ensure that
7module Type.ExtraChecks (mainType, occurs, portTypes) where
7module Type.ExtraChecks (mainType, occurs, portTypes) where
8
8
9import Control.Applicative ((<$>),(<*>))
9import Control.Applicative ((<$>),(<*>))
10+import Control.Monad.Error
10import Control.Monad.State
11import Control.Monad.State
11import qualified Data.Map as Map
12import qualified Data.Map as Map
12import qualified Data.Traversable as Traverse
13import qualified Data.Traversable as Traverse
@@ -25,17 +26,19 @@ import qualified Type.State as TS
25throw :: [Doc] -> Either [Doc] a
26throw :: [Doc] -> Either [Doc] a
26throw err = Left [ P.vcat err ]
27throw err = Left [ P.vcat err ]
27
28
28−mainType :: TS.Env -> IO (Either [P.Doc] (Map.Map String ST.CanonicalType))
29+mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
29mainType environment =
30mainType environment =
30− mainCheck <$> Traverse.traverse TT.toSrcType environment
31+ do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
32+ mainCheck environment'
31 where
33 where
32− mainCheck :: Map.Map String ST.CanonicalType -> Either [P.Doc] (Map.Map String ST.CanonicalType)
34+ mainCheck :: (Monad m) => Map.Map String ST.CanonicalType
35+ -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
33 mainCheck env =
36 mainCheck env =
34 case Map.lookup "main" env of
37 case Map.lookup "main" env of
35− Nothing -> Right env
38+ Nothing -> return env
36 Just typeOfMain
39 Just typeOfMain
37− | tipe `elem` acceptable -> Right env
40+ | tipe `elem` acceptable -> return env
38− | otherwise -> throw err
41+ | otherwise -> throwError err
39 where
42 where
40 acceptable = [ "Graphics.Element.Element"
43 acceptable = [ "Graphics.Element.Element"
41 , "Signal.Signal Graphics.Element.Element" ]
44 , "Signal.Signal Graphics.Element.Element" ]
@@ -48,9 +51,11 @@ mainType environment =
48
51
49data Direction = In | Out
52data Direction = In | Out
50
53
51−portTypes :: Canonical.Expr -> Either [P.Doc] ()
54+portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
52portTypes expr =
55portTypes expr =
53− const () <$> Expr.checkPorts (check In) (check Out) expr
56+ case Expr.checkPorts (check In) (check Out) expr of
57+ Left err -> throwError err
58+ Right _ -> return ()
54 where
59 where
55 check = isValid True False False
60 check = isValid True False False
56 isValid isTopLevel seenFunc seenSignal direction name tipe =
61 isValid isTopLevel seenFunc seenSignal direction name tipe =
compiler/Type/Inference.hs+39−34
@@ -8,8 +8,8 @@ import qualified Type.Environment as Env
8import qualified Type.Constrain.Expression as TcExpr
8import qualified Type.Constrain.Expression as TcExpr
9import qualified Type.Solve as Solve
9import qualified Type.Solve as Solve
10
10
11+import qualified AST.Annotation as A
11import AST.Module as Module
12import AST.Module as Module
12−import AST.Annotation (noneNoDocs)
13import AST.Type (CanonicalType)
13import AST.Type (CanonicalType)
14import qualified AST.Variable as Var
14import qualified AST.Variable as Var
15import Text.PrettyPrint
15import Text.PrettyPrint
@@ -17,45 +17,50 @@ import qualified Type.State as TS
17import qualified Type.ExtraChecks as Check
17import qualified Type.ExtraChecks as Check
18import Control.Arrow (first, second)
18import Control.Arrow (first, second)
19import Control.Monad.State (execStateT, forM)
19import Control.Monad.State (execStateT, forM)
20−import Control.Monad.Error (ErrorT, runErrorT, liftIO)
20+import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)
21
21
22import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
22import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
23 -- the IO monad. I don't think that'd be worthwhile.
23 -- the IO monad. I don't think that'd be worthwhile.
24
24
25
25
26infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)
26infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)
27−infer interfaces modul = unsafePerformIO $ do
27+infer interfaces modul = unsafePerformIO $ runErrorT $ do
28− let moduleBody = body modul
28+ (header, constraint) <- genConstraints interfaces modul
29−
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
30− env <- Env.initialEnvironment (canonicalizeAdts interfaces modul)
47+ env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)
48+
31− ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
49+ ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do
32− do (_, vars, args, result) <- Env.freshDataScheme env name
50+ (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name
33− return (name, (vars, foldr (T.==>) result args))
51+ return (name, (vars, foldr (T.==>) result args))
34−
52+
35− attemptConstraint <- runErrorT $ do
36− importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
53+ importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
37−
54+
38− let allTypes = concat (ctors : importedVars)
55+ let allTypes = concat (ctors : importedVars)
39− vars = concatMap (fst . snd) allTypes
56+ vars = concatMap (fst . snd) allTypes
40− header = Map.map snd (Map.fromList allTypes)
57+ header = Map.map snd (Map.fromList allTypes)
41− environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
58+ environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]
42−
59+
43− fvar <- liftIO $ T.variable T.Flexible
60+ fvar <- liftIO $ T.variable T.Flexible
44− c <- TcExpr.constrain env (program moduleBody) (T.varN fvar)
61+ c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)
45− return (header, environ c)
62+ return (header, environ c)
46−
63+
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'
59
64
60canonicalizeValues :: Env.Environment -> (String, Interface)
65canonicalizeValues :: Env.Environment -> (String, Interface)
61 -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]
66 -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]