Kakadu / zanuda / 80

Committed 30 Jun 2026 05:14PM UTC coverage: 84.943% (-0.1%) from 85.067%

Build # 80

Build Type

push

github

Committed by

Kakadu

Commit Message

Minor polishing

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

Coverage Stats

0 of 1 new or added line in 1 file covered. (0.0%)

66 existing lines in 3 files now uncovered.

2234 of 2630 relevant lines covered (84.94%)

567.69 hits per line

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

86.9

/src/pattern/ast_pattern_tests.ml

open Compenv

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

let type_implementation source_file =
  let outputprefix = output_prefix source_file in
  let modulename = "Module1" in
  Env.set_unit_name modulename;
  Typemod.type_implementation source_file outputprefix modulename
;;

[%%else]

let type_implementation file =
  Typemod.type_implementation Unit_info.(make ~source_file:file Impl "")
;;

[%%endif]

let translate filename =
  Compmisc.init_path ();
  let env = Compmisc.initial_env () in
  try
    let parsetree = Pparse.parse_implementation ~tool_name:"xxx" filename in
    let { Typedtree.structure = typedtree; _ } =
      type_implementation filename env parsetree
    in
    parsetree, typedtree
  with
  | Typecore.Error (_, _, _) as exc ->
    Location.report_exception Format.std_formatter exc;
    Format.printf "\n%!";
    raise_notrace
      (Failure (Printf.sprintf "Typecheck error at %s line %d" __FILE__ __LINE__))
  | x -> raise x
;;

let extract_first =
  let open Parsetree in
  function
  | [ { pstr_desc = Pstr_value (_, [ vb ]) } ] -> vb.pvb_expr
  | _ -> assert false
;;

let extract_first_typed =
  let open Typedtree in
  fun str ->
    match str.str_items with
    | [ { str_desc = Tstr_value (_, [ vb ]) } ] -> vb.vb_expr
    | _ -> assert false
;;

let run_string code line pat sk =
  let filename = Printf.sprintf "tmp%d.ml" line in
  Out_channel.with_open_text filename (fun ch -> output_string ch code);
  let parsetree, _ = translate filename in
  let expr = extract_first parsetree in
  Tast_pattern.parse pat Location.none expr sk ~on_error:(Printf.printf "ERROR: %s\n")
;;

let run_si code line pat sk =
  let filename = Printf.sprintf "tmp%d.ml" line in
  Out_channel.with_open_text filename (fun ch -> output_string ch code);
  let parsetree, _ = translate filename in
  let expr = List.hd parsetree in
  Tast_pattern.parse pat Location.none expr sk ~on_error:(Printf.printf "ERROR: %s\n")
;;

let run_string_typed ?(verbose = false) code line pat sk =
  let filename = Printf.sprintf "tmp%d.ml" line in
  Out_channel.with_open_text filename (fun ch -> output_string ch code);
  let _, ttree = translate filename in
  let expr = extract_first_typed ttree in
  if verbose then Format.printf "@[%a@]\n" Printtyped.implementation ttree;
  Tast_pattern.parse pat Location.none expr sk ~on_error:(Printf.printf "ERROR: %s\n")
;;

let run_si_typed code line pat sk =
  let filename = Printf.sprintf "tmp%d.ml" line in
  Out_channel.with_open_text filename (fun ch -> output_string ch code);
  let _, ttree = translate filename in
  let expr = List.hd ttree.Typedtree.str_items in
  Tast_pattern.parse pat Location.none expr sk ~on_error:(Printf.printf "ERROR: %s\n")
;;

let default_sk pats _cases =
  Format.printf
    "patterns: @[%a@]\n%!"
    (Format.pp_print_list
       ~pp_sep:(fun ppf () -> Format.pp_print_char ppf ' ')
       Pprintast.pattern)
    pats;
  print_endline "success"
;;

let%expect_test _ =
  let code = {| let f x y = function true -> 1 | false -> 0 |} in
  run_string code __LINE__ Tast_pattern.(pexp_function_cases __ __) default_sk;
  [%expect
    {|
    patterns: x y
    success|}]
;;

let%expect_test _ =
  let code = {| let f x y = function true -> 1 | false -> 0 |} in
  run_string
    code
    __LINE__
    Tast_pattern.(pexp_function_cases (as__ (drop ^:: drop ^:: nil)) __)
    default_sk;
  [%expect
    {|
    patterns: x y
    success |}]
;;

let%expect_test _ =
  let code =
    {|
let backslash = fun ch ->
  match ch with
  | ch when List.mem ch [ "$"; "'"; "\""; "\\"; "\n" ] -> ch
  | "\n" -> ""
  | ch -> "" ^ ch
|}
  in
  run_string_typed
    code
    __LINE__
    Tast_pattern.(
      texp_function_body
        ((nolabel ** __) ^:: nil)
        (as__ (texp_match (texp_ident_loc __) drop __)))
    (fun (id, _) _ _ path cases ->
      Format.printf "Ident = %s\n%!" (Ident.name id);
      (match path with
       | Path.Pident id -> Format.printf "Ident = %s\n%!" (Ident.name id)
       | _ -> assert false);
      Format.printf "cases count = %d\n%!" (List.length cases);
      print_endline "OK");
  [%expect
    {|
    Ident = ch
    Ident = ch
    cases count = 3
    OK |}]
;;

let () = ()

let%expect_test _ =
  let code = {| let f x y = function true -> 1 | false -> 0 |} in
  run_string code __LINE__ Tast_pattern.(pexp_function_cases (list __) __) default_sk;
  [%expect
    {|

    patterns: x y
    success|}];
  let code = {| let f x y = x+y |} in
  run_string
    code
    __LINE__
    Tast_pattern.(pexp_function_body drop (pexp_apply drop (list (drop ** __))))
    (fun args ->
      Format.printf
        "%a%!"
        Format.(
          pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf " ") Pprintast.expression)
        args
      (* List.iter (Format.printf "%a\n%!" Pprintast.expression) args *));
  [%expect
    {|

    x y|}]
;;

let%expect_test "Parse typed zanuda attribute" =
  let code = {| [@@@zanuda "asdf"] |} in
  run_si_typed code __LINE__ Tast_pattern.(tstr_zanuda_attr __) (fun s -> print_endline s);
  [%expect {| asdf |}]
;;

let%expect_test "List.fold circumflex" =
  let code = {| let foo  = List.fold_left (^)  |} in
  run_string_typed
    (* ~verbose:true *)
    code
    __LINE__
    Tast_pattern.(
      let list_fold = texp_ident_typ (path [ "Stdlib"; "List"; "fold_left" ]) drop in
      let concat_op =
        let typ_str =
          typ_constr (path [ "Stdlib"; "string" ] ||| path [ "string" ]) nil
        in
        texp_ident_typ
          (path [ "Stdlib"; "^" ])
          (typ_arrow typ_str (typ_arrow typ_str typ_str))
      in
      texp_apply list_fold ((nolabel ** arg concat_op) ^:: __))
    (fun _ -> print_endline "OK");
  [%expect "OK"]
;;

1	open Compenv
2
3	[%%if ocaml_version < (5, 0, 0)]
4
5	let type_implementation source_file =
6	let outputprefix = output_prefix source_file in	7✔
7	let modulename = "Module1" in	7✔
8	Env.set_unit_name modulename;
9	Typemod.type_implementation source_file outputprefix modulename	7✔
10	;;
11
12	[%%else]
13
14	let type_implementation file =
15	Typemod.type_implementation Unit_info.(make ~source_file:file Impl "")
16	;;
17
18	[%%endif]
19
20	let translate filename =
21	Compmisc.init_path ();	7✔
22	let env = Compmisc.initial_env () in	7✔
23	try	7✔
24	let parsetree = Pparse.parse_implementation ~tool_name:"xxx" filename in
25	let { Typedtree.structure = typedtree; _ } =	7✔
26	type_implementation filename env parsetree
27	in
28	parsetree, typedtree	7✔
29	with
NEW 30	\| Typecore.Error (_, _, _) as exc ->	×
31	Location.report_exception Format.std_formatter exc;
32	Format.printf "\n%!";	×
UNCOV 33	raise_notrace	×
UNCOV 34	(Failure (Printf.sprintf "Typecheck error at %s line %d" __FILE__ __LINE__))	×
UNCOV 35	\| x -> raise x	×
36	;;
37
38	let extract_first =
39	let open Parsetree in
40	function
41	\| [ { pstr_desc = Pstr_value (_, [ vb ]) } ] -> vb.pvb_expr	4✔
42	\| _ -> assert false
43	;;
44
45	let extract_first_typed =
46	let open Typedtree in
47	fun str ->
48	match str.str_items with	2✔
49	\| [ { str_desc = Tstr_value (_, [ vb ]) } ] -> vb.vb_expr	2✔
50	\| _ -> assert false
51	;;
52
53	let run_string code line pat sk =
54	let filename = Printf.sprintf "tmp%d.ml" line in	4✔
55	Out_channel.with_open_text filename (fun ch -> output_string ch code);	4✔
56	let parsetree, _ = translate filename in	4✔
57	let expr = extract_first parsetree in	4✔
58	Tast_pattern.parse pat Location.none expr sk ~on_error:(Printf.printf "ERROR: %s\n")	4✔
59	;;
60
61	let run_si code line pat sk =
62	let filename = Printf.sprintf "tmp%d.ml" line in	×
UNCOV 63	Out_channel.with_open_text filename (fun ch -> output_string ch code);	×
UNCOV 64	let parsetree, _ = translate filename in	×
UNCOV 65	let expr = List.hd parsetree in	×
UNCOV 66	Tast_pattern.parse pat Location.none expr sk ~on_error:(Printf.printf "ERROR: %s\n")	×
67	;;
68
69	let run_string_typed ?(verbose = false) code line pat sk =	2✔
70	let filename = Printf.sprintf "tmp%d.ml" line in	2✔
71	Out_channel.with_open_text filename (fun ch -> output_string ch code);	2✔
72	let _, ttree = translate filename in	2✔
73	let expr = extract_first_typed ttree in	2✔
UNCOV 74	if verbose then Format.printf "@[%a@]\n" Printtyped.implementation ttree;	×
75	Tast_pattern.parse pat Location.none expr sk ~on_error:(Printf.printf "ERROR: %s\n")	2✔
76	;;
77
78	let run_si_typed code line pat sk =
79	let filename = Printf.sprintf "tmp%d.ml" line in	1✔
80	Out_channel.with_open_text filename (fun ch -> output_string ch code);	1✔
81	let _, ttree = translate filename in	1✔
82	let expr = List.hd ttree.Typedtree.str_items in	1✔
83	Tast_pattern.parse pat Location.none expr sk ~on_error:(Printf.printf "ERROR: %s\n")	1✔
84	;;
85
86	let default_sk pats _cases =
87	Format.printf	3✔
88	"patterns: @[%a@]\n%!"
89	(Format.pp_print_list	3✔
90	~pp_sep:(fun ppf () -> Format.pp_print_char ppf ' ')	3✔
91	Pprintast.pattern)
92	pats;
93	print_endline "success"	3✔
94	;;
95
96	let%expect_test _ =
97	let code = {\| let f x y = function true -> 1 \| false -> 0 \|} in	1✔
98	run_string code __LINE__ Tast_pattern.(pexp_function_cases __ __) default_sk;	1✔
99	[%expect	1✔
100	{\|
101	patterns: x y
102	success\|}]	5✔
103	;;
104
105	let%expect_test _ =
106	let code = {\| let f x y = function true -> 1 \| false -> 0 \|} in	1✔
107	run_string
108	code
109	__LINE__
110	Tast_pattern.(pexp_function_cases (as__ (drop ^:: drop ^:: nil)) __)	1✔
111	default_sk;
112	[%expect	1✔
113	{\|
114	patterns: x y
115	success \|}]	5✔
116	;;
117
118	let%expect_test _ =
119	let code =	1✔
120	{\|
121	let backslash = fun ch ->
122	match ch with
123	\| ch when List.mem ch [ "$"; "'"; "\""; "\\"; "\n" ] -> ch
124	\| "\n" -> ""
125	\| ch -> "" ^ ch
126	\|}
127	in
128	run_string_typed
129	code
130	__LINE__
131	Tast_pattern.(
132	texp_function_body	1✔
133	((nolabel ** __) ^:: nil)	1✔
134	(as__ (texp_match (texp_ident_loc __) drop __)))	1✔
135	(fun (id, _) _ _ path cases ->
136	Format.printf "Ident = %s\n%!" (Ident.name id);	1✔
137	(match path with	1✔
138	\| Path.Pident id -> Format.printf "Ident = %s\n%!" (Ident.name id)	1✔
139	\| _ -> assert false);
140	Format.printf "cases count = %d\n%!" (List.length cases);	1✔
141	print_endline "OK");	1✔
142	[%expect	1✔
143	{\|
144	Ident = ch
145	Ident = ch
146	cases count = 3
147	OK \|}]	5✔
148	;;
149
150	let () = ()
151
152	let%expect_test _ =
153	let code = {\| let f x y = function true -> 1 \| false -> 0 \|} in	1✔
154	run_string code __LINE__ Tast_pattern.(pexp_function_cases (list __) __) default_sk;	1✔
155	[%expect	1✔
156	{\|
157
158	patterns: x y
159	success\|}];	5✔
160	let code = {\| let f x y = x+y \|} in	1✔
161	run_string
162	code
163	__LINE__
164	Tast_pattern.(pexp_function_body drop (pexp_apply drop (list (drop ** __))))	1✔
165	(fun args ->
166	Format.printf	1✔
167	"%a%!"
168	Format.(
169	pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf " ") Pprintast.expression)	1✔
170	args
171	(* List.iter (Format.printf "%a\n%!" Pprintast.expression) args *));
172	[%expect	1✔
173	{\|
174
175	x y\|}]	5✔
176	;;
177
178	let%expect_test "Parse typed zanuda attribute" =
179	let code = {\| [@@@zanuda "asdf"] \|} in	1✔
180	run_si_typed code __LINE__ Tast_pattern.(tstr_zanuda_attr __) (fun s -> print_endline s);	1✔
181	[%expect {\| asdf \|}]	1✔
182	;;
183
184	let%expect_test "List.fold circumflex" =
185	let code = {\| let foo = List.fold_left (^) \|} in	1✔
186	run_string_typed
187	(* ~verbose:true *)
188	code
189	__LINE__
190	Tast_pattern.(
191	let list_fold = texp_ident_typ (path [ "Stdlib"; "List"; "fold_left" ]) drop in	1✔
192	let concat_op =	1✔
193	let typ_str =
194	typ_constr (path [ "Stdlib"; "string" ] \|\|\| path [ "string" ]) nil	1✔
195	in
196	texp_ident_typ	1✔
197	(path [ "Stdlib"; "^" ])	1✔
198	(typ_arrow typ_str (typ_arrow typ_str typ_str))	1✔
199	in
200	texp_apply list_fold ((nolabel ** arg concat_op) ^:: __))	1✔
201	(fun _ -> print_endline "OK");	1✔
202	[%expect "OK"]	1✔
203	;;

Kakadu / zanuda / 80

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