[MLton-commit] r6053

[Vesa Karvonen]

Lexicographic product combinator for orderings.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cmp.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/cmp.sig

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml	2007-09-27 10:53:54 UTC (rev 6052)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml	2007-09-28 08:33:52 UTC (rev 6053)
@@ -56,7 +56,7 @@
 structure Fix = struct type 'a t = 'a UnOp.t -> 'a end
 structure Reader = struct type ('a, 'b) t = 'b -> ('a * 'b) Option.t end
 structure Writer = struct type ('a, 'b) t = 'a * 'b -> 'b end
-structure Cmp = struct type 'a t = 'a Sq.t -> Order.t end
+structure Cmp = struct open Product type 'a t = 'a Sq.t -> Order.t end
 structure BinOp = struct type 'a t = 'a Sq.t -> 'a end
 structure BinPr = struct type 'a t = 'a Sq.t UnPr.t end
 structure Emb = struct type ('a, 'b) t = ('a -> 'b) * ('b -> 'a Option.t) end

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cmp.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cmp.sml	2007-09-27 10:53:54 UTC (rev 6052)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/fn/cmp.sml	2007-09-28 08:33:52 UTC (rev 6053)
@@ -7,8 +7,15 @@
 structure Cmp :> CMP = struct
    open Cmp
 
+   infix &
+
    fun map b2a = Fn.map (Sq.map b2a, Fn.id)
 
+   fun op *` (aO, bO) (lA & lB, rA & rB) =
+       case aO (lA, rA)
+        of EQUAL => bO (lB, rB)
+         | other => other
+
    local
       open Order
    in

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/cmp.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/cmp.sig	2007-09-27 10:53:54 UTC (rev 6052)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/fn/cmp.sig	2007-09-28 08:33:52 UTC (rev 6053)
@@ -15,6 +15,12 @@
    val map : ('b -> 'a) -> 'a t -> 'b t
    (** Changes the domain of an ordering. *)
 
+   val *` : 'a t * 'b t -> ('a, 'b) Product.t t
+   (**
+    * Given orderings for {'a} and {'b} returns the lexicographic ordering
+    * for their product {('a, 'b) Product.t}.
+    *)
+
    val mkRelOps : 'a t -> {<  : 'a BinPr.t, <= : 'a BinPr.t,
                            >  : 'a BinPr.t, >= : 'a BinPr.t,
                            == : 'a BinPr.t, != : 'a BinPr.t}