adamc@110
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@110
|
2 * All rights reserved.
|
adamc@110
|
3 *
|
adamc@110
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@110
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@110
|
6 *
|
adamc@110
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@110
|
8 * this list of conditions and the following disclaimer.
|
adamc@110
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@110
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@110
|
11 * and/or other materials provided with the distribution.
|
adamc@110
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@110
|
13 * derived from this software without specific prior written permission.
|
adamc@110
|
14 *
|
adamc@110
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@110
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@110
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@110
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@110
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@110
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@110
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@110
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@110
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@110
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@110
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@110
|
26 *)
|
adamc@110
|
27
|
adamc@110
|
28 structure Tag :> TAG = struct
|
adamc@110
|
29
|
adamc@110
|
30 open Core
|
adamc@110
|
31
|
adamc@110
|
32 structure U = CoreUtil
|
adamc@110
|
33 structure E = CoreEnv
|
adamc@110
|
34
|
adamc@110
|
35 structure IM = IntBinaryMap
|
adamc@112
|
36 structure SM = BinaryMapFn(struct
|
adamc@112
|
37 type ord_key = string
|
adamc@112
|
38 val compare = String.compare
|
adamc@112
|
39 end)
|
adamc@110
|
40
|
adamc@110
|
41 fun kind (k, s) = (k, s)
|
adamc@110
|
42 fun con (c, s) = (c, s)
|
adamc@110
|
43
|
adamc@1046
|
44 fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for both a link and a form");
|
adamc@1046
|
45 TextIO.output (TextIO.stdErr,
|
adamc@1046
|
46 "Make sure that the signature of the containing module hides any form handlers.\n"))
|
adamc@1046
|
47
|
adamc@112
|
48 fun exp env (e, s) =
|
adamc@1065
|
49 let
|
adamc@1065
|
50 fun tagIt (e, ek : export_kind, newAttr, (count, tags, byTag, newTags)) =
|
adamc@1065
|
51 let
|
adamc@1065
|
52 val loc = #2 e
|
adamc@1065
|
53
|
adamc@1065
|
54 val eOrig = e
|
adamc@1065
|
55
|
adamc@1065
|
56 fun unravel (e, _) =
|
adamc@1065
|
57 case e of
|
adamc@1065
|
58 ENamed n => (n, [])
|
adamc@1065
|
59 | EApp (e1, e2) =>
|
adamc@1065
|
60 let
|
adamc@1065
|
61 val (n, es) = unravel e1
|
adamc@1065
|
62 in
|
adamc@1065
|
63 (n, es @ [e2])
|
adamc@1065
|
64 end
|
adamc@1065
|
65 | _ => (ErrorMsg.errorAt loc ("Invalid " ^ newAttr
|
adamc@1065
|
66 ^ " expression");
|
adamc@1065
|
67 Print.epreface ("Expression",
|
adamc@1065
|
68 CorePrint.p_exp CoreEnv.empty eOrig);
|
adamc@1065
|
69 (0, []))
|
adamc@1065
|
70
|
adamc@1065
|
71 val (f, args) = unravel e
|
adamc@1065
|
72
|
adamc@1065
|
73 val (cn, count, tags, newTags) =
|
adamc@1065
|
74 case IM.find (tags, f) of
|
adamc@1065
|
75 NONE =>
|
adamc@1065
|
76 (count, count + 1, IM.insert (tags, f, count),
|
adamc@1065
|
77 (ek, f, count) :: newTags)
|
adamc@1065
|
78 | SOME cn => (cn, count, tags, newTags)
|
adamc@1065
|
79
|
adamc@1065
|
80 val (_, _, _, s) = E.lookupENamed env f
|
adamc@1065
|
81
|
adamc@1065
|
82 val byTag = case SM.find (byTag, s) of
|
adamc@1065
|
83 NONE => SM.insert (byTag, s, (ek, f))
|
adamc@1065
|
84 | SOME (ek', f') =>
|
adamc@1065
|
85 (if f = f' then
|
adamc@1065
|
86 ()
|
adamc@1065
|
87 else
|
adamc@1065
|
88 ErrorMsg.errorAt loc
|
adamc@1065
|
89 ("Duplicate HTTP tag "
|
adamc@1065
|
90 ^ s);
|
adamc@1065
|
91 if ek = ek' then
|
adamc@1065
|
92 ()
|
adamc@1065
|
93 else
|
adamc@1065
|
94 both (loc, s);
|
adamc@1065
|
95 byTag)
|
adamc@1065
|
96
|
adamc@1065
|
97 val e = (EClosure (cn, args), loc)
|
adamc@1065
|
98 in
|
adamc@1065
|
99 (e, (count, tags, byTag, newTags))
|
adamc@1065
|
100 end
|
adamc@1065
|
101 in
|
adamc@1065
|
102 case e of
|
adamc@1065
|
103 EApp (
|
adamc@1065
|
104 (EApp (
|
adamc@1065
|
105 (EApp (
|
adamc@1065
|
106 (EApp (
|
adamc@140
|
107 (ECApp (
|
adamc@140
|
108 (ECApp (
|
adamc@140
|
109 (ECApp (
|
adamc@721
|
110 (ECApp (
|
adamc@1065
|
111 (ECApp (
|
adamc@1065
|
112 (ECApp (
|
adamc@110
|
113 (ECApp (
|
adamc@110
|
114 (ECApp (
|
adamc@1065
|
115 (EFfi ("Basis", "tag"),
|
adamc@1065
|
116 loc), given), _), absent), _), outer), _), inner), _),
|
adamc@1065
|
117 useOuter), _), useInner), _), bindOuter), _), bindInner), _),
|
adamc@1065
|
118 class), _),
|
adamc@1065
|
119 attrs), _),
|
adamc@1065
|
120 tag), _),
|
adamc@1065
|
121 xml) =>
|
adamc@1065
|
122 (case attrs of
|
adamc@1065
|
123 (ERecord xets, _) =>
|
adamc@1065
|
124 let
|
adamc@1065
|
125 val (xets, s) =
|
adamc@1065
|
126 ListUtil.foldlMap (fn ((x, e, t), s) =>
|
adamc@1065
|
127 let
|
adamc@1065
|
128 fun tagIt' (ek, newAttr) =
|
adamc@1065
|
129 let
|
adamc@1065
|
130 val (e', s) = tagIt (e, ek, newAttr, s)
|
adamc@1065
|
131 val t = (CFfi ("Basis", "string"), loc)
|
adamc@1065
|
132 in
|
adamc@1065
|
133 (((CName newAttr, loc), e', t), s)
|
adamc@1065
|
134 end
|
adamc@1065
|
135 in
|
adamc@1065
|
136 case x of
|
adamc@1065
|
137 (CName "Link", _) => tagIt' (Link, "Link")
|
adamc@1065
|
138 | (CName "Action", _) => tagIt' (Action ReadWrite, "Action")
|
adamc@1065
|
139 | _ => ((x, e, t), s)
|
adamc@1065
|
140 end)
|
adamc@1065
|
141 s xets
|
adamc@1065
|
142 in
|
adamc@1065
|
143 (EApp (
|
adamc@1065
|
144 (EApp (
|
adamc@1065
|
145 (EApp (
|
adamc@1065
|
146 (EApp (
|
adamc@140
|
147 (ECApp (
|
adamc@140
|
148 (ECApp (
|
adamc@140
|
149 (ECApp (
|
adamc@721
|
150 (ECApp (
|
adamc@1065
|
151 (ECApp (
|
adamc@1065
|
152 (ECApp (
|
adamc@1065
|
153 (ECApp (
|
adamc@1065
|
154 (ECApp (
|
adamc@1065
|
155 (EFfi ("Basis", "tag"),
|
adamc@1065
|
156 loc), given), loc), absent), loc), outer), loc), inner), loc),
|
adamc@1065
|
157 useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc),
|
adamc@1065
|
158 class), loc),
|
adamc@1065
|
159 (ERecord xets, loc)), loc),
|
adamc@1065
|
160 tag), loc),
|
adamc@1065
|
161 xml), s)
|
adamc@1065
|
162 end
|
adamc@1065
|
163 | _ => (ErrorMsg.errorAt loc "Attribute record is too complex";
|
adamc@1065
|
164 (e, s)))
|
adamc@110
|
165
|
adamc@1065
|
166 | EFfiApp ("Basis", "url", [(ERel 0, _)]) => (e, s)
|
adamc@1065
|
167
|
adamc@1065
|
168 | EFfiApp ("Basis", "url", [e]) =>
|
adamc@1065
|
169 let
|
adamc@1065
|
170 val (e, s) = tagIt (e, Link, "Url", s)
|
adamc@1065
|
171 in
|
adamc@1067
|
172 (EFfiApp ("Basis", "url", [e]), s)
|
adamc@1065
|
173 end
|
adamc@1065
|
174
|
adamc@1065
|
175 | EApp ((ENamed n, _), e') =>
|
adamc@1065
|
176 let
|
adamc@1065
|
177 val (_, _, eo, _) = E.lookupENamed env n
|
adamc@1065
|
178 in
|
adamc@1065
|
179 case eo of
|
adamc@1065
|
180 SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [(ERel 0, _)]), _)), _) =>
|
adamc@1065
|
181 let
|
adamc@1065
|
182 val (e, s) = tagIt (e', Link, "Url", s)
|
adamc@1065
|
183 in
|
adamc@1067
|
184 (EFfiApp ("Basis", "url", [e]), s)
|
adamc@1065
|
185 end
|
adamc@1065
|
186 | _ => (e, s)
|
adamc@1065
|
187 end
|
adamc@1065
|
188
|
adamc@1065
|
189 | _ => (e, s)
|
adamc@1065
|
190 end
|
adamc@110
|
191
|
adamc@110
|
192 fun decl (d, s) = (d, s)
|
adamc@110
|
193
|
adamc@110
|
194 fun tag file =
|
adamc@110
|
195 let
|
adamc@179
|
196 val count = U.File.maxName file
|
adamc@110
|
197
|
adamc@112
|
198 fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
|
adamc@112
|
199 case d' of
|
adamc@144
|
200 DExport (ek, n) =>
|
adamc@112
|
201 let
|
adamc@112
|
202 val (_, _, _, s) = E.lookupENamed env n
|
adamc@112
|
203 in
|
adamc@112
|
204 case SM.find (byTag, s) of
|
adamc@112
|
205 NONE => ([d], (env, count, tags, byTag))
|
adamc@144
|
206 | SOME (ek', n') =>
|
adamc@144
|
207 (if ek = ek' then
|
adamc@144
|
208 ()
|
adamc@144
|
209 else
|
adamc@1046
|
210 both (loc, s);
|
adamc@144
|
211 ([], (env, count, tags, byTag)))
|
adamc@112
|
212 end
|
adamc@112
|
213 | _ =>
|
adamc@112
|
214 let
|
adamc@126
|
215 val env' = E.declBinds env d
|
adamc@126
|
216 val env'' = case d' of
|
adamc@126
|
217 DValRec _ => env'
|
adamc@126
|
218 | _ => env
|
adamc@126
|
219
|
adamc@112
|
220 val (d, (count, tags, byTag, newTags)) =
|
adamc@112
|
221 U.Decl.foldMap {kind = kind,
|
adamc@112
|
222 con = con,
|
adamc@126
|
223 exp = exp env'',
|
adamc@112
|
224 decl = decl}
|
adamc@112
|
225 (count, tags, byTag, []) d
|
adamc@110
|
226
|
adamc@126
|
227 val env = env'
|
adamc@110
|
228
|
adamc@126
|
229 val newDs = map
|
adamc@144
|
230 (fn (ek, f, cn) =>
|
adamc@112
|
231 let
|
adamc@492
|
232 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
|
adamc@492
|
233
|
adamc@112
|
234 fun unravel (all as (t, _)) =
|
adamc@112
|
235 case t of
|
adamc@112
|
236 TFun (dom, ran) =>
|
adamc@112
|
237 let
|
adamc@112
|
238 val (args, result) = unravel ran
|
adamc@112
|
239 in
|
adamc@112
|
240 (dom :: args, result)
|
adamc@112
|
241 end
|
adamc@112
|
242 | _ => ([], all)
|
adamc@110
|
243
|
adamc@112
|
244 val (fnam, t, _, tag) = E.lookupENamed env f
|
adamc@112
|
245 val (args, result) = unravel t
|
adamc@110
|
246
|
adamc@119
|
247 val (abs, t) =
|
adamc@119
|
248 case args of
|
adamc@119
|
249 [] =>
|
adamc@119
|
250 let
|
adamc@492
|
251 val app = (EApp ((ENamed f, loc), (ERecord [], loc)), loc)
|
adamc@492
|
252 val body = (EWrite app, loc)
|
adamc@119
|
253 in
|
adamc@492
|
254 (body,
|
adamc@119
|
255 (TFun (unit, unit), loc))
|
adamc@119
|
256 end
|
adamc@119
|
257 | _ =>
|
adamc@119
|
258 let
|
adamc@119
|
259 val (app, _) = foldl (fn (t, (app, n)) =>
|
adamc@119
|
260 ((EApp (app, (ERel n, loc)), loc),
|
adamc@119
|
261 n - 1))
|
adamc@119
|
262 ((ENamed f, loc), length args - 1) args
|
adamc@280
|
263 val app = (EApp (app, (ERecord [], loc)), loc)
|
adamc@119
|
264 val body = (EWrite app, loc)
|
adamc@280
|
265 val t = (TFun (unit, unit), loc)
|
adamc@119
|
266 val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
|
adamc@119
|
267 ((EAbs ("x" ^ Int.toString n,
|
adamc@119
|
268 t,
|
adamc@119
|
269 rest,
|
adamc@119
|
270 abs), loc),
|
adamc@119
|
271 n + 1,
|
adamc@119
|
272 (TFun (t, rest), loc)))
|
adamc@280
|
273 (body, 0, t) args
|
adamc@119
|
274 in
|
adamc@119
|
275 (abs, t)
|
adamc@119
|
276 end
|
adamc@112
|
277 in
|
adamc@126
|
278 (("wrap_" ^ fnam, cn, t, abs, tag),
|
adamc@144
|
279 (DExport (ek, cn), loc))
|
adamc@112
|
280 end) newTags
|
adamc@126
|
281
|
adamc@126
|
282 val (newVals, newExports) = ListPair.unzip newDs
|
adamc@126
|
283
|
adamc@126
|
284 val ds = case d of
|
adamc@126
|
285 (DValRec vis, _) => [(DValRec (vis @ newVals), loc)]
|
adamc@126
|
286 | _ => map (fn vi => (DVal vi, loc)) newVals @ [d]
|
adamc@112
|
287 in
|
adamc@126
|
288 (ds @ newExports, (env, count, tags, byTag))
|
adamc@112
|
289 end
|
adamc@110
|
290
|
adamc@112
|
291 val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty) file
|
adamc@110
|
292 in
|
adamc@110
|
293 file
|
adamc@110
|
294 end
|
adamc@110
|
295
|
adamc@110
|
296 end
|