Mercurial > urweb

annotate src/tag.sml @ 1550:daf71c76707e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Postgres deadlock triggers unlimited retry
author Adam Chlipala <adam@chlipala.net>
date Sun, 28 Aug 2011 14:01:41 -0400
parents 44a12a321150
children 3621f486ce72
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",
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@1271 163 | _ => (e, s))
adamc@110 164
adamc@1065 165 | EFfiApp ("Basis", "url", [(ERel 0, _)]) => (e, s)
adamc@1065 166
adamc@1065 167 | EFfiApp ("Basis", "url", [e]) =>
adamc@1065 168 let
adamc@1065 169 val (e, s) = tagIt (e, Link, "Url", s)
adamc@1065 170 in
adamc@1067 171 (EFfiApp ("Basis", "url", [e]), s)
adamc@1065 172 end
adamc@1065 173
adam@1370 174 | EFfiApp ("Basis", "effectfulUrl", [(ERel 0, _)]) => (e, s)
adam@1370 175
adam@1370 176 | EFfiApp ("Basis", "effectfulUrl", [e]) =>
adam@1370 177 let
adam@1370 178 val (e, s) = tagIt (e, Extern ReadCookieWrite, "Url", s)
adam@1370 179 in
adam@1370 180 (EFfiApp ("Basis", "url", [e]), s)
adam@1370 181 end
adam@1370 182
adamc@1065 183 | EApp ((ENamed n, _), e') =>
adamc@1065 184 let
adamc@1065 185 val (_, _, eo, _) = E.lookupENamed env n
adamc@1065 186 in
adamc@1065 187 case eo of
adamc@1065 188 SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [(ERel 0, _)]), _)), _) =>
adamc@1065 189 let
adamc@1065 190 val (e, s) = tagIt (e', Link, "Url", s)
adamc@1065 191 in
adamc@1067 192 (EFfiApp ("Basis", "url", [e]), s)
adamc@1065 193 end
adamc@1065 194 | _ => (e, s)
adamc@1065 195 end
adamc@1065 196
adamc@1065 197 | _ => (e, s)
adamc@1065 198 end
adamc@110 199
adamc@110 200 fun decl (d, s) = (d, s)
adamc@110 201
adamc@110 202 fun tag file =
adamc@110 203 let
adamc@179 204 val count = U.File.maxName file
adamc@110 205
adamc@112 206 fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
adamc@112 207 case d' of
adamc@1104 208 DExport (ek, n, _) =>
adamc@112 209 let
adamc@112 210 val (_, _, _, s) = E.lookupENamed env n
adamc@112 211 in
adamc@112 212 case SM.find (byTag, s) of
adamc@112 213 NONE => ([d], (env, count, tags, byTag))
adamc@144 214 | SOME (ek', n') =>
adamc@144 215 (if ek = ek' then
adamc@144 216 ()
adamc@144 217 else
adamc@1046 218 both (loc, s);
adamc@144 219 ([], (env, count, tags, byTag)))
adamc@112 220 end
adamc@112 221 | _ =>
adamc@112 222 let
adamc@126 223 val env' = E.declBinds env d
adamc@126 224 val env'' = case d' of
adamc@126 225 DValRec _ => env'
adamc@126 226 | _ => env
adamc@126 227
adamc@112 228 val (d, (count, tags, byTag, newTags)) =
adamc@112 229 U.Decl.foldMap {kind = kind,
adamc@112 230 con = con,
adamc@126 231 exp = exp env'',
adamc@112 232 decl = decl}
adamc@112 233 (count, tags, byTag, []) d
adamc@110 234
adamc@126 235 val env = env'
adamc@110 236
adamc@126 237 val newDs = map
adamc@144 238 (fn (ek, f, cn) =>
adamc@112 239 let
adamc@492 240 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
adamc@492 241
adamc@112 242 fun unravel (all as (t, _)) =
adamc@112 243 case t of
adamc@112 244 TFun (dom, ran) =>
adamc@112 245 let
adamc@112 246 val (args, result) = unravel ran
adamc@112 247 in
adamc@112 248 (dom :: args, result)
adamc@112 249 end
adamc@112 250 | _ => ([], all)
adamc@110 251
adamc@112 252 val (fnam, t, _, tag) = E.lookupENamed env f
adamc@112 253 val (args, result) = unravel t
adamc@110 254
adamc@119 255 val (abs, t) =
adamc@119 256 case args of
adamc@119 257 [] =>
adamc@119 258 let
adamc@492 259 val app = (EApp ((ENamed f, loc), (ERecord [], loc)), loc)
adamc@492 260 val body = (EWrite app, loc)
adamc@119 261 in
adamc@492 262 (body,
adamc@119 263 (TFun (unit, unit), loc))
adamc@119 264 end
adamc@119 265 | _ =>
adamc@119 266 let
adamc@119 267 val (app, _) = foldl (fn (t, (app, n)) =>
adamc@119 268 ((EApp (app, (ERel n, loc)), loc),
adamc@119 269 n - 1))
adamc@119 270 ((ENamed f, loc), length args - 1) args
adamc@280 271 val app = (EApp (app, (ERecord [], loc)), loc)
adamc@119 272 val body = (EWrite app, loc)
adamc@280 273 val t = (TFun (unit, unit), loc)
adamc@119 274 val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
adamc@119 275 ((EAbs ("x" ^ Int.toString n,
adamc@119 276 t,
adamc@119 277 rest,
adamc@119 278 abs), loc),
adamc@119 279 n + 1,
adamc@119 280 (TFun (t, rest), loc)))
adamc@280 281 (body, 0, t) args
adamc@119 282 in
adamc@119 283 (abs, t)
adamc@119 284 end
adamc@112 285 in
adamc@126 286 (("wrap_" ^ fnam, cn, t, abs, tag),
adamc@1104 287 (DExport (ek, cn, false), loc))
adamc@112 288 end) newTags
adamc@126 289
adamc@126 290 val (newVals, newExports) = ListPair.unzip newDs
adamc@126 291
adamc@126 292 val ds = case d of
adamc@126 293 (DValRec vis, _) => [(DValRec (vis @ newVals), loc)]
adamc@126 294 | _ => map (fn vi => (DVal vi, loc)) newVals @ [d]
adamc@112 295 in
adamc@126 296 (ds @ newExports, (env, count, tags, byTag))
adamc@112 297 end
adamc@110 298
adamc@112 299 val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty) file
adamc@110 300 in
adamc@110 301 file
adamc@110 302 end
adamc@110 303
adamc@110 304 end