]> matita.cs.unibo.it Git - pkg-cerco/acc.git/blob - src/utilities/printPottier.ml
Package description and copyright added.
[pkg-cerco/acc.git] / src / utilities / printPottier.ml
1 (* Pasted from Pottier's PP compiler *)
2
3 open Printf
4
5 type punctuation =
6     unit -> string
7
8 type 'a printer =
9     unit -> 'a -> string
10
11 (* ------------------------------------------------------------------------- *)
12
13 (* Newlines and indentation. *)
14
15 let maxindent =
16   120
17
18 let whitespace =
19   String.make maxindent ' '
20
21 let indentation =
22   ref 0
23
24 let nl () =
25   "\n" ^ String.sub whitespace 0 !indentation
26
27 let indent ofs producer () x =
28   let old_indentation = !indentation in
29   let new_indentation = old_indentation + ofs in
30   if new_indentation <= maxindent then
31     indentation := new_indentation;
32   let result = sprintf "%t%a" nl producer x in
33   indentation := old_indentation;
34   result
35
36 (* ------------------------------------------------------------------------- *)
37
38 (* Lists. *)
39
40 let rec list elem () xs =
41   match xs with
42   | [] ->
43       ""
44   | x :: xs ->
45       sprintf "%a%a" elem x (list elem) xs
46
47 let rec preclist delim elem () xs =
48   match xs with
49   | [] ->
50       ""
51   | x :: xs ->
52       sprintf "%t%a%a" delim elem x (preclist delim elem) xs
53
54 let rec termlist delim elem () xs =
55   match xs with
56   | [] ->
57       ""
58   | x :: xs ->
59       sprintf "%a%t%a" elem x delim (termlist delim elem) xs
60
61 let seplist sep elem () xs =
62   match xs with
63   | [] ->
64       ""
65   | x :: xs ->
66       sprintf "%a%a" elem x (preclist sep elem) xs
67
68 let annlist announcement list () xs =
69   match xs with
70   | [] ->
71       ""
72   | _ :: _ ->
73       sprintf "%t%a" announcement list xs
74
75 (* ------------------------------------------------------------------------- *)
76
77 (* Punctuation. *)
78
79 let space () =
80   sprintf " "
81
82 let comma () =
83   sprintf ", "
84
85 let semicolon () =
86   sprintf "; "
87
88 let var () =
89   sprintf "var "
90
91 let seminl () =
92   sprintf "%t%t" semicolon nl
93
94 let nlspace k () =
95   sprintf "%t%s" nl (String.make k ' ')
96
97 let nlnl () =
98   sprintf "%t%t" nl nl
99
100 (* ------------------------------------------------------------------------- *)
101
102 (* [atmost n delimiter stop] normally prints a [delimiter], except that,
103    every [n] calls, it prints a [stop] in addition. *)
104
105 let atmost n (delimiter : punctuation) (stop : punctuation) : punctuation =
106   let i =
107     ref 0
108   in
109   function () ->
110     incr i;
111     delimiter() ^
112     if !i = n then begin
113       i := 0;
114       stop()
115     end
116     else
117       ""
118
119 (* ------------------------------------------------------------------------- *)
120
121 (* Tables. *)
122
123 let width column =
124   List.fold_left (fun width x ->
125     max width (String.length x)
126   ) 0 column
127
128 let pad width x =
129   let y = String.make width ' ' in
130   String.blit x 0 y 0 (String.length x);
131   y
132
133 let pad column =
134   List.map (pad (width column)) column
135
136 let rec zipcat column1 column2 =
137   List.fold_right2 (fun x1 x2 column ->
138     (x1 ^ x2) :: column
139   ) column1 column2 []
140
141 let catenate columns =
142   match columns with
143   | [] ->
144       []
145   | column :: columns ->
146       List.fold_left (fun table column ->
147         zipcat table (pad column)
148       ) (pad column) columns
149
150 let transposerev lines =
151   match lines with
152   | [] ->
153       []
154   | line :: lines ->
155       List.fold_left (fun columns line ->
156         List.fold_right2 (fun x column columns ->
157           (x :: column) :: columns
158         ) line columns []
159       ) (List.map (fun x -> [ x ]) line) lines
160
161 (* ------------------------------------------------------------------------- *)
162
163 (* Conditional. *)
164
165 let showif flag printer x =
166   if flag then begin
167     Printf.fprintf stdout "%s%!" (sprintf "%a" printer x);
168     x
169   end
170   else
171     x
172