diff --git a/CHANGES.md b/CHANGES.md index a10ab881c..23f9b7eca 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -3,6 +3,9 @@ #### Added - Report all parsing errors in Markdown files (#389, @NathanReb) +- Add alternative syntax for explicitly setting the block-type. + The new label `type=...` can be set to `ocaml`, `toplevel`, `cram` or + `include`. (#385, @NathanReb) #### Changed diff --git a/lib/block.ml b/lib/block.ml index 4a53ce329..9ebe0270f 100644 --- a/lib/block.ml +++ b/lib/block.ml @@ -414,7 +414,7 @@ let infer_block ~loc ~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 diff --git a/lib/label.ml b/lib/label.ml index f9f93d73d..3c31ceded 100644 --- a/lib/label.ml +++ b/lib/label.ml @@ -71,7 +71,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 @@ -84,13 +90,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 @@ -106,7 +106,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 "type=%a" pp_block_type bt let is_prefix ~prefix s = let len_prefix = String.length prefix in @@ -140,41 +140,65 @@ 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 = [ ""; {|"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) + 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 = [ ""; {|"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)) + | "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 = diff --git a/lib/label.mli b/lib/label.mli index fdba0a603..5ae377bfc 100644 --- a/lib/label.mli +++ b/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 diff --git a/test/bin/mdx-test/expect/block-type/test-case.md b/test/bin/mdx-test/expect/block-type/test-case.md new file mode 100644 index 000000000..674ac57aa --- /dev/null +++ b/test/bin/mdx-test/expect/block-type/test-case.md @@ -0,0 +1,24 @@ +It is possible to explicitly state the type of a block using the +`type` label to bypass the language header + content based inference, +providing better, more focused 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 +# 1 + 1;; +``` + + +```sh +let x = 2 +``` + + +```ocaml +$ echo "boom" +``` + +The include block type is somewhat redundant with the `file=...` label as +so it is not tested here. diff --git a/test/bin/mdx-test/expect/block-type/test-case.md.expected b/test/bin/mdx-test/expect/block-type/test-case.md.expected new file mode 100644 index 000000000..00fe5ff35 --- /dev/null +++ b/test/bin/mdx-test/expect/block-type/test-case.md.expected @@ -0,0 +1,26 @@ +It is possible to explicitly state the type of a block using the +`type` label to bypass the language header + content based inference, +providing better, more focused 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 +# 1 + 1;; +- : int = 2 +``` + + +```ocaml +let x = 2 +``` + + +```sh +$ echo "boom" +boom +``` + +The include block type is somewhat redundant with the `file=...` label as +so it is not tested here. diff --git a/test/bin/mdx-test/expect/dune.inc b/test/bin/mdx-test/expect/dune.inc index 54b10eeba..c66e114c3 100644 --- a/test/bin/mdx-test/expect/dune.inc +++ b/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)) diff --git a/test/bin/mdx-test/failure/block-type-value/test-case.md b/test/bin/mdx-test/failure/block-type-value/test-case.md new file mode 100644 index 000000000..a46b38255 --- /dev/null +++ b/test/bin/mdx-test/failure/block-type-value/test-case.md @@ -0,0 +1,14 @@ +This tests that erros are properly reported when the `type` label +is misused. + +It requires a value + + +```ocaml +``` + +It only accepts a fixed set of values + + +```ocaml +``` diff --git a/test/bin/mdx-test/failure/block-type-value/test-case.md.expected b/test/bin/mdx-test/failure/block-type-value/test-case.md.expected new file mode 100644 index 000000000..8931f1eff --- /dev/null +++ b/test/bin/mdx-test/failure/block-type-value/test-case.md.expected @@ -0,0 +1,2 @@ +[mdx] Fatal error: File "test-case.md", lines 6-8: invalid code block: Label `type` requires a value. +[mdx] Fatal error: File "test-case.md", lines 12-14: invalid code block: "invalid" is not a valid value for label `type`. Valid values are "ocaml", "cram", "toplevel" and "include". diff --git a/test/bin/mdx-test/failure/dune.inc b/test/bin/mdx-test/failure/dune.inc index 9bf381ab6..87739745f 100644 --- a/test/bin/mdx-test/failure/dune.inc +++ b/test/bin/mdx-test/failure/dune.inc @@ -12,6 +12,19 @@ (alias runtest) (action (diff block-locations/test-case.md.expected block-locations.actual))) +(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)) @@ -65,6 +78,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)) diff --git a/test/bin/mdx-test/failure/include-without-file-label/test-case.md b/test/bin/mdx-test/failure/include-without-file-label/test-case.md new file mode 100644 index 000000000..298d518f2 --- /dev/null +++ b/test/bin/mdx-test/failure/include-without-file-label/test-case.md @@ -0,0 +1,6 @@ +Explicitly setting the `type` to `include` has little benefits except +for warning you that the `file=...` label is mandatory. + + +```ocaml +``` diff --git a/test/bin/mdx-test/failure/include-without-file-label/test-case.md.expected b/test/bin/mdx-test/failure/include-without-file-label/test-case.md.expected new file mode 100644 index 000000000..2deddf767 --- /dev/null +++ b/test/bin/mdx-test/failure/include-without-file-label/test-case.md.expected @@ -0,0 +1 @@ +[mdx] Fatal error: File "test-case.md", lines 4-6: invalid code block: `file` label is required for include blocks. diff --git a/test/lib/test_block.ml b/test/lib/test_block.ml index 86312d883..f9d687bf0 100644 --- a/test/lib/test_block.ml +++ b/test/lib/test_block.ml @@ -38,10 +38,10 @@ let test_mk = (test_name, `Quick, test_fun) in [ - make_test ~name:"invalid ocaml" ~labels:[ Block_kind OCaml ] + make_test ~name:"invalid ocaml" ~labels:[ Block_type OCaml ] ~header:(Some OCaml) ~contents:[ "# let x = 2;;" ] ~expected:(Error (`Msg "toplevel syntax is not allowed in OCaml blocks.")); - make_test ~name:"invalid toplevel" ~labels:[ Block_kind Toplevel ] + make_test ~name:"invalid toplevel" ~labels:[ Block_type Toplevel ] ~header:(Some OCaml) ~contents:[ "let x = 2;;" ] ~expected:(Error (`Msg "invalid toplevel syntax in toplevel blocks.")); ]