blob: af8c48a7062fc548c7f903d91334ed1d81431d2c (
plain)
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
|
type state =
| Token
| String
| DString
| MString of int
| EndString
| Expression
type t = {
buffer : Sedlexing.lexbuf;
mutable start_p : Lexing.position option;
state : state Stack.t;
reset_line : bool;
}
let buffer : t -> Sedlexing.lexbuf = fun t -> t.buffer
let start : t -> unit =
fun t ->
let _start_pos, end_pos = Sedlexing.lexing_positions t.buffer in
let () =
if not t.reset_line then
Sedlexing.set_position t.buffer { end_pos with Lexing.pos_lnum = 1 }
in
t.start_p <- None
let positions : t -> Lexing.position * Lexing.position =
fun t ->
let default, end_p = Sedlexing.lexing_positions t.buffer in
let start_p = Option.value ~default t.start_p in
(start_p, end_p)
let content : t -> string = fun t -> Sedlexing.Utf8.lexeme t.buffer
let from_lexbuf : ?reset_line:bool -> Sedlexing.lexbuf -> t =
fun ?(reset_line = true) t ->
{ buffer = t; start_p = None; reset_line; state = Stack.create () }
let set_start_position : t -> Lexing.position -> unit =
fun t position ->
match t.start_p with
| None -> t.start_p <- Some position
| _ ->
(* We are already inside a block code, don’t stack it *)
()
let tokenize : (t -> 'a) -> t -> unit -> 'a * Lexing.position * Lexing.position
=
fun f t ->
let lexer () =
(* Clear the previous registered start position if any *)
t.start_p <- None;
let token = f t in
let default, curr_p = positions t in
let start_p = Option.value ~default t.start_p in
t.start_p <- None;
(token, start_p, curr_p)
in
lexer
let rollback : t -> unit = fun t -> Sedlexing.rollback t.buffer
(** The comment system is terrible. The same symbol can be used for :
- starting a comment
- inequality operation
In order to manage this, I try to identify the context in a very basic way,
using a counter for determining the token to send.
*)
let state : t -> state option = fun t -> Stack.top_opt t.state
let enter_state : t -> state -> unit = fun t state -> Stack.push state t.state
let leave_state : t -> unit = fun t -> ignore (Stack.pop_opt t.state)
|
