viewcvs.cgi/types/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 = {
    nfv    : fv;
    na     : Types.descr;
    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 p2, 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)

  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
    { nfv     = nf.v;
      na      = nf.a;
      nbasic  = basic nf.basic;
      nprod   = prod nf.prod;
      nrecord = record nf.record;
    }


  module Disp = struct

    type actions = {
      basic: (Types.descr * result) list;
      prod: result dispatch dispatch;
      record: record option;
    }
    and record = 
        [ `Label of Types.label * record dispatch * record option
        | `Result of result ]

    and 'a dispatch = dispatcher * 'a array
    and result = int * source list
    and source = 
        [ `Catch | `Const of Types.const 
        | `Left of int | `Right of int | `Recompose of int * int
        | `Field of Types.label * int
        ]
      
    and dispatcher = {
      id : int;
      t  : Types.descr;
      pl : normal array;
      interface : (Types.descr * int * (capture, int) sm option array) array;
      mutable actions : actions option
    }

    let cur_id = ref 0

  module DispMap = Map.Make(
    struct
      type t = Types.descr * normal 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 res = ref [] in
      let rec aux t bindings arity i = 
        if Types.non_empty t 
        then 
          if i = Array.length pl 
          then res := (t, arity, Array.of_list (List.rev bindings)) :: !res
          else
            let p = pl.(i) in
            aux (Types.cap t p.na) (Some (num arity p.nfv) :: bindings)
              (arity + (List.length p.nfv)) (i+1);
            aux (Types.diff t p.na) (None :: bindings) arity (i+1)
      in
      aux t [] 0 0;
      let res = { id = !cur_id; 
                  t = t;
                  pl = pl;
                  interface = Array.of_list !res; 
                  actions = None } in
      incr cur_id;
      dispatchers := DispMap.add (t,pl) res !dispatchers;
      res
    
  let flatten pl =
    let accu = ref [] and idx = ref [] in
    let aux i x = accu := x :: !accu; idx := i :: !idx  in
    Array.iteri (fun i -> List.iter (aux i)) pl;
    Array.of_list !idx,
    Array.of_list !accu

  let collect f pl =
    let accu = ref [] in
    let aux (res,x) = try accu := (f x) :: !accu with Exit -> () in
    Array.iter (List.iter aux) pl;
    SortedList.from_list (!accu)


  let rec find_uniq f = function
    | [] -> None
    | (res,x) :: rem -> if (f x) then Some res else find_uniq f rem

  let compare_masks a1 a2 =
    try
      for i = 0 to Array.length a1 - 1 do
        match a1.(i),a2.(i) with   
          | None,Some _| Some _, None -> raise Exit
          | _ -> ()
      done;
      true
    with Exit -> false

  let find_code (d : dispatcher) a =
    let rec aux i =
      if i = Array.length d.interface 
      then raise Not_found
      else 
        match d.interface.(i) with
          | (_,_,m) when compare_masks m a  -> i
          | _ -> aux (i + 1) in
    aux 0

  let conv_source_basic = function
    | (`Catch | `Const _) as x -> x
    | _ -> assert false

  let create_result f pl =
    let res = ref [] in
    Array.iter
      (function 
         | Some b -> List.iter (fun x -> res := f x :: !res) b
         | None -> ()
      ) pl;
    List.rev !res
    
  let filter f = Array.map (find_uniq f)

  let dispatch_basic d : (Types.descr * result) list =
    let pl = Array.map (fun p -> p.nbasic) d.pl in
    let tests = collect (fun x -> x) pl in
    let t = Types.cap any_basic d.t in
    let accu = ref [] in
    let rec aux t l = 
      if Types.non_empty t 
      then match l with
        | [] ->
            let pl = filter (Types.subtype t) pl in
            let code = find_code d pl in
            let res = create_result (fun (v,s) -> conv_source_basic s) pl in
            accu := (t, (code,res)) :: !accu
        | ty :: rem -> aux (Types.cap t ty) rem; aux (Types.diff t ty) rem
    in
    aux t tests;
    !accu


  let get_tests pl f t d =
    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 (p,info) ->
                   let p = normal (restrict t p) in
                   accu := (p,[i, 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,arity,m) =
      let selected = Array.create (Array.length pl) [] in
      let add r (i,inf) = selected.(i) <- (r,inf) :: selected.(i) in
      Array.iteri 
        (fun j -> function Some r -> List.iter (add r) infos.(j) | None -> ())
        m;
      d t selected unselect
    in
    let res = Array.map result disp.interface in
    (disp,res)


  let conv_source_prod left right (v,s) = match s with
    | (`Catch | `Const _) as x -> x
    | `Left -> 
(*
Printf.eprintf "Left %s\n" v;
List.iter (fun (v,i) -> Printf.eprintf "  LEFT(%s => %i)\n" v i) left;
List.iter (fun (v,i) -> Printf.eprintf "  RIGHT(%s => %i)\n" v i) right;
flush stderr;
*)
        `Left (List.assoc v left)
    | `Right -> `Right (List.assoc v right)
    | `Recompose -> `Recompose (List.assoc v left, List.assoc v right)
    | _ -> assert false

  let rec dispatch_prod disp : (result dispatch dispatch) =
(*
    Printf.eprintf "dispatch_prod %i: " disp.id;
    Array.iteri (fun i p ->
                   Printf.eprintf "(%i:" i;
                   List.iter (fun v -> Printf.eprintf "%s" v) p.nfv;
                   Printf.eprintf ")";
                ) disp.pl;
    Printf.eprintf "\n";
    flush stderr;
*)
    let pl = Array.map (fun p -> p.nprod) disp.pl in
    let t = Types.Product.get disp.t in
    get_tests pl
      (fun (res,(p,q)) -> [p, (res,q)], [])
      (Types.Product.pi1 t)
      (dispatch_prod1 disp t)
  and dispatch_prod1 disp t t1 pl _ =
    let t = Types.Product.restrict_1 t t1 in
    get_tests pl
      (fun (ret1, (res,q)) -> [q, (ret1,res)], [] ) 
      (Types.Product.pi2 t)
      (dispatch_prod2 disp t)
  and dispatch_prod2 disp t t2 pl _ =
    let aux_final = function
      | [] -> None
      | [(ret2, (ret1, res))] -> 
          Some (List.map (conv_source_prod ret1 ret2) res)
      | _ -> assert false in
    let final = Array.map aux_final pl in
    let code = find_code disp final in
    let ret = create_result (fun s -> s) final in
    (code,ret)


  let dummy_label = Types.label ""

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

  let map_record f = 
    let rec aux = function
      | [] -> []
      | h::t -> (match f h with (_,_,`Fail) -> aux t | x -> x :: (aux t)) in
    Array.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_not_found l = 
    map_record 
      (function
         | (res, catch, `Label (l1, _, ab)) when l1 = l -> (res, catch, ab)
         | x -> x)

  let conv_source_record catch (v,s) = match s with
    | (`Catch | `Const _) as x -> x
    | `Field l -> `Field (l, List.assoc v (List.assoc l catch))
    | _ -> assert false

  let rec dispatch_record disp : record option =
    let prep p = List.map (fun (res,r) -> (res,[],r)) p.nrecord in
    let pl0 = Array.map prep disp.pl in
    let t = Types.Record.get disp.t in
    dispatch_record_opt disp t pl0
  and dispatch_record_opt disp t pl =
    if Types.Record.is_empty t then None 
    else Some (dispatch_record_label disp t pl)
  and dispatch_record_label disp t pl =
    match collect_first_label pl with
      | None -> 
          let aux_final = function
            | [(res, catch, `Success)] -> 
                Some (List.map (conv_source_record catch) res)
            | [] -> None
            | _ -> assert false in
          let final = Array.map aux_final pl in
          let code = find_code disp final in
          let ret = create_result (fun s -> s) final in
          `Result (code,ret)
      | Some l ->
          let present =
            let pl = label_found l pl in
            let t = Types.Record.restrict_label_present t l in
            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)
          in
          let absent = 
            let pl = label_not_found l pl in
            let t = Types.Record.restrict_label_absent t l in
            dispatch_record_opt disp t pl
          in
          `Label (l, present, absent)
  and dispatch_record_field l disp t tfield pl others =
    let t = Types.Record.restrict_field t l tfield in
    let aux (ret, (res, catch, rem)) = (res, (l,ret) :: catch, rem) in
    let pl = Array.map (List.map aux) pl in
    Array.iteri (fun i o -> pl.(i) <- pl.(i) @ o) others;
    dispatch_record_label disp t pl
    

  let actions disp =
    match disp.actions with
      | Some a -> a
      | None ->
          let a = {
            basic = dispatch_basic disp;
            prod  = dispatch_prod disp;
            record = dispatch_record disp;
          } in
          disp.actions <- Some a;
          a

  let to_print = ref []
  let printed = ref []

  let queue d =
    if not (List.mem d.id !printed) then (
      printed := d.id :: !printed;
      to_print := d :: !to_print
    )

  let print_actions ppf actions =
    let print_source ppf = function
      | `Catch  -> Format.fprintf ppf "v"
      | `Const c -> Types.Print.print_const ppf c
      | `Left i -> Format.fprintf ppf "l%i" i
      | `Right j -> Format.fprintf ppf "r%i" j
      | `Recompose (i,j) -> Format.fprintf ppf "(l%i,r%i)" i j
      | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i
    in
    let rec print_result ppf = function
      | [] -> ()
      | [s] -> print_source ppf s
      | s::rem -> Format.fprintf ppf "%a," print_source s; print_result ppf rem
    in
    let print_ret ppf (code,ret) = 
      Format.fprintf ppf "$%i(%a)" code print_result ret in
    let print_lhs ppf (code,prefix,d) =
      let arity = match d.interface.(code) with (_,a,_) -> a in
      Format.fprintf ppf "$%i(" code;
      for i = 0 to arity - 1 do
        if i > 0 then Format.fprintf ppf ",";
        Format.fprintf ppf "%s%i" prefix i;
      done;
      Format.fprintf ppf ")" in
    let print_basic (t,ret) =
      Format.fprintf ppf " | %a ->%a@\n"
        Types.Print.print_descr t
        print_ret ret
    in
    let print_prod2 (d,rem) =
      queue d;
      Format.fprintf ppf "          match v2 with disp_%i@\n" d.id;
      Array.iteri 
        (fun code r ->
           Format.fprintf ppf "          | %a -> %a\n" 
             print_lhs (code, "r", d)
             print_ret r;
        )
        rem
    in
    let print_prod (d,rem) =
      if Array.length rem > 0 then (
        queue d;
        Format.fprintf ppf " | (v1,v2) -> @\n";
        Format.fprintf ppf "      match v1 with disp_%i@\n" d.id;
        Array.iteri 
          (fun code d2 ->
             Format.fprintf ppf "        | %a -> @\n"
             print_lhs (code, "l", d);
             print_prod2 d2;
          )
          rem
      )
    in
    let rec print_record_opt ppf = function
      | None -> ()
      | Some r -> 
          Format.fprintf ppf " | Record -> @\n";
          Format.fprintf ppf "     @[%a@]@\n"  print_record r
    and print_record ppf = function
      | `Result r -> print_ret ppf r
      | `Label (l, (d,present), absent) ->
          let l = Types.label_name l in
          queue d;
          Format.fprintf ppf " check label %s:@\n" l;
          Format.fprintf ppf "  Present => match with disp_%i@\n" d.id;
          Array.iteri
            (fun code r ->
               Format.fprintf ppf "    | %a -> @\n"
                 print_lhs (code, l, d);
               Format.fprintf ppf "       @[%a@]@\n"
                 print_record r
            ) present;
          match absent with
            | Some r ->
                Format.fprintf ppf "  Absent => @[%a@]@\n"
                   print_record r
            | None -> ()
    in
    
    List.iter print_basic actions.basic;
    print_prod actions.prod;
    print_record_opt ppf actions.record

  let rec print_dispatchers ppf =
    match !to_print with
      | [] -> ()
      | d :: rem ->
          to_print := rem;
          Format.fprintf ppf "Dispatcher %i accepts [%a]@\n" 
            d.id Types.Print.print_descr d.t;
(*
          Array.iteri
            (fun code (t, arity, m) ->
               Format.fprintf ppf "  $%i(arity=%i) accepts [%a]" 
                 code arity
                 Types.Print.print_descr t;
               Array.iter
               (function 
                  | None -> Format.fprintf ppf " None"
                  | Some b -> 
                      Format.fprintf ppf " Some(";
                      List.iter 
                        (fun (v,i) ->  Format.fprintf ppf "%s=>%i;" v i)
                        b;
                      Format.fprintf ppf ")"
               ) m; 
               Format.fprintf ppf "@\n";
            )
            d.interface;
*)
          Format.fprintf ppf "disp_%i = function@\n" d.id;
          print_actions ppf (actions d);
          print_dispatchers ppf

  let show ppf t pl =
    let disp = dispatcher t pl in
    queue disp;
    print_dispatchers ppf

  end


(***************************************************************


  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) *)

  module Dispatch = struct
    type t = {
      id    : int;
      fv    : fv list;
      masks : (mask * (int * int * (capture, int) sm option array)) list;
      basic : (Types.descr * (result option list)) list;
      prod  : prod;
      record: record option;

      mutable basic' : (Types.descr * result') list option;
      mutable prod' : result' disp' disp' option
    }
    and prod = prod_result disp disp
    and prod_result = (result * (int * int)) option list

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

    and mask = bool list
    and 'a disp = (Types.descr * nf SortedList.t) * (mask * 'a) list
    and 'a disp' = t * (int * 'a) list

    and result' = int * source' list
    and source' = 
      [ `Catch | `Const of Types.const 
      | `Left of int | `Right of int | `Recompose of int * int
      | `Field of Types.label * int
      ]
  end


(* 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

  module D = Map.Make(
    struct
      type t = Types.descr * normal list
      let compare = compare
    end
  )

  let dispatchers = ref D.empty
  let id = ref 0

  let rec dispatch (t : Types.descr) (pl : normal list) =
    try D.find (t,pl) !dispatchers
    with Not_found ->
      let basic = dispatch_basic t pl
      and prod = dispatch_prod t pl 
      and record = dispatch_record t pl in

      let alloc mask =
        let arity = ref 0 in
        let rec aux pl mask = 
          match (pl,mask) with
          | ([],[]) -> []
          | (p :: pl, true :: mask) ->
              let l = 
                   List.map (fun v -> incr arity; (v,!arity-1)) p.nfv in
              Some l :: aux pl mask
          | (_ :: pl, false :: mask) -> None :: aux pl mask
          | _ -> assert false
        in
        let r = aux pl mask in
        !arity, Array.of_list r
      in              

      let map_disp f ((t,pl),l) =
        let pl = List.map (fun p -> normal (restrict t p)) pl in
        let d = dispatch t pl in
        let r =  List.map 
                   (fun (m,r) -> 
                      let (code,_,res) = 
                        try List.assoc m d.Dispatch.masks
                        with Not_found -> assert false
                      in
                      (code, f res r)) l 
        in
        (d, r)
      in

      let map_basic masks =
        let source : source -> Dispatch.source' = function
          | `Catch -> `Catch
          | `Const c -> `Const c
          | _ -> assert false
        in
        let result rhs res =
          List.fold_left (fun rhs (v,src) -> source src :: rhs) rhs res
        in
        List.map 
          (fun (t, ret) ->
             let m = mask ret in
             let (code,_,_) = try List.assoc m masks with Not_found -> assert false in
             let rhs = 
               List.fold_left
                 (fun rhs ->
                    function 
                      | Some x -> result rhs x 
                      | None -> rhs
                 ) [] ret in
             (t,(code,List.rev rhs))
          )
      in
             
      let map_prod masks =
        let source res1 res2 v : source -> Dispatch.source' = function
          | `Catch -> `Catch
          | `Const c -> `Const c
          | `Left -> 
              let v1 = try List.assoc v res1 with Not_found -> assert false in
              `Left v1
          | `Right -> 
              let v2 = try List.assoc v res2 with Not_found -> assert false in
              `Right v2
          | `Recompose ->
              Printf.eprintf "res1:\n";
              List.iter (fun (v,i) -> Printf.eprintf "v=%s;i=%i\n" v i) res1;
              Printf.eprintf "res2:\n";
              List.iter (fun (v,i) -> Printf.eprintf "v=%s;i=%i\n" v i) res2;
              flush stderr;

              let v1 = try List.assoc v res1 with Not_found -> assert false in
              let v2 = try List.assoc v res2 with Not_found -> assert false in
              `Recompose (v1,v2)
          | _ -> assert false
        in
        let result rhs res1 res2 (res,(i,j)) =
          let res1 = match res1.(i) with Some r -> r | None -> assert false in
          let res2 = match res2.(j) with Some r -> r | None -> assert false in
          List.fold_left 
            (fun rhs (v,src) -> source res1 res2 v src :: rhs) rhs res
        in
        map_disp 
          (fun res1 -> 
             map_disp 
             (fun res2 ret -> 
                let m = mask ret in
                let (code,_,_) = List.assoc m masks in
                let rhs = 
                  List.fold_left
                    (fun rhs ->
                       function 
                         | Some x -> result rhs res1 res2 x 
                         | None -> rhs
                    ) [] ret in
                (code,List.rev rhs)
             )
          )
      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);
        
        let rec it_record_opt : Dispatch.record option -> unit = 
          function  None -> () | Some r -> it_record r
        and it_record : Dispatch.record -> unit = function
          | `Result r -> acc r
          | `Label (_,d,ro) -> it_record_disp d;  it_record_opt ro
        and it_record_disp (_,l) = List.iter (fun (_,r) -> it_record r) l
        in
        it_record_opt record;
        List.map 
          (fun (m,i) -> let (arity,r) = alloc m in (m,(i,arity,r))) 
          (num 0 (SortedList.from_list !accu))
      in
      incr id;
      let disp =
        { 
          Dispatch.id = !id;
          Dispatch.fv = List.map (fun p -> p.nfv) pl;
          Dispatch.masks = masks;
          Dispatch.basic = basic;
          Dispatch.prod = prod;
          Dispatch.record = record;
          Dispatch.basic' = None;
          Dispatch.prod' = None;
        }
      in
      dispatchers := D.add (t,pl) disp !dispatchers;
      disp.Dispatch.basic' <- Some (map_basic masks basic);
      disp.Dispatch.prod' <- Some (map_prod masks prod);
      disp


  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 -> 
        Types.Print.print_const Format.str_formatter c;
        Format.flush_str_formatter ()
    | _ -> 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 print_source' ppf = function
    | `Catch  -> Format.fprintf ppf "v"
    | `Const c -> Types.Print.print_const ppf c
    | `Left i -> Format.fprintf ppf "l%i" i
    | `Right j -> Format.fprintf ppf "r%i" j
    | `Recompose (i,j) -> Format.fprintf ppf "(l%i,r%i)" i j
    | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i

  let print_result' ppf (code,bindings) =
    Format.fprintf ppf "C%i ( " code;
    List.iter (print_source' ppf) bindings;
    Format.fprintf ppf ")"

  let no t pl =
    let pl = List.map (fun p -> normal (restrict t p)) pl in
    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 =
    List.iter 
      (fun (m,(i,arity,res)) -> 
         Format.fprintf ppf "[%i] arity=%i" i arity;
         Array.iter (function
                      | None -> Format.fprintf ppf " O"
                      | Some r -> 
                          Format.fprintf ppf " ( ";
                          List.iter (fun (v,i) ->
                                       Format.fprintf ppf "%s " v)
                            r;
                          Format.fprintf ppf ")"
                   ) res;
           Format.fprintf ppf "@\n"
      ) 
      d.Dispatch.masks;
    
    Format.fprintf ppf "let matcher_%i v = match v with@\n" num;
    (match d.Dispatch.prod' with Some p -> show_prod ppf p | None -> assert false);
    (match d.Dispatch.basic' with Some p -> show_basic ppf p | None -> assert false);
    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_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' result in
    List.iter case

  and show_prod ppf = function
    | (_, []) -> ()
    | (disp1, cases1) ->
        Format.fprintf ppf 
        "  | (v1,v2) -> match matcher_%i v1 with@\n" disp1.Dispatch.id;
        List.iter (case_prod1 ppf) cases1
  and case_prod2 ppf (code2, result) =
    Format.fprintf ppf "          | %i -> %a@\n" 
      code2
      print_result' result
  and case_prod1 ppf (code1, (disp2,cases2)) =
    Format.fprintf ppf "      | %i -> match matcher_%i v2 with@\n" 
      code1
      disp2.Dispatch.id;
    List.iter (case_prod2 ppf) 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))|_)* ] "];;
showt " [(`A)*] "  [" [ (x::`A)* ] "];;

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;;
*)


(*
#install_printer Types.Print.print_descr;;
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 disp t l = 
  let l = Array.of_list (
    List.map (fun p -> Patterns.NF.normal (Patterns.NF.nf (pat p))) l) in
  let t = typ t in
  Patterns.NF.Disp.show Format.std_formatter t l;;

let () = disp "_" ["(x,y,z)"];;

disp "_" ["`A"];;
disp "_" ["((x,y),z) | ((x := 1) & (y := 2), z)"];;
*)