Add poc files
This commit is contained in:
Joey Yakimowich-Payne
parent
30da2412e3
commit
fa600b98f7
220 changed files with 45679 additions and 0 deletions
454
h_program-lang/pretty_print_code.ml
Normal file
454
h_program-lang/pretty_print_code.ml
Normal file
|
|
@ -0,0 +1,454 @@
|
|||
(* Julien Verlaguet, Yoann Padioleau
|
||||
*
|
||||
* Copyright (C) 2011 Facebook
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
* version 2.1 as published by the Free Software Foundation, with the
|
||||
* special exception on linking described in file license.txt.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file
|
||||
* license.txt for more details.
|
||||
*)
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Prelude *)
|
||||
(*****************************************************************************)
|
||||
(* julien: this is a copy/paste of the original pp.ml.
|
||||
* It is slightly modified, and I don't know how much these modifications
|
||||
* affect xhpizer. I hope to be able to merge these two files back together.
|
||||
*)
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Types *)
|
||||
(*****************************************************************************)
|
||||
|
||||
(* we use a backtracking model *)
|
||||
exception Fail
|
||||
|
||||
type env = {
|
||||
(* the actual printing hook, sometimes temporarily set to do_nothing()
|
||||
* when trying something before actually printing it. *)
|
||||
print: (string -> unit);
|
||||
|
||||
(* stack of margin, push'ed and pop'ed when processing {} *)
|
||||
mutable margin: int list;
|
||||
|
||||
(* current column *)
|
||||
mutable cmargin: int;
|
||||
(* current line *)
|
||||
mutable line: int;
|
||||
|
||||
(* depth in the tree of try_ *)
|
||||
mutable level: int;
|
||||
|
||||
(* for the parenthesis automatic insertion *)
|
||||
mutable priority: int;
|
||||
|
||||
(* pad: ?? *)
|
||||
mutable last_nl: bool;
|
||||
mutable emptyl: bool;
|
||||
mutable failed: bool;
|
||||
mutable pushed: bool;
|
||||
}
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Helpers *)
|
||||
(*****************************************************************************)
|
||||
|
||||
let empty o = {
|
||||
print = o;
|
||||
margin = [0];
|
||||
priority = 0;
|
||||
cmargin = 0;
|
||||
level = 0;
|
||||
pushed = false;
|
||||
last_nl = false;
|
||||
emptyl = false;
|
||||
failed = false;
|
||||
line = 0;
|
||||
}
|
||||
|
||||
let debug env f =
|
||||
let buf = Buffer.create 256 in
|
||||
let env' = { env with print = (fun s -> Buffer.add_string buf s)} in
|
||||
(try f env' with _ -> ());
|
||||
Printf.printf "Debug %s\n" (Buffer.contents buf)
|
||||
|
||||
let do_nothing _ = ()
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Newlines and spaces *)
|
||||
(*****************************************************************************)
|
||||
|
||||
let print env x =
|
||||
(* todo: this is the case right now for comments.
|
||||
* we should normalize those comments?
|
||||
* if (String.contains x '\n')
|
||||
* then failwith (Printf.sprintf "%s contains a newline\n" x);
|
||||
*)
|
||||
|
||||
env.last_nl <- false;
|
||||
env.emptyl <- false;
|
||||
|
||||
env.cmargin <- env.cmargin + String.length x;
|
||||
if env.cmargin >= 80
|
||||
then
|
||||
(* there is nothing to backtrack on, so just print it *)
|
||||
if env.level = 0
|
||||
then begin env.print x; env.failed <- true end
|
||||
else raise Fail
|
||||
else env.print x
|
||||
|
||||
let spaces env =
|
||||
for _i = 1 to List.hd env.margin do
|
||||
print env " ";
|
||||
done
|
||||
|
||||
let newline env =
|
||||
env.pushed <- false;
|
||||
if env.last_nl
|
||||
then env.emptyl <- true;
|
||||
env.last_nl <- true;
|
||||
env.cmargin <- 0;
|
||||
env.line <- env.line + 1;
|
||||
env.print "\n"
|
||||
|
||||
let newline_opt env =
|
||||
if env.last_nl
|
||||
then ()
|
||||
else newline env
|
||||
|
||||
let space_or_nl env =
|
||||
if env.cmargin < 75
|
||||
then print env " "
|
||||
else (newline env; spaces env)
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Margins *)
|
||||
(*****************************************************************************)
|
||||
|
||||
let margin_offset = ref 2
|
||||
|
||||
let push env =
|
||||
env.pushed <- true;
|
||||
env.margin <- List.hd env.margin + !margin_offset :: env.margin
|
||||
|
||||
let pop env =
|
||||
env.margin <- List.tl env.margin
|
||||
|
||||
let nest env f =
|
||||
push env;
|
||||
f env;
|
||||
pop env
|
||||
|
||||
let nest_opt env f =
|
||||
if env.pushed
|
||||
then f env
|
||||
else begin
|
||||
push env;
|
||||
f env;
|
||||
pop env
|
||||
end
|
||||
|
||||
let nestc env f =
|
||||
env.margin <- env.cmargin :: env.margin;
|
||||
f env;
|
||||
pop env
|
||||
|
||||
let nest_block env f =
|
||||
print env "{";
|
||||
newline env;
|
||||
nest env f;
|
||||
spaces env;
|
||||
print env "}"
|
||||
|
||||
let nest_block_nl env f =
|
||||
nest_block env f;
|
||||
newline env
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Lists *)
|
||||
(*****************************************************************************)
|
||||
|
||||
let rec simpl_list env f sep = function
|
||||
| [] -> ()
|
||||
| [x] -> f env x
|
||||
| x :: rl -> f env x; print env sep; simpl_list env f sep rl
|
||||
|
||||
let rec list_sep env f sep = function
|
||||
| [] -> ()
|
||||
| [x] -> f env x
|
||||
| x :: rl -> f env x; sep env; list_sep env f sep rl
|
||||
|
||||
let flat_list env f opar l sep cpar =
|
||||
print env opar;
|
||||
list_sep env f (fun env -> print env sep; print env " ") l;
|
||||
print env cpar
|
||||
|
||||
(* pad: used to take a last_nl parameter, but it was not used *)
|
||||
let nl_nested_list env f opar l sep cpar =
|
||||
print env opar;
|
||||
nest env (fun env ->
|
||||
newline env;
|
||||
spaces env;
|
||||
list_sep env f (fun env -> print env sep; newline env; spaces env) l;
|
||||
newline env;
|
||||
);
|
||||
if cpar <> ""
|
||||
then begin
|
||||
spaces env;
|
||||
print env cpar
|
||||
end
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Backtracking combinators *)
|
||||
(*****************************************************************************)
|
||||
|
||||
let fail () = raise Fail
|
||||
|
||||
let try_ env f =
|
||||
f { env with print = do_nothing; level = env.level + 1};
|
||||
f env
|
||||
|
||||
|
||||
let choice_left env f1 f2 =
|
||||
try try_ env f1
|
||||
with
|
||||
| Fail when env.level = 0 ->
|
||||
(try f2 env with Fail -> assert false)
|
||||
(* otherwise, just let the exception bubble up more *)
|
||||
|
||||
|
||||
let choice_right env f1 f2 =
|
||||
try try_ env f1
|
||||
with Fail ->
|
||||
f2 env
|
||||
|
||||
let try_hard env f =
|
||||
try
|
||||
f { env with print = do_nothing; level = 1 };
|
||||
f env
|
||||
with Fail ->
|
||||
let env' = { env with failed = false; print = do_nothing; level = 0 } in
|
||||
f env';
|
||||
if env'.failed
|
||||
then raise Fail
|
||||
else f { env with level = 0 }
|
||||
|
||||
let cut_list env f l =
|
||||
List.iter (
|
||||
fun x ->
|
||||
choice_right env
|
||||
(fun env -> f env x)
|
||||
(fun env -> newline env; spaces env; f env x)
|
||||
) l
|
||||
|
||||
|
||||
let list env f opar l sep cpar =
|
||||
let simple = (fun env -> flat_list env f opar l sep cpar) in
|
||||
let nested = (fun env -> nl_nested_list env f opar l sep cpar) in
|
||||
choice_right env simple nested
|
||||
|
||||
let list_left env f opar l sep cpar =
|
||||
let simple = (fun env -> if l <> [] then print env " "; flat_list env f opar l sep cpar) in
|
||||
let nested = (fun env -> nl_nested_list env f opar l sep cpar) in
|
||||
choice_left env simple nested
|
||||
|
||||
let nested_arg env f opar l sep cpar =
|
||||
let rec elt = function
|
||||
| [] -> assert false
|
||||
| [x] ->
|
||||
f env x;
|
||||
newline env;
|
||||
| x :: rl ->
|
||||
f env x; print env sep; newline env; spaces env;
|
||||
elt rl
|
||||
in
|
||||
nestc env (
|
||||
fun env ->
|
||||
print env opar;
|
||||
nestc env (
|
||||
fun _env ->
|
||||
elt l;
|
||||
);
|
||||
spaces env;
|
||||
print env cpar;
|
||||
)
|
||||
|
||||
|
||||
let fun_args env f opar l sep cpar =
|
||||
let simple = (
|
||||
fun env ->
|
||||
let line = env.line in
|
||||
flat_list env f opar l sep cpar;
|
||||
if line <> env.line then fail();
|
||||
) in
|
||||
let nl_nested = (fun env -> nl_nested_list env f opar l sep cpar) in
|
||||
choice_right env simple nl_nested
|
||||
|
||||
|
||||
let nested_list env f opar l sep cpar last_nl =
|
||||
env.margin <- env.cmargin :: env.margin;
|
||||
print env opar;
|
||||
env.margin <- env.cmargin :: env.margin;
|
||||
list_sep env f (fun env -> print env sep; newline env; spaces env) l;
|
||||
if last_nl
|
||||
then begin
|
||||
print env sep;
|
||||
newline env;
|
||||
pop env;
|
||||
spaces env;
|
||||
print env cpar;
|
||||
end
|
||||
else begin
|
||||
print env cpar;
|
||||
pop env;
|
||||
end;
|
||||
pop env
|
||||
|
||||
let fun_params env f l =
|
||||
let opar = "(" in
|
||||
let sep = "," in
|
||||
let cpar = ")" in
|
||||
let simple = (
|
||||
fun env ->
|
||||
let line = env.line in
|
||||
flat_list env f opar l sep cpar;
|
||||
if line <> env.line then fail();
|
||||
) in
|
||||
let nl_nested = (fun env -> nested_list env f opar l sep cpar true) in
|
||||
choice_right env simple nl_nested
|
||||
|
||||
(*****************************************************************************)
|
||||
(* Parenthesis handling *)
|
||||
(*****************************************************************************)
|
||||
|
||||
let paren prio env f =
|
||||
let old_prio = env.priority in
|
||||
env.priority <- prio;
|
||||
if (prio >= old_prio) || (prio = -1)
|
||||
then f env
|
||||
else begin
|
||||
print env "(";
|
||||
f env;
|
||||
print env ")";
|
||||
end;
|
||||
env.priority <- old_prio
|
||||
|
||||
(*****************************************************************************)
|
||||
(* String helpers *)
|
||||
(*****************************************************************************)
|
||||
(* module PpString = struct *)
|
||||
|
||||
let char_is_space = function
|
||||
| ' ' | '\t' | '\n' | '\r' -> true
|
||||
| _ -> false
|
||||
|
||||
let is_space s i = char_is_space s.[i]
|
||||
|
||||
let rec is_only_space s i =
|
||||
if i >= String.length s
|
||||
then true
|
||||
else is_space s i && is_only_space s (i+1)
|
||||
|
||||
let strip s =
|
||||
let c1 = ref 0 in
|
||||
let c2 = ref (String.length s - 1) in
|
||||
while is_space s !c1 do
|
||||
incr c1;
|
||||
done;
|
||||
while is_space s !c2 do
|
||||
decr c2;
|
||||
done;
|
||||
let c2 = String.length s - 1 - !c2 in
|
||||
String.sub s !c1 (String.length s - !c1 - c2)
|
||||
|
||||
let space = function
|
||||
| ' ' | '\t' -> true
|
||||
| _ -> false
|
||||
|
||||
let rec find_cut x start i =
|
||||
if i < 20
|
||||
then start
|
||||
else if space x.[i]
|
||||
then i
|
||||
else find_cut x start (i-1)
|
||||
|
||||
let rec string quote sep env x =
|
||||
choice_left env (
|
||||
fun env ->
|
||||
print env x
|
||||
) (
|
||||
fun env ->
|
||||
let size = 80 - env.cmargin - String.length sep - 1 in
|
||||
let size = find_cut x size size in
|
||||
let s = String.sub x 0 size in
|
||||
let rest = String.sub x size (String.length x - size) in
|
||||
print env s;
|
||||
print env quote;
|
||||
print env sep;
|
||||
newline env;
|
||||
spaces env;
|
||||
print env quote;
|
||||
string quote sep env rest
|
||||
)
|
||||
|
||||
let string quote sep env x =
|
||||
if env.cmargin >= 20
|
||||
then begin
|
||||
print env quote;
|
||||
print env x;
|
||||
print env quote
|
||||
end
|
||||
else
|
||||
nestc env (
|
||||
fun env ->
|
||||
print env quote;
|
||||
string quote sep env x;
|
||||
print env quote;
|
||||
)
|
||||
|
||||
let first_char_escape env s =
|
||||
if s = "" then 0 else
|
||||
match s.[0] with
|
||||
| 'A' .. 'Z' | 'a' .. 'z' | '&' | ' ' | '\n' | '<' | '>' -> 0
|
||||
| _c ->
|
||||
print env "{'";
|
||||
let size = ref 1 in
|
||||
while !size < String.length s && not (char_is_space s.[!size]) do incr size done;
|
||||
let size = !size in
|
||||
print env (String.sub s 0 size);
|
||||
print env "'}";
|
||||
if size < String.length s then print env " ";
|
||||
size
|
||||
|
||||
let print_text env s =
|
||||
let size = ref (String.length s - 1) in
|
||||
while !size >= 0 && char_is_space s.[!size] do
|
||||
decr size;
|
||||
done;
|
||||
let size = !size in
|
||||
let buf = Buffer.create 80 in
|
||||
let last_is_space = ref true in
|
||||
nestc env (
|
||||
fun env ->
|
||||
let i = first_char_escape env s in
|
||||
for i = i to size do
|
||||
if Common2.is_space s.[i]
|
||||
then
|
||||
if !last_is_space
|
||||
then ()
|
||||
else begin
|
||||
last_is_space := true;
|
||||
print env (Buffer.contents buf);
|
||||
Buffer.clear buf;
|
||||
space_or_nl env;
|
||||
end
|
||||
else (last_is_space := false; Buffer.add_char buf s.[i])
|
||||
done;
|
||||
print env (Buffer.contents buf);
|
||||
Buffer.clear buf;
|
||||
)
|
||||
Loading…
Add table
Add a link
Reference in a new issue