(****************************************************************************)

(*                                                                          *)

(*                                   OCaml                                  *)

(*                                                                          *)

(*                            INRIA Rocquencourt                            *)

(*                                                                          *)

(*  Copyright  2006   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.                                                            *)

(*                                                                          *)

(****************************************************************************)

(* Authors:

 * - Nicolas Pouillard: initial version

 *)

module Make (Ast     : Sig.Camlp4Ast)

            (Gram    : Sig.Grammar.Static with module Loc = Ast.Loc

                                            with type Token.t = Sig.camlp4_token)

            (Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst Ast)

: Sig.Camlp4Syntax with module Loc = Ast.Loc

                    and module Ast = Ast

                    and module Token = Gram.Token

                    and module Gram = Gram

                    and module Quotation = Quotation

= struct

  module Loc     = Ast.Loc;

  module Ast     = Ast;

  module Gram    = Gram;

  module Token   = Gram.Token;

  open Sig;

  (* Warnings *)

  type warning = Loc.t -> string -> unit;

  value default_warning loc txt = Format.eprintf "<W> %a: %s@." Loc.print loc txt;

  value current_warning = ref default_warning;

  value print_warning loc txt = current_warning.val loc txt;

  value a_CHAR = Gram.Entry.mk "a_CHAR";

  value a_FLOAT = Gram.Entry.mk "a_FLOAT";

  value a_INT = Gram.Entry.mk "a_INT";

  value a_INT32 = Gram.Entry.mk "a_INT32";

  value a_INT64 = Gram.Entry.mk "a_INT64";

  value a_LABEL = Gram.Entry.mk "a_LABEL";

  value a_LIDENT = Gram.Entry.mk "a_LIDENT";

  value a_NATIVEINT = Gram.Entry.mk "a_NATIVEINT";

  value a_OPTLABEL = Gram.Entry.mk "a_OPTLABEL";

  value a_STRING = Gram.Entry.mk "a_STRING";

  value a_UIDENT = Gram.Entry.mk "a_UIDENT";

  value a_ident = Gram.Entry.mk "a_ident";

  value amp_ctyp = Gram.Entry.mk "amp_ctyp";

  value and_ctyp = Gram.Entry.mk "and_ctyp";

  value match_case = Gram.Entry.mk "match_case";

  value match_case0 = Gram.Entry.mk "match_case0";

  value binding = Gram.Entry.mk "binding";

  value class_declaration = Gram.Entry.mk "class_declaration";

  value class_description = Gram.Entry.mk "class_description";

  value class_expr = Gram.Entry.mk "class_expr";

  value class_fun_binding = Gram.Entry.mk "class_fun_binding";

  value class_fun_def = Gram.Entry.mk "class_fun_def";

  value class_info_for_class_expr = Gram.Entry.mk "class_info_for_class_expr";

  value class_info_for_class_type = Gram.Entry.mk "class_info_for_class_type";

  value class_longident = Gram.Entry.mk "class_longident";

  value class_longident_and_param = Gram.Entry.mk "class_longident_and_param";

  value class_name_and_param = Gram.Entry.mk "class_name_and_param";

  value class_sig_item = Gram.Entry.mk "class_sig_item";

  value class_signature = Gram.Entry.mk "class_signature";

  value class_str_item = Gram.Entry.mk "class_str_item";

  value class_structure = Gram.Entry.mk "class_structure";

  value class_type = Gram.Entry.mk "class_type";

  value class_type_declaration = Gram.Entry.mk "class_type_declaration";

  value class_type_longident = Gram.Entry.mk "class_type_longident";

  value class_type_longident_and_param = Gram.Entry.mk "class_type_longident_and_param";

  value class_type_plus = Gram.Entry.mk "class_type_plus";

  value comma_ctyp = Gram.Entry.mk "comma_ctyp";

  value comma_expr = Gram.Entry.mk "comma_expr";

  value comma_ipatt = Gram.Entry.mk "comma_ipatt";

  value comma_patt = Gram.Entry.mk "comma_patt";

  value comma_type_parameter = Gram.Entry.mk "comma_type_parameter";

  value constrain = Gram.Entry.mk "constrain";

  value constructor_arg_list = Gram.Entry.mk "constructor_arg_list";

  value constructor_declaration = Gram.Entry.mk "constructor_declaration";

  value constructor_declarations = Gram.Entry.mk "constructor_declarations";

  value ctyp = Gram.Entry.mk "ctyp";

  value cvalue_binding = Gram.Entry.mk "cvalue_binding";

  value direction_flag = Gram.Entry.mk "direction_flag";

  value direction_flag_quot = Gram.Entry.mk "direction_flag_quot";

  value dummy = Gram.Entry.mk "dummy";

  value entry_eoi = Gram.Entry.mk "entry_eoi";

  value eq_expr = Gram.Entry.mk "eq_expr";

  value expr = Gram.Entry.mk "expr";

  value expr_eoi = Gram.Entry.mk "expr_eoi";

  value field_expr = Gram.Entry.mk "field_expr";

  value field_expr_list = Gram.Entry.mk "field_expr_list";

  value fun_binding = Gram.Entry.mk "fun_binding";

  value fun_def = Gram.Entry.mk "fun_def";

  value ident = Gram.Entry.mk "ident";

  value implem = Gram.Entry.mk "implem";

  value interf = Gram.Entry.mk "interf";

  value ipatt = Gram.Entry.mk "ipatt";

  value ipatt_tcon = Gram.Entry.mk "ipatt_tcon";

  value label = Gram.Entry.mk "label";

  value label_declaration = Gram.Entry.mk "label_declaration";

  value label_declaration_list = Gram.Entry.mk "label_declaration_list";

  value label_expr = Gram.Entry.mk "label_expr";

  value label_expr_list = Gram.Entry.mk "label_expr_list";

  value label_ipatt = Gram.Entry.mk "label_ipatt";

  value label_ipatt_list = Gram.Entry.mk "label_ipatt_list";

  value label_longident = Gram.Entry.mk "label_longident";

  value label_patt = Gram.Entry.mk "label_patt";

  value label_patt_list = Gram.Entry.mk "label_patt_list";

  value labeled_ipatt = Gram.Entry.mk "labeled_ipatt";

  value let_binding = Gram.Entry.mk "let_binding";

  value meth_list = Gram.Entry.mk "meth_list";

  value meth_decl = Gram.Entry.mk "meth_decl";

  value module_binding = Gram.Entry.mk "module_binding";

  value module_binding0 = Gram.Entry.mk "module_binding0";

  value module_declaration = Gram.Entry.mk "module_declaration";

  value module_expr = Gram.Entry.mk "module_expr";

  value module_longident = Gram.Entry.mk "module_longident";

  value module_longident_with_app = Gram.Entry.mk "module_longident_with_app";

  value module_rec_declaration = Gram.Entry.mk "module_rec_declaration";

  value module_type = Gram.Entry.mk "module_type";

  value package_type = Gram.Entry.mk "package_type";

  value more_ctyp = Gram.Entry.mk "more_ctyp";

  value name_tags = Gram.Entry.mk "name_tags";

  value opt_as_lident = Gram.Entry.mk "opt_as_lident";

  value opt_class_self_patt = Gram.Entry.mk "opt_class_self_patt";

  value opt_class_self_type = Gram.Entry.mk "opt_class_self_type";

  value opt_class_signature = Gram.Entry.mk "opt_class_signature";

  value opt_class_structure = Gram.Entry.mk "opt_class_structure";

  value opt_comma_ctyp = Gram.Entry.mk "opt_comma_ctyp";

  value opt_dot_dot = Gram.Entry.mk "opt_dot_dot";

  value row_var_flag_quot = Gram.Entry.mk "row_var_flag_quot";

  value opt_eq_ctyp = Gram.Entry.mk "opt_eq_ctyp";

  value opt_expr = Gram.Entry.mk "opt_expr";

  value opt_meth_list = Gram.Entry.mk "opt_meth_list";

  value opt_mutable = Gram.Entry.mk "opt_mutable";

  value mutable_flag_quot = Gram.Entry.mk "mutable_flag_quot";

  value opt_polyt = Gram.Entry.mk "opt_polyt";

  value opt_private = Gram.Entry.mk "opt_private";

  value private_flag_quot = Gram.Entry.mk "private_flag_quot";

  value opt_rec = Gram.Entry.mk "opt_rec";

  value opt_nonrec = Gram.Entry.mk "opt_nonrec";

  value rec_flag_quot = Gram.Entry.mk "rec_flag_quot";

  value opt_sig_items = Gram.Entry.mk "opt_sig_items";

  value opt_str_items = Gram.Entry.mk "opt_str_items";

  value opt_virtual = Gram.Entry.mk "opt_virtual";

  value virtual_flag_quot = Gram.Entry.mk "virtual_flag_quot";

  value opt_override = Gram.Entry.mk "opt_override";

  value override_flag_quot = Gram.Entry.mk "override_flag_quot";

  value opt_when_expr = Gram.Entry.mk "opt_when_expr";

  value patt = Gram.Entry.mk "patt";

  value patt_as_patt_opt = Gram.Entry.mk "patt_as_patt_opt";

  value patt_eoi = Gram.Entry.mk "patt_eoi";

  value patt_tcon = Gram.Entry.mk "patt_tcon";

  value phrase = Gram.Entry.mk "phrase";

  value poly_type = Gram.Entry.mk "poly_type";

  value row_field = Gram.Entry.mk "row_field";

  value sem_expr = Gram.Entry.mk "sem_expr";

  value sem_expr_for_list = Gram.Entry.mk "sem_expr_for_list";

  value sem_patt = Gram.Entry.mk "sem_patt";

  value sem_patt_for_list = Gram.Entry.mk "sem_patt_for_list";

  value semi = Gram.Entry.mk "semi";

  value sequence = Gram.Entry.mk "sequence";

  value do_sequence = Gram.Entry.mk "do_sequence";

  value sig_item = Gram.Entry.mk "sig_item";

  value sig_items = Gram.Entry.mk "sig_items";

  value star_ctyp = Gram.Entry.mk "star_ctyp";

  value str_item = Gram.Entry.mk "str_item";

  value str_items = Gram.Entry.mk "str_items";

  value top_phrase = Gram.Entry.mk "top_phrase";

  value type_constraint = Gram.Entry.mk "type_constraint";

  value type_declaration = Gram.Entry.mk "type_declaration";

  value type_ident_and_parameters = Gram.Entry.mk "type_ident_and_parameters";

  value type_kind = Gram.Entry.mk "type_kind";

  value type_longident = Gram.Entry.mk "type_longident";

  value type_longident_and_parameters = Gram.Entry.mk "type_longident_and_parameters";

  value type_parameter = Gram.Entry.mk "type_parameter";

  value type_parameters = Gram.Entry.mk "type_parameters";

  value typevars = Gram.Entry.mk "typevars";

  value use_file = Gram.Entry.mk "use_file";

  value val_longident = Gram.Entry.mk "val_longident";

  value value_let = Gram.Entry.mk "value_let";

  value value_val = Gram.Entry.mk "value_val";

  value with_constr = Gram.Entry.mk "with_constr";

  value expr_quot = Gram.Entry.mk "quotation of expression";

  value patt_quot = Gram.Entry.mk "quotation of pattern";

  value ctyp_quot = Gram.Entry.mk "quotation of type";

  value str_item_quot = Gram.Entry.mk "quotation of structure item";

  value sig_item_quot = Gram.Entry.mk "quotation of signature item";

  value class_str_item_quot = Gram.Entry.mk "quotation of class structure item";

  value class_sig_item_quot = Gram.Entry.mk "quotation of class signature item";

  value module_expr_quot = Gram.Entry.mk "quotation of module expression";

  value module_type_quot = Gram.Entry.mk "quotation of module type";

  value class_type_quot = Gram.Entry.mk "quotation of class type";

  value class_expr_quot = Gram.Entry.mk "quotation of class expression";

  value with_constr_quot = Gram.Entry.mk "quotation of with constraint";

  value binding_quot = Gram.Entry.mk "quotation of binding";

  value rec_binding_quot = Gram.Entry.mk "quotation of record binding";

  value match_case_quot = Gram.Entry.mk "quotation of match_case (try/match/function case)";

  value module_binding_quot = Gram.Entry.mk "quotation of module rec binding";

  value ident_quot = Gram.Entry.mk "quotation of identifier";

  value prefixop = Gram.Entry.mk "prefix operator (start with '!', '?', '~')";

  value infixop0 = Gram.Entry.mk "infix operator (level 0) (comparison operators, and some others)";

  value infixop1 = Gram.Entry.mk "infix operator (level 1) (start with '^', '@')";

  value infixop2 = Gram.Entry.mk "infix operator (level 2) (start with '+', '-')";

  value infixop3 = Gram.Entry.mk "infix operator (level 3) (start with '*', '/', '%')";

  value infixop4 = Gram.Entry.mk "infix operator (level 4) (start with \"**\") (right assoc)";

  EXTEND Gram

    top_phrase:

      [ [ `EOI -> None ] ]

    ;

  END;

  module AntiquotSyntax = struct

    module Loc  = Ast.Loc;

    module Ast  = Sig.Camlp4AstToAst Ast;

    module Gram = Gram;

    value antiquot_expr = Gram.Entry.mk "antiquot_expr";

    value antiquot_patt = Gram.Entry.mk "antiquot_patt";

    EXTEND Gram

      antiquot_expr:

        [ [ x = expr; `EOI -> x ] ]

      ;

      antiquot_patt:

        [ [ x = patt; `EOI -> x ] ]

      ;

    END;

    value parse_expr loc str = Gram.parse_string antiquot_expr loc str;

    value parse_patt loc str = Gram.parse_string antiquot_patt loc str;

  end;

  module Quotation = Quotation;

  value wrap directive_handler pa init_loc cs =

    let rec loop loc =

      let (pl, stopped_at_directive) = pa loc cs in

      match stopped_at_directive with

      [ Some new_loc ->

        let pl =

          match List.rev pl with

          [ [] -> assert False

          | [x :: xs] ->

              match directive_handler x with

              [ None -> xs

              | Some x -> [x :: xs] ] ]

        in (List.rev pl) @ (loop new_loc)

      | None -> pl ]

    in loop init_loc;

  value parse_implem ?(directive_handler = fun _ -> None) _loc cs =

    let l = wrap directive_handler (Gram.parse implem) _loc cs in

    <:str_item< $list:l$ >>;

  value parse_interf ?(directive_handler = fun _ -> None) _loc cs =

    let l = wrap directive_handler (Gram.parse interf) _loc cs in

    <:sig_item< $list:l$ >>;

  value print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer";

  value print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer";

end;