Mercurial > urweb

comparison src/tag.sml @ 112:690d72c92a15

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Handling duplicate tags
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 12:43:47 -0400
parents 2d6116de9cca
children 94856a3b4752
comparison
equal deleted inserted replaced
111:2d6116de9cca 112:690d72c92a15
31 31
32 structure U = CoreUtil 32 structure U = CoreUtil
33 structure E = CoreEnv 33 structure E = CoreEnv
34 34
35 structure IM = IntBinaryMap 35 structure IM = IntBinaryMap
36 structure SM = BinaryMapFn(struct
37 type ord_key = string
38 val compare = String.compare
39 end)
36 40
37 fun kind (k, s) = (k, s) 41 fun kind (k, s) = (k, s)
38 fun con (c, s) = (c, s) 42 fun con (c, s) = (c, s)
39 43
40 fun exp (e, s) = 44 fun exp env (e, s) =
41 case e of 45 case e of
42 EApp ( 46 EApp (
43 (EApp ( 47 (EApp (
44 (EApp ( 48 (EApp (
45 (ECApp ( 49 (ECApp (
53 xml) => 57 xml) =>
54 (case attrs of 58 (case attrs of
55 (ERecord xets, _) => 59 (ERecord xets, _) =>
56 let 60 let
57 val (xets, s) = 61 val (xets, s) =
58 ListUtil.foldlMap (fn ((x, e, t), (count, tags, newTags)) => 62 ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) =>
59 case x of 63 case x of
60 (CName "Link", _) => 64 (CName "Link", _) =>
61 let 65 let
62 fun unravel (e, _) = 66 fun unravel (e, _) =
63 case e of 67 case e of
78 NONE => 82 NONE =>
79 (count, count + 1, IM.insert (tags, f, count), 83 (count, count + 1, IM.insert (tags, f, count),
80 (f, count) :: newTags) 84 (f, count) :: newTags)
81 | SOME cn => (cn, count, tags, newTags) 85 | SOME cn => (cn, count, tags, newTags)
82 86
87 val (_, _, _, s) = E.lookupENamed env f
88
89 val byTag = case SM.find (byTag, s) of
90 NONE => SM.insert (byTag, s, f)
91 | SOME f' =>
92 (if f = f' then
93 ()
94 else
95 ErrorMsg.errorAt loc
96 ("Duplicate HTTP tag "
97 ^ s);
98 byTag)
99
83 val e = (EClosure (cn, args), loc) 100 val e = (EClosure (cn, args), loc)
84 val t = (CFfi ("Basis", "string"), loc) 101 val t = (CFfi ("Basis", "string"), loc)
85 in 102 in
86 ((x, e, t), 103 ((x, e, t),
87 (count, tags, newTags)) 104 (count, tags, byTag, newTags))
88 end 105 end
89 | _ => ((x, e, t), (count, tags, newTags))) 106 | _ => ((x, e, t), (count, tags, byTag, newTags)))
90 s xets 107 s xets
91 in 108 in
92 (EApp ( 109 (EApp (
93 (EApp ( 110 (EApp (
94 (EApp ( 111 (EApp (
115 case d of 132 case d of
116 DCon (_, n, _, _) => Int.max (n, count) 133 DCon (_, n, _, _) => Int.max (n, count)
117 | DVal (_, n, _, _, _) => Int.max (n, count) 134 | DVal (_, n, _, _, _) => Int.max (n, count)
118 | DExport _ => count) 0 file 135 | DExport _ => count) 0 file
119 136
120 fun doDecl (d as (d', loc), (env, count, tags)) = 137 fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
121 let 138 case d' of
122 val (d, (count, tags, newTags)) = 139 DExport n =>
123 U.Decl.foldMap {kind = kind, 140 let
124 con = con, 141 val (_, _, _, s) = E.lookupENamed env n
125 exp = exp, 142 in
126 decl = decl} 143 case SM.find (byTag, s) of
127 (count, tags, []) d 144 NONE => ([d], (env, count, tags, byTag))
128 145 | SOME n' => ([], (env, count, tags, byTag))
129 val env = E.declBinds env d 146 end
130 147 | _ =>
131 val newDs = ListUtil.mapConcat 148 let
132 (fn (f, cn) => 149 val (d, (count, tags, byTag, newTags)) =
133 let 150 U.Decl.foldMap {kind = kind,
134 fun unravel (all as (t, _)) = 151 con = con,
135 case t of 152 exp = exp env,
136 TFun (dom, ran) => 153 decl = decl}
137 let 154 (count, tags, byTag, []) d
138 val (args, result) = unravel ran 155
139 in 156 val env = E.declBinds env d
140 (dom :: args, result) 157
141 end 158 val newDs = ListUtil.mapConcat
142 | _ => ([], all) 159 (fn (f, cn) =>
143 160 let
144 val (fnam, t, _, tag) = E.lookupENamed env f 161 fun unravel (all as (t, _)) =
145 val (args, result) = unravel t 162 case t of
146 163 TFun (dom, ran) =>
147 val (app, _) = foldl (fn (t, (app, n)) => 164 let
148 ((EApp (app, (ERel n, loc)), loc), 165 val (args, result) = unravel ran
149 n - 1)) 166 in
150 ((ENamed f, loc), length args - 1) args 167 (dom :: args, result)
151 val body = (EWrite app, loc) 168 end
152 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) 169 | _ => ([], all)
153 val (abs, _, t) = foldr (fn (t, (abs, n, rest)) => 170
154 ((EAbs ("x" ^ Int.toString n, 171 val (fnam, t, _, tag) = E.lookupENamed env f
155 t, 172 val (args, result) = unravel t
156 rest, 173
157 abs), loc), 174 val (app, _) = foldl (fn (t, (app, n)) =>
158 n + 1, 175 ((EApp (app, (ERel n, loc)), loc),
159 (TFun (t, rest), loc))) 176 n - 1))
160 (body, 0, unit) args 177 ((ENamed f, loc), length args - 1) args
161 in 178 val body = (EWrite app, loc)
162 [(DVal ("wrap_" ^ fnam, cn, t, abs, tag), loc), 179 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
163 (DExport cn, loc)] 180 val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
164 end) newTags 181 ((EAbs ("x" ^ Int.toString n,
165 in 182 t,
166 (newDs @ [d], (env, count, tags)) 183 rest,
167 end 184 abs), loc),
168 185 n + 1,
169 val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty) file 186 (TFun (t, rest), loc)))
187 (body, 0, unit) args
188 in
189 [(DVal ("wrap_" ^ fnam, cn, t, abs, tag), loc),
190 (DExport cn, loc)]
191 end) newTags
192 in
193 (newDs @ [d], (env, count, tags, byTag))
194 end
195
196 val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty) file
170 in 197 in
171 file 198 file
172 end 199 end
173 200
174 end 201 end