(* Copyright (c) 2004-2007, Virgile Prevosto
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *     * Redistributions in binary form must reproduce the above copyright
 *       notice, this list of conditions and the following disclaimer in the
 *       documentation and/or other materials provided with the distribution.
 *     * The names of its contributors may not be used to endorse or promote
 *       products derived from this software without specific prior
 *       written permission.
 *
 * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY
 * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 * DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
 * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
 * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
 * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)

(** syntactic sugar to choose modules implementation according to some
    condition.
*)

(* incompatible with ocaml 3.10. Usage:
   ocamlc -pp camlp4o choose_module.cmo file.ml

   added expressions:

   choose_module M = match e with Foo when true -> M1 | _ -> Mdefault in M.x

   register_module "ident" M1,M2,M3 in choice
   select_module A from choice using e with F in A.x

   register and select use an intermediate file, choice.p4o, written by
   register and read by select. if e is equal to "ident", then A will be
   bound to F(M1,M2,M3)

*)

open Pcaml

let choices = Grammar.Entry.create Pcaml.gram "choices"

(* extension of file storing list of module choices. *)
let ext = ".p4o"

let open_path open_func f =
  if Sys.file_exists f then
    open_func f
  else
    let rec try_dir lst  =
      match lst with
          [] -> raise Not_found
        | a::l ->
            let fpath = Filename.concat a f in
              if Sys.file_exists fpath then
                open_func fpath
              else try_dir l
    in try_dir !Odyl_main.path

let open_in_path = open_path open_in_bin
let open_out_path = open_path open_out_bin

let make_one_choice a mod_expr exp =
  let _loc = Lexing.dummy_pos, Lexing.dummy_pos in
    <:expr<let module $uid:a$ = $mod_expr$ in $exp$>>

EXTEND
    expr: [[
            "choose_module"; a = UIDENT; "="; "match" ; cond = expr; "with";
            OPT "|"; l = LIST1 choices SEP "|";
            "in"; e = expr ->
              let new_l = List.map
                            (fun (patt,optwhen,expr) ->
                               (patt,optwhen, make_one_choice a expr e)) l
              in  <:expr< match $cond$ with [$list:new_l$] >>
          | "register_module"; opt=STRING; l=LIST1 module_expr SEP ","; "in";
                  store = LIDENT ->
                    let filename = store ^ ext in
                    let current_table =
                      try
                        let chan = open_in_path filename in
                        let res = Marshal.from_channel chan in
                          close_in chan; res
                      with Not_found | End_of_file -> Hashtbl.create 7
                    in
                      Hashtbl.replace current_table opt l;
                      let chan =
                        try open_out_path filename
                        with Not_found -> open_out_bin filename
                      in
                        Marshal.to_channel chan current_table [];
                        flush chan; close_out chan;
                        <:expr< $str:opt$ >>
          | "select_module"; a = UIDENT; "from"; store = LIDENT; "using";
                  choice = expr;
                  post_process = OPT ["with"; m = module_expr -> m];
                  "in"; e = expr ->
                    let apply f x = <:module_expr< $f$ $x$>> in
                    let create_mod_value l =
                      match post_process with
                          None -> List.hd l
                        | Some s -> List.fold_left apply s l
                    in
                    let selection =
                      try
                        let chan = open_in_path (store ^ ext) in
                        let res =
                          Marshal.from_channel chan
                        in close_in chan; res
                      with Not_found | End_of_file  ->
                        Hashtbl.create 1
                    in
                    let patts =
                      Hashtbl.fold
                        (fun patt -> fun mod_expr_list -> fun l ->
                           (<:patt<$str:patt$>>, None,
                            make_one_choice a
                              (create_mod_value mod_expr_list) e)
                           :: l)
                        selection [ <:patt< _ >>, None,
                                    <:expr< failwith
                                      ("not a valid option for selection of "
                                      ^ $str:store$)>>
                                  ]
                    in <:expr< match $choice$ with [$list:patts$]>>
]];

  choices: [[ p=patt; w = OPT ["when"; e = expr -> e]; "->"; m = module_expr ->
                (p,w,m)
            ]];
END