diff --git a/src/pp.ml b/src/pp.ml index 37edc8c..8a088c6 100644 --- a/src/pp.ml +++ b/src/pp.ml @@ -223,7 +223,7 @@ end let of_fmt f x = Format (fun ppf -> f ppf x) -let compare compare_tag = +let compare = let compare_both (type a b) (f : a -> a -> int) (g : b -> b -> int) (a, b) (c, d) = let r = f a c in @@ -232,62 +232,75 @@ let compare compare_tag = else g b d in - let rec compare x y = - match (x, y) with - | Nop, Nop -> 0 - | Nop, _ -> -1 - | _, Nop -> 1 - | Seq (a, b), Seq (c, d) -> compare_both compare compare (a, b) (c, d) - | Seq _, _ -> -1 - | _, Seq _ -> 1 - | Concat (a, b), Concat (c, d) -> - compare_both compare (List.compare ~cmp:compare) (a, b) (c, d) - | Concat _, _ -> -1 - | _, Concat _ -> 1 - | Box (a, b), Box (c, d) -> compare_both Int.compare compare (a, b) (c, d) - | Box _, _ -> -1 - | _, Box _ -> 1 - | Vbox (a, b), Vbox (c, d) -> compare_both Int.compare compare (a, b) (c, d) - | Vbox _, _ -> -1 - | _, Vbox _ -> 1 - | Hbox a, Hbox b -> compare a b - | Hbox _, _ -> -1 - | _, Hbox _ -> 1 - | Hvbox (a, b), Hvbox (c, d) -> - compare_both Int.compare compare (a, b) (c, d) - | Hvbox _, _ -> -1 - | _, Hvbox _ -> 1 - | Hovbox (a, b), Hovbox (c, d) -> - compare_both Int.compare compare (a, b) (c, d) - | Hovbox _, _ -> -1 - | _, Hovbox _ -> 1 - | Verbatim a, Verbatim b -> String.compare a b - | Verbatim _, _ -> -1 - | _, Verbatim _ -> 1 - | Char a, Char b -> Char.compare a b - | Char _, _ -> -1 - | _, Char _ -> 1 - | Break (a, b), Break (c, d) -> - let compare (x, y, z) (a, b, c) = - compare_both String.compare - (compare_both Int.compare String.compare) - (x, (y, z)) - (a, (b, c)) - in - compare_both compare compare (a, b) (c, d) - | Break _, _ -> -1 - | _, Break _ -> 1 - | Newline, Newline -> 0 - | Newline, _ -> -1 - | _, Newline -> 1 - | Text a, Text b -> String.compare a b - | Text _, _ -> -1 - | _, Text _ -> 1 - | Tag (a, b), Tag (c, d) -> compare_both compare_tag compare (a, b) (c, d) - | Format _, Format _ -> - raise - (Invalid_argument "[Pp.of_fmt] values not supported in [Pp.compare]") - | Format _, _ -> -1 - | _, Format _ -> 1 + (* Due to 4.08 lower bound, we need to define this here. *) + let rec compare_list a b ~cmp:f : int = + match (a, b) with + | [], [] -> 0 + | [], _ :: _ -> -1 + | _ :: _, [] -> 1 + | x :: a, y :: b -> ( + match (f x y : int) with + | 0 -> compare_list a b ~cmp:f + | ne -> ne) in - compare + fun compare_tag -> + let rec compare x y = + match (x, y) with + | Nop, Nop -> 0 + | Nop, _ -> -1 + | _, Nop -> 1 + | Seq (a, b), Seq (c, d) -> compare_both compare compare (a, b) (c, d) + | Seq _, _ -> -1 + | _, Seq _ -> 1 + | Concat (a, b), Concat (c, d) -> + compare_both compare (compare_list ~cmp:compare) (a, b) (c, d) + | Concat _, _ -> -1 + | _, Concat _ -> 1 + | Box (a, b), Box (c, d) -> compare_both Int.compare compare (a, b) (c, d) + | Box _, _ -> -1 + | _, Box _ -> 1 + | Vbox (a, b), Vbox (c, d) -> + compare_both Int.compare compare (a, b) (c, d) + | Vbox _, _ -> -1 + | _, Vbox _ -> 1 + | Hbox a, Hbox b -> compare a b + | Hbox _, _ -> -1 + | _, Hbox _ -> 1 + | Hvbox (a, b), Hvbox (c, d) -> + compare_both Int.compare compare (a, b) (c, d) + | Hvbox _, _ -> -1 + | _, Hvbox _ -> 1 + | Hovbox (a, b), Hovbox (c, d) -> + compare_both Int.compare compare (a, b) (c, d) + | Hovbox _, _ -> -1 + | _, Hovbox _ -> 1 + | Verbatim a, Verbatim b -> String.compare a b + | Verbatim _, _ -> -1 + | _, Verbatim _ -> 1 + | Char a, Char b -> Char.compare a b + | Char _, _ -> -1 + | _, Char _ -> 1 + | Break (a, b), Break (c, d) -> + let compare (x, y, z) (a, b, c) = + compare_both String.compare + (compare_both Int.compare String.compare) + (x, (y, z)) + (a, (b, c)) + in + compare_both compare compare (a, b) (c, d) + | Break _, _ -> -1 + | _, Break _ -> 1 + | Newline, Newline -> 0 + | Newline, _ -> -1 + | _, Newline -> 1 + | Text a, Text b -> String.compare a b + | Text _, _ -> -1 + | _, Text _ -> 1 + | Tag (a, b), Tag (c, d) -> compare_both compare_tag compare (a, b) (c, d) + | Format _, Format _ -> + raise + (Invalid_argument "[Pp.of_fmt] values not supported in [Pp.compare]") + | Format _, _ -> -1 + | _, Format _ -> 1 + in + compare