summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/flat_util.sig3
-rw-r--r--src/flat_util.sml43
2 files changed, 46 insertions, 0 deletions
diff --git a/src/flat_util.sig b/src/flat_util.sig
index 4e77f3c7..ff7edcd1 100644
--- a/src/flat_util.sig
+++ b/src/flat_util.sig
@@ -28,6 +28,9 @@
signature FLAT_UTIL = sig
structure Typ : sig
+ val compare : Flat.typ * Flat.typ -> order
+ val sortFields : (string * Flat.typ) list -> (string * Flat.typ) list
+
val mapfold : (Flat.typ', 'state, 'abort) Search.mapfolder
-> (Flat.typ, 'state, 'abort) Search.mapfolder
diff --git a/src/flat_util.sml b/src/flat_util.sml
index 89e6f143..e9656f5b 100644
--- a/src/flat_util.sml
+++ b/src/flat_util.sml
@@ -33,6 +33,49 @@ structure S = Search
structure Typ = struct
+fun join (o1, o2) =
+ case o1 of
+ EQUAL => o2 ()
+ | v => v
+
+fun joinL f (os1, os2) =
+ case (os1, os2) of
+ (nil, nil) => EQUAL
+ | (nil, _) => LESS
+ | (h1 :: t1, h2 :: t2) =>
+ join (f (h1, h2), fn () => joinL f (t1, t2))
+ | (_ :: _, nil) => GREATER
+
+fun compare ((t1, _), (t2, _)) =
+ case (t1, t2) of
+ (TFun (d1, r1), TFun (d2, r2)) =>
+ join (compare (d1, d2), fn () => compare (r1, r2))
+ | (TCode (d1, r1), TCode (d2, r2)) =>
+ join (compare (d1, d2), fn () => compare (r1, r2))
+ | (TRecord xts1, TRecord xts2) =>
+ let
+ val xts2 = sortFields xts1
+ val xts2 = sortFields xts2
+ in
+ joinL compareFields (xts1, xts2)
+ end
+ | (TNamed n1, TNamed n2) => Int.compare (n1, n2)
+
+ | (TFun _, _) => LESS
+ | (_, TFun _) => GREATER
+
+ | (TCode _, _) => LESS
+ | (_, TCode _) => GREATER
+
+ | (TRecord _, _) => LESS
+ | (_, TRecord _) => GREATER
+
+and compareFields ((x1, t1), (x2, t2)) =
+ join (String.compare (x1, x2),
+ fn () => compare (t1, t2))
+
+and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (x, y) = GREATER) xts
+
fun mapfold fc =
let
fun mft c acc =