patterns.ml

exception Error of string
open Ident

(* Syntactic algebra *)
(* Constraint: any node except Constr has fv<>[] ... *)
type d =
  | Constr of Types.descr
  | Cup of descr * descr
  | Cap of descr * descr
  | Times of node * node
  | Xml of node * node
  | Record of Types.label * node
  | Capture of id
  | Constant of id * Types.const
and node = {
  id : int;
  mutable descr : descr option;
  accept : Types.node;
  fv : fv
} and descr = Types.descr * fv * d

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

let printed = ref []
let to_print = ref []
let rec print ppf (a,_,d) = 
(*  Format.fprintf ppf "[%a]" Types.Print.print_descr a; *)
  match d with
    | Constr t -> Types.Print.print_descr ppf t
    | Cup (p1,p2) -> Format.fprintf ppf "(%a | %a)" print p1 print p2
    | Cap (p1,p2) -> Format.fprintf ppf "(%a & %a)" print p1 print p2
    | Times (n1,n2) -> 
	Format.fprintf ppf "(P%i,P%i)" n1.id n2.id;
	to_print := n1 :: n2 :: !to_print
    | Xml (n1,n2) -> 
	Format.fprintf ppf "XML(P%i,P%i)" n1.id n2.id;
	to_print := n1 :: n2 :: !to_print
    | Record (l,n) -> 
	Format.fprintf ppf "{ %s =  P%i }" (Types.LabelPool.value l) n.id;
	to_print := n :: !to_print
    | Capture x ->
	Format.fprintf ppf "%s" (Id.value x)
    | Constant (x,c) ->
	Format.fprintf ppf "(%s := %a)" (Id.value x) 
	  Types.Print.print_const c

let dump_print ppf =
  while !to_print <> [] do
    let p = List.hd !to_print in
    to_print := List.tl !to_print;
    if not (List.mem p.id !printed) then
      ( printed := p.id :: !printed;
	Format.fprintf ppf "P%i:=%a\n" p.id print (descr p)
      )
  done

let print ppf d =
  Format.fprintf ppf "%a@\n" print d;
  dump_print ppf


let counter = State.ref "Patterns.counter" 0

let make 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 = (x,IdSet.empty,Constr x)
let cup ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
  if not (IdSet.equal fv1 fv2) then (
    let x = match IdSet.pick (IdSet.diff fv1 fv2) with
      | Some x -> x
      | None -> match IdSet.pick (IdSet.diff fv2 fv1) with Some x -> x 
	  | None -> assert false
    in
    raise 
      (Error 
	 ("The capture variable " ^ (Id.value x) ^ 
	  " should appear on both side of this | pattern"))
  );
  (Types.cup acc1 acc2, IdSet.cup fv1 fv2, Cup (x1,x2))
let cap ((acc1,fv1,_) as x1) ((acc2,fv2,_) as x2) = 
  if not (IdSet.disjoint fv1 fv2) then (
    match IdSet.pick (IdSet.cap fv1 fv2) with
      | Some x -> 
	  raise 
	  (Error 
	     ("The capture variable " ^ (Id.value x) ^ 
	      " cannot appear on both side of this & pattern"))
      | None -> assert false
  );
  (Types.cap acc1 acc2, IdSet.cup fv1 fv2, Cap (x1,x2))
let times x y =
  (Types.times x.accept y.accept, IdSet.cup x.fv y.fv, Times (x,y))
let xml x y =
  (Types.xml x.accept y.accept, IdSet.cup x.fv y.fv, Xml (x,y))
let record l x = 
  (Types.record l false x.accept, x.fv, Record (l,x))
let capture x = (Types.any, IdSet.singleton x, Capture x)
let constant x c = (Types.any, IdSet.singleton x, Constant (x,c))




(* Static semantics *)

let cup_res v1 v2 = Types.Positive.cup [v1;v2]
let empty_res fv = IdMap.constant (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) : Types.Positive.v id_map =
(* TODO: avoid is_empty t when t is not changing (Cap) *)
  if Types.is_empty t 
  then empty_res fv
  else
    match d with
      | Constr _ -> IdMap.empty
      | Cup ((a,_,_) as d1,d2) ->
	  IdMap.merge cup_res
	    (filter_descr (Types.cap t a) d1)
	    (filter_descr (Types.diff t a) d2)
      | Cap (d1,d2) ->
	  IdMap.merge cup_res (filter_descr t d1) (filter_descr t d2)
      | Times (p1,p2) -> filter_prod fv p1 p2 t
      | Xml (p1,p2) -> filter_prod ~kind:`XML fv p1 p2 t
      | Record (l,p) ->
	  filter_node (Types.Record.project t l) p
      | Capture c ->
	  IdMap.singleton c (Types.Positive.ty t)
      | Constant (c, cst) ->
	  IdMap.singleton c (Types.Positive.ty (Types.constant cst))

and filter_prod ?kind fv p1 p2 t =
  List.fold_left 
    (fun accu (d1,d2) ->
       let term = 
	 IdMap.merge times_res (filter_node d1 p1) (filter_node d2 p2)
       in
       IdMap.merge cup_res accu term
    )
    (empty_res fv)
    (Types.Product.normal ?kind t)


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

let filter t p =
  let r = filter_node t p in
  memo_filter :=  MemoFilter.empty;
  IdMap.get (IdMap.map Types.Positive.solve r)


(* Normal forms for patterns and compilation *)

module Normal : sig 
  type 'a sl = 'a SortedList.t
  type ('a,'b) sm = ('a,'b) SortedMap.t

  type source = 
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
    | SField of Types.label 
  type result = source id_map

  type nnf = node sl * Types.descr
  type 'a nline = (result *  'a) list
  type record =
      [ `Success
      | `SomeField
      | `NoField
      | `Fail
      | `Dispatch of (nnf * record) list
      | `Label of Types.label * (nnf * record) list * record ]
  type t = {
    nfv    : fv;
    ncatchv: fv;
    na     : Types.descr;
    nbasic : Types.descr nline;
    nprod  : (nnf * nnf) nline;
    nxml   : (nnf * nnf) nline;
    nrecord: record nline
  }

  val any_basic: Types.descr
  val normal: Types.descr -> node list -> t
end = 
struct
  let any_basic = Types.neg (List.fold_left Types.cup Types.empty
			       [Types.Product.any_xml;
				Types.Product.any;
				Types.Record.any])


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

  type source = 
    | SCatch | SConst of Types.const 
    | SLeft | SRight | SRecompose 
    | SField of Types.label 
  type result = source id_map

  type nnf = node sl * Types.descr   (* pl,t;   t <= \accept{pl} *)
  type 'a nline = (result *  'a) sl
  type record =
      [ `Success
      | `SomeField
      | `NoField
      | `Fail
      | `Dispatch of (nnf * record) list
      | `Label of Types.label * (nnf * record) list * record ]
  type t = {
    nfv    : fv;
    ncatchv: fv;
    na     : Types.descr;
    nbasic : Types.descr nline;
    nprod  : (nnf * nnf) nline;
    nxml   : (nnf * nnf) nline;
    nrecord: record nline
  }

  let rec print_record ppf = function
    | `Success -> Format.fprintf ppf "Success"
    | `SomeField -> Format.fprintf ppf "SomeField"
    | `NoField -> Format.fprintf ppf "NoField"
    | `Fail -> Format.fprintf ppf "Fail"
    | `Dispatch _ -> Format.fprintf ppf "Dispatch"
    | `Label (l,pr,ab) ->
	Format.fprintf ppf "Label(%s@[" (Types.LabelPool.value l);
	List.iter (fun (_,r) -> Format.fprintf ppf ",%a" print_record r) pr;
	Format.fprintf ppf ",%a@])" print_record ab

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

  let nempty = { nfv = IdSet.empty; ncatchv = IdSet.empty; 
		 na = Types.empty;
		 nbasic = []; nprod = []; nxml = []; nrecord = [] }


  let ncup nf1 nf2 = 
    (* assert (Types.is_empty (Types.cap nf1.na nf2.na)); *)
    (* assert (nf1.nfv = nf2.nfv); *)
    { nfv = nf1.nfv;
      ncatchv = IdSet.cap nf1.ncatchv nf2.ncatchv;
      na      = Types.cup nf1.na nf2.na;
      nbasic  = SortedList.cup nf1.nbasic nf2.nbasic;
      nprod   = SortedList.cup nf1.nprod nf2.nprod;
      nxml    = SortedList.cup nf1.nxml nf2.nxml;
      nrecord = SortedList.cup nf1.nrecord nf2.nrecord;
    }

  let double_fold f l1 l2 =
    SortedList.from_list
      (List.fold_left 
	 (fun accu x1 ->
	    List.fold_left
	    (fun accu x2 ->
	       f accu x1 x2
	    )
	    accu l2
	 ) [] l1)
	 
  let ncap nf1 nf2 =
    let prod accu (res1,((pl1,t1),(ql1,s1))) (res2,((pl2,t2),(ql2,s2))) =
      let t = Types.cap t1 t2 in
      if Types.is_empty t then accu else
	let s = Types.cap s1 s2  in
	if Types.is_empty s then accu else
	  (fus res1 res2, ((slcup pl1 pl2,t),(slcup ql1 ql2,s))) :: accu
    in
    let basic accu (res1,t1) (res2,t2) =
      let t = Types.cap t1 t2 in
      if Types.is_empty t then accu else
	(fus res1 res2, t) :: accu
    in
    let record accu (res1,rec1) (res2,rec2) =
      let rec aux extra1 rec1 extra2 rec2 = 
	let rec1 =
	  if extra1 then
	    match rec1 with 
	      | `SomeField -> `Success
	      | `NoField -> `Fail
	      | x -> x
	  else rec1
	and rec2 = 
	  if extra2 then
	    match rec2 with 
	      | `SomeField -> `Success
	      | `NoField -> `Fail
	      | x -> x
	  else rec2
	in
	match (rec1,rec2) with
	| `Success, r | r, `Success -> r
	| `Fail, _ | _, `Fail -> `Fail

	| `SomeField, `Label (l, pr, ab) ->
	    (match aux false `SomeField extra2 ab with
	       | `Fail when pr = [] -> `Fail
	       | ab -> `Label (l, pr, ab))
	| `Label (l, pr, ab), `SomeField ->
	    (match aux false `SomeField extra1 ab with
	       | `Fail when pr = [] -> `Fail
	       | ab -> `Label (l, pr, ab))

	| `NoField, `Label (l,pr,ab) ->
	    (match aux false `NoField extra2 ab with 
	       | `Fail -> `Fail 
	       | ab -> `Label (l, [], ab))

	| `Label (l, pr, ab), `NoField ->
	    (match aux false `NoField extra1 ab with 
	       | `Fail -> `Fail 
	       | ab -> `Label (l, [], ab))

	| `SomeField, `NoField | `NoField,`SomeField -> 
	    `Fail
	| `NoField, `NoField -> `NoField
	| `SomeField, `SomeField -> `SomeField
	| `Label (l1,pr1,ab1), `Label (l2,pr2,ab2) ->
(*TODO: eliminate `Fail *)
	    if (l1 < l2) then
	      `Label (l1, 
		      List.map (fun (d,r) -> (d, aux extra1 r true rec2)) pr1,
		      aux extra1 ab1 extra2 rec2)
	    else if (l2 < l1) then
	      `Label (l2, 
		      List.map (fun (d,r) -> (d, aux extra2 r true rec1)) pr2,
		      aux extra2 ab2 extra1 rec1)
	    else
	      let pr = 
		double_fold
		  (fun accu ((d1,t1),r1) ((d2,t2),r2) ->
		     let r = aux extra1 r1 extra2 r2 in
		     match r with 
		       | `Fail -> accu 
		       | x -> ((slcup d1 d2, Types.cap t1 t2),x)::accu)
		  pr1 pr2 in
	      `Label (l1, pr, aux extra1 ab1 extra2 ab2)
	| `Dispatch _, _ | _, `Dispatch _ -> assert false in
      let res = aux false rec1 false rec2 in
(*      Format.fprintf Format.std_formatter 
	"ncap; @\nrecord1=%a; @\nrecord2=%a;@\n result=%a@\n"
	print_record rec1
	print_record rec2
	print_record res; *)
      match res with
	| `Fail -> accu
	| r -> (fus res1 res2, r) :: accu
    in
    { nfv = IdSet.cup nf1.nfv nf2.nfv;
      ncatchv = IdSet.cup nf1.ncatchv nf2.ncatchv;
      na = Types.cap nf1.na nf2.na;
      nbasic = double_fold basic nf1.nbasic nf2.nbasic;
      nprod = double_fold prod nf1.nprod nf2.nprod;
      nxml = double_fold prod nf1.nxml nf2.nxml;
      nrecord = double_fold record nf1.nrecord nf2.nrecord;
    }

  let nnode p = [p], Types.descr p.accept
  let empty_res = IdMap.empty

  let ntimes acc p q = 
    let src_p = IdMap.constant SLeft p.fv
    and src_q = IdMap.constant SRight q.fv in
    let src = IdMap.merge_elem SRecompose src_p src_q in 
    { nempty with 
	nfv = IdSet.cup p.fv q.fv; 
	na = acc;
	nprod = [ (src, (nnode p, nnode q)) ];
    }

  let nxml acc p q = 
    let src_p = IdMap.constant SLeft p.fv
    and src_q = IdMap.constant SRight q.fv in
    let src = IdMap.merge_elem SRecompose src_p src_q in 
    { nempty with 
	nfv = IdSet.cup p.fv q.fv; 
	na = acc;
	nxml =  [ (src, (nnode p, nnode q)) ];
    }
    
  let nrecord acc l p =
    let src = IdMap.constant (SField l) p.fv in
    let r = Types.Record.normal acc in
    { nempty with
	nfv = p.fv;
	na = acc;
	nrecord = [ src, `Label (l,[nnode p, `Success],`Fail) ] }

  let nconstr t =
    let rec aux_record = function
      | `Success -> `Success
      | `Fail -> `Fail
      | `NoField -> `NoField
      | `SomeField -> `SomeField
      | `Label (l, pr, ab) ->
	  `Label (l, 
		  List.map (fun (t,r) -> ([],t), aux_record r) pr,
		  aux_record ab) in
    { nempty with
	na = t;
	nbasic = [ empty_res, Types.cap t any_basic ];
	nprod = 
	  List.map 
	    (fun (t1,t2) -> empty_res, (([],t1),([],t2)))
	    (Types.Product.normal t);
	nxml= 
	  List.map 
	    (fun (t1,t2) -> empty_res, (([],t1),([],t2)))
	    (Types.Product.normal ~kind:`XML t);
	nrecord = [ empty_res, aux_record (Types.Record.normal t) ]
    }

  let nconstant x c = 
    let l = IdMap.singleton x (SConst c) in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.empty;
      na = Types.any;
      nbasic = [ (l,any_basic) ]; 
      nprod  = [ (l,(([], Types.any),([], Types.any))) ];
      nxml   = [ (l,(([], Types.any),([], Types.any))) ];
      nrecord = [ (l,`Success) ];
    }

  let ncapture x = 
    let l = IdMap.singleton x SCatch in
    { nfv = IdSet.singleton x;
      ncatchv = IdSet.singleton x;
      na = Types.any;
      nbasic = [ (l,any_basic) ]; 
      nprod  = [ (l,(([], Types.any),([], Types.any))) ];
      nxml   = [ (l,(([], Types.any),([], Types.any))) ];
      nrecord = [ (l,`Success) ];
    }

  let rec nnormal (acc,fv,d) =
    if Types.is_empty acc 
    then nempty
    else match d with
      | Constr t -> nconstr t
      | Cap (p,q) -> ncap (nnormal p) (nnormal q)
      | Cup ((acc1,_,_) as p,q) -> 
	  ncup (nnormal p) (ncap (nnormal q) (nconstr (Types.neg acc1)))
      | Times (p,q) -> ntimes acc p q
      | Xml (p,q) -> nxml acc p q
      | Capture x -> ncapture x
      | Constant (x,c) -> nconstant x c
      | Record (l,p) -> nrecord acc l p
   
  let remove_catchv n =
    let ncv = n.ncatchv in
    let nlines l = 
      let l = List.map (fun (res,x) -> (IdMap.diff res ncv,x)) l in
(*       let l = SortedList.from_list l in (* Can get rid of it ? *) *)
      l in
    { nfv     = IdSet.diff n.nfv ncv;
      ncatchv = n.ncatchv;
      na      = n.na;
      nbasic  = nlines n.nbasic;
      nprod   = nlines n.nprod;
      nxml    = nlines n.nxml;
      nrecord = nlines n.nrecord;
    }

  let normal t pl =
    remove_catchv
      (List.fold_left (fun a p -> ncap a (nnormal (descr p))) (nconstr t) pl)
end


module Compile = 
struct
  type actions =
    | AIgnore of result
    | AKind of actions_kind
  and actions_kind = {
    basic: (Types.descr * result) list;
    prod: result dispatch dispatch;
    xml: result dispatch dispatch;
    record: record option;
  }
  and record = 
      [ `Label of Types.label * record dispatch * record option
      | `Result of result
      | `Result_other of Types.label list * result * result ]
      
  and 'a dispatch =
    | Dispatch of dispatcher * 'a array
    | TailCall of dispatcher
    | Ignore of 'a
    | Impossible

  and result = int * source array
  and source = 
    | Catch | Const of Types.const 
    | Left of int | Right of int | Recompose of int * int
    | Field of Types.label * int
      
  and return_code = 
      Types.descr * int *   (* accepted type, arity *)
      (int * int id_map) list

  and interface =
    [ `Result of int
    | `Switch of interface * interface
    | `None ]

  and dispatcher = {
    id : int;
    t  : Types.descr;
    pl : Normal.t array;
    interface : interface;
    codes : return_code array;
    mutable actions : actions option
  }

  let array_for_all f a =
    let rec aux f a i =
      if i = Array.length a then true
      else f a.(i) && (aux f a (succ i))
    in
    aux f a 0

  let array_for_all_i f a =
    let rec aux f a i =
      if i = Array.length a then true
      else f i a.(i) && (aux f a (succ i))
    in
    aux f a 0

  let combine_kind basic prod xml record =
    try (
      let rs = [] in
      let rs = match basic with
	| [_,r] -> r :: rs
	| [] -> rs
	| _ -> raise Exit in
      let rs = match prod with
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
	| _ -> raise Exit in
      let rs = match xml with
	| Impossible -> rs
	| Ignore (Ignore r) -> r :: rs
	| _ -> raise Exit in
      let rs = match record with
	| None -> rs
	| Some (`Result r) -> r :: rs
	| _ -> raise Exit in
      match rs with
	| ((_, ret) as r) :: rs when 
	    List.for_all ( (=) r ) rs 
	    && array_for_all 
	      (function Catch | Const _ -> true | _ -> false) ret
	    -> AIgnore r
	| _ -> raise Exit
    )
    with Exit -> AKind { basic = basic; prod = prod; xml = xml; record = record }

  let combine (disp,act) =
    if Array.length act = 0 then Impossible
    else
      if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes) 
	 && (array_for_all ( (=) act.(0) ) act) then
	   Ignore act.(0)
      else
	Dispatch (disp, act)

  let combine_record l present absent = 
    match (present,absent) with
      | (Ignore r1, Some r2) when r1 = r2 -> r1
(*      | (`Ignore r, None) -> r  *)
(* Could allow this when r has no `Result_other ... *)
(* Otherwise:
debug compile {| x = Int; y =? Int |} {| x = Any |};;
[DEBUG:compile]
let disp_0 = function
 | Record -> 
     [x ]SomeField:$0;NoField:$1
*)
      | (Impossible, Some r) -> r
      | _ -> `Label (l, present, absent)

  let detect_right_tail_call = function
    | Dispatch (disp,branches) 
	when
	  array_for_all_i
	    (fun i (code,ret) ->
	       (i = code) && 
	       (array_for_all_i 
		  (fun pos -> 
		     function Right j when pos = j -> true | _ -> false)
		  ret
	       )
	    ) branches
	  -> TailCall disp
    | x -> x

  let detect_left_tail_call = function
    | Dispatch (disp,branches)
	when
	  array_for_all_i
	    (fun i -> 
	       function 
		 | Ignore (code,ret) ->
		     (i = code) &&
		     (array_for_all_i 
			(fun pos -> 
			   function Left j when pos = j -> true | _ -> false)
			ret
	       )
		 | _ -> false
	    ) branches
 	  ->
	 TailCall disp
    | x -> x
   
  let cur_id = State.ref "Patterns.cur_id" 0
		 (* TODO: save dispatchers ? *)
		 
  module DispMap = Map.Make(
    struct
      type t = Types.descr * Normal.t array
      let compare = compare
    end
  )
    
  let dispatchers = ref DispMap.empty
		      
  let dispatcher t pl : dispatcher =
    try DispMap.find (t,pl) !dispatchers
    with Not_found ->
      let nb = ref 0 in
      let codes = ref [] in
      let rec aux t arity i accu = 
	if Types.is_empty t then `None
	else
	  if i = Array.length pl 
	  then (incr nb; codes := (t,arity,accu)::!codes; `Result (!nb - 1))
	  else
	    let p = pl.(i) in
	    let tp = p.Normal.na in
	    assert(IdSet.disjoint p.Normal.nfv p.Normal.ncatchv);
	    let v = p.Normal.nfv in
(*	    let v = IdSet.diff p.Normal.nfv p.Normal.ncatchv in*)

(*	    let tp = Types.normalize tp in *)
	    let accu' = (i,IdMap.num arity v) :: accu in
	    `Switch 
	      (
	       aux (Types.cap t tp) (arity + (IdSet.length v)) (i+1) accu',
	       aux (Types.diff t tp) arity (i+1) accu
	      )
      in
      let iface = aux t 0 0 [] in
      let res = { id = !cur_id; 
		  t = t;
		  pl = pl;
		  interface = iface;
		  codes = Array.of_list (List.rev !codes);
		  actions = None } in
      incr cur_id;
      dispatchers := DispMap.add (t,pl) res !dispatchers;
      res
    
  let find_code d a =
    let rec aux i = function
      | `Result code -> code
      | `None -> assert false
      | `Switch (yes,_) when a.(i) <> None -> aux (i + 1) yes
      | `Switch (_,no) -> aux (i + 1) no
    in
    aux 0 d.interface

  let create_result pl =
    let aux x accu = match x with Some b -> b @ accu | None -> accu in
    Array.of_list (Array.fold_right aux pl [])

  let return disp pl f =
    let aux = function [x] -> Some (f x) | [] -> None | _ -> assert false in
    let final = Array.map aux pl in
    (find_code disp final, create_result final)
    
  let conv_source_basic s = match s with
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
    | _ -> assert false

  let assoc v l =
    try IdMap.assoc v l with Not_found -> -1

  let conv_source_prod left right v s = match s with
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
    | Normal.SLeft -> Left (assoc v left)
    | Normal.SRight -> Right (assoc v right)
    | Normal.SRecompose -> Recompose (assoc v left, assoc v right)
    | _ -> assert false

  let conv_source_record catch v s = match s with
    | Normal.SCatch -> Catch
    | Normal.SConst c -> Const c
    | Normal.SField l -> 
	Field (l, try assoc v (List.assoc l catch) with Not_found -> -1)
    | _ -> assert false


  let dispatch_basic disp : (Types.descr * result) list =
(* TODO: try other algo, using disp.codes .... *)
    let pl = Array.map (fun p -> p.Normal.nbasic) disp.pl in
    let tests =
      let accu = ref [] in
      let aux i (res,x) = accu := (x, [i,res]) :: !accu in
      Array.iteri (fun i -> List.iter (aux i)) pl;
      SortedMap.from_list SortedList.cup !accu in

    let t = Types.cap Normal.any_basic disp.t in
    let accu = ref [] in
    let rec aux (success : (int * Normal.result) list) t l = 
      if Types.non_empty t 
      then match l with
	| [] ->
	    let selected = Array.create (Array.length pl) [] in
	    let add (i,res) = selected.(i) <- res :: selected.(i) in
	    List.iter add success;
	    
	    let aux_final res = IdMap.map_to_list conv_source_basic res in
	    accu := (t, return disp selected aux_final) :: !accu
	| (ty,i) :: rem -> 
	    aux (i @ success) (Types.cap t ty) rem; 
	    aux success (Types.diff t ty) rem
    in
    aux [] t tests;
    !accu


  let get_tests pl f t d post =
    let accu = ref [] in
    let unselect = Array.create (Array.length pl) [] in
    let aux i x = 
      let yes, no = f x in
      List.iter (fun ( (pl,ty), info) ->
		   let p = Normal.normal ty pl in
		   accu := (p,[i, p.Normal.ncatchv, info]) :: !accu;
		) yes;
      unselect.(i) <- no @ unselect.(i) in
    Array.iteri (fun i -> List.iter (aux i)) pl;

    let sorted = Array.of_list (SortedMap.from_list SortedList.cup !accu) in
    let infos = Array.map snd sorted in
    let disp = dispatcher t (Array.map fst sorted) in
    let result (t,_,m) =
      let selected = Array.create (Array.length pl) [] in
      let add r (i, ncv, inf) = selected.(i) <- (r,ncv,inf) :: selected.(i) in
      List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
      d t selected unselect
    in
    let res = Array.map result disp.codes in
    post (disp,res)


  let make_branches t brs =
    let (_,brs) = 
      List.fold_left
	(fun (t,brs) (p,e) ->
	   let p' = ([p],t) in
	   let t' = Types.diff t (Types.descr (accept p)) in
	   (t', (p',e) :: brs)
	) (t,[]) brs in
	
    let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
    get_tests 
      pl 
      (fun x -> [x],[])
      t
      (fun _ pl _ ->
	 let r = ref None in
	 let aux = function 
	   | [(res,catchv,e)] -> assert (!r = None); 
	       let catchv = IdMap.constant (-1) catchv in
	       r := Some (IdMap.union_disj catchv res,e)
	   | [] -> () | _ -> assert false in
	 Array.iter aux pl;
	 let r = match !r with None -> assert false | Some x -> x in
	 r
      )
      (fun x -> x)


  let rec dispatch_prod ?(kind=`Normal) disp =
    let pl = 
      match kind with
	| `Normal ->  Array.map (fun p -> p.Normal.nprod) disp.pl
	| `XML -> Array.map (fun p -> p.Normal.nxml) disp.pl
    in
    let t = Types.Product.get ~kind disp.t in
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
      (fun x -> detect_left_tail_call (combine x))
  and dispatch_prod1 disp t t1 pl _ =
    let t = Types.Product.restrict_1 t t1 in
    get_tests pl
      (fun (ret1, ncatchv, (res,q)) -> [q, (ret1,res)], [] ) 
      (Types.Product.pi2 t)
      (dispatch_prod2 disp t)
      (fun x -> detect_right_tail_call (combine x))
  and dispatch_prod2 disp t t2 pl _ =
    let aux_final (ret2, ncatchv, (ret1, res)) =  
      IdMap.mapi_to_list (conv_source_prod ret1 ret2) res in
    return disp pl aux_final


  let dummy_label = Types.LabelPool.dummy_max

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

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

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

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

(*
  let memo_dispatch_record = ref []
  let memo_dr_count = ref 0
*)

  let rec print_normal_record ppf = function
    | `Success -> Format.fprintf ppf "Success"
    | `Fail -> Format.fprintf ppf "Fail"
    | `Label (l,pr,ab) ->
	Format.fprintf ppf "Label (%s,pr=%a,ab=%a)" (Types.LabelPool.value l)
	   print_normal_record_pr pr
	   print_normal_record ab
    | _ -> assert false
  and print_normal_record_pr ppf =
    List.iter (fun (nf,r) ->
		 Format.fprintf ppf "[_,%a]"
		  print_normal_record r) 
  let dump_dr ppf pl =
    Array.iteri
      (fun i x ->
	 Format.fprintf ppf "[%i:]" i;
	 List.iter
	   (fun (res,catch,nr) ->
	      Format.fprintf ppf "Result:";
	      List.iter (fun (x,s) -> Format.fprintf ppf "%s," x) res;
    	      Format.fprintf ppf "Catch:";
	      List.iter (fun (l,r) -> 
			   Format.fprintf ppf "%s[" (Types.LabelPool.value l);
			   List.iter (fun (x,i) -> 
					Format.fprintf ppf "%s->%i" x i) r;
			   Format.fprintf ppf "]"
			) catch;
    	      Format.fprintf ppf "NR:%a" print_normal_record nr
	   ) x;
	 Format.fprintf ppf "@\n"
      ) pl

  let rec dispatch_record disp : record option =
    let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
    let pl0 = Array.map prep disp.pl in
    let t = Types.Record.get disp.t in
    let r = dispatch_record_opt disp t pl0 [] in
(*    memo_dispatch_record := []; *)
    r
  and dispatch_record_opt disp t pl labs =
    if Types.Record.is_empty t then None 
    else Some (dispatch_record_label disp t pl labs)
(*  and dispatch_record_label disp t pl =
    try List.assoc (t,pl) !memo_dispatch_record
    with Not_found ->
      (*       Format.fprintf Format.std_formatter "%a@\n" 
	       Types.Print.print_descr (Types.Record.descr t);
	       dump_dr Format.std_formatter pl; *)
      let r = dispatch_record_label' disp t pl in 
      incr memo_dr_count;
      let r = !memo_dr_count, r in 
      memo_dispatch_record := ((t,pl),r) :: !memo_dispatch_record;
      r *)
  and dispatch_record_label disp t pl labs =
    match collect_first_label pl with
      | None -> 
	  let aux_final (res, catch, x) =
	    assert (x = `Success); 
	    IdMap.mapi_to_list (conv_source_record catch) res 
	  in
	  let somefield = 
	    if Types.Record.somefield_possible t then
	      let aux = function `Success | `SomeField -> `Success | _ -> `Fail in
	      Some (return disp (map_record aux pl) aux_final)
	    else None
	  in
	  let nofield = 
	    if Types.Record.nofield_possible t then 
	      let aux = function `Success | `NoField -> `Success | _ -> `Fail in
	      Some (return disp (map_record aux pl) aux_final)
	    else None
	  in
	  (match (somefield,nofield) with
	     | Some r1, Some r2 -> 
		 if r1 = r2 then `Result r1 else `Result_other(labs,r1,r2)
	     | Some r1, None -> `Result r1
	     | None, Some r2 -> `Result r2
	     | _ -> assert false)
      | Some l ->
	  let (plabs,absent) = 
	    let pl = label_not_found l pl in
	    let t = Types.Record.restrict_label_absent t l in
	    pl, dispatch_record_opt disp t pl labs
	  in
	  let present =
	    let labs = l :: labs in
	    let pl = label_found l pl in
	    let t = Types.Record.restrict_label_present t l in
	    if Types.Record.is_empty t then Impossible else 
	      get_tests pl
		(function 
		   | (res,catch, `Dispatch d) -> 
		       List.map (fun (p, r) -> p, (res, catch, r)) d, []
		   | x -> [],[x])
		(Types.Record.project_field t l)
		(dispatch_record_field l disp t plabs labs)
		(fun x -> combine x)
	  in
	  combine_record l present absent
  and dispatch_record_field l disp t plabs labs tfield pl others =
    let t = Types.Record.restrict_field t l tfield in
    let aux (ret, ncatchv, (res, catch, rem)) = 
      let catch = if IdMap.is_empty ret then catch else (l,ret) :: catch in
      (res, catch, rem) in
    let pl = Array.map (List.map aux) pl in
    Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
(*    if pl = plabs then `Absent else  *)
      (* TODO: Check that this is the good condition ....
	 Need condition on t ?

	 No, it isn't a good condition:
	 match { x = "a" } : { x =? "a"|"b" } with
	 | { x = "b" } -> 1
	 | _  -> 0;;
	 Need to investigate ....
      *)
	 
    dispatch_record_label disp t pl labs
    
      
  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
	  let a = combine_kind
		    (dispatch_basic disp)
		    (dispatch_prod disp)
		    (dispatch_prod ~kind:`XML disp)