mbarbin / mdexp / 18

Committed 02 Apr 2026 01:44PM UTC coverage: 95.876% (+3.1%) from 92.788%

Build # 18

Build Type

push

github

Committed by

web-flow

Commit Message

Merge pull request #5 from mbarbin/assorted-improvements

Assorted improvements

Coverage Stats

191 of 203 new or added lines in 22 files covered. (94.09%)

1 existing line in 1 file now uncovered.

1674 of 1746 relevant lines covered (95.88%)

166.39 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

86.5

/src/mdexp/line_processor.ml

(*********************************************************************************)
(*  mdexp - Literate Programming with Embedded Snapshots                         *)
(*  SPDX-FileCopyrightText: 2025-2026 Mathieu Barbin <mathieu.barbin@gmail.com>  *)
(*  SPDX-License-Identifier: LGPL-3.0-or-later WITH LGPL-3.0-linking-exception   *)
(*********************************************************************************)

module Action = struct
  type t =
    | Emit_prose_line of string
    | Emit_code_line of string
    | Close_code_fence
    | Flush_prose
    | Flush_code
    | Blank_separator
    | Enter_snapshot of Located_json.t option
    | Enter_code of Located_json.t option
    | Configure of Located_json.t

  let json_to_dyn json = Dyn.string (Yojson.Basic.to_string json)
  let located_json_to_dyn lj = json_to_dyn (Located_json.json lj :> Yojson.Basic.t)

  let to_dyn = function
    | Emit_prose_line s -> Dyn.variant "Emit_prose_line" [ Dyn.string s ]
    | Emit_code_line s -> Dyn.variant "Emit_code_line" [ Dyn.string s ]
    | Close_code_fence -> Dyn.variant "Close_code_fence" []
    | Flush_prose -> Dyn.variant "Flush_prose" []
    | Flush_code -> Dyn.variant "Flush_code" []
    | Blank_separator -> Dyn.variant "Blank_separator" []
    | Enter_snapshot lj_opt ->
      Dyn.variant "Enter_snapshot" [ Dyn.option located_json_to_dyn lj_opt ]
    | Enter_code lj_opt ->
      Dyn.variant "Enter_code" [ Dyn.option located_json_to_dyn lj_opt ]
    | Configure lj -> Dyn.variant "Configure" [ located_json_to_dyn lj ]
  ;;
end

(* -- Comment stripping internals -- *)

module Strip_result = struct
  type t =
    | Not_a_comment
    | Content of
        { content : string
        ; col : int
        }
    | Block_closer
end

let is_block_comment_opening line ~(comment_syntax : Comment_syntax.t) =
  match comment_syntax.block with
  | None -> false
  | Some block ->
    let trimmed = String.ltrim line in
    String.starts_with ~prefix:block.start_ trimmed
;;

let is_single_line_block_comment line ~(comment_syntax : Comment_syntax.t) =
  match comment_syntax.block with
  | Some block ->
    let trimmed = String.trim line in
    String.starts_with ~prefix:block.start_ trimmed
    && String.ends_with ~suffix:block.end_ trimmed
  | None -> false
;;

let is_standalone_block_closer line ~(comment_syntax : Comment_syntax.t) =
  match comment_syntax.block with
  | None -> false
  | Some block ->
    let trimmed = String.trim line in
    String.equal trimmed block.end_ || String.equal trimmed ("@" ^ block.end_)
;;

let ends_with_block_closer line ~(comment_syntax : Comment_syntax.t) =
  match comment_syntax.block with
  | None -> false
  | Some block ->
    let trimmed = String.rtrim line in
    String.ends_with ~suffix:block.end_ trimmed
;;

let strip_line_comment ~prefix line =
  let trimmed = String.ltrim line in
  let leading_ws = String.length line - String.length trimmed in
  if String.starts_with ~prefix trimmed
  then (
    let len = String.length prefix in
    let rest = String.sub trimmed ~pos:len ~len:(String.length trimmed - len) in
    if String.length rest > 0 && Char.equal rest.[0] ' '
    then Some (String.sub rest ~pos:1 ~len:(String.length rest - 1), leading_ws + len + 1)
    else Some (rest, leading_ws + len))
  else None
;;

let strip_block_comment ~block_start ~block_end ~in_block_comment line =
  let trimmed = String.ltrim line in
  let leading_ws = String.length line - String.length trimmed in
  let trimmed_all = String.trim trimmed in
  if
    (not (String.starts_with ~prefix:block_start trimmed))
    && (String.equal trimmed_all block_end || String.equal trimmed_all ("@" ^ block_end))
  then Strip_result.Block_closer
  else (
    let found_opening, after_opening, col =
      if String.starts_with ~prefix:block_start trimmed
      then (
        let len = String.length block_start in
        let rest = String.sub trimmed ~pos:len ~len:(String.length trimmed - len) in
        let has_space = String.length rest > 0 && Char.equal rest.[0] ' ' in
        let rest =
          if has_space then String.sub rest ~pos:1 ~len:(String.length rest - 1) else rest
        in
        let col = leading_ws + len + if has_space then 1 else 0 in
        true, rest, col)
      else false, trimmed, leading_ws
    in
    if found_opening
    then (
      let trimmed_end = String.rtrim after_opening in
      if String.ends_with ~suffix:block_end trimmed_end
      then (
        let len = String.length block_end in
        let content =
          String.sub trimmed_end ~pos:0 ~len:(String.length trimmed_end - len)
        in
        Content { content = String.rtrim content; col })
      else Content { content = trimmed_end; col })
    else if in_block_comment
    then (
      let trimmed_end = String.rtrim line in
      if String.ends_with ~suffix:block_end trimmed_end
      then (
        let len = String.length block_end in
        let content =
          String.sub trimmed_end ~pos:0 ~len:(String.length trimmed_end - len)
        in
        Content { content = String.rtrim content; col = 0 })
      else Content { content = String.rtrim line; col = 0 })
    else Not_a_comment)
;;

let strip line ~(comment_syntax : Comment_syntax.t) ~in_block_comment =
  let line_result =
    match comment_syntax.line_prefix with
    | Some prefix ->
      (match strip_line_comment ~prefix line with
       | Some (content, col) -> Some (Strip_result.Content { content; col })
       | None -> None)
    | None -> None
  in
  let block_result () =
    match comment_syntax.block with
    | Some block ->
      strip_block_comment
        ~block_start:block.start_
        ~block_end:block.end_
        ~in_block_comment
        line
    | None -> Not_a_comment
  in
  match line_result with
  | Some r when not in_block_comment -> r
  | _ -> block_result ()
;;

(* -- Classified line (internal intermediate representation) -- *)

module Classified_line = struct
  type t =
    | Directive of
        { directive : Directive.t
        ; trailing : string option
        ; is_single_line_block : bool
        ; loc : Loc.t
        ; col : int
        }
    | Comment_content of
        { content : string
        ; raw_line : string
        ; ends_block : bool
        ; from_line_comment : bool
        ; col : int
        }
    | Block_closer
    | Non_comment of { content : string }
end

let classify_line ~file_cache ~line_number ~comment_syntax ~in_block_comment line =
  let is_block_closer = is_standalone_block_closer line ~comment_syntax in
  let has_trailing_closer = ends_with_block_closer line ~comment_syntax in
  let result = strip line ~comment_syntax ~in_block_comment in
  let new_in_block_comment = ref in_block_comment in
  let parse_directive content ~col =
    Directive.parse_line ~content ~file_cache ~line:line_number ~col
  in
  let classified =
    match result with
    | Block_closer ->
      new_in_block_comment := false;
      Classified_line.Block_closer
    | Not_a_comment -> Non_comment { content = line }
    | Content { content = comment_content; col } when is_block_closer ->
      new_in_block_comment := false;
      (match parse_directive comment_content ~col with
       | Some { directive; trailing; loc } ->
         Directive { directive; trailing; is_single_line_block = false; loc; col }
       | None -> Block_closer)
    | Content { content = comment_content; col } ->
      (match parse_directive comment_content ~col with
       | Some { directive; trailing; loc } ->
         let is_single_line = is_single_line_block_comment line ~comment_syntax in
         let is_opening = is_block_comment_opening line ~comment_syntax in
         new_in_block_comment := is_opening && not is_single_line;
         Directive
           { directive; trailing; is_single_line_block = is_single_line; loc; col }
       | None ->
         let ends_block = has_trailing_closer && in_block_comment in
         if ends_block then new_in_block_comment := false;
         let from_line_comment =
           Option.is_some comment_syntax.line_prefix && not !new_in_block_comment
         in
         Comment_content
           { content = comment_content
           ; raw_line = line
           ; ends_block
           ; from_line_comment
           ; col
           })
  in
  classified, !new_in_block_comment
;;

(* -- State machine (internal) -- *)

type inline_config_origin =
  | Snapshot
  | Code
  | Config

module Mode = struct
  type t =
    | Ignore
    | Prose
    | Code_block
    | Accumulating_inline_config of
        { origin : inline_config_origin
        ; accumulator : Json5_accumulator.t
        }
end

let try_parse_located_json5 ~file_cache ~accumulator text =
  match Yojson_five.Basic.from_string text |> Result.to_option with
  | None -> None
  | Some (`Assoc _ as json) -> Some (Located_json.create ~file_cache ~accumulator ~json)
  | Some _ -> None
;;

let emit_inline_config_action origin located_json =
  match origin with
  | Snapshot -> Action.Enter_snapshot (Some located_json)
  | Code -> Action.Enter_code (Some located_json)
  | Config -> Action.Configure located_json
;;

let mode_after_config = function
  | Snapshot | Config -> Mode.Ignore
  | Code -> Mode.Code_block
;;

let fallback_action = function
  | Snapshot -> [ Action.Enter_snapshot None ]
  | Code -> [ Action.Enter_code None ]
  | Config -> []
;;

let finalize_accumulator ~file_cache origin accumulator =
  let contents = Json5_accumulator.buffer_contents accumulator in
  if String.is_empty (String.trim contents)
  then fallback_action origin
  else (
    match try_parse_located_json5 ~file_cache ~accumulator contents with
    | Some lj -> [ emit_inline_config_action origin lj ]
    | None -> fallback_action origin)
;;

let close_current_block ~file_cache (mode : Mode.t) =
  match mode with
  | Ignore -> []
  | Accumulating_inline_config { origin; accumulator } ->
    finalize_accumulator ~file_cache origin accumulator
  | Prose -> [ Action.Flush_prose; Blank_separator ]
  | Code_block -> [ Flush_code; Close_code_fence; Blank_separator ]
;;

let start_inline_config ~file_cache ~file_offset ~origin ~inline ~close_actions =
  let mode_done = mode_after_config origin in
  match inline with
  | None ->
    (match origin with
     | Config ->
       let acc = Json5_accumulator.create () in
       Mode.Accumulating_inline_config { origin; accumulator = acc }, close_actions
     | Snapshot | Code -> mode_done, close_actions @ fallback_action origin)
  | Some s ->
    let acc = Json5_accumulator.create () in
    (match Json5_accumulator.feed acc ~file_offset ~line:s with
     | Done { json_text } ->
       (match try_parse_located_json5 ~file_cache ~accumulator:acc json_text with
        | Some lj -> mode_done, close_actions @ [ emit_inline_config_action origin lj ]
        | None -> mode_done, close_actions @ fallback_action origin)
     | Need_more ->
       Accumulating_inline_config { origin; accumulator = acc }, close_actions
     | Error -> mode_done, close_actions @ fallback_action origin)
;;

let compute_file_offset ~file_cache ~line_number ~col =
  let line_loc = Loc.of_file_line ~file_cache ~line:line_number in
  Loc.start_offset line_loc + col
;;

let start_directive_inline_config ~file_cache ~mode ~origin ~trailing ~loc =
  let close_actions = close_current_block ~file_cache mode in
  let trailing_len =
    match trailing with
    | None -> 0
    | Some s -> String.length s
  in
  let file_offset = Loc.stop_offset loc - trailing_len in
  start_inline_config ~file_cache ~file_offset ~origin ~inline:trailing ~close_actions
;;

let transition
      ~file_cache
      ~line_number
      ~(mode : Mode.t)
      ~default_code_lang:_
      (input : Classified_line.t)
  =
  match input with
  | Directive { directive = Prose; trailing; is_single_line_block; loc = _; col = _ } ->
    let close_actions = close_current_block ~file_cache mode in
    let enter_actions =
      match trailing with
      | Some content -> [ Action.Emit_prose_line content ]
      | None -> []
    in
    let flush_actions =
      if is_single_line_block && Option.is_some trailing
      then [ Action.Flush_prose; Blank_separator ]
      else []
    in
    let new_mode =
      if is_single_line_block && Option.is_some trailing then Mode.Ignore else Prose
    in
    new_mode, close_actions @ enter_actions @ flush_actions
  | Directive { directive = Code; trailing; is_single_line_block = _; loc; col = _ } ->
    start_directive_inline_config ~file_cache ~mode ~origin:Code ~trailing ~loc
  | Directive { directive = Snapshot; trailing; is_single_line_block = _; loc; col = _ }
    -> start_directive_inline_config ~file_cache ~mode ~origin:Snapshot ~trailing ~loc
  | Directive { directive = Config; trailing; is_single_line_block = _; loc; col = _ } ->
    start_directive_inline_config ~file_cache ~mode ~origin:Config ~trailing ~loc
  | Directive
      { directive = End; is_single_line_block = _; trailing = _; loc = _; col = _ } ->
    let close_actions = close_current_block ~file_cache mode in
    Ignore, close_actions
  | Block_closer ->
    (match mode with
     | Accumulating_inline_config { origin; accumulator } ->
       mode_after_config origin, finalize_accumulator ~file_cache origin accumulator
     | Code_block -> Code_block, []
     | _ ->
       let close_actions = close_current_block ~file_cache mode in
       Ignore, close_actions)
  | Comment_content { content; raw_line; ends_block; from_line_comment; col } ->
    (match mode with
     | Ignore -> Ignore, []
     | Accumulating_inline_config { origin; accumulator } ->
       let file_offset = compute_file_offset ~file_cache ~line_number ~col in
       let done_mode = mode_after_config origin in
       (match Json5_accumulator.feed accumulator ~file_offset ~line:content with
        | Done { json_text } ->
          (match try_parse_located_json5 ~file_cache ~accumulator json_text with
           | Some lj -> done_mode, [ emit_inline_config_action origin lj ]
           | None -> done_mode, fallback_action origin)
        | Need_more ->
          if ends_block
          then done_mode, finalize_accumulator ~file_cache origin accumulator
          else mode, []
        | Error ->
          if ends_block
          then done_mode, finalize_accumulator ~file_cache origin accumulator
          else mode, [])
     | Prose ->
       let actions = [ Action.Emit_prose_line content ] in
       if ends_block
       then Ignore, actions @ [ Flush_prose; Blank_separator ]
       else Prose, actions
     | Code_block ->
       let content_to_use =
         if from_line_comment
         then raw_line
         else (
           let has_leading_whitespace =
             String.length raw_line > 0
             && (Char.equal (String.get raw_line 0) ' '
                 || Char.equal (String.get raw_line 0) '\t')
           in
           if has_leading_whitespace then raw_line else content)
       in
       let actions = [ Action.Emit_code_line content_to_use ] in
       if ends_block
       then Ignore, actions @ [ Flush_code; Close_code_fence; Blank_separator ]
       else mode, actions)
  | Non_comment { content } ->
    (match mode with
     | Code_block -> mode, [ Action.Emit_code_line content ]
     | Accumulating_inline_config { origin; accumulator } ->
       mode_after_config origin, finalize_accumulator ~file_cache origin accumulator
     | _ -> mode, [])
;;

(* -- Public interface -- *)

type t =
  { file_cache : Loc.File_cache.t
  ; comment_syntax : Comment_syntax.t
  ; default_code_lang : Markdown_lang_id.t
  ; mutable line_number : int
  ; mutable in_block_comment : bool
  ; mutable mode : Mode.t
  }

let create ~file_cache ~comment_syntax ~default_code_lang =
  { file_cache
  ; comment_syntax
  ; default_code_lang
  ; line_number = 0
  ; in_block_comment = false
  ; mode = Ignore
  }
;;

let feed t ~line =
  t.line_number <- t.line_number + 1;
  let classified, new_in_block_comment =
    classify_line
      ~file_cache:t.file_cache
      ~line_number:t.line_number
      ~comment_syntax:t.comment_syntax
      ~in_block_comment:t.in_block_comment
      line
  in
  t.in_block_comment <- new_in_block_comment;
  let new_mode, actions =
    transition
      ~file_cache:t.file_cache
      ~line_number:t.line_number
      ~mode:t.mode
      ~default_code_lang:t.default_code_lang
      classified
  in
  t.mode <- new_mode;
  actions
;;

let flush t =
  match t.mode with
  | Ignore -> []
  | Prose -> [ Action.Flush_prose ]
  | Code_block -> [ Flush_code; Close_code_fence ]
  | Accumulating_inline_config { origin; accumulator } ->
    finalize_accumulator ~file_cache:t.file_cache origin accumulator
;;

1	(*********************************************************************************)
2	(* mdexp - Literate Programming with Embedded Snapshots *)
3	(* SPDX-FileCopyrightText: 2025-2026 Mathieu Barbin <mathieu.barbin@gmail.com> *)
4	(* SPDX-License-Identifier: LGPL-3.0-or-later WITH LGPL-3.0-linking-exception *)
5	(*********************************************************************************)
6
7	module Action = struct
8	type t =
9	\| Emit_prose_line of string
10	\| Emit_code_line of string
11	\| Close_code_fence
12	\| Flush_prose
13	\| Flush_code
14	\| Blank_separator
15	\| Enter_snapshot of Located_json.t option
16	\| Enter_code of Located_json.t option
17	\| Configure of Located_json.t
18
19	let json_to_dyn json = Dyn.string (Yojson.Basic.to_string json)	12✔
20	let located_json_to_dyn lj = json_to_dyn (Located_json.json lj :> Yojson.Basic.t)	12✔
21
22	let to_dyn = function
23	\| Emit_prose_line s -> Dyn.variant "Emit_prose_line" [ Dyn.string s ]	20✔
24	\| Emit_code_line s -> Dyn.variant "Emit_code_line" [ Dyn.string s ]	11✔
25	\| Close_code_fence -> Dyn.variant "Close_code_fence" []	12✔
26	\| Flush_prose -> Dyn.variant "Flush_prose" []	19✔
27	\| Flush_code -> Dyn.variant "Flush_code" []	12✔
28	\| Blank_separator -> Dyn.variant "Blank_separator" []	23✔
29	\| Enter_snapshot lj_opt ->	3✔
30	Dyn.variant "Enter_snapshot" [ Dyn.option located_json_to_dyn lj_opt ]	3✔
31	\| Enter_code lj_opt ->	12✔
32	Dyn.variant "Enter_code" [ Dyn.option located_json_to_dyn lj_opt ]	12✔
33	\| Configure lj -> Dyn.variant "Configure" [ located_json_to_dyn lj ]	6✔
34	;;
35	end
36
37	(* -- Comment stripping internals -- *)
38
39	module Strip_result = struct
40	type t =
41	\| Not_a_comment
42	\| Content of
43	{ content : string
44	; col : int
45	}
46	\| Block_closer
47	end
48
49	let is_block_comment_opening line ~(comment_syntax : Comment_syntax.t) =
50	match comment_syntax.block with	372✔
51	\| None -> false	28✔
52	\| Some block ->	344✔
53	let trimmed = String.ltrim line in
54	String.starts_with ~prefix:block.start_ trimmed	344✔
55	;;
56
57	let is_single_line_block_comment line ~(comment_syntax : Comment_syntax.t) =
58	match comment_syntax.block with	372✔
59	\| Some block ->	344✔
60	let trimmed = String.trim line in
61	String.starts_with ~prefix:block.start_ trimmed	344✔
62	&& String.ends_with ~suffix:block.end_ trimmed	267✔
63	\| None -> false	28✔
64	;;
65
66	let is_standalone_block_closer line ~(comment_syntax : Comment_syntax.t) =
67	match comment_syntax.block with	1,577✔
68	\| None -> false	71✔
69	\| Some block ->	1,506✔
70	let trimmed = String.trim line in
71	String.equal trimmed block.end_ \|\| String.equal trimmed ("@" ^ block.end_)	18✔
72	;;
73
74	let ends_with_block_closer line ~(comment_syntax : Comment_syntax.t) =
75	match comment_syntax.block with	1,577✔
76	\| None -> false	71✔
77	\| Some block ->	1,506✔
78	let trimmed = String.rtrim line in
79	String.ends_with ~suffix:block.end_ trimmed	1,506✔
80	;;
81
82	let strip_line_comment ~prefix line =
83	let trimmed = String.ltrim line in	169✔
84	let leading_ws = String.length line - String.length trimmed in	169✔
85	if String.starts_with ~prefix trimmed
86	then (	101✔
87	let len = String.length prefix in
88	let rest = String.sub trimmed ~pos:len ~len:(String.length trimmed - len) in	101✔
89	if String.length rest > 0 && Char.equal rest.[0] ' '	94✔
90	then Some (String.sub rest ~pos:1 ~len:(String.length rest - 1), leading_ws + len + 1)	94✔
91	else Some (rest, leading_ws + len))	7✔
92	else None	68✔
93	;;
94
95	let strip_block_comment ~block_start ~block_end ~in_block_comment line =
96	let trimmed = String.ltrim line in	1,452✔
97	let leading_ws = String.length line - String.length trimmed in	1,452✔
98	let trimmed_all = String.trim trimmed in
99	if	1,452✔
100	(not (String.starts_with ~prefix:block_start trimmed))	1,452✔
101	&& (String.equal trimmed_all block_end \|\| String.equal trimmed_all ("@" ^ block_end))	1✔
102	then Strip_result.Block_closer	19✔
103	else (	1,433✔
104	let found_opening, after_opening, col =
105	if String.starts_with ~prefix:block_start trimmed
106	then (	408✔
107	let len = String.length block_start in
108	let rest = String.sub trimmed ~pos:len ~len:(String.length trimmed - len) in	408✔
109	let has_space = String.length rest > 0 && Char.equal rest.[0] ' ' in	406✔
110	let rest =
111	if has_space then String.sub rest ~pos:1 ~len:(String.length rest - 1) else rest	32✔
112	in
113	let col = leading_ws + len + if has_space then 1 else 0 in	32✔
114	true, rest, col)
115	else false, trimmed, leading_ws	1,025✔
116	in
117	if found_opening
118	then (	408✔
119	let trimmed_end = String.rtrim after_opening in
120	if String.ends_with ~suffix:block_end trimmed_end	408✔
121	then (	324✔
122	let len = String.length block_end in
123	let content =	324✔
124	String.sub trimmed_end ~pos:0 ~len:(String.length trimmed_end - len)	324✔
125	in
126	Content { content = String.rtrim content; col })	324✔
127	else Content { content = trimmed_end; col })	84✔
128	else if in_block_comment	1,025✔
129	then (	473✔
130	let trimmed_end = String.rtrim line in
131	if String.ends_with ~suffix:block_end trimmed_end	473✔
132	then (	62✔
133	let len = String.length block_end in
134	let content =	62✔
135	String.sub trimmed_end ~pos:0 ~len:(String.length trimmed_end - len)	62✔
136	in
137	Content { content = String.rtrim content; col = 0 })	62✔
138	else Content { content = String.rtrim line; col = 0 })	411✔
139	else Not_a_comment)	552✔
140	;;
141
142	let strip line ~(comment_syntax : Comment_syntax.t) ~in_block_comment =
143	let line_result =	1,577✔
144	match comment_syntax.line_prefix with
145	\| Some prefix ->	169✔
146	(match strip_line_comment ~prefix line with
147	\| Some (content, col) -> Some (Strip_result.Content { content; col })	101✔
148	\| None -> None)	68✔
149	\| None -> None	1,408✔
150	in
151	let block_result () =
152	match comment_syntax.block with	1,477✔
153	\| Some block ->	1,452✔
154	strip_block_comment
155	~block_start:block.start_
156	~block_end:block.end_
157	~in_block_comment
158	line
159	\| None -> Not_a_comment	25✔
160	in
161	match line_result with
162	\| Some r when not in_block_comment -> r	100✔
163	\| _ -> block_result ()	1,477✔
164	;;
165
166	(* -- Classified line (internal intermediate representation) -- *)
167
168	module Classified_line = struct
169	type t =
170	\| Directive of
171	{ directive : Directive.t
172	; trailing : string option
173	; is_single_line_block : bool
174	; loc : Loc.t
175	; col : int
176	}
177	\| Comment_content of
178	{ content : string
179	; raw_line : string
180	; ends_block : bool
181	; from_line_comment : bool
182	; col : int
183	}
184	\| Block_closer
185	\| Non_comment of { content : string }
186	end
187
188	let classify_line ~file_cache ~line_number ~comment_syntax ~in_block_comment line =
189	let is_block_closer = is_standalone_block_closer line ~comment_syntax in	1,577✔
190	let has_trailing_closer = ends_with_block_closer line ~comment_syntax in	1,577✔
191	let result = strip line ~comment_syntax ~in_block_comment in	1,577✔
192	let new_in_block_comment = ref in_block_comment in	1,577✔
193	let parse_directive content ~col =
194	Directive.parse_line ~content ~file_cache ~line:line_number ~col	981✔
195	in
196	let classified =
197	match result with
198	\| Block_closer ->	19✔
199	new_in_block_comment := false;
200	Classified_line.Block_closer
201	\| Not_a_comment -> Non_comment { content = line }	577✔
202	\| Content { content = comment_content; col } when is_block_closer ->	981✔
203	new_in_block_comment := false;	×
204	(match parse_directive comment_content ~col with
205	\| Some { directive; trailing; loc } ->	×
206	Directive { directive; trailing; is_single_line_block = false; loc; col }
207	\| None -> Block_closer)	×
208	\| Content { content = comment_content; col } ->	981✔
209	(match parse_directive comment_content ~col with
210	\| Some { directive; trailing; loc } ->	372✔
211	let is_single_line = is_single_line_block_comment line ~comment_syntax in
212	let is_opening = is_block_comment_opening line ~comment_syntax in	372✔
213	new_in_block_comment := is_opening && not is_single_line;	267✔
214	Directive
215	{ directive; trailing; is_single_line_block = is_single_line; loc; col }
216	\| None ->	609✔
217	let ends_block = has_trailing_closer && in_block_comment in	157✔
218	if ends_block then new_in_block_comment := false;	20✔
219	let from_line_comment =	609✔
220	Option.is_some comment_syntax.line_prefix && not !new_in_block_comment	49✔
221	in
222	Comment_content
223	{ content = comment_content
224	; raw_line = line
225	; ends_block
226	; from_line_comment
227	; col
228	})
229	in
230	classified, !new_in_block_comment
231	;;
232
233	(* -- State machine (internal) -- *)
234
235	type inline_config_origin =
236	\| Snapshot
237	\| Code
238	\| Config
239
240	module Mode = struct
241	type t =
242	\| Ignore
243	\| Prose
244	\| Code_block
245	\| Accumulating_inline_config of
246	{ origin : inline_config_origin
247	; accumulator : Json5_accumulator.t
248	}
249	end
250
251	let try_parse_located_json5 ~file_cache ~accumulator text =
252	match Yojson_five.Basic.from_string text \|> Result.to_option with	79✔
253	\| None -> None	×
254	\| Some (`Assoc _ as json) -> Some (Located_json.create ~file_cache ~accumulator ~json)	79✔
NEW 255	\| Some _ -> None	×
256	;;
257
258	let emit_inline_config_action origin located_json =
259	match origin with	79✔
260	\| Snapshot -> Action.Enter_snapshot (Some located_json)	41✔
261	\| Code -> Action.Enter_code (Some located_json)	18✔
262	\| Config -> Action.Configure located_json	20✔
263	;;
264
265	let mode_after_config = function
266	\| Snapshot \| Config -> Mode.Ignore	26✔
267	\| Code -> Mode.Code_block	83✔
268	;;
269
270	let fallback_action = function
271	\| Snapshot -> [ Action.Enter_snapshot None ]	38✔
272	\| Code -> [ Action.Enter_code None ]	61✔
273	\| Config -> []	×
274	;;
275
276	let finalize_accumulator ~file_cache origin accumulator =
277	let contents = Json5_accumulator.buffer_contents accumulator in	×
278	if String.is_empty (String.trim contents)	×
279	then fallback_action origin	×
280	else (	×
281	match try_parse_located_json5 ~file_cache ~accumulator contents with
282	\| Some lj -> [ emit_inline_config_action origin lj ]	×
283	\| None -> fallback_action origin)	×
284	;;
285
286	let close_current_block ~file_cache (mode : Mode.t) =
287	match mode with	388✔
288	\| Ignore -> []	237✔
289	\| Accumulating_inline_config { origin; accumulator } ->	×
290	finalize_accumulator ~file_cache origin accumulator
291	\| Prose -> [ Action.Flush_prose; Blank_separator ]	78✔
292	\| Code_block -> [ Flush_code; Close_code_fence; Blank_separator ]	73✔
293	;;
294
295	let start_inline_config ~file_cache ~file_offset ~origin ~inline ~close_actions =
296	let mode_done = mode_after_config origin in	178✔
297	match inline with	178✔
298	\| None ->	102✔
299	(match origin with
300	\| Config ->	3✔
301	let acc = Json5_accumulator.create () in
302	Mode.Accumulating_inline_config { origin; accumulator = acc }, close_actions	3✔
303	\| Snapshot \| Code -> mode_done, close_actions @ fallback_action origin)	38✔
304	\| Some s ->	76✔
305	let acc = Json5_accumulator.create () in
306	(match Json5_accumulator.feed acc ~file_offset ~line:s with	76✔
307	\| Done { json_text } ->	73✔
308	(match try_parse_located_json5 ~file_cache ~accumulator:acc json_text with
309	\| Some lj -> mode_done, close_actions @ [ emit_inline_config_action origin lj ]	73✔
310	\| None -> mode_done, close_actions @ fallback_action origin)	×
311	\| Need_more ->	3✔
312	Accumulating_inline_config { origin; accumulator = acc }, close_actions
313	\| Error -> mode_done, close_actions @ fallback_action origin)	×
314	;;
315
316	let compute_file_offset ~file_cache ~line_number ~col =
317	let line_loc = Loc.of_file_line ~file_cache ~line:line_number in	12✔
318	Loc.start_offset line_loc + col	12✔
319	;;
320
321	let start_directive_inline_config ~file_cache ~mode ~origin ~trailing ~loc =
322	let close_actions = close_current_block ~file_cache mode in	178✔
323	let trailing_len =	178✔
324	match trailing with
325	\| None -> 0	102✔
326	\| Some s -> String.length s	76✔
327	in
328	let file_offset = Loc.stop_offset loc - trailing_len in	178✔
329	start_inline_config ~file_cache ~file_offset ~origin ~inline:trailing ~close_actions
330	;;
331
332	let transition
333	~file_cache
334	~line_number
335	~(mode : Mode.t)
336	~default_code_lang:_
337	(input : Classified_line.t)
338	=
339	match input with	1,577✔
340	\| Directive { directive = Prose; trailing; is_single_line_block; loc = _; col = _ } ->	117✔
341	let close_actions = close_current_block ~file_cache mode in
342	let enter_actions =	117✔
343	match trailing with
344	\| Some content -> [ Action.Emit_prose_line content ]	19✔
345	\| None -> []	98✔
346	in
347	let flush_actions =
348	if is_single_line_block && Option.is_some trailing	28✔
349	then [ Action.Flush_prose; Blank_separator ]	18✔
350	else []	99✔
351	in
352	let new_mode =
353	if is_single_line_block && Option.is_some trailing then Mode.Ignore else Prose	18✔
354	in
355	new_mode, close_actions @ enter_actions @ flush_actions
356	\| Directive { directive = Code; trailing; is_single_line_block = _; loc; col = _ } ->	79✔
357	start_directive_inline_config ~file_cache ~mode ~origin:Code ~trailing ~loc
358	\| Directive { directive = Snapshot; trailing; is_single_line_block = _; loc; col = _ }	79✔
359	-> start_directive_inline_config ~file_cache ~mode ~origin:Snapshot ~trailing ~loc
360	\| Directive { directive = Config; trailing; is_single_line_block = _; loc; col = _ } ->	20✔
361	start_directive_inline_config ~file_cache ~mode ~origin:Config ~trailing ~loc
362	\| Directive	77✔
363	{ directive = End; is_single_line_block = _; trailing = _; loc = _; col = _ } ->
364	let close_actions = close_current_block ~file_cache mode in
365	Ignore, close_actions	77✔
366	\| Block_closer ->	19✔
367	(match mode with
368	\| Accumulating_inline_config { origin; accumulator } ->	×
369	mode_after_config origin, finalize_accumulator ~file_cache origin accumulator	×
370	\| Code_block -> Code_block, []	3✔
371	\| _ ->	16✔
372	let close_actions = close_current_block ~file_cache mode in
373	Ignore, close_actions)	16✔
374	\| Comment_content { content; raw_line; ends_block; from_line_comment; col } ->	609✔
375	(match mode with
376	\| Ignore -> Ignore, []	80✔
377	\| Accumulating_inline_config { origin; accumulator } ->	12✔
378	let file_offset = compute_file_offset ~file_cache ~line_number ~col in
379	let done_mode = mode_after_config origin in
380	(match Json5_accumulator.feed accumulator ~file_offset ~line:content with	12✔
381	\| Done { json_text } ->	6✔
382	(match try_parse_located_json5 ~file_cache ~accumulator json_text with
383	\| Some lj -> done_mode, [ emit_inline_config_action origin lj ]	6✔
384	\| None -> done_mode, fallback_action origin)	×
385	\| Need_more ->	6✔
386	if ends_block
387	then done_mode, finalize_accumulator ~file_cache origin accumulator	×
388	else mode, []	6✔
389	\| Error ->	×
390	if ends_block
391	then done_mode, finalize_accumulator ~file_cache origin accumulator	×
392	else mode, [])	×
393	\| Prose ->	470✔
394	let actions = [ Action.Emit_prose_line content ] in
395	if ends_block
396	then Ignore, actions @ [ Flush_prose; Blank_separator ]	18✔
397	else Prose, actions	452✔
398	\| Code_block ->	47✔
399	let content_to_use =
400	if from_line_comment
401	then raw_line	7✔
402	else (	40✔
403	let has_leading_whitespace =
404	String.length raw_line > 0	40✔
405	&& (Char.equal (String.get raw_line 0) ' '	2✔
406	\|\| Char.equal (String.get raw_line 0) '\t')	×
407	in
408	if has_leading_whitespace then raw_line else content)	2✔
409	in
410	let actions = [ Action.Emit_code_line content_to_use ] in
411	if ends_block
412	then Ignore, actions @ [ Flush_code; Close_code_fence; Blank_separator ]	×
413	else mode, actions)	47✔
414	\| Non_comment { content } ->	577✔
415	(match mode with
416	\| Code_block -> mode, [ Action.Emit_code_line content ]	261✔
417	\| Accumulating_inline_config { origin; accumulator } ->	×
418	mode_after_config origin, finalize_accumulator ~file_cache origin accumulator	×
419	\| _ -> mode, [])	316✔
420	;;
421
422	(* -- Public interface -- *)
423
424	type t =
425	{ file_cache : Loc.File_cache.t
426	; comment_syntax : Comment_syntax.t
427	; default_code_lang : Markdown_lang_id.t
428	; mutable line_number : int
429	; mutable in_block_comment : bool
430	; mutable mode : Mode.t
431	}
432
433	let create ~file_cache ~comment_syntax ~default_code_lang =
434	{ file_cache	144✔
435	; comment_syntax
436	; default_code_lang
437	; line_number = 0
438	; in_block_comment = false
439	; mode = Ignore
440	}
441	;;
442
443	let feed t ~line =
444	t.line_number <- t.line_number + 1;	1,577✔
445	let classified, new_in_block_comment =
446	classify_line
447	~file_cache:t.file_cache
448	~line_number:t.line_number
449	~comment_syntax:t.comment_syntax
450	~in_block_comment:t.in_block_comment
451	line
452	in
453	t.in_block_comment <- new_in_block_comment;	1,577✔
454	let new_mode, actions =
455	transition
456	~file_cache:t.file_cache
457	~line_number:t.line_number
458	~mode:t.mode
459	~default_code_lang:t.default_code_lang
460	classified
461	in
462	t.mode <- new_mode;	1,577✔
463	actions
464	;;
465
466	let flush t =
467	match t.mode with	144✔
468	\| Ignore -> []	135✔
469	\| Prose -> [ Action.Flush_prose ]	3✔
470	\| Code_block -> [ Flush_code; Close_code_fence ]	6✔
471	\| Accumulating_inline_config { origin; accumulator } ->	×
472	finalize_accumulator ~file_cache:t.file_cache origin accumulator
473	;;

mbarbin / mdexp / 18

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous