Mercurial > urweb

comparison src/mono_util.sml @ 109:813e5a52063d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove closure conversion in favor of zany fun with modules, which also replaces 'page'
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 10:17:06 -0400
parents d101cb1efe55
children 2d6116de9cca
comparison
equal deleted inserted replaced
108:f59553dc1b6a 109:813e5a52063d
31 31
32 structure S = Search 32 structure S = Search
33 33
34 structure Typ = struct 34 structure Typ = struct
35 35
36 fun join (o1, o2) =
37 case o1 of
38 EQUAL => o2 ()
39 | v => v
40
41 fun joinL f (os1, os2) =
42 case (os1, os2) of
43 (nil, nil) => EQUAL
44 | (nil, _) => LESS
45 | (h1 :: t1, h2 :: t2) =>
46 join (f (h1, h2), fn () => joinL f (t1, t2))
47 | (_ :: _, nil) => GREATER
48
49 fun compare ((t1, _), (t2, _)) =
50 case (t1, t2) of
51 (TFun (d1, r1), TFun (d2, r2)) =>
52 join (compare (d1, d2), fn () => compare (r1, r2))
53 | (TRecord xts1, TRecord xts2) =>
54 let
55 val xts1 = sortFields xts1
56 val xts2 = sortFields xts2
57 in
58 joinL compareFields (xts1, xts2)
59 end
60 | (TNamed n1, TNamed n2) => Int.compare (n1, n2)
61 | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
62
63 | (TFun _, _) => LESS
64 | (_, TFun _) => GREATER
65
66 | (TRecord _, _) => LESS
67 | (_, TRecord _) => GREATER
68
69 | (TNamed _, _) => LESS
70 | (_, TNamed _) => GREATER
71
72 and compareFields ((x1, t1), (x2, t2)) =
73 join (String.compare (x1, x2),
74 fn () => compare (t1, t2))
75
76 and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (x, y) = GREATER) xts
77
36 fun mapfold fc = 78 fun mapfold fc =
37 let 79 let
38 fun mft c acc = 80 fun mft c acc =
39 S.bindP (mft' c acc, fc) 81 S.bindP (mft' c acc, fc)
40 82
83 structure Exp = struct 125 structure Exp = struct
84 126
85 datatype binder = 127 datatype binder =
86 NamedT of string * int * typ option 128 NamedT of string * int * typ option
87 | RelE of string * typ 129 | RelE of string * typ
88 | NamedE of string * int * typ * exp option 130 | NamedE of string * int * typ * exp option * string
89 131
90 fun mapfoldB {typ = fc, exp = fe, bind} = 132 fun mapfoldB {typ = fc, exp = fe, bind} =
91 let 133 let
92 val mft = Typ.mapfold fc 134 val mft = Typ.mapfold fc
93 135
209 fun mfd ctx d acc = 251 fun mfd ctx d acc =
210 S.bindP (mfd' ctx d acc, fd ctx) 252 S.bindP (mfd' ctx d acc, fd ctx)
211 253
212 and mfd' ctx (dAll as (d, loc)) = 254 and mfd' ctx (dAll as (d, loc)) =
213 case d of 255 case d of
214 DVal (x, n, t, e) => 256 DVal (x, n, t, e, s) =>
215 S.bind2 (mft t, 257 S.bind2 (mft t,
216 fn t' => 258 fn t' =>
217 S.map2 (mfe ctx e, 259 S.map2 (mfe ctx e,
218 fn e' => 260 fn e' =>
219 (DVal (x, n, t', e'), loc))) 261 (DVal (x, n, t', e', s), loc)))
220 | DPage (xts, e) => 262 | DExport _ => S.return2 dAll
221 S.bind2 (ListUtil.mapfold (fn (x, t) =>
222 S.map2 (mft t,
223 fn t' =>
224 (x, t'))) xts,
225 fn xts' =>
226 S.map2 (mfe ctx e,
227 fn e' =>
228 (DPage (xts', e'), loc)))
229 in 263 in
230 mfd 264 mfd
231 end 265 end
232 266
233 fun mapfold {typ = fc, exp = fe, decl = fd} = 267 fun mapfold {typ = fc, exp = fe, decl = fd} =
260 S.bind2 (mfd ctx d, 294 S.bind2 (mfd ctx d,
261 fn d' => 295 fn d' =>
262 let 296 let
263 val ctx' = 297 val ctx' =
264 case #1 d' of 298 case #1 d' of
265 DVal (x, n, t, e) => bind (ctx, NamedE (x, n, t, SOME e)) 299 DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
266 | DPage _ => ctx 300 | DExport _ => ctx
267 in 301 in
268 S.map2 (mff ctx' ds', 302 S.map2 (mff ctx' ds',
269 fn ds' => 303 fn ds' =>
270 d' :: ds') 304 d' :: ds')
271 end) 305 end)