From bf481126316dacb5664fed2f3d7d153effc11ef1 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Mon, 4 Mar 2024 16:49:05 +0000 Subject: [PATCH] Add an 'exec' label to execute include OCaml blocks --- lib/block.ml | 90 ++++++++++++++----- lib/block.mli | 10 +++ lib/dep.ml | 15 ++-- lib/label.ml | 3 + lib/label.mli | 1 + lib/test/mdx_test.ml | 83 +++++++++++------ test/bin/mdx-test/expect/code/test-case.md | 3 +- test/bin/mdx-test/expect/dune.inc | 12 +++ .../mdx-test/expect/exec-include/test-case.md | 58 ++++++++++++ 9 files changed, 217 insertions(+), 58 deletions(-) create mode 100644 test/bin/mdx-test/expect/exec-include/test-case.md diff --git a/lib/block.ml b/lib/block.ml index 783d6b43e..c7755715f 100644 --- a/lib/block.ml +++ b/lib/block.ml @@ -30,6 +30,16 @@ let locate_errors ~loc r = (fun l -> List.map (fun (`Msg m) -> `Msg (locate_error_msg ~loc m)) l) r +module OCaml_kind = struct + type t = Impl | Intf + + let infer_from_file file = + match Filename.(remove_extension (basename file), extension file) with + | _, (".ml" | ".mlt" | ".eliom") -> Some Impl + | _, (".mli" | ".eliomi") -> Some Intf + | _ -> None +end + module Header = struct type t = Shell of [ `Sh | `Bash ] | OCaml | Other of string @@ -85,7 +95,14 @@ type ocaml_value = { } type toplevel_value = { env : Ocaml_env.t; non_det : Label.non_det option } -type include_ocaml_file = { part_included : string option } + +type include_ocaml_file = { + part_included : string option; + ocaml_value : ocaml_value option; + kind : OCaml_kind.t; + exec : bool; +} + type include_other_file = { header : Header.t option } type include_file_kind = @@ -118,6 +135,12 @@ type t = { value : value; } +let get_ocaml_value t = + match t.value with + | OCaml ocaml_value -> Some ocaml_value + | Include { file_kind = Fk_ocaml { ocaml_value; _ }; _ } -> ocaml_value + | _ -> None + let dump_section = Fmt.(Dump.pair int string) let header t = @@ -190,24 +213,22 @@ let pp_error ?syntax ?delim ppf outputs = outputs err_delim | _ -> () -let has_output t = - match t.value with - | OCaml { errors = []; _ } -> false - | OCaml { errors = _; _ } -> true +let has_errors t = + match get_ocaml_value t with + | Some { errors = _ :: _; _ } -> true | _ -> false let pp_value ?syntax ppf t = let delim = t.delim in - match t.value with - | OCaml { errors = []; _ } -> () - | OCaml { errors; _ } -> + match get_ocaml_value t with + | Some { errors; _ } -> let errors = error_padding errors in pp_error ?syntax ?delim ppf errors | _ -> () let pp_footer ?syntax ppf t = let delim = - if has_output t then ( + if has_errors t then ( pp_value ?syntax ppf t; None) else t.delim @@ -288,6 +309,13 @@ let non_det t = | Include _ | Raw _ -> None let skip t = t.skip + +let exec t = + match t.value with + | Include { file_kind = Fk_ocaml { exec; _ }; _ } -> exec + | Include _ | Raw _ -> false + | _ -> true + let set_variables t = t.set_variables let unset_variables t = t.unset_variables let value t = t.value @@ -349,6 +377,7 @@ type block_config = { env : string option; dir : string option; skip : bool; + exec : bool; version : (Label.Relation.t * Ocaml_version.t) option; os_type : (Label.Relation.t * string) option; set_variables : (string * string) list; @@ -369,6 +398,7 @@ let get_block_config l = env = get_label (function Env x -> Some x | _ -> None) l; dir = get_label (function Dir x -> Some x | _ -> None) l; skip = List.exists (function Label.Skip -> true | _ -> false) l; + exec = List.exists (function Label.Exec -> true | _ -> false) l; version = get_label (function Version (x, y) -> Some (x, y) | _ -> None) l; os_type = get_label (function Os_type (x, y) -> Some (x, y) | _ -> None) l; set_variables = @@ -378,13 +408,16 @@ let get_block_config l = file_inc = get_label (function File x -> Some x | _ -> None) l; } +let mk_ocaml_value env non_det errors header = + { env = Ocaml_env.mk env; non_det; errors; header } + let mk_ocaml ~loc ~config ~header ~contents ~errors = let kind = "OCaml" in match config with | { file_inc = None; part = None; env; non_det; _ } -> ( (* TODO: why does this call guess_ocaml_kind when infer_block already did? *) match guess_ocaml_kind contents with - | `Code -> Ok (OCaml { env = Ocaml_env.mk env; non_det; errors; header }) + | `Code -> Ok (OCaml (mk_ocaml_value env non_det errors header)) | `Toplevel -> loc_error ~loc "toplevel syntax is not allowed in OCaml blocks.") | { file_inc = Some _; _ } -> label_not_allowed ~loc ~label:"file" ~kind @@ -422,13 +455,31 @@ let mk_toplevel ~loc ~config ~contents ~errors = let mk_include ~loc ~config ~header ~errors = let kind = "include" in match config with - | { file_inc = Some file_included; part; non_det = None; env = None; _ } -> ( - let* () = check_no_errors ~loc errors in - match header with - | Some Header.OCaml -> - let file_kind = Fk_ocaml { part_included = part } in + | { file_inc = Some file_included; part; non_det; env; exec; _ } -> ( + let kind = + match header with + | Some Header.OCaml -> `OCaml + | None -> ( + match OCaml_kind.infer_from_file file_included with + | Some _ -> `OCaml + | None -> `Other) + | _ -> `Other + in + match kind with + | `OCaml -> + let kind = + Util.Option.value ~default:OCaml_kind.Impl + (OCaml_kind.infer_from_file file_included) + in + let part_included = part in + let ocaml_value = + match kind with + | Impl -> Some (mk_ocaml_value env non_det errors header) + | Intf -> None + in + let file_kind = Fk_ocaml { part_included; ocaml_value; kind; exec } in Ok (Include { file_included; file_kind }) - | _ -> ( + | `Other -> ( match part with | None -> let file_kind = Fk_other { header } in @@ -436,9 +487,6 @@ let mk_include ~loc ~config ~header ~errors = | Some _ -> label_not_allowed ~loc ~label:"part" ~kind:"non-OCaml include")) | { file_inc = None; _ } -> label_required ~loc ~label:"file" ~kind - | { non_det = Some _; _ } -> - label_not_allowed ~loc ~label:"non-deterministic" ~kind - | { env = Some _; _ } -> label_not_allowed ~loc ~label:"env" ~kind let infer_block ~loc ~config ~header ~contents ~errors = match config with @@ -523,7 +571,7 @@ let from_raw raw = ~delim:None let is_active ?section:s t = - let active = + let active_section = match s with | Some p -> ( match t.section with @@ -531,4 +579,4 @@ let is_active ?section:s t = | None -> Re.execp (Re.Perl.compile_pat p) "") | None -> true in - active && t.version_enabled && t.os_type_enabled && not t.skip + active_section && t.version_enabled && t.os_type_enabled && not t.skip diff --git a/lib/block.mli b/lib/block.mli index b023265df..fecb4b614 100644 --- a/lib/block.mli +++ b/lib/block.mli @@ -16,6 +16,10 @@ (** Code blocks headers. *) +module OCaml_kind : sig + type t = Impl | Intf +end + module Header : sig type t = Shell of [ `Sh | `Bash ] | OCaml | Other of string @@ -47,6 +51,9 @@ type include_ocaml_file = { part_included : string option; (** [part_included] is the part of the file to synchronize with. If lines is not specified synchronize the whole file. *) + ocaml_value : ocaml_value option; + kind : OCaml_kind.t; + exec : bool; } type include_other_file = { header : Header.t option } @@ -168,6 +175,9 @@ val unset_variables : t -> string list val skip : t -> bool (** [skip t] is true iff [skip] is in the labels of [t]. *) +val exec : t -> bool +(** [exec t] is true iff [exec] is in the labels of [t]. *) + val value : t -> value (** [value t] is [t]'s value. *) diff --git a/lib/dep.ml b/lib/dep.ml index 0f5b06a37..90762854e 100644 --- a/lib/dep.ml +++ b/lib/dep.ml @@ -16,14 +16,15 @@ type t = File of string | Dir of string -let of_block block = +let of_block b = let open Block in - match (directory block, file block, skip block) with - | Some d, Some f, false -> Some (File (Filename.concat d f)) - | Some d, None, false -> Some (Dir d) - | None, Some f, false -> Some (File f) - | None, None, false -> None - | _, _, true -> None + let block b = (not (skip b)) || exec b in + match (directory b, file b, block b) with + | Some d, Some f, true -> Some (File (Filename.concat d f)) + | Some d, None, true -> Some (Dir d) + | None, Some f, true -> Some (File f) + | None, None, true -> None + | _, _, false -> None let of_lines = let open Document in diff --git a/lib/label.ml b/lib/label.ml index b18fc6f02..2bfbd3852 100644 --- a/lib/label.ml +++ b/lib/label.ml @@ -87,6 +87,7 @@ type t = | Part of string | Env of string | Skip + | Exec | Non_det of non_det option | Version of Relation.t * Ocaml_version.t | Os_type of Relation.t * string @@ -111,6 +112,7 @@ let pp ppf = function | Part p -> Fmt.pf ppf "part=%s" p | Env e -> Fmt.pf ppf "env=%s" e | Skip -> Fmt.string ppf "skip" + | Exec -> Fmt.string ppf "exec" | Non_det None -> Fmt.string ppf "non-deterministic" | Non_det (Some Nd_output) -> Fmt.string ppf "non-deterministic=output" | Non_det (Some Nd_command) -> Fmt.string ppf "non-deterministic=command" @@ -159,6 +161,7 @@ let requires_eq_value ~label ~value f = let interpret label value = match label with | "skip" -> doesnt_accept_value ~label ~value Skip + | "exec" -> doesnt_accept_value ~label ~value Exec | "ocaml" -> doesnt_accept_value ~label ~value (Block_kind OCaml) | "cram" -> doesnt_accept_value ~label ~value (Block_kind Cram) | "toplevel" -> doesnt_accept_value ~label ~value (Block_kind Toplevel) diff --git a/lib/label.mli b/lib/label.mli index 5abc4205d..bbd69101e 100644 --- a/lib/label.mli +++ b/lib/label.mli @@ -40,6 +40,7 @@ type t = | Part of string | Env of string | Skip + | Exec (** Only for include blocks. *) | Non_det of non_det option | Version of Relation.t * Ocaml_version.t | Os_type of Relation.t * string diff --git a/lib/test/mdx_test.ml b/lib/test/mdx_test.ml index bbed0cd32..fa185bba0 100644 --- a/lib/test/mdx_test.ml +++ b/lib/test/mdx_test.ml @@ -190,10 +190,22 @@ let rec remove_padding ?(front = true) = function let xs = remove_padding ~front xs in x :: xs -let update_ocaml ~errors = function - | { Block.value = OCaml v; _ } as b -> - { b with value = OCaml { v with errors } } - (* [eval_ocaml] only called on OCaml blocks *) +let update_errors ~errors t = + let update_ocaml_value (ov : Block.ocaml_value) = { ov with errors } in + match t.Block.value with + | OCaml v -> { t with value = OCaml (update_ocaml_value v) } + | Include + ({ file_kind = Fk_ocaml ({ ocaml_value = Some v; exec; _ } as fk); _ } as + i) -> + if exec then + let ocaml_value = Some (update_ocaml_value v) in + let file_kind = Block.Fk_ocaml { fk with ocaml_value } in + { t with value = Include { i with file_kind } } + else t + | _ -> assert false + +let update_include ~contents = function + | { Block.value = Include _; _ } as b -> { b with contents } | _ -> assert false let rec error_padding = function @@ -206,7 +218,7 @@ let rec error_padding = function let contains_warnings l = String.is_prefix ~affix:"Warning" l || String.is_infix ~affix:"\nWarning" l -let eval_ocaml ~(block : Block.t) ?syntax ?root c ppf errors = +let eval_ocaml ~(block : Block.t) ?root c errors = let cmd = block.contents |> remove_padding in let error_lines = match eval_test ?root ~block c cmd with @@ -229,8 +241,7 @@ let eval_ocaml ~(block : Block.t) ?syntax ?root c ppf errors = | `Output x -> `Output (ansi_color_strip x)) (Output.merge output errors) in - let updated_block = update_ocaml ~errors block in - Block.pp ?syntax ppf updated_block + update_errors ~errors block let lines = function Ok x | Error x -> x @@ -278,9 +289,12 @@ let read_part file part = (match part with None -> "" | Some p -> p) file | Some lines -> + (* in any [string] element of lines, there might be newlines. *) let contents = String.concat ~sep:"\n" lines in String.drop contents ~rev:true ~sat:Char.Ascii.is_white |> String.drop ~sat:(function '\n' -> true | _ -> false) + |> (fun contents -> "\n" ^ contents ^ "\n") + |> String.cuts ~sep:"\n" let write_parts ~force_output file parts = let output_file = file ^ ".corrected" in @@ -292,18 +306,13 @@ let write_parts ~force_output file parts = flush oc; close_out oc -let update_block_content ?syntax ppf t content = - Block.pp_header ?syntax ppf t; - Fmt.string ppf "\n"; - Output.pp ppf (`Output content); - Fmt.string ppf "\n"; - Block.pp_footer ?syntax ppf t - -let update_file_or_block ?syntax ?root ppf md_file ml_file block part = +let update_file_or_block ?root md_file ml_file block part = let root = root_dir ?root ~block () in let dir = Filename.dirname md_file in let ml_file = resolve_root ml_file dir root in - update_block_content ?syntax ppf block (read_part ml_file part) + let contents = read_part ml_file part in + let new_block = update_include ~contents block in + new_block exception Test_block_failure of Block.t * string @@ -337,26 +346,42 @@ let run_exn ~non_deterministic ~silent_eval ~record_backtrace ~syntax ~silent in let preludes = preludes ~prelude ~prelude_str in + let run_ocaml_value t Block.{ env; non_det; errors; header = _; _ } = + let det () = + Mdx_top.in_env env (fun () -> eval_ocaml ~block:t ?root c errors) + in + with_non_det non_deterministic non_det + ~on_skip_execution:(fun () -> t) + ~on_keep_old_output:det ~on_evaluation:det + in + let test_block ~ppf ~temp_file t = let print_block () = Block.pp ?syntax ppf t in if Block.is_active ?section t then match Block.value t with | Raw _ -> print_block () - | Include { file_included; file_kind = Fk_ocaml { part_included } } -> + | Include + { + file_included; + file_kind = Fk_ocaml { part_included; ocaml_value; _ }; + } -> assert (syntax <> Some Cram); - update_file_or_block ?syntax ?root ppf file file_included t - part_included - | Include { file_included; file_kind = Fk_other _ } -> - let new_content = read_part file_included None in - update_block_content ?syntax ppf t new_content - | OCaml { non_det; env; errors; header = _ } -> - let det () = - assert (syntax <> Some Cram); - Mdx_top.in_env env (fun () -> - eval_ocaml ~block:t ?syntax ?root c ppf errors) + let new_block = + update_file_or_block ?root file file_included t part_included in - with_non_det non_deterministic non_det ~on_skip_execution:print_block - ~on_keep_old_output:det ~on_evaluation:det + let updated_block = + match ocaml_value with + | Some ocaml_value -> run_ocaml_value new_block ocaml_value + | _ -> new_block + in + Block.pp ?syntax ppf updated_block + | Include { file_included; file_kind = Fk_other _ } -> + let contents = read_part file_included None in + let new_block = update_include ~contents t in + Block.pp ?syntax ppf new_block + | OCaml ov -> + let updated_block = run_ocaml_value t ov in + Block.pp ?syntax ppf updated_block | Cram { language = _; non_det } -> let tests = Cram.of_lines t.contents in with_non_det non_deterministic non_det ~on_skip_execution:print_block diff --git a/test/bin/mdx-test/expect/code/test-case.md b/test/bin/mdx-test/expect/code/test-case.md index 196326819..3bc1aaf5d 100644 --- a/test/bin/mdx-test/expect/code/test-case.md +++ b/test/bin/mdx-test/expect/code/test-case.md @@ -29,5 +29,6 @@ module type Foo = sig type t end ```ocaml skip # Pipe.f ();; -- : unit +Line 1, characters 1-7: +Error: Unbound module Pipe ``` diff --git a/test/bin/mdx-test/expect/dune.inc b/test/bin/mdx-test/expect/dune.inc index f489a3e2e..26dbaa5ae 100644 --- a/test/bin/mdx-test/expect/dune.inc +++ b/test/bin/mdx-test/expect/dune.inc @@ -179,6 +179,18 @@ (alias runtest) (action (diff errors/test-case.md errors.actual))) +(rule + (target exec-include.actual) + (deps (package mdx) (source_tree exec-include)) + (action + (with-stdout-to %{target} + (chdir exec-include + (run ocaml-mdx test --output - test-case.md))))) + +(rule + (alias runtest) + (action (diff exec-include/test-case.md exec-include.actual))) + (rule (target exit.actual) (deps (package mdx) (source_tree exit)) diff --git a/test/bin/mdx-test/expect/exec-include/test-case.md b/test/bin/mdx-test/expect/exec-include/test-case.md new file mode 100644 index 000000000..0f3df354b --- /dev/null +++ b/test/bin/mdx-test/expect/exec-include/test-case.md @@ -0,0 +1,58 @@ +.mli files are included but not executed: + +```ocaml +val f : int -> int +``` + +.mli files are still included when `skip` is used: + +```ocaml +val f : int -> int +``` + +`exec` has no effect: + +```ocaml +val f : int -> int +``` + +.ml files are included but not executed by default: + +```ocaml +let f x = x + 1 +``` + + +```ocaml +let k = x = 1 +``` +```mdx-error +Line 1, characters 9-10: +Error: Unbound value x +``` + +.ml files are no longer included when `skip` is used: + +```ocaml +let f x = x + 1 +``` + + +```ocaml +let k = x = 1 +``` + +.ml files are executed when `exec` is used: + +```ocaml +let f x = x + 1 +``` + + +```ocaml +let k = x = 1 +``` +```mdx-error +Line 1, characters 9-10: +Error: Unbound value x +```