(**************************************************************************)
(*                                                                        *)
(*  Ocamlviz --- real-time profiling tools for Objective Caml             *)
(*  Copyright (C) by INRIA - CNRS - Universite Paris Sud                  *)
(*  Authors: Julien Robert                                                *)
(*           Guillaume Von Tokarski                                       *)
(*           Sylvain Conchon                                              *)
(*           Jean-Christophe Filliatre                                    *)
(*           Fabrice Le Fessant                                           *)
(*  GNU Library General Public License version 2                          *)
(*  See file LICENSE for details                                          *)
(*                                                                        *)
(**************************************************************************)

open Camlp4.PreCast
open Syntax


let fun_idents = ref []


let getfilename loc = 
  let filename = Loc.file_name loc in
  let regex = Str.regexp "\\." in
  let nb = Str.search_forward regex filename 0 in
  Str.first_chars filename nb 

let fname f _loc = (getfilename _loc)^"_"^f

exception CannotModifyThis

let rec binding_map isrec _loc b =
  match b with
    | <:binding< $x$ and $y$ >> ->
	let x = binding_map isrec _loc x in
	let y = binding_map isrec _loc y in
	<:binding< $x$ and $y$ >>
    
    
    | <:binding< $p$ = $e$>> ->
      let orig = <:binding< $p$ = $e$>> in
      begin
	match p with
	  | <:patt< $lid:f$  >> ->
	    begin
	      Format.eprintf "patt:%s " f;
	      match e with
		| (* int ref *) <:expr< ref $int:x$>> ->
		  
		  let lexpr = <:expr< Ocamlviz.Value.observe_int_ref $str:fname f _loc$ (ref $int:x$)>> in
		  <:binding< $p$ = $lexpr$ >>
		
		| (* float ref *) <:expr< ref $flo:x$>> -> 
		  let lexpr = <:expr< Ocamlviz.Value.observe_float_ref $str:fname f _loc$ (ref $flo:x$)>> in
		  <:binding< $p$ = $lexpr$ >>
		
		| (* string ref *) <:expr< ref $str:x$>> -> 
		  let lexpr = <:expr< Ocamlviz.Value.observe_string_ref $str:fname f _loc$ (ref $str:x$)>> in
		  <:binding< $p$ = $lexpr$ >>
		 
		| (* bool ref *) <:expr< ref True >> -> 
		  let lexpr = <:expr< Ocamlviz.Value.observe_bool_ref $str:fname f _loc$ (ref true)>> in
		  <:binding< $p$ = $lexpr$ >>
		| <:expr< ref False >> -> 
		  let lexpr = <:expr< Ocamlviz.Value.observe_bool_ref $str:fname f _loc$ (ref false)>> in
		  <:binding< $p$ = $lexpr$ >>
		  
		| (* Hashtbl.create *) <:expr< Hashtbl.create $int:x$>> -> 
		  let lexpr = <:expr< Ocamlviz.Hashtable.observe $str:fname f _loc$ ( Hashtbl.create $int:x$)>> in
		  <:binding< $p$ = $lexpr$ >>		  
		  
		| (* function *) <:expr< fun $x$ -> $ee$ >> -> 
		    let rec iter ee args =
		      match ee with
			  <:expr< fun $x$ -> $ee$ >> ->
			    iter ee (x :: args)
			  | _ ->

			      let rec repl_args args n =
				match args with
				    [] -> []
				  | arg :: args ->
				      <:patt< $lid: Printf.sprintf "xxx%d" n$ >> :: repl_args args (n+1)
			      in
			      let args = repl_args args 0 in
			      let rec iterinv ee args =
				match args with
				    [] -> ee
				  | x :: args ->
				      iterinv <:expr< fun $x$ -> $ee$ >> args
			      in

			      let rec appli ee args = 
				match args with
				  [] -> ee
                                  | x :: args ->
				      match x with
					  <:patt< $lid:name$  >> ->
						let ename = <:expr< $lid:name$ >> in
						appli (<:expr< $ee$ $ename$ >> ) args
					|_ -> assert false
					   
			      in

			      let lexpr =
				if isrec then
				  let ee = appli (<:expr< $lid:f$>>) (List.rev args) in
				   <:expr<
				    let rec $binding:orig$ in
				    
                                    Ocamlviz.Time.start $lid:f^"__tobs"$ ;
                                    Ocamlviz.Point.observe $lid:f^ "__pobs"$;
				    let v = $ee$ in
				    Ocamlviz.Time.stop $lid:f^ "__tobs"$;
                                    v >>

				else
				  
				  <:expr< 
                                    Ocamlviz.Time.start $lid:f^ "__tobs"$ ;
                                Ocamlviz.Point.observe $lid:f^ "__pobs"$; 
                                let v = $ee$ in
                                Ocamlviz.Time.stop $lid:f^ "__tobs"$;
                                v>>
				  
			      in
				  fun_idents := (f, List.length args):: !fun_idents;
				  
				  let ee = iterinv lexpr args in
				  <:binding< $p$ = $ee$>>
		    in
		    iter ee [x]
		  
		  | _ -> raise CannotModifyThis
	    end
	  | _ -> orig
      end
    | _ -> assert false

(*
let is_function b =
  match b with
*)

(* let expr = Gram.Entry.mk "expr";; *)

EXTEND Gram

str_item: LEVEL "top" 

(* [["let"; f = LIDENT; arg = LIDENT ; "=" ; e = expr  ->  *)
(*     <:str_item< let $lid:f$ $lid:arg$ = 2 ;; >> ]]; *)

[[
   "let"; "rec"; b = binding -> 
     begin try 
     fun_idents := []; 
     let b = binding_map true _loc b in
     let str = List.fold_left (fun str (id,_) ->
				 <:str_item<
				   let $lid: id ^ "__pobs"$ = Ocamlviz.Point.create $str:fname id _loc$;;
			       let $lid: id ^ "__tobs"$ = Ocamlviz.Time.create $str:fname id _loc$;;
			       $str$ >>
			      )
       <:str_item< let $binding:b$  ;; >>  !fun_idents
     in
     str
     with CannotModifyThis ->
        <:str_item< let rec $binding:b$  ;; >>
     end
	 
 |
     "let"; b = binding -> 
     begin try 
       fun_idents := []; let b = binding_map false _loc b in 
       let str = List.fold_left (fun str (id,_) ->
				   <:str_item< 
				     let $lid: id ^ "__pobs"$ = Ocamlviz.Point.create $str:fname id _loc$;;
				 let $lid: id ^ "__tobs"$ = Ocamlviz.Time.create $str:fname id _loc$;;
				 $str$ >>
				) 
	 <:str_item< let $binding:b$  ;; >>  !fun_idents 
	 in     
	 str
     with CannotModifyThis ->
        <:str_item< let $binding:b$  ;; >>
     end

    (* List.fold_left (fun str (id,nargs) -> *)
(* 		      let rec iterinv ee nargs = *)
(* 			if nargs = 0 then *)
(* 			    ee *)
(* 			else *)
(* 			  iterinv <:expr< fun $lid: Printf.sprintf "a%d" nargs *)
(* 			    $ -> $ee$ >> (nargs-1) *)
(* 		      in *)
(* 		      let rec iter nargs = *)
(* 			if nargs = 0 then *)
(* 			    <:expr< $lid: id$ >> *)
(* 			else *)
(* 			  let ee = iter (nargs-1) in *)
(* 			  <:expr< $ee$ $lid: Printf.sprintf "a%d" nargs$ >>  *)
(* 		      in *)
(* 		      let apply = iter nargs in *)
(* 		      let body =   (\* <:expr<  *\) *)
(* (\*                                 start $lid:id^ "__tobs"$ ; *\) *)
(* (\*                                 Ocamlviz.Point.observe $lid:id^ "__pobs"$;  *\) *)
(* (\*                                 let v = $apply$ in *\) *)
(* (\*                                 stop $lid:id^ "__tobs"$; *\) *)
(* (\*                                 v>> *\) *)

(* 				  <:expr< *)
(* 			let t0___obs = start () in *)
(* 			let v = $apply$ in *)
(* 			stop t0___obs; *)
(* 			v >> *)
(* 		      in *)
(* 		      let ee = iterinv body nargs in *)
(*                     <:str_item< $str$;; let $lid: id$ = $ee$;; >> *)
(*                  )  *)

(*     str  !fun_idents  *)


 (* | *)

(* "let"; "rec"; b = binding -> fun_idents := []; let b = binding_map _loc b in  *)
(*   List.fold_left (fun str (id, args) -> *)
(*                     <:str_item< let $lid: id ^ "___obs" $ = Ocamlviz.Point.create $str:id$;; $str$ >> *)
(*                  )  *)
(*     <:str_item< let rec  $binding:b$  ;; >>  !fun_idents  *)
 
]];



END;;
