Mercurial > urweb

comparison src/tag.sml @ 1065:217eb87dde31

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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