@@ -1,207 +0,0 @@
1−module Transform.Canonicalize.Wire (checkForeignInput, checkForeignOutput, input) where
2−
3−import Control.Applicative ((<$>))
4−import Control.Monad.Error (forM_, throwError)
5−import Text.PrettyPrint as P
6−
7−import qualified AST.Declaration as D
8−import qualified AST.Expression.Canonical as Canonical
9−import qualified AST.PrettyPrint as PP
10−import qualified AST.Type as ST
11−import qualified AST.Variable as Var
12−import qualified Transform.Canonicalize.Environment as Env
13−
14−
15−throw :: [Doc] -> Env.Canonicalizer [P.Doc] a
16−throw err =
17− throwError [ P.vcat err ]
18−
19−
20−checkForeignInput :: String -> ST.CanonicalType -> Env.Canonicalizer [P.Doc] ()
21−checkForeignInput name tipe =
22− checkForeign In name tipe tipe
23−
24−
25−checkForeignOutput :: String -> ST.CanonicalType -> Env.Canonicalizer [P.Doc] ()
26−checkForeignOutput name tipe =
27− checkForeign Out name tipe tipe
28−
29−
30−data Direction = In | Out
31−
32−
33−checkForeign
34− :: Direction
35− -> String
36− -> ST.CanonicalType
37− -> ST.CanonicalType
38− -> Env.Canonicalizer [P.Doc] ()
39−checkForeign direction name rootType tipe =
40− case tipe of
41− ST.Aliased _ args t ->
42− checkForeign direction name rootType (ST.dealias args t)
43−
44− ST.App (ST.Type signal) [t]
45− | Var.isStream signal ->
46− validForeignType False (Just Stream) direction name rootType t
47−
48− | Var.isVarying signal ->
49− validForeignType False (Just Varying) direction name rootType t
50−
51− _ ->
52− validForeignType False Nothing direction name rootType tipe
53−
54−
55−data Signal = Stream | Varying
56−
57−
58−validForeignType
59− :: Bool
60− -> Maybe Signal
61− -> Direction
62− -> String
63− -> ST.CanonicalType
64− -> ST.CanonicalType
65− -> Env.Canonicalizer [P.Doc] ()
66−validForeignType seenFunc seenSignal direction name rootType tipe =
67− let valid localType =
68− validForeignType seenFunc seenSignal direction name rootType localType
69−
70− err kind =
71− throw (foreignError name direction rootType tipe kind)
72− in
73− case tipe of
74− ST.Aliased _ args t ->
75− valid (ST.dealias args t)
76−
77− ST.Type v ->
78− case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
79− True -> return ()
80− False -> err "It contains an unsupported type"
81−
82− ST.App t [] ->
83− valid t
84−
85− ST.App (ST.Type v) [t]
86− | Var.isMaybe v -> valid t
87− | Var.isArray v -> valid t
88− | Var.isList v -> valid t
89−
90− ST.App (ST.Type v) ts
91− | Var.isTuple v -> mapM_ valid ts
92−
93− ST.App _ _ ->
94− err "It contains an unsupported type"
95−
96− ST.Var _ ->
97− err "It contains a free type variable"
98−
99− ST.Lambda _ _ ->
100− case direction of
101− In -> err "It contains functions"
102− Out ->
103− if seenFunc
104− then err "It contains higher-order functions"
105− else
106− case seenSignal of
107− Just Stream ->
108− err "It is a streams that contains a function"
109−
110− Just Varying ->
111− err "It is a varying value that contains a function"
112−
113− Nothing ->
114− forM_ (ST.collectLambdas tipe)
115− (validForeignType True seenSignal direction name rootType)
116−
117− ST.Record _ (Just _) ->
118− err "It contains extended records with free type variables"
119−
120− ST.Record fields Nothing ->
121− mapM_ (\(k,v) -> (,) k <$> valid v) fields
122−
123−
124−foreignError
125− :: String
126− -> Direction
127− -> ST.CanonicalType
128− -> ST.CanonicalType
129− -> String
130− -> [P.Doc]
131−foreignError name direction rootType localType problemMessage =
132− [ P.text ("Foreign " ++ dir "Input" "Output" ++ " Error:")
133− , P.nest 4 $
134− P.vcat
135− [ txt [ "The foreign ", wire, " named '", name, "' has an invalid type.\n" ]
136− , P.nest 4 (PP.pretty rootType) <> P.text "\n"
137− , txt [ problemMessage, ":\n" ]
138− , P.nest 4 (PP.pretty localType) <> P.text "\n"
139− , txt [ "Acceptable values for foreign ", wire, "s include:" ]
140− , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]
141− , txt [ " Json.Values, ", dir "" "first-order functions, tasks, ", "and concrete records." ]
142− ]
143− ]
144− where
145− dir inMsg outMsg =
146− case direction of
147− In -> inMsg
148− Out -> outMsg
149−
150− txt = P.text . concat
151−
152− wire =
153− dir "input" "output"
154−
155−
156−input
157− :: String
158− -> Maybe Canonical.Expr
159− -> ST.CanonicalType
160− -> Env.Canonicalizer [P.Doc] D.CanonicalLoopback
161−input name maybeExpr tipe =
162− case maybeExpr of
163− Nothing ->
164− case ST.deepDealias tipe of
165− ST.Record
166− [ ("address", ST.App (ST.Type address) [a])
167− , ("stream", ST.App (ST.Type stream) [b])
168− ]
169− Nothing
170− | Var.isStream stream && Var.isAddress address && a == b ->
171− return (D.Address name tipe)
172−
173−
174− _ ->
175− throw $ inputError name tipe $
176− [ P.text "An input like this must be a Stream.Input" ]
177−
178− Just expr ->
179− case ST.deepDealias tipe of
180− ST.App (ST.Type signal) [ ST.App (ST.Type result) [failure,success] ]
181− | Var.isStream signal && Var.isResult result ->
182− let task =
183− Var.fromModule ["Task"] "Task"
184− taskType =
185− ST.App (ST.Type signal) [ ST.App (ST.Type task) [failure,success] ]
186− in
187− return (D.Task name taskType expr tipe)
188−
189− _ ->
190− throw $ inputError name tipe $
191− [ P.text "An input that runs tasks must be a stream of results."
192− , P.text "Something like the following:\n"
193− , P.text " Stream (Result Http.Error String)"
194− , P.text " Stream (Result x ())"
195− ]
196−
197−
198−inputError :: String -> ST.CanonicalType -> [Doc] -> [Doc]
199−inputError name tipe message =
200− [ P.text "Input Error:"
201− , P.nest 4 $
202− P.vcat $
203− [ P.text ("The input named '" ++ name ++ "' has an invalid type.\n")
204− , P.nest 4 (PP.pretty tipe) <> P.text "\n"
205− ]
206− ++ message
207− ]