Revert "Allow execution of included OCaml code blocks"

CHANGES.md

@@ -1,10 +1,18 @@
+### unreleased
+
+#### Changed
+
+- Revert #446: "Allow execution of included OCaml code blocks" (#<PR_NUMBER>, @gpetiot).
+  Included OCaml code blocks preserve their pre-2.4.0 behavior.
+
 ### 2.4.0
 
 #### Added
 
 - Handle the error-blocks syntax (#439, @jonludlam, @gpetiot)
 - Allow execution of included OCaml code blocks. Add `skip` to `include` blocks
-  to revert to the old behavior (#446, @panglesd)
+  to revert to the old behavior (#446, @panglesd, @gpetiot)
+  *Warning: this is a breaking change that is reverted in the next release.*
 - Make MDX compatible with OCaml 5.2 (#448, @gpetiot)
 
 #### Fixed

lib/block.ml

@@ -30,16 +30,6 @@ 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
 
@@ -95,13 +85,7 @@ type ocaml_value = {
 }
 
 type toplevel_value = { env : Ocaml_env.t; non_det : Label.non_det option }
-
-type include_ocaml_file = {
-  part_included : string option;
-  ocaml_value : ocaml_value option;
-  kind : OCaml_kind.t;
-}
-
+type include_ocaml_file = { part_included : string option }
 type include_other_file = { header : Header.t option }
 
 type include_file_kind =
@@ -134,12 +118,6 @@ 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 =
@@ -212,22 +190,24 @@ let pp_error ?syntax ?delim ppf outputs =
         outputs err_delim
   | _ -> ()
 
-let has_errors t =
-  match get_ocaml_value t with
-  | Some { errors = _ :: _; _ } -> true
+let has_output t =
+  match t.value with
+  | OCaml { errors = []; _ } -> false
+  | OCaml { errors = _; _ } -> true
   | _ -> false
 
 let pp_value ?syntax ppf t =
   let delim = t.delim in
-  match get_ocaml_value t with
-  | Some { errors; _ } ->
+  match t.value with
+  | OCaml { errors = []; _ } -> ()
+  | OCaml { errors; _ } ->
       let errors = error_padding errors in
       pp_error ?syntax ?delim ppf errors
   | _ -> ()
 
 let pp_footer ?syntax ppf t =
   let delim =
-    if has_errors t then (
+    if has_output t then (
       pp_value ?syntax ppf t;
       None)
     else t.delim
@@ -398,16 +378,13 @@ 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 (mk_ocaml_value env non_det errors header))
+      | `Code -> Ok (OCaml { env = Ocaml_env.mk 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
@@ -445,38 +422,23 @@ 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; env; _ } -> (
-      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 } in
+  | { 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
           Ok (Include { file_included; file_kind })
-      | `Other -> (
+      | _ -> (
           match part with
           | None ->
               let file_kind = Fk_other { header } in
               Ok (Include { file_included; file_kind })
           | 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
@@ -561,18 +523,12 @@ let from_raw raw =
            ~delim:None
 
 let is_active ?section:s t =
-  let active_section =
+  let active =
     match s with
     | Some p -> (
         match t.section with
         | Some s -> Re.execp (Re.Perl.compile_pat p) (snd s)
         | None -> Re.execp (Re.Perl.compile_pat p) "")
     | None -> true
   in
-  let can_update_content =
-    match t.value with
-    (* include blocks are always updated even if not executed *)
-    | Include _ -> true
-    | _ -> not t.skip
-  in
-  active_section && t.version_enabled && t.os_type_enabled && can_update_content
+  active && t.version_enabled && t.os_type_enabled && not t.skip

lib/block.mli

@@ -16,10 +16,6 @@
 
 (** 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
 
@@ -51,8 +47,6 @@ 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;
 }
 
 type include_other_file = { header : Header.t option }

lib/test/mdx_test.ml

@@ -190,19 +190,10 @@ let rec remove_padding ?(front = true) = function
       let xs = remove_padding ~front xs in
       x :: xs
 
-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; _ } as fk); _ } as i) ->
-      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 } }
-  | _ -> assert false
-
-let update_include ~contents = function
-  | { Block.value = Include _; _ } as b -> { b with contents }
+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 *)
   | _ -> assert false
 
 let rec error_padding = function
@@ -215,7 +206,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) ?root c errors =
+let eval_ocaml ~(block : Block.t) ?syntax ?root c ppf errors =
   let cmd = block.contents |> remove_padding in
   let error_lines =
     match eval_test ?root ~block c cmd with
@@ -238,7 +229,8 @@ let eval_ocaml ~(block : Block.t) ?root c errors =
               | `Output x -> `Output (ansi_color_strip x))
             (Output.merge output errors)
   in
-  update_errors ~errors block
+  let updated_block = update_ocaml ~errors block in
+  Block.pp ?syntax ppf updated_block
 
 let lines = function Ok x | Error x -> x
 
@@ -286,12 +278,9 @@ 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
@@ -303,13 +292,18 @@ let write_parts ~force_output file parts =
       flush oc;
       close_out oc
 
-let update_file_or_block ?root md_file ml_file block part =
+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 root = root_dir ?root ~block () in
   let dir = Filename.dirname md_file in
   let ml_file = resolve_root ml_file dir root in
-  let contents = read_part ml_file part in
-  let new_block = update_include ~contents block in
-  new_block
+  update_block_content ?syntax ppf block (read_part ml_file part)
 
 exception Test_block_failure of Block.t * string
 
@@ -343,44 +337,26 @@ 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; ocaml_value; _ };
-          } ->
+      | Include { file_included; file_kind = Fk_ocaml { part_included } } ->
           assert (syntax <> Some Cram);
-          let new_block =
-            update_file_or_block ?root file file_included t part_included
-          in
-          let updated_block =
-            match ocaml_value with
-            (* including without executing *)
-            | Some _ when t.skip -> new_block
-            | Some ocaml_value -> run_ocaml_value new_block ocaml_value
-            | _ -> new_block
-          in
-          Block.pp ?syntax ppf updated_block
+          update_file_or_block ?syntax ?root ppf file file_included t
+            part_included
       | 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
+          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)
+          in
+          with_non_det non_deterministic non_det ~on_skip_execution:print_block
+            ~on_keep_old_output:det ~on_evaluation:det
       | Cram { language = _; non_det } ->
           let tests = Cram.of_lines t.contents in
           with_non_det non_deterministic non_det ~on_skip_execution:print_block

test/bin/mdx-test/expect/dune.inc

@@ -179,18 +179,6 @@
  (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))