Mercurial > urweb

comparison src/mono_fooify.sml @ 2254:44ae2254f8fb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Factor out urlification.
author Ziv Scully <ziv@mit.edu>
date Mon, 21 Sep 2015 16:07:35 -0400
parents
children 6f2ea4ed573a
comparison
equal deleted inserted replaced
2253:d665925acff8 2254:44ae2254f8fb
1 structure MonoFooify :> MONO_FOOIFY = struct
2
3 open Mono
4
5 datatype foo_kind =
6 Attr
7 | Url
8
9 val nextPvar = ref 0
10 val pvarDefs = ref ([] : (string * int * (string * int * typ option) list) list)
11
12 structure Fm = struct
13
14 type vr = string * int * typ * exp * string
15
16 structure IM = IntBinaryMap
17
18 structure M = BinaryMapFn(struct
19 type ord_key = foo_kind
20 fun compare x =
21 case x of
22 (Attr, Attr) => EQUAL
23 | (Attr, _) => LESS
24 | (_, Attr) => GREATER
25
26 | (Url, Url) => EQUAL
27 end)
28
29 structure TM = BinaryMapFn(struct
30 type ord_key = typ
31 val compare = MonoUtil.Typ.compare
32 end)
33
34 type t = {
35 count : int,
36 map : int IM.map M.map,
37 listMap : int TM.map M.map,
38 decls : vr list
39 }
40
41 fun empty count = {
42 count = count,
43 map = M.empty,
44 listMap = M.empty,
45 decls = []
46 }
47
48 fun chooseNext count =
49 let
50 val n = !nextPvar
51 in
52 if count < n then
53 (count, count+1)
54 else
55 (nextPvar := n + 1;
56 (n, n+1))
57 end
58
59 fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
60 fun freshName {count, map, listMap, decls} =
61 let
62 val (next, count) = chooseNext count
63 in
64 (next, {count = count , map = map, listMap = listMap, decls = decls})
65 end
66 fun decls ({decls, ...} : t) =
67 case decls of
68 [] => []
69 | _ => [(DValRec decls, ErrorMsg.dummySpan)]
70
71 fun lookup (t as {count, map, listMap, decls}) k n thunk =
72 let
73 val im = Option.getOpt (M.find (map, k), IM.empty)
74 in
75 case IM.find (im, n) of
76 NONE =>
77 let
78 val n' = count
79 val (d, {count, map, listMap, decls}) =
80 thunk count {count = count + 1,
81 map = M.insert (map, k, IM.insert (im, n, n')),
82 listMap = listMap,
83 decls = decls}
84 in
85 ({count = count,
86 map = map,
87 listMap = listMap,
88 decls = d :: decls}, n')
89 end
90 | SOME n' => (t, n')
91 end
92
93 fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
94 let
95 val tm = Option.getOpt (M.find (listMap, k), TM.empty)
96 in
97 case TM.find (tm, tp) of
98 NONE =>
99 let
100 val n' = count
101 val (d, {count, map, listMap, decls}) =
102 thunk count {count = count + 1,
103 map = map,
104 listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
105 decls = decls}
106 in
107 ({count = count,
108 map = map,
109 listMap = listMap,
110 decls = d :: decls}, n')
111 end
112 | SOME n' => (t, n')
113 end
114
115 (* Has to be set at the end of [Monoize]. *)
116 val canonical = ref (empty 0 : t)
117
118 end
119
120 fun fk2s fk =
121 case fk of
122 Attr => "attr"
123 | Url => "url"
124
125 fun capitalize s =
126 if s = "" then
127 s
128 else
129 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
130
131 structure E = ErrorMsg
132
133 val dummyExp = (EPrim (Prim.Int 0), E.dummySpan)
134
135 fun fooifyExp fk lookupENamed lookupDatatype =
136 let
137 fun fooify fm (e, tAll as (t, loc)) =
138 case #1 e of
139 EClosure (fnam, [(ERecord [], _)]) =>
140 let
141 val (_, s) = lookupENamed fnam
142 in
143 ((EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
144 end
145 | EClosure (fnam, args) =>
146 let
147 val (ft, s) = lookupENamed fnam
148 fun attrify (args, ft, e, fm) =
149 case (args, ft) of
150 ([], _) => (e, fm)
151 | (arg :: args, (TFun (t, ft), _)) =>
152 let
153 val (arg', fm) = fooify fm (arg, t)
154 in
155 attrify (args, ft,
156 (EStrcat (e,
157 (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
158 arg'), loc)), loc),
159 fm)
160 end
161 | _ => (E.errorAt loc "Type mismatch encoding attribute";
162 (e, fm))
163 in
164 attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
165 end
166 | _ =>
167 case t of
168 TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
169 | TFfi (m, x) => ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
170
171 | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
172 | TRecord ((x, t) :: xts) =>
173 let
174 val (se, fm) = fooify fm ((EField (e, x), loc), t)
175 in
176 foldl (fn ((x, t), (se, fm)) =>
177 let
178 val (se', fm) = fooify fm ((EField (e, x), loc), t)
179 in
180 ((EStrcat (se,
181 (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
182 se'), loc)), loc),
183 fm)
184 end) (se, fm) xts
185 end
186
187 | TDatatype (i, ref (dk, _)) =>
188 let
189 fun makeDecl n fm =
190 let
191 val (x, xncs) =
192 case ListUtil.search (fn (x, i', xncs) =>
193 if i' = i then
194 SOME (x, xncs)
195 else
196 NONE) (!pvarDefs) of
197 NONE => lookupDatatype i
198 | SOME v => v
199
200 val (branches, fm) =
201 ListUtil.foldlMap
202 (fn ((x, n, to), fm) =>
203 case to of
204 NONE =>
205 (((PCon (dk, PConVar n, NONE), loc),
206 (EPrim (Prim.String (Prim.Normal, x)), loc)),
207 fm)
208 | SOME t =>
209 let
210 val (arg, fm) = fooify fm ((ERel 0, loc), t)
211 in
212 (((PCon (dk, PConVar n, SOME (PVar ("a", t), loc)), loc),
213 (EStrcat ((EPrim (Prim.String (Prim.Normal, x ^ "/")), loc),
214 arg), loc)),
215 fm)
216 end)
217 fm xncs
218
219 val dom = tAll
220 val ran = (TFfi ("Basis", "string"), loc)
221 in
222 ((fk2s fk ^ "ify_" ^ x,
223 n,
224 (TFun (dom, ran), loc),
225 (EAbs ("x",
226 dom,
227 ran,
228 (ECase ((ERel 0, loc),
229 branches,
230 {disc = dom,
231 result = ran}), loc)), loc),
232 ""),
233 fm)
234 end
235
236 val (fm, n) = Fm.lookup fm fk i makeDecl
237 in
238 ((EApp ((ENamed n, loc), e), loc), fm)
239 end
240
241 | TOption t =>
242 let
243 val (body, fm) = fooify fm ((ERel 0, loc), t)
244 in
245 ((ECase (e,
246 [((PNone t, loc),
247 (EPrim (Prim.String (Prim.Normal, "None")), loc)),
248
249 ((PSome (t, (PVar ("x", t), loc)), loc),
250 (EStrcat ((EPrim (Prim.String (Prim.Normal, "Some/")), loc),
251 body), loc))],
252 {disc = tAll,
253 result = (TFfi ("Basis", "string"), loc)}), loc),
254 fm)
255 end
256
257 | TList t =>
258 let
259 fun makeDecl n fm =
260 let
261 val rt = (TRecord [("1", t), ("2", (TList t, loc))], loc)
262 val (arg, fm) = fooify fm ((ERel 0, loc), rt)
263
264 val branches = [((PNone rt, loc),
265 (EPrim (Prim.String (Prim.Normal, "Nil")), loc)),
266 ((PSome (rt, (PVar ("a", rt), loc)), loc),
267 (EStrcat ((EPrim (Prim.String (Prim.Normal, "Cons/")), loc),
268 arg), loc))]
269
270 val dom = tAll
271 val ran = (TFfi ("Basis", "string"), loc)
272 in
273 ((fk2s fk ^ "ify_list",
274 n,
275 (TFun (dom, ran), loc),
276 (EAbs ("x",
277 dom,
278 ran,
279 (ECase ((ERel 0, loc),
280 branches,
281 {disc = dom,
282 result = ran}), loc)), loc),
283 ""),
284 fm)
285 end
286
287 val (fm, n) = Fm.lookupList fm fk t makeDecl
288 in
289 ((EApp ((ENamed n, loc), e), loc), fm)
290 end
291
292 | _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
293 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
294 (dummyExp, fm))
295 in
296 fooify
297 end
298
299 fun urlify env expTyp =
300 let
301 val (exp, fm) =
302 fooifyExp
303 Url
304 (fn n =>
305 let
306 val (_, t, _, s) = MonoEnv.lookupENamed env n
307 in
308 (t, s)
309 end)
310 (fn n => MonoEnv.lookupDatatype env n)
311 (!Fm.canonical)
312 expTyp
313 in
314 Fm.canonical := fm;
315 exp
316 end
317 end