Merge pull request #446 from panglesd/exec-included-blocks

Allow execution of included OCaml code blocks

Author: gpetiot

CHANGES.md

@@ -3,6 +3,7 @@
 #### Added
 
 - Handle the error-blocks syntax (#439, @jonludlam, @gpetiot)
+- Allow execution of included OCaml code blocks (#446, @panglesd)
 
 #### Fixed
 

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,13 @@ 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;
+}
+
 type include_other_file = { header : Header.t option }
 
 type include_file_kind =
@@ -118,6 +134,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 =
@@ -191,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
@@ -379,13 +399,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
@@ -423,23 +446,38 @@ 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; _ } -> (
+      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
           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
@@ -524,12 +562,18 @@ 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
         | Some s -> Re.execp (Re.Perl.compile_pat p) (snd s)
         | None -> Re.execp (Re.Perl.compile_pat p) "")
     | None -> true
   in
-  active && t.version_enabled && t.os_type_enabled && not t.skip
+  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

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,8 @@ 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,10 +190,19 @@ 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; _ } 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 }
   | _ -> assert false
 
 let rec error_padding = function
@@ -206,7 +215,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 +238,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 +286,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 +303,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 +343,44 @@ 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
+            (* 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
+      | 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

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))

test/bin/mdx-test/expect/exec-include/code.ml

@@ -0,0 +1,7 @@
+(* $MDX part-begin=OK *)
+let f x = x + 1
+(* $MDX part-end *)
+
+(* $MDX part-begin=KO *)
+let k = x = 1
+(* $MDX part-end *)

test/bin/mdx-test/expect/exec-include/code.mli

@@ -0,0 +1 @@
+val f : int -> int

test/bin/mdx-test/expect/exec-include/test-case.md

@@ -0,0 +1,38 @@
+.mli files are included but not executed:
+<!-- $MDX file=code.mli -->
+```ocaml
+val f : int -> int
+```
+
+.mli files are still included when `skip` is used:
+<!-- $MDX file=code.mli,skip -->
+```ocaml
+val f : int -> int
+```
+
+.ml files are included and executed:
+<!-- $MDX file=code.ml,part=OK -->
+```ocaml
+let f x = x + 1
+```
+
+<!-- $MDX file=code.ml,part=KO -->
+```ocaml
+let k = x = 1
+```
+```mdx-error
+Line 1, characters 9-10:
+Error: Unbound value x
+```
+
+
+.ml files are still included but no longer executed when `skip` is used:
+<!-- $MDX file=code.ml,part=OK,skip -->
+```ocaml
+let f x = x + 1
+```
+
+<!-- $MDX file=code.ml,part=KO,skip -->
+```ocaml
+let k = x = 1
+```