module Env = Map.Make (struct type t = string let compare = compare end)
let empty_env = Env.empty

type t =
  | Pair of t * t
  | Record of (Types.label,t) SortedMap.t
  | Atom of Types.atom
  | Integer of Big_int.big_int
  | Char of Chars.Unichar.t
  | Fun of abstr
and env = t Env.t
and abstr = { 
  fun_iface : (Types.descr * Types.descr) list;
  mutable fun_env   : env;
  fun_body  : Typed.branches;
}

let rec print ppf = function
  | Pair (x,y) ->
      Format.fprintf ppf "(%a,%a)" print x print y
  | Record l ->
      Format.fprintf ppf "{%a}" print_record l
  | Atom a ->
      Format.fprintf ppf "`%s" (Types.atom_name a)
  | Integer i ->
      Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
  | Char c ->
      Chars.Unichar.print ppf c
  | Fun c ->
      Format.fprintf ppf "<fun>"

and print_record ppf = function
  | [] -> ()
  | [f] -> print_field ppf f
  | f :: rem -> Format.fprintf ppf "%a; %a" print_field f print_record rem

and print_field ppf (l,v) = 
  Format.fprintf ppf "%s = %a" (Types.label_name l) print v  


(* Running dispatchers *)

let const = function
  | Types.Integer i -> Integer i
  | Types.Atom a -> Atom a
  | Types.Char c -> Char c

let make_result_prod r1 r2 v (code,r) = 
  let ret = Array.map
    (function
       | `Catch -> v
       | `Const c -> const c
       | `Left i -> r1.(i)
       | `Right j -> r2.(j)
       | `Recompose (i,j) -> Pair (r1.(i), r2.(j))
       | _ -> assert false
    ) r in
  (code,ret)

let make_result_record v fields (code,r) =
  let ret = Array.map
    (function
       | `Catch -> v
       | `Const c -> const c
       | `Field (l,i) -> (List.assoc l fields).(i)
       | _ -> assert false
    ) r in
  (code,ret)

let make_result_basic v (code,r) = 
  let ret = Array.map
    (function
       | `Catch -> v
       | `Const c -> const c
       | _ -> assert false
    ) r in
  (code,ret)

let dummy_r = [||]

let rec run_dispatcher d v = 
  let actions = Patterns.Compile.actions d in
  match v with
  | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
  | Record r -> run_disp_record v [] r actions.Patterns.Compile.record
  | Atom a -> 
      run_disp_basic v (fun t -> Types.Atom.has_atom t a) 
        actions.Patterns.Compile.basic
  | Char c ->
      run_disp_basic v (fun t -> Types.Char.has_char t c) 
        actions.Patterns.Compile.basic
  | Integer i ->
      run_disp_basic v (fun t -> Types.Int.has_int t i) 
        actions.Patterns.Compile.basic
  | Fun f ->
      run_disp_basic v (fun t -> Types.Arrow.check_iface f.fun_iface t) 
        actions.Patterns.Compile.basic

and run_disp_basic v f = function
  | [(_,r)] -> make_result_basic v r
  | (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
  | _ -> assert false
  

and run_disp_prod v v1 v2 = function
  | `None -> assert false
  | `TailCall d1 -> run_dispatcher d1 v1
  | `Ignore d2 -> run_disp_prod2 dummy_r v v2 d2
  | `Dispatch (d1,b1) ->
      let (code1,r1) = run_dispatcher d1 v1 in
      run_disp_prod2 r1 v v2 b1.(code1)

and run_disp_prod2 r1 v v2 = function
  | `None -> assert false
  | `Ignore r -> make_result_prod r1 dummy_r v r
  | `TailCall d2 -> run_dispatcher d2 v2
  | `Dispatch (d2,b2) ->
      let (code2,r2) = run_dispatcher d2 v2 in
      make_result_prod r1 r2 v b2.(code2)
	    
and run_disp_record v bindings fields = function
  | None -> assert false
  | Some record -> run_disp_record' v bindings fields record

and run_disp_record' v bindings fields = function
  | `Result r -> make_result_record v bindings r
  | `Label (l, present, absent) ->
      let rec aux = function
	| (l1,_) :: rem when l1 < l -> aux rem
	| (l1,vl) :: rem when l1 = l -> 
	    run_disp_field v bindings rem l vl present
	| _ -> run_disp_record v bindings fields absent
      in
      aux fields

and run_disp_field v bindings fields l vl = function
  | `None -> assert false
  | `Ignore r -> run_disp_record' v bindings fields r
  | `TailCall d -> run_dispatcher d vl
  | `Dispatch (dl,bl) ->
      let (codel,rl) = run_dispatcher dl vl in
      run_disp_record' v ((l,rl)::bindings) fields bl.(codel)

(* Evaluation of expressions *)


let rec eval env e = 
  match e.Typed.exp_descr with
    | Typed.Var s -> Env.find s env
    | Typed.Apply (f,arg) ->
	eval_apply (eval env f) (eval env arg)
    | Typed.Abstraction a ->
	let a' = { 
	  fun_env = env;
	  fun_iface = a.Typed.fun_iface;
	  fun_body = a.Typed.fun_body
	} in
	let self = Fun a' in
	(match a.Typed.fun_name with
	   | Some f -> a'.fun_env <- Env.add f self a'.fun_env
	   | None -> ());
	self
    | Typed.RecordLitt r ->
	Record (List.map (fun (l,e) -> (l, eval env e)) r)
    | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
    | Typed.Cst c -> const c
    | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
    | Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
    | Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)
    | Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)
    | Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)
    | Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)
    | Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
    | Typed.Op ("/", [e1; e2]) -> eval_div (eval env e1) (eval env e2)
    | Typed.Dot (e, l) -> eval_dot l (eval env e)
    | Typed.DebugTyper t -> failwith "Evaluating a ! expression"
    | _ -> failwith "Unknown expression"


and eval_apply f arg = match f with
  | Fun a -> eval_branches a.fun_env a.fun_body arg
  | _ -> assert false

and eval_branches env brs arg =
  let (disp, rhs) = Typed.dispatcher brs in
  let (code, bindings) = run_dispatcher disp arg in
  let (bind, e) = rhs.(code) in
  let env = 
    List.fold_left (fun env (x,i) -> Env.add x bindings.(i) env) env bind in
  eval env e

and eval_map env brs = function
  | Pair (x,y) -> Pair (eval_branches env brs x, eval_map env brs y)
  | q -> q
  
and eval_flatten = function
  | Pair (x,y) -> eval_concat x (eval_flatten y)
  | q -> q

and eval_concat l1 l2 = match l1 with
  | Pair (x,y) -> Pair (x, eval_concat y l2)
  | q -> l2

and eval_dot l = function
  | Record r -> List.assoc l r
  | _ -> assert false

and eval_add x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Big_int.add_big_int x y)
  | _ -> assert false

and eval_mul x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Big_int.mult_big_int x y)
  | _ -> assert false

and eval_sub x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Big_int.sub_big_int x y)
  | _ -> assert false

and eval_div x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Big_int.div_big_int x y)
  | _ -> assert false