@@ -4,7 +4,7 @@
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, wireTypes) where
7+module Type.ExtraChecks (mainType, occurs) where
88
99import Prelude hiding (maybe)
1010import Control.Applicative ((<$>),(<*>))
@@ -16,21 +16,14 @@ import qualified Data.UnionFind.IO as UF
1616import Text.PrettyPrint as P
1717
1818import qualified AST.Annotation as A
19−import qualified AST.Expression.Canonical as Canonical
2019import qualified AST.PrettyPrint as PP
2120import qualified AST.Type as ST
2221import qualified AST.Variable as Var
23−import qualified Transform.Expression as Expr
2422import qualified Type.Hint as Hint
2523import qualified Type.Type as TT
2624import qualified Type.State as TS
2725
2826
29−throw :: [Doc] -> Either [Doc] a
30−throw err =
31− Left [ P.vcat err ]
32−
33−
3427-- MAIN TYPE
3528
3629mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
@@ -114,181 +107,6 @@ badMainMessage typeOfMain =
114107 ]
115108
116109
117−-- PORT TYPES
118−
119−data Direction = In | Out
120−
121−
122−wireTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
123−wireTypes expr =
124− case Expr.checkWires (checkWires In) (checkWires Out) checkLoobacks expr of
125− Left err -> throwError err
126− Right _ -> return ()
127−
128−
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 _ args t ->
143− checkWiresHelp direction name rootType (ST.dealias args 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 _ args t ->
176− valid (ST.dealias args 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 4 $
235− P.vcat
236− [ txt [ "The ", wire, " named '", name, "' has an invalid type.\n" ]
237− , P.nest 4 (PP.pretty rootType) <> P.text "\n"
238− , txt [ problemMessage, ":\n" ]
239− , P.nest 4 (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
250−
251− txt = P.text . concat
252−
253− wire =
254− dir "input" "output"
255−
256−
257−checkLoobacks :: String -> ST.CanonicalType -> Bool -> Either [P.Doc] ()
258−checkLoobacks name tipe hasExpr =
259− checkLoobacksHelp name tipe tipe hasExpr
260−
261−
262−checkLoobacksHelp :: String -> ST.CanonicalType -> ST.CanonicalType -> Bool -> Either [P.Doc] ()
263−checkLoobacksHelp name rootType tipe hasExpr =
264− case ST.deepDealias tipe of
265− ST.Record
266− [ ("mailbox", ST.App (ST.Type mailbox) [a])
267− , ("stream", ST.App (ST.Type stream) [b])
268− ]
269− Nothing
270− | not hasExpr
271− && Var.isStream stream
272− && Var.isMailbox mailbox
273− && a == b
274− ->
275− return ()
276−
277− ST.App (ST.Type signal) [ ST.App (ST.Type result) [_,_] ]
278− | hasExpr && Var.isStream signal && Var.isResult result ->
279− return ()
280−
281− _ ->
282− throw $
283− [ P.text "Loopback Error:"
284− , P.nest 4 $
285− P.vcat
286− [ P.text ("The loopback named '" ++ name ++ "' has an invalid type.\n")
287− , P.nest 4 (PP.pretty rootType) <> P.text "\n"
288− ]
289− ]
290−
291−
292110-- INFINITE TYPES
293111
294112occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()