Mercurial > urweb

annotate src/tag.sml @ 1062:3bc726a822fb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Shake bug fix; pattern reduction in ReduceLocal
author Adam Chlipala <adamc@hcoop.net>
date Tue, 08 Dec 2009 11:45:19 -0500
parents a5eb8f87bc17
children 217eb87dde31
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@110 49 case e of
adamc@110 50 EApp (
adamc@110 51 (EApp (
adamc@110 52 (EApp (
adamc@721 53 (EApp (
adamc@110 54 (ECApp (
adamc@110 55 (ECApp (
adamc@110 56 (ECApp (
adamc@140 57 (ECApp (
adamc@140 58 (ECApp (
adamc@140 59 (ECApp (
adamc@140 60 (ECApp (
adamc@721 61 (ECApp (
adamc@721 62 (EFfi ("Basis", "tag"),
adamc@721 63 loc), given), _), absent), _), outer), _), inner), _),
adamc@721 64 useOuter), _), useInner), _), bindOuter), _), bindInner), _),
adamc@721 65 class), _),
adamc@110 66 attrs), _),
adamc@110 67 tag), _),
adamc@110 68 xml) =>
adamc@110 69 (case attrs of
adamc@110 70 (ERecord xets, _) =>
adamc@110 71 let
adamc@110 72 val (xets, s) =
adamc@112 73 ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) =>
adamc@143 74 let
adamc@144 75 fun tagIt (ek, newAttr) =
adamc@143 76 let
adamc@1062 77 val eOrig = e
adamc@1062 78
adamc@143 79 fun unravel (e, _) =
adamc@143 80 case e of
adamc@143 81 ENamed n => (n, [])
adamc@143 82 | EApp (e1, e2) =>
adamc@143 83 let
adamc@143 84 val (n, es) = unravel e1
adamc@143 85 in
adamc@143 86 (n, es @ [e2])
adamc@143 87 end
adamc@1062 88 | _ => (ErrorMsg.errorAt loc ("Invalid " ^ newAttr
adamc@1062 89 ^ " expression");
adamc@1062 90 Print.epreface ("Expression",
adamc@1062 91 CorePrint.p_exp CoreEnv.empty eOrig);
adamc@143 92 (0, []))
adamc@110 93
adamc@143 94 val (f, args) = unravel e
adamc@112 95
adamc@143 96 val (cn, count, tags, newTags) =
adamc@143 97 case IM.find (tags, f) of
adamc@143 98 NONE =>
adamc@143 99 (count, count + 1, IM.insert (tags, f, count),
adamc@144 100 (ek, f, count) :: newTags)
adamc@143 101 | SOME cn => (cn, count, tags, newTags)
adamc@143 102
adamc@143 103 val (_, _, _, s) = E.lookupENamed env f
adamc@112 104
adamc@143 105 val byTag = case SM.find (byTag, s) of
adamc@144 106 NONE => SM.insert (byTag, s, (ek, f))
adamc@144 107 | SOME (ek', f') =>
adamc@143 108 (if f = f' then
adamc@143 109 ()
adamc@143 110 else
adamc@143 111 ErrorMsg.errorAt loc
adamc@143 112 ("Duplicate HTTP tag "
adamc@143 113 ^ s);
adamc@144 114 if ek = ek' then
adamc@144 115 ()
adamc@144 116 else
adamc@1046 117 both (loc, s);
adamc@143 118 byTag)
adamc@143 119
adamc@143 120 val e = (EClosure (cn, args), loc)
adamc@143 121 val t = (CFfi ("Basis", "string"), loc)
adamc@143 122 in
adamc@143 123 (((CName newAttr, loc), e, t),
adamc@143 124 (count, tags, byTag, newTags))
adamc@143 125 end
adamc@143 126 in
adamc@143 127 case x of
adamc@907 128 (CName "Link", _) => tagIt (Link, "Link")
adamc@731 129 | (CName "Action", _) => tagIt (Action ReadWrite, "Action")
adamc@143 130 | _ => ((x, e, t), (count, tags, byTag, newTags))
adamc@143 131 end)
adamc@110 132 s xets
adamc@110 133 in
adamc@110 134 (EApp (
adamc@110 135 (EApp (
adamc@110 136 (EApp (
adamc@721 137 (EApp (
adamc@110 138 (ECApp (
adamc@110 139 (ECApp (
adamc@110 140 (ECApp (
adamc@140 141 (ECApp (
adamc@140 142 (ECApp (
adamc@140 143 (ECApp (
adamc@140 144 (ECApp (
adamc@721 145 (ECApp (
adamc@721 146 (EFfi ("Basis", "tag"),
adamc@721 147 loc), given), loc), absent), loc), outer), loc), inner), loc),
adamc@721 148 useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc),
adamc@721 149 class), loc),
adamc@110 150 (ERecord xets, loc)), loc),
adamc@110 151 tag), loc),
adamc@110 152 xml), s)
adamc@110 153 end
adamc@110 154 | _ => (ErrorMsg.errorAt loc "Attribute record is too complex";
adamc@110 155 (e, s)))
adamc@110 156
adamc@110 157 | _ => (e, s)
adamc@110 158
adamc@110 159 fun decl (d, s) = (d, s)
adamc@110 160
adamc@110 161 fun tag file =
adamc@110 162 let
adamc@179 163 val count = U.File.maxName file
adamc@110 164
adamc@112 165 fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
adamc@112 166 case d' of
adamc@144 167 DExport (ek, n) =>
adamc@112 168 let
adamc@112 169 val (_, _, _, s) = E.lookupENamed env n
adamc@112 170 in
adamc@112 171 case SM.find (byTag, s) of
adamc@112 172 NONE => ([d], (env, count, tags, byTag))
adamc@144 173 | SOME (ek', n') =>
adamc@144 174 (if ek = ek' then
adamc@144 175 ()
adamc@144 176 else
adamc@1046 177 both (loc, s);
adamc@144 178 ([], (env, count, tags, byTag)))
adamc@112 179 end
adamc@112 180 | _ =>
adamc@112 181 let
adamc@126 182 val env' = E.declBinds env d
adamc@126 183 val env'' = case d' of
adamc@126 184 DValRec _ => env'
adamc@126 185 | _ => env
adamc@126 186
adamc@112 187 val (d, (count, tags, byTag, newTags)) =
adamc@112 188 U.Decl.foldMap {kind = kind,
adamc@112 189 con = con,
adamc@126 190 exp = exp env'',
adamc@112 191 decl = decl}
adamc@112 192 (count, tags, byTag, []) d
adamc@110 193
adamc@126 194 val env = env'
adamc@110 195
adamc@126 196 val newDs = map
adamc@144 197 (fn (ek, f, cn) =>
adamc@112 198 let
adamc@492 199 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
adamc@492 200
adamc@112 201 fun unravel (all as (t, _)) =
adamc@112 202 case t of
adamc@112 203 TFun (dom, ran) =>
adamc@112 204 let
adamc@112 205 val (args, result) = unravel ran
adamc@112 206 in
adamc@112 207 (dom :: args, result)
adamc@112 208 end
adamc@112 209 | _ => ([], all)
adamc@110 210
adamc@112 211 val (fnam, t, _, tag) = E.lookupENamed env f
adamc@112 212 val (args, result) = unravel t
adamc@110 213
adamc@119 214 val (abs, t) =
adamc@119 215 case args of
adamc@119 216 [] =>
adamc@119 217 let
adamc@492 218 val app = (EApp ((ENamed f, loc), (ERecord [], loc)), loc)
adamc@492 219 val body = (EWrite app, loc)
adamc@119 220 in
adamc@492 221 (body,
adamc@119 222 (TFun (unit, unit), loc))
adamc@119 223 end
adamc@119 224 | _ =>
adamc@119 225 let
adamc@119 226 val (app, _) = foldl (fn (t, (app, n)) =>
adamc@119 227 ((EApp (app, (ERel n, loc)), loc),
adamc@119 228 n - 1))
adamc@119 229 ((ENamed f, loc), length args - 1) args
adamc@280 230 val app = (EApp (app, (ERecord [], loc)), loc)
adamc@119 231 val body = (EWrite app, loc)
adamc@280 232 val t = (TFun (unit, unit), loc)
adamc@119 233 val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
adamc@119 234 ((EAbs ("x" ^ Int.toString n,
adamc@119 235 t,
adamc@119 236 rest,
adamc@119 237 abs), loc),
adamc@119 238 n + 1,
adamc@119 239 (TFun (t, rest), loc)))
adamc@280 240 (body, 0, t) args
adamc@119 241 in
adamc@119 242 (abs, t)
adamc@119 243 end
adamc@112 244 in
adamc@126 245 (("wrap_" ^ fnam, cn, t, abs, tag),
adamc@144 246 (DExport (ek, cn), loc))
adamc@112 247 end) newTags
adamc@126 248
adamc@126 249 val (newVals, newExports) = ListPair.unzip newDs
adamc@126 250
adamc@126 251 val ds = case d of
adamc@126 252 (DValRec vis, _) => [(DValRec (vis @ newVals), loc)]
adamc@126 253 | _ => map (fn vi => (DVal vi, loc)) newVals @ [d]
adamc@112 254 in
adamc@126 255 (ds @ newExports, (env, count, tags, byTag))
adamc@112 256 end
adamc@110 257
adamc@112 258 val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty) file
adamc@110 259 in
adamc@110 260 file
adamc@110 261 end
adamc@110 262
adamc@110 263 end