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