1
(* packaging of annotated sexp functions *)
4
let iter t ~f = List.iter f t
5
let map t ~f = List.rev (List.rev_map f t)
8
include Type_with_layout
10
type pos = Src_pos.Relative.t = { row : int; col : int }
11
let sexp_of_pos = Src_pos.Relative.sexp_of_t
14
let main = Lexer.main_with_layout
17
module Parser = Parser_with_layout
19
module Render = struct
21
module Rel_pos = Src_pos.Relative
22
module Abs_pos = Src_pos.Absolute
25
immed_after : Abs_pos.t;
30
mutable row_shift : Rel_pos.t;
31
mutable current : Abs_pos.t;
32
mutable last_atom : last_atom option;
35
(* the point of [immed_after_last_atom] is to prevent
36
(A B C) from rendering as (A BBC) after we replace B with BB *)
38
type 'a t = (char -> unit) -> state -> 'a
40
let return a _putc _st = a
42
let bind m f putc st = f (m putc st) putc st
46
row_shift = Rel_pos.zero;
47
current = Abs_pos.origin;
51
let emit_char putc st c =
52
let {Abs_pos.col; row} = st.current in
55
st.current <- {Abs_pos.row = 1 + row; col = 1}
57
st.current <- {Abs_pos.row; col = 1 + col}
59
let emit_string putc st str =
60
let n = String.length str in
62
emit_char putc st str.[i]
65
let emit_chars putc st c ~n =
66
emit_string putc st (String.make n c)
68
let advance putc ~anchor st ~by:delta ~unescaped_atom =
69
let new_pos = Abs_pos.add (Abs_pos.add anchor delta) st.row_shift in
70
let need_to_leave_room_between_two_unescaped_atoms_lest_they_become_one =
71
unescaped_atom && begin
72
match st.last_atom with
73
| Some {immed_after; unescaped = prev_unescaped} ->
74
new_pos = immed_after && prev_unescaped
78
let need_to_reposition =
79
not (Abs_pos.geq new_pos st.current)
80
|| need_to_leave_room_between_two_unescaped_atoms_lest_they_become_one
82
let (row_delta, new_pos) =
83
if need_to_reposition then begin
84
(* repositioning heuristic: just move to the next fresh row *)
85
let new_row = 1 + st.current.Abs_pos.row in
86
let row_delta = new_row - new_pos.Abs_pos.row in
87
(row_delta, {Abs_pos.row = new_row; col = new_pos.Abs_pos.col})
91
begin (* advance to new_pos by emitting whitespace *)
92
if new_pos.Abs_pos.row > st.current.Abs_pos.row then begin
93
let n = (new_pos.Abs_pos.row - st.current.Abs_pos.row) in
94
emit_chars putc st '\n' ~n
96
if new_pos.Abs_pos.col > st.current.Abs_pos.col then begin
97
let n = (new_pos.Abs_pos.col - st.current.Abs_pos.col) in
98
emit_chars putc st ' ' ~n
101
assert (new_pos = st.current);
103
st.row_shift with Rel_pos.
104
row = st.row_shift.Rel_pos.row + row_delta;
107
let rec render_t putc ~anchor (st : state) t =
109
| Atom (delta, text, fmt_text) ->
112
| None | Some "" -> Pre_sexp.maybe_esc_str text
115
let unescaped = fmt_text.[0] <> '"' in
116
advance putc st ~by:delta ~anchor ~unescaped_atom:unescaped;
117
emit_string putc st fmt_text;
118
st.last_atom <- Some { immed_after = st.current; unescaped; };
119
| List (start_delta, tocs, end_delta) ->
120
advance putc st ~by:start_delta ~anchor ~unescaped_atom:false;
121
let child_anchor = Abs_pos.sub st.current st.row_shift in
122
emit_char putc st '(';
123
List.iter tocs ~f:(fun toc -> render_toc putc ~anchor:child_anchor st toc);
124
advance putc st ~by:end_delta ~anchor ~unescaped_atom:false;
125
emit_char putc st ')';
128
and render_toc putc ~anchor st = function
129
| Sexp t -> render_t putc ~anchor st t
130
| Comment c -> render_c putc ~anchor st c
132
and render_c putc ~anchor st = function
133
| Plain_comment (delta, text) ->
134
advance putc st ~by:delta ~anchor ~unescaped_atom:false;
135
emit_string putc st text
136
| Sexp_comment (delta, cs, t) ->
137
advance putc st ~by:delta ~anchor ~unescaped_atom:false;
138
emit_string putc st "#;";
139
List.iter cs ~f:(render_c putc ~anchor st);
140
render_t putc ~anchor st t
142
let render asexp putc st = render_toc putc ~anchor:Abs_pos.origin st asexp
148
module Forget = struct
150
(* In cps to prevent non-tail recursion.
151
The polymorphism in the signature ensures that each function returns
152
only through the continuation. *)
154
val forget_t : t -> (Type.t -> 'r) -> 'r
155
val forget_toc : t_or_comment -> (Type.t option -> 'r) -> 'r
156
val forget_tocs : t_or_comment list -> (Type.t list -> 'r) -> 'r
159
let rec forget_t t k =
161
| Atom (_, x, _) -> k (Type.Atom x)
162
| List (_, tocs, _) -> forget_tocs tocs (fun xs -> k (Type.List xs))
164
and forget_tocs tocs k =
168
forget_toc toc (function
169
| None -> forget_tocs tocs k
170
| Some x -> forget_tocs tocs (fun xs -> k (x :: xs)))
172
and forget_toc toc k =
174
| Comment _ -> k None
175
| Sexp t -> forget_t t (fun x -> k (Some x))
178
let t x = Cps.forget_t x (fun y -> y)
179
let t_or_comment x = Cps.forget_toc x (fun y -> y)
180
let t_or_comments x = Cps.forget_tocs x (fun y -> y)
added
removed
lib/sexp_with_layout.ml
