@@ -4,8 +4,9 @@
4successfully. At that point we still need to do occurs checks and ensure that
4successfully. At that point we still need to do occurs checks and ensure that
5`main` has an acceptable type.
5`main` has an acceptable type.
7−module Type.ExtraChecks (mainType, occurs, portTypes) where
7+module Type.ExtraChecks (mainType, occurs, wireTypes) where
9+import Prelude hiding (maybe)
9import Control.Applicative ((<$>),(<*>))
10import Control.Applicative ((<$>),(<*>))
10import Control.Monad.Error
11import Control.Monad.Error
11import Control.Monad.State
12import Control.Monad.State
@@ -118,81 +119,142 @@ badMainMessage typeOfMain =
118data Direction = In | Out
119data Direction = In | Out
121−portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
122+wireTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
122−portTypes expr =
123+wireTypes expr =
123− case Expr.checkPorts (check In) (check Out) expr of
124+ case Expr.checkWires (checkWires In) (checkWires Out) expr of
124 Left err -> throwError err
125 Left err -> throwError err
125 Right _ -> return ()
126 Right _ -> return ()
127− check = isValid True False False
128− isValid isTopLevel seenFunc seenSignal direction name tipe =
130− ST.Aliased _ t -> valid t
133− case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
135− False -> err "an unsupported type"
137− ST.App t [] -> valid t
139− ST.App (ST.Type v) [t]
140− | Var.isSignal v -> handleSignal t
141− | Var.isMaybe v -> valid t
142− | Var.isArray v -> valid t
143− | Var.isList v -> valid t
145− ST.App (ST.Type v) [_, _]
146− | Var.isPromise v ->
148− In -> err "promises"
151− ST.App (ST.Type v) ts
152− | Var.isTuple v -> mapM_ valid ts
154− ST.App _ _ -> err "an unsupported type"
156− ST.Var _ -> err "free type variables"
160− In -> err "functions"
161− Out | seenFunc -> err "higher-order functions"
162− | seenSignal -> err "signals that contain functions"
164− forM_ (ST.collectLambdas tipe)
165− (isValid' True seenSignal direction name)
167− ST.Record _ (Just _) -> err "extended records with free type variables"
169− ST.Record fields Nothing ->
129+checkWires :: Direction -> String -> ST.CanonicalType -> Either [P.Doc] ()
130+checkWires direction name tipe =
131+ checkWiresHelp direction name tipe tipe
139+ -> Either [P.Doc] ()
140+checkWiresHelp direction name rootType tipe =
143+ checkWiresHelp direction name rootType t
145+ ST.App (ST.Type signal) [t]
146+ | Var.isStream signal ->
147+ validWireType False (Just Stream) direction name rootType t
149+ | Var.isVarying signal ->
150+ validWireType False (Just Varying) direction name rootType t
153+ validWireType False Nothing direction name rootType tipe
156+data Signal = Stream | Varying
166+ -> Either [P.Doc] ()
167+validWireType seenFunc seenSignal direction name rootType tipe =
168+ let valid localType =
169+ validWireType seenFunc seenSignal direction name rootType localType
172+ throw (wireError name direction rootType tipe kind)
179+ case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
181+ False -> err "It contains an unsupported type"
186+ ST.App (ST.Type v) [t]
187+ | Var.isMaybe v -> valid t
188+ | Var.isArray v -> valid t
189+ | Var.isList v -> valid t
191+ ST.App (ST.Type v) ts
192+ | Var.isTuple v -> mapM_ valid ts
195+ err "It contains an unsupported type"
198+ err "It contains a free type variable"
202+ In -> err "It contains functions"
205+ then err "It contains higher-order functions"
209+ err "It is a streams that contains a function"
212+ err "It is a varying value that contains a function"
215+ forM_ (ST.collectLambdas tipe)
216+ (validWireType True seenSignal direction name rootType)
218+ ST.Record _ (Just _) ->
219+ err "It contains extended records with free type variables"
221+ ST.Record fields Nothing ->
170− mapM_ (\(k,v) -> (,) k <$> valid v) fields
222+ mapM_ (\(k,v) -> (,) k <$> valid v) fields
232+wireError name direction rootType localType problemMessage =
233+ [ P.text (dir "Input" "Output" ++ " Error:")
236+ [ txt [ "The ", wire, " named '", name, "' was has an invalid type.\n" ]
237+ , P.nest 2 (PP.pretty rootType) <> P.text "\n"
238+ , txt [ problemMessage, ":\n" ]
239+ , P.nest 2 (PP.pretty localType) <> P.text "\n"
240+ , txt [ "Acceptable values for ", wire, "s include:" ]
241+ , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]
242+ , txt [ " Json.Values, ", dir "" "first-order functions, promises, ", "and concrete records." ]
173− isValid' = isValid False
246+ dir inMsg outMsg =
174− valid = isValid' seenFunc seenSignal direction name
247+ case direction of
176− handleSignal t
251+ txt = P.text . concat
177− | seenFunc = err "functions that involve signals"
178− | seenSignal = err "signals-of-signals"
179− | isTopLevel = isValid' seenFunc True direction name t
180− | otherwise = err "a signal within a data stucture"
182− dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
253+ wire =
183− txt = P.text . concat
254+ dir "input" "output"
187− [ txt [ "Type Error: the value ", dir "coming in" "sent out"
188− , " through port '", name, "' is invalid." ]
189− , txt [ "It contains ", kind, ":\n" ]
190− , P.nest 4 (PP.pretty tipe) <> P.text "\n"
191− , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
192− , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]
193− , txt [ " Json.Values, ", dir "" "first-order functions, promises, ", "and concrete records." ]
197occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
259occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
198occurs (name, variable) =
260occurs (name, variable) =