Mercurial > urweb

annotate src/tag.sml @ 2112:b4702145f8de

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Treat getHeader and getenv as vectors for reading request data supplied implicitly by browsers
author Adam Chlipala <adam@chlipala.net>
date Thu, 05 Feb 2015 11:09:25 -0500
parents f1485ed65d6c
children
rev   line source
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
adam@1946 44 fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for multiple modes (link, form, RPC handler).");
adamc@1046 45 TextIO.output (TextIO.stdErr,
adam@1946 46 "Make sure that the signature of the containing module hides any form/RPC 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",
adam@1628 68 CorePrint.p_exp env eOrig);
adamc@1065 69 (0, []))
adamc@1065 70
adamc@1065 71 val (f, args) = unravel e
adam@1628 72 in
adam@1628 73 if f = 0 then
adam@1628 74 (e, (count, tags, byTag, newTags))
adam@1628 75 else
adam@1628 76 let
adam@1628 77 val (cn, count, tags, newTags) =
adam@1628 78 case IM.find (tags, f) of
adam@1628 79 NONE =>
adam@1628 80 (count, count + 1, IM.insert (tags, f, count),
adam@1628 81 (ek, f, count) :: newTags)
adam@1628 82 | SOME cn => (cn, count, tags, newTags)
adam@1628 83
adam@1628 84 val (_, _, _, s) = E.lookupENamed env f
adamc@1065 85
adam@1628 86 val byTag = case SM.find (byTag, s) of
adam@1628 87 NONE => SM.insert (byTag, s, (ek, f))
adam@1628 88 | SOME (ek', f') =>
adam@1628 89 (if f = f' then
adam@1628 90 ()
adam@1628 91 else
adam@1628 92 ErrorMsg.errorAt loc
adam@1628 93 ("Duplicate HTTP tag "
adam@1628 94 ^ s);
adam@1628 95 if ek = ek' then
adam@1628 96 ()
adam@1628 97 else
adam@1628 98 both (loc, s);
adam@1628 99 byTag)
adamc@1065 100
adam@1628 101 val e = (EClosure (cn, args), loc)
adam@1628 102 in
adam@1628 103 (e, (count, tags, byTag, newTags))
adam@1628 104 end
adamc@1065 105 end
adamc@1065 106 in
adamc@1065 107 case e of
adamc@1065 108 EApp (
adamc@1065 109 (EApp (
adamc@1065 110 (EApp (
adamc@1065 111 (EApp (
adam@1646 112 (EApp (
adam@1754 113 (EApp (
adam@1754 114 (EApp (
adamc@721 115 (ECApp (
adamc@1065 116 (ECApp (
adamc@1065 117 (ECApp (
adamc@110 118 (ECApp (
adamc@110 119 (ECApp (
adam@1646 120 (ECApp (
adam@1754 121 (ECApp (
adam@1754 122 (ECApp (
adam@1754 123 (EFfi ("Basis", "tag"),
adam@1754 124 loc), given), _), absent), _), outer), _), inner), _),
adam@1754 125 useOuter), _), useInner), _), bindOuter), _), bindInner), _),
adam@1754 126 class), _),
adam@1754 127 dynClass), _),
adam@1754 128 style), _),
adam@1754 129 dynStyle), _),
adamc@1065 130 attrs), _),
adamc@1065 131 tag), _),
adamc@1065 132 xml) =>
adamc@1065 133 (case attrs of
adamc@1065 134 (ERecord xets, _) =>
adamc@1065 135 let
adamc@1065 136 val (xets, s) =
adamc@1065 137 ListUtil.foldlMap (fn ((x, e, t), s) =>
adamc@1065 138 let
adamc@1065 139 fun tagIt' (ek, newAttr) =
adamc@1065 140 let
adamc@1065 141 val (e', s) = tagIt (e, ek, newAttr, s)
adamc@1065 142 val t = (CFfi ("Basis", "string"), loc)
adamc@1065 143 in
adamc@1065 144 (((CName newAttr, loc), e', t), s)
adamc@1065 145 end
adamc@1065 146 in
adamc@1065 147 case x of
adam@1946 148 (CName "Link", _) => tagIt' (Link ReadCookieWrite, "Link")
adamc@1065 149 | (CName "Action", _) => tagIt' (Action ReadWrite, "Action")
adamc@1065 150 | _ => ((x, e, t), s)
adamc@1065 151 end)
adamc@1065 152 s xets
adamc@1065 153 in
adamc@1065 154 (EApp (
adamc@1065 155 (EApp (
adamc@1065 156 (EApp (
adamc@1065 157 (EApp (
adam@1646 158 (EApp (
adam@1754 159 (EApp (
adam@1754 160 (EApp (
adamc@721 161 (ECApp (
adamc@1065 162 (ECApp (
adamc@1065 163 (ECApp (
adamc@1065 164 (ECApp (
adamc@1065 165 (ECApp (
adam@1646 166 (ECApp (
adam@1754 167 (ECApp (
adam@1754 168 (ECApp (
adam@1754 169 (EFfi ("Basis", "tag"),
adam@1754 170 loc), given), loc), absent), loc), outer), loc), inner), loc),
adam@1754 171 useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc),
adam@1754 172 class), loc), dynClass), loc), style), loc), dynStyle), loc),
adamc@1065 173 (ERecord xets, loc)), loc),
adamc@1065 174 tag), loc),
adamc@1065 175 xml), s)
adamc@1065 176 end
adamc@1271 177 | _ => (e, s))
adamc@110 178
adam@1663 179 | EFfiApp ("Basis", "url", [((ERel 0, _), _)]) => (e, s)
adamc@1065 180
adam@1663 181 | EFfiApp ("Basis", "url", [(e, t)]) =>
adamc@1065 182 let
adam@1946 183 val (e, s) = tagIt (e, Link ReadCookieWrite, "Url", s)
adamc@1065 184 in
adam@1663 185 (EFfiApp ("Basis", "url", [(e, t)]), s)
adamc@1065 186 end
adamc@1065 187
adam@1663 188 | EFfiApp ("Basis", "effectfulUrl", [((ERel 0, _), _)]) => (e, s)
adam@1370 189
adam@1663 190 | EFfiApp ("Basis", "effectfulUrl", [(e, t)]) =>
adam@1370 191 let
adam@1370 192 val (e, s) = tagIt (e, Extern ReadCookieWrite, "Url", s)
adam@1370 193 in
adam@1663 194 (EFfiApp ("Basis", "url", [(e, t)]), s)
adam@1370 195 end
adam@1370 196
adamc@1065 197 | EApp ((ENamed n, _), e') =>
adamc@1065 198 let
adamc@1065 199 val (_, _, eo, _) = E.lookupENamed env n
adamc@1065 200 in
adamc@1065 201 case eo of
adam@1663 202 SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [((ERel 0, _), t)]), _)), _) =>
adamc@1065 203 let
adam@1946 204 val (e, s) = tagIt (e', Link ReadCookieWrite, "Url", s)
adamc@1065 205 in
adam@1663 206 (EFfiApp ("Basis", "url", [(e, t)]), s)
adamc@1065 207 end
adamc@1065 208 | _ => (e, s)
adamc@1065 209 end
adamc@1065 210
adamc@1065 211 | _ => (e, s)
adamc@1065 212 end
adamc@110 213
adamc@110 214 fun decl (d, s) = (d, s)
adamc@110 215
adamc@110 216 fun tag file =
adamc@110 217 let
adamc@179 218 val count = U.File.maxName file
adamc@110 219
adamc@112 220 fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
adamc@112 221 case d' of
adamc@1104 222 DExport (ek, n, _) =>
adamc@112 223 let
adamc@112 224 val (_, _, _, s) = E.lookupENamed env n
adamc@112 225 in
adamc@112 226 case SM.find (byTag, s) of
adamc@112 227 NONE => ([d], (env, count, tags, byTag))
adamc@144 228 | SOME (ek', n') =>
adamc@144 229 (if ek = ek' then
adamc@144 230 ()
adamc@144 231 else
adamc@1046 232 both (loc, s);
adamc@144 233 ([], (env, count, tags, byTag)))
adamc@112 234 end
adamc@112 235 | _ =>
adamc@112 236 let
adamc@126 237 val env' = E.declBinds env d
adamc@126 238 val env'' = case d' of
adamc@126 239 DValRec _ => env'
adamc@126 240 | _ => env
adamc@126 241
adamc@112 242 val (d, (count, tags, byTag, newTags)) =
adamc@112 243 U.Decl.foldMap {kind = kind,
adamc@112 244 con = con,
adamc@126 245 exp = exp env'',
adamc@112 246 decl = decl}
adamc@112 247 (count, tags, byTag, []) d
adamc@110 248
adamc@126 249 val env = env'
adamc@110 250
adamc@126 251 val newDs = map
adamc@144 252 (fn (ek, f, cn) =>
adamc@112 253 let
adamc@492 254 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
adamc@492 255
adamc@112 256 fun unravel (all as (t, _)) =
adamc@112 257 case t of
adamc@112 258 TFun (dom, ran) =>
adamc@112 259 let
adamc@112 260 val (args, result) = unravel ran
adamc@112 261 in
adamc@112 262 (dom :: args, result)
adamc@112 263 end
adamc@112 264 | _ => ([], all)
adamc@110 265
adamc@112 266 val (fnam, t, _, tag) = E.lookupENamed env f
adamc@112 267 val (args, result) = unravel t
adamc@110 268
adamc@119 269 val (abs, t) =
adamc@119 270 case args of
adamc@119 271 [] =>
adamc@119 272 let
adamc@492 273 val app = (EApp ((ENamed f, loc), (ERecord [], loc)), loc)
adamc@492 274 val body = (EWrite app, loc)
adamc@119 275 in
adamc@492 276 (body,
adamc@119 277 (TFun (unit, unit), loc))
adamc@119 278 end
adamc@119 279 | _ =>
adamc@119 280 let
adamc@119 281 val (app, _) = foldl (fn (t, (app, n)) =>
adamc@119 282 ((EApp (app, (ERel n, loc)), loc),
adamc@119 283 n - 1))
adamc@119 284 ((ENamed f, loc), length args - 1) args
adamc@280 285 val app = (EApp (app, (ERecord [], loc)), loc)
adamc@119 286 val body = (EWrite app, loc)
adamc@280 287 val t = (TFun (unit, unit), loc)
adamc@119 288 val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
adamc@119 289 ((EAbs ("x" ^ Int.toString n,
adamc@119 290 t,
adamc@119 291 rest,
adamc@119 292 abs), loc),
adamc@119 293 n + 1,
adamc@119 294 (TFun (t, rest), loc)))
adamc@280 295 (body, 0, t) args
adamc@119 296 in
adamc@119 297 (abs, t)
adamc@119 298 end
adamc@112 299 in
adamc@126 300 (("wrap_" ^ fnam, cn, t, abs, tag),
adamc@1104 301 (DExport (ek, cn, false), loc))
adamc@112 302 end) newTags
adamc@126 303
adamc@126 304 val (newVals, newExports) = ListPair.unzip newDs
adamc@126 305
adamc@126 306 val ds = case d of
adamc@126 307 (DValRec vis, _) => [(DValRec (vis @ newVals), loc)]
adamc@126 308 | _ => map (fn vi => (DVal vi, loc)) newVals @ [d]
adamc@112 309 in
adamc@126 310 (ds @ newExports, (env, count, tags, byTag))
adamc@112 311 end
adamc@110 312
adamc@112 313 val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty) file
adamc@110 314 in
adamc@110 315 file
adamc@110 316 end
adamc@110 317
adamc@110 318 end