Mercurial > urweb

comparison 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
comparison
equal deleted inserted replaced
109:813e5a52063d 110:3739af9e727a
1 (* Copyright (c) 2008, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 structure Tag :> TAG = struct
29
30 open Core
31
32 structure U = CoreUtil
33 structure E = CoreEnv
34
35 structure IM = IntBinaryMap
36
37 fun kind (k, s) = (k, s)
38 fun con (c, s) = (c, s)
39
40 fun exp (e, s) =
41 case e of
42 EApp (
43 (EApp (
44 (EApp (
45 (ECApp (
46 (ECApp (
47 (ECApp (
48 (ECApp (
49 (EFfi ("Basis", "tag"),
50 loc), given), _), absent), _), outer), _), inner), _),
51 attrs), _),
52 tag), _),
53 xml) =>
54 (case attrs of
55 (ERecord xets, _) =>
56 let
57 val (xets, s) =
58 ListUtil.foldlMap (fn ((x, e, t), (count, tags, newTags)) =>
59 case x of
60 (CName "Link", _) =>
61 let
62 fun unravel (e, _) =
63 case e of
64 ENamed n => (n, [])
65 | EApp (e1, e2) =>
66 let
67 val (n, es) = unravel e1
68 in
69 (n, es @ [e2])
70 end
71 | _ => (ErrorMsg.errorAt loc "Invalid link expression";
72 (0, []))
73
74 val (f, args) = unravel e
75
76 val (cn, count, tags, newTags) =
77 case IM.find (tags, f) of
78 NONE =>
79 (count, count + 1, IM.insert (tags, f, count),
80 (f, count) :: newTags)
81 | SOME cn => (cn, count, tags, newTags)
82
83 val e = (EClosure (cn, args), loc)
84 val t = (CFfi ("Basis", "string"), loc)
85 in
86 ((x, e, t),
87 (count, tags, newTags))
88 end
89 | _ => ((x, e, t), (count, tags, newTags)))
90 s xets
91 in
92 (EApp (
93 (EApp (
94 (EApp (
95 (ECApp (
96 (ECApp (
97 (ECApp (
98 (ECApp (
99 (EFfi ("Basis", "tag"),
100 loc), given), loc), absent), loc), outer), loc), inner), loc),
101 (ERecord xets, loc)), loc),
102 tag), loc),
103 xml), s)
104 end
105 | _ => (ErrorMsg.errorAt loc "Attribute record is too complex";
106 (e, s)))
107
108 | _ => (e, s)
109
110 fun decl (d, s) = (d, s)
111
112 fun tag file =
113 let
114 val count = foldl (fn ((d, _), count) =>
115 case d of
116 DCon (_, n, _, _) => Int.max (n, count)
117 | DVal (_, n, _, _, _) => Int.max (n, count)
118 | DExport _ => count) 0 file
119
120 fun doDecl (d as (d', loc), (env, count, tags)) =
121 let
122 val (d, (count, tags, newTags)) =
123 U.Decl.foldMap {kind = kind,
124 con = con,
125 exp = exp,
126 decl = decl}
127 (count, tags, []) d
128
129 val env = E.declBinds env d
130
131 val newDs = ListUtil.mapConcat
132 (fn (f, cn) =>
133 let
134 fun unravel (all as (t, _)) =
135 case t of
136 TFun (dom, ran) =>
137 let
138 val (args, result) = unravel ran
139 in
140 (dom :: args, result)
141 end
142 | _ => ([], all)
143
144 val (fnam, t, _, tag) = E.lookupENamed env f
145 val (args, result) = unravel t
146
147 val (app, _) = foldl (fn (t, (app, n)) =>
148 ((EApp (app, (ERel n, loc)), loc),
149 n - 1))
150 ((ENamed f, loc), length args - 1) args
151 val body = (EWrite app, loc)
152 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
153 val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
154 ((EAbs ("x" ^ Int.toString n,
155 t,
156 rest,
157 abs), loc),
158 n + 1,
159 (TFun (t, rest), loc)))
160 (body, 0, unit) args
161 in
162 [(DVal ("wrap_" ^ fnam, cn, t, abs, tag), loc),
163 (DExport cn, loc)]
164 end) newTags
165 in
166 (newDs @ [d], (env, count, tags))
167 end
168
169 val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count, IM.empty) file
170 in
171 file
172 end
173
174 end