v0.18~preview.130.05+548

ppx_bonsai/src/expander/balance_list_tree.ml → balance_list_tree/src/balance_list_tree.ml

@@ -22,16 +22,14 @@ let balance ~n nodes =
     | _ when Nonempty_list.length chunks > n -> Nonempty_list.map chunks ~f:loop |> loop
     | _ -> Node (Nonempty_list.map chunks ~f:loop)
   in
-  match loop nodes with
-  | Leaf _ as single -> Nonempty_list.singleton single
-  | Node ls -> ls
+  loop nodes
 ;;
 
 let balance ~n list =
   match Nonempty_list.of_list list with
   | None -> Or_error.error_string "expand_letn: list of bindings must be non-empty"
   | Some _ when n <= 0 -> Or_error.error_string "expand_letn: n must be positive"
-  | Some [ singleton ] when n = 1 -> Ok (Nonempty_list.singleton (Leaf singleton))
+  | Some [ singleton ] when n = 1 -> Ok (Leaf singleton)
   | Some _ when n = 1 ->
     Or_error.error_string
       "expand_letn: n may only be 1 if the length of the input list is exactly 1"

ppx_bonsai/src/expander/balance_list_tree.mli → balance_list_tree/src/balance_list_tree.mli

@@ -12,4 +12,4 @@ type 'a t = private
     - the length of the list is < 1, or
     - n <= 0, or
     - n = 1, and the length of the list is not exactly 1 *)
-val balance : n:int -> 'a list -> 'a t Nonempty_list.t Or_error.t
+val balance : n:int -> 'a list -> 'a t Or_error.t

balance_list_tree/src/dune

@@ -0,0 +1,6 @@
+(library
+ (name balance_list_tree)
+ (public_name bonsai.balance_list_tree)
+ (libraries core core_kernel.nonempty_list)
+ (preprocess
+  (pps ppx_jane)))

balance_list_tree/test/balance_list_tree_test.ml

@@ -0,0 +1,142 @@
+open Core
+open Balance_list_tree
+
+let test ~n ~list_len =
+  let list = List.init list_len ~f:Fn.id in
+  match balance ~n list with
+  | Error error -> print_s [%message (error : Error.t)]
+  | Ok result -> print_s [%sexp (result : int t)]
+;;
+
+let%expect_test "special case of ~n=1, list_len=1" =
+  test ~n:1 ~list_len:1;
+  [%expect {| (Leaf 0) |}]
+;;
+
+let%expect_test "basic behavior" =
+  test ~n:2 ~list_len:5;
+  [%expect
+    {|
+    (Node
+     ((Node ((Node ((Leaf 0) (Leaf 1))) (Node ((Leaf 2) (Leaf 3))))) (Leaf 4)))
+    |}];
+  test ~n:5 ~list_len:20;
+  [%expect
+    {|
+    (Node
+     ((Node ((Leaf 0) (Leaf 1) (Leaf 2) (Leaf 3) (Leaf 4)))
+      (Node ((Leaf 5) (Leaf 6) (Leaf 7) (Leaf 8) (Leaf 9)))
+      (Node ((Leaf 10) (Leaf 11) (Leaf 12) (Leaf 13) (Leaf 14)))
+      (Node ((Leaf 15) (Leaf 16) (Leaf 17) (Leaf 18) (Leaf 19)))))
+    |}]
+;;
+
+let%expect_test "(mod n list_len = mod n (-1))" =
+  test ~n:2 ~list_len:16;
+  [%expect
+    {|
+    (Node
+     ((Node
+       ((Node ((Node ((Leaf 0) (Leaf 1))) (Node ((Leaf 2) (Leaf 3)))))
+        (Node ((Node ((Leaf 4) (Leaf 5))) (Node ((Leaf 6) (Leaf 7)))))))
+      (Node
+       ((Node ((Node ((Leaf 8) (Leaf 9))) (Node ((Leaf 10) (Leaf 11)))))
+        (Node ((Node ((Leaf 12) (Leaf 13))) (Node ((Leaf 14) (Leaf 15)))))))))
+    |}];
+  test ~n:3 ~list_len:5;
+  [%expect {| (Node ((Node ((Leaf 0) (Leaf 1) (Leaf 2))) (Node ((Leaf 3) (Leaf 4))))) |}];
+  test ~n:3 ~list_len:11;
+  [%expect
+    {|
+    (Node
+     ((Node
+       ((Node ((Leaf 0) (Leaf 1) (Leaf 2))) (Node ((Leaf 3) (Leaf 4) (Leaf 5)))
+        (Node ((Leaf 6) (Leaf 7) (Leaf 8)))))
+      (Node ((Leaf 9) (Leaf 10)))))
+    |}];
+  test ~n:7 ~list_len:13;
+  [%expect
+    {|
+    (Node
+     ((Node ((Leaf 0) (Leaf 1) (Leaf 2) (Leaf 3) (Leaf 4) (Leaf 5) (Leaf 6)))
+      (Node ((Leaf 7) (Leaf 8) (Leaf 9) (Leaf 10) (Leaf 11) (Leaf 12)))))
+    |}];
+  test ~n:5 ~list_len:19;
+  [%expect
+    {|
+    (Node
+     ((Node ((Leaf 0) (Leaf 1) (Leaf 2) (Leaf 3) (Leaf 4)))
+      (Node ((Leaf 5) (Leaf 6) (Leaf 7) (Leaf 8) (Leaf 9)))
+      (Node ((Leaf 10) (Leaf 11) (Leaf 12) (Leaf 13) (Leaf 14)))
+      (Node ((Leaf 15) (Leaf 16) (Leaf 17) (Leaf 18)))))
+    |}]
+;;
+
+let%expect_test "errors" =
+  test ~n:(-1) ~list_len:5;
+  [%expect {| (error "expand_letn: n must be positive") |}];
+  test ~n:0 ~list_len:5;
+  [%expect {| (error "expand_letn: n must be positive") |}];
+  test ~n:5 ~list_len:0;
+  [%expect {| (error "expand_letn: list of bindings must be non-empty") |}]
+;;
+
+let%expect_test "regression" =
+  test ~n:7 ~list_len:50;
+  [%expect
+    {|
+    (Node
+     ((Node
+       ((Node ((Leaf 0) (Leaf 1) (Leaf 2) (Leaf 3) (Leaf 4) (Leaf 5) (Leaf 6)))
+        (Node
+         ((Leaf 7) (Leaf 8) (Leaf 9) (Leaf 10) (Leaf 11) (Leaf 12) (Leaf 13)))
+        (Node
+         ((Leaf 14) (Leaf 15) (Leaf 16) (Leaf 17) (Leaf 18) (Leaf 19) (Leaf 20)))
+        (Node
+         ((Leaf 21) (Leaf 22) (Leaf 23) (Leaf 24) (Leaf 25) (Leaf 26) (Leaf 27)))
+        (Node
+         ((Leaf 28) (Leaf 29) (Leaf 30) (Leaf 31) (Leaf 32) (Leaf 33) (Leaf 34)))
+        (Node
+         ((Leaf 35) (Leaf 36) (Leaf 37) (Leaf 38) (Leaf 39) (Leaf 40) (Leaf 41)))
+        (Node
+         ((Leaf 42) (Leaf 43) (Leaf 44) (Leaf 45) (Leaf 46) (Leaf 47) (Leaf 48)))))
+      (Leaf 49)))
+    |}]
+;;
+
+let%quick_test "balancer is balanced, doesn't have more than `n` children per node, and \
+                has all leaves exactly once. Also, leaves preserve order. "
+  =
+  fun (n : (int[@generator Int.gen_uniform_incl 0 15]))
+    (list_len : (int[@generator Int.gen_uniform_incl 0 1_000])) ->
+  let list = List.init list_len ~f:Fn.id in
+  match balance ~n list, n, list with
+  | Error _, _, [] | Error _, 0, _ -> ()
+  | Error _, 1, ls when List.length ls > 1 -> ()
+  | Error err, _, _ ->
+    Error.raise_s
+      [%message "Balancer errored" (err : Error.t) (n : int) (List.length list : int)]
+  | Ok balanced, _, _ ->
+    let last_visited_leaf = ref (-1) in
+    let rec traverse ~depth = function
+      | Leaf v ->
+        assert (v = !last_visited_leaf + 1);
+        last_visited_leaf := v
+      | Node children ->
+        (match children with
+         | [ Leaf _ ] -> raise_s [%message "Found an unflattened node!"]
+         | _ -> ());
+        assert (Nonempty_list.length children <= n);
+        Nonempty_list.fold children ~init:`Seen_no_leaves ~f:(fun acc child ->
+          traverse ~depth:(depth + 1) child;
+          match acc, child with
+          | `Seen_no_leaves, Node _ -> `Seen_no_leaves
+          | `Seen_no_leaves, Leaf _ -> `Seen_leaves
+          | `Seen_leaves, Node _ -> failwith "All nodes must be before all leaves"
+          | `Seen_leaves, Leaf _ -> `Seen_leaves)
+        |> Fn.ignore
+    in
+    traverse ~depth:0 balanced;
+    assert (List.length list = !last_visited_leaf + 1);
+    [%expect {| |}]
+;;

balance_list_tree/test/dune

@@ -0,0 +1,6 @@
+(library
+ (name balance_list_tree_test)
+ (libraries balance_list_tree core patdiff.expect_test_patdiff
+   core_kernel.nonempty_list)
+ (preprocess
+  (pps ppx_jane ppx_expect ppx_bonsai ppxlib.metaquot ppx_quick_test)))

bonsai.opam

@@ -18,6 +18,7 @@ depends: [
   "core_kernel"
   "incr_map"
   "incremental"
+  "ocaml-embed-file"
   "ppx_here"
   "ppx_jane"
   "ppx_let"
@@ -26,7 +27,6 @@ depends: [
   "uopt"
   "virtual_dom"
   "dune"             {>= "3.11.0"}
-  "ocaml-embed-file"
   "ppxlib"           {>= "0.33.0"}
 ]
 available: arch != "arm32" & arch != "x86_32"

ppx_bonsai/src/expander/dune

@@ -1,7 +1,7 @@
 (library
  (name ppx_bonsai_expander)
  (public_name bonsai.ppx_bonsai_expander)
- (libraries core core_kernel.nonempty_list ppxlib ppxlib_jane
-   ppx_let.expander ppx_pattern_bind ppx_here.expander)
+ (libraries balance_list_tree core core_kernel.nonempty_list
+   ppx_here.expander ppx_let.expander ppx_pattern_bind ppxlib ppxlib_jane)
  (preprocess
   (pps ppxlib.metaquot ppx_jane)))

ppx_bonsai/src/expander/ppx_bonsai_expander.ml

@@ -89,9 +89,13 @@ let sub (location_behavior : Location_behavior.t) : (module Ext) =
              List.fold
                pattern_projections
                ~init:body
-               ~f:(fun expr { txt = binding; loc } ->
+               ~f:(fun expr { txt = binding; loc = _ } ->
                  sub_return
-                   ~loc
+                   ~loc:
+                     { loc_start = lhs.ppat_loc.loc_start
+                     ; loc_end = body.pexp_loc.loc_end
+                     ; loc_ghost = true
+                     }
                    ~modul
                    ~lhs:binding.pvb_pat
                    ~rhs:binding.pvb_expr
@@ -154,13 +158,16 @@ let sub (location_behavior : Location_behavior.t) : (module Ext) =
 
     let expand_match ~loc ~modul ~locality expr =
       let expr =
-        match expr.pexp_desc with
-        | Pexp_tuple expressions ->
-          match_tuple_mapper
-            ~modul
-            ~loc:{ expr.pexp_loc with loc_ghost = true }
-            ~expressions
-            ~locality
+        match Ppxlib_jane.Shim.Expression_desc.of_parsetree ~loc expr.pexp_desc with
+        | Pexp_tuple labeled_expressions ->
+          (match Ppxlib_jane.as_unlabeled_tuple labeled_expressions with
+           | Some expressions ->
+             match_tuple_mapper
+               ~modul
+               ~loc:{ expr.pexp_loc with loc_ghost = true }
+               ~expressions
+               ~locality
+           | None -> expr)
         | _ -> expr
       in
       function
@@ -238,20 +245,20 @@ let arr (location_behavior : Location_behavior.t) : (module Ext) =
             match acc with
             | true -> true
             | false ->
-              (match Ppxlib_jane.Jane_syntax.Pattern.of_ast pattern with
-               | Some (Jpat_tuple (_tuple, Open), _attrs) -> true
-               | _ ->
-                 (match Ppxlib_jane.Shim.Pattern_desc.of_parsetree pattern.ppat_desc with
-                  (* let (_ as a) = x in ... *)
-                  | Ppat_alias (_, _) -> false
-                  | Ppat_any
-                  (* let { a ; b ; _ } = x in ... *)
-                  | Ppat_record (_, Open)
-                  (* let { a = (module _) ; b } = x in ... *)
-                  | Ppat_unpack { txt = None; _ } -> true
-                  | Ppat_record (_, Closed) | Ppat_unpack { txt = Some _; _ } ->
-                    super#pattern pattern acc
-                  | _ -> super#pattern pattern acc))
+              (match Ppxlib_jane.Shim.Pattern_desc.of_parsetree pattern.ppat_desc with
+               (* let (_ as a) = x in ... *)
+               | Ppat_alias (_, _) -> false
+               | Ppat_any
+               (* let { a ; b ; _ } = x in ... *)
+               | Ppat_record (_, Open)
+               (* let ~a, .. = x in ... *)
+               | Ppat_tuple (_, Open)
+               (* let { a = (module _) ; b } = x in ... *)
+               | Ppat_unpack { txt = None; _ } -> true
+               | Ppat_record (_, Closed)
+               | Ppat_tuple (_, Closed)
+               | Ppat_unpack { txt = Some _; _ } -> super#pattern pattern acc
+               | _ -> super#pattern pattern acc)
         end
       in
       ignore_finder#pattern pattern false
@@ -478,7 +485,12 @@ let arr (location_behavior : Location_behavior.t) : (module Ext) =
         in
         match Balance_list_tree.balance ~n ppx_bindings with
         | Error err -> invalid_arg (Error.to_string_hum err)
-        | Ok subtrees ->
+        | Ok balanced ->
+          let subtrees =
+            match balanced with
+            | Balance_list_tree.Leaf _ -> Nonempty_list.singleton balanced
+            | Node xs -> xs
+          in
           let exps, pats = Nonempty_list.map subtrees ~f:loop |> Nonempty_list.unzip in
           let f_exp = build_multiarg_fun ~args:pats ~body:ppx_body in
           build_application exps ~f_exp ~op_name:"arr"

ppx_bonsai/test/error_location_tests/test_match_sub_type_error_location.mlt

@@ -0,0 +1,74 @@
+#print_line_numbers true
+
+open! Bonsai
+open Bonsai.Let_syntax
+
+(* This test file is a regression test for a bug where the errors from the match
+   arms of a match%sub were instead reported at the start of the match%sub which results
+   in confusing type error messages! *)
+
+type t =
+  | A of int
+  | B of int
+  | C of t list
+
+let _component t (local_ _graph) =
+  match%sub t with
+  | A x ->
+    let%arr x in
+    x
+  | B x ->
+    let%arr x in
+    x
+  | C l ->
+    let%arr l in
+    let _ = l in
+    Bonsai.return 1.0
+;;
+
+[%%expect
+  {xxx|
+Line 23, characters 4-66:
+Error: This expression has type float Bonsai.t Bonsai.t
+       but an expression was expected of type int Bonsai.t
+       Type float Bonsai.t is not compatible with type int
+|xxx}]
+
+let _more_basic_component t (local_ _graph) =
+  match%sub Bonsai.return false with
+  | false ->
+    (* An int! *)
+    Bonsai.return 1
+  | true ->
+    (* A float! *)
+    Bonsai.return 1.0
+;;
+
+(* This one is fine! *)
+
+[%%expect
+  {|
+Line 44, characters 4-21:
+Error: This expression has type float Bonsai.t
+       but an expression was expected of type int Bonsai.t
+       Type float is not compatible with type int
+|}]
+
+let _more_basic_component t (local_ _graph) =
+  match%sub Bonsai.return false with
+  | false ->
+    (* An int! *)
+    Bonsai.return 1
+  | true ->
+    (* A float! *)
+    Bonsai.return (Bonsai.return 1)
+;;
+
+(* This one is also fine! (error points to a useful location) *)
+[%%expect
+  {|
+Line 64, characters 4-35:
+Error: This expression has type int Bonsai.t Bonsai.t
+       but an expression was expected of type int Bonsai.t
+       Type int Bonsai.t is not compatible with type int
+|}]