(* $Id: xstrp4_here.ml.310 31 2007-08-05 21:14:11Z gerd $
 * ----------------------------------------------------------------------
 *
 *)

open Xstrp4_here_types
open Camlp4.PreCast
open Syntax

let camlp4loc (loc1,loc2) =
  Loc.merge
    (Loc.of_lexing_position loc1)
    (Loc.of_lexing_position loc2)
    


let interpolated_expr lexbuf _loc =
  (* Parse [lexbuf], and generate the syntax tree for the corresponding expression.
   *)

  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 =
    { Lexing.pos_fname = Loc.file_name _loc;
      Lexing.pos_lnum = p.Lexing.pos_lnum + Loc.start_line _loc - 1;
      Lexing.pos_cnum = p.Lexing.pos_cnum + Loc.start_off _loc;
      Lexing.pos_bol  = p.Lexing.pos_bol  + Loc.start_bol _loc;
    }
  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 toklist_ast =
    List.map
      (function
	   Literal(s,lexloc) -> 
	     let _loc = camlp4loc lexloc in
	     <:expr< $str:s$ >>	
	 | Variable (sl,fmt,lexloc) -> 
	     let _loc = camlp4loc lexloc in
	     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@here< [] >>
      | x :: l' ->
	  let ast_l' = mk_list_ast l' in
	  <:expr@here< [ $x$ :: $ast_l'$ ] >>
  in

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

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


let here_expr _loc _loc_name s =
  let lexbuf = Lexing.from_string s in
  interpolated_expr lexbuf _loc
;;

let interpolated_file filename _loc =
  let pathname =
    if Filename.is_implicit filename then
      Filename.concat (Filename.dirname (Loc.file_name _loc)) filename 
    else
      filename
  in
  let f = open_in pathname in
  let lexbuf = Lexing.from_channel f in
  let _loc =
    Loc.of_tuple
      (pathname, 1, 0, 0, 1, 0, 0, false) in
  interpolated_expr lexbuf _loc
;;


let included_file filename _loc =
  let pathname =
    if Filename.is_implicit filename then
      Filename.concat (Filename.dirname (Loc.file_name _loc)) 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;
  <:expr< $str:s$ >>
;;


let interpolation = Gram.Entry.mk "interpolation";;

EXTEND Gram
  interpolation:
    [[ s = STRING -> 
	 let lexbuf = Lexing.from_string s in
	 interpolated_expr lexbuf _loc
     ]];

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

END
;;


Quotation.add
  "here"
  Syntax.Quotation.DynAst.expr_tag
  here_expr
;;