(**************************************************************************)
(*  The CDuce compiler                                                    *)
(*  Alain Frisch <Alain.Frisch@inria.fr> and the CDuce team               *)
(*  Copyright CNRS,INRIA, 2003,2004 (see LICENSE for details)             *)
(**************************************************************************)

open Value
open Ident
open Patterns.Compile
open Encodings


type t = (Value.t * Types.t Lazy.t) list

let rec print ppf = function
  | [] -> ()
  | (v, t) :: l ->
      print ppf l;
      Format.fprintf ppf 
	"Value @[%a@] does not match type @[%a@]@."
	Value.print v
	Types.Print.print (Lazy.force t);


exception Path of t

let expected d fail =
  let ts = types_of_codes d in
  let a = ref Types.empty in
  Array.iteri (fun i t -> if i != fail then a := Types.cup t !a) ts;
  !a

let make_result pt  fail (code,_,_) =
  if fail == code then raise (Path pt);
  code

let rec run_disp_basic pt fail f =  function
  | [(_,r)] -> make_result pt fail r
  | (t,r)::rem -> 
      if f t then make_result pt fail r 
      else run_disp_basic pt fail f rem
  | _ -> assert false

let find_array pred a = 
  let res = ref (-1) in 
  for i = 0 to Array.length a - 1 do
    if pred a.(i) then (assert (!res = (-1)); res := i)
  done;
  !res

let new_fail_res fail =
  find_array (function (code,_,_) when code = fail -> true | _ -> false)
let new_fail_disp fail =
  find_array (function Ignore (code,_,_) when code = fail -> true | _ -> false)


let rec run_dispatcher pt fail d v = 
  match actions d with
    | AIgnore r -> make_result pt fail r
    | AKind k -> run_disp_kind pt d fail k v

and run_disp pt fail d v =
  run_dispatcher ((v, lazy (expected d fail))::pt) fail d v

and run_disp_kind pt d fail actions = function
  | Pair (v1,v2) -> run_disp_prod pt d fail v1 v2 actions.prod
  | Xml (v1,v2,v3) -> run_disp_prod pt d fail v1 (Pair(v2,v3)) actions.xml
  | Record r -> run_disp_record pt d fail false (LabelMap.get r) actions.record
  | Atom a -> make_result pt fail (Atoms.get_map a actions.atoms) 
  | Char c -> make_result pt fail (Chars.get_map c actions.chars) 
  | Integer i ->
      run_disp_basic pt fail (fun t -> Types.Int.has_int t i) actions.basic
  | Abstraction (None,_) ->
      run_disp_basic pt fail 
	(fun t -> failwith "Run-time inspection of external abstraction")
        actions.basic
  | Abstraction (Some iface,_)
  | Abstraction2 (_,iface,_) ->
      run_disp_basic pt fail (fun t -> Types.Arrow.check_iface iface t) 
        actions.basic
  | Absent ->
      run_disp_basic pt fail (fun t -> Types.Record.has_absent t) actions.basic
  | v ->
      run_disp_kind pt d fail actions (normalize v)


and run_disp_prod pt d fail v1 v2 = function
  | Impossible -> assert false
  | TailCall d1 -> run_disp pt fail d1 v1
  | Ignore d2 -> run_disp_prod2 pt d fail v2 d2
  | Dispatch (d1,b1) ->
      let code1 = run_disp pt (new_fail_disp fail b1) d1 v1 in
      run_disp_prod2 pt d fail v2 b1.(code1)

and run_disp_prod2 pt (d:dispatcher) fail v2 = function
  | Impossible -> assert false
  | Ignore r -> make_result pt fail r
  | TailCall d2 -> run_disp pt fail d2 v2
  | Dispatch (d2,b2) ->
      let code2 = run_disp pt (new_fail_res fail b2) d2 v2 in
      make_result pt fail b2.(code2)

and run_disp_record pt (d:dispatcher) fail other fields = function
  | None -> assert false
  | Some (RecLabel (l,r)) ->
      let rec aux other = function
	| (l1,_) :: rem when l1 < l -> aux true rem
	| (l1,vl) :: rem when l1 == l ->
	    run_disp_record1 pt d fail l other vl rem r
	| rem -> 
	    run_disp_record1 pt d fail l other Absent rem r
      in
      aux other fields
  | Some (RecNolabel (some,none)) ->
      let other = other || (fields != []) in
      let r = if other then some else none in
      match r with
	| Some r -> make_result pt fail r
	| None -> assert false
      
and run_disp_record1 pt (d:dispatcher) fail l other v1 rem = function
  | Impossible -> assert false
  | TailCall d1 -> run_disp pt fail d1 v1
  | Ignore d2 ->  run_disp_record2 pt d fail other rem d2
  | Dispatch (d1,b1) ->
      let code1 = run_disp pt (new_fail_disp fail b1) d1 v1 in
      run_disp_record2 pt d fail other rem b1.(code1)

and run_disp_record2 pt (d:dispatcher) fail other rem = function
  | Impossible -> assert false
  | Ignore r -> make_result pt fail r
  | TailCall d2 -> run_disp_record_loop pt fail other rem d2
  | Dispatch (d2,b2) ->
      let code2 = run_disp_record_loop pt (new_fail_res fail b2) other rem d2 in
      make_result pt fail b2.(code2)

and run_disp_record_loop pt fail other rem d =
  match actions d with
    | AIgnore r -> make_result pt fail r
    | AKind k -> run_disp_record pt d fail other rem k.record

let is_xml = function Xml _ -> true | _ -> false

let rec prepare = function
  | (Absent, _) :: l -> prepare l
  | x :: l ->
      (try
	 let y = List.find (function (Xml _,_) -> true | _ -> false) l in
	 [ x; y ]
       with Not_found -> [ x ])
  | [] -> assert false

let explain t0 t v =
  let p = Patterns.make IdSet.empty in
  Patterns.define p (Patterns.constr t);
  let (d,rhs) = make_branches t0 [ (p,()) ] in
  (* The instrumented dispatcher is slower, so we first try the normal
     one. This is optimized for the case where the value matches. *)
  let (code,_) = Run_dispatch.run_dispatcher d v in
  (* let fail = find_array (function Fail -> true | _ -> false) rhs in *)
  match rhs.(code) with
    | Fail ->
	(try ignore (run_disp [] code d v); assert false 
	 with Path p -> Some (prepare p))
    | _ -> None
