Kakadu / zanuda / 83

Committed 30 Jun 2026 07:08PM UTC coverage: 85.004% (+0.06%) from 84.943%

Build # 83

Build Type

push

github

Committed by

Kakadu

Commit Message

Fix compilation errors after rebase

Signed-off-by: Kakadu <Kakadu@pm.me>

Coverage Stats

6 of 6 new or added lines in 1 file covered. (100.0%)

17 existing lines in 2 files now uncovered.

2256 of 2654 relevant lines covered (85.0%)

565.59 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

76.06

/src/pattern/Tast_pattern.ml

[@@@ocaml.text "/*"]

(** Copyright 2021-2025, Kakadu. *)

(** SPDX-License-Identifier: LGPL-3.0-or-later *)

[@@@ocaml.text "/*"]

module Ast_pattern0 = struct
  exception Expected of Location.t * string

  let fail loc expected = raise (Expected (loc, expected))

  type context =
    { (* [matched] counts how many constructors have been matched. This is used to find what
         pattern matches the most some piece of ast in [Ast_pattern.alt]. In the case where
         all branches fail to match, we report the error from the one that matches the
         most.
         This is only incremented by combinators that can fail. *)
      mutable matched : int
    }

  type ('matched_value, 'k, 'k_result) t =
    | T of (context -> Location.t -> 'matched_value -> 'k -> 'k_result)

  (* end of copy-paste from https://github.com/ocaml-ppx/ppxlib/blob/0.22.2/src/ast_pattern0.ml *)
  (* TODO: deal with licencing issues *)
end

open Location
open Format
open Ast_pattern0

let debug_enabled = false

let log fmt =
  let open Format in
  if debug_enabled then kasprintf (printf "%s\n%!") fmt else ifprintf std_formatter fmt
;;

type ('a, 'b, 'c) t = ('a, 'b, 'c) Ast_pattern0.t

let save_context ctx = ctx.matched
let restore_context ctx backup = ctx.matched <- backup
let incr_matched c = c.matched <- c.matched + 1

let parse (T f) loc ?on_error x k =
  try f { matched = 0 } loc x k with
  | Expected (loc, expected) ->
    (match on_error with
     | None -> Location.raise_errorf ~loc "%s expected" expected
     | Some f -> f expected)
;;

module Packed = struct
  type ('a, 'b) t = T : ('a, 'b, 'c) Ast_pattern0.t * 'b -> ('a, 'c) t

  let create t f = T (t, f)
  let parse (T (t, f)) loc x = parse t loc x f
end

let __ : 'a 'b. ('a, 'a -> 'b, 'b) t =
  T
    (fun ctx _loc x k ->
      incr_matched ctx;
      k x)
;;

let as__ : 'a 'b 'c. ('a, 'b, 'c) t -> ('a, 'a -> 'b, 'c) t =
  fun (T f1) ->
  T
    (fun ctx loc x k ->
      let k = f1 ctx loc x (k x) in
      k)
;;

let pair (T f1) (T f2) =
  T
    (fun ctx loc (x1, x2) k ->
      let k = f1 ctx loc x1 k in
      let k = f2 ctx loc x2 k in
      k)
;;

let ( ** ) = pair

let __' =
  T
    (fun ctx loc x k ->
      incr_matched ctx;
      k { loc; txt = x })
;;

let drop : 'a 'b. ('a, 'b, 'b) t =
  T
    (fun ctx _loc _ k ->
      incr_matched ctx;
      k)
;;

let ( +?? ) (T fargs) msg =
  T
    (fun ctx loc e k ->
      try fargs ctx loc e k with
      | Ast_pattern0.Expected (loc, _) -> fail loc msg)
;;

let cst ~to_string ?(equal = Stdlib.( = )) v =
  T
    (fun ctx loc x k ->
      if equal x v
      then (
        incr_matched ctx;
        (* printf "cst succeeded for %s\n%!" (to_string v); *)
        k)
      else fail loc (to_string v))
;;

let int v = cst ~to_string:Int.to_string v
let char v = cst ~to_string:(Printf.sprintf "%C") v
let string v = cst ~to_string:(Printf.sprintf "%S") v
let float v = cst ~to_string:Float.to_string v
let int32 v = cst ~to_string:Int32.to_string v
let int64 v = cst ~to_string:Int64.to_string v
let nativeint v = cst ~to_string:Nativeint.to_string v
let bool v = cst ~to_string:Bool.to_string v

let false_ =
  T
    (fun ctx loc x k ->
      match x with
      | false ->
        ctx.matched <- ctx.matched + 1;
        k
      | _ -> fail loc "false")
;;

let true_ =
  T
    (fun ctx loc x k ->
      match x with
      | true ->
        ctx.matched <- ctx.matched + 1;
        k
      | _ -> fail loc "true")
;;

let nil =
  T
    (fun ctx loc x k ->
      log "trying [] \n%!";
      match x with
      | [] ->
        ctx.matched <- ctx.matched + 1;
        k
      | _ -> fail loc "[]")
;;

let ( ^:: ) (T f0) (T f1) =
  T
    (fun ctx loc x k ->
      match x with
      | x0 :: x1 ->
        ctx.matched <- ctx.matched + 1;
        (* Format.printf "trying elem of cons cell\n%!"; *)
        let k = f0 ctx loc x0 k in
        (* Format.printf "trying tail of cons cell\n%!"; *)
        let k = f1 ctx loc x1 k in
        (* Format.printf "trying  cons cell succeeded\n%!"; *)
        k
      | _ ->
        (* Format.printf "failing elem of cons cell\n%!"; *)
        fail loc "::")
;;

let list (T fel) =
  let rec helper acc ctx loc xs k =
    match xs with
    | [] -> k (List.rev acc)
    | h :: tl ->
      (match fel ctx loc h Fun.id with
       | x -> helper (x :: acc) ctx loc tl k)
  in
  T (fun ctx loc xs k -> helper [] ctx loc xs k)
;;

let none =
  T
    (fun ctx loc x k ->
      match x with
      | None ->
        ctx.matched <- ctx.matched + 1;
        k
      | _ -> fail loc "None")
;;

let some (T f0) =
  T
    (fun ctx loc x k ->
      match x with
      | Some x0 ->
        ctx.matched <- ctx.matched + 1;
        let k = f0 ctx loc x0 k in
        k
      | _ -> fail loc "Some")
;;

let triple (T f1) (T f2) (T f3) =
  T
    (fun ctx loc (x1, x2, x3) k ->
      let k = f1 ctx loc x1 k in
      let k = f2 ctx loc x2 k in
      let k = f3 ctx loc x3 k in
      k)
;;

let alt (T f1) (T f2) =
  T
    (fun ctx loc x k ->
      let backup = save_context ctx in
      try f1 ctx loc x k with
      | e1 ->
        let m1 = save_context ctx in
        restore_context ctx backup;
        (try f2 ctx loc x k with
         | e2 ->
           let m2 = save_context ctx in
           if m1 >= m2
           then (
             restore_context ctx m1;
             raise e1)
           else raise e2))
;;

let ( ||| ) = alt

let conde = function
  | [] -> fail Location.none "Bad argument"
  | h :: tl -> List.fold_left ( ||| ) h tl
;;

let map (T func) ~f = T (fun ctx loc x k -> func ctx loc x (f k))
let map' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (f loc k))
let map_result (T func) ~f = T (fun ctx loc x k -> f (func ctx loc x k))
let ( >>| ) t f = map t ~f
let map0 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (k f))
let map1 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a -> k (f a)))
let map2 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a b -> k (f a b)))
let map3 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a b c -> k (f a b c)))

let map4 (T func) ~f =
  T (fun ctx loc x k -> func ctx loc x (fun a b c d -> k (f a b c d)))
;;

let map5 (T func) ~f =
  T (fun ctx loc x k -> func ctx loc x (fun a b c d e -> k (f a b c d e)))
;;

let map6 (T func) ~f:fmap =
  T (fun ctx loc x k -> func ctx loc x (fun a b c d e f -> k (fmap a b c d e f)))
;;

let map7 (T func) ~f:fmap =
  T (fun ctx loc x k -> func ctx loc x (fun a b c d e f g -> k (fmap a b c d e f g)))
;;

let map0' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (k (f loc)))
let map1' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a -> k (f loc a)))
let map2' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a b -> k (f loc a b)))
let map_result (T func) ~f = T (fun ctx loc x k -> f (func ctx loc x k))
let alt_option some none = alt (map1 some ~f:(fun x -> Some x)) (map0 none ~f:None)

let many (T f) =
  T (fun ctx loc l k -> k (ListLabels.map l ~f:(fun x -> f ctx loc x (fun x -> x))))
;;

let loc (T f) = T (fun ctx _loc (x : _ Ppxlib.Loc.t) k -> f ctx x.loc x.txt k)
let pack0 t = map t ~f:(fun f -> f ())
let pack2 t = map t ~f:(fun f x y -> f (x, y))
let pack3 t = map t ~f:(fun f x y z -> f (x, y, z))

(* end of copy-paste from https://github.com/ocaml-ppx/ppxlib/blob/0.22.2/src/ast_pattern.ml *)
(* TODO: deal with licencing issues *)

let lident (T fident) =
  T
    (fun ctx loc x k ->
      match x with
      | Longident.Lident id ->
        ctx.matched <- ctx.matched + 1;
        k |> fident ctx loc id
      | _ -> fail loc "lident")
;;

let elongident (lident : Longident.t) =
  T
    (fun ctx loc x k ->
      if Stdlib.compare x lident = 0
      then (
        ctx.matched <- ctx.matched + 1;
        k)
      else fail loc "elongident")
;;

[%%if ocaml_version < (5, 4, 0)]

let ldot_wrapper = Fun.id

[%%endif]
[%%if ocaml_version >= (5, 5, 0)]

let ldot_wrapper { txt; _ } = txt

[%%endif]

let ldot (T fl) (T fname) =
  T
    (fun ctx loc x k ->
      match x with
      | Longident.Ldot (ident, name) ->
        ctx.matched <- ctx.matched + 1;
        k |> fl ctx loc (ldot_wrapper ident) |> fname ctx loc (ldot_wrapper name)
      | _ -> fail loc "ldot")
;;

let path_pident (T fident) =
  T
    (fun ctx loc x k ->
      match x with
      | Path.Pident id ->
        ctx.matched <- ctx.matched + 1;
        k |> fident ctx loc id
      | _ -> fail loc "path_pident")
;;

let path xs =
  let rec helper ps ctx loc x k =
    let cmp_names l r =
      let ans = String.equal l r in
      (* printf "\t\tCompare names %s and %s:  %b\n%!" l r ans; *)
      ans
    in
    match x, ps with
    | Path.Pident id, [ id0 ] ->
      if cmp_names (Ident.name id) id0
      then (
        let () = ctx.matched <- ctx.matched + 1 in
        k)
      else fail loc "path"
    | Path.Pdot (next, id), id0 :: ids when cmp_names id id0 -> helper ids ctx loc next k
    | Path.Papply _, _ -> fail loc "path got Papply"
    | _ -> fail loc (sprintf "path %s" (String.concat "." xs))
  in
  T (helper (List.rev xs))
;;

let path_of_list = function
  | [] -> failwith "Bad argument: path_of_list"
  | s :: tl ->
    ListLabels.fold_left
      tl
      ~init:(Path.Pident (Ident.create_local s))
      ~f:(fun acc x -> Path.Pdot (acc, x))
;;

let%test_module " " =
  (module struct
    [@@@coverage off]

    let names = [ "Stdlib!"; "List"; "length" ]

    [%%if ocaml_version < (5, 0, 0)]

    let pp_path = Path.print

    [%%else]

    let pp_path = Format_doc.compat Path.print

    [%%endif]

    let%test_unit _ =
      let old = !Clflags.unique_ids in
      Clflags.unique_ids := false;
      [%test_eq: Base.string]
        "Stdlib!.List.length"
        (asprintf "%a" pp_path (path_of_list names));
      Clflags.unique_ids := old
    ;;

    let%test _ =
      let noloc =
        Warnings.
          { loc_start = Lexing.dummy_pos; loc_end = Lexing.dummy_pos; loc_ghost = true }
      in
      parse (path names) noloc ~on_error:(fun _ -> false) (path_of_list names) true
    ;;
  end)
;;

open Typedtree

let econst (T f0) =
  T
    (fun ctx loc x k ->
      match x.exp_desc with
      | Texp_constant n ->
        ctx.matched <- ctx.matched + 1;
        f0 ctx loc n k
      | _ -> fail loc (sprintf "econst"))
;;

let eint (T f0) =
  T
    (fun ctx loc x k ->
      match x.exp_desc with
      | Texp_constant (Asttypes.Const_int n) ->
        ctx.matched <- ctx.matched + 1;
        f0 ctx loc n k
      | _ -> fail loc "eint")
;;

let estring =
  T
    (fun ctx loc x k ->
      match x.exp_desc with
      | Texp_constant (Asttypes.Const_string (s, _, None)) ->
        ctx.matched <- ctx.matched + 1;
        k s
      | _ -> fail loc "estring")
;;

let ebool =
  T
    (fun ctx loc x k ->
      match x.exp_desc with
      | Texp_construct ({ txt = Lident "true" }, _, []) ->
        ctx.matched <- ctx.matched + 1;
        k true
      | Texp_construct ({ txt = Lident "false" }, _, []) ->
        ctx.matched <- ctx.matched + 1;
        k false
      | _ -> fail loc (sprintf "ebool"))
;;

[%%if ocaml_version < (5, 0, 0)]

let tpat_var (T fname) =
  T
    (fun ctx loc x k ->
      match x.pat_desc with
      | Tpat_var (_, { txt }) ->
        ctx.matched <- ctx.matched + 1;
        k |> fname ctx loc txt
      | _ -> fail loc "tpat_var")
;;

let tpat_id (T fname) =
  T
    (fun ctx loc x k ->
      match x.pat_desc with
      | Tpat_var (id, { loc }) ->
        ctx.matched <- ctx.matched + 1;
        k |> fname ctx loc id
      | _ -> fail loc "tpat_var_id")
;;

[%%else]

let tpat_var (T fname) =
  T
    (fun (type kind) ctx loc (x : kind pattern_desc pattern_data) k ->
      match x.pat_desc with
      | Tpat_var (_, { txt }, _uid) ->
        ctx.matched <- ctx.matched + 1;
        k |> fname ctx loc txt
      | Tpat_value v ->
        (match (v :> pattern).pat_desc with
         | Tpat_var (_, { txt }, _uid) ->
           ctx.matched <- ctx.matched + 1;
           k |> fname ctx loc txt
         | _ -> fail loc "tpat_var")
      | _ -> fail loc "tpat_var")
;;

let tpat_id (T fname) =
  T
    (fun (type kind) ctx loc (x : kind pattern_desc pattern_data) k ->
      match x.pat_desc with
      | Typedtree.Tpat_value v ->
        (match (v :> pattern).pat_desc with
         | Tpat_var (id, { loc }, _uid) ->
           ctx.matched <- ctx.matched + 1;
           k |> fname ctx loc id
         | _ -> fail loc "tpat_id")
      | Tpat_var (id, { loc }, _uid) ->
        ctx.matched <- ctx.matched + 1;
        k |> fname ctx loc id
      | _ -> fail loc "tpat_id 2")
;;

[%%endif]

let tpat_constructor (T fname) (T fargs) =
  T
    (fun ctx loc x k ->
      match x.pat_desc with
      | Tpat_construct ({ txt }, _, args, _) ->
        ctx.matched <- ctx.matched + 1;
        k |> fname ctx loc txt |> fargs ctx loc args
      | _ -> fail loc "tpat_constructor")
;;

[%%if ocaml_version < (5, 4, 0)]

let tpat_tuple (T fargs) =
  T
    (fun ctx loc x k ->
      match x.pat_desc with
      | Tpat_tuple pats ->
        ctx.matched <- ctx.matched + 1;
        k |> fargs ctx loc pats
      | _ -> fail loc "tpat_tuple")
;;

[%%else]

let tpat_tuple (T fargs) =
  T
    (fun ctx loc x k ->
      match x.pat_desc with
      | Tpat_tuple pats ->
        ctx.matched <- ctx.matched + 1;
        k |> fargs ctx loc (List.map snd pats)
      | _ -> fail loc "tpat_tuple")
;;

[%%endif]

let tpat_value (T fpat) =
  T
    (fun ctx loc x k ->
      match x.pat_desc with
      | Tpat_value arg ->
        let inner = (arg :> value pattern_desc pattern_data) in
        ctx.matched <- ctx.matched + 1;
        k |> fpat ctx loc inner
      | _ -> fail loc "tpat_value")
;;

let tpat_exception (T fpat) =
  T
    (fun ctx loc x k ->
      match x.pat_desc with
      | Tpat_exception exc ->
        ctx.matched <- ctx.matched + 1;
        k |> fpat ctx loc exc
      | _ -> fail loc "tpat_exception")
;;

let tpat_any =
  T
    (fun ctx loc x k ->
      match x.pat_desc with
      | Tpat_any ->
        ctx.matched <- ctx.matched + 1;
        k
      | _ -> fail loc "tpat_any")
;;

let texp_ident (T fpath) =
  T
    (fun ctx loc x k ->
      let __ _ = log "texp_ident %a\n%!" My_printtyped.expr x in
      match x.exp_desc with
      | Texp_ident (path, _, _) ->
        ctx.matched <- ctx.matched + 1;
        let ans = fpath ctx loc path k in
        log "texp_ident + %a\n%!" My_printtyped.expr x;
        ans
      | _ -> fail loc "texp_ident")
;;

let texp_ident_loc (T fpath) =
  T
    (fun ctx loc x k ->
      match x.exp_desc with
      | Texp_ident (path, _, _) ->
        ctx.matched <- ctx.matched + 1;
        k x.exp_loc |> fpath ctx loc path
      | _ -> fail loc "texp_ident")
;;

(* TODO(Kakadu): accept and Ident, and not a string *)
let pident (T fstr) =
  T
    (fun ctx loc x k ->
      match x with
      | Path.Pident id -> fstr ctx loc (Ident.name id) k
      | _ -> fail loc "pident")
;;

let texp_ident_typ (T fpath) (T ftyp) =
  T
    (fun ctx loc x k ->
      (* let __ _ = Format.printf "texp_ident_typ %a\n%!" MyPrinttyped.expr x in *)
      match x.exp_desc with
      | Texp_ident (path, _, typ) ->
        ctx.matched <- ctx.matched + 1;
        k |> fpath ctx loc path |> ftyp ctx loc typ.Types.val_type
      | _ -> fail loc "texp_ident_typ")
;;

[%%if ocaml_version < (5, 0, 0)]

let texp_assert (T fexp) =
  T
    (fun ctx loc x k ->
      match x.exp_desc with
      | Texp_assert e ->
        ctx.matched <- ctx.matched + 1;
        fexp ctx loc e k
      | _ -> fail loc "texp_assert")
;;

[%%else]

let texp_assert (T fexp) =
  T
    (fun ctx loc x k ->
       match x.exp_desc with
       | Texp_assert (e, _) ->
         ctx.matched <- ctx.matched + 1;
         fexp ctx loc e k
       | _ -> fail loc "texp_assert"
     : context -> Warnings.loc -> expression -> 'a -> 'b)
;;

[%%endif]

let texp_apply (T f0) (T args0) =
  T
    (fun ctx loc x k ->
      (* let __ _ = log "texp_apply %a\n%!" MyPrinttyped.expr x in *)
      match x.exp_desc with
      | Texp_apply (f, args) ->
        ctx.matched <- ctx.matched + 1;
        let ans = k |> f0 ctx loc f |> args0 ctx loc args in
        (* let _ = log "texp_apply + %a\n%!" MyPrinttyped.expr x in *)
        ans
      | _ -> fail loc "texp_apply")
;;

let texp_apply_nolabelled (T f0) (T args0) =
  let exception EarlyExit in
  let module M = struct
    [%%if ocaml_version < (5, 4, 0)]

    let extractor = function
      | Asttypes.Labelled _, _ | Asttypes.Optional _, _ | _, None -> raise EarlyExit
      | _, Some x -> x
    ;;

    [%%else]

    let extractor = function
      | Asttypes.Labelled _, _ | Asttypes.Optional _, _ | _, Omitted _ -> raise EarlyExit
      | _, Arg x -> x
    ;;

    [%%endif]
  end
  in
  T
    (fun ctx loc x k ->
      match x.exp_desc with
      | Texp_apply (f, args) ->
        ctx.matched <- ctx.matched + 1;
        let k = f0 ctx loc f k in
        (try
           let args = ListLabels.map args ~f:M.extractor in
           args0 ctx loc args k
         with
         | EarlyExit -> fail loc "texp_apply: None among the arguments")
      | _ -> fail loc "texp_apply")
;;

[%%if ocaml_version < (5, 4, 0)]

type constructor_description = Types.constructor_description
type label_description = Types.label_description

let label_name l = l.Types.lbl_name

type ('a, 'b) arg_or_omitted = 'a option
type apply_arg = (expression, unit) arg_or_omitted

let option_of_apply_arg = Fun.id

let arg (T fe) : (apply_arg, _, _) t =
  T
    (fun ctx loc x k ->
      match x with
      | Some a ->
        ctx.matched <- ctx.matched + 1;
        k |> fe ctx loc a
      | None -> fail loc (sprintf "arg"))
;;

[%%endif]
[%%if ocaml_version >= (5, 5, 0)]

type constructor_description = Data_types.constructor_description
type label_description = Data_types.label_description

let label_name l = l.Data_types.lbl_name

type ('a, 'b) arg_or_omitted = ('a, 'b) Typedtree.arg_or_omitted =
  | Arg of 'a
  | Omitted of 'b
[@@ocaml.warning "-unused-type-declaration"]

type apply_arg = (expression, unit) arg_or_omitted
[@@ocaml.warning "-unused-type-declaration"]

let option_of_apply_arg = function
  | Arg x -> Some x
  | Omitted _ -> None
;;

let arg (T fe) : (apply_arg, _, _) t =
  T
    (fun ctx loc x k ->
      match x with
      | Arg a ->
        ctx.matched <- ctx.matched + 1;
        k |> fe ctx loc a
      | _ -> fail loc (sprintf "arg"))
;;

[%%endif]

let texp_construct (T fpath) (T fcd) (T fargs) =
  T
    (fun ctx loc x k ->
      match x.exp_desc with
      | Texp_construct (path, cd, args) ->
        ctx.matched <- ctx.matched + 1;
        let k = fpath ctx loc path.txt k in
        k |> fcd ctx loc cd |> fargs ctx loc args
      | _ -> fail loc (sprintf "texp_construct"))
;;

let texp_assert_false () = texp_assert (texp_construct (lident (string "false")) drop nil)

let texp_let (T fvbs) (T fexpr) =
  T
    (fun ctx loc x k ->
      match x.exp_desc with
      | Texp_let (_flg, vbs, expr) ->
        ctx.matched <- ctx.matched + 1;
        k |> fvbs ctx loc vbs |> fexpr ctx loc expr
      | _ -> fail loc (sprintf "texp_let"))
;;

let nolabel =
  T
    (fun ctx loc x k ->
      match x with
      | Asttypes.Nolabel ->
        ctx.matched <- ctx.matched + 1;
        k
      | _ -> fail loc "nolabel")
;;

let labelled (T fstr) =
  T
    (fun ctx loc x k ->
      match x with
      | Asttypes.Labelled s ->
        ctx.matched <- ctx.matched + 1;
        k |> fstr ctx loc s
      | _ -> fail loc "labelled")
;;

let texp_apply1 f x = texp_apply f ((nolabel ** arg x) ^:: nil)
let texp_apply2 f x y = texp_apply f ((nolabel ** arg x) ^:: (nolabel ** arg y) ^:: nil)

[%%if ocaml_version < (4, 11, 2)]

(* 4.10 *)
type case_val = Typedtree.case
type case_comp = Typedtree.case
type value_pat = pattern
type comp_pat = pattern

[%%else]

type case_val = value case
type case_comp = computation case
type value_pat = value pattern_desc pattern_data
type comp_pat = computation pattern_desc pattern_data

[%%endif]
[%%if ocaml_version < (5, 0, 0)]

let texp_function (T fcases) =
  T
    (fun ctx loc e k ->
      match e.exp_desc with
      | Texp_function { cases } ->
        ctx.matched <- ctx.matched + 1;
        k |> fcases ctx loc cases
      | _ -> fail loc "texp_function")
;;

let texp_function_body (T fargs) (T frhs) =
  let rec helper acc ctx loc e k =
    match e.exp_desc with
    | Texp_function
        { cases =
            [ { c_lhs = { pat_desc = Tpat_var (pid, _); pat_loc; _ }
              ; c_rhs
              ; c_guard = None
              }
            ]
        ; arg_label
        ; partial = Total
        } -> helper ((arg_label, (pid, pat_loc)) :: acc) ctx loc c_rhs k
    | _ when [] = acc -> fail loc "texp_function_body"
    | _ -> k |> fargs ctx loc (List.rev acc) |> frhs ctx loc e
  in
  T (helper [])
;;

let texp_function_cases
  :  ((Asttypes.arg_label * (Ident.t * Location.t)) list, 'a, 'b) t
  -> (value case list, 'b, 'c) t
  -> (expression, 'a, 'c) t
  =
  fun (T fargs) (T frhs) ->
  let rec helper acc ctx loc e k =
    match e.exp_desc with
    | Typedtree.Texp_function
        { cases =
            [ { c_lhs = { pat_desc = Tpat_var (pid, tag); _ }; c_rhs; c_guard = _ } ]
        ; arg_label
        ; partial = Total
        } -> helper ((arg_label, (pid, tag.loc)) :: acc) ctx loc c_rhs k
    | Texp_function { cases = _ :: _ :: _ as cases; _ } ->
      k |> fargs ctx loc (List.rev acc) |> frhs ctx loc cases
    | _ -> fail loc "texp_function_cases"
  in
  T (helper [])
;;

[%%else]

let texp_function_cases (T fparam) (T fcases) =
  T
    (fun ctx loc e k ->
      match e.exp_desc with
      | Texp_function (params, Tfunction_cases cases) ->
        ctx.matched <- ctx.matched + 1;
        k
        |> fparam
             ctx
             loc
             (List.map (fun p -> p.Typedtree.fp_arg_label, (p.fp_param, p.fp_loc)) params)
        |> fcases ctx loc cases.cases
      | _ -> fail loc "texp_function")
;;

let texp_function_body (T fparam) (T fcases) =
  T
    (fun ctx loc e k ->
      match e.exp_desc with
      | Typedtree.Texp_function (params, Tfunction_body e) ->
        ctx.matched <- ctx.matched + 1;
        k
        |> fparam
             ctx
             loc
             (List.map (fun p -> p.fp_arg_label, (p.fp_param, p.fp_loc)) params)
        |> fcases ctx loc e
      | _ -> fail loc "texp_function")
;;

[%%endif]

let case (T pat) (T guard) (T rhs) =
  T
    (fun ctx loc { c_lhs; c_rhs; c_guard } k ->
      k |> pat ctx loc c_lhs |> guard ctx loc c_guard |> rhs ctx loc c_rhs)
;;

let ccase (T pat) (T guard) (T rhs) =
  T
    (fun ctx loc { c_lhs; c_rhs; c_guard } k ->
      k |> pat ctx loc c_lhs |> guard ctx loc c_guard |> rhs ctx loc c_rhs)
;;

[%%if ocaml_version < (5, 0, 0)]

let texp_match (T fexpr) (T fcomp_cases) (T fval_cases) =
  let rec split (type _a) (comps, vals) (cases : _ case list) =
    let _ : case_comp list = comps in
    let _ : case_val list = vals in
    let wrap (type a) comps vals : a case -> case_comp list * case_val list =
      let _ : case_comp list = comps in
      let _ : case_val list = vals in
      fun case ->
        match case with
        | { c_lhs = { pat_desc = Tpat_value p }; _ } ->
          ( comps
          , { c_lhs = (p :> pattern); c_rhs = case.c_rhs; c_guard = case.c_guard } :: vals
          )
        | { c_lhs = { pat_desc = Tpat_any }; _ } -> comps, (case :> case_val) :: vals
        | { c_lhs = { pat_desc = Tpat_var _ }; _ } -> comps, (case :> case_val) :: vals
        | { c_lhs = { pat_desc = Tpat_alias _ }; _ } -> comps, (case :> case_val) :: vals
        | { c_lhs = { pat_desc = Tpat_constant _ }; _ } ->
          comps, (case :> case_val) :: vals
        | { c_lhs = { pat_desc = Tpat_construct _ }; _ } ->
          comps, (case :> case_val) :: vals
        | { c_lhs = { pat_desc = Tpat_variant _ }; _ } ->
          comps, (case :> case_val) :: vals
        | { c_lhs = { pat_desc = Tpat_record _ }; _ } -> comps, (case :> case_val) :: vals
        | { c_lhs = { pat_desc = Tpat_array _ }; _ } -> comps, (case :> case_val) :: vals
        | { c_lhs = { pat_desc = Tpat_lazy _ }; _ } -> comps, (case :> case_val) :: vals
        (* | { c_lhs = { pat_desc = Tpat_value _ }; _ } -> (case :> case_comp) :: comps, vals *)
        | { c_lhs = { pat_desc = Tpat_exception _ }; _ } ->
          (case :> case_comp) :: comps, vals
        | { c_lhs = { pat_desc = Tpat_or _ }; _ } ->
          (* TODO(Kakadu): What to do here? We need to look deeply into or-pattern to understand where to place it?
            See issue #76
          *)
          (* failwith "Or-patterns are not yet implemented" *)
          comps, vals
        | { c_lhs; _ } ->
          (* Format.eprintf "%a\n%!" My_printtyped.pattern c_lhs; *)
          Format.eprintf
            "Unsupported pattern: tag = %d, is_block = %b\n"
            Obj.(tag @@ repr c_lhs)
            Obj.(is_block @@ repr c_lhs);
          assert false
    in
    match cases with
    | h :: tl -> split (wrap comps vals h) tl
    | [] -> List.rev comps, List.rev vals
  in
  T
    (fun ctx loc e k ->
      match e.exp_desc with
      | Texp_match (e, cases, _) ->
        ctx.matched <- ctx.matched + 1;
        let comp_cases, val_cases = split ([], []) cases in
        (* log
           "There are %d comp cases and %d val cases"
           (List.length comp_cases)
           (List.length val_cases); *)
        k
        |> fexpr ctx loc e
        |> fcomp_cases ctx loc comp_cases
        |> fval_cases ctx loc val_cases
      | _ -> fail loc "texp_match")
;;

[%%else]

let texp_match (T fexpr) (T fcomp_cases) (T fval_cases) =
  T
    (fun ctx loc e k ->
      match e.Typedtree.exp_desc with
      | Texp_match (e, ccases, vcases, _) ->
        let ccases, vcases =
          List.fold_left
            (fun (cacc, vacc) c ->
              match c.c_lhs.pat_desc with
              | Tpat_value v ->
                cacc, { c with c_lhs = (v :> value general_pattern) } :: vacc
              | _ -> cacc, vacc)
            ([], vcases)
            ccases
        in
        ctx.matched <- ctx.matched + 1;
        k |> fexpr ctx loc e |> fcomp_cases ctx loc ccases |> fval_cases ctx loc vcases
      | _ -> fail loc "texp_match")
;;

[%%endif]

let texp_ite (T pred) (T fthen) (T felse) =
  T
    (fun ctx loc e k ->
      match e.exp_desc with
      | Texp_ifthenelse (p, thenb, elseb) ->
        ctx.matched <- ctx.matched + 1;
        k |> pred ctx loc p |> fthen ctx loc thenb |> felse ctx loc elseb
      | _ -> fail loc "texp_ite")
;;

[%%if ocaml_version < (5, 0, 0)]

let texp_try (T fexpr) (T fcases) =
  T
    (fun ctx loc e k ->
      match e.exp_desc with
      | Texp_try (e, cases) ->
        ctx.matched <- ctx.matched + 1;
        k |> fexpr ctx loc e |> fcases ctx loc cases
      | _ -> fail loc "texp_try")
;;

[%%else]

let texp_try (T fexpr) (T fcases) =
  T
    (fun ctx loc e k ->
      match e.exp_desc with
      | Typedtree.Texp_try (e, cases, _) ->
        (* TODO: support effects *)
        ctx.matched <- ctx.matched + 1;
        k |> fexpr ctx loc e |> fcases ctx loc cases
      | _ -> fail loc "texp_try")
;;

[%%endif]

let texp_record (T fext) (T ffields) =
  T
    (fun ctx loc e k ->
      match e.exp_desc with
      | Texp_record { fields; extended_expression; _ } ->
        ctx.matched <- ctx.matched + 1;
        k |> fext ctx loc extended_expression |> ffields ctx loc fields
      | _ -> fail loc "texp_record")
;;

let texp_field (T fexpr) (T fdesc) =
  T
    (fun ctx loc e k ->
      match e.exp_desc with
      | Texp_field (e, _, desc) ->
        ctx.matched <- ctx.matched + 1;
        k |> fexpr ctx loc e |> fdesc ctx loc desc
      | _ -> fail loc "texp_field")
;;

[%%if ocaml_version < (5, 4, 0)]

let label_desc (T fname) =
  T
    (fun ctx loc e k ->
      match e with
      | { Types.lbl_name; _ } ->
        ctx.matched <- ctx.matched + 1;
        k |> fname ctx loc lbl_name)
;;

[%%else]

let label_desc (T fname) =
  T
    (fun ctx loc e k ->
      match e with
      | { Data_types.lbl_name; _ } ->
        ctx.matched <- ctx.matched + 1;
        k |> fname ctx loc lbl_name)
;;

[%%endif]

let rld_kept =
  T
    (fun ctx loc e k ->
      match e with
      | Kept _ ->
        ctx.matched <- ctx.matched + 1;
        k
      | _ -> fail loc "rld_kept")
;;

let rld_overriden (T flident) (T fexpr) =
  T
    (fun ctx loc e k ->
      match e with
      | Overridden ({ txt = lident }, e) ->
        ctx.matched <- ctx.matched + 1;
        k |> flident ctx loc lident |> fexpr ctx loc e
      | _ -> fail loc "rld_overriden")
;;

let value_binding (T fpat) (T fexpr) =
  T
    (fun ctx loc { vb_pat; vb_expr } k ->
      ctx.matched <- ctx.matched + 1;
      k |> fpat ctx loc vb_pat |> fexpr ctx loc vb_expr)
;;

let rec core_typ (T ftexpr) = T (fun ctx loc x k -> ftexpr ctx loc x.ctyp_type k)

let rec typ_constr (T fpath) (T fargs) =
  let rec helper ctx loc x k =
    (* Format.printf "typ = %a\n%!" Printtyp.type_expr x; *)
    match Types.get_desc x with
    | Tconstr (path, args, _) ->
      ctx.matched <- ctx.matched + 1;
      k |> fpath ctx loc path |> fargs ctx loc args
    | Tpoly (arg, []) | Tlink arg -> helper ctx loc arg k
    | _ ->
      (* let msg = Format.asprintf "typ_constr: %a " Printtyp.type_expr x in *)
      fail loc "typ_constr"
  in
  T helper
;;

let rec typ_arrow (T l) (T r) =
  let rec helper ctx loc x k =
    (* Format.printf "typ = %a\n%!" Printtyp.type_expr x; *)
    match Types.get_desc x with
    | Tarrow (_, tl, tr, _) ->
      ctx.matched <- ctx.matched + 1;
      k |> l ctx loc tl |> r ctx loc tr
    | _ -> fail loc "typ_arrow"
  in
  T helper
;;

let typ_kind_abstract =
  T
    (fun ctx loc x k ->
      match x with
      | Typedtree.Ttype_abstract ->
        ctx.matched <- ctx.matched + 1;
        k
      | _ -> fail loc "typ_kind_abstract")
;;

let typ_kind_open =
  T
    (fun ctx loc x k ->
      match x with
      | Typedtree.Ttype_open ->
        ctx.matched <- ctx.matched + 1;
        k
      | _ -> fail loc "typ_kind_open")
;;

let typ_kind_variant =
  T
    (fun ctx loc x k ->
      match x with
      | Typedtree.Ttype_variant _ ->
        ctx.matched <- ctx.matched + 1;
        k
      | _ -> fail loc "typ_kind_variant")
;;

let typ_kind_record (T flabels) =
  T
    (fun ctx loc x k ->
      match x with
      | Typedtree.Ttype_record labels ->
        ctx.matched <- ctx.matched + 1;
        k |> flabels ctx loc labels
      | _ -> fail loc "typ_kind_record")
;;

(* Structure *)

let tstr_attribute (T fattr) =
  T
    (fun ctx loc str k ->
      match str.str_desc with
      | Tstr_attribute attr ->
        ctx.matched <- ctx.matched + 1;
        k |> fattr ctx loc attr
      | _ -> fail loc "tstr_attribute")
;;

let tsig_attribute (T fattr) =
  T
    (fun ctx loc str k ->
      match str.sig_desc with
      | Tsig_attribute attr ->
        ctx.matched <- ctx.matched + 1;
        k |> fattr ctx loc attr
      | _ -> fail loc "tsig_attribute")
;;

let tsig_val_name (T fname) =
  T
    (fun ctx loc str k ->
      match str.sig_desc with
      | Tsig_value { val_id = txt } ->
        ctx.matched <- ctx.matched + 1;
        k |> fname ctx loc txt
      | _ -> fail loc "tsig_val_name")
;;

let attribute (T fname) (T fpayload) =
  T
    (fun ctx loc attr k ->
      let open Parsetree in
      k |> fname ctx loc attr.attr_name.txt |> fpayload ctx loc attr.attr_payload)
;;

let payload_stru (T fstru) =
  T
    (fun ctx loc x k ->
      match x with
      | Parsetree.PStr stru -> k |> fstru ctx loc stru
      | _ -> fail loc "payload_stru")
;;

let pstr_eval (T f) =
  T
    (fun ctx loc x k ->
      match x.Parsetree.pstr_desc with
      | Parsetree.Pstr_eval (e, _) -> k |> f ctx loc e
      | _ -> fail loc "pstr_eval")
;;

let pexp_constant (T f) =
  T
    (fun ctx loc e k ->
      match e.Parsetree.pexp_desc with
      | Parsetree.Pexp_constant e -> k |> f ctx loc e
      | _ -> fail loc "pexp_constant")
;;

[%%if ocaml_version < (5, 0, 0)]

let pexp_function_cases (T fargs) (T fcases) =
  let open Parsetree in
  let rec helper acc ctx loc x k =
    match x.pexp_desc with
    | Pexp_fun (Asttypes.Nolabel, None, pat, rhs) -> helper (pat :: acc) ctx loc rhs k
    | Pexp_function cases -> k |> fargs ctx loc (List.rev acc) |> fcases ctx loc cases
    | _ -> fail loc "pexp_function_cases"
  in
  T (helper [])
;;

let pexp_function_body (T fargs) (T fcases) =
  let open Parsetree in
  let rec helper acc ctx loc x k =
    match x.pexp_desc with
    | Pexp_fun (Asttypes.Nolabel, None, pat, rhs) -> helper (pat :: acc) ctx loc rhs k
    | _ -> k |> fargs ctx loc (List.rev acc) |> fcases ctx loc x
  in
  T (helper [])
;;

let pconst_string (T fstring) =
  T
    (fun ctx loc x k ->
      match x with
      | Parsetree.Pconst_string (s, _, _) -> k |> fstring ctx loc s
      | _ -> fail loc "pconst_string")
;;

[%%else]

let pexp_function_body (T fargs) (T fbody) =
  let open Parsetree in
  T
    (fun ctx loc x k ->
      match x.pexp_desc with
      | Pexp_function (params, _, Pfunction_body e) ->
        let args =
          List.map
            (fun p ->
              match p.pparam_desc with
              | Pparam_val (Nolabel, _, pat) -> pat
              | Pparam_newtype _ | _ -> fail loc "pexp_function_body: params")
            params
        in
        k |> fargs ctx loc args |> fbody ctx loc e
      | _ -> fail loc "pexp_function_body")
;;

let pexp_function_cases (T fargs) (T fcases) =
  let open Parsetree in
  T
    (fun ctx loc x k ->
      match x.pexp_desc with
      | Pexp_function (params, _, Pfunction_cases (cases, _, _)) ->
        let args =
          List.map
            (fun p ->
              match p.pparam_desc with
              | Pparam_val (Nolabel, _, pat) -> pat
              | Pparam_newtype _ | _ -> fail loc "pexp_function_cases: params")
            params
        in
        k |> fargs ctx loc args |> fcases ctx loc cases
      | _ -> fail loc "pexp_function_cases")
;;

let pconst_string (T fstring) =
  T
    (fun ctx loc x k ->
      match x.Parsetree.pconst_desc with
      | Parsetree.Pconst_string (s, _, _) -> k |> fstring ctx loc s
      | _ -> fail loc "pconst_string")
;;

[%%endif]

let payload_str (T fstru) =
  let open Parsetree in
  T
    (fun ctx loc x k ->
      match x with
      | PStr stru -> fstru ctx loc stru k
      | _ -> fail loc "payload_str")
;;

let pexp_apply (T f) (T fargs) =
  let open Parsetree in
  let helper ctx loc x k =
    match x.pexp_desc with
    | Pexp_apply (efun, eargs) -> k |> f ctx loc efun |> fargs ctx loc eargs
    | _ -> fail loc "pexp_apply"
  in
  T helper
;;

let tstr_zanuda_attr str =
  tstr_attribute
    (attribute
       (string "zanuda")
       (payload_stru (pstr_eval (pexp_constant (pconst_string str)) ^:: nil)))
;;

let pstr_eval (T f) =
  let open Parsetree in
  T
    (fun ctx loc x k ->
      match x.pstr_desc with
      | Pstr_eval (e, _attrs) -> k |> f ctx loc e
      | _ -> fail loc "pstr_eval")
;;

let tstr_docattr on_str =
  tstr_attribute
    (attribute
       drop
       (payload_stru (pstr_eval (pexp_constant (pconst_string on_str)) ^:: nil)))
;;

let tsig_docattr on_str =
  tsig_attribute
    (attribute
       drop
       (payload_stru (pstr_eval (pexp_constant (pconst_string on_str)) ^:: nil)))
;;

type context = Ast_pattern0.context

let of_func f = T f
let to_func (T f) = f
let fail = fail

let%test_module "Fake tests, only to increase coverage" =
  (module struct
    [@@@coverage off]

    let noloc =
      Warnings.
        { loc_start = Lexing.dummy_pos; loc_end = Lexing.dummy_pos; loc_ghost = true }
    ;;

    let%test _ =
      match path_of_list [] with
      | exception Failure _ -> true
      | _ -> false
    ;;

    let%test_unit _ =
      let mk p ?(inv = false) what =
        let on_error, rez =
          if inv then Fun.const true, false else Fun.const false, true
        in
        parse p noloc ~on_error what rez
      in
      [%test_eq: Base.bool]
        true
        (mk
           ~inv:true
           (path_pident drop)
           Path.(Pdot (Pident (Ident.create_local "List"), "map")));
      [%test_eq: Base.bool]
        true
        (mk (path_pident drop) Path.(Pident (Ident.create_local "compare")));
      [%test_eq: Base.bool] true (mk ~inv:true (labelled drop) Asttypes.Nolabel);
      [%test_eq: Base.bool]
        true
        (mk
           (econst drop)
           { Typedtree.exp_desc = Texp_constant (Asttypes.Const_string ("", noloc, None))
           ; exp_extra = []
           ; exp_type = Predef.type_string
           ; exp_loc = noloc
           ; exp_env = Env.empty
           ; exp_attributes = []
           });
      let _42 =
        { Typedtree.exp_desc = Texp_constant (Asttypes.Const_int 42)
        ; exp_extra = []
        ; exp_type = Predef.type_int
        ; exp_loc = noloc
        ; exp_env = Env.empty
        ; exp_attributes = []
        }
      in
      [%test_eq: Base.bool] true (mk (econst drop) _42)
    ;;
  end)
;;

Kakadu / zanuda / 83

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous