Mercurial > urweb

annotate src/tag.sml @ 123:e3041657d653

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Parsing and elaborating (non-mutual) 'val rec'
author Adam Chlipala <adamc@hcoop.net>
date Thu, 17 Jul 2008 10:09:34 -0400
parents 7fdc146b2bc2
children fd98dd10dce7
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@112 44 fun exp env (e, s) =
adamc@110 45 case e of
adamc@110 46 EApp (
adamc@110 47 (EApp (
adamc@110 48 (EApp (
adamc@110 49 (ECApp (
adamc@110 50 (ECApp (
adamc@110 51 (ECApp (
adamc@110 52 (ECApp (
adamc@110 53 (EFfi ("Basis", "tag"),
adamc@110 54 loc), given), _), absent), _), outer), _), inner), _),
adamc@110 55 attrs), _),
adamc@110 56 tag), _),
adamc@110 57 xml) =>
adamc@110 58 (case attrs of
adamc@110 59 (ERecord xets, _) =>
adamc@110 60 let
adamc@110 61 val (xets, s) =
adamc@112 62 ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) =>
adamc@110 63 case x of
adamc@110 64 (CName "Link", _) =>
adamc@110 65 let
adamc@110 66 fun unravel (e, _) =
adamc@110 67 case e of
adamc@110 68 ENamed n => (n, [])
adamc@110 69 | EApp (e1, e2) =>
adamc@110 70 let
adamc@110 71 val (n, es) = unravel e1
adamc@110 72 in
adamc@110 73 (n, es @ [e2])
adamc@110 74 end
adamc@110 75 | _ => (ErrorMsg.errorAt loc "Invalid link expression";
adamc@110 76 (0, []))
adamc@110 77
adamc@110 78 val (f, args) = unravel e
adamc@110 79
adamc@110 80 val (cn, count, tags, newTags) =
adamc@110 81 case IM.find (tags, f) of
adamc@110 82 NONE =>
adamc@110 83 (count, count + 1, IM.insert (tags, f, count),
adamc@110 84 (f, count) :: newTags)
adamc@110 85 | SOME cn => (cn, count, tags, newTags)
adamc@110 86
adamc@112 87 val (_, _, _, s) = E.lookupENamed env f
adamc@112 88
adamc@112 89 val byTag = case SM.find (byTag, s) of
adamc@112 90 NONE => SM.insert (byTag, s, f)
adamc@112 91 | SOME f' =>
adamc@112 92 (if f = f' then
adamc@112 93 ()
adamc@112 94 else
adamc@112 95 ErrorMsg.errorAt loc
adamc@112 96 ("Duplicate HTTP tag "
adamc@112 97 ^ s);
adamc@112 98 byTag)
adamc@112 99
adamc@110 100 val e = (EClosure (cn, args), loc)
adamc@110 101 val t = (CFfi ("Basis", "string"), loc)
adamc@110 102 in
adamc@117 103 (((CName "href", loc), e, t),
adamc@112 104 (count, tags, byTag, newTags))
adamc@110 105 end
adamc@112 106 | _ => ((x, e, t), (count, tags, byTag, newTags)))
adamc@110 107 s xets
adamc@110 108 in
adamc@110 109 (EApp (
adamc@110 110 (EApp (
adamc@110 111 (EApp (
adamc@110 112 (ECApp (
adamc@110 113 (ECApp (
adamc@110 114 (ECApp (
adamc@110 115 (ECApp (
adamc@110 116 (EFfi ("Basis", "tag"),
adamc@110 117 loc), given), loc), absent), loc), outer), loc), inner), loc),
adamc@110 118 (ERecord xets, loc)), loc),
adamc@110 119 tag), loc),
adamc@110 120 xml), s)
adamc@110 121 end
adamc@110 122 | _ => (ErrorMsg.errorAt loc "Attribute record is too complex";
adamc@110 123 (e, s)))
adamc@110 124
adamc@110 125 | _ => (e, s)
adamc@110 126
adamc@110 127 fun decl (d, s) = (d, s)
adamc@110 128
adamc@110 129 fun tag file =
adamc@110 130 let
adamc@110 131 val count = foldl (fn ((d, _), count) =>
adamc@110 132 case d of
adamc@110 133 DCon (_, n, _, _) => Int.max (n, count)
adamc@110 134 | DVal (_, n, _, _, _) => Int.max (n, count)
adamc@110 135 | DExport _ => count) 0 file
adamc@110 136
adamc@112 137 fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
adamc@112 138 case d' of
adamc@112 139 DExport n =>
adamc@112 140 let
adamc@112 141 val (_, _, _, s) = E.lookupENamed env n
adamc@112 142 in
adamc@112 143 case SM.find (byTag, s) of
adamc@112 144 NONE => ([d], (env, count, tags, byTag))
adamc@112 145 | SOME n' => ([], (env, count, tags, byTag))
adamc@112 146 end
adamc@112 147 | _ =>
adamc@112 148 let
adamc@112 149 val (d, (count, tags, byTag, newTags)) =
adamc@112 150 U.Decl.foldMap {kind = kind,
adamc@112 151 con = con,
adamc@112 152 exp = exp env,
adamc@112 153 decl = decl}
adamc@112 154 (count, tags, byTag, []) d
adamc@110 155
adamc@112 156 val env = E.declBinds env d
adamc@110 157
adamc@112 158 val newDs = ListUtil.mapConcat
adamc@112 159 (fn (f, cn) =>
adamc@112 160 let
adamc@112 161 fun unravel (all as (t, _)) =
adamc@112 162 case t of
adamc@112 163 TFun (dom, ran) =>
adamc@112 164 let
adamc@112 165 val (args, result) = unravel ran
adamc@112 166 in
adamc@112 167 (dom :: args, result)
adamc@112 168 end
adamc@112 169 | _ => ([], all)
adamc@110 170
adamc@112 171 val (fnam, t, _, tag) = E.lookupENamed env f
adamc@112 172 val (args, result) = unravel t
adamc@110 173
adamc@112 174 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
adamc@119 175
adamc@119 176 val (abs, t) =
adamc@119 177 case args of
adamc@119 178 [] =>
adamc@119 179 let
adamc@119 180 val body = (EWrite (ENamed f, loc), loc)
adamc@119 181 in
adamc@119 182 ((EAbs ("x", unit, unit, body), loc),
adamc@119 183 (TFun (unit, unit), loc))
adamc@119 184 end
adamc@119 185 | _ =>
adamc@119 186 let
adamc@119 187 val (app, _) = foldl (fn (t, (app, n)) =>
adamc@119 188 ((EApp (app, (ERel n, loc)), loc),
adamc@119 189 n - 1))
adamc@119 190 ((ENamed f, loc), length args - 1) args
adamc@119 191 val body = (EWrite app, loc)
adamc@119 192 val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
adamc@119 193 ((EAbs ("x" ^ Int.toString n,
adamc@119 194 t,
adamc@119 195 rest,
adamc@119 196 abs), loc),
adamc@119 197 n + 1,
adamc@119 198 (TFun (t, rest), loc)))
adamc@119 199 (body, 0, unit) args
adamc@119 200 in
adamc@119 201 (abs, t)
adamc@119 202 end
adamc@112 203 in
adamc@112 204 [(DVal ("wrap_" ^ fnam, cn, t, abs, tag), loc),
adamc@112 205 (DExport cn, loc)]
adamc@112 206 end) newTags
adamc@112 207 in
adamc@112 208 (newDs @ [d], (env, count, tags, byTag))
adamc@112 209 end
adamc@110 210
adamc@112 211 val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty) file
adamc@110 212 in
adamc@110 213 file
adamc@110 214 end
adamc@110 215
adamc@110 216 end