Source

orakuda / pa / pa_format.ml

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

(* This module does not provide any parser extension, 
   but a parser tool function for printf format string.
*)
   
module Make(Syntax : Sig.Camlp4Syntax) = struct
    
  (* open Sig *)
  open Syntax
  (* open Ast *)
  (* open Printf *)
  open Lexformat

  let parse specials _loc _loc_var_opt s =
    let t, (abss, apps), fmt, rems = Lexformat.from_string_to_classic specials s in
    let string_constant =
      List.for_all (function 
	| String _ | Char _ | Escaped _ -> true
	| Conv _ -> false) t
    in
    let v = 
      if string_constant then `Const <:expr<$str:fmt$>>
      else 
        `Fun (abss, fun fnct ->
	  let base = <:expr<$fnct$ $str:fmt$>> in
	  let id n = Printf.sprintf "id%d" n in
	  let rec put_apps e = function
	    | [] -> e
	    | `Var n ::xs -> 
	        let id = id n in
	        put_apps <:expr<$exp:e$ $lid:id$>> xs
	    | `Applied ((Arg_expr str | Arg_var str), _pos) :: xs ->
	        put_apps 
	        <:expr<$exp:e$ $exp:AntiquotSyntax.parse_expr _loc str$>> 
		  xs
	    | `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
	        put_apps 
	        <:expr<$exp:e$ __rex_group#$meth$ >> 
		  xs
	  in
	  let rec put_abss e = function
	    | [] -> e
	    | n::ns ->
	        let id = id n in 
	        put_abss <:expr<fun $lid:id$ -> $exp:e$>> ns
	  in
	  put_abss (put_apps base apps) abss)
    in
    v, rems
end