Introduce new syntax for explicit block type

This introduce a new, more explicit labels `block-type=...` which
is meant to replace the four separate labels `cram`, `ocaml`, `toplevel`
and `include` in the future.

It is added for a transition period at the end of which the four labels
of the apocalypse should be removed in favor of this new one.

Signed-off-by: Nathan Rebours <[email protected]>

Author: NathanReb

CHANGES.md

@@ -2,6 +2,10 @@
 
 #### Added
 
+- Add alternative syntax for explicitly setting the block-type.
+  The new label `block-type=...` can be set to `ocaml`, `toplevel`, `cram` or
+  `include`. (#<PR_NUMBER>, @NathanReb)
+
 #### Changed
 
 #### Deprecated

lib/block.ml

@@ -384,7 +384,7 @@ let infer_block ~config ~header ~contents ~errors =
 
 let mk ~loc ~section ~labels ~legacy_labels ~header ~contents ~errors =
   let block_kind =
-    get_label (function Block_kind x -> Some x | _ -> None) labels
+    get_label (function Block_type x -> Some x | _ -> None) labels
   in
   let config = get_block_config labels in
   (match block_kind with

lib/label.ml

@@ -73,7 +73,13 @@ type non_det = Nd_output | Nd_command
 
 let default_non_det = Nd_output
 
-type block_kind = OCaml | Cram | Toplevel | Include
+type block_type = OCaml | Cram | Toplevel | Include
+
+let pp_block_type ppf = function
+  | OCaml -> Fmt.string ppf "ocaml"
+  | Cram -> Fmt.string ppf "cram"
+  | Toplevel -> Fmt.string ppf "toplevel"
+  | Include -> Fmt.string ppf "include"
 
 type t =
   | Dir of string
@@ -86,13 +92,7 @@ type t =
   | Version of Relation.t * Ocaml_version.t
   | Set of string * string
   | Unset of string
-  | Block_kind of block_kind
-
-let pp_block_kind ppf = function
-  | OCaml -> Fmt.string ppf "ocaml"
-  | Cram -> Fmt.string ppf "cram"
-  | Toplevel -> Fmt.string ppf "toplevel"
-  | Include -> Fmt.string ppf "include"
+  | Block_type of block_type
 
 let pp ppf = function
   | Dir d -> Fmt.pf ppf "dir=%s" d
@@ -108,7 +108,7 @@ let pp ppf = function
       Fmt.pf ppf "version%a%a" Relation.pp op Ocaml_version.pp v
   | Set (v, x) -> Fmt.pf ppf "set-%s=%s" v x
   | Unset x -> Fmt.pf ppf "unset-%s" x
-  | Block_kind bk -> pp_block_kind ppf bk
+  | Block_type bt -> Fmt.pf ppf "block-type=%a" pp_block_type bt
 
 let is_prefix ~prefix s =
   let len_prefix = String.length prefix in
@@ -142,41 +142,67 @@ let requires_value ~label ~value f =
 
 let requires_eq_value ~label ~value f =
   requires_value ~label ~value (fun op value ->
-      match op with Relation.Eq -> Ok (f value) | _ -> non_eq_op ~label)
+      match op with Relation.Eq -> (f value) | _ -> non_eq_op ~label)
+
+let version_of_string s =
+  match Ocaml_version.of_string s with
+  | Ok v -> Ok v
+  | Error (`Msg e) ->
+    Util.Result.errorf "Invalid version: %s." e
+
+let parse_non_det_value ~label s = 
+  match s with
+  | "output" -> Ok Nd_output
+  | "command" -> Ok Nd_command
+  | s -> 
+    let allowed_values = [ "<none>"; {|"command"|}; {|"output"|} ] in
+    invalid_value ~label ~allowed_values s
+
+let parse_block_type_value ~label s =
+  match s with
+  | "ocaml" -> Ok OCaml
+  | "cram" -> Ok Cram
+  | "toplevel" -> Ok Toplevel
+  | "include" -> Ok Include
+  | s ->
+    let allowed_values =
+      [{|"ocaml"|}; {|"cram"|}; {|"toplevel"|}; {|"include"|}]
+    in
+    invalid_value ~label ~allowed_values s
 
 let interpret label value =
+  let open Util.Result.Infix in
   match label with
   | "skip" -> doesnt_accept_value ~label ~value Skip
-  | "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)
-  | "include" -> doesnt_accept_value ~label ~value (Block_kind Include)
+  | "ocaml" -> doesnt_accept_value ~label ~value (Block_type OCaml)
+  | "cram" -> doesnt_accept_value ~label ~value (Block_type Cram)
+  | "toplevel" -> doesnt_accept_value ~label ~value (Block_type Toplevel)
+  | "include" -> doesnt_accept_value ~label ~value (Block_type Include)
   | v when is_prefix ~prefix:"unset-" v ->
       doesnt_accept_value ~label ~value
         (Unset (split_prefix ~prefix:"unset-" v))
   | "version" ->
-      requires_value ~label ~value (fun op v ->
-          match Ocaml_version.of_string v with
-          | Ok v -> Ok (Version (op, v))
-          | Error (`Msg e) ->
-              Util.Result.errorf "Invalid `version` label value: %s." e)
+    requires_value ~label ~value
+      (fun op v -> version_of_string v >>= fun v -> Ok (Version (op, v)))
   | "non-deterministic" -> (
       match value with
       | None -> Ok (Non_det None)
-      | Some (Relation.Eq, "output") -> Ok (Non_det (Some Nd_output))
-      | Some (Relation.Eq, "command") -> Ok (Non_det (Some Nd_command))
-      | Some (Relation.Eq, v) ->
-          let allowed_values = [ "<none>"; {|"command"|}; {|"output"|} ] in
-          invalid_value ~label ~allowed_values v
+      | Some (Relation.Eq, s) ->
+        parse_non_det_value ~label s >>= fun nd ->
+        Ok (Non_det (Some nd))
       | Some _ -> non_eq_op ~label)
-  | "dir" -> requires_eq_value ~label ~value (fun x -> Dir x)
-  | "source-tree" -> requires_eq_value ~label ~value (fun x -> Source_tree x)
-  | "file" -> requires_eq_value ~label ~value (fun x -> File x)
-  | "part" -> requires_eq_value ~label ~value (fun x -> Part x)
-  | "env" -> requires_eq_value ~label ~value (fun x -> Env x)
+  | "dir" -> requires_eq_value ~label ~value (fun x -> Ok (Dir x))
+  | "source-tree" ->
+    requires_eq_value ~label ~value (fun x -> Ok (Source_tree x))
+  | "file" -> requires_eq_value ~label ~value (fun x -> Ok (File x))
+  | "part" -> requires_eq_value ~label ~value (fun x -> Ok (Part x))
+  | "env" -> requires_eq_value ~label ~value (fun x -> Ok (Env x))
+  | "block-type" ->
+    requires_eq_value ~label ~value
+      (fun x -> parse_block_type_value ~label x >>= fun bt -> Ok (Block_type bt))
   | l when is_prefix ~prefix:"set-" l ->
       requires_eq_value ~label ~value (fun x ->
-          Set (split_prefix ~prefix:"set-" l, x))
+          Ok (Set (split_prefix ~prefix:"set-" l, x)))
   | l -> Error (`Msg (Format.sprintf "`%s` is not a valid label." l))
 
 let of_string s =

lib/label.mli

@@ -29,7 +29,7 @@ type non_det = Nd_output | Nd_command
 
 val default_non_det : non_det
 
-type block_kind = OCaml | Cram | Toplevel | Include
+type block_type = OCaml | Cram | Toplevel | Include
 
 type t =
   | Dir of string
@@ -42,7 +42,7 @@ type t =
   | Version of Relation.t * Ocaml_version.t
   | Set of string * string
   | Unset of string
-  | Block_kind of block_kind
+  | Block_type of block_type
 
 val pp : Format.formatter -> t -> unit
 

test/bin/mdx-test/expect/block-type/test-case.md

@@ -0,0 +1,21 @@
+It is possible to explicitly state the type of a block using the
+`block-type` label, working around language header and content based
+inference which can sometime lead to troublesome error messages.
+
+The following blocks use a volontarily misleading language header that would
+normally lead to errors if we let MDX infer the type of block based on them.
+
+```sh block-type=toplevel
+# 1 + 1;;
+```
+
+```sh block-type=ocaml
+let x = 2
+```
+
+```ocaml block-type=cram
+$ echo "boom"
+```
+
+The include block type is somewhat redundant with the `file=...` label as
+so it is not tested here.

test/bin/mdx-test/expect/block-type/test-case.md.expected

@@ -0,0 +1,23 @@
+It is possible to explicitly state the type of a block using the
+`block-type` label, working around language header and content based
+inference which can sometime lead to troublesome error messages.
+
+The following blocks use a volontarily misleading language header that would
+normally lead to errors if we let MDX infer the type of block based on them.
+
+```ocaml block-type=toplevel
+# 1 + 1;;
+- : int = 2
+```
+
+```ocaml block-type=ocaml
+let x = 2
+```
+
+```sh block-type=cram
+$ echo "boom"
+boom
+```
+
+The include block type is somewhat redundant with the `file=...` label as
+so it is not tested here.

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

@@ -11,6 +11,18 @@
  (alias runtest)
  (action (diff bash-fence/test-case.md.expected bash-fence.actual)))
 
+(rule
+ (target block-type.actual)
+ (deps (package mdx) (source_tree block-type))
+ (action
+  (with-stdout-to %{target}
+   (chdir block-type
+    (run ocaml-mdx test --output - test-case.md)))))
+
+(rule
+ (alias runtest)
+ (action (diff block-type/test-case.md.expected block-type.actual)))
+
 (rule
  (target casual-file-inc.actual)
  (deps (package mdx) (source_tree casual-file-inc))

test/bin/mdx-test/failure/block-type-value/test-case.md

@@ -0,0 +1,12 @@
+This tests that erros are properly reported when the `block-type` label
+is misused.
+
+It requires a value
+
+```ocaml block-type
+```
+
+It only accept a fixed set of values
+
+```ocaml block-type=invalid
+```

test/bin/mdx-test/failure/block-type-value/test-case.md.expected

@@ -0,0 +1 @@
+[mdx] Fatal error: File "test-case.md", line 6: invalid code block: Label `block-type` requires a value.

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

@@ -1,4 +1,17 @@
 
+(rule
+ (target block-type-value.actual)
+ (deps (package mdx) (source_tree block-type-value))
+ (action
+  (with-accepted-exit-codes 1
+   (with-outputs-to %{target}
+    (chdir block-type-value
+     (run %{bin:ocaml-mdx} test test-case.md))))))
+
+(rule
+ (alias runtest)
+ (action (diff block-type-value/test-case.md.expected block-type-value.actual)))
+
 (rule
  (target both-prelude.actual)
  (deps (package mdx) (source_tree both-prelude))
@@ -52,6 +65,19 @@
  (enabled_if (<> %{os_type} Win32))
  (action (diff in-toplevel/test-case.md.expected in-toplevel.actual)))
 
+(rule
+ (target include-without-file-label.actual)
+ (deps (package mdx) (source_tree include-without-file-label))
+ (action
+  (with-accepted-exit-codes 1
+   (with-outputs-to %{target}
+    (chdir include-without-file-label
+     (run %{bin:ocaml-mdx} test test-case.md))))))
+
+(rule
+ (alias runtest)
+ (action (diff include-without-file-label/test-case.md.expected include-without-file-label.actual)))
+
 (rule
  (target invalid-label.actual)
  (deps (package mdx) (source_tree invalid-label))