(* $Id$
 * ----------------------------------------------------------------------
 *
 *)

open Xstrp4_here_types
open Pcaml

(* Note: Since O'Caml 3.09, the location variable is called "_loc" while
 * in earlier versions it was called "loc". Fortunately, 3.09 allows it
 * to set the name of the variable with the -loc option.
 *)



let interpolated_expr ?(fname="") 
                      ?(lnum_offset=0) ?(cnum_offset=0) ?(bol_offset=0)
		      lexbuf =
  (* Parse [lexbuf], and generate the syntax tree for the corresponding expression.
   * The locations in this tree are relative to [s]! Before inserting the tree
   * into the surrounding tree an antiquotation node should be created.
   *)

  let rec parse_here_expr() =
    let tok = Xstrp4_here_lexer.token lexbuf in
      match tok with
	  Textend -> []
	| x       -> x :: parse_here_expr ()
  in

  let rec normalize_literals =
    (* - Concat adjacent literals
     * - Remove empty literals
     *)
    function
	[] -> 
	  []
      | Literal("",_) :: tl -> 
	  normalize_literals tl
      | Literal(s1,(p1,_)) :: (Literal(s2,(_,p2))) :: tl -> 
	  normalize_literals((Literal(s1^s2,(p1,p2)))::tl)
      | hd :: tl ->
	  hd :: (normalize_literals tl)
  in

  let fix_position p =
    {p with 
       Lexing.pos_fname = fname;
       Lexing.pos_lnum = p.Lexing.pos_lnum + lnum_offset;
       Lexing.pos_cnum = p.Lexing.pos_cnum + cnum_offset + 1;
       Lexing.pos_bol  = p.Lexing.pos_bol  + bol_offset;
    }
  in		   

  let fix_positions =
    function
	Literal(s, (p1, p2)) -> 
	  Literal(s, (fix_position p1, fix_position p2))
      | Variable(sl, fmt, (p1, p2)) ->
	  Variable(sl, fmt, (fix_position p1, fix_position p2))
      | other -> 
	  other
  in

  let toklist = 
    List.map fix_positions (normalize_literals (parse_here_expr ())) in
  let loc = 
    let start_pos =
      match toklist with
	  Literal(_,(l1,_)) :: _ -> l1
	| Variable(_,_,(l1,_)) :: _ -> l1
	| _ -> Lexing.dummy_pos
    in
    let end_pos =
      match List.rev toklist with
	  Literal(_,(_,l2)) :: _ -> l2
	| Variable(_,_,(_,l2)) :: _ -> l2
	| _ -> Lexing.dummy_pos
    in
    (start_pos, end_pos)
  in

  let toklist_ast =
    List.map
      (function
	   Literal(s,loc) -> <:expr< $str:s$ >>
	 | Variable (sl,fmt,loc) -> 
	     let rec translate_id sl =
	       match sl with
		   s :: ((s' :: _) as sl') -> 
		     let moduleid_ast = <:expr< $uid:s$ >> in
		     let valueid_ast = translate_id sl' in
		     <:expr< $moduleid_ast$ . $valueid_ast$ >>
		 | [s] ->
		     <:expr< $lid:s$ >>
		 | _ ->
		     failwith "Xstrp4.here_expr"
	     in
	     let node =  match fmt with
		 "%s" -> translate_id sl
	       | ("%d"|"%i") -> 
		   let id = translate_id sl in
		   <:expr< $lid:"string_of_int"$ $id$ >>
	       | _ ->
		   let id = translate_id sl in
		   <:expr< ( ( $uid:"Printf"$ . $lid:"sprintf"$ ) 
			     $str:fmt$
			   ) 
		           $id$ >>
	     in
	     node
	 | Textend -> failwith "Xstrp4.here_expr")
      toklist
  in

  let rec mk_list_ast l =
    match l with 
	[] -> <:expr< [] >>
      | x :: l' ->
	  let ast_l' = mk_list_ast l' in
	  <:expr< [ $x$ :: $ast_l'$ ] >>
  in

  let string_mod_ast =    <:expr< $uid:"String"$ >> in
  let concat_val_ast =    <:expr< $lid:"concat"$ >> in
  let string_concat_ast = <:expr< $string_mod_ast$ . $concat_val_ast$ >> in
  let concat_ast =        <:expr< $string_concat_ast$ $str:""$ >> in
  let list_ast =          mk_list_ast toklist_ast in
  let result_ast =        <:expr< $concat_ast$ $list_ast$ >> in

  match toklist with
      [] ->
	<:expr< $str:""$ >>
    | [Literal s] ->
	List.hd toklist_ast   (* = <:expr< $str:s$ >> *)
    | _ ->
	(* General case: *)
	result_ast
;;


let here_expr s =
  let lexbuf = Lexing.from_string s in
  let result_ast = interpolated_expr ~lnum_offset:(-1) lexbuf in
  let loc = (Lexing.dummy_pos, Lexing.dummy_pos) in
  (* <:expr< $anti:result_ast$ >> *)
  result_ast     (* For O'Caml 3.08, this creates better error positions! *)
;;


let interpolated_file filename =
  let pathname =
    if Filename.is_implicit filename then
      Filename.concat (Filename.dirname !input_file) filename 
    else
      filename
  in
  let f = open_in pathname in
  let lexbuf = Lexing.from_channel f in
  let result_ast = interpolated_expr ~fname:pathname lexbuf in
  let loc = (Lexing.dummy_pos, Lexing.dummy_pos) in
            (* Will be replaced anyway by camlp4 *)
  <:expr< $anti:result_ast$ >>
;;


let included_file filename =
  let pathname =
    if Filename.is_implicit filename then
      Filename.concat (Filename.dirname !input_file) filename 
    else
      filename
  in
  let f = open_in pathname in
  let n = in_channel_length f in
  let s = String.create n in
  really_input f s 0 n;
  close_in f;
  let start_p = { Lexing.pos_fname = pathname;
		  pos_lnum = 1;
		  pos_bol = 0;
		  pos_cnum = 0 } in
  let end_p = { Lexing.pos_fname = pathname;
		pos_lnum = 1;
		pos_bol = 0;
		pos_cnum = n } in
  let loc = (start_p, end_p) in
  <:expr< $str:s$ >>
;;


let here_pat s =
  failwith "<<:here< >> documents not allowed in patterns"
;;


let interpolation = Grammar.Entry.create Pcaml.gram "interpolation";;

EXTEND
  interpolation:
    [[ s = STRING -> 
	 let (start_p,_) = loc in
	 let lexbuf = Lexing.from_string s in
	 interpolated_expr 
	   ~lnum_offset:(start_p.Lexing.pos_lnum - 1)
	   ~cnum_offset:(start_p.Lexing.pos_cnum)
	   ~bol_offset:(start_p.Lexing.pos_bol)
	   lexbuf 
     ]];

  expr: AFTER "simple"
    [[ "interpolate"; "file"; s = STRING -> interpolated_file s
     | "interpolate"; expr = interpolation -> expr
     | "include_file"; s = STRING -> included_file s
     ]];

END
;;


Quotation.add
   "here"
   (Quotation.ExAst(here_expr, here_pat))
;;