@@ -14,12 +14,12 @@ import qualified Type.State as TS
1414import qualified Type.Alias as Alias
1515import Text.PrettyPrint as P
1616import SourceSyntax.PrettyPrint (pretty)
17+import qualified SourceSyntax.Helpers as Help
1718import qualified SourceSyntax.Type as T
1819import qualified SourceSyntax.Expression as E
1920import qualified SourceSyntax.Location as L
2021import qualified Transform.Expression as Expr
2122import qualified Data.Traversable as Traverse
22−import System.IO.Unsafe
2323
2424throw err = Left [ P.vcat err ]
2525
@@ -43,69 +43,60 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
4343 , P.nest 4 . pretty $ Alias.realias rules mainType
4444 , P.text " " ]
4545
46+data Direction = In | Out
47+
4648portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
4749portTypes rules expr =
4850 const () <$> Expr.checkPorts checkIn checkOut expr
4951 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 =
52+ checkIn name st _ = isValidType In name st
53+ checkOut name st = isValidType Out name st
54+
55+ isValidType = isValid True
56+ isValid firstOrder direction name tipe =
57+ let valid = isValid firstOrder direction name in
9458 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.Record _ _ -> throw $ err msg "Elm records"
59+ T.Data ctor ts | okay ctor -> mapM_ valid ts
60+ | otherwise -> err "Algebraic Data Types"
61+
62+ T.Var _ -> err "free type variables"
63+
64+ T.Lambda t1 t2 ->
65+ case direction of
66+ In -> err "functions"
67+ Out | firstOrder -> do isValid False direction name t1
68+ valid t2
69+ | otherwise -> err "higher-order functions"
70+
71+ T.Record _ (Just _) -> err "extended records with free type variables"
72+
73+ T.Record fields Nothing ->
74+ mapM_ (\(k,v) -> (,) k <$> valid v) fields
75+
10076 where
101− okay ctor = and [ List.isPrefixOf "JavaScript." ctor
102− , 1 == length (filter (=='.') ctor) ]
103−
104− err msg kind =
105− [ P.text $ "Type Error: the values " ++ msg ++ " through port '" ++ name ++
106− "' must be JavaScript values."
107− , P.text $ "The values sent through this port contain " ++ kind ++ " with type:\n"
108− , showType tipe
77+ okay ctor = isJs ctor || isElm ctor
78+
79+ isJs ctor =
80+ List.isPrefixOf "JavaScript." ctor
81+ && length (filter (=='.') ctor) == 1
82+
83+ isElm ctor =
84+ ctor `elem` ["Int","Float","String","Maybe.Maybe","_List","Signal.Signal"]
85+ || Help.isTuple ctor
86+
87+ dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
88+ txt = P.text . concat
89+
90+ err kind =
91+ throw $
92+ [ txt [ "Type Error: the value ", dir "coming in" "sent out"
93+ , " through port '", name, "' is invalid." ]
94+ , txt [ "Acceptable values for ", dir "incoming" "outgoing"
95+ , " ports include JavaScript values and the following Elm values:" ]
96+ , txt [ "Ints, Floats, Strings, Maybes, Lists, Tuples, "
97+ , dir "" "first-order functions, ", "and concrete records." ]
98+ , txt [ "The values sent through this port contain ", kind, ":\n" ]
99+ , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
109100 ]
110101
111102occurs :: (String, Variable) -> StateT TS.SolverState IO ()