Mercurial > urweb

annotate src/tag.sml @ 1721:5df85275c0d4

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