(****************************************************************************)
(*                                                                          *)
(*                                   OCaml                                  *)
(*                                                                          *)
(*                            INRIA Rocquencourt                            *)
(*                                                                          *)
(*  Copyright  2007   Institut National de Recherche  en  Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed under   *)
(*  the terms of the GNU Library General Public License, with the special   *)
(*  exception on linking described in LICENSE at the top of the Camlp4      *)
(*  source tree.                                                            *)
(*                                                                          *)
(****************************************************************************)

open Camlp4;
open PreCast;
module MapTy = Map.Make String;

type t =
  { name : Ast.ident;
    type_decls : MapTy.t Ast.ctyp;
    acc : Ast.expr;
    app : Ast.expr;
    id  : Ast.expr;
    tup : Ast.expr;
    com : Ast.expr;
    str : Ast.expr;
    int : Ast.expr;
    flo : Ast.expr;
    chr : Ast.expr;
    ant : Ast.ident;
  };

value _loc = Loc.ghost;

value x i = <:ident< $lid:"x"^string_of_int i$ >>;

value meta_ s = <:ident< $lid:"meta_"^s$ >>;

value mf_ s = "mf_" ^ s;

value rec string_of_ident =
  fun
  [ <:ident< $lid:s$ >> -> s
  | <:ident< $uid:s$ >> -> s
  | <:ident< $i1$.$i2$ >> -> "acc_" ^ (string_of_ident i1) ^ "_" ^ (string_of_ident i2)
  | <:ident< $i1$ $i2$ >> -> "app_" ^ (string_of_ident i1) ^ "_" ^ (string_of_ident i2)
  | <:ident< $anti:_$ >> -> assert False ];

value fold_args ty f init =
  let (_, res) =
    List.fold_left begin fun (i, acc) ty ->
      (succ i, f ty i acc)
    end (0, init) ty
  in res;

value fold_data_ctors ty f init =
  let rec loop acc t =
    match t with
    [ <:ctyp< $uid:cons$ of $ty$ >> -> f cons (Ast.list_of_ctyp ty []) acc
    | <:ctyp< $uid:cons$ >> -> f cons [] acc
    | <:ctyp< $t1$ | $t2$ >> -> loop (loop acc t1) t2
    | <:ctyp<>> -> acc
    | _ -> assert False ] in
  loop init ty;

value fold_type_decls m f init =
  MapTy.fold f m.type_decls init;

value patt_of_data_ctor_decl cons tyargs =
  fold_args tyargs begin fun _ i acc ->
    <:patt< $acc$ $id:x i$ >>
  end <:patt< $id:cons$ >>;

value expr_of_data_ctor_decl cons tyargs =
  fold_args tyargs begin fun _ i acc ->
    <:expr< $acc$ $id:x i$ >>
  end <:expr< $id:cons$ >>;

value is_antiquot_data_ctor s =
  let ls = String.length s in
  ls > 3 && String.sub s (ls - 3) 3 = "Ant";

value rec meta_ident m =
  fun
  [ <:ident< $i1$.$i2$ >> -> <:expr< Ast.IdAcc _loc $meta_ident m i1$ $meta_ident m i2$ >>
  | <:ident< $i1$ $i2$ >> -> <:expr< Ast.IdApp _loc $meta_ident m i1$ $meta_ident m i2$ >>
  | <:ident< $anti:s$ >>  -> <:expr< $anti:s$ >>
  | <:ident< $lid:s$ >>   -> <:expr< Ast.IdLid _loc $str:s$ >>
  | <:ident< $uid:s$ >>   -> <:expr< Ast.IdUid _loc $str:s$ >> ];
value m_app m x y = <:expr< $m.app$ _loc $x$ $y$ >>;
value m_id m i = <:expr< $m.id$ _loc $i$ >>;
value m_uid m s = m_id m (meta_ident m <:ident< $uid:s$ >>);

value failure = <:expr< raise (Failure "MetaGenerator: cannot handle that kind of types") >>;

value mk_meta m =
  let m_name_uid x = <:ident< $m.name$.$uid:x$ >> in
  fold_type_decls m begin fun tyname tydcl binding_acc ->
    match tydcl with
    [ Ast.TyDcl _ _ tyvars <:ctyp< [$ty$] >> _ ->
      let match_case =
        fold_data_ctors ty begin fun cons tyargs acc ->
          let m_name_cons = m_name_uid cons in
          let init = m_id m (meta_ident m m_name_cons) in
          let p = patt_of_data_ctor_decl m_name_cons tyargs in
          let e =
            if List.mem cons  ["BAnt"; "OAnt"; "LAnt"; "ReAnt"; "DiAnt";
                               "MuAnt"; "PrAnt"; "ViAnt"; "OvAnt"; "RvAnt"] then
              <:expr< $id:m.ant$ _loc x0 >>
            else if is_antiquot_data_ctor cons then
              expr_of_data_ctor_decl m.ant tyargs
            else
              fold_args tyargs begin fun ty i acc ->
                let rec fcall_of_ctyp ty =
                  match ty with
                  [ <:ctyp< $id:id$ >> ->
                      <:expr< $id:meta_ (string_of_ident id)$ >>
                  | <:ctyp< ($t1$ * $t2$) >> ->
                      <:expr< fun _loc (x1, x2) ->
                                $m.tup$ _loc
                                  ($m.com$ _loc
                                    ($fcall_of_ctyp t1$ _loc x1)
                                    ($fcall_of_ctyp t2$ _loc x2)) >>
                  | <:ctyp< $t1$ $t2$ >> ->
                      <:expr< $fcall_of_ctyp t1$ $fcall_of_ctyp t2$ >>
                  | <:ctyp< '$s$ >> -> <:expr< $lid:mf_ s$ >>
                  | _ -> failure ]
                in m_app m acc <:expr< $fcall_of_ctyp ty$ _loc $id:x i$ >>
              end init
          in <:match_case< $p$ -> $e$ | $acc$ >>
        end <:match_case<>> in
        let funct =
          List.fold_right begin fun tyvar acc ->
            match tyvar with
            [ <:ctyp< +'$s$ >> | <:ctyp< -'$s$ >> | <:ctyp< '$s$ >> ->
                <:expr< fun $lid:mf_ s$ -> $acc$ >>
            | _ -> assert False ]
          end tyvars <:expr< fun _loc -> fun [ $match_case$ ] >>
        in <:binding< $binding_acc$ and $lid:"meta_"^tyname$ = $funct$ >>
    | Ast.TyDcl _ _ _ _ _ -> binding_acc
    | _ -> assert False ]
  end <:binding<>>;

value find_type_decls = object
  inherit Ast.fold as super;
  value accu = MapTy.empty;
  method get = accu;
  method ctyp =
    fun
    [ Ast.TyDcl _ name _ _ _ as t -> {< accu = MapTy.add name t accu >}
    | t -> super#ctyp t ];
end;

value filter st =
  let type_decls = lazy (find_type_decls#str_item st)#get in
  object
   inherit Ast.map as super;
   method module_expr me =
     let mk_meta_module m =
       let bi = mk_meta m in
       <:module_expr<
        struct
          value meta_string _loc s = $m.str$ _loc (safe_string_escaped s);
          value meta_int _loc s = $m.int$ _loc s;
          value meta_float _loc s = $m.flo$ _loc s;
          value meta_char _loc s = $m.chr$ _loc (String.escaped s);
          value meta_bool _loc =
            fun
            [ False -> $m_uid m "False"$
            | True  -> $m_uid m "True"$ ];
          value rec meta_list mf_a _loc =
            fun
            [ [] -> $m_uid m "[]"$
            | [x :: xs] -> $m_app m (m_app m (m_uid m "::") <:expr< mf_a _loc x >>) <:expr< meta_list mf_a _loc xs >>$ ];
          value rec $bi$;
        end >> in
     match super#module_expr me with
     [ <:module_expr< Camlp4Filters.MetaGeneratorExpr $id:i$ >> ->
         mk_meta_module
           { name = i;
             type_decls = Lazy.force type_decls;
             app = <:expr< Ast.ExApp >>;
             acc = <:expr< Ast.ExAcc >>;
             id  = <:expr< Ast.ExId  >>;
             tup = <:expr< Ast.ExTup >>;
             com = <:expr< Ast.ExCom >>;
             str = <:expr< Ast.ExStr >>;
             int = <:expr< Ast.ExInt >>;
             flo = <:expr< Ast.ExFlo >>;
             chr = <:expr< Ast.ExChr >>;
             ant = <:ident< Ast.ExAnt >>
           }
     | <:module_expr< Camlp4Filters.MetaGeneratorPatt $id:i$ >> ->
         mk_meta_module
           { name = i;
             type_decls = Lazy.force type_decls;
             app = <:expr< Ast.PaApp >>;
             acc = <:expr< Ast.PaAcc >>;
             id  = <:expr< Ast.PaId  >>;
             tup = <:expr< Ast.PaTup >>;
             com = <:expr< Ast.PaCom >>;
             str = <:expr< Ast.PaStr >>;
             int = <:expr< Ast.PaInt >>;
             flo = <:expr< Ast.PaFlo >>;
             chr = <:expr< Ast.PaChr >>;
             ant = <:ident< Ast.PaAnt >>
           }
     | me -> me ];
  end#str_item st;

AstFilters.register_str_item_filter filter;
