(* Otags III
 * 
 * Hendrik Tews Copyright (C) 2010 - 2017
 * 
 * This file is part of "Otags III".
 * 
 * "Otags III" 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 3 of the
 * License, or (at your option) any later version.
 * 
 * "Otags III" 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 in file COPYING in this or one of the parent
 * directories for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with "Otags III". If not, see
 * <http://www.gnu.org/licenses/>.
 * 
 * recursive tagging function
 * 
 * This file depends on the OCaml syntax tree and is therefore likely
 * to break with each new OCaml version. To make it a bit more robust
 * all pattern matches contain catch-all clauses such that new syntax
 * pieces are ignored (instead of crashing otags). In order to
 * conveniently find missing new syntax, otags should be test build
 * with ``make devel-build'', which compiles this file with the
 * ppx_flush_catchall preprocessor and with -w A (instead of -w
 * A-4-11). ppx_flush_catchall deletes in each pattern match that is
 * annotated with the @flushcatchall attribute the last catch-all
 * match ``| _ -> ()'', possibly inside an or pattern.
 *)

open Migrate_parsetree.Ast_405

open Otags_misc
open Otags_types
open Parsetree
open Asttypes

(******************************************************************************
 *
 **********************   tagging functions   *********************************
 *
 ******************************************************************************)


let tag_type_decl write_tag {ptype_name = {txt; loc} ; ptype_kind; _ } =
  write_tag loc txt;
  match [@flushcatchall] ptype_kind with
    | Ptype_variant(constr_decl_list) ->
        (* Invariant: non-empty list *)
       List.iter
	 (fun {pcd_name = {txt; loc}; _} -> write_tag loc txt)
	 constr_decl_list
    | Ptype_record(field_decl_list) ->
        (* Invariant: non-empty list *)
       List.iter
	 (fun {pld_name = {txt; loc}; _} -> write_tag loc txt)
	 field_decl_list
    | Ptype_abstract
    | Ptype_open
       (* XXX: .. (extensible variant type) *)
    | _ -> ()

let tag_extension_constuctor write_tag {pext_name = {txt; loc}; _} =
  write_tag loc txt

let rec tag_class_field_decl write_tag ct =
  match [@flushcatchall] ct.pctf_desc with
    | Pctf_inherit ct ->
          (* inherit CT *)
       (* The class type can be a concrete class body 
	* type object ... end, therefore we tag it.
	*)
       tag_class_type write_tag ct
    | Pctf_val({txt; loc}, _mutable, _virtual, _core_type) ->
        (* val x: T *)
       write_tag loc txt
    | Pctf_method({txt; loc}, _private, _virtual, _core_type) ->
        (* method x: T

           Note: T can be a Ptyp_poly.
         *)
       write_tag loc txt
    | Pctf_constraint _
	  (* constraint T1 = T2 *)
    | Pctf_attribute _
	  (* [@@@id] *)
    | Pctf_extension _
	  (* [%%id] *)
    | _ -> ()

and tag_class_type write_tag ct = match [@flushcatchall] ct.pcty_desc with
  | Pcty_signature {pcsig_fields; _ } ->
        (* object ... end *)
     List.iter (tag_class_field_decl write_tag) pcsig_fields
  | Pcty_arrow(_label, _type, ct) ->
        (* T -> CT       Simple
           ~l:T -> CT    Labelled l
           ?l:T -> CT    Optional l
         *)
     tag_class_type write_tag ct

  | Pcty_constr _
        (* c
           ['a1, ..., 'an] c *)
  | Pcty_extension _
        (* [%id] *)
    -> ()
  | _ -> ()

let tag_class_decl write_tag {pci_name = {txt; loc}; pci_expr; _} =
    write_tag loc txt;
    tag_class_type write_tag pci_expr


let rec tag_sig_item write_tag sig_item =
  match [@flushcatchall] sig_item.psig_desc with
    | Psig_value({pval_name = {txt; loc}; _}) -> write_tag loc txt
	  (*
	    val x: T
	    external x: T = "s1" ... "sn"
	   *)
    | Psig_type(_rec, type_decl_list) ->
    	  (* type t1 = ... and ... and tn = ... *)
       List.iter (tag_type_decl write_tag) type_decl_list
    | Psig_typext({ptyext_path = {txt; loc}; ptyext_constructors; _ }) ->
    	  (* type t1 += ... *)
       write_tag loc (Longident.last txt);
       List.iter (tag_extension_constuctor write_tag) ptyext_constructors
    | Psig_exception(ext_constr) ->
    	  (* exception C of T *)
       tag_extension_constuctor write_tag ext_constr
    | Psig_module md ->
    	  (* module X : MT *)
       tag_module_declaration write_tag md
    | Psig_recmodule mds ->
    	  (* module rec X1 : MT1 and ... and Xn : MTn *)
       List.iter (tag_module_declaration write_tag) mds
    | Psig_modtype mod_type_decl ->
    	  (* module type S = MT
    	     module type S *)
       tag_module_type_decl write_tag mod_type_decl
    | Psig_class class_decls ->
    	  (* class c1 : ... and ... and cn : ... *)
       List.iter (tag_class_decl write_tag) class_decls
    | Psig_class_type class_decls ->
    	  (* class type ct1 = ... and ... and ctn = ... *)
       List.iter (tag_class_decl write_tag) class_decls

    | Psig_open _
    	  (* open X *)
    | Psig_include _
    	  (* include MT *)
    | Psig_attribute _
    	  (* [@@@id] *)
    | Psig_extension _
    	  (* [%%id] *)
    | _ -> ()
	     
and tag_module_declaration write_tag {pmd_name = {txt; loc}; pmd_type; _ } =
  write_tag loc txt;
  tag_module_type write_tag pmd_type

and tag_module_type write_tag mt = match [@flushcatchall] mt.pmty_desc with
  | Pmty_ident _ -> ()
        (* S *)
    (* The id here can be a long one with dots and applications.
     * However, the grammar forbits real signatures appearing inside it.
     *)
  | Pmty_signature sig_items ->
        (* sig ... end *)
     List.iter (tag_sig_item write_tag) sig_items
  | Pmty_functor(_idloc, mt_opt, mt) ->
        (* functor(X : MT1) -> MT2 *)
    (* XXX mt_opt = None for generative functors *)
     option_map (tag_module_type write_tag) mt_opt;
     tag_module_type write_tag mt
  | Pmty_with(mt, _constraint_list) ->
        (* MT with ... *)
     tag_module_type write_tag mt

  | Pmty_typeof _
        (* module type of ME *)
  | Pmty_extension _
        (* [%id] *)
  | Pmty_alias _
        (* (module M) *)
  | _ -> ()
	 
and tag_module_type_decl write_tag {pmtd_name = {txt; loc}; pmtd_type; _ } =
  write_tag loc txt;
  option_map (tag_module_type write_tag) pmtd_type

let rec tag_class_field_def write_tag cfd =
  match [@flushcatchall] cfd.pcf_desc with
    | Pcf_inherit(_, ce, _) ->
	  (* inherit CE
	     inherit CE as x
	     inherit! CE
	     inherit! CE as x
	   *)
       (* ce can be a class body and is therefore tagged.
	*)
       tag_class_expr write_tag ce
    | Pcf_val({txt; loc}, _, _) -> write_tag loc txt
	  (* val x = E
	     val virtual x: T
	   *)
    | Pcf_method({txt; loc}, _, _) -> write_tag loc txt
	  (* method x = E            (E can be a Pexp_poly)
	     method virtual x: T     (T can be a Ptyp_poly)
	   *)

    | Pcf_constraint _
	  (* constraint T1 = T2 *)
    | Pcf_initializer _
	  (* initializer E *)
    | Pcf_attribute _
	  (* [@@@id] *)
    | Pcf_extension _
	  (* [%%id] *)
    | _ -> ()

and tag_class_expr write_tag ce = match [@flushcatchall] ce.pcl_desc with
  | Pcl_structure {pcstr_fields; _ } ->
        (* object ... end *)
     List.iter (tag_class_field_def write_tag) pcstr_fields
  | Pcl_fun(_, _, _, ce) -> tag_class_expr write_tag ce
        (* fun P -> CE                          (Simple, None)
           fun ~l:P -> CE                       (Labelled l, None)
           fun ?l:P -> CE                       (Optional l, None)
           fun ?l:(P = E0) -> CE                (Optional l, Some E0)
         *)
  | Pcl_apply(ce, _) -> tag_class_expr write_tag ce
        (* CE ~l1:E1 ... ~ln:En
           li can be empty (non labeled argument) or start with '?'
           (optional argument).

           Invariant: n > 0
         *)
  | Pcl_let(_, _, ce) -> tag_class_expr write_tag ce
        (* let P1 = E1 and ... and Pn = EN in CE      (flag = Nonrecursive)
           let rec P1 = E1 and ... and Pn = EN in CE  (flag = Recursive)
         *)
  | Pcl_constraint(ce, ct) ->
        (* (CE : CT) *)
     tag_class_expr write_tag ce;
     (* ct can contain an object body, therefore tag it *)
     tag_class_type write_tag ct
  | Pcl_constr _
        (* c
           ['a1, ..., 'an] c *)
  | Pcl_extension _
        (* [%id] *)
  | _ -> ()

let tag_class_def write_tag {pci_name = {txt; loc}; pci_expr; _} =
    write_tag loc txt;
    tag_class_expr write_tag pci_expr
					      

let rec tag_let_pattern write_tag pa =
  match [@flushcatchall] pa.ppat_desc with
    | Ppat_var { txt; loc } -> write_tag loc txt
	  (* x *)
    | Ppat_alias(pat, {txt; loc}) ->
	  (* P as 'a *)
       write_tag loc txt;
       tag_let_pattern write_tag pat
    | Ppat_tuple(pat_list) -> List.iter (tag_let_pattern write_tag) pat_list
	  (* (P1, ..., Pn)

	     Invariant: n >= 2
	  *)
    | Ppat_constraint(pat, _) -> tag_let_pattern write_tag pat
	  (* (P : T) *)
    | Ppat_open(_mod_long_id, pat) -> tag_let_pattern write_tag pat
          (* M.(P) *)

    | Ppat_any
	  (* _ *)
    | Ppat_constant _
	  (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
    | Ppat_interval _
	  (* 'a'..'z'

	     Other forms of interval are recognized by the parser
	     but rejected by the type-checker. *)
    | Ppat_construct _
	  (* C                None
	     C P              Some P
	     C (P1, ..., Pn)  Some (Ppat_tuple [P1; ...; Pn])
	   *)
    | Ppat_variant _
	  (* `A             (None)
	     `A P           (Some P)
	   *)
    | Ppat_record _
	  (* { l1=P1; ...; ln=Pn }     (flag = Closed)
	     { l1=P1; ...; ln=Pn; _}   (flag = Open)

	     Invariant: n > 0
	   *)
    | Ppat_array _
	  (* [| P1; ...; Pn |] *)
    | Ppat_or _
	  (* P1 | P2 *)
    | Ppat_type _
	  (* #tconst *) (* short-hand for all poly variants in tconst *)
    | Ppat_lazy _
	  (* lazy P *)
    | Ppat_unpack _
	  (* (module P)
	     Note: (module P : S) is represented as
	     Ppat_constraint(Ppat_unpack, Ptyp_package)
	   *)
    | Ppat_exception _
	  (* exception P *)
      (* Exception patterns are only permitted in proper matches with at 
       * least 2 cases and not in let bindings. 
       *)
    | Ppat_extension _
	  (* [%id] *)
    | _ -> ()

let rec tag_str_item write_tag stri =
  match [@flushcatchall] stri.pstr_desc with
    | Pstr_value(_rec_flag, value_binding_list) ->
	  (* let P1 = E1 and ... and Pn = EN       (flag = Nonrecursive)
	     let rec P1 = E1 and ... and Pn = EN   (flag = Recursive)
	   *)
       List.iter (fun {pvb_pat; _ } -> tag_let_pattern write_tag pvb_pat)
		 value_binding_list     
    | Pstr_primitive({pval_name = {txt; loc}; _}) -> write_tag loc txt
	  (*  val x: T
	      external x: T = "s1" ... "sn" *)
      (* XXX the val x seems to be a copy/paste error *)
    | Pstr_type(_rec, type_decl_list) ->
	  (* type t1 = ... and ... and tn = ... *)
       List.iter (tag_type_decl write_tag) type_decl_list
    | Pstr_typext({ptyext_path = {txt; loc}; ptyext_constructors; _ }) ->
	  (* type t1 += ... *)
      (* 
       * XXX check type A.B.t += X
       * XXX try to rigger the Longident.last fatal exception
       *)
       write_tag loc (Longident.last txt);
       List.iter (tag_extension_constuctor write_tag) ptyext_constructors
    | Pstr_exception(ext_constr) ->
	  (* exception C of T
	     exception C = M.X *)
       tag_extension_constuctor write_tag ext_constr
    | Pstr_module(mod_binding) ->
	  (* module X = ME *)
       tag_module_def_binding write_tag mod_binding
    | Pstr_recmodule mod_bindings ->
	  (* module rec X1 = ME1 and ... and Xn = MEn *)
       List.iter (tag_module_def_binding write_tag) mod_bindings
    | Pstr_modtype mod_type_decl ->
	  (* module type S = MT *)
       tag_module_type_decl write_tag mod_type_decl
    | Pstr_class class_defs ->
	  (* class c1 = ... and ... and cn = ... *)
       List.iter (tag_class_def write_tag) class_defs
    | Pstr_class_type class_decls ->
       (* class type ct1 = ... and ... and ctn = ... *)
       List.iter (tag_class_decl write_tag) class_decls

    | Pstr_eval _
	  (* E *)
    | Pstr_open _
	  (* open X *)
    | Pstr_include _
	  (* include ME *)
    | Pstr_attribute _
	  (* [@@@id] *)
    | Pstr_extension _
	  (* [%%id] *)
    | _ -> ()

and tag_module_def_binding write_tag {pmb_name = {txt; loc}; pmb_expr; _ } =
  write_tag loc txt;
  tag_module_expr write_tag pmb_expr

and tag_module_expr write_tag me = match [@flushcatchall] me.pmod_desc with
  | Pmod_structure str_items ->
        (* struct ... end *)
     List.iter
       (tag_str_item write_tag)
       str_items
  | Pmod_functor(_, _, me) -> tag_module_expr write_tag me
        (* functor(X : MT1) -> ME *)
    (* XXX tag arg signature? *)
  | Pmod_constraint(me, mt) ->
        (* (ME : MT) *)
     (* XXX check nested type constraints in functors *)
     tag_module_type write_tag mt;
     tag_module_expr write_tag me
    
  | Pmod_ident _ 
        (* X *)
  | Pmod_apply _ 			(* XXX check and probably tag this *)
        (* ME1(ME2) *)
  | Pmod_unpack _
        (* (val E) *)
  | Pmod_extension _
        (* [%id] *)
  | _ -> ()

(* Generate tags for unit_ast of file file by calling write_tag 
 * for each tag.
 *)
let generate_tags write_tag unit_ast =
  (match [@flushcatchall] unit_ast with
    | Sig_ast sig_items ->
      List.iter
	(tag_sig_item write_tag)
	sig_items
    | Struct_ast str_items ->
      List.iter
	(tag_str_item write_tag)
	str_items
    | _ -> ()
  )