Source file alpha_comments.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
open Core_kernel

open MParser

let to_string from until between : string =
  from ^ (String.of_char_list between) ^ until

let anything_including_newlines ~until =
  (many
     (not_followed_by (string until) ""
      >>= fun () -> any_char_or_nl))

let anything_excluding_newlines ~until =
  (many
     (not_followed_by (string until) ""
      >>= fun () -> any_char))

(** a parser for comments with delimiters [from] and [until] that do not nest *)
let non_nested_comment from until s =
  (between
     (string from)
     (string until)
     (anything_including_newlines ~until)
   |>> to_string from until
  ) s

let until_newline start s =
  (string start >> anything_excluding_newlines ~until:"\n"
   |>> fun l -> start^(String.of_char_list l)) s

let any_newline comment_string s =
  (string comment_string >> anything_excluding_newlines ~until:"\n" |>> fun l -> (comment_string^String.of_char_list l)) s

let is_not p s =
  if is_ok (p s) then
    Empty_failed (unknown_error s)
  else
    match read_char s with
    | Some c ->
      Consumed_ok (c, advance_state s 1, No_error)
    | None ->
      Empty_failed (unknown_error s)

(** A nested comment parser *)
let nested_comment from until s =
  let reserved = skip ((string from) <|> (string until)) in
  let rec grammar s =
    ((comment_delimiters >>= fun string -> return string)
     <|>
     (is_not reserved >>= fun c -> return (Char.to_string c)))
      s

  and comment_delimiters s =
    (between
       (string from)
       (string until)
       ((many grammar) >>= fun result ->
        return (String.concat result)))
      s
  in
  (comment_delimiters |>> fun content ->
   from ^ content ^ until) s

(** a parser for, e.g., /* ... */ style block comments. Non-nested. *)
module Multiline = struct
  module type S = sig
    val left : string
    val right : string
  end

  module Make (M : S) = struct
    let comment s = non_nested_comment M.left M.right s
  end
end

module Until_newline = struct
  module type S = sig
    val start : string
  end

  module Make (M : S) = struct
    let comment s = until_newline M.start s
  end
end

module Nested_multiline = struct
  module type S = sig
    val left : string
    val right : string
  end

  module Make (M : S) = struct
    let comment s = nested_comment M.left M.right s
  end
end