Source

orakuda / pa / pa_top.ml

The default branch has multiple heads

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

let seed = Digest.to_hex (Digest.string (String.concat " " (Array.to_list Sys.argv)))

module Id : Sig.Id = struct
  let name = "pa_top"
  let version = "1.0"
end

module M = struct
  open PreCast

  let exprs = ref ([] : (string * PreCast.Syntax.Ast.expr) list) 
  ;;

  let create_expr_id = 
    let cntr = ref 0 in
    fun () -> 
      incr cntr; 
      Printf.sprintf "__top_%s_expr%d" seed !cntr
  ;;

  let in_implem = ref false
  let set_in_implem () = in_implem := true

  let may_put_in_top e =
    if !in_implem then 
      let id = create_expr_id () in
      exprs := (id,e) :: !exprs;
      let _loc = Ast.loc_of_expr e in
      <:expr<$lid:id$>>
    else e
  ;;
end

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

  open Ast
  (* open Printf *)

  let stopped_at _loc =
    Some (Loc.move_line 1 _loc) (* FIXME be more precise *)

  let _ = Gram.Entry.clear implem

  EXTEND Gram
    GLOBAL: implem
  ;

  implem_:
      [ [ "#"; n = a_LIDENT; dp = opt_expr; semi ->
            ([ <:str_item< # $n$ $dp$ >> ], stopped_at _loc)
        | si = str_item; semi; (sil, stopped) = SELF -> (si :: sil, stopped)
        | `EOI -> ([], None)
      ] ]
    ;

  implem:
    [ 
      [ in_implem;
	(sitems, stopped) = implem_ ->
	  let expr_defs =
	    List.map (fun (id, exp) ->
	      let exp = (Obj.magic exp : Ast.expr) in
	      let _loc = Ast.loc_of_expr exp in
	      <:str_item<let $lid:id$ = $exp:exp$>>) 
	      (List.rev !M.exprs)
	  in
	  M.exprs := [];
	  (expr_defs @ sitems), stopped
      ]
    ];

  in_implem:
    [ [ -> M.set_in_implem () ]
    ];

  END

end

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

module Register (Syntax: Sig.Camlp4Syntax) = struct
  open Syntax
  let may_put_in_top (e : Ast.expr) = 
    (Obj.magic (M.may_put_in_top (Obj.magic e)) : Ast.expr);; 
end