Mercurial > urweb

annotate src/tag.sml @ 1628:3621f486ce72

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Don't crash on invalid URL head terms during Tag
author Adam Chlipala <adam@chlipala.net>
date Sat, 03 Dec 2011 17:25:51 -0500
parents 44a12a321150
children ca3b73a7b4d0
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
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",
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 (
adamc@140 112 (ECApp (
adamc@140 113 (ECApp (
adamc@140 114 (ECApp (
adamc@721 115 (ECApp (
adamc@1065 116 (ECApp (
adamc@1065 117 (ECApp (
adamc@110 118 (ECApp (
adamc@110 119 (ECApp (
adamc@1065 120 (EFfi ("Basis", "tag"),
adamc@1065 121 loc), given), _), absent), _), outer), _), inner), _),
adamc@1065 122 useOuter), _), useInner), _), bindOuter), _), bindInner), _),
adamc@1065 123 class), _),
adamc@1065 124 attrs), _),
adamc@1065 125 tag), _),
adamc@1065 126 xml) =>
adamc@1065 127 (case attrs of
adamc@1065 128 (ERecord xets, _) =>
adamc@1065 129 let
adamc@1065 130 val (xets, s) =
adamc@1065 131 ListUtil.foldlMap (fn ((x, e, t), s) =>
adamc@1065 132 let
adamc@1065 133 fun tagIt' (ek, newAttr) =
adamc@1065 134 let
adamc@1065 135 val (e', s) = tagIt (e, ek, newAttr, s)
adamc@1065 136 val t = (CFfi ("Basis", "string"), loc)
adamc@1065 137 in
adamc@1065 138 (((CName newAttr, loc), e', t), s)
adamc@1065 139 end
adamc@1065 140 in
adamc@1065 141 case x of
adamc@1065 142 (CName "Link", _) => tagIt' (Link, "Link")
adamc@1065 143 | (CName "Action", _) => tagIt' (Action ReadWrite, "Action")
adamc@1065 144 | _ => ((x, e, t), s)
adamc@1065 145 end)
adamc@1065 146 s xets
adamc@1065 147 in
adamc@1065 148 (EApp (
adamc@1065 149 (EApp (
adamc@1065 150 (EApp (
adamc@1065 151 (EApp (
adamc@140 152 (ECApp (
adamc@140 153 (ECApp (
adamc@140 154 (ECApp (
adamc@721 155 (ECApp (
adamc@1065 156 (ECApp (
adamc@1065 157 (ECApp (
adamc@1065 158 (ECApp (
adamc@1065 159 (ECApp (
adamc@1065 160 (EFfi ("Basis", "tag"),
adamc@1065 161 loc), given), loc), absent), loc), outer), loc), inner), loc),
adamc@1065 162 useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc),
adamc@1065 163 class), loc),
adamc@1065 164 (ERecord xets, loc)), loc),
adamc@1065 165 tag), loc),
adamc@1065 166 xml), s)
adamc@1065 167 end
adamc@1271 168 | _ => (e, s))
adamc@110 169
adamc@1065 170 | EFfiApp ("Basis", "url", [(ERel 0, _)]) => (e, s)
adamc@1065 171
adamc@1065 172 | EFfiApp ("Basis", "url", [e]) =>
adamc@1065 173 let
adamc@1065 174 val (e, s) = tagIt (e, Link, "Url", s)
adamc@1065 175 in
adamc@1067 176 (EFfiApp ("Basis", "url", [e]), s)
adamc@1065 177 end
adamc@1065 178
adam@1370 179 | EFfiApp ("Basis", "effectfulUrl", [(ERel 0, _)]) => (e, s)
adam@1370 180
adam@1370 181 | EFfiApp ("Basis", "effectfulUrl", [e]) =>
adam@1370 182 let
adam@1370 183 val (e, s) = tagIt (e, Extern ReadCookieWrite, "Url", s)
adam@1370 184 in
adam@1370 185 (EFfiApp ("Basis", "url", [e]), s)
adam@1370 186 end
adam@1370 187
adamc@1065 188 | EApp ((ENamed n, _), e') =>
adamc@1065 189 let
adamc@1065 190 val (_, _, eo, _) = E.lookupENamed env n
adamc@1065 191 in
adamc@1065 192 case eo of
adamc@1065 193 SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [(ERel 0, _)]), _)), _) =>
adamc@1065 194 let
adamc@1065 195 val (e, s) = tagIt (e', Link, "Url", s)
adamc@1065 196 in
adamc@1067 197 (EFfiApp ("Basis", "url", [e]), s)
adamc@1065 198 end
adamc@1065 199 | _ => (e, s)
adamc@1065 200 end
adamc@1065 201
adamc@1065 202 | _ => (e, s)
adamc@1065 203 end
adamc@110 204
adamc@110 205 fun decl (d, s) = (d, s)
adamc@110 206
adamc@110 207 fun tag file =
adamc@110 208 let
adamc@179 209 val count = U.File.maxName file
adamc@110 210
adamc@112 211 fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
adamc@112 212 case d' of
adamc@1104 213 DExport (ek, n, _) =>
adamc@112 214 let
adamc@112 215 val (_, _, _, s) = E.lookupENamed env n
adamc@112 216 in
adamc@112 217 case SM.find (byTag, s) of
adamc@112 218 NONE => ([d], (env, count, tags, byTag))
adamc@144 219 | SOME (ek', n') =>
adamc@144 220 (if ek = ek' then
adamc@144 221 ()
adamc@144 222 else
adamc@1046 223 both (loc, s);
adamc@144 224 ([], (env, count, tags, byTag)))
adamc@112 225 end
adamc@112 226 | _ =>
adamc@112 227 let
adamc@126 228 val env' = E.declBinds env d
adamc@126 229 val env'' = case d' of
adamc@126 230 DValRec _ => env'
adamc@126 231 | _ => env
adamc@126 232
adamc@112 233 val (d, (count, tags, byTag, newTags)) =
adamc@112 234 U.Decl.foldMap {kind = kind,
adamc@112 235 con = con,
adamc@126 236 exp = exp env'',
adamc@112 237 decl = decl}
adamc@112 238 (count, tags, byTag, []) d
adamc@110 239
adamc@126 240 val env = env'
adamc@110 241
adamc@126 242 val newDs = map
adamc@144 243 (fn (ek, f, cn) =>
adamc@112 244 let
adamc@492 245 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
adamc@492 246
adamc@112 247 fun unravel (all as (t, _)) =
adamc@112 248 case t of
adamc@112 249 TFun (dom, ran) =>
adamc@112 250 let
adamc@112 251 val (args, result) = unravel ran
adamc@112 252 in
adamc@112 253 (dom :: args, result)
adamc@112 254 end
adamc@112 255 | _ => ([], all)
adamc@110 256
adamc@112 257 val (fnam, t, _, tag) = E.lookupENamed env f
adamc@112 258 val (args, result) = unravel t
adamc@110 259
adamc@119 260 val (abs, t) =
adamc@119 261 case args of
adamc@119 262 [] =>
adamc@119 263 let
adamc@492 264 val app = (EApp ((ENamed f, loc), (ERecord [], loc)), loc)
adamc@492 265 val body = (EWrite app, loc)
adamc@119 266 in
adamc@492 267 (body,
adamc@119 268 (TFun (unit, unit), loc))
adamc@119 269 end
adamc@119 270 | _ =>
adamc@119 271 let
adamc@119 272 val (app, _) = foldl (fn (t, (app, n)) =>
adamc@119 273 ((EApp (app, (ERel n, loc)), loc),
adamc@119 274 n - 1))
adamc@119 275 ((ENamed f, loc), length args - 1) args
adamc@280 276 val app = (EApp (app, (ERecord [], loc)), loc)
adamc@119 277 val body = (EWrite app, loc)
adamc@280 278 val t = (TFun (unit, unit), loc)
adamc@119 279 val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
adamc@119 280 ((EAbs ("x" ^ Int.toString n,
adamc@119 281 t,
adamc@119 282 rest,
adamc@119 283 abs), loc),
adamc@119 284 n + 1,
adamc@119 285 (TFun (t, rest), loc)))
adamc@280 286 (body, 0, t) args
adamc@119 287 in
adamc@119 288 (abs, t)
adamc@119 289 end
adamc@112 290 in
adamc@126 291 (("wrap_" ^ fnam, cn, t, abs, tag),
adamc@1104 292 (DExport (ek, cn, false), loc))
adamc@112 293 end) newTags
adamc@126 294
adamc@126 295 val (newVals, newExports) = ListPair.unzip newDs
adamc@126 296
adamc@126 297 val ds = case d of
adamc@126 298 (DValRec vis, _) => [(DValRec (vis @ newVals), loc)]
adamc@126 299 | _ => map (fn vi => (DVal vi, loc)) newVals @ [d]
adamc@112 300 in
adamc@126 301 (ds @ newExports, (env, count, tags, byTag))
adamc@112 302 end
adamc@110 303
adamc@112 304 val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty) file
adamc@110 305 in
adamc@110 306 file
adamc@110 307 end
adamc@110 308
adamc@110 309 end