Mercurial > urweb

annotate src/tag.sml @ 110:3739af9e727a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Starting with closure links
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 11:43:57 -0400
parents
children 2d6116de9cca
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@110 36
adamc@110 37 fun kind (k, s) = (k, s)
adamc@110 38 fun con (c, s) = (c, s)
adamc@110 39
adamc@110 40 fun exp (e, s) =
adamc@110 41 case e of
adamc@110 42 EApp (
adamc@110 43 (EApp (
adamc@110 44 (EApp (
adamc@110 45 (ECApp (
adamc@110 46 (ECApp (
adamc@110 47 (ECApp (
adamc@110 48 (ECApp (
adamc@110 49 (EFfi ("Basis", "tag"),
adamc@110 50 loc), given), _), absent), _), outer), _), inner), _),
adamc@110 51 attrs), _),
adamc@110 52 tag), _),
adamc@110 53 xml) =>
adamc@110 54 (case attrs of
adamc@110 55 (ERecord xets, _) =>
adamc@110 56 let
adamc@110 57 val (xets, s) =
adamc@110 58 ListUtil.foldlMap (fn ((x, e, t), (count, tags, newTags)) =>
adamc@110 59 case x of
adamc@110 60 (CName "Link", _) =>
adamc@110 61 let
adamc@110 62 fun unravel (e, _) =
adamc@110 63 case e of
adamc@110 64 ENamed n => (n, [])
adamc@110 65 | EApp (e1, e2) =>
adamc@110 66 let
adamc@110 67 val (n, es) = unravel e1
adamc@110 68 in
adamc@110 69 (n, es @ [e2])
adamc@110 70 end
adamc@110 71 | _ => (ErrorMsg.errorAt loc "Invalid link expression";
adamc@110 72 (0, []))
adamc@110 73
adamc@110 74 val (f, args) = unravel e
adamc@110 75
adamc@110 76 val (cn, count, tags, newTags) =
adamc@110 77 case IM.find (tags, f) of
adamc@110 78 NONE =>
adamc@110 79 (count, count + 1, IM.insert (tags, f, count),
adamc@110 80 (f, count) :: newTags)
adamc@110 81 | SOME cn => (cn, count, tags, newTags)
adamc@110 82
adamc@110 83 val e = (EClosure (cn, args), loc)
adamc@110 84 val t = (CFfi ("Basis", "string"), loc)
adamc@110 85 in
adamc@110 86 ((x, e, t),
adamc@110 87 (count, tags, newTags))
adamc@110 88 end
adamc@110 89 | _ => ((x, e, t), (count, tags, newTags)))
adamc@110 90 s xets
adamc@110 91 in
adamc@110 92 (EApp (
adamc@110 93 (EApp (
adamc@110 94 (EApp (
adamc@110 95 (ECApp (
adamc@110 96 (ECApp (
adamc@110 97 (ECApp (
adamc@110 98 (ECApp (
adamc@110 99 (EFfi ("Basis", "tag"),
adamc@110 100 loc), given), loc), absent), loc), outer), loc), inner), loc),
adamc@110 101 (ERecord xets, loc)), loc),
adamc@110 102 tag), loc),
adamc@110 103 xml), s)
adamc@110 104 end
adamc@110 105 | _ => (ErrorMsg.errorAt loc "Attribute record is too complex";
adamc@110 106 (e, s)))
adamc@110 107
adamc@110 108 | _ => (e, s)
adamc@110 109
adamc@110 110 fun decl (d, s) = (d, s)
adamc@110 111
adamc@110 112 fun tag file =
adamc@110 113 let
adamc@110 114 val count = foldl (fn ((d, _), count) =>
adamc@110 115 case d of
adamc@110 116 DCon (_, n, _, _) => Int.max (n, count)
adamc@110 117 | DVal (_, n, _, _, _) => Int.max (n, count)
adamc@110 118 | DExport _ => count) 0 file
adamc@110 119
adamc@110 120 fun doDecl (d as (d', loc), (env, count, tags)) =
adamc@110 121 let
adamc@110 122 val (d, (count, tags, newTags)) =
adamc@110 123 U.Decl.foldMap {kind = kind,
adamc@110 124 con = con,
adamc@110 125 exp = exp,
adamc@110 126 decl = decl}
adamc@110 127 (count, tags, []) d
adamc@110 128
adamc@110 129 val env = E.declBinds env d
adamc@110 130
adamc@110 131 val newDs = ListUtil.mapConcat
adamc@110 132 (fn (f, cn) =>
adamc@110 133 let
adamc@110 134 fun unravel (all as (t, _)) =
adamc@110 135 case t of
adamc@110 136 TFun (dom, ran) =>
adamc@110 137 let
adamc@110 138 val (args, result) = unravel ran
adamc@110 139 in
adamc@110 140 (dom :: args, result)
adamc@110 141 end
adamc@110 142 | _ => ([], all)
adamc@110 143
adamc@110 144 val (fnam, t, _, tag) = E.lookupENamed env f
adamc@110 145 val (args, result) = unravel t
adamc@110 146
adamc@110 147 val (app, _) = foldl (fn (t, (app, n)) =>
adamc@110 148 ((EApp (app, (ERel n, loc)), loc),
adamc@110 149 n - 1))
adamc@110 150 ((ENamed f, loc), length args - 1) args
adamc@110 151 val body = (EWrite app, loc)
adamc@110 152 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
adamc@110 153 val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
adamc@110 154 ((EAbs ("x" ^ Int.toString n,
adamc@110 155 t,
adamc@110 156 rest,
adamc@110 157 abs), loc),
adamc@110 158 n + 1,
adamc@110 159 (TFun (t, rest), loc)))
adamc@110 160 (body, 0, unit) args
adamc@110 161 in
adamc@110 162 [(DVal ("wrap_" ^ fnam, cn, t, abs, tag), loc),
adamc@110 163 (DExport cn, loc)]
adamc@110 164 end) newTags
adamc@110 165 in
adamc@110 166 (newDs @ [d], (env, count, tags))
adamc@110 167 end
adamc@110 168
adamc@110 169 val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count, IM.empty) file
adamc@110 170 in
adamc@110 171 file
adamc@110 172 end
adamc@110 173
adamc@110 174 end