@@ -1,11 +1,12 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2−module Type.ExtraChecks (extraChecks, occursCheck) where
2+module Type.ExtraChecks (mainType, occurs, portTypes) where
3-- This module contains checks to be run *after* type inference has
3-- This module contains checks to be run *after* type inference has
4-- completed successfully. At that point we still need to do occurs
4-- completed successfully. At that point we still need to do occurs
5-- checks and ensure that `main` has an acceptable type.
5-- checks and ensure that `main` has an acceptable type.
7import Control.Applicative ((<$>),(<*>))
7import Control.Applicative ((<$>),(<*>))
8import Control.Monad.State
8import Control.Monad.State
9+import qualified Data.List as List
9import qualified Data.Map as Map
10import qualified Data.Map as Map
10import qualified Data.UnionFind.IO as UF
11import qualified Data.UnionFind.IO as UF
11import Type.Type ( Variable, structure, Term1(..), toSrcType )
12import Type.Type ( Variable, structure, Term1(..), toSrcType )
@@ -13,31 +14,103 @@ import qualified Type.State as TS
13import qualified Type.Alias as Alias
14import qualified Type.Alias as Alias
14import Text.PrettyPrint as P
15import Text.PrettyPrint as P
15import SourceSyntax.PrettyPrint (pretty)
16import SourceSyntax.PrettyPrint (pretty)
16−import SourceSyntax.Type (Type)
17+import qualified SourceSyntax.Type as T
18+import qualified SourceSyntax.Expression as E
17−import qualified SourceSyntax.Location as Location
19+import qualified SourceSyntax.Location as L
20+import qualified Transform.Expression as Expr
18import qualified Data.Traversable as Traverse
21import qualified Data.Traversable as Traverse
22+import System.IO.Unsafe
20−extraChecks :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String Type))
24+throw err = Left [ P.vcat err ]
21−extraChecks rules env =
22− mainCheck rules <$> Traverse.traverse toSrcType env
26+mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))
27+mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
24−mainCheck :: Alias.Rules -> Map.Map String Type -> Either [P.Doc] (Map.Map String Type)
29+ mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)
25−mainCheck rules env =
30+ mainCheck rules env =
26− case Map.lookup "main" env of
31+ case Map.lookup "main" env of
27− Nothing -> Right env
32+ Nothing -> Right env
28− Just mainType
33+ Just mainType
29− | tipe `elem` acceptable -> Right env
34+ | tipe `elem` acceptable -> Right env
30− | otherwise -> Left [ P.vcat err ]
35+ | otherwise -> throw err
37+ acceptable = [ "Graphics.Element.Element"
32− acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"]
38+ , "Signal.Signal Graphics.Element.Element" ]
33− tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType
40+ tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType
34− err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
41+ err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
35− , P.text "Instead 'main' has type:\n"
42+ , P.text "Instead 'main' has type:\n"
36− , P.nest 4 . pretty $ Alias.realias rules mainType
43+ , P.nest 4 . pretty $ Alias.realias rules mainType
37− , P.text " " ]
44+ , P.text " " ]
46+portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
47+portTypes rules expr =
48+ const () <$> Expr.checkPorts checkIn checkOut expr
50+ showType tipe = (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
53+ do t <- getSignal name st
54+ case unsafePerformIO (toSrcType tt) of
56+ do isJsType "coming in" name a
57+ if b `elem` okayTypes then return () else throw msg
60+ , T.Data "Maybe.Maybe" [t]
61+ , T.Data "Either.Either" [T.Data "String.String" [], t]
63+ msg = [ P.text $ "Type Error: the handler for port '" ++ name ++
64+ "' returns values of type:\n"
66+ , P.text $ "but the port's type annotation requires that the handler returns values"
67+ , P.text $ "with one of the following types:\n"
68+ ] ++ map showType okayTypes ++
69+ [ P.text "If the handler returns a Maybe or Either, invalid values will cause an"
70+ , P.text "error to be thrown to the JS error handler associated with this port." ]
73+ throw [ P.text $ "Type Error: the handler for port '" ++ name ++
74+ "' must be a function!"
75+ , P.text "Instead it was given a value of type:\n"
80+ do t <- getSignal name st
81+ isJsType "sent out" name t
83+ getSignal name tipe =
85+ T.Data "Signal.Signal" [t] -> return t
86+ _ -> throw [ P.text $ "Type Error: port '" ++ name ++ "' must be a Signal,"
87+ , P.text $ "but the type annotation says it has non-Signal type:\n"
89+ , P.text $ "Maybe instead you want the following type?\n"
90+ , showType (T.Data "Signal.Signal" [tipe])
93+ isJsType msg name tipe =
95+ T.Data ctor ts | okay ctor -> mapM_ (isJsType msg name) ts
96+ | otherwise -> throw $ err msg "Elm values"
97+ T.Var _ -> throw $ err msg "type variables"
98+ T.Lambda _ _ -> throw $ err msg "Elm functions"
99+ T.EmptyRecord -> throw $ err msg "Elm records"
100+ T.Record _ _ -> throw $ err msg "Elm records"
102+ okay ctor = and [ List.isPrefixOf "JavaScript." ctor
103+ , 1 == length (filter (=='.') ctor) ]
106+ [ P.text $ "Type Error: the values " ++ msg ++ " through port '" ++ name ++
107+ "' must be JavaScript values."
108+ , P.text $ "The values sent through this port contain " ++ kind ++ " with type:\n"
39−occursCheck :: (String, Variable) -> StateT TS.SolverState IO ()
112+occurs :: (String, Variable) -> StateT TS.SolverState IO ()
40−occursCheck (name, variable) =
113+occurs (name, variable) =
41 do vars <- liftIO $ infiniteVars [] variable
114 do vars <- liftIO $ infiniteVars [] variable
42 case vars of
115 case vars of
43 [] -> return ()
116 [] -> return ()
@@ -49,7 +122,7 @@ occursCheck (name, variable) =
49 Just _ ->
122 Just _ ->
50 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
123 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
51 var' <- liftIO $ UF.fresh desc
124 var' <- liftIO $ UF.fresh desc
52− TS.addError (Location.NoSpan name) (Just msg) var var'
125+ TS.addError (L.NoSpan name) (Just msg) var var'
54 msg = "Infinite types are not allowed"
127 msg = "Infinite types are not allowed"
55 fallback _ = return $ P.text msg
128 fallback _ = return $ P.text msg