(*
  OCaml Camlp4 syntax extension for (more "perlish") hash tables

  Copyright (C) <2003> Stefano Zacchiroli <zack@cs.unibo.it>

  Created:        Thy, 26 Jun 2003 23:16:14 +0200 zack
  Last-Modified:  Mon, 06 Oct 2003 14:21:35 +0200 zack

  This program is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation; either version 2 of the License, or
  (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
*)

(*
  ----  USAGE  ----

  Hashtbl creation

      (* create an hashtbl of with (initial size = magic_size) *)
    let tbl = {}

      (* create an hashtbl of initial size 12 *)
    let tbl = {}|12|

      (* create an hashbbl of size 3, with bindings specified in an
      associative-list-like manner. If a key occurs more than once the first one
      appearing in the list will be the more recent one. Every expression
      returning an associative list could be used inside braces *)
    let tbl = {}["foo", 1; "bar", 2; "quux", 3]

      (* as above, with initial size 17 *)
    let tbl = {}["foo", 1; "bar", 2; "quux", 3]|17|

  Hashtbl lookup

    tbl{"foo"}            (* Hashtbl.find tbl "foo" *)
    tbl{["foo"]}          (* Hashtbl.find_all tbl "foo" *)
    tbl{?"foo"}           (* Hashtbl.mem tbl "foo" *)

  Hashtbl insertion

    tbl{"foo"} <- 1       (* Hashtbl.replace tbl "foo" 1 *)
    tbl{"foo"} <= 1       (* Hashtbl.add tbl "foo" 1 *)

  Hashtbl deletion

    tbl{"foo"} ->         (* Hashtbl.remove tbl "foo" *)

  Perl-like operators
  [ disabled by default because they are a bit too "invasive", if you would
    like to use them, you should uncomment the corresponding lines in the
    grammar extension below ]

    keys tbl              (* list all keys in tbl *)
    values tbl            (* list all values in tbl, multiple binding are
                          reported more than once *)

  ----  COMPILATION  ----

  Compile the syntax extension with:
    ocamlc -I +camlp4 -c -pp "camlp4o q_MLast.cmo pa_extend.cmo" hashtbl_ext.ml

  Compile your sources with:
    ocaml{c,opt} -pp "camlp4{o,r} hashtbl_ext.cmo" <source.ml>

    # assuming that the .cmo is in a directory that is in the camlp4 path,
    # otherwise you need to add -I to camlp4{o,r} as needed

  ----  QUIRKS  ----

  Hashtbl with lists as keys, (i.e. (_ list, _) Hashtbl.t) [ are you so fool? ]

    tbl{([...])}          (* tbl{[...]} will try to invoke Hashtbl.find_all on
                          the _content_ of the list. Obviously you can do:
                            let key = [...] in tbl{key} *)
*)

open Pcaml

let magic_size = 1024

let hashtbl_find loc tbl k = <:expr< Hashtbl.find ($tbl$) ($k$) >>
let hashtbl_find_all loc tbl k = <:expr< Hashtbl.find_all ($tbl$) ($k$) >>
let hashtbl_mem loc tbl k = <:expr< Hashtbl.mem ($tbl$) ($k$) >>
let hashtbl_add loc tbl k v = <:expr< Hashtbl.add ($tbl$) ($k$) ($v$) >>
let hashtbl_replace loc tbl k v = <:expr< Hashtbl.replace ($tbl$) ($k$) ($v$) >>
let hashtbl_remove loc tbl k = <:expr< Hashtbl.remove ($tbl$) ($k$) >>

let hashtbl_keys loc tbl =
  <:expr< Hashtbl.fold (fun k _ acc -> [k :: acc]) ($tbl$) [] >>
let hashtbl_values loc tbl =
  <:expr< Hashtbl.fold (fun _ v acc -> [v :: acc]) ($tbl$) [] >>

let magic_size = string_of_int magic_size
let hashtbl_create loc size content =
  <:expr<
    let size =
      match ($int:size$) with
      [ 0 ->
          match ($content$) with
          [ [] -> ($int:magic_size$)
          | _ -> List.length ($content$) ]
      | v -> v ]
    in
    let table = Hashtbl.create size in
    do {
      List.iter (fun (k,v) -> Hashtbl.add table k v) ($content$);
      table
    }
  >>

EXTEND

  expr: LEVEL "simple"
    [
      [ "{"; "}";
        content = OPT [ e = expr LEVEL "simple" -> e ];
        size = OPT [ "|"; size = INT; "|" -> size ] ->
          let size = match size with None -> "0" | Some v -> v in
          let content =
            match content with None -> <:expr< [] >> | Some c -> c
          in
          hashtbl_create loc size content
      | table = expr; "{"; key = expr; "}" ->
          hashtbl_find loc table key
      | table = expr; "{"; "["; key = expr; "]"; "}" ->
          hashtbl_find_all loc table key
      | table = expr; "{"; "?"; key = expr; "}" ->
          hashtbl_mem loc table key
      | table = expr; "{"; key = expr; "}"; "<-"; value = expr LEVEL "expr1" ->
          hashtbl_replace loc table key value
      | table = expr; "{"; key = expr; "}"; "<="; value = expr LEVEL "expr1" ->
          hashtbl_add loc table key value
      | table = expr; "{"; key = expr; "}"; "->" ->
          hashtbl_remove loc table key
(*
      | "keys"; e = SELF -> hashtbl_keys loc e
      | "values"; e = SELF -> hashtbl_values loc e
*)
      ]
    ];

END