Mercurial > urweb

annotate src/tag.sml @ 1327:1cc67fdac4d3

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