(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *         Copyright INRIA, CNRS and contributors             *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

DECLARE PLUGIN "ltac_plugin"

{

open Util
open Pp
open Glob_term
open Constrexpr
open Tacexpr
open Namegen
open Genarg
open Genredexpr
open Names
open Attributes

open Pcoq
open Pcoq.Prim
open Pcoq.Constr
open Pvernac.Vernac_
open Pltac

let fail_default_value = Locus.ArgArg 0

let arg_of_expr = function
    TacArg { CAst.v } -> v
  | e -> Tacexp (e:raw_tactic_expr)

let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) ()
let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n
let genarg_of_ipattern pat = in_gen (rawwit Tacarg.wit_simple_intropattern) pat
let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c
let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac

let reference_to_id qid =
  if Libnames.qualid_is_ident qid then
    CAst.make ?loc:qid.CAst.loc @@ Libnames.qualid_basename qid
  else
    CErrors.user_err ?loc:qid.CAst.loc
      (str "This expression should be a simple identifier.")

let tactic_mode = Entry.create "tactic_command"

let new_entry name =
  let e = Entry.create name in
  e

let toplevel_selector = new_entry "toplevel_selector"
let tacdef_body = new_entry "tacdef_body"

(* Registers [tactic_mode] as a parser for proof editing *)
let classic_proof_mode = Pvernac.register_proof_mode "Classic" tactic_mode

(* Hack to parse "[ id" without dropping [ *)
let test_bracket_ident =
  let open Pcoq.Lookahead in
  to_entry "test_bracket_ident" begin
    lk_kw "[" >> lk_ident
  end

(* Tactics grammar rules *)

let hint = G_proofs.hint

}

GRAMMAR EXTEND Gram
  GLOBAL: tactic tacdef_body ltac_expr binder_tactic tactic_value command hint
          tactic_mode constr_may_eval constr_eval toplevel_selector
          term;

  tactic_then_last:
    [ [ "|"; lta = LIST0 (OPT ltac_expr) SEP "|" ->
        { Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) }
      | -> { [||] }
    ] ]
  ;
  for_each_goal:
    [ [ ta = ltac_expr; "|"; tg = for_each_goal -> { let (first,last) = tg in (ta::first, last) }
      | ta = ltac_expr; ".."; l = tactic_then_last -> { ([], Some (ta, l)) }
      | ".."; l = tactic_then_last -> { ([], Some (TacId [], l)) }
      | ta = ltac_expr -> { ([ta], None) }
      | "|"; tg = for_each_goal -> { let (first,last) = tg in (TacId [] :: first, last) }
      | -> { ([TacId []], None) }
    ] ]
  ;
  tactic_then_locality: (* [true] for the local variant [TacThens] and [false]
                           for [TacExtend] *)
  [ [ "[" ; l = OPT">" -> { if Option.is_empty l then true else false } ] ]
  ;
  ltac_expr:
    [ "5" RIGHTA
      [ te = binder_tactic -> { te } ]
    | "4" LEFTA
      [ ta0 = ltac_expr; ";"; ta1 = binder_tactic -> { TacThen (ta0, ta1) }
      | ta0 = ltac_expr; ";"; ta1 = ltac_expr -> { TacThen (ta0,ta1) }
      | ta0 = ltac_expr; ";"; l = tactic_then_locality; tg = for_each_goal; "]" -> {
          let (first,tail) = tg in
          match l , tail with
          | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last))
          | true  , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last)
          | false , None -> TacThen (ta0,TacDispatch first)
          | true  , None -> TacThens (ta0,first) } ]
    | "3" RIGHTA
      [ IDENT "try"; ta = ltac_expr -> { TacTry ta }
      | IDENT "do"; n = nat_or_var; ta = ltac_expr -> { TacDo (n,ta) }
      | IDENT "timeout"; n = nat_or_var; ta = ltac_expr -> { TacTimeout (n,ta) }
      | IDENT "time"; s = OPT string; ta = ltac_expr -> { TacTime (s,ta) }
      | IDENT "repeat"; ta = ltac_expr -> { TacRepeat ta }
      | IDENT "progress"; ta = ltac_expr -> { TacProgress ta }
      | IDENT "once"; ta = ltac_expr -> { TacOnce ta }
      | IDENT "exactly_once"; ta = ltac_expr -> { TacExactlyOnce ta }
      | IDENT "infoH"; ta = ltac_expr -> { TacShowHyps ta }
(*To do: put Abstract in Refiner*)
      | IDENT "abstract"; tc = NEXT -> { TacAbstract (tc,None) }
      | IDENT "abstract"; tc = NEXT; "using";  s = ident ->
        { TacAbstract (tc,Some s) }
      | IDENT "only"; sel = selector; ":"; ta = ltac_expr -> { TacSelect (sel, ta) } ]
(*End of To do*)
    | "2" RIGHTA
      [ ta0 = ltac_expr; "+"; ta1 = binder_tactic -> { TacOr (ta0,ta1) }
      | ta0 = ltac_expr; "+"; ta1 = ltac_expr -> { TacOr (ta0,ta1) }
      | IDENT "tryif" ; ta = ltac_expr ;
              "then" ; tat = ltac_expr ;
              "else" ; tae = ltac_expr -> { TacIfThenCatch(ta,tat,tae) }
      | ta0 = ltac_expr; "||"; ta1 = binder_tactic -> { TacOrelse (ta0,ta1) }
      | ta0 = ltac_expr; "||"; ta1 = ltac_expr -> { TacOrelse (ta0,ta1) } ]
    | "1" RIGHTA
      [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" ->
          { TacMatchGoal (b,false,mrl) }
      | b = match_key; IDENT "reverse"; IDENT "goal"; "with";
        mrl = match_context_list; "end" ->
          { TacMatchGoal (b,true,mrl) }
      |	b = match_key; c = ltac_expr; "with"; mrl = match_list; "end" ->
          { TacMatch (b,c,mrl) }
      | IDENT "first" ; "["; l = LIST0 ltac_expr SEP "|"; "]" ->
          { TacFirst l }
      | IDENT "solve" ; "["; l = LIST0 ltac_expr SEP "|"; "]" ->
          { TacSolve l }
      | IDENT "idtac"; l = LIST0 message_token -> { TacId l }
      | g=failkw; n = [ n = nat_or_var -> { n } | -> { fail_default_value } ];
          l = LIST0 message_token -> { TacFail (g,n,l) }
      | st = simple_tactic -> { st }
      | a = tactic_value -> { TacArg(CAst.make ~loc a) }
      | r = reference; la = LIST0 tactic_arg ->
        { TacArg(CAst.make ~loc @@ TacCall (CAst.make ~loc (r,la))) } ]
    | "0"
      [ "("; a = ltac_expr; ")" -> { a }
      | "["; ">"; tg = for_each_goal; "]" -> {
          let (tf,tail) = tg in
          begin match tail with
          | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl)
          | None -> TacDispatch tf
          end }
      | a = tactic_atom -> { TacArg (CAst.make ~loc a) } ] ]
  ;
  failkw:
  [ [ IDENT "fail" -> { TacLocal } | IDENT "gfail" -> { TacGlobal } ] ]
  ;
  (* binder_tactic: level 5 of ltac_expr *)
  binder_tactic:
    [ RIGHTA
      [ "fun"; it = LIST1 input_fun ; "=>"; body = ltac_expr LEVEL "5" ->
          { TacFun (it,body) }
      | "let"; isrec = [IDENT "rec" -> { true } | -> { false } ];
          llc = LIST1 let_clause SEP "with"; "in";
          body = ltac_expr LEVEL "5" -> { TacLetIn (isrec,llc,body) } ] ]
  ;
  (* Tactic arguments to the right of an application *)
  tactic_arg:
    [ [ a = tactic_value -> { a }
      | c = Constr.constr -> { (match c with { CAst.v = CRef (r,None) } -> Reference r | c -> ConstrMayEval (ConstrTerm c)) }
      (* Unambiguous entries: tolerated w/o "ltac:" modifier *)
      | "()" -> { TacGeneric (None, genarg_of_unit ()) } ] ]
  ;
  (* Can be used as argument and at toplevel in tactic expressions. *)
  tactic_value:
    [ [ c = constr_eval -> { ConstrMayEval c }
      | IDENT "fresh"; l = LIST0 fresh_id -> { TacFreshId l }
      | IDENT "type_term"; c=uconstr -> { TacPretype c }
      | IDENT "numgoals" -> { TacNumgoals } ] ]
  ;
  (* If a qualid is given, use its short name. TODO: have the shortest
     non ambiguous name where dots are replaced by "_"? Probably too
     verbose most of the time. *)
  fresh_id:
    [ [ s = STRING -> { Locus.ArgArg s (*| id = ident -> Locus.ArgVar (!@loc,id)*) }
        | qid = qualid -> { Locus.ArgVar (CAst.make ~loc @@ Libnames.qualid_basename qid) } ] ]
  ;
  constr_eval:
    [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr ->
          { ConstrEval (rtc,c) }
      | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" ->
          { ConstrContext (id,c) }
      | IDENT "type"; IDENT "of"; c = Constr.constr ->
          { ConstrTypeOf c } ] ]
  ;
  constr_may_eval: (* For extensions *)
    [ [ c = constr_eval -> { c }
      | c = Constr.constr -> { ConstrTerm c } ] ]
  ;
  tactic_atom:
    [ [ n = integer -> { TacGeneric (None, genarg_of_int n) }
      | r = reference -> { TacCall (CAst.make ~loc (r,[])) }
      | "()" -> { TacGeneric (None, genarg_of_unit ()) } ] ]
  ;
  match_key:
    [ [ "match" -> { Once }
      | IDENT "lazymatch" -> { Select }
      | IDENT "multimatch" -> { General } ] ]
  ;
  input_fun:
    [ [ "_" -> { Name.Anonymous }
      | l = ident -> { Name.Name l } ] ]
  ;
  let_clause:
    [ [ idr = identref; ":="; te = ltac_expr ->
         { (CAst.map (fun id -> Name id) idr, arg_of_expr te) }
      | na = ["_" -> { CAst.make ~loc Anonymous } ]; ":="; te = ltac_expr ->
         { (na, arg_of_expr te) }
      | idr = identref; args = LIST1 input_fun; ":="; te = ltac_expr ->
         { (CAst.map (fun id -> Name id) idr, arg_of_expr (TacFun(args,te))) } ] ]
  ;
  match_pattern:
    [ [ IDENT "context";  oid = OPT Constr.ident;
          "["; pc = Constr.cpattern; "]" ->
        { Subterm (oid, pc) }
      | pc = Constr.cpattern -> { Term pc } ] ]
  ;
  match_hyp:
    [ [ na = name; ":"; mp =  match_pattern -> { Hyp (na, mp) }
      | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> { Def (na, mpv, mpt) }
      | na = name; ":="; mpv = match_pattern ->
        { let t, ty =
            match mpv with
            | Term t -> (match t with
              | { CAst.v = CCast (t, (CastConv ty | CastVM ty | CastNative ty)) } -> Term t, Some (Term ty)
              | _ -> mpv, None)
            | _ -> mpv, None
          in Def (na, t, Option.default (Term (CAst.make @@ CHole (None, IntroAnonymous, None))) ty) }
    ] ]
  ;
  match_context_rule:
    [ [ largs = LIST0 match_hyp SEP ","; "|-"; mp = match_pattern;
        "=>"; te = ltac_expr -> { Pat (largs, mp, te) }
      | "["; largs = LIST0 match_hyp SEP ","; "|-"; mp = match_pattern;
        "]"; "=>"; te = ltac_expr -> { Pat (largs, mp, te) }
      | "_"; "=>"; te = ltac_expr -> { All te } ] ]
  ;
  match_context_list:
    [ [ mrl = LIST1 match_context_rule SEP "|" -> { mrl }
      | "|"; mrl = LIST1 match_context_rule SEP "|" -> { mrl } ] ]
  ;
  match_rule:
    [ [ mp = match_pattern; "=>"; te = ltac_expr -> { Pat ([],mp,te) }
      | "_"; "=>"; te = ltac_expr -> { All te } ] ]
  ;
  match_list:
    [ [ mrl = LIST1 match_rule SEP "|" -> { mrl }
      | "|"; mrl = LIST1 match_rule SEP "|" -> { mrl } ] ]
  ;
  message_token:
    [ [ id = identref -> { MsgIdent id }
      | s = STRING -> { MsgString s }
      | n = natural -> { MsgInt n } ] ]
  ;

  ltac_def_kind:
    [ [ ":=" -> { false }
      | "::=" -> { true } ] ]
  ;

  (* Definitions for tactics *)
  tacdef_body:
    [ [ name = Constr.global; it=LIST1 input_fun;
        redef = ltac_def_kind; body = ltac_expr ->
        { if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body))
          else
            let id = reference_to_id name in
            Tacexpr.TacticDefinition (id, TacFun (it, body)) }
      | name = Constr.global; redef = ltac_def_kind;
        body = ltac_expr ->
        { if redef then Tacexpr.TacticRedefinition (name, body)
          else
            let id = reference_to_id name in
            Tacexpr.TacticDefinition (id, body) }
    ] ]
  ;
  tactic:
    [ [ tac = ltac_expr -> { tac } ] ]
  ;

  range_selector:
    [ [ n = natural ; "-" ; m = natural -> { (n, m) }
      | n = natural -> { (n, n) } ] ]
  ;
  (* We unfold a range selectors list once so that we can make a special case
   * for a unique SelectNth selector. *)
  range_selector_or_nth:
    [ [ n = natural ; "-" ; m = natural;
        l = OPT [","; l = LIST1 range_selector SEP "," -> { l } ] ->
        { Goal_select.SelectList ((n, m) :: Option.default [] l) }
      | n = natural;
        l = OPT [","; l = LIST1 range_selector SEP "," -> { l } ] ->
        { let open Goal_select in
          Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l } ] ]
  ;
  selector:
  [ [ l = range_selector_or_nth -> { l }
    | test_bracket_ident; "["; id = ident; "]" -> { Goal_select.SelectId id } ] ]
  ;
  toplevel_selector:
    [ [ sel = selector; ":" -> { sel }
    |   "!"; ":" -> { Goal_select.SelectAlreadyFocused }
    |   IDENT "all"; ":" -> { Goal_select.SelectAll } ] ]
  ;
  tactic_mode:
    [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> { tac g }
      | g = OPT toplevel_selector; "{" -> { Vernacexpr.VernacSubproof g } ] ]
  ;
  command:
    [ [ IDENT "Proof"; "with"; ta = Pltac.tactic;
        l = OPT [ IDENT "using"; l = G_vernac.section_subset_expr -> { l } ] ->
          { Vernacexpr.VernacProof (Some (in_tac ta), l) }
      | IDENT "Proof"; IDENT "using"; l = G_vernac.section_subset_expr;
        "with"; ta = Pltac.tactic ->
          { Vernacexpr.VernacProof (Some (in_tac ta),Some l) } ] ]
  ;
  hint:
    [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>";
        tac = Pltac.tactic ->
        { Vernacexpr.HintsExtern (n,c, in_tac tac) } ] ]
  ;
  term: LEVEL "0"
    [ [ IDENT "ltac"; ":"; "("; tac = Pltac.ltac_expr; ")" ->
        { let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in
          CAst.make ~loc @@ CHole (None, IntroAnonymous, Some arg) } ] ]
  ;
  END

{

open Stdarg
open Tacarg
open Vernacextend
open Libnames

let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s

}

VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY { pr_ltac_selector }
| [ toplevel_selector(s) ] -> { s }
END

{

let pr_ltac_info n = str "Info" ++ spc () ++ int n

}

VERNAC ARGUMENT EXTEND ltac_info PRINTED BY { pr_ltac_info }
| [ "Info" natural(n) ] -> { n }
END

{

let pr_ltac_use_default b =
  if b then (* Bug: a space is inserted before "..." *) str ".." else mt ()

}

VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY { pr_ltac_use_default }
| [ "." ] -> { false }
| [ "..." ] -> { true }
END

{

let rm_abstract = function
  | TacAbstract (t,_) -> t, true
  | TacSolve [TacAbstract (t,_)] -> TacSolve [t], true
  | x -> x, false
let is_explicit_terminator = function TacSolve _ -> true | _ -> false

}

VERNAC { tactic_mode } EXTEND VernacSolve STATE proof
| [ ltac_selector_opt(g) ltac_info_opt(info) tactic(t) ltac_use_default(with_end_tac) ] =>
    { classify_as_proofstep } -> {
    let g = Option.default (Goal_select.get_default_goal_selector ()) g in
    let global = match g with Goal_select.SelectAll | Goal_select.SelectList _ -> true | _ -> false in
    let t = Tacinterp.hide_interp { Tacinterp.global; ast = t; } in
    ComTactic.solve g ~info t ~with_end_tac
  }
END

VERNAC { tactic_mode } EXTEND VernacSolveParallel STATE proof
| [ "par" ":" ltac_info_opt(info) tactic(t) ltac_use_default(with_end_tac) ] =>
    {
      let solving_tac = is_explicit_terminator t in
      let pbr = if solving_tac then Some "par" else None in
      VtProofStep{ proof_block_detection = pbr }
    } -> {
      let t, abstract = rm_abstract t in
      let t = Tacinterp.hide_interp { Tacinterp.global = true; ast = t; } in
      ComTactic.solve_parallel ~info t ~abstract ~with_end_tac
    }
END

{

let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")"

}

VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY { pr_ltac_tactic_level }
| [ "(" "at" "level" natural(n) ")" ] -> { n }
END

VERNAC ARGUMENT EXTEND ltac_production_sep
| [ "," string(sep) ] -> { sep }
END

{

let pr_ltac_production_item = function
| Tacentries.TacTerm s -> quote (str s)
| Tacentries.TacNonTerm (_, ((arg, None), None)) -> str arg
| Tacentries.TacNonTerm (_, ((arg, Some _), None)) -> assert false
| Tacentries.TacNonTerm (_, ((arg, sep), Some id)) ->
  let sep = match sep with
  | None -> mt ()
  | Some sep -> str "," ++ spc () ++ quote (str sep)
  in
  str arg ++ str "(" ++ Id.print id ++ sep ++ str ")"

}

VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY { pr_ltac_production_item }
| [ string(s) ] -> { Tacentries.TacTerm s }
| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] ->
  { Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, sep), Some p)) }
| [ ident(nt) ] ->
  { Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, None), None)) }
END

VERNAC COMMAND EXTEND VernacTacticNotation
| #[ deprecation; locality; ]
  [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] =>
  { VtSideff ([], VtNow) } ->
  {
    let n = Option.default 0 n in
    Tacentries.add_tactic_notation (Locality.make_module_locality locality) n ?deprecation r e;
  }
END

VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY
| [ "Print" "Ltac" reference(r) ] ->
  { Feedback.msg_notice (Tacentries.print_ltac r) }
END

VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY
| [ "Locate" "Ltac" reference(r) ] ->
  { Tacentries.print_located_tactic r }
END

{

let pr_ltac_ref = Libnames.pr_qualid

let pr_tacdef_body env sigma tacdef_body =
  let id, redef, body =
    match tacdef_body with
    | TacticDefinition ({CAst.v=id}, body) -> Id.print id, false, body
    | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body
  in
  let idl, body =
    match body with
      | Tacexpr.TacFun (idl,b) -> idl,b
      | _ -> [], body in
  id ++
    prlist (function Name.Anonymous -> str " _"
      | Name.Name id -> spc () ++ Id.print id) idl
  ++ (if redef then str" ::=" else str" :=") ++ brk(1,1)
  ++ Pptactic.pr_raw_tactic env sigma body

}

VERNAC ARGUMENT EXTEND ltac_tacdef_body
PRINTED BY { pr_tacdef_body env sigma }
| [ tacdef_body(t) ] -> { t }
END

VERNAC COMMAND EXTEND VernacDeclareTacticDefinition
| #[ deprecation; locality; ] [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => {
    VtSideff (List.map (function
      | TacticDefinition ({CAst.v=r},_) -> r
      | TacticRedefinition (qid,_) -> qualid_basename qid) l, VtLater)
  } -> {
         Tacentries.register_ltac (Locality.make_module_locality locality) ?deprecation l;
  }
END

VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY
| [ "Print" "Ltac" "Signatures" ] -> { Tacentries.print_ltacs () }
END