git.iko.soy/elk
on master help sign in
Make port checks more permissive
fe3b343Evan Czaplicki
compiler/Type/ExtraChecks.hs+49−58
compare with master
unifiedsplit
@@ -14,12 +14,12 @@ import qualified Type.State as TS
14import qualified Type.Alias as Alias
14import qualified Type.Alias as Alias
15import Text.PrettyPrint as P
15import Text.PrettyPrint as P
16import SourceSyntax.PrettyPrint (pretty)
16import SourceSyntax.PrettyPrint (pretty)
17+import qualified SourceSyntax.Helpers as Help
17import qualified SourceSyntax.Type as T
18import qualified SourceSyntax.Type as T
18import qualified SourceSyntax.Expression as E
19import qualified SourceSyntax.Expression as E
19import qualified SourceSyntax.Location as L
20import qualified SourceSyntax.Location as L
20import qualified Transform.Expression as Expr
21import qualified Transform.Expression as Expr
21import qualified Data.Traversable as Traverse
22import qualified Data.Traversable as Traverse
22−import System.IO.Unsafe
23
23
24throw err = Left [ P.vcat err ]
24throw err = Left [ P.vcat err ]
25
25
@@ -43,69 +43,60 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
43 , P.nest 4 . pretty $ Alias.realias rules mainType
43 , P.nest 4 . pretty $ Alias.realias rules mainType
44 , P.text " " ]
44 , P.text " " ]
45
45
46+data Direction = In | Out
47+
46portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
48portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
47portTypes rules expr =
49portTypes rules expr =
48 const () <$> Expr.checkPorts checkIn checkOut expr
50 const () <$> Expr.checkPorts checkIn checkOut expr
49 where
51 where
50− showType tipe = (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
51−
52− checkIn name st tt =
52+ checkIn name st _ = isValidType In name st
53− do t <- getSignal name st
53+ checkOut name st = isValidType Out name st
54− case unsafePerformIO (toSrcType tt) of
54+
55− T.Lambda a b ->
55+ isValidType = isValid True
56− do isJsType "coming in" name a
56+ isValid firstOrder direction name tipe =
57− if b `elem` okayTypes then return () else throw msg
57+ let valid = isValid firstOrder direction name in
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
58 case tipe of
95− T.Data ctor ts | okay ctor -> mapM_ (isJsType msg name) ts
59+ T.Data ctor ts | okay ctor -> mapM_ valid ts
96− | otherwise -> throw $ err msg "Elm values"
60+ | otherwise -> err "Algebraic Data Types"
61+
97− T.Var _ -> throw $ err msg "type variables"
62+ T.Var _ -> err "free type variables"
98− T.Lambda _ _ -> throw $ err msg "Elm functions"
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+
99− T.Record _ _ -> throw $ err msg "Elm records"
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+
100 where
76 where
77+ okay ctor = isJs ctor || isElm ctor
78+
79+ isJs ctor =
101− okay ctor = and [ List.isPrefixOf "JavaScript." ctor
80+ List.isPrefixOf "JavaScript." ctor
102− , 1 == length (filter (=='.') ctor) ]
81+ && length (filter (=='.') ctor) == 1
103−
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+
104− err msg kind =
90+ err kind =
91+ throw $
92+ [ txt [ "Type Error: the value ", dir "coming in" "sent out"
105− [ P.text $ "Type Error: the values " ++ msg ++ " through port '" ++ name ++
93+ , " through port '", name, "' is invalid." ]
94+ , txt [ "Acceptable values for ", dir "incoming" "outgoing"
106− "' must be JavaScript values."
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." ]
107− , P.text $ "The values sent through this port contain " ++ kind ++ " with type:\n"
98+ , txt [ "The values sent through this port contain ", kind, ":\n" ]
108− , showType tipe
99+ , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
109 ]
100 ]
110
101
111occurs :: (String, Variable) -> StateT TS.SolverState IO ()
102occurs :: (String, Variable) -> StateT TS.SolverState IO ()