fix: add compatability for OCaml 4.08 and above.

Signed-off-by: Ali Caglayan <[email protected]>
ocaml-dune · Aug 22, 2023 · 12b389b · 12b389b
1 parent 892e7ec
commit 12b389b
Showing 1 changed file with 72 additions and 59 deletions.
diff --git 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