Skip to content

GitLab

Commit b50962d5 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-05-19 20:30:05 by cvscast] Improve pretty-printer 

Original author: cvscast
Date: 2003-05-19 20:30:05+00:00
parent 298c4872
Hide whitespace changes
Inline Side-by-side
misc/pretty.ml
View file @ b50962d5
......@@ -4,32 +4,148 @@ type 'a regexp =
| Seq of 'a regexp * 'a regexp
| Alt of 'a regexp * 'a regexp
| Star of 'a regexp
| Plus of 'a regexp
| Trans of 'a
module Decompile(H : Hashtbl.S) = struct
let alt s1 s2 = match (s1,s2) with
| Empty,s | s,Empty -> s2
| (s1,s2) -> Alt (s1,s2)
type 'a re =
| RSeq of 'a re list
| RAlt of 'a re list
| RTrans of 'a
| RStar of 'a re
let star = function
| Empty | Epsilon -> Epsilon
| Star _ as s -> s
| s -> Star s
| RPlus of 'a re
module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct
let rec compare s1 s2 =
if s1 == s2 then 0
else match (s1,s2) with
| RSeq x, RSeq y | RAlt x, RAlt y -> compare_list x y
| RSeq _, _ -> -1 | _, RSeq _ -> 1
| RAlt _, _ -> -1 | _, RAlt _ -> 1
| RTrans x, RTrans y -> S.compare x y
| RTrans _, _ -> -1 | _, RTrans _ -> 1
| RStar x, RStar y | RPlus x, RPlus y -> compare x y
| RStar _, _ -> -1 | _, RStar _ -> 1
and compare_list l1 l2 = match (l1,l2) with
| x1::y1, x2::y2 ->
let c = compare x1 x2 in if c = 0 then compare_list y1 y2 else c
| [], [] -> 0
| [], _ -> -1 | _, [] -> 1
let rec dump ppf = function
| RSeq l -> Format.fprintf ppf "Seq(%a)" dump_list l
| RAlt l -> Format.fprintf ppf "Alt(%a)" dump_list l
| RStar r -> Format.fprintf ppf "Star(%a)" dump r
| RPlus r -> Format.fprintf ppf "Plus(%a)" dump r
| RTrans x -> Format.fprintf ppf "Trans"
and dump_list ppf = function
| [] -> ()
| [h] -> Format.fprintf ppf "%a" dump h
| h::t -> Format.fprintf ppf "%a,%a" dump h dump_list t
let rec factor accu l1 l2 = match (l1,l2) with
| (x1::y1,x2::y2) when compare x1 x2 = 0 -> factor (x1::accu) y1 y2
| (l1,l2) -> (accu,l1,l2)
let rec regexp = function
| RSeq l ->
let rec aux = function
| [h] -> regexp h
| h::t -> Seq (regexp h,aux t)
| [] -> Epsilon in
aux l
| RAlt l ->
let rec aux = function
| [h] -> regexp h
| h::t -> Alt (regexp h,aux t)
| [] -> Empty in
aux l
| RTrans x -> Trans x
| RStar r -> Star (regexp r)
| RPlus r -> Plus (regexp r)
let epsilon = RSeq []
let empty = RAlt []
let rec nullable = function
| RAlt l -> List.exists nullable l
| RSeq l -> List.for_all nullable l
| RPlus r -> nullable r
| RStar _ -> true
| RTrans _ -> false
let has_epsilon =
List.exists (function RSeq [] -> true | _ -> false)
let rec seq s1 s2 = match (s1,s2) with
| Empty,_ | _,Empty -> Empty
| Epsilon,s | s,Epsilon -> s
| Seq (a,b),s2 -> Seq (a, seq b s2)
| (s1,s2) -> Seq (s1,s2)
let remove_epsilon =
List.filter (function RSeq [] -> false | _ -> true)
let rec merge l1 l2 = match (l1,l2) with
| x1::y1, x2::y2 ->
let c = compare x1 x2 in
if c = 0 then x1::(merge y1 y2)
else if c < 0 then x1::(merge y1 l2)
else x2::(merge l1 y2)
| [], l | l,[] -> l
let rec absorb_epsilon = function
| RPlus r :: l -> RStar r :: l
| (r :: _) as l when nullable r -> l
| r :: l -> r :: (absorb_epsilon l)
| [] -> [ epsilon ]
let alt s1 s2 =
let s1 = match s1 with RAlt x -> x | x -> [x] in
let s2 = match s2 with RAlt x -> x | x -> [x] in
let l = merge s1 s2 in
let l =
if has_epsilon l
then absorb_epsilon (remove_epsilon l)
else l in
match l with
| [x] -> x
| l -> RAlt l
let rec seq s1 s2 =
match (s1,s2) with
| RAlt [], _ | _, RAlt [] -> epsilon
| RSeq [], x | x, RSeq [] -> x
| _ ->
let s1 = match s1 with RSeq x -> x | x -> [x] in
let s2 = match s2 with RSeq x -> x | x -> [x] in
find_plus [] (s1 @ s2)
and find_plus before = function
| [] -> (match before with [h] -> h | l -> RSeq (List.rev l))
| (RStar s)::after ->
let star = match s with RSeq x -> x | x -> [x] in
let (right,star',after') = factor [] star after in
let (left,star'',before') = factor [] (List.rev star') before in
(match star'' with
| [] ->
let s = find_plus [] (left @ (List.rev right)) in
find_plus ((RPlus s)::before') after'
| _ ->
find_plus ((RStar s)::before) after)
| x::after -> find_plus (x::before) after
let star = function
| RAlt [] | RSeq [] -> epsilon
| RStar _ as s -> s
| s -> RStar s
type 'a slot = {
mutable weight : int;
mutable outg : ('a slot * 'a regexp) list;
mutable inc : ('a slot * 'a regexp) list;
mutable self : 'a regexp;
mutable outg : ('a slot * 'a re) list;
mutable inc : ('a slot * 'a re) list;
mutable self : 'a re;
mutable ok : bool
}
let empty () = { weight = 0; outg = []; inc = []; self = Empty; ok = false }
let alloc_slot () =
{ weight = 0; outg = []; inc = []; self = empty; ok = false }
let decompile trans n0 =
let slot_table = H.create 121 in
......@@ -37,7 +153,7 @@ module Decompile(H : Hashtbl.S) = struct
let slot n =
try H.find slot_table n
with Not_found ->
let s = empty () in
let s = alloc_slot () in
H.add slot_table n s;
slots := s :: !slots;
s in
......@@ -47,16 +163,16 @@ module Decompile(H : Hashtbl.S) = struct
then s1.self <- alt s1.self t
else (s1.outg <- (s2,t) :: s1.outg; s2.inc <- (s1,t) :: s2.inc) in
let final = empty () in
let initial = empty () in
let final = alloc_slot () in
let initial = alloc_slot () in
let rec conv n =
let s = slot n in
if not s.ok then (
s.ok <- true;
let (tr,f) = trans n in
if f then add_trans s final Epsilon;
List.iter (fun (l,dst) -> add_trans s (conv dst) (Trans l)) tr;
if f then add_trans s final epsilon;
List.iter (fun (l,dst) -> add_trans s (conv dst) (RTrans l)) tr;
);
s in
......@@ -71,14 +187,17 @@ module Decompile(H : Hashtbl.S) = struct
s.outg
) s.inc in
add_trans initial (conv n0) Epsilon;
add_trans initial (conv n0) epsilon;
List.iter
(fun s -> s.weight <- List.length s.inc * List.length s.outg)
!slots;
let slots = List.sort (fun s1 s2 -> compare s1.weight s2.weight) !slots in
let slots =
List.sort (fun s1 s2 -> Pervasives.compare s1.weight s2.weight) !slots in
List.iter elim slots;
List.fold_left
(fun accu (s,t) -> if s == final then alt accu t else accu)
Empty
initial.outg
let r =
List.fold_left
(fun accu (s,t) -> if s == final then alt accu t else accu)
empty
initial.outg in
regexp r
end
misc/pretty.mli
View file @ b50962d5
......@@ -6,8 +6,10 @@ type 'a regexp =
| Seq of 'a regexp * 'a regexp
| Alt of 'a regexp * 'a regexp
| Star of 'a regexp
| Plus of 'a regexp
| Trans of 'a
module Decompile(H : Hashtbl.S) : sig
val decompile: (H.key -> ('a * H.key) list * bool) -> H.key -> 'a regexp
module Decompile(H : Hashtbl.S)(S : Set.OrderedType)
: sig
val decompile: (H.key -> (S.t * H.key) list * bool) -> H.key -> S.t regexp
end
types/types.ml
View file @ b50962d5
......@@ -951,9 +951,11 @@ struct
(n, d)
let is_regexp t = subtype t seqs_descr
module Decompile = Pretty.Decompile(DescrHash)
type t = { mutable def : d list; mutable name : string option }
module S = struct
type t = { id : int;
mutable def : d list;
mutable state : [ `Expand | `None | `Marked | `Named of string ] }
and d =
| Name of string
| Regexp of t Pretty.regexp
......@@ -964,6 +966,10 @@ struct
| Record of (bool * t) label_map * bool * bool
| Arrows of (t * t) list * (t * t) list
| Neg of t
let compare x y = x.id - y.id
end
module Decompile = Pretty.Decompile(DescrHash)(S)
open S
module DescrPairMap =
Map.Make(
......@@ -985,7 +991,8 @@ struct
named := DescrMap.add d name !named
let memo = DescrHash.create 63
let empty_t = { def = []; name = None }
let counter = ref 0
let alloc def = { id = (incr counter; !counter); def = def; state = `None }
let count_name = ref 0
let name () =
......@@ -994,7 +1001,9 @@ struct
let to_print = ref []
let trivial_rec b = b == BoolRec.empty || (is_empty { empty with record = BoolRec.diff BoolRec.full b})
let trivial_rec b =
b == BoolRec.empty ||
(is_empty { empty with record = BoolRec.diff BoolRec.full b})
let trivial_pair b = b == BoolPair.empty || b == BoolPair.full
......@@ -1014,27 +1023,22 @@ struct
aux BoolRec.compare d.record any.record in
n >= 4
let rec prepare d =
try
let slot = DescrHash.find memo d in
if (slot.name == None) then
(let n = name () in
slot.name <- Some n;
to_print := (n,slot) :: !to_print);
slot
try DescrHash.find memo d
with Not_found ->
try
let n = DescrMap.find d !named in
let s = { name = Some n; def = [] } in
let s = alloc [] in
s.state <- `Named n;
DescrHash.add memo d s;
s
with Not_found ->
if worth_complement d then
{ empty_t with def = [Neg (prepare (neg d))] }
alloc [Neg (prepare (neg d))]
else
let slot = { empty_t with def = [] } in
if worth_abbrev d then DescrHash.add memo d slot;
let slot = alloc [] in
if not (worth_abbrev d) then slot.state <- `Expand;
DescrHash.add memo d slot;
let (seq,not_seq) =
if (subtype { empty with times = d.times } seqs_descr) then
(cap d seqs_descr, diff d seqs_descr)
......@@ -1095,10 +1099,38 @@ struct
tr, Atoms.contains nil_atom t.atoms)
d
let rec assign_name s =
match s.state with
| `None -> s.state <- `Marked; List.iter assign_name_rec s.def
| `Marked -> s.state <- `Named (name ()); to_print := s :: !to_print
| _ -> ()
and assign_name_rec = function
| Neg t -> assign_name t
| Name _ | Char _ | Atomic _ -> ()
| Regexp r -> assign_name_regexp r
| Pair (t1,t2) -> assign_name t1; assign_name t2
| Xml (tag,t2,t3) ->
(match tag with `Type t -> assign_name t | _ -> ());
assign_name t2;
assign_name t3
| Record (r,_,_) ->
List.iter (fun (_,(_,t)) -> assign_name t) (LabelMap.get r)
| Arrows (p,n) ->
List.iter (fun (t1,t2) -> assign_name t1; assign_name t2) p;
List.iter (fun (t1,t2) -> assign_name t1; assign_name t2) n
and assign_name_regexp = function
| Pretty.Epsilon | Pretty.Empty -> ()
| Pretty.Alt (r1,r2)
| Pretty.Seq (r1,r2) -> assign_name_regexp r1; assign_name_regexp r2
| Pretty.Star r | Pretty.Plus r -> assign_name_regexp r
| Pretty.Trans t -> assign_name t
let rec do_print_slot pri ppf s =
match s.name with
| None -> do_print_slot_real pri ppf s.def
| Some n -> Format.fprintf ppf "%s" n
match s.state with
| `Named n -> Format.fprintf ppf "%s" n
| `None -> assert false
| `Expand | `Marked ->
do_print_slot_real pri ppf s.def
and do_print_slot_real pri ppf def =
let rec aux ppf = function
| [] -> Format.fprintf ppf "Empty"
......@@ -1118,11 +1150,11 @@ struct
Format.fprintf ppf "@[(%a,%a)@]"
(do_print_slot 0) t1
(do_print_slot 0) t2
| Xml (tag,t2,t3) ->
| Xml (tag,attr,t) ->
Format.fprintf ppf "<%a%a>%a"
do_print_tag tag
do_print_attr t2
(do_print_slot 0) t3
do_print_attr attr
(do_print_slot 0) t
| Record (r,some,none) ->
if some then Format.fprintf ppf "@[{"
else Format.fprintf ppf "@[{|";
......@@ -1151,7 +1183,8 @@ struct
| `Tag s -> Format.fprintf ppf "%s" s
| `Type t -> Format.fprintf ppf "(%a)" (do_print_slot 0) t
and do_print_attr ppf = function
| { name = None; def = [ Record (r,true,true) ] } -> do_print_record ppf r
| { state = `Marked|`Expand;
def = [ Record (r,true,true) ] } -> do_print_record ppf r
| t -> Format.fprintf ppf " %a" (do_print_slot 2) t
and do_print_record ppf r =
let first = ref true in
......@@ -1163,13 +1196,9 @@ struct
(LabelPool.value l) opt (do_print_slot 0) t
) (LabelMap.get r)
and do_print_regexp pri ppf = function
| Pretty.Empty -> assert false
| Pretty.Empty -> Format.fprintf ppf "Empty" (*assert false *)
| Pretty.Epsilon -> ()
| Pretty.Seq (Pretty.Trans t1,Pretty.Star (Pretty.Trans t2))
| Pretty.Seq (Pretty.Star (Pretty.Trans t1),Pretty.Trans t2)
when t1 == t2 ->
Format.fprintf ppf "@[%a@]+" (do_print_slot 3) t1
| Pretty.Seq (Pretty.Trans { name = None; def = [ Char _ ] }, _) as r->
| Pretty.Seq (Pretty.Trans { def = [ Char _ ] }, _) as r->
(match extract_string [] r with
| s, None ->
Format.fprintf ppf "'";
......@@ -1197,28 +1226,36 @@ struct
if pri >= 2 then Format.fprintf ppf ")@]"
| Pretty.Star r ->
Format.fprintf ppf "@[%a@]*" (do_print_regexp 3) r
| Pretty.Plus r ->
Format.fprintf ppf "@[%a@]+" (do_print_regexp 3) r
| Pretty.Trans t ->
do_print_slot pri ppf t
and extract_string accu = function
| Pretty.Seq (Pretty.Trans { name = None; def = [ Char c ] }, r) ->
| Pretty.Seq (Pretty.Trans { def = [ Char c ] }, r) ->
extract_string (c :: accu) r
| Pretty.Trans { name = None; def = [ Char c ] } ->
| Pretty.Trans { def = [ Char c ] } ->
(List.rev (c :: accu), None)
| r -> (List.rev accu,Some r)
let get_name = function
| { state = `Named n } -> n
| _ -> assert false
let print ppf d =
let t = prepare d in
assign_name t;
Format.fprintf ppf "@[@[%a@]" (do_print_slot 0) t;
(match List.rev !to_print with
| [] -> ()
| (n,s)::t ->
| s::t ->
Format.fprintf ppf
" where@ @[<v>%s = @[%a@]" n (do_print_slot_real 0) s.def;
" where@ @[<v>%s = @[%a@]" (get_name s)
(do_print_slot_real 0) s.def;
List.iter
(fun (n,s) ->
(fun s ->
Format.fprintf ppf " and@ %s = @[%a@]"
n (do_print_slot_real 0) s.def)
(get_name s) (do_print_slot_real 0) s.def)
t;
Format.fprintf ppf "@]"
);
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment