Mercurial > urweb

comparison src/flat_util.sml @ 28:104d43266b33

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Field sorting for Flat
author Adam Chlipala <adamc@hcoop.net>
date Tue, 10 Jun 2008 16:22:46 -0400
parents 4ab19c19665f
children 537db4ee89f4
comparison
equal deleted inserted replaced
27:145b536fc702 28:104d43266b33
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 | (TCode (d1, r1), TCode (d2, r2)) =>
54 join (compare (d1, d2), fn () => compare (r1, r2))
55 | (TRecord xts1, TRecord xts2) =>
56 let
57 val xts2 = sortFields xts1
58 val xts2 = sortFields xts2
59 in
60 joinL compareFields (xts1, xts2)
61 end
62 | (TNamed n1, TNamed n2) => Int.compare (n1, n2)
63
64 | (TFun _, _) => LESS
65 | (_, TFun _) => GREATER
66
67 | (TCode _, _) => LESS
68 | (_, TCode _) => GREATER
69
70 | (TRecord _, _) => LESS
71 | (_, TRecord _) => GREATER
72
73 and compareFields ((x1, t1), (x2, t2)) =
74 join (String.compare (x1, x2),
75 fn () => compare (t1, t2))
76
77 and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (x, y) = GREATER) xts
78
36 fun mapfold fc = 79 fun mapfold fc =
37 let 80 let
38 fun mft c acc = 81 fun mft c acc =
39 S.bindP (mft' c acc, fc) 82 S.bindP (mft' c acc, fc)
40 83