@@ -4,8 +4,9 @@
44successfully. At that point we still need to do occurs checks and ensure that
55`main` has an acceptable type.
66-}
7−module Type.ExtraChecks (mainType, occurs, portTypes) where
7+module Type.ExtraChecks (mainType, occurs, wireTypes) where
88
9+import Prelude hiding (maybe)
910import Control.Applicative ((<$>),(<*>))
1011import Control.Monad.Error
1112import Control.Monad.State
@@ -118,81 +119,142 @@ badMainMessage typeOfMain =
118119data Direction = In | Out
119120
120121
121−portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
122−portTypes expr =
123− case Expr.checkPorts (check In) (check Out) expr of
122+wireTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
123+wireTypes expr =
124+ case Expr.checkWires (checkWires In) (checkWires Out) expr of
124125 Left err -> throwError err
125126 Right _ -> return ()
126− where
127− check = isValid True False False
128− isValid isTopLevel seenFunc seenSignal direction name tipe =
129− case tipe of
130− ST.Aliased _ t -> valid t
131−
132− ST.Type v ->
133− case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
134− True -> return ()
135− False -> err "an unsupported type"
136−
137− ST.App t [] -> valid t
138−
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
144−
145− ST.App (ST.Type v) [_, _]
146− | Var.isPromise v ->
147− case direction of
148− In -> err "promises"
149− Out -> return ()
150−
151− ST.App (ST.Type v) ts
152− | Var.isTuple v -> mapM_ valid ts
153−
154− ST.App _ _ -> err "an unsupported type"
155−
156− ST.Var _ -> err "free type variables"
157−
158− ST.Lambda _ _ ->
159− case direction of
160− In -> err "functions"
161− Out | seenFunc -> err "higher-order functions"
162− | seenSignal -> err "signals that contain functions"
163− | otherwise ->
164− forM_ (ST.collectLambdas tipe)
165− (isValid' True seenSignal direction name)
166127
167− ST.Record _ (Just _) -> err "extended records with free type variables"
168128
169− ST.Record fields Nothing ->
170− mapM_ (\(k,v) -> (,) k <$> valid v) fields
171−
172− where
173− isValid' = isValid False
174− valid = isValid' seenFunc seenSignal direction name
129+checkWires :: Direction -> String -> ST.CanonicalType -> Either [P.Doc] ()
130+checkWires direction name tipe =
131+ checkWiresHelp direction name tipe tipe
132+
133+
134+checkWiresHelp
135+ :: Direction
136+ -> String
137+ -> ST.CanonicalType
138+ -> ST.CanonicalType
139+ -> Either [P.Doc] ()
140+checkWiresHelp direction name rootType tipe =
141+ case tipe of
142+ ST.Aliased _ t ->
143+ checkWiresHelp direction name rootType t
144+
145+ ST.App (ST.Type signal) [t]
146+ | Var.isStream signal ->
147+ validWireType False (Just Stream) direction name rootType t
148+
149+ | Var.isVarying signal ->
150+ validWireType False (Just Varying) direction name rootType t
151+
152+ _ ->
153+ validWireType False Nothing direction name rootType tipe
154+
155+
156+data Signal = Stream | Varying
157+
158+
159+validWireType
160+ :: Bool
161+ -> Maybe Signal
162+ -> Direction
163+ -> String
164+ -> ST.CanonicalType
165+ -> ST.CanonicalType
166+ -> Either [P.Doc] ()
167+validWireType seenFunc seenSignal direction name rootType tipe =
168+ let valid localType =
169+ validWireType seenFunc seenSignal direction name rootType localType
170+
171+ err kind =
172+ throw (wireError name direction rootType tipe kind)
173+ in
174+ case tipe of
175+ ST.Aliased _ t ->
176+ valid t
177+
178+ ST.Type v ->
179+ case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
180+ True -> return ()
181+ False -> err "It contains an unsupported type"
182+
183+ ST.App t [] ->
184+ valid t
185+
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
190+
191+ ST.App (ST.Type v) ts
192+ | Var.isTuple v -> mapM_ valid ts
193+
194+ ST.App _ _ ->
195+ err "It contains an unsupported type"
196+
197+ ST.Var _ ->
198+ err "It contains a free type variable"
199+
200+ ST.Lambda _ _ ->
201+ case direction of
202+ In -> err "It contains functions"
203+ Out ->
204+ if seenFunc
205+ then err "It contains higher-order functions"
206+ else
207+ case seenSignal of
208+ Just Stream ->
209+ err "It is a streams that contains a function"
210+
211+ Just Varying ->
212+ err "It is a varying value that contains a function"
213+
214+ Nothing ->
215+ forM_ (ST.collectLambdas tipe)
216+ (validWireType True seenSignal direction name rootType)
217+
218+ ST.Record _ (Just _) ->
219+ err "It contains extended records with free type variables"
220+
221+ ST.Record fields Nothing ->
222+ mapM_ (\(k,v) -> (,) k <$> valid v) fields
223+
224+
225+wireError
226+ :: String
227+ -> Direction
228+ -> ST.CanonicalType
229+ -> ST.CanonicalType
230+ -> String
231+ -> [P.Doc]
232+wireError name direction rootType localType problemMessage =
233+ [ P.text (dir "Input" "Output" ++ " Error:")
234+ , P.nest 2 $
235+ P.vcat
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." ]
243+ ]
244+ ]
245+ where
246+ dir inMsg outMsg =
247+ case direction of
248+ In -> inMsg
249+ Out -> outMsg
175250
176− handleSignal t
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"
251+ txt = P.text . concat
181252
182− dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
183− txt = P.text . concat
253+ wire =
254+ dir "input" "output"
184255
185− err kind =
186− throw $
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." ]
194− ]
195256
257+-- INFINITE TYPES
196258
197259occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
198260occurs (name, variable) =