Mercurial > urweb
comparison src/tag.sml @ 1065:217eb87dde31
Basis.url and redirects
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Thu, 10 Dec 2009 13:32:09 -0500 |
parents | 3bc726a822fb |
children | 50dd937c4cb9 |
comparison
equal
deleted
inserted
replaced
1064:b89e3d8731ed | 1065:217eb87dde31 |
---|---|
44 fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for both a link and a form"); | 44 fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for both a link and a form"); |
45 TextIO.output (TextIO.stdErr, | 45 TextIO.output (TextIO.stdErr, |
46 "Make sure that the signature of the containing module hides any form handlers.\n")) | 46 "Make sure that the signature of the containing module hides any form handlers.\n")) |
47 | 47 |
48 fun exp env (e, s) = | 48 fun exp env (e, s) = |
49 case e of | 49 let |
50 EApp ( | 50 fun tagIt (e, ek : export_kind, newAttr, (count, tags, byTag, newTags)) = |
51 (EApp ( | 51 let |
52 (EApp ( | 52 val loc = #2 e |
53 (EApp ( | 53 |
54 (ECApp ( | 54 val eOrig = e |
55 (ECApp ( | 55 |
56 (ECApp ( | 56 fun unravel (e, _) = |
57 (ECApp ( | 57 case e of |
58 ENamed n => (n, []) | |
59 | EApp (e1, e2) => | |
60 let | |
61 val (n, es) = unravel e1 | |
62 in | |
63 (n, es @ [e2]) | |
64 end | |
65 | _ => (ErrorMsg.errorAt loc ("Invalid " ^ newAttr | |
66 ^ " expression"); | |
67 Print.epreface ("Expression", | |
68 CorePrint.p_exp CoreEnv.empty eOrig); | |
69 (0, [])) | |
70 | |
71 val (f, args) = unravel e | |
72 | |
73 val (cn, count, tags, newTags) = | |
74 case IM.find (tags, f) of | |
75 NONE => | |
76 (count, count + 1, IM.insert (tags, f, count), | |
77 (ek, f, count) :: newTags) | |
78 | SOME cn => (cn, count, tags, newTags) | |
79 | |
80 val (_, _, _, s) = E.lookupENamed env f | |
81 | |
82 val byTag = case SM.find (byTag, s) of | |
83 NONE => SM.insert (byTag, s, (ek, f)) | |
84 | SOME (ek', f') => | |
85 (if f = f' then | |
86 () | |
87 else | |
88 ErrorMsg.errorAt loc | |
89 ("Duplicate HTTP tag " | |
90 ^ s); | |
91 if ek = ek' then | |
92 () | |
93 else | |
94 both (loc, s); | |
95 byTag) | |
96 | |
97 val e = (EClosure (cn, args), loc) | |
98 in | |
99 (e, (count, tags, byTag, newTags)) | |
100 end | |
101 in | |
102 case e of | |
103 EApp ( | |
104 (EApp ( | |
105 (EApp ( | |
106 (EApp ( | |
58 (ECApp ( | 107 (ECApp ( |
59 (ECApp ( | 108 (ECApp ( |
60 (ECApp ( | 109 (ECApp ( |
61 (ECApp ( | 110 (ECApp ( |
62 (EFfi ("Basis", "tag"), | 111 (ECApp ( |
63 loc), given), _), absent), _), outer), _), inner), _), | 112 (ECApp ( |
64 useOuter), _), useInner), _), bindOuter), _), bindInner), _), | |
65 class), _), | |
66 attrs), _), | |
67 tag), _), | |
68 xml) => | |
69 (case attrs of | |
70 (ERecord xets, _) => | |
71 let | |
72 val (xets, s) = | |
73 ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) => | |
74 let | |
75 fun tagIt (ek, newAttr) = | |
76 let | |
77 val eOrig = e | |
78 | |
79 fun unravel (e, _) = | |
80 case e of | |
81 ENamed n => (n, []) | |
82 | EApp (e1, e2) => | |
83 let | |
84 val (n, es) = unravel e1 | |
85 in | |
86 (n, es @ [e2]) | |
87 end | |
88 | _ => (ErrorMsg.errorAt loc ("Invalid " ^ newAttr | |
89 ^ " expression"); | |
90 Print.epreface ("Expression", | |
91 CorePrint.p_exp CoreEnv.empty eOrig); | |
92 (0, [])) | |
93 | |
94 val (f, args) = unravel e | |
95 | |
96 val (cn, count, tags, newTags) = | |
97 case IM.find (tags, f) of | |
98 NONE => | |
99 (count, count + 1, IM.insert (tags, f, count), | |
100 (ek, f, count) :: newTags) | |
101 | SOME cn => (cn, count, tags, newTags) | |
102 | |
103 val (_, _, _, s) = E.lookupENamed env f | |
104 | |
105 val byTag = case SM.find (byTag, s) of | |
106 NONE => SM.insert (byTag, s, (ek, f)) | |
107 | SOME (ek', f') => | |
108 (if f = f' then | |
109 () | |
110 else | |
111 ErrorMsg.errorAt loc | |
112 ("Duplicate HTTP tag " | |
113 ^ s); | |
114 if ek = ek' then | |
115 () | |
116 else | |
117 both (loc, s); | |
118 byTag) | |
119 | |
120 val e = (EClosure (cn, args), loc) | |
121 val t = (CFfi ("Basis", "string"), loc) | |
122 in | |
123 (((CName newAttr, loc), e, t), | |
124 (count, tags, byTag, newTags)) | |
125 end | |
126 in | |
127 case x of | |
128 (CName "Link", _) => tagIt (Link, "Link") | |
129 | (CName "Action", _) => tagIt (Action ReadWrite, "Action") | |
130 | _ => ((x, e, t), (count, tags, byTag, newTags)) | |
131 end) | |
132 s xets | |
133 in | |
134 (EApp ( | |
135 (EApp ( | |
136 (EApp ( | |
137 (EApp ( | |
138 (ECApp ( | 113 (ECApp ( |
139 (ECApp ( | 114 (ECApp ( |
140 (ECApp ( | 115 (EFfi ("Basis", "tag"), |
141 (ECApp ( | 116 loc), given), _), absent), _), outer), _), inner), _), |
117 useOuter), _), useInner), _), bindOuter), _), bindInner), _), | |
118 class), _), | |
119 attrs), _), | |
120 tag), _), | |
121 xml) => | |
122 (case attrs of | |
123 (ERecord xets, _) => | |
124 let | |
125 val (xets, s) = | |
126 ListUtil.foldlMap (fn ((x, e, t), s) => | |
127 let | |
128 fun tagIt' (ek, newAttr) = | |
129 let | |
130 val (e', s) = tagIt (e, ek, newAttr, s) | |
131 val t = (CFfi ("Basis", "string"), loc) | |
132 in | |
133 (((CName newAttr, loc), e', t), s) | |
134 end | |
135 in | |
136 case x of | |
137 (CName "Link", _) => tagIt' (Link, "Link") | |
138 | (CName "Action", _) => tagIt' (Action ReadWrite, "Action") | |
139 | _ => ((x, e, t), s) | |
140 end) | |
141 s xets | |
142 in | |
143 (EApp ( | |
144 (EApp ( | |
145 (EApp ( | |
146 (EApp ( | |
142 (ECApp ( | 147 (ECApp ( |
143 (ECApp ( | 148 (ECApp ( |
144 (ECApp ( | 149 (ECApp ( |
145 (ECApp ( | 150 (ECApp ( |
146 (EFfi ("Basis", "tag"), | 151 (ECApp ( |
147 loc), given), loc), absent), loc), outer), loc), inner), loc), | 152 (ECApp ( |
148 useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc), | 153 (ECApp ( |
149 class), loc), | 154 (ECApp ( |
150 (ERecord xets, loc)), loc), | 155 (EFfi ("Basis", "tag"), |
151 tag), loc), | 156 loc), given), loc), absent), loc), outer), loc), inner), loc), |
152 xml), s) | 157 useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc), |
153 end | 158 class), loc), |
154 | _ => (ErrorMsg.errorAt loc "Attribute record is too complex"; | 159 (ERecord xets, loc)), loc), |
155 (e, s))) | 160 tag), loc), |
156 | 161 xml), s) |
157 | _ => (e, s) | 162 end |
163 | _ => (ErrorMsg.errorAt loc "Attribute record is too complex"; | |
164 (e, s))) | |
165 | |
166 | EFfiApp ("Basis", "url", [(ERel 0, _)]) => (e, s) | |
167 | |
168 | EFfiApp ("Basis", "url", [e]) => | |
169 let | |
170 val (e, s) = tagIt (e, Link, "Url", s) | |
171 in | |
172 (#1 e, s) | |
173 end | |
174 | |
175 | EApp ((ENamed n, _), e') => | |
176 let | |
177 val (_, _, eo, _) = E.lookupENamed env n | |
178 in | |
179 case eo of | |
180 SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [(ERel 0, _)]), _)), _) => | |
181 let | |
182 val (e, s) = tagIt (e', Link, "Url", s) | |
183 in | |
184 (#1 e, s) | |
185 end | |
186 | _ => (e, s) | |
187 end | |
188 | |
189 | _ => (e, s) | |
190 end | |
158 | 191 |
159 fun decl (d, s) = (d, s) | 192 fun decl (d, s) = (d, s) |
160 | 193 |
161 fun tag file = | 194 fun tag file = |
162 let | 195 let |