Source

orakuda / pa / pa_cformat.ml

Full commit
open Camlp4                                             (* -*- camlp4of -*- *)

(* This module does not provide any parser extension, 
   but a parser tool function for printf format string.
*)
   
module Id : Sig.Id = struct
  let name = "pa_cformat"
  let version = "1.0"
end

module Parser_compiler(Syntax : Sig.Camlp4Syntax) = struct
    
  (* open Sig *)
  open Syntax

  (* open Ast *)
  (* open Printf *)
  open Lexformat

  module Compile = struct
    exception Error of conversion * string

    let format_for_c conv =
      let ctype = match conv.ctype with
        | CF -> Cf (* to get "%f" *)
        | ctype -> ctype
      in
      let conv = { conv with inlined_arg = None; ctype = ctype } in
      compile_conversion conv
    ;;

    (* check we need to call c primitives *)
    let c_primitive conv =
      try
        Some (match conv.ctype with
        | Cd | Cu | Cx | CX | Co -> "int"
        | Cf | Ce | CE | Cg | CG -> "float"
        | Cld | Clu | Clx | ClX | Clo -> "int32"
        | Cnd | Cnu | Cnx | CnX | Cno -> "natint"
        | CLd | CLu | CLx | CLX | CLo -> "int64"
        | CF -> "camlfloat"
        | _ -> raise Not_found)
      with
      | Not_found -> None
    ;;

    let with_width_or_precision conv =
      conv.width <> None || conv.precision <> None
    ;;

    let _concat_expr _loc eopt1 eopt2 = 
      match eopt1, eopt2 with
      | None, None -> None
      | (Some e, None | None, Some e) -> Some e
      | Some e1, Some e2 -> Some (<:expr< $e1$; $e2$ >>)
    ;;

    let _get_arg _loc = <:expr<get_arg ()>>
    ;;
    
    let flush_buffer _loc buf : Ast.expr option =
      let contents = Buffer.contents buf in
      Buffer.clear buf;
      if contents = "" then None
      else Some <:expr< __cformat_out.Orakuda.Cformat.string $str:contents$ >> 
    ;;
    
    let xid = function
      | -1 -> "__cformat_out"
      | n -> Printf.sprintf "__cformat_x%d" n 
    ;;

    let compile_conv 
        _loc 
        buf (* static, non % part *)
        pos (* arg position *) 
        conv 
        : Ast.expr list * (int * (Lexformat.inlined_arg * int) option) list
        =
      if conv.ctype = Cpercent then begin
        Buffer.add_char buf '%';
        [], []
      end else 
        let e, abss = 
          let with_adv_pos ?(by=1) e = pos := !pos + by; e in
          let get_pos ?(add=0) () = 
	    <:expr< $lid: xid (!pos + add) $>>
          in
          match c_primitive conv with
          | Some typ -> 
              begin match format_for_c conv with
	      | [] -> assert false
	      | [ `String fmt ] -> 
    	          with_adv_pos 
    	            (<:expr< __cformat_out.Orakuda.Cformat.string 
			(Orakuda.Cformat.$lid:"format_" ^ typ$ 
			    $str:fmt$ $get_pos ()$) >>,
		    [!pos, conv.inlined_arg])
	      | tokens -> 
		  let rev_parameters, rev_tokens = 
		    List.fold_left (fun (params, tokens) token ->
		      match token with
		      | `String s -> (params, <:expr<$str:s$>> :: tokens)
		      | `Star -> 
			  let param = !pos in 
			  let var = get_pos () in
			  incr pos;
			  (param :: params, var :: tokens))
		      ([], []) tokens
		  in
		  let parameters = List.rev rev_parameters in
		  let tokens = List.rev rev_tokens in
		  let fmt = 
		    List.fold_left (fun acc exp ->
		      <:expr<$acc$ ^ $exp$>>) (List.hd tokens) (List.tl tokens)
		  in
		  with_adv_pos
		    (<:expr< __cformat_out.Orakuda.Cformat.string
			(Orakuda.Cformat.$lid:"format_" ^ typ$
			    $fmt$ $get_pos ()$)>>,
		    List.map (fun param -> param, None) parameters @
		      [!pos, conv.inlined_arg])
              end
          | None ->
              match conv.ctype with
              | Cpercent 
              | Cd | Cu | Cx | CX | Co
              | Cf | Ce | CE | Cg | CG
              | Cld | Clu | Clx | ClX | Clo
              | Cnd | Cnu | Cnx | CnX | Cno
              | CLd | CLu | CLx | CLX | CLo
              | CF -> assert false
                  
              | (Cs | CS | Cc | CC | CB | Ca | Ct 
    	        | Cformat _ | Cformat_subst _ | Cflush ) 
    	          when with_width_or_precision conv ->
    	          raise (Error (conv, "no width nor precision allowed"))
                    
              | Cs -> 
	          with_adv_pos 
		    (<:expr< __cformat_out.Orakuda.Cformat.string 
			$get_pos ()$ >>,
		    [!pos, conv.inlined_arg])
              | CS -> 
	          with_adv_pos 
		    (<:expr< __cformat_out.Orakuda.Cformat.caml_string
			$get_pos ()$ >>,
		    [!pos, conv.inlined_arg])
		    
              | Cc -> 
	          with_adv_pos 
		    (<:expr< __cformat_out.Orakuda.Cformat.char $get_pos ()$ >>,
		    [!pos, conv.inlined_arg])
              | CC -> 
	          with_adv_pos 
		    (<:expr< __cformat_out.Orakuda.Cformat.caml_char 
			$get_pos ()$ >>,
		    [!pos, conv.inlined_arg])
              | CB -> 
	          with_adv_pos 
		    (<:expr< __cformat_out.Orakuda.Cformat.bool $get_pos ()$ >>,
		    [!pos, conv.inlined_arg])
              | Ca -> 
		  (* Ca cannot take ${} *)
		  if conv.inlined_arg <> None then 
    	            raise (Error (conv, 
				 "cannot take inlined argument. use %t"));
    	          with_adv_pos ~by:2
    	            (<:expr< 
			__cformat_out.Orakuda.Cformat.formatf 
			  $get_pos ()$ 
			  $get_pos ~add:1 ()$ 
	              >>,
		    [!pos, None; !pos+1, None])
              | Ct -> 
    	          with_adv_pos
    	            (<:expr< __cformat_out.Orakuda.Cformat.formatf 
			$get_pos ()$ () >>,
		    [!pos, conv.inlined_arg])
              | Cflush -> 
		  (* no ${} *)
		  if conv.inlined_arg <> None then 
    	            raise (Error (conv,
				 "cannot take inlined argument"));
		  (<:expr< __cformat_out.Orakuda.Cformat.flush () >>, [])
              | _ -> raise (Error (conv, "not supported")) 
        in
        let es = 
          match flush_buffer _loc buf with
          | None -> [e]
          | Some e' -> [e'; e]
        in
        es, abss
    ;;

    let compile_token _loc buf pos = function
      | String s -> Buffer.add_string buf s; [], []
      | Escaped c -> Buffer.add_char buf c; [], []
      | Conv conv -> compile_conv _loc buf pos conv
    ;;

    let compile _loc tokens = 
      let buf = Buffer.create 128 in
      let pos = ref 0 in
      let es, abss =
	let es_list, abss_list = 
	  List.split
	    (List.map (compile_token _loc buf pos) tokens)
	in
	let es = 
          let es = List.concat es_list in
          match flush_buffer _loc buf with
          | None -> es
          | Some e -> es @ [e] (* CR jfuruse: ugly *)
        in
	let abss = List.concat abss_list in
        es, abss
      in
      let put_abstract e i = <:expr< fun $lid: xid i$ -> $e$ >> in
      let rec abstract e = function
	| [] -> e
	| (i,_)::is -> put_abstract (abstract e is) i
      in
      (* code *)
      let e = 
        List.fold_right (fun e acc ->
	  <:expr<$e$; $acc$>>) es <:expr<__cformat_out.Orakuda.Cformat.finish ()>>
      in 
      let abss = (-1, None) :: abss in
      let e =
	abstract
	  <:expr< ( 
	    $abstract e 
              (List.filter (function (_, None) -> true | _ -> false)  abss)$
	      : (_,_) Orakuda.Cformat.t) >>
	  (List.filter (function (_, None) -> false | _ -> true) abss) 
      in

      let put_app e = function
	| (_, None) -> e
	| (_, Some (arg, _pos)) ->
	    let str =
	      match arg with
	      | (Arg_expr str | Arg_var str) -> str
  	      | Arg_rex_ref var ->
		  match var with
		  | '0' .. '9' -> Printf.sprintf "_%c" var
		  | '`' -> "_left"
		  | '\'' -> "_right"
		  | '&' -> "_0"
		  | '+' -> "_last"
		  | _ -> assert false
	    in
  	    (* CR jfuruse: use pos *)
  	    <:expr<$exp:e$ $exp:AntiquotSyntax.parse_expr _loc str$>>
      in
      let put_apps e = 
	List.fold_left put_app e abss
      in

(*
  	| `Applied (Arg_rex_ref var, _pos) :: xs ->
            let meth = match var with
              | '0' .. '9' -> Printf.sprintf "_%c" var
              | '`' -> "_left"
              | '\'' -> "_right"
              | '&' -> "_0"
              | '+' -> "_last"
              | _ -> assert false
            in
  	    (* CR jfuruse: use pos *)
  	    put_apps 
  	    <:expr<$exp:e$ __rex_group#$meth$ >> 
*)
	e, put_apps
  end
  ;;

  module Top = Pa_top.Register(Syntax)

  let parse specials _loc _loc_var_opt s =
    match Lexformat.from_string specials s with
    | _, pos, rem when rem <> "" -> 
        raise (Lexformat.Error (pos, pos + 1,
		                Printf.sprintf "Unescaped special character %C found" rem.[0]))
    | t, _, _ -> 
        let e, inlined_f = Compile.compile _loc t in
        inlined_f (Top.may_put_in_top e)
  ;;
end

module Make(Syntax : Sig.Camlp4Syntax) = struct
    
  (* open Sig *)

  include Syntax

  (* open Ast *)
  (* open Printf *)
  (* open Lexformat *)

  module Parser = Parser_compiler(Syntax)

  let _ = 
    Syntax.Quotation.add "fmt"
      Syntax.Quotation.DynAst.expr_tag (Parser.parse ['"']);

    Syntax.Quotation.add "fmt"
      Syntax.Quotation.DynAst.str_item_tag
      (fun _loc _loc_var_opt s ->
	let e = Parser.parse ['"'] _loc _loc_var_opt s in
	<:str_item< $exp:e$ >>);
  ;;
end

let module M = Register.OCamlSyntaxExtension(Id)(Make) in ()