Mercurial > urweb

annotate src/tag.sml @ 1735:ec47f49c6aa3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
In simplifying constructors for error messages, unfold constructor synonyms from modules
author Adam Chlipala <adam@chlipala.net>
date Wed, 02 May 2012 08:23:30 -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