(*
  With ocamlbuild:
    To compile (using this _tags file):
      ocamlbuild pa_oo.cmo
    To use:
      ocaml camlp4o.cma ./_build/pa_oo.cmo
    or
      ocamlc -pp 'camlp4o ./_build/pa_oo.cmo'

  Without:
    To compile:
      ocamlc -I +camlp4 -c -pp camlp4orf pa_oo.ml
    To use:
      ocaml camlp4o.cma pa_oo.cmo
    or
      ocamlc -pp 'camlp4o -I . pa_oo.cmo'
*)

open Camlp4.PreCast

module Caml = Syntax

let expand_access _loc mut id e kind =
  let id' = id^"'" in
  let reader = <:class_str_item< method $id$ = $lid:id$ >>
  and writer =
    <:class_str_item< method $"set_"^id$ $lid:id'$ = $lid:id$ := $lid:id'$ >>
  in
  let accessors =
    match kind with None -> <:class_str_item<>>
    | Some k -> match k with
      | `R -> reader
      | `W -> writer
      | `RW -> <:class_str_item< $reader$; $writer$ >>
  in
  <:class_str_item<
    value $mutable:mut$ $lid:id$ = $e$;
    $accessors$
  >>

(* Copied from camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml *)
let bigarray_set _loc var newval =
  match var with
  | <:expr< Bigarray.Array1.get $arr$ $c1$ >> ->
      Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >>
  | <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> ->
      Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >>
  | <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> ->
      Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >>
  | <:expr< Bigarray.Genarray.get $arr$ [| $coords$ |] >> ->
      Some <:expr< Bigarray.Genarray.set $arr$ [| $coords$ |] $newval$ >>
  | _ -> None

let expand_set _loc e1 e2 =
  match bigarray_set _loc e1 e2 with
  | Some e -> e
  | None -> match e1 with
    | <:expr< $o$ # $x$ >> -> <:expr< $o$ # $"set_"^x$ $e2$ >>
    | _ -> <:expr< $e1$ := $e2$ >>

DELETE_RULE Caml.Gram Caml.expr: SELF; "<-"; Caml.expr LEVEL "top" END;;

EXTEND Caml.Gram
  GLOBAL: Caml.class_str_item Caml.expr Caml.opt_mutable Caml.ctyp;
  Caml.class_str_item: [
    [ "val"; "mutable"; `LIDENT lab; e = cvalue_binding; kind = cvalue_kind ->
      expand_access _loc Ast.BTrue lab e kind
    | "val"; `LIDENT lab; e = cvalue_binding; kind = cvalue_kind ->
      expand_access _loc Ast.BFalse lab e kind ]
  ];
  cvalue_kind: [
    [ kind = OPT [ "with"; k =
       [ "reader" -> `R | "writer" -> `W | "accessor" -> `RW ] -> k] ->
      kind ]
  ];
  cvalue_binding: [
    [ "="; e = Caml.expr -> e
    | ":"; t = Caml.ctyp; "="; e = Caml.expr -> <:expr< ($e$ : $t$) >> ]
  ];
  Caml.expr: LEVEL ":=" [
    [ e1 = SELF; "<-"; e2 = Caml.expr LEVEL "top" -> expand_set _loc e1 e2 ]
  ];
  Caml.expr: LEVEL "simple" [
    [ "{|"; cf = LIST1 obj_record SEP ";"; "|}" ->
      (* self = OPT
        [ "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
        | "("; p = patt; ")" -> <:patt< $p$ >> ]; *)
      <:expr< object $Ast.crSem_of_list cf$ end >> ]
  ];
  obj_record: [
    [ "inherit"; ce = Caml.class_expr -> <:class_str_item< inherit $ce$ >>
    | mf = Caml.opt_mutable; `LIDENT lab; ty = OPT [ ":"; t = Caml.ctyp -> t];
      "="; e = Caml.expr LEVEL "top" ->
        expand_access _loc mf lab e (Some(if mf = Ast.BFalse then `R else `RW)) ]
  ];
END;;