source: Deliverables/D2.2/8051/src/utilities/print.ml @ 486

Last change on this file since 486 was 486, checked in by ayache, 9 years ago

Deliverable D2.2

File size: 3.4 KB
Line 
1(* Pasted from Pottier's PP compiler *)
2
3open Printf
4
5type punctuation =
6    unit -> string
7
8type 'a printer =
9    unit -> 'a -> string
10
11(* ------------------------------------------------------------------------- *)
12
13(* Newlines and indentation. *)
14
15let maxindent =
16  120
17
18let whitespace =
19  String.make maxindent ' '
20
21let indentation =
22  ref 0
23
24let nl () =
25  "\n" ^ String.sub whitespace 0 !indentation
26
27let 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
40let rec list elem () xs =
41  match xs with
42  | [] ->
43      ""
44  | x :: xs ->
45      sprintf "%a%a" elem x (list elem) xs
46
47let 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
54let 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
61let seplist sep elem () xs =
62  match xs with
63  | [] ->
64      ""
65  | x :: xs ->
66      sprintf "%a%a" elem x (preclist sep elem) xs
67
68let annlist announcement list () xs =
69  match xs with
70  | [] ->
71      ""
72  | _ :: _ ->
73      sprintf "%t%a" announcement list xs
74
75(* ------------------------------------------------------------------------- *)
76
77(* Punctuation. *)
78
79let space () =
80  sprintf " "
81
82let comma () =
83  sprintf ", "
84
85let semicolon () =
86  sprintf "; "
87
88let var () =
89  sprintf "var "
90
91let seminl () =
92  sprintf "%t%t" semicolon nl
93
94let nlspace k () =
95  sprintf "%t%s" nl (String.make k ' ')
96
97let 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
105let 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
123let width column =
124  List.fold_left (fun width x ->
125    max width (String.length x)
126  ) 0 column
127
128let pad width x =
129  let y = String.make width ' ' in
130  String.blit x 0 y 0 (String.length x);
131  y
132
133let pad column =
134  List.map (pad (width column)) column
135
136let rec zipcat column1 column2 =
137  List.fold_right2 (fun x1 x2 column ->
138    (x1 ^ x2) :: column
139  ) column1 column2 []
140
141let 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
150let 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
165let 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
Note: See TracBrowser for help on using the repository browser.