Mercurial > urweb

comparison src/tag.sml @ 144:f0d3402184d1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Simple forms work
author Adam Chlipala <adamc@hcoop.net>
date Tue, 22 Jul 2008 15:12:20 -0400
parents 4b9c2bd6157c
children 80192edca30d
comparison
equal deleted inserted replaced
143:4b9c2bd6157c 144:f0d3402184d1
64 (ERecord xets, _) => 64 (ERecord xets, _) =>
65 let 65 let
66 val (xets, s) = 66 val (xets, s) =
67 ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) => 67 ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) =>
68 let 68 let
69 fun tagIt newAttr = 69 fun tagIt (ek, newAttr) =
70 let 70 let
71 fun unravel (e, _) = 71 fun unravel (e, _) =
72 case e of 72 case e of
73 ENamed n => (n, []) 73 ENamed n => (n, [])
74 | EApp (e1, e2) => 74 | EApp (e1, e2) =>
86 86
87 val (cn, count, tags, newTags) = 87 val (cn, count, tags, newTags) =
88 case IM.find (tags, f) of 88 case IM.find (tags, f) of
89 NONE => 89 NONE =>
90 (count, count + 1, IM.insert (tags, f, count), 90 (count, count + 1, IM.insert (tags, f, count),
91 (f, count) :: newTags) 91 (ek, f, count) :: newTags)
92 | SOME cn => (cn, count, tags, newTags) 92 | SOME cn => (cn, count, tags, newTags)
93 93
94 val (_, _, _, s) = E.lookupENamed env f 94 val (_, _, _, s) = E.lookupENamed env f
95 95
96 val byTag = case SM.find (byTag, s) of 96 val byTag = case SM.find (byTag, s) of
97 NONE => SM.insert (byTag, s, f) 97 NONE => SM.insert (byTag, s, (ek, f))
98 | SOME f' => 98 | SOME (ek', f') =>
99 (if f = f' then 99 (if f = f' then
100 () 100 ()
101 else 101 else
102 ErrorMsg.errorAt loc 102 ErrorMsg.errorAt loc
103 ("Duplicate HTTP tag " 103 ("Duplicate HTTP tag "
104 ^ s); 104 ^ s);
105 if ek = ek' then
106 ()
107 else
108 ErrorMsg.errorAt loc
109 "Function needed as both a link and a form ";
105 byTag) 110 byTag)
106 111
107 val e = (EClosure (cn, args), loc) 112 val e = (EClosure (cn, args), loc)
108 val t = (CFfi ("Basis", "string"), loc) 113 val t = (CFfi ("Basis", "string"), loc)
109 in 114 in
110 (((CName newAttr, loc), e, t), 115 (((CName newAttr, loc), e, t),
111 (count, tags, byTag, newTags)) 116 (count, tags, byTag, newTags))
112 end 117 end
113 in 118 in
114 case x of 119 case x of
115 (CName "Link", _) => tagIt "Href" 120 (CName "Link", _) => tagIt (Link, "Href")
116 | (CName "Action", _) => tagIt "Action" 121 | (CName "Action", _) => tagIt (Action, "Action")
117 | _ => ((x, e, t), (count, tags, byTag, newTags)) 122 | _ => ((x, e, t), (count, tags, byTag, newTags))
118 end) 123 end)
119 s xets 124 s xets
120 in 125 in
121 (EApp ( 126 (EApp (
152 | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis 157 | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
153 | DExport _ => count) 0 file 158 | DExport _ => count) 0 file
154 159
155 fun doDecl (d as (d', loc), (env, count, tags, byTag)) = 160 fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
156 case d' of 161 case d' of
157 DExport n => 162 DExport (ek, n) =>
158 let 163 let
159 val (_, _, _, s) = E.lookupENamed env n 164 val (_, _, _, s) = E.lookupENamed env n
160 in 165 in
161 case SM.find (byTag, s) of 166 case SM.find (byTag, s) of
162 NONE => ([d], (env, count, tags, byTag)) 167 NONE => ([d], (env, count, tags, byTag))
163 | SOME n' => ([], (env, count, tags, byTag)) 168 | SOME (ek', n') =>
169 (if ek = ek' then
170 ()
171 else
172 ErrorMsg.errorAt loc "Function needed for both a link and a form";
173 ([], (env, count, tags, byTag)))
164 end 174 end
165 | _ => 175 | _ =>
166 let 176 let
167 val env' = E.declBinds env d 177 val env' = E.declBinds env d
168 val env'' = case d' of 178 val env'' = case d' of
177 (count, tags, byTag, []) d 187 (count, tags, byTag, []) d
178 188
179 val env = env' 189 val env = env'
180 190
181 val newDs = map 191 val newDs = map
182 (fn (f, cn) => 192 (fn (ek, f, cn) =>
183 let 193 let
184 fun unravel (all as (t, _)) = 194 fun unravel (all as (t, _)) =
185 case t of 195 case t of
186 TFun (dom, ran) => 196 TFun (dom, ran) =>
187 let 197 let
223 in 233 in
224 (abs, t) 234 (abs, t)
225 end 235 end
226 in 236 in
227 (("wrap_" ^ fnam, cn, t, abs, tag), 237 (("wrap_" ^ fnam, cn, t, abs, tag),
228 (DExport cn, loc)) 238 (DExport (ek, cn), loc))
229 end) newTags 239 end) newTags
230 240
231 val (newVals, newExports) = ListPair.unzip newDs 241 val (newVals, newExports) = ListPair.unzip newDs
232 242
233 val ds = case d of 243 val ds = case d of