(* 超来 -- The domain-specific language of remote computation

   The evaluator of Chourai expressions, or the server of
   RPC batches
*)

(*
#load "unix.cma";;
#load "config.cmo";;
#load "wire.cmo";;
#load "server_comm.cmo";;
#load "fact.cmo";;
#load "album.cmo";;
*)
open Wire;;
open Rpc_t;;

(* Registry of functions that this server can apply *)
let registry =
  [("<", fn_int2_bool (fun (x,y) -> x < y));
   ("Factorial", Fact.fact_wrapped);
  ]
  @ Album.album_registry
;;


(* A few helpers, mostly for debugging and tracing *)
let show_chr_val = function
  | UVal wire     -> show_wire wire
  | UVar varname  -> "Var" ^ string_of_int varname
  | UTag tagname  -> "Tag:" ^ tagname
;;

let rec show_chr_op = function
  | App (f,x)    -> "App "  ^ show_chr_val f ^ " " ^ show_chr_val x
  | App2 (f,x,y) -> "App2 " ^ show_chr_val f ^ " " ^ show_chr_val x
                      ^ " " ^ show_chr_val y
  | Guard (t,e)  ->
      "Guard " ^  show_chr_val t ^ " in " ^ show_chr_exps e

and show_chr_exps exps =
    let show_let (v,op) = "Let " ^ string_of_int v ^ " = " ^ show_chr_op op in
    String.concat "; " (List.map show_let exps)

(* Associating env names with their wire values
   For the time being, assume that vars can't have function types *)
module Env = Map.Make(struct type t = varname let compare = compare end);;

(* Obtain the value, consulting the environment if needed *)
let resolve_rcp_val env = function
  | UVal wire    -> wire
  | UVar varname -> Env.find varname env
  | UTag tagname -> failwith "UTag in resolve: not supported so far"
;;

(* eval: Evaluate a chr_op and return its value in the wire format,
   or throw an exception.
   execute: Execute a chr_request, a sequence of
   expressions paired with the name of a variable that
   will receive the value of the expression.
   The request is a `compiled' computation in the A-normal form.
   The function execute is programmed in the accumulator-passing
   style and receives the responses as an accumulator.
   The env holds the association of variables with already
   computed values.

   Unless some major exception happens (say, in marshalling),
   the responses match in number and order with the requests.
   If an error occurs while evaluating a request,
   the batch is terminated and all further requests assumed to
   be ended with the same error.
*)
let rec eval env req : wire_t =
  Printf.printf "Evaluating: %s" (show_chr_op req);
  print_newline ();
  match req with
  | App (UTag tag,arg) -> 
      let fn = List.assoc tag registry in
      let v  = resolve_rcp_val env arg in
      fn v
  | App (f,_) -> failwith ("inappropriate op: " ^ show_chr_val f)
  | App2 (UTag tag,argx,argy) -> 
      let fn = List.assoc tag registry in
      let vx = resolve_rcp_val env argx in
      let vy = resolve_rcp_val env argy in
      fn (WComp [vx;vy])
  | App2 (f,_,_) -> failwith ("inappropriate op: " ^ show_chr_val f)

  | Guard (test,exp) ->
      let tv = resolve_rcp_val env test in
      begin
	match bool_from_wire tv with
	| Datum true  -> 
	    let (resp,ok,_) = execute env [] exp in
	    if not ok then failwith "Subexpression evaluation failed"
	    else bool_to_wire true
	| Datum false -> bool_to_wire false
	| Err e       -> failwith e
      end

and execute env responses = function
    | [] -> (List.rev responses,
	     (match responses with	(* Success indicator *)
	     | ((Err _)::_) -> false
	     | _            -> true),
	     env)
    | ((var,req)::rest) ->
	let r = try Datum (eval env req) 
	          with e -> Err (Printexc.to_string e) in
	begin
	  match r with
	  | Datum rv -> execute (Env.add var rv env) (r::responses) rest
	  | Err e -> 
	      let newerr = Err ("Skipped due to the earlier: " ^ e) in
	      execute env (List.map (fun _ -> newerr) rest @ r::responses) []
        end

(* A simple test *)
let t = 
  eval (Env.empty) (App (UTag "Factorial",
		         UVal (int_to_wire 5)));;



(* Service a batch of requests and generate a batch of matching replies *)
let serve cin cout  =
  let req  = (Marshal.from_channel cin : chr_request) in
  let (resp,success,_) = execute Env.empty [] req in
  let _ = Printf.printf "Responses computed %s. Replying..." 
            (if success then "successfully" else "partly or not at all");
            print_newline () in
  let () = Marshal.to_channel cout resp [] 
  in flush cout
;;

      

(* The main function *)
let main () = Server_comm.start_server serve
;;

main ();;