Mercurial > urweb
comparison src/tag.sml @ 112:690d72c92a15
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 |