Mercurial > urweb

comparison src/flat_util.sml @ 29:537db4ee89f4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Translation to Cjr
author Adam Chlipala <adamc@hcoop.net>
date Tue, 10 Jun 2008 18:28:43 -0400
parents 104d43266b33
children 198172560b73
comparison
equal deleted inserted replaced
28:104d43266b33 29:537db4ee89f4
46 join (f (h1, h2), fn () => joinL f (t1, t2)) 46 join (f (h1, h2), fn () => joinL f (t1, t2))
47 | (_ :: _, nil) => GREATER 47 | (_ :: _, nil) => GREATER
48 48
49 fun compare ((t1, _), (t2, _)) = 49 fun compare ((t1, _), (t2, _)) =
50 case (t1, t2) of 50 case (t1, t2) of
51 (TFun (d1, r1), TFun (d2, r2)) => 51 (TTop, TTop) => EQUAL
52 | (TFun (d1, r1), TFun (d2, r2)) =>
52 join (compare (d1, d2), fn () => compare (r1, r2)) 53 join (compare (d1, d2), fn () => compare (r1, r2))
53 | (TCode (d1, r1), TCode (d2, r2)) => 54 | (TCode (d1, r1), TCode (d2, r2)) =>
54 join (compare (d1, d2), fn () => compare (r1, r2)) 55 join (compare (d1, d2), fn () => compare (r1, r2))
55 | (TRecord xts1, TRecord xts2) => 56 | (TRecord xts1, TRecord xts2) =>
56 let 57 let
59 in 60 in
60 joinL compareFields (xts1, xts2) 61 joinL compareFields (xts1, xts2)
61 end 62 end
62 | (TNamed n1, TNamed n2) => Int.compare (n1, n2) 63 | (TNamed n1, TNamed n2) => Int.compare (n1, n2)
63 64
65 | (TTop, _) => LESS
66 | (_, TTop) => GREATER
67
64 | (TFun _, _) => LESS 68 | (TFun _, _) => LESS
65 | (_, TFun _) => GREATER 69 | (_, TFun _) => GREATER
66 70
67 | (TCode _, _) => LESS 71 | (TCode _, _) => LESS
68 | (_, TCode _) => GREATER 72 | (_, TCode _) => GREATER
81 fun mft c acc = 85 fun mft c acc =
82 S.bindP (mft' c acc, fc) 86 S.bindP (mft' c acc, fc)
83 87
84 and mft' (cAll as (c, loc)) = 88 and mft' (cAll as (c, loc)) =
85 case c of 89 case c of
86 TFun (t1, t2) => 90 TTop => S.return2 cAll
91 | TFun (t1, t2) =>
87 S.bind2 (mft t1, 92 S.bind2 (mft t1,
88 fn t1' => 93 fn t1' =>
89 S.map2 (mft t2, 94 S.map2 (mft t2,
90 fn t2' => 95 fn t2' =>
91 (TFun (t1', t2'), loc))) 96 (TFun (t1', t2'), loc)))
154 S.map2 (mfe ctx e2, 159 S.map2 (mfe ctx e2,
155 fn e2' => 160 fn e2' =>
156 (EApp (e1', e2'), loc))) 161 (EApp (e1', e2'), loc)))
157 162
158 | ERecord xes => 163 | ERecord xes =>
159 S.map2 (ListUtil.mapfold (fn (x, e) => 164 S.map2 (ListUtil.mapfold (fn (x, e, t) =>
160 S.map2 (mfe ctx e, 165 S.bind2 (mfe ctx e,
161 fn e' => 166 fn e' =>
162 (x, e'))) 167 S.map2 (mft t,
168 fn t' =>
169 (x, e', t'))))
163 xes, 170 xes,
164 fn xes' => 171 fn xes' =>
165 (ERecord xes', loc)) 172 (ERecord xes', loc))
166 | EField (e, x) => 173 | EField (e, x) =>
167 S.map2 (mfe ctx e, 174 S.map2 (mfe ctx e,
168 fn e' => 175 fn e' =>
169 (EField (e', x), loc)) 176 (EField (e', x), loc))
170 177
171 | ELet (xes, e) => 178 | ELet (xes, e) =>
172 S.bind2 (ListUtil.mapfold (fn (x, e) => 179 S.bind2 (ListUtil.mapfold (fn (x, t, e) =>
173 S.map2 (mfe ctx e, 180 S.bind2 (mft t,
174 fn e' => 181 fn t' =>
175 (x, e'))) 182 S.map2 (mfe ctx e,
183 fn e' =>
184 (x, t', e'))))
176 xes, 185 xes,
177 fn xes' => 186 fn xes' =>
178 S.map2 (mfe ctx e, 187 S.map2 (mfe ctx e,
179 fn e' => 188 fn e' =>
180 (ELet (xes', e'), loc))) 189 (ELet (xes', e'), loc)))