(* Copyright 2021 Pierre Courtieu
  This file is part of LibHyps. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it. *)

(** This file defines tacticals for iterating a tactic on sets of
    hypothesis. In particular on the set of hypothesis generated by a
    tactic. For examples of use of this tacticals, see LibHyps.v and
    for to seee them working, see LibHypsDemo.v.

    [onAllHyp tac] applies [tac H] for each H of the proof context
    (natural order: newer hyps first).

    [onAllHypRev tac] like onAllHyp but applies [tac H] in reverse
    order.

    [tac_all_new_hyps tac1 tac2] applies tac1 on the current goal,
    then applies tac on each "new" hypothesis generated by tac1. A
    hypothesis is "new" if its name was not present before tac1 was
    applied.

    [tac_all_new_hyps_rev tac1 tac2] works like tac_all_new_hyps but
    applies tac2 in reverse order.

    In all these tacticals, a failure during tac makes the whole
    expression to fail.

    For efficiency and generality we also provide a tactical working
    on a list of hypothesis instead of only on at a time.
    
     *)


Require Import Ltac2.Ltac2.

From Ltac2 Require Import Option Constr Printf.
Import Constr.Unsafe.
Local Set Default Proof Mode "Classic".
(* Require Import LibHyps.LibHypsDebug. *)

(* Utilities *)
Local Ltac2 is_dep_prod (t:constr): bool :=
  match kind t with
  | Prod _ subt => Bool.neg (is_closed subt)
  | _ => false
  end.

Local Ltac2 pr_list (pr: unit -> 'a -> message) () (l: 'a list) :=
  let rec pr_list_  () (l: 'a list) :=
    match l with
    | [] => fprintf ""
    | [e] => fprintf "%a" pr e
    | e::l' => fprintf "%a , %a" pr e pr_list_ l'
    end in
  fprintf "[ %a ]" pr_list_ l.


(* Pure Ltac2 tactics *)
Module Ltac2.
  Ltac2 all_hyps_ident() := List.map (fun (x,_,_) => x) (Control.hyps ()).

  Ltac2 iter_hyps (tac:ident -> unit) (lh:ident list) :=
    List.iter tac lh.

  Ltac2 map_all_hyps (tac:'a -> unit) :=
    let all_hyps := all_hyps_ident() in
    iter_hyps tac all_hyps.

  Ltac2 map_all_hyps_rev (tac: 'a -> unit) :=
    let all_hyps := List.rev (all_hyps_ident()) in
    iter_hyps tac all_hyps.

  Ltac2 then_eachnh_gen (tac1:'a -> unit) (tac2:ident -> unit) (rev:bool) :=
    let hyps_before := all_hyps_ident() in
    let _ := tac1() in
    Control.enter
      (fun () => 
         let hyps_after := all_hyps_ident() in
         let new_hyps: ident list := List.filter_out (fun id => List.mem Ident.equal id hyps_before) hyps_after in
         iter_hyps tac2 (if rev then List.rev new_hyps else new_hyps)).

  Ltac2 then_eachnh (tac1:'a -> unit) (tac2:ident -> unit) :=
    then_eachnh_gen tac1 tac2 false.

  Ltac2 then_eachnh_rev (tac1:'a -> unit) (tac2:ident -> unit) :=
    then_eachnh_gen tac1 tac2 true.

End Ltac2.

(* Ltac2 tacticals on Ltac1 tactics and values. Mainly work
   translating them to ltac2 values and call tactical from Ltac2
   above.*)
Module Ltac1.
  Ltac2 apply_run (tac:Ltac1.t) lid :=
    let larg := List.map Ltac1.of_ident lid in
    Ltac1.apply tac larg (fun t => Ltac1.run t).
  
  Ltac2 iter_hyps (tac:Ltac1.t) (lh:ident list): unit :=
    let tac2:ident -> unit := (fun (id:ident) => apply_run tac [id])  in
    Ltac2.iter_hyps tac2 lh.

  (* Iterate tac on all hyps of a goal, top to bottom or reverse. *)

  Ltac2 map_all_hyps (tac:Ltac1.t) :=
    let tac2:ident -> unit := (fun (id:ident) => apply_run tac [id])  in
    Ltac2.map_all_hyps tac2.

  Ltac2 map_all_hyps_rev (tac:Ltac1.t) :=
    let tac2:ident -> unit := (fun (id:ident) => apply_run tac [id])  in
    Ltac2.map_all_hyps_rev tac2.

  Ltac2 then_eachnh (tac1:Ltac1.t) (tac2:Ltac1.t) :=  
    let tac1':unit -> unit := (fun () => Ltac1.run tac1) in
    let tac2':ident -> unit := (fun id => apply_run tac2 [id]) in
    Ltac2.then_eachnh tac1' tac2'.

  Ltac2 then_eachnh_rev (tac1:Ltac1.t) (tac2:Ltac1.t) :=  
    let tac1':unit -> unit := (fun () => Ltac1.run tac1) in
    let tac2':ident -> unit := (fun id => apply_run tac2 [id]) in
    Ltac2.then_eachnh_rev tac1' tac2'.
End Ltac1.

Ltac map_all_hyps tac :=
  let t := ltac2:(tac |- Ltac1.map_all_hyps tac) in
  t tac.

Ltac map_all_hyps_rev tac :=
  let t := ltac2:(tac |- Ltac1.map_all_hyps_rev tac) in
  t tac.

(* Ltac tacticals *)
Ltac then_eachnh tac1 tac2 :=
  let t := ltac2:(tac1 tac2 |- Ltac1.then_eachnh tac1 tac2) in
  t tac1 tac2.

Ltac then_eachnh_rev tac1 tac2 :=
  let t := ltac2:(tac1 tac2 |- Ltac1.then_eachnh_rev tac1 tac2) in
  t tac1 tac2.

  (* then_allnh_rev tac1 ltac:(map_hyps tac2). *)
(* Ltac then_eachnh tac1 tac2 := then_allnh tac1 ltac:(map_hyps tac2). *)



(* For less parenthesis: OnAllHyp tacA;tac2. *)
Tactic Notation (at level 4) "onAllHyps" tactic(tac) := map_all_hyps tac.
Tactic Notation (at level 4) "onAllHypsRev" tactic(tac) := map_all_hyps_rev tac.

Module Notations.
  (* Default syntax: *)
  (* Tactic Notation (at level 4) tactic4(tac)";" "{!" tactic(tach) "}" := then_allnh tac tach. *)
  (* Tactic Notation (at level 4) tactic4(tac)";" "{!<" tactic(tach)"}":= then_allnh_rev tac tach. *)
  (* single-goal-minded tach (most common use case). *)
  Tactic Notation (at level 4) tactic4(tac)";" "{" tactic(tach)"}":= then_eachnh tac tach.
  Tactic Notation (at level 4) tactic4(tac)";" "{<" tactic(tach)"}":= then_eachnh_rev tac tach.
  (* Legacy tacticals.
     Warning: not applicable for tactic operating directly on a list of hyps *)
  (* Tactic Notation (at level 4) tactic4(tac) ";;" tactic4(tach) := then_eachnh tac tach. *)
  (* Tactic Notation (at level 4) tactic4(tac) ";!;" tactic4(tach) := (then_eachnh_rev tac tach). *)
End Notations.


Import Notations.
(*
Goal forall n m p q : nat, n<m -> m<p -> p<=q -> True.
Proof.
  intros n m p q H H0 H1.
  Unset Silent.
  map_all_hyps ltac:(fun h => idtac h).
  map_all_hyps_rev ltac:(fun h => idtac h).
  onAllHyps (fun h => idtac h).
  onAllHypsRev (fun h => idtac h).
  ltac2:(Ltac2.then_eachnh (fun () => induction H) (fun id => printf "%I" id)).
  Undo 1.
  then_eachnh ltac:(induction H) ltac:(fun h => idtac h).
  Undo 1.
  then_eachnh_rev ltac:(induction H) ltac:(fun h => idtac h).
  Undo 1.
  induction H ;{ fun h => idtac h }.
  Undo 1.
  induction H ;{< fun h => idtac h }.
*)

