eval.ml

open Value
open Run_dispatch
open Ident

exception MultipleDeclaration of id
module Env = Map.Make (Ident.Id)
type env = t Env.t

let global_env = State.ref "Eval.global_env" Env.empty

let enter_global x v = 
  if Env.mem x !global_env then
    raise (MultipleDeclaration x);
  global_env := Env.add x v !global_env


let exn_int_of = CDuceExn (Pair (
			     Atom (Atoms.mk_ascii "Invalid_argument"),
			     string_latin1 "int_of"))


let exn_load_file_utf8 = CDuceExn (Pair (
			     Atom (Atoms.mk_ascii "load_file_utf8"),
			     string_latin1 "File is not a valid UTF-8 stream"))


(* Evaluation of expressions *)

let rec eval env e0 = 
  match e0.Typed.exp_descr with
    | Typed.Forget (e,_) -> eval env e
    | Typed.Var s -> 
	(try Env.find s env
	with Not_found -> Env.find s !global_env)
    | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
    | Typed.Abstraction a ->
	let env = 
	  IdSet.fold
	    (fun accu x -> 
	       try Env.add x (Env.find x env) accu
	       with Not_found -> accu (* global *))
	    Env.empty a.Typed.fun_fv in
	let env_ref = ref env in
	let rec self = Abstraction (a.Typed.fun_iface, 
				    eval_branches' env_ref a.Typed.fun_body) in
	(match a.Typed.fun_name with
	  | None -> ()
	  | Some f -> env_ref := Env.add f self env;
	);
	self
(* Optimizations:
       - for the non-recursive case, use eval_branches
       - for the recursive case, could cheat by patching self afterwards:
                (Obj.magic self).(1) <- ....
*)
    | Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
    | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
    | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> 
	Xml (eval env e1, eval env e2, eval env e3)
    | Typed.Cst c -> const c
    | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
    | Typed.Map (false,arg,brs) -> eval_map env brs (eval env arg)
    | Typed.Map (true,_,_) -> assert false
    | Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
    | Typed.Op ("raise", [e]) -> raise (CDuceExn (eval env e))
    | Typed.Try (arg,brs) -> 
	(try eval env arg with CDuceExn v -> eval_branches env brs v)
    | Typed.Op ("flatten", [{Typed.exp_descr=Typed.Map (true,arg,brs)}]) -> 
	eval_transform 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.Op ("mod", [e1; e2]) -> eval_mod (eval env e1) (eval env e2)
    | Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
    | Typed.Op ("load_html", [e]) -> eval_load_html (eval env e)
    | Typed.Op ("load_file", [e]) -> eval_load_file ~utf8:false (eval env e)
    | Typed.Op ("load_file_utf8", [e]) -> eval_load_file ~utf8:true (eval env e)
    | Typed.Op ("print_xml", [e]) -> Print_xml.print_xml ~utf8:false (eval env e)
    | Typed.Op ("print_xml_utf8", [e]) -> Print_xml.print_xml ~utf8:true (eval env e)
    | Typed.Op ("print", [e]) -> eval_print (eval env e)
    | Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
    | Typed.Op ("atom_of", [e]) -> eval_atom_of (eval env e)
    | Typed.Op ("string_of", [e]) -> eval_string_of (eval env e)
    | Typed.Op ("dump_to_file", [e1; e2]) -> 
	eval_dump_to_file (eval env e1) (eval env e2)
    | Typed.Op ("dump_to_file_utf8", [e1; e2]) -> 
	eval_dump_to_file_utf8 (eval env e1) (eval env e2)
    | Typed.Op ("=",[e1; e2]) -> eval_equal (eval env e1) (eval env e2)
    | Typed.Op ("<",[e1; e2]) -> eval_lt (eval env e1) (eval env e2)
    | Typed.Op ("<=",[e1; e2]) -> eval_lte (eval env e1) (eval env e2)
    | Typed.Op (">",[e1; e2]) -> eval_gt (eval env e1) (eval env e2)
    | Typed.Op (">=",[e1; e2]) -> eval_gte (eval env e1) (eval env e2)
    | Typed.Dot (e, l) -> eval_dot l (eval env e)
    | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
    | Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
    | _ -> assert false


and eval_apply f arg = match f with
  | Abstraction (_,clos) -> clos arg
  | _ -> eval_concat f arg

and eval_branches' env_ref brs arg =
  eval_branches !env_ref brs arg

and eval_branches env brs arg =
  let (disp, rhs) = Typed.dispatcher brs in
  let (code, bindings) = run_dispatcher disp arg in
  match rhs.(code) with 
    | Patterns.Compile.Match (bind,e) ->
	let env = 
	  List.fold_left (fun env (x,i) -> 
			    if (i == -1) then Env.add x arg env 
			    else Env.add x bindings.(i) env) env (IdMap.get bind) in
	eval env e
    | Patterns.Compile.Fail -> Value.Absent

and eval_let_decl env l =
  let v = eval env l.Typed.let_body in
  let (disp,bind) = Typed.dispatcher_let_decl l in
  let (_,bindings) = run_dispatcher disp v in
  List.map (fun (x,i) -> (x, if (i == -1) then v else bindings.(i))) (IdMap.get bind)

and eval_map env brs = function
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      Pair (x, eval_map env brs y)
  | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v -> 
      eval_map env brs (normalize v)
  | q -> q
  
and eval_flatten = function
  | Pair (x,y) -> eval_concat x (eval_flatten y)
  | q -> q

and eval_transform env brs = function
  | Pair (x,y) -> 
      let x = match eval_branches env brs x with Value.Absent -> Value.nil | x -> x in
      eval_concat x (eval_transform env brs y)
  | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v -> 
      if Types.Char.is_empty (brs.Typed.br_accept) 
      then eval_transform env brs q
      else eval_transform env brs (normalize v)
  | q -> q

and eval_xtrans env brs = function
  | String_utf8 (s,i,j,q) as v ->
      if Types.Char.is_empty (brs.Typed.br_accept) 
      then String_utf8 (s,i,j, eval_xtrans env brs q)
      else eval_xtrans env brs (normalize v)
  | String_latin1 (s,i,j,q) as v ->
      if Types.Char.is_empty (brs.Typed.br_accept) 
      then String_latin1 (s,i,j, eval_xtrans env brs q)
      else eval_xtrans env brs (normalize v)
  | Pair (x,y) -> 
      (match eval_branches env brs x with
	 | Absent -> 
	     let x = match x with
	       | Xml (tag, attr, child) -> 
		   let child = eval_xtrans env brs child in
		   Xml (tag, attr, child)
	       | x -> x in
	     let y = eval_xtrans env brs y in
	     Pair (x,y)
	 | x ->
	     let y = eval_xtrans env brs y in
	     eval_concat x y)
  | q -> q

and eval_concat l1 l2 = match l1 with
  | Pair (x,y) -> Pair (x, eval_concat y l2)
  | String_latin1 (s,i,j,q) -> String_latin1 (s,i,j, eval_concat q l2)
  | String_utf8 (s,i,j,q) -> String_utf8 (s,i,j, eval_concat q l2)
  | q -> l2

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

and eval_remove_field l = function
  | Record r -> Record (LabelMap.remove l r)
  | _ -> assert false

and eval_add x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Intervals.vadd x y)
  | Record r1, Record r2 -> Record (LabelMap.merge (fun x y -> y) r1 r2)
  | _ -> assert false

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

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

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

and eval_mod x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Intervals.vmod x y)
  | _ -> assert false

and eval_load_xml e =
  Load_xml.load_xml (get_string_latin1 e)
    (* Note: loading iso-8859-1 (even ASCII) files with utf-8 internal
       encoding has a non negligible overhead with PXP *)

and eval_load_html e =
  Load_xml.load_html (get_string_latin1 e)

and eval_load_file ~utf8 e =
  Location.protect_op "load_file";
  let ic = open_in (get_string_latin1 e) in
  let len = in_channel_length ic in
  let s = String.create len in
  really_input ic s 0 len;
  close_in ic;
  if utf8 then 
    if U.check s 
    then Value.string_utf8 (U.mk s) 
    else raise exn_load_file_utf8
  else Value.string_latin1 s

and eval_int_of e =
  let (s,_) = get_string_utf8 e in
  try Integer (Intervals.mk (U.get_str s)) (* UTF-8 is ASCII compatible ! *)
  with Failure _ -> raise exn_int_of

and eval_atom_of e =
  let (s,_) = get_string_utf8 e in (* TODO: check that s is a correct Name wrt XML *)
  Atom (Atoms.mk s)
  
and eval_print v =
  Location.protect_op "print";
  print_string (get_string_latin1 v);
  flush stdout;
  Value.nil

and eval_dump_to_file f v =
  Location.protect_op "dump_to_file";
  let oc = open_out (get_string_latin1 f) in
  output_string oc (get_string_latin1 v);
  close_out oc;
  Value.nil
and eval_dump_to_file_utf8 f v =
  Location.protect_op "dump_to_file_utf8";
  let oc = open_out (get_string_latin1 f) in
  let (v,_) = get_string_utf8 v in
  output_string oc (U.get_str v);
  close_out oc;
  Value.nil


and eval_string_of v =
  let b = Buffer.create 16 in
  let ppf = Format.formatter_of_buffer b in
  Value.print ppf v;
  Format.pp_print_flush ppf ();
  string_latin1 (Buffer.contents b)
    
and eval_equal v1 v2 =
  let c = Value.compare v1 v2 in
  Value.vbool (Value.compare v1 v2 == 0)

and eval_lt v1 v2 =
  let c = Value.compare v1 v2 in
  Value.vbool (Value.compare v1 v2 < 0)

and eval_lte v1 v2 =
  let c = Value.compare v1 v2 in
  Value.vbool (Value.compare v1 v2 <= 0)

and eval_gt v1 v2 =
  let c = Value.compare v1 v2 in
  Value.vbool (Value.compare v1 v2 > 0)

and eval_gte v1 v2 =
  let c = Value.compare v1 v2 in
  Value.vbool (Value.compare v1 v2 >= 0)