patterns.ml

type capture = string
type fv = capture SortedList.t

exception IllFormedCup of fv * fv
exception IllFormedCap of fv * fv

(* Syntactic algebra *)

type d =
  | Constr of Types.node
  | Cup of descr * descr
  | Cap of descr * descr
  | Times of node * node
  | Record of Types.label * node
  | Capture of capture
  | Constant of capture * Types.const
and node = {
  id : int;
  mutable descr : descr option;
  accept : Types.node;
  fv : fv
} and descr = Types.descr * fv * d

let make =
  let counter = ref 0 in
  fun fv ->
    incr counter;
    { id = !counter; descr = None; accept = Types.make (); fv = fv }

let define x ((accept,fv,_) as d) =
  assert (x.fv = fv);
  Types.define x.accept accept;
  x.descr <- Some d

let constr x = (Types.descr x,[],Constr x)
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
  if fv1 <> fv2 then raise (IllFormedCup (fv1,fv2));
  (Types.cup acc1 acc2, SortedList.cup fv1 fv2, Cup (x1,x2))
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
  if not (SortedList.disjoint fv1 fv2) then raise (IllFormedCap (fv1,fv2));
  (Types.cap acc1 acc2, SortedList.cup fv1 fv2, Cap (x1,x2))
let times x y =
  (Types.times x.accept y.accept, SortedList.cup x.fv y.fv, Times (x,y))
let record l x = 
  (Types.record l false x.accept, x.fv, Record (l,x))
let capture x = (Types.any, [x], Capture x)
let constant x c = (Types.any, [x], Constant (x,c))


let id x = x.id
let descr x = match x.descr with Some d -> d | None -> failwith "Patterns.descr"
let fv x = x.fv
let accept x = Types.internalize x.accept


(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
let empty_res fv = List.map (fun v -> (v, Types.Positive.ty Types.empty)) fv
let times_res v1 v2 = Types.Positive.times v1 v2

module MemoFilter = Map.Make 
  (struct type t = Types.descr * node let compare = compare end)

let memo_filter = ref MemoFilter.empty

let rec filter_descr t (_,fv,d) : (capture, Types.Positive.v) SortedMap.t =
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
      | Constr _ -> []
      | Cup ((a,_,_) as d1,d2) ->
	  SortedMap.union cup_res
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
      | Cap (d1,d2) ->
	  SortedMap.union cup_res (filter_descr t d1) (filter_descr t d2)
      | Times (p1,p2) ->
	  List.fold_left 
	    (fun accu (d1,d2) ->
	       let term = 
		 SortedMap.union times_res 
		   (filter_node d1 p1) 
		   (filter_node d2 p2)
	       in
	       SortedMap.union cup_res accu term
	    )
	    (empty_res fv)
	    (Types.Product.normal t)
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
	  [(c, Types.Positive.ty t)]
      | Constant (c, cst) ->
	  [(c, Types.Positive.ty (Types.constant cst))]

and filter_node t p : (capture, Types.Positive.v) SortedMap.t =
  try MemoFilter.find (t,p) !memo_filter
  with Not_found ->
    let (_,fv,_) as d = descr p in
    let res = List.map (fun v -> (v,Types.Positive.forward ())) fv in
    memo_filter := MemoFilter.add (t,p) res !memo_filter;
    let r = filter_descr t (descr p) in
    List.iter2 (fun (_,r) (_,v) -> Types.Positive.define v r) r res;
    r

let filter t p =
  let r = filter_node t p in
  memo_filter :=  MemoFilter.empty;
  List.map (fun (c,v) -> (c,Types.Positive.solve v)) r



(* Normal forms for patterns and compilation *)

module NF = 
struct

  type 'a sl = 'a SortedList.t
  type ('a,'b) sm = ('a,'b) SortedMap.t

  type source = 
      [ `Catch | `Const of Types.const 
      | `Left | `Right | `Recompose 
      | `Field of Types.label 
      ]
  type result = (capture, source) sm

  type 'a line = (result * 'a, Types.descr) sm
  type nf = {
    v     : fv;
    a     : Types.descr;
    basic : unit line;
    prod  : (node sl * node sl) line;
    record: ((Types.label, node sl) sm) line
  }

  type 'a nline = (result *  'a) list
  type record =
      [ `Success
      | `Fail
      | `Dispatch of (nf * record) list
      | `Label of Types.label * (nf * record) list * record ]
  type normal = {
    nbasic : Types.descr nline;
    nprod  : (nf * nf) nline;
    nrecord: record nline
  }

  let empty = { v = []; a = Types.empty; basic = []; prod = []; record = [] }
  let any_basic = Types.neg (Types.cup Types.Product.any Types.Record.any)


  let restrict t nf =
    let rec filter = function
      | (key,acc) :: rem -> 
	  let acc = Types.cap t acc in
	  if Types.is_empty acc then filter rem else (key,acc) :: (filter rem)
      | [] -> []
    in
    {  v = nf.v;
       a = Types.cap t nf.a;
       basic = filter nf.basic;
       prod = filter nf.prod;
       record = filter nf.record;
    }

  let fus = SortedMap.union_disj
  let slcup = SortedList.cup

  let cap nf1 nf2 =
    let merge f lines1 lines2 =
      let m =
	List.fold_left 
	  (fun accu ((res1,x1),acc1) ->
	     List.fold_left
	     (fun accu ((res2,x2),acc2) ->
		let acc = Types.cap acc1 acc2 in
		if Types.is_empty acc then accu
		else ((fus res1 res2, f x1 x2),acc) :: accu
	     ) accu lines2
	  ) [] lines1 in
      SortedMap.from_list Types.cup m
    in
    let merge_basic () () = ()
    and merge_prod (p1,q1) (p2,q2) = slcup p1 p1, slcup q1 q2
    and merge_record r1 r2 = SortedMap.union slcup r1 r2 in
    { v = SortedList.cup nf1.v nf2.v;
      a = Types.cap nf1.a nf2.a;
      basic = merge merge_basic nf1.basic nf2.basic;
      prod = merge merge_prod nf1.prod nf2.prod;
      record = merge merge_record nf1.record nf2.record;
    }


		  
  let cup acc1 nf1 nf2 =
    let nf2 = restrict (Types.neg acc1) nf2 in
    { v = nf1.v; (* = nf2.v *)
      a = Types.cup nf1.a nf2.a;
      basic = SortedMap.union Types.cup nf1.basic nf2.basic;
      prod  = SortedMap.union Types.cup nf1.prod nf2.prod;
      record = SortedMap.union Types.cup nf1.record nf2.record;
    }

  let times acc p q = 
    let src_p = List.map (fun v -> (v,`Left)) p.fv
    and src_q = List.map (fun v -> (v,`Right)) q.fv in
    let src = SortedMap.union (fun _ _ -> `Recompose) src_p src_q in 
    { empty with 
	v = SortedList.cup p.fv q.fv; 
	a = acc;
	prod = [ (src, ([p], [q])), acc ] }

  let record acc l p =
    let src = List.map (fun v -> (v, `Field l)) p.fv in
    { empty with
	v = p.fv;
	a = acc;
	record = [ (src, [l,[p]]), acc ] }

  let any =
    { v = [];
      a = Types.any;
      basic = [ ([],()), any_basic ]; 
      prod  = [ ([],([],[])), Types.Product.any ];
      record = [ ([],[]), Types.Record.any ];
    }

  let capture x =
    let l = [x,`Catch] in
    { v = [x];
      a = Types.any;
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
      record = [ (l,[]), Types.Record.any ];
    }

  let constant x c =
    let l = [x,`Const c] in
    { v = [x];
      a = Types.any;
      basic = [ (l,()), any_basic ]; 
      prod  = [ (l,([],[])), Types.Product.any  ];
      record = [ (l,[]), Types.Record.any ];
    }

  let constr t =
    { v = [];
      a = t;
      basic = [ ([],()), Types.cap t any_basic ];
      prod  = [ ([],([],[])), Types.cap t Types.Product.any ];
      record = [ ([],[]), Types.cap t Types.Record.any ];
    }

(* Put a pattern in normal form *)
  let rec nf (acc,fv,d) =
    if Types.is_empty acc 
    then empty
    else match d with
      | Constr t -> constr (Types.descr t)
      | Cap (p,q) -> cap (nf p) (nf q)
      | Cup ((acc1,_,_) as p,q) -> cup acc1 (nf p) (nf q)
      | Times (p,q) -> times acc p q
      | Capture x -> capture x
      | Constant (x,c) -> constant x c
      | Record (l,p) -> record acc l p

  let bigcap = List.fold_left (fun a p -> cap a (nf (descr p))) any

  let rec num i = function [] -> [] | h::t -> (h,i)::(num (i+1) t)


  module Dispatch = struct
    type t = { 
      fv    : fv list;
      masks : (mask * int) list;
      basic : (Types.descr * (result option list)) list;
      prod  : prod;
      record: record option;
    }
    and prod = disp * (mask * disp * (mask * prod_result) list) list 
    and prod_result = (result * (int * int)) option list

    and record = 
	[ `Label of Types.label * disp * (mask * record) list * record option
	| `Result of record_result ]
    and record_result = (result * (Types.label * int) list) option list

    and mask = bool list
    and disp = Types.descr * nf SortedList.t
  end

  let normal nf =
    let basic =
      List.map (fun ((res,()),acc) -> (res,acc)) 

    and prod =
      let line accu (((res,(pl,ql)),acc)) =
	let p = bigcap pl and q = bigcap ql in
	let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in
	List.fold_left aux accu (Types.Product.normal acc) in
      List.fold_left line []

    and record =
      let rec aux nr fields = 
	match (nr,fields) with
	  | (`Success, []) -> `Success
	  | (`Fail,_) -> `Fail
	  | (`Success, (l2,pl)::fields) ->
	      `Label (l2, [bigcap pl, aux nr fields], `Fail)
	  | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
	      `Label (l2, [bigcap pl, aux nr fields], `Fail)
	  | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
	      let p = bigcap pl in
	      let pr = 
		List.map (fun (t,x) -> (restrict t p, aux x fields)) pr in
	      `Label (l1, pr, `Fail)
	  | (`Label (l1, pr, ab),_) ->
	      let pr = 
		List.map (fun (t,x) -> (constr t, aux x fields)) pr in
	      `Label (l1, pr, aux ab fields)
      in

      let line accu ((res,fields),acc) =
	let nr = Types.Record.normal acc in
	let x = aux nr fields in
	match x with 
	  | `Fail -> accu 
	  | x -> (res,x) :: accu in
      List.fold_left line []
    in
    { nbasic  = basic nf.basic;
      nprod   = prod nf.prod;
      nrecord = record nf.record;
    }

  let collect f pp =
    let aux accu (res,x) = (f x) :: accu in
    SortedList.from_list (List.fold_left (List.fold_left aux) [] pp)

  let rec map_map f = function 
    | [] -> [] 
    | x::l -> 
	try let y = f x in y::(map_map f l)
	with Not_found -> map_map f l

  let get_option = function [x] -> Some x | [] -> None | _ -> assert false
  let extract_unique f l = get_option (map_map f l)
(* Could optimize to extract directly the first (and single) *)

(* Basic (and arrow) types *)

  let filter_basic ty =
    let aux (k,t) = if Types.subtype ty t then k else raise Not_found in
    List.map (extract_unique aux)
   
  let dispatch_basic t pl =
    let rec aux pl accu t l = 
      if Types.is_empty t then accu 
      else match l with
	| [] ->
	    let pl = filter_basic t pl in
	    (t, pl) :: accu
	| ty :: rem ->
	    let accu = aux pl accu (Types.cap t ty) rem in
	    let accu = aux pl accu (Types.diff t ty) rem in
	    accu
    in
    let pl = List.map (fun p -> p.nbasic) pl in
    let tests = collect (fun x -> x) pl in
    let t = Types.cap any_basic t in
    aux pl [] t tests

(* Product types *)

  let filter_prod1 success =
    let aux (res,(p,q)) = (res,(List.assoc p success,q)) in
    List.map (map_map aux)

  let filter_prod2 success =
    let aux (res,(i,q)) = (res,(i,List.assoc q success)) in
    List.map (extract_unique aux)

  let rec dispatch_prod t pl =
    let pl = List.map (fun p -> p.nprod) pl in
    let tests = collect (fun (p,_) -> p) pl in
    let t = Types.Product.get t in
    let disp = aux_prod1 t pl [] [] [] 0 tests in
    let pi1 = Types.Product.pi1 t in
    ((pi1,tests),disp)

  and aux_prod2 t pl accu mask success j tests = 
    if Types.is_empty t then accu 
    else match tests with
      | [] ->
	  let pl = filter_prod2 success pl in
	  (List.rev mask, pl) :: accu
      | p :: rem -> 
	  let accu =
	    let t = Types.cap t p.a in
	    aux_prod2 t pl accu (true::mask) ((p,j)::success) (j+1) rem in
	  let accu =
	    let t = Types.diff t p.a in
	    aux_prod2 t pl accu (false::mask) success (j+1) rem in
	  accu

  and aux_prod1 t pl accu mask success i tests =
    if t = [] then accu 
    else match tests with
      | [] ->
	  let pl = filter_prod1 success pl in
	  let t = Types.Product.pi2 t in
	  let tests = collect (fun (_,q)-> q) pl in
	  let disp = aux_prod2 t pl [] [] [] 0 tests in
	  let mask = List.rev mask in
	  (mask, (t,tests), disp) :: accu
      | p :: rem ->
	  let accu = 
	    let t = Types.Product.restrict_1 t p.a in
	    aux_prod1 t pl accu (true::mask) ((p,i)::success) (i+1) rem in
	  let accu =
	    let t = Types.Product.restrict_1 t (Types.neg p.a) in
	    aux_prod1 t pl accu (false::mask) success (i+1) rem in
	  accu

(* Record types *)


  let map_record f = 
    let rec aux = function
      | [] -> []
      | h::t -> (match f h with (_,_,`Fail) -> aux t | x -> x :: (aux t)) in
    List.map aux

  let label_found l = 
    map_record 
      (function
	 | (res, catch, `Label (l1, pr, _)) when l1 = l -> 
	     (res, catch, `Dispatch pr)
	 | x -> x)

  let label_disp l success =
    map_record
      (function
	 | (res, catch, `Dispatch disp) ->
	     let aux (p,rem) = (List.assoc p success, rem) in
	     (match extract_unique aux disp with
		| None -> (res, catch, `Fail)
		| Some (i,rem) -> (res, (l, i)::catch, rem))
	 | x -> x)

  let label_not_found l = 
    map_record 
      (function
	 | (res, catch, `Label (l1, _, ab)) when l1 = l -> (res, catch, ab)
	 | x -> x)


  let dummy_label = Types.label ""

  let collect_first_label pp =
    let f = ref true and m = ref dummy_label in
    let aux = function
      | (_, _, `Label (l, _, _)) ->
	  if (!f) then (f := false; m := l) else if (l < !m) then m:= l;
      | _ -> () in
    List.iter (List.iter aux) pp;
    if !f then None else Some !m

  let collect_record pp =
    let aux accu = function
      | (res,catch,`Dispatch disp) ->  
	  List.fold_left (fun accu (p,_) -> p :: accu) accu disp
      | _ -> accu in
    SortedList.from_list (List.fold_left (List.fold_left aux) [] pp)

  let final_record =
    let aux = function
      | [(res, catch, `Success)] -> Some (res, catch)
      | [] -> None
      | _ -> assert false in
    List.map aux

(* combiner les restrict field, ... *)
  let rec dispatch_record t pl =
    let pl = List.map 
	       (fun p -> List.map (fun (res,r) -> (res,[],r)) p.nrecord
	       ) pl in
    let t = Types.Record.get t in
    if Types.Record.is_empty t then None else Some (aux_record1 t pl)

  and aux_record1 t pl =
    match collect_first_label pl with
      | None -> `Result (final_record pl)
      | Some l ->
	  let (disp,pr) = 
	    let pl = label_found l pl in
	    let tests = collect_record pl in
	    let t = Types.Record.restrict_label_present t l in
	    let disp = aux_record2 t pl l [] [] [] 0 tests in
	    ((Types.Record.project_field t l, tests),disp)
	  in
	  let ab = 
	    let pl = label_not_found l pl in
	    let t = Types.Record.restrict_label_absent t l in
	    if Types.Record.is_empty t then None 
	    else Some (aux_record1 t pl)
	  in
	  `Label (l, disp, pr, ab)
	    
  and aux_record2 t pl l accu mask success i tests =
    if Types.Record.is_empty t then accu
    else match tests with
      | [] ->
	  let pl = label_disp l success pl in
	  let disp = aux_record1 t pl in
	  (List.rev mask, disp) :: accu
      | p :: rem ->
	  let accu =
	    let t = Types.Record.restrict_field t l p.a in
	    aux_record2 t pl l accu (true::mask) ((p,i)::success) (i+1) rem in
	  let accu =
	    let t = Types.Record.restrict_field t l (Types.neg p.a) in
	    aux_record2 t pl l accu (false::mask) success (i+1) rem in
	  accu

  let mask l = List.map (function None -> false | Some _ -> true) l

  let rec dispatch (t : Types.descr) (pl : nf list) =
    let fv = List.map (fun p -> p.v) pl in
    let pl = List.map (fun p -> normal (restrict t p)) pl in
    let basic = dispatch_basic t pl
    and prod = dispatch_prod t pl 
    and record = dispatch_record t pl in

    let masks =
      let accu = ref [] in
      let acc r = accu := (mask r) :: !accu in
      List.iter (fun (_,r) -> acc r) basic;
      List.iter (fun (_,_,l) -> List.iter (fun (_,r) -> acc r) l) (snd prod);
      num 0 (SortedList.from_list !accu) in

    { 
      Dispatch.fv = fv;
      Dispatch.masks = masks;
      Dispatch.basic = basic;
      Dispatch.prod = prod;
      Dispatch.record = record;
    }


  let to_print = ref []
  let memo = ref []
  let count = ref 0

  let print_fv ppf fv =
    List.iter (fun x -> Format.fprintf ppf "{%s}" x) fv

  let res_basic x = function
    | `Catch -> "v"
    | `Const c -> "const"
    | _ -> assert false

  let res_prod i j x res = 
    match res with
      | `Left -> Printf.sprintf "l%i_%s" i x
      | `Right -> Printf.sprintf "r%i_%s" j x
      | `Recompose -> Printf.sprintf "(l%i_%s,r%i_%s)" i x j x
      | _ -> res_basic x res

  let res_record m x res = 
    match res with
      | `Field l -> 
	  Printf.sprintf "f%s_%i_%s" (Types.label_name l) (List.assoc l m) x
      | _ -> res_basic x res


  let print_mask ppf =
    List.iter (fun b -> Format.fprintf ppf "%i" (if b then 1 else 0))

  let compute_vars mask pl =
    List.fold_right2
      (fun (b,i) p acc -> 
	 if b then List.fold_right (fun v acc -> (i,v)::acc) p.v acc
	 else acc
      )
      (num 0 mask) pl []

  let compute_result f result =
    List.fold_right
      (function
	 | None -> (fun acc -> acc)
	 | Some x ->
	     let (r,res) = f x in
	     List.fold_right (fun (x,s) acc -> res x s :: acc) r
      )
      result []

  let print_success ppf (mask,pl,pr) =
    let vars = 
      let v = compute_vars mask pl in
      if v = [] then "" else
	let v = List.map (fun (i,v) -> Format.sprintf "%s%i_%s" pr i v) v in
	" (" ^ String.concat ", " v ^ ")" in
    Format.fprintf ppf "`S%a%s" print_mask mask vars

  let print_result f ppf result =
    let res = compute_result f result in
    let res = if res = [] then "" else " (" ^ String.concat ", " res ^ ")" in
    Format.fprintf ppf "`S%a%s" print_mask (mask result) res


  let no t pl = 
    try List.assoc (t,pl) !memo 
    with Not_found ->
      incr count;
      let d = dispatch t pl in
      memo := ((t,pl),!count) :: !memo;
      to_print := (!count, d) :: !to_print;
      !count

  let rec show ppf num d =
    Format.fprintf ppf "let matcher_%i v = match v with@\n" num;
    show_basic ppf d.Dispatch.basic;
    show_prod ppf d.Dispatch.prod;
    show_record ppf d.Dispatch.record;
    Format.fprintf ppf "@\n"

  and show_basic ppf =
    let pr_basic ppf t =
      if Types.subtype any_basic t then Format.fprintf ppf "AnyBasic"
      else Types.Print.print_descr ppf t in
    let case (t,result) = 
      Format.fprintf ppf "  | @[%a@] -> %a@\n" 
	pr_basic t
	(print_result (fun res -> (res,res_basic))) result in
    List.iter case
      
  and show_prod ppf = function
    | (_, []) -> ()
    | ((t1,pl1), cases1) ->
	Format.fprintf ppf 
	"  | (v1,v2) -> match matcher_%i v1 with@\n" (no t1 pl1);
	List.iter (case_prod1 ppf pl1) cases1
  and case_prod2 ppf pl2 (mask2, result) =
    Format.fprintf ppf "          | %a -> %a@\n" 
      print_success (mask2,pl2,"r")
      (print_result (fun (res,(i,j)) -> (res,res_prod i j))) result
  and case_prod1 ppf pl1 (mask1, (t2,pl2), cases2) =
    Format.fprintf ppf "      | %a -> match matcher_%i v2 with@\n" 
      print_success (mask1,pl1,"l")
      (no t2 pl2);
    List.iter (case_prod2 ppf pl2) cases2

  and show_record ppf = function
    | None -> ()
    | Some r ->
	Format.fprintf ppf "  | Record r -> @\n";
	Format.fprintf ppf "     @[%a@]@\n" show_record_aux r

  and show_record_aux ppf = function
    | `Result r  ->
	print_result (fun (res,m) -> (res, res_record m)) ppf r
    | `Label (l, (t,pl), cases, ab) -> 
	let ln = Types.label_name l in
	Format.fprintf ppf "match matcher_%i r.%s with@\n" (no t pl) ln;
	if cases <> [] then
	  (
	    let case (mask, rem) =
	      Format.fprintf ppf "  | %a -> @\n    @[%a@]@\n"
		print_success (mask, pl, Printf.sprintf "f%s_" ln)
		show_record_aux rem
	    in
	    List.iter case cases;
	  );
	(match ab with
	   | Some ab ->
	       Format.fprintf ppf 
	      "  | absent -> @\n    @[%a@]@\n" show_record_aux ab
	   | None -> ()
	)
	
	
    
  let show ppf t pl =
    ignore (no t pl);
    let rec loop () = 
      match !to_print with
	| (n,d)::r -> to_print:=r; show ppf n d; loop ()
	| [] -> ()
    in
    loop ()

  let get i =
    fst (List.find (fun (_,j) -> i = j) !memo)

end   

(*
  let test_filter t p = 
    let t = Syntax.make_type (Syntax.parse t)
    and p = Syntax.make_pat (Syntax.parse p) in
    let r = Patterns.filter (Types.descr t) p in
    List.iter (fun (v,t) -> 
                 let t = Types.normalize t in
                 Format.fprintf Format.std_formatter "@[%s => %a@]@\n"
                       v Types.Print.print t) r;;
test_filter "[ (1 2 3?)* ]" "[ (x::(1 2) 3?)* ]";;
*)

(*
let pat s = Patterns.descr (Typer.pat (Parser.From_string.pat s));;
let typ s = Types.descr (Typer.typ (Parser.From_string.pat s));;
let f s = Patterns.NF.nf (pat s);;
let show' t l = Patterns.NF.show Format.std_formatter t (List.map f l);;
let show l = show' Types.any l;;
let showt t l = show' (typ t) l;;

 showt " [(`A `B `C?)*] "  [" [ (((x::`A) `B (x::`C))|_)* ] "];;

show ["{x=2;y=3}"];;
show [" [((x::1)|(y::2))*] "];;

let g s =
   Patterns.NF.ProdMap.fold (fun k x acc -> (k,x)::acc) (Patterns.NF.left (f s)) [];;

 Patterns.NF.dispatch Types.any [ f "(x,y)" ];;
 Patterns.NF.show Format.std_formatter 0 Types.any [ f "(x,y)" ];;
 Patterns.NF.show Format.std_formatter 0 Types.any [ f "(0--100,x) | (_,(x:=10))" ];;

let t = Types.descr (Syntax.make_type (Syntax.parse "[_*]")) in
Patterns.NF.show Format.std_formatter 0 t [ f "[((x::5)|_)*]" ];;


Patterns.NF.show Format.std_formatter 0 Types.any [ f "(x,y)"; f "(x,y)"];;
Patterns.NF.show Format.std_formatter 0 Types.any [ f "x"; f "y"];;

show [ "((x,_),_)"; "((_,x),_)" ];;
showt " [ (1 3?)* ]" [ " [(x::1 3?)*] " ];;
showt " [ (1 3?)* ]" [ " [(1 (x::3)?)*] " ];;
#install_printer Types.Print.print;;
#install_printer Types.Print.print_descr;;
let (t,[p1;p2]) = Patterns.NF.get 5;;
*)