Source

ocaml-pure-polyrecord / pa_polyrecord.ml

open Camlp4
open PreCast
open Ast

let _loc = Loc.ghost

let hash_variant s =
  let accu = ref 0 in
  for i = 0 to String.length s - 1 do
    accu := 223 * !accu + Char.code s.[i]
  done;
  (* reduce to 31 bits *)
  accu := !accu land (1 lsl 31 - 1);
  (* make it signed for 64 bits architectures *)
  if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu

let rec concat_let_bindings : binding list -> binding = function
  | [] -> BiNil _loc
  | [x] -> x
  | x::xs -> BiAnd (_loc, x, concat_let_bindings xs)

let rec concat_class_str_items = function
  | [] -> CrNil _loc
  | [x] -> x
  | x::xs -> CrSem (_loc, x, concat_class_str_items xs)

let rec create_list : expr list -> expr = function
  | [] -> <:expr< [] >>
  | e::es -> <:expr< $e$ ::$ create_list es $ >>

let rec explode_rec_binding = function
  | RbNil _ -> []
  | RbSem (_, r1, r2) -> explode_rec_binding r1 @ explode_rec_binding r2
  | RbEq  (_, id, e) -> [id, e]
  | RbAnt _ -> assert false

open Syntax

let xlabel_expr_list = Gram.Entry.mk "xlabel_expr_list"
let xlabel_expr = Gram.Entry.mk "xlabel_expr"

let create_var = 
  let cntr = ref 0 in
  fun prefix ->
    incr cntr;
    prefix ^ string_of_int !cntr

EXTEND Gram

  GLOBAL: expr xlabel_expr_list xlabel_expr ;

  xlabel_expr_list:
    [ [ b1 = xlabel_expr; ";"; b2 = SELF -> b1 :: b2
      | b1 = xlabel_expr; ";"            -> [b1]
      | b1 = xlabel_expr                 -> [b1]
    ] ];
  xlabel_expr:
    [ [ i = label; "="; e = expr LEVEL "top" -> (i, e)
      | i = label -> (i, <:expr< $lid:i$ >>)
    ] ]
    ;

  expr: LEVEL "simple"
    [ [ "{|"; lel = TRY [lel = xlabel_expr_list; "|}" -> lel] ->

          let bindings = List.map (fun (l, e) -> <:binding< $lid:l$ = $e$ >>) lel in
          let meths = List.map (fun (l, _) -> 
            <:class_str_item< method $l$ = $lid:l$ >>) lel in
          let o = <:expr< object $concat_class_str_items meths$ end >> in
          let list = create_list (List.map (fun (l, _) -> 
             <:expr< $int: string_of_int (hash_variant l)$, 
                     Obj.repr $lid:l$ >>) lel) 
          in
          let var = create_var "a" in
          <:expr< let $concat_let_bindings bindings$ in
                  let _o = ($o$ : '$var$) in
                  (Polyrecord.create $list$ : '$var$ Polyrecord.t) >>

      | "{|"; e = TRY [e = expr LEVEL "."; "with" -> e]; lel = xlabel_expr_list; "|}" ->
      
          let bindings = List.map (fun (l, e) -> <:binding< $lid:l$ = $e$ >>) lel in
          let meths = List.map (fun (l, _) -> <:expr< o#$l$ = $lid:l$ >>) lel in
          let o = create_list meths in
          let list = create_list (List.map (fun (l, _) -> 
             <:expr< $int: string_of_int (hash_variant l)$, 
                     Obj.repr $lid:l$ >>) lel) 
          in
          let var = create_var "a" in
          <:expr< let e : '$var$ Polyrecord.t = $e$ in
                  let $concat_let_bindings bindings$ in
                  let _o : '$var$ -> _ = fun o -> $o$ in
                  (Polyrecord.update e $list$ : '$var$ Polyrecord.t) >>

      ] ];

  expr: BEFORE "." (* LEFTA *)
     [ [ e = SELF; ".."; l = label; "<-"; e2 = expr LEVEL "top" ->
          
          let var = create_var "a" in
          let res = create_var "res" in 
           <:expr< 
             let e : '$var$ Polyrecord.t = $e$ in
             let e2 : '$res$ = $e2$ in
             let _o : '$var$ -> '$res$ ref = fun o -> o#$l$ in
             Polyrecord.set $e$ $int:string_of_int (hash_variant l)$ (Obj.repr $e2$)
           >> 

       | e = SELF; ".."; l = label -> 

          let var = create_var "a" in
          let res = create_var "res" in 
           <:expr< 
             let e : '$var$ Polyrecord.t = $e$ in
             let _o : '$var$ -> '$res$ = fun o -> o#$l$ in
             (Obj.magic (Polyrecord.get $e$ $int:string_of_int (hash_variant l)$) : '$res$)
           >> 

     ]];

(*
  expr: BEFORE "||"
    [ ":=" NONA
        [ e1 = SELF; "<="; e2 = expr LEVEL "top" ->
            match bigarray_set _loc e1 e2 with
            [ Some e -> e
            | None -> <:expr< $e1$ := $e2$ >> ]
      ] ];
*)

END