@@ -1,11 +1,12 @@
11{-# OPTIONS_GHC -W #-}
2−module Type.ExtraChecks (extraChecks, occursCheck) where
2+module Type.ExtraChecks (mainType, occurs, portTypes) where
33-- This module contains checks to be run *after* type inference has
44-- completed successfully. At that point we still need to do occurs
55-- checks and ensure that `main` has an acceptable type.
66
77import Control.Applicative ((<$>),(<*>))
88import Control.Monad.State
9+import qualified Data.List as List
910import qualified Data.Map as Map
1011import qualified Data.UnionFind.IO as UF
1112import Type.Type ( Variable, structure, Term1(..), toSrcType )
@@ -13,31 +14,103 @@ import qualified Type.State as TS
1314import qualified Type.Alias as Alias
1415import Text.PrettyPrint as P
1516import SourceSyntax.PrettyPrint (pretty)
16−import SourceSyntax.Type (Type)
17−import qualified SourceSyntax.Location as Location
17+import qualified SourceSyntax.Type as T
18+import qualified SourceSyntax.Expression as E
19+import qualified SourceSyntax.Location as L
20+import qualified Transform.Expression as Expr
1821import qualified Data.Traversable as Traverse
22+import System.IO.Unsafe
1923
20−extraChecks :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String Type))
21−extraChecks rules env =
22− mainCheck rules <$> Traverse.traverse toSrcType env
24+throw err = Left [ P.vcat err ]
2325
24−mainCheck :: Alias.Rules -> Map.Map String Type -> Either [P.Doc] (Map.Map String Type)
25−mainCheck rules env =
26− case Map.lookup "main" env of
27− Nothing -> Right env
28− Just mainType
29− | tipe `elem` acceptable -> Right env
30− | otherwise -> Left [ P.vcat err ]
31− where
32− acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"]
33− tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType
34− err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
35− , P.text "Instead 'main' has type:\n"
36− , P.nest 4 . pretty $ Alias.realias rules mainType
37− , P.text " " ]
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
28+ where
29+ mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)
30+ mainCheck rules env =
31+ case Map.lookup "main" env of
32+ Nothing -> Right env
33+ Just mainType
34+ | tipe `elem` acceptable -> Right env
35+ | otherwise -> throw err
36+ where
37+ acceptable = [ "Graphics.Element.Element"
38+ , "Signal.Signal Graphics.Element.Element" ]
39+
40+ tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType
41+ err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
42+ , P.text "Instead 'main' has type:\n"
43+ , P.nest 4 . pretty $ Alias.realias rules mainType
44+ , P.text " " ]
45+
46+portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
47+portTypes rules expr =
48+ const () <$> Expr.checkPorts checkIn checkOut expr
49+ where
50+ showType tipe = (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
51+
52+ checkIn name st tt =
53+ do t <- getSignal name st
54+ case unsafePerformIO (toSrcType tt) of
55+ T.Lambda a b ->
56+ do isJsType "coming in" name a
57+ if b `elem` okayTypes then return () else throw msg
58+ where
59+ okayTypes = [ t
60+ , T.Data "Maybe.Maybe" [t]
61+ , T.Data "Either.Either" [T.Data "String.String" [], t]
62+ ]
63+ msg = [ P.text $ "Type Error: the handler for port '" ++ name ++
64+ "' returns values of type:\n"
65+ , showType b
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." ]
71+
72+ tipe ->
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"
76+ , showType tipe
77+ ]
78+
79+ checkOut name st =
80+ do t <- getSignal name st
81+ isJsType "sent out" name t
82+
83+ getSignal name tipe =
84+ case tipe of
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"
88+ , showType tipe
89+ , P.text $ "Maybe instead you want the following type?\n"
90+ , showType (T.Data "Signal.Signal" [tipe])
91+ ]
92+
93+ isJsType msg name tipe =
94+ case tipe of
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"
101+ where
102+ okay ctor = and [ List.isPrefixOf "JavaScript." ctor
103+ , 1 == length (filter (=='.') ctor) ]
104+
105+ err msg kind =
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"
109+ , showType tipe
110+ ]
38111
39−occursCheck :: (String, Variable) -> StateT TS.SolverState IO ()
40−occursCheck (name, variable) =
112+occurs :: (String, Variable) -> StateT TS.SolverState IO ()
113+occurs (name, variable) =
41114 do vars <- liftIO $ infiniteVars [] variable
42115 case vars of
43116 [] -> return ()
@@ -49,7 +122,7 @@ occursCheck (name, variable) =
49122 Just _ ->
50123 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
51124 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'
53126 where
54127 msg = "Infinite types are not allowed"
55128 fallback _ = return $ P.text msg