/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Eqns
import Lean.Util.CollectFVars
import Lean.Util.ForEachExprWhere
import Lean.Meta.Tactic.Split
import Lean.Meta.Tactic.Apply
import Lean.Meta.Tactic.Refl
import Lean.Meta.Match.MatchEqs

namespace Lean.Elab.Eqns
open Meta

structure EqnInfoCore where
  declName    : Name
  levelParams : List Name
  type        : Expr
  value       : Expr
  deriving Inhabited

partial def expand : Expr → Expr
  | Expr.letE _ _ v b _ => expand (b.instantiate1 v)
  | Expr.mdata _ b      => expand b
  | e => e

def expandRHS? (mvarId : MVarId) : MetaM (Option MVarId) := do
  let target ← mvarId.getType'
  let some (_, lhs, rhs) := target.eq? | return none
  unless rhs.isLet || rhs.isMData do return none
  return some (← mvarId.replaceTargetDefEq (← mkEq lhs (expand rhs)))

def funext? (mvarId : MVarId) : MetaM (Option MVarId) := do
  let target ← mvarId.getType'
  let some (_, _, rhs) := target.eq? | return none
  unless rhs.isLambda do return none
  commitWhenSome? do
    let [mvarId] ← mvarId.apply (← mkConstWithFreshMVarLevels ``funext) | return none
    let (_, mvarId) ← mvarId.intro1
    return some mvarId

def simpMatch? (mvarId : MVarId) : MetaM (Option MVarId) := do
  let mvarId' ← Split.simpMatchTarget mvarId
  if mvarId != mvarId' then return some mvarId' else return none

def simpIf? (mvarId : MVarId) : MetaM (Option MVarId) := do
  let mvarId' ← simpIfTarget mvarId (useDecide := true)
  if mvarId != mvarId' then return some mvarId' else return none

private def findMatchToSplit? (env : Environment) (e : Expr) (declNames : Array Name) (exceptionSet : ExprSet) : Option Expr :=
  e.findExt? fun e => Id.run do
    if e.hasLooseBVars || exceptionSet.contains e then
      return Expr.FindStep.visit
    else if let some info := isMatcherAppCore? env e then
      let args := e.getAppArgs
      -- If none of the discriminants is a free variable, then it is not worth splitting the match
      let mut hasFVarDiscr := false
      for i in [info.getFirstDiscrPos : info.getFirstDiscrPos + info.numDiscrs] do
        let discr := args[i]!
        if discr.isFVar then
          hasFVarDiscr := true
          break
      unless hasFVarDiscr do
        return Expr.FindStep.visit
      -- At least one alternative must contain a `declNames` application with loose bound variables.
      for i in [info.getFirstAltPos : info.getFirstAltPos + info.numAlts] do
        let alt := args[i]!
        if Option.isSome <| alt.find? fun e => declNames.any e.isAppOf && e.hasLooseBVars then
          return Expr.FindStep.found
      return Expr.FindStep.visit
    else
      let Expr.const declName .. := e.getAppFn | return Expr.FindStep.visit
      if declName == ``WellFounded.fix || isBRecOnRecursor env declName then
        -- We should not go inside unfolded nested recursive applications
        return Expr.FindStep.done
      else
        return Expr.FindStep.visit

partial def splitMatch? (mvarId : MVarId) (declNames : Array Name) : MetaM (Option (List MVarId)) := commitWhenSome? do
  let target ← mvarId.getType'
  let rec go (badCases : ExprSet) : MetaM (Option (List MVarId)) := do
    if let some e := findMatchToSplit? (← getEnv) target declNames badCases then
      try
        Meta.Split.splitMatch mvarId e
      catch _ =>
        go (badCases.insert e)
    else
      trace[Meta.Tactic.split] "did not find term to split\n{MessageData.ofGoal mvarId}"
      return none
  go {}

structure Context where
  declNames : Array Name

private def lhsDependsOn (type : Expr) (fvarId : FVarId) : MetaM Bool :=
  forallTelescope type fun _ type => do
    if let some (_, lhs, _) ← matchEq? type then
      dependsOn lhs fvarId
    else
      dependsOn type fvarId

/-- Try to close goal using `rfl` with smart unfolding turned off. -/
def tryURefl (mvarId : MVarId) : MetaM Bool :=
  withOptions (smartUnfolding.set · false) do
    try mvarId.refl; return true catch _ => return false

/--
  Eliminate `namedPatterns` from equation, and trivial hypotheses.
-/
def simpEqnType (eqnType : Expr) : MetaM Expr := do
  forallTelescopeReducing (← instantiateMVars eqnType) fun ys type => do
    let proofVars := collect type
    trace[Elab.definition] "simpEqnType type: {type}"
    let mut type ← Match.unfoldNamedPattern type
    let mut eliminated : FVarIdSet := {}
    for y in ys.reverse do
      trace[Elab.definition] ">> simpEqnType: {← inferType y}, {type}"
      if proofVars.contains y.fvarId! then
        let some (_, Expr.fvar fvarId, rhs) ← matchEq? (← inferType y) | throwError "unexpected hypothesis in altenative{indentExpr eqnType}"
        eliminated := eliminated.insert fvarId
        type := type.replaceFVarId fvarId rhs
      else if eliminated.contains y.fvarId! then
        if (← dependsOn type y.fvarId!) then
          type ← mkForallFVars #[y] type
      else
        if let some (_, lhs, rhs) ← matchEq? (← inferType y) then
          if (← isDefEq lhs rhs) then
            if !(← dependsOn type y.fvarId!) then
              continue
            else if !(← lhsDependsOn type y.fvarId!) then
              -- Since the `lhs` of the `type` does not depend on `y`, we replace it with `Eq.refl` in the `rhs`
              type := type.replaceFVar y (← mkEqRefl lhs)
              continue
        type ← mkForallFVars #[y] type
    return type
where
  -- Collect eq proof vars used in `namedPatterns`
  collect (e : Expr) : FVarIdSet :=
    let go (e : Expr) (ω) : ST ω FVarIdSet := do
      let ref ← ST.mkRef {}
      e.forEachWhere Match.isNamedPattern fun e => do
        let some e := Match.isNamedPattern? e | unreachable!
        let arg := e.appArg!.consumeMData
        if arg.isFVar then
          ST.Prim.Ref.modify ref (·.insert arg.fvarId!)
      ST.Prim.Ref.get ref
    runST (go e)

private partial def saveEqn (mvarId : MVarId) : StateRefT (Array Expr) MetaM Unit := mvarId.withContext do
  let target ← mvarId.getType'
  let fvarState := collectFVars {} target
  let fvarState ← (← getLCtx).foldrM (init := fvarState) fun decl fvarState => do
    if fvarState.fvarSet.contains decl.fvarId then
      return collectFVars fvarState (← instantiateMVars decl.type)
    else
      return fvarState
  let mut fvarIdSet := fvarState.fvarSet
  let mut fvarIds ← sortFVarIds <| fvarState.fvarSet.toArray
  -- Include (relevant) propositions that are not already in `fvarIdSet`
  let mut modified := false
  repeat
    modified := false
    for decl in (← getLCtx) do
      unless fvarIdSet.contains decl.fvarId do
        if (← isProp decl.type) then
          let type ← instantiateMVars decl.type
          unless (← isIrrelevant fvarIdSet type) do
            modified := true
            (fvarIdSet, fvarIds) ← pushDecl fvarIdSet fvarIds decl
  until !modified
  let type ← mkForallFVars (fvarIds.map mkFVar) target
  let type ← simpEqnType type
  modify (·.push type)
where
  /--
    We say the type/proposition is "irrelevant" if
    1- It does not contain any variable in `fvarIdSet` OR
    2- It is of the form `x = t` or `t = x` where `x` is a free variable
       that is not in `fvarIdSet`. This can of equality can be eliminated by substitution.  -/
  isIrrelevant (fvarIdSet : FVarIdSet) (type : Expr) : MetaM Bool := do
    if Option.isNone <| type.find? fun e => e.isFVar && fvarIdSet.contains e.fvarId! then
      return true
    else if let some (_, lhs, rhs) := type.eq? then
      return (lhs.isFVar && !fvarIdSet.contains lhs.fvarId!)
             || (rhs.isFVar && !fvarIdSet.contains rhs.fvarId!)
    else
      return false

  pushDecl (fvarIdSet : FVarIdSet) (fvarIds : Array FVarId) (localDecl : LocalDecl) : MetaM (FVarIdSet × Array FVarId) := do
    let (fvarIdSet, fvarIds) ← collectDeps fvarIdSet fvarIds (← instantiateMVars localDecl.type)
    return (fvarIdSet.insert localDecl.fvarId, fvarIds.push localDecl.fvarId)

  collectDeps (fvarIdSet : FVarIdSet) (fvarIds : Array FVarId) (type : Expr) : MetaM (FVarIdSet × Array FVarId) := do
    let s := collectFVars {} type
    let usedFVarIds ← sortFVarIds <| s.fvarSet.toArray
    let mut fvarIdSet := fvarIdSet
    let mut fvarIds := fvarIds
    for fvarId in usedFVarIds do
      unless fvarIdSet.contains fvarId do
        (fvarIdSet, fvarIds) ← pushDecl fvarIdSet fvarIds (← fvarId.getDecl)
    return (fvarIdSet, fvarIds)

/--
  Quick filter for deciding whether to use `simpMatch?` at `mkEqnTypes`.
  If the result is `false`, then it is not worth trying `simpMatch`.
-/
private def shouldUseSimpMatch (e : Expr) : MetaM Bool := do
  let env ← getEnv
  return Option.isSome <| e.find? fun e => Id.run do
    if let some info := isMatcherAppCore? env e then
      let args := e.getAppArgs
      for discr in args[info.getFirstDiscrPos : info.getFirstDiscrPos + info.numDiscrs] do
        if discr.isConstructorApp env then
          return true
    return false

partial def mkEqnTypes (declNames : Array Name) (mvarId : MVarId) : MetaM (Array Expr) := do
  let (_, eqnTypes) ← go mvarId |>.run { declNames } |>.run #[]
  return eqnTypes
where
  go (mvarId : MVarId) : ReaderT Context (StateRefT (Array Expr) MetaM) Unit := do
    trace[Elab.definition.eqns] "mkEqnTypes step\n{MessageData.ofGoal mvarId}"
    if (← tryURefl mvarId) then
      saveEqn mvarId
      return ()

    if let some mvarId ← expandRHS? mvarId then
      return (← go mvarId)
--  The following `funext?` was producing an overapplied `lhs`. Possible refinement: only do it if we want to apply `splitMatch` on the body of the lambda
/-    if let some mvarId ← funext? mvarId then
        return (← go mvarId) -/

    if (← shouldUseSimpMatch (← mvarId.getType')) then
      if let some mvarId ← simpMatch? mvarId then
        return (← go mvarId)

    if let some mvarIds ← splitMatch? mvarId declNames then
      return (← mvarIds.forM go)

    saveEqn mvarId

/--
  Some of the hypotheses added by `mkEqnTypes` may not be used by the actual proof (i.e., `value` argument).
  This method eliminates them.

  Alternative solution: improve `saveEqn` and make sure it never includes unnecessary hypotheses.
  These hypotheses are leftovers from tactics such as `splitMatch?` used in `mkEqnTypes`.
-/
def removeUnusedEqnHypotheses (declType declValue : Expr) : CoreM (Expr × Expr) := do
  go declType declValue #[] {}
where
  go (type value : Expr) (xs : Array Expr) (lctx : LocalContext) : CoreM (Expr × Expr) := do
    match value with
    | .lam n d b bi =>
      let d := d.instantiateRev xs
      let fvarId ← mkFreshFVarId
      go (type.bindingBody!) b (xs.push (mkFVar fvarId)) (lctx.mkLocalDecl fvarId n d bi)
    | _ =>
      let type  := type.instantiateRev xs
      let value := value.instantiateRev xs
      let mut s := collectFVars (collectFVars {} type) value
      let mut xsNew := #[]
      for x in xs.reverse do
        if s.fvarSet.contains x.fvarId! then
          s := collectFVars s (lctx.getFVar! x).type
          xsNew := xsNew.push x
      if xsNew.size == xs.size then
        return (declType, declValue)
      else
        xsNew := xsNew.reverse
        return (lctx.mkForall xsNew type, lctx.mkLambda xsNew value)

/-- Delta reduce the equation left-hand-side -/
def deltaLHS (mvarId : MVarId) : MetaM MVarId := mvarId.withContext do
  let target ← mvarId.getType'
  let some (_, lhs, rhs) := target.eq? | throwTacticEx `deltaLHS mvarId "equality expected"
  let some lhs ← delta? lhs | throwTacticEx `deltaLHS mvarId "failed to delta reduce lhs"
  mvarId.replaceTargetDefEq (← mkEq lhs rhs)

def deltaRHS? (mvarId : MVarId) (declName : Name) : MetaM (Option MVarId) := mvarId.withContext do
  let target ← mvarId.getType'
  let some (_, lhs, rhs) := target.eq? | return none
  let some rhs ← delta? rhs.consumeMData (· == declName) | return none
  mvarId.replaceTargetDefEq (← mkEq lhs rhs)

private partial def whnfAux (e : Expr) : MetaM Expr := do
  let e ← whnfI e -- Must reduce instances too, otherwise it will not be able to reduce `(Nat.rec ... ... (OfNat.ofNat 0))`
  let f := e.getAppFn
  match f with
  | .proj _ _ s => return mkAppN (f.updateProj! (← whnfAux s)) e.getAppArgs
  | _ => return e

/-- Apply `whnfR` to lhs, return `none` if `lhs` was not modified -/
def whnfReducibleLHS? (mvarId : MVarId) : MetaM (Option MVarId) := mvarId.withContext do
  let target ← mvarId.getType'
  let some (_, lhs, rhs) := target.eq? | return none
  let lhs' ← whnfAux lhs
  if lhs' != lhs then
    return some (← mvarId.replaceTargetDefEq (← mkEq lhs' rhs))
  else
    return none

def tryContradiction (mvarId : MVarId) : MetaM Bool := do
  mvarId.contradictionCore { genDiseq := true }

structure UnfoldEqnExtState where
  map : PHashMap Name Name := {}
  deriving Inhabited

/- We generate the unfold equation on demand, and do not save them on .olean files. -/
builtin_initialize unfoldEqnExt : EnvExtension UnfoldEqnExtState ←
  registerEnvExtension (pure {})

/--
  Auxiliary method for `mkUnfoldEq`. The structure is based on `mkEqnTypes`.
  `mvarId` is the goal to be proved. It is a goal of the form
  ```
  declName x_1 ... x_n = body[x_1, ..., x_n]
  ```
  The proof is constracted using the automatically generated equational theorems.
  We basically keep splitting the `match` and `if-then-else` expressions in the right hand side
  until one of the equational theorems is applicable.
-/
partial def mkUnfoldProof (declName : Name) (mvarId : MVarId) : MetaM Unit := do
  let some eqs ← getEqnsFor? declName | throwError "failed to generate equations for '{declName}'"
  let tryEqns (mvarId : MVarId) : MetaM Bool :=
    eqs.anyM fun eq => commitWhen do
      try
        let subgoals ← mvarId.apply (← mkConstWithFreshMVarLevels eq)
        subgoals.allM fun subgoal => do
          if (← subgoal.isAssigned) then
            return true -- Subgoal was already solved. This can happen when there are dependencies between the subgoals
          else
            subgoal.assumptionCore
      catch _ =>
        return false
  let rec go (mvarId : MVarId) : MetaM Unit := do
    if (← tryEqns mvarId) then
      return ()
    -- Remark: we removed funext? from `mkEqnTypes`
    -- else if let some mvarId ← funext? mvarId then
    --  go mvarId

    if (← shouldUseSimpMatch (← mvarId.getType')) then
      if let some mvarId ← simpMatch? mvarId then
        return (← go mvarId)

    if let some mvarIds ← splitTarget? mvarId (splitIte := false) then
      return (← mvarIds.forM go)

    if (← tryContradiction mvarId) then
      return ()

    throwError "failed to generate unfold theorem for '{declName}'\n{MessageData.ofGoal mvarId}"
  go mvarId

/-- Generate the "unfold" lemma for `declName`. -/
def mkUnfoldEq (declName : Name) (info : EqnInfoCore) : MetaM Name := withLCtx {} {} do
  let env ← getEnv
  withOptions (tactic.hygienic.set · false) do
    let baseName := mkPrivateName env declName
    lambdaTelescope info.value fun xs body => do
      let us := info.levelParams.map mkLevelParam
      let type ← mkEq (mkAppN (Lean.mkConst declName us) xs) body
      let goal ← mkFreshExprSyntheticOpaqueMVar type
      mkUnfoldProof declName goal.mvarId!
      let type ← mkForallFVars xs type
      let value ← mkLambdaFVars xs (← instantiateMVars goal)
      let name := baseName ++ `_unfold
      addDecl <| Declaration.thmDecl {
        name, type, value
        levelParams := info.levelParams
      }
      return name

def getUnfoldFor? (declName : Name) (getInfo? : Unit → Option EqnInfoCore) : MetaM (Option Name) := do
  let env ← getEnv
  if let some eq := unfoldEqnExt.getState env |>.map.find? declName then
    return some eq
  else if let some info := getInfo? () then
    let eq ← mkUnfoldEq declName info
    modifyEnv fun env => unfoldEqnExt.modifyState env fun s => { s with map := s.map.insert declName eq }
    return some eq
  else
    return none

builtin_initialize
  registerTraceClass `Elab.definition.unfoldEqn
  registerTraceClass `Elab.definition.eqns

end Lean.Elab.Eqns


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Robert Y. Lewis, Arthur Paulino, Gabriel Ebner
-/
import Lean.Util.CollectLevelParams
import Lean.Meta.ForEachExpr
import Std.Tactic.Lint.Basic
import Std.Data.Array.Basic

open Lean Meta

namespace Std.Tactic.Lint

/-!
# Various linters

This file defines several small linters.
-/

/-- A linter for checking whether a declaration has a namespace twice consecutively in its name. -/
@[std_linter] def dupNamespace : Linter where
  noErrorsFound := "No declarations have a duplicate namespace."
  errorsFound := "DUPLICATED NAMESPACES IN NAME:"
  test declName := do
    if ← isAutoDecl declName then return none
    if isGlobalInstance (← getEnv) declName then return none
    let nm := declName.components
    let some (dup, _) := nm.zip nm.tail! |>.find? fun (x, y) => x == y
      | return none
    return m!"The namespace {dup} is duplicated in the name"

/-- A linter for checking for unused arguments.
We skip all declarations that contain `sorry` in their value. -/
@[std_linter] def unusedArguments : Linter where
  noErrorsFound := "No unused arguments."
  errorsFound := "UNUSED ARGUMENTS."
  test declName := do
    if ← isAutoDecl declName then return none
    if ← isProjectionFn declName then return none
    let info ← getConstInfo declName
    let ty := info.type
    let some val := info.value? | return none
    forallTelescope ty fun args ty => do
      let mut e := (mkAppN val args).headBeta
      e := mkApp e ty
      for arg in args do
        let ldecl ← getFVarLocalDecl arg
        e := mkApp e ldecl.type
        if let some val := ldecl.value? then
          e := mkApp e val
      let unused := args.zip (.range args.size) |>.filter fun (arg, _) =>
        !e.containsFVar arg.fvarId!
      if unused.isEmpty then return none
      addMessageContextFull <| .joinSep (← unused.toList.mapM fun (arg, i) =>
          return m!"argument {i+1} {arg} : {← inferType arg}") m!", "

/-- A linter for checking definition doc strings. -/
@[std_linter] def docBlame : Linter where
  noErrorsFound := "No definitions are missing documentation."
  errorsFound := "DEFINITIONS ARE MISSING DOCUMENTATION STRINGS:"
  test declName := do
    if (← isAutoDecl declName) || isGlobalInstance (← getEnv) declName then
      return none
    if let .str _ s := declName then
      if s == "parenthesizer" || s == "formatter" || s == "delaborator" || s == "quot" then
      return none
    let kind ← match ← getConstInfo declName with
      | .axiomInfo .. => pure "axiom"
      | .opaqueInfo .. => pure "constant"
      | .defnInfo .. => pure "definition"
      | .inductInfo .. => pure "inductive"
      | _ => return none
    let (none) ← findDocString? (← getEnv) declName | return none
    return m!"{kind} missing documentation string"

/-- A linter for checking theorem doc strings. -/
@[std_linter disabled] def docBlameThm : Linter where
  noErrorsFound := "No theorems are missing documentation."
  errorsFound := "THEOREMS ARE MISSING DOCUMENTATION STRINGS:"
  test declName := do
    if ← isAutoDecl declName then
      return none
    let kind ← match ← getConstInfo declName with
      | .thmInfo .. => pure "theorem"
      | _ => return none
    let (none) ← findDocString? (← getEnv) declName | return none
    return m!"{kind} missing documentation string"

/-- A linter for checking whether the correct declaration constructor (definition or theorem)
has been used. -/
@[std_linter] def defLemma : Linter where
  noErrorsFound := "All declarations correctly marked as def/lemma."
  errorsFound := "INCORRECT DEF/LEMMA:"
  test declName := do
    if (← isAutoDecl declName) || isGlobalInstance (← getEnv) declName then
      return none
    if ← isProjectionFn declName then return none
    let info ← getConstInfo declName
    let isThm ← match info with
      | .defnInfo .. => pure false
      | .thmInfo .. => pure true
      | _ => return none
    match isThm, ← isProp info.type with
    | true, false => pure "is a lemma/theorem, should be a def"
    | false, true => pure "is a def, should be lemma/theorem"
    | _, _ => return none

/-- A linter for missing checking whether statements of declarations are well-typed. -/
@[std_linter] def checkType : Linter where
  noErrorsFound :=
    "The statements of all declarations type-check with default reducibility settings."
  errorsFound := "THE STATEMENTS OF THE FOLLOWING DECLARATIONS DO NOT TYPE-CHECK."
  isFast := true
  test declName := do
    if ← isAutoDecl declName then return none
    if ← isTypeCorrect (← getConstInfo declName).type then return none
    return m!"the statement doesn't type check."

/--
`univParamsGrouped e` computes for each `level` `u` of `e` the parameters that occur in `u`,
and returns the corresponding set of lists of parameters.
In pseudo-mathematical form, this returns `{{p : parameter | p ∈ u} | (u : level) ∈ e}`
FIXME: We use `Array Name` instead of `HashSet Name`, since `HashSet` does not have an equality
instance. It will ignore `nm₀.proof_i` declarations.
-/
private def univParamsGrouped (e : Expr) (nm₀ : Name) : Lean.HashSet (Array Name) :=
  runST fun σ => do
    let res ← ST.mkRef (σ := σ) {}
    e.forEach fun
      | .sort u =>
        res.modify (·.insert (CollectLevelParams.visitLevel u {}).params)
      | .const n us => do
        if let .str n s .. := n then
          if n == nm₀ && s.startsWith "proof_" then
            return
        res.modify <| us.foldl (·.insert <| CollectLevelParams.visitLevel · {} |>.params)
      | _ => pure ()
    res.get

/--
The good parameters are the parameters that occur somewhere in the set as a singleton or
(recursively) with only other good parameters.
All other parameters in the set are bad.
-/
private partial def badParams (l : Array (Array Name)) : Array Name :=
  let goodLevels := l.filterMap fun
    | #[u] => some u
    | _ => none
  if goodLevels.isEmpty then
    l.flatten.toList.eraseDups.toArray
  else
    badParams <| l.map (·.filter (!goodLevels.contains ·))

/-- A linter for checking that there are no bad `max u v` universe levels.
Checks whether all universe levels `u` in the type of `d` are "good".
This means that `u` either occurs in a `level` of `d` by itself, or (recursively)
with only other good levels.
When this fails, usually this means that there is a level `max u v`, where neither `u` nor `v`
occur by themselves in a level. It is ok if *one* of `u` or `v` never occurs alone. For example,
`(α : Type u) (β : Type (max u v))` is a occasionally useful method of saying that `β` lives in
a higher universe level than `α`.
-/
@[std_linter] def checkUnivs : Linter where
  noErrorsFound :=
    "All declarations have good universe levels."
  errorsFound := "THE STATEMENTS OF THE FOLLOWING DECLARATIONS HAVE BAD UNIVERSE LEVELS. " ++
"This usually means that there is a `max u v` in the type where neither `u` nor `v` " ++
"occur by themselves. Solution: Find the type (or type bundled with data) that has this " ++
"universe argument and provide the universe level explicitly. If this happens in an implicit " ++
"argument of the declaration, a better solution is to move this argument to a `variables` " ++
"command (then it's not necessary to provide the universe level).
It is possible that this linter gives a false positive on definitions where the value of the " ++
"definition has the universes occur separately, and the definition will usually be used with " ++
"explicit universe arguments. In this case, feel free to add `@[nolint checkUnivs]`."
  isFast := true
  test declName := do
    if ← isAutoDecl declName then return none
    let bad := badParams (univParamsGrouped (← getConstInfo declName).type declName).toArray
    if bad.isEmpty then return none
    return m!"universes {bad} only occur together."

/-- A linter for checking that declarations aren't syntactic tautologies.
Checks whether a lemma is a declaration of the form `∀ a b ... z, e₁ = e₂`
where `e₁` and `e₂` are identical exprs.
We call declarations of this form syntactic tautologies.
Such lemmas are (mostly) useless and sometimes introduced unintentionally when proving basic facts
with rfl when elaboration results in a different term than the user intended. -/
@[std_linter] def synTaut : Linter where
  noErrorsFound :=
    "No declarations are syntactic tautologies."
  errorsFound := "THE FOLLOWING DECLARATIONS ARE SYNTACTIC TAUTOLOGIES. " ++
"This usually means that they are of the form `∀ a b ... z, e₁ = e₂` where `e₁` and `e₂` are " ++
"identical expressions. We call declarations of this form syntactic tautologies. " ++
"Such lemmas are (mostly) useless and sometimes introduced unintentionally when proving " ++
"basic facts using `rfl`, when elaboration results in a different term than the user intended. " ++
"You should check that the declaration really says what you think it does."
  isFast := true
  test declName := do
    if ← isAutoDecl declName then return none
    forallTelescope (← getConstInfo declName).type fun _ ty => do
      let some (lhs, rhs) := ty.eq?.map (fun (_, l, r) => (l, r)) <|> ty.iff?
        | return none
      if lhs == rhs then
        return m!"LHS equals RHS syntactically"
      return none

/--
Return a list of unused have/suffices/let_fun terms in an expression.
This actually finds all beta-redexes.
-/
def findUnusedHaves (e : Expr) : MetaM (Array MessageData) := do
  let res ← IO.mkRef #[]
  forEachExpr e fun e => do
    let some e := letFunAnnotation? e | return
    let Expr.app (Expr.lam n t b ..) _ .. := e | return
    if n.isInternal then return
    if b.hasLooseBVars then return
    let msg ← addMessageContextFull m!"unnecessary have {n.eraseMacroScopes} : {t}"
    res.modify (·.push msg)
  res.get

/-- A linter for checking that declarations don't have unused term mode have statements. We do not
tag this as `@[std_linter]` so that it is not in the default linter set as it is slow and an
uncommon problem. -/
@[std_linter] def unusedHavesSuffices : Linter where
  noErrorsFound := "No declarations have unused term mode have statements."
  errorsFound := "THE FOLLOWING DECLARATIONS HAVE INEFFECTUAL TERM MODE HAVE/SUFFICES BLOCKS. " ++
    "In the case of `have` this is a term of the form `have h := foo, bar` where `bar` does not " ++
    "refer to `foo`. Such statements have no effect on the generated proof, and can just be " ++
    "replaced by `bar`, in addition to being ineffectual, they may make unnecessary assumptions " ++
    "in proofs appear as if they are used. " ++
    "For `suffices` this is a term of the form `suffices h : foo, proof_of_goal, proof_of_foo` where" ++
    " `proof_of_goal` does not refer to `foo`. " ++
    "Such statements have no effect on the generated proof, and can just be replaced by " ++
    "`proof_of_goal`, in addition to being ineffectual, they may make unnecessary assumptions in " ++
    "proofs appear as if they are used. "
  test declName := do
    if ← isAutoDecl declName then return none
    let info ← getConstInfo declName
    let mut unused ← findUnusedHaves info.type
    if let some value := info.value? then
      unused := unused ++ (← findUnusedHaves value)
    unless unused.isEmpty do
      return some <| .joinSep unused.toList ", "
    return none

/--
A linter for checking if variables appearing on both sides of an iff are explicit. Ideally, such
variables should be implicit instead.
-/
@[std_linter disabled] def explicitVarsOfIff : Linter where
  noErrorsFound := "No explicit variables on both sides of iff"
  errorsFound := "EXPLICIT VARIABLES ON BOTH SIDES OF IFF"
  test declName := do
    if ← isAutoDecl declName then return none
    forallTelescope (← getConstInfo declName).type fun args ty => do
      let some (lhs, rhs) := ty.iff? | return none
      let explicit ← args.filterM fun arg =>
        return (← getFVarLocalDecl arg).binderInfo.isExplicit &&
          lhs.containsFVar arg.fvarId! && rhs.containsFVar arg.fvarId!
      if explicit.isEmpty then return none
      addMessageContextFull m!"should be made implicit: {
        MessageData.joinSep (explicit.toList.map (m!"{·}")) ", "}"


/- Additional theroems for option. -/
namespace option

theorem failure_is_none (α : Type _) : (failure : option α) = none := rfl

theorem coe_is_some {α : Type _} (x:α) : (coe x : option α) = some x := rfl

theorem or_else_none {α : Type _} (x : option α) : (x <|> none) = x :=
begin
  cases x; trivial,
end

theorem none_or_else {α : Type _} (x : option α) : (none <|> x) = x :=
begin
  cases x; trivial,
end

theorem some_or_else {α : Type _} (x : α) (y : option α) : (some x <|> y) = some x :=
begin
  trivial,
end

end option


open Lean.Parser.Tactic in
macro "rw0" s:rwRuleSeq : tactic =>
  `(tactic| rw (config := { offsetCnstrs := false }) $s:rwRuleSeq)

example (m n : Nat) : Nat.ble (n+1) (n+0) = false := by
  rw0 [Nat.add_zero]
  trace_state
  admit


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.lint.default
import Mathlib.tactic.ext
import Mathlib.PostPort

universes u_1 u_4 u_2 u_3 u_5 u_6

namespace Mathlib

namespace sigma

protected instance inhabited {α : Type u_1} {β : α → Type u_4} [Inhabited α]
    [Inhabited (β Inhabited.default)] : Inhabited (sigma β) :=
  { default := mk Inhabited.default Inhabited.default }

protected instance decidable_eq {α : Type u_1} {β : α → Type u_4} [h₁ : DecidableEq α]
    [h₂ : (a : α) → DecidableEq (β a)] : DecidableEq (sigma β) :=
  sorry

@[simp] theorem mk.inj_iff {α : Type u_1} {β : α → Type u_4} {a₁ : α} {a₂ : α} {b₁ : β a₁}
    {b₂ : β a₂} : mk a₁ b₁ = mk a₂ b₂ ↔ a₁ = a₂ ∧ b₁ == b₂ :=
  sorry

@[simp] theorem eta {α : Type u_1} {β : α → Type u_4} (x : sigma fun (a : α) => β a) :
    mk (fst x) (snd x) = x :=
  cases_on x
    fun (x_fst : α) (x_snd : β x_fst) =>
      idRhs
        (mk (fst (mk x_fst x_snd)) (snd (mk x_fst x_snd)) =
          mk (fst (mk x_fst x_snd)) (snd (mk x_fst x_snd)))
        rfl

theorem ext {α : Type u_1} {β : α → Type u_4} {x₀ : sigma β} {x₁ : sigma β} (h₀ : fst x₀ = fst x₁)
    (h₁ : snd x₀ == snd x₁) : x₀ = x₁ :=
  sorry

theorem ext_iff {α : Type u_1} {β : α → Type u_4} {x₀ : sigma β} {x₁ : sigma β} :
    x₀ = x₁ ↔ fst x₀ = fst x₁ ∧ snd x₀ == snd x₁ :=
  cases_on x₀
    fun (x₀_fst : α) (x₀_snd : β x₀_fst) =>
      cases_on x₁ fun (x₁_fst : α) (x₁_snd : β x₁_fst) => mk.inj_iff

@[simp] theorem forall {α : Type u_1} {β : α → Type u_4} {p : (sigma fun (a : α) => β a) → Prop} :
    (∀ (x : sigma fun (a : α) => β a), p x) ↔ ∀ (a : α) (b : β a), p (mk a b) :=
  sorry

@[simp] theorem exists {α : Type u_1} {β : α → Type u_4} {p : (sigma fun (a : α) => β a) → Prop} :
    (∃ (x : sigma fun (a : α) => β a), p x) ↔ ∃ (a : α), ∃ (b : β a), p (mk a b) :=
  sorry

/-- Map the left and right components of a sigma -/
def map {α₁ : Type u_2} {α₂ : Type u_3} {β₁ : α₁ → Type u_5} {β₂ : α₂ → Type u_6} (f₁ : α₁ → α₂)
    (f₂ : (a : α₁) → β₁ a → β₂ (f₁ a)) (x : sigma β₁) : sigma β₂ :=
  mk (f₁ (fst x)) (f₂ (fst x) (snd x))

end sigma

theorem sigma_mk_injective {α : Type u_1} {β : α → Type u_4} {i : α} :
    function.injective (sigma.mk i) :=
  sorry

theorem function.injective.sigma_map {α₁ : Type u_2} {α₂ : Type u_3} {β₁ : α₁ → Type u_5}
    {β₂ : α₂ → Type u_6} {f₁ : α₁ → α₂} {f₂ : (a : α₁) → β₁ a → β₂ (f₁ a)}
    (h₁ : function.injective f₁) (h₂ : ∀ (a : α₁), function.injective (f₂ a)) :
    function.injective (sigma.map f₁ f₂) :=
  sorry

theorem function.surjective.sigma_map {α₁ : Type u_2} {α₂ : Type u_3} {β₁ : α₁ → Type u_5}
    {β₂ : α₂ → Type u_6} {f₁ : α₁ → α₂} {f₂ : (a : α₁) → β₁ a → β₂ (f₁ a)}
    (h₁ : function.surjective f₁) (h₂ : ∀ (a : α₁), function.surjective (f₂ a)) :
    function.surjective (sigma.map f₁ f₂) :=
  sorry

/-- Interpret a function on `Σ x : α, β x` as a dependent function with two arguments. -/
def sigma.curry {α : Type u_1} {β : α → Type u_4} {γ : (a : α) → β a → Type u_2}
    (f : (x : sigma β) → γ (sigma.fst x) (sigma.snd x)) (x : α) (y : β x) : γ x y :=
  f (sigma.mk x y)

/-- Interpret a dependent function with two arguments as a function on `Σ x : α, β x` -/
def sigma.uncurry {α : Type u_1} {β : α → Type u_4} {γ : (a : α) → β a → Type u_2}
    (f : (x : α) → (y : β x) → γ x y) (x : sigma β) : γ (sigma.fst x) (sigma.snd x) :=
  f (sigma.fst x) (sigma.snd x)

/-- Convert a product type to a Σ-type. -/
@[simp] def prod.to_sigma {α : Type u_1} {β : Type u_2} : α × β → sigma fun (_x : α) => β := sorry

@[simp] theorem prod.fst_to_sigma {α : Type u_1} {β : Type u_2} (x : α × β) :
    sigma.fst (prod.to_sigma x) = prod.fst x :=
  prod.cases_on x fun (x_fst : α) (x_snd : β) => Eq.refl (sigma.fst (prod.to_sigma (x_fst, x_snd)))

@[simp] theorem prod.snd_to_sigma {α : Type u_1} {β : Type u_2} (x : α × β) :
    sigma.snd (prod.to_sigma x) = prod.snd x :=
  prod.cases_on x fun (x_fst : α) (x_snd : β) => Eq.refl (sigma.snd (prod.to_sigma (x_fst, x_snd)))

namespace psigma

/-- Nondependent eliminator for `psigma`. -/
def elim {α : Sort u_1} {β : α → Sort u_2} {γ : Sort u_3} (f : (a : α) → β a → γ) (a : psigma β) :
    γ :=
  cases_on a f

@[simp] theorem elim_val {α : Sort u_1} {β : α → Sort u_2} {γ : Sort u_3} (f : (a : α) → β a → γ)
    (a : α) (b : β a) : elim f (mk a b) = f a b :=
  rfl

protected instance inhabited {α : Sort u_1} {β : α → Sort u_2} [Inhabited α]
    [Inhabited (β Inhabited.default)] : Inhabited (psigma β) :=
  { default := mk Inhabited.default Inhabited.default }

protected instance decidable_eq {α : Sort u_1} {β : α → Sort u_2} [h₁ : DecidableEq α]
    [h₂ : (a : α) → DecidableEq (β a)] : DecidableEq (psigma β) :=
  sorry

theorem mk.inj_iff {α : Sort u_1} {β : α → Sort u_2} {a₁ : α} {a₂ : α} {b₁ : β a₁} {b₂ : β a₂} :
    mk a₁ b₁ = mk a₂ b₂ ↔ a₁ = a₂ ∧ b₁ == b₂ :=
  sorry

theorem ext {α : Sort u_1} {β : α → Sort u_2} {x₀ : psigma β} {x₁ : psigma β} (h₀ : fst x₀ = fst x₁)
    (h₁ : snd x₀ == snd x₁) : x₀ = x₁ :=
  sorry

theorem ext_iff {α : Sort u_1} {β : α → Sort u_2} {x₀ : psigma β} {x₁ : psigma β} :
    x₀ = x₁ ↔ fst x₀ = fst x₁ ∧ snd x₀ == snd x₁ :=
  cases_on x₀
    fun (x₀_fst : α) (x₀_snd : β x₀_fst) =>
      cases_on x₁ fun (x₁_fst : α) (x₁_snd : β x₁_fst) => mk.inj_iff

/-- Map the left and right components of a sigma -/
def map {α₁ : Sort u_3} {α₂ : Sort u_4} {β₁ : α₁ → Sort u_5} {β₂ : α₂ → Sort u_6} (f₁ : α₁ → α₂)
    (f₂ : (a : α₁) → β₁ a → β₂ (f₁ a)) : psigma β₁ → psigma β₂ :=
  sorry

end Mathlib


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon

Monad encapsulating continuation passing programming style, similar to
Haskell's `Cont`, `ContT` and `MonadCont`:
<http://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Cont.html>
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.monad.writer
import Mathlib.PostPort

universes u v w l u_1 u_2 u₀ u₁ v₀ v₁

namespace Mathlib

structure monad_cont.label (α : Type w) (m : Type u → Type v) (β : Type u) where
  apply : α → m β

def monad_cont.goto {α : Type u_1} {β : Type u} {m : Type u → Type v} (f : monad_cont.label α m β)
    (x : α) : m β :=
  monad_cont.label.apply f x

class monad_cont (m : Type u → Type v) where
  call_cc : {α β : Type u} → (monad_cont.label α m β → m α) → m α

class is_lawful_monad_cont (m : Type u → Type v) [Monad m] [monad_cont m] extends is_lawful_monad m
    where
  call_cc_bind_right :
    ∀ {α ω γ : Type u} (cmd : m α) (next : monad_cont.label ω m γ → α → m ω),
      (monad_cont.call_cc fun (f : monad_cont.label ω m γ) => cmd >>= next f) =
        do
          let x ← cmd
          monad_cont.call_cc fun (f : monad_cont.label ω m γ) => next f x
  call_cc_bind_left :
    ∀ {α : Type u} (β : Type u) (x : α) (dead : monad_cont.label α m β → β → m α),
      (monad_cont.call_cc fun (f : monad_cont.label α m β) => monad_cont.goto f x >>= dead f) =
        pure x
  call_cc_dummy :
    ∀ {α β : Type u} (dummy : m α),
      (monad_cont.call_cc fun (f : monad_cont.label α m β) => dummy) = dummy

def cont_t (r : Type u) (m : Type u → Type v) (α : Type w) := (α → m r) → m r

def cont (r : Type u) (α : Type w) := cont_t r id α

namespace cont_t

def run {r : Type u} {m : Type u → Type v} {α : Type w} : cont_t r m α → (α → m r) → m r := id

def map {r : Type u} {m : Type u → Type v} {α : Type w} (f : m r → m r) (x : cont_t r m α) :
    cont_t r m α :=
  f ∘ x

theorem run_cont_t_map_cont_t {r : Type u} {m : Type u → Type v} {α : Type w} (f : m r → m r)
    (x : cont_t r m α) : run (map f x) = f ∘ run x :=
  rfl

def with_cont_t {r : Type u} {m : Type u → Type v} {α : Type w} {β : Type w}
    (f : (β → m r) → α → m r) (x : cont_t r m α) : cont_t r m β :=
  fun (g : β → m r) => x (f g)

theorem run_with_cont_t {r : Type u} {m : Type u → Type v} {α : Type w} {β : Type w}
    (f : (β → m r) → α → m r) (x : cont_t r m α) : run (with_cont_t f x) = run x ∘ f :=
  rfl

protected theorem ext {r : Type u} {m : Type u → Type v} {α : Type w} {x : cont_t r m α}
    {y : cont_t r m α} (h : ∀ (f : α → m r), run x f = run y f) : x = y :=
  funext fun (x_1 : α → m r) => h x_1

protected instance monad {r : Type u} {m : Type u → Type v} : Monad (cont_t r m) := sorry

protected instance is_lawful_monad {r : Type u} {m : Type u → Type v} :
    is_lawful_monad (cont_t r m) :=
  is_lawful_monad.mk
    (fun (α β : Type u_1) (x : α) (f : α → cont_t r m β) =>
      cont_t.ext fun (f_1 : β → m r) => Eq.refl (run (pure x >>= f) f_1))
    fun (α β γ : Type u_1) (x : cont_t r m α) (f : α → cont_t r m β) (g : β → cont_t r m γ) =>
      cont_t.ext fun (f_1 : γ → m r) => Eq.refl (run (x >>= f >>= g) f_1)

def monad_lift {r : Type u} {m : Type u → Type v} [Monad m] {α : Type u} : m α → cont_t r m α :=
  fun (x : m α) (f : α → m r) => x >>= f

protected instance has_monad_lift {r : Type u} {m : Type u → Type v} [Monad m] :
    has_monad_lift m (cont_t r m) :=
  has_monad_lift.mk fun (α : Type u) => monad_lift

theorem monad_lift_bind {r : Type u} {m : Type u → Type v} [Monad m] [is_lawful_monad m]
    {α : Type u} {β : Type u} (x : m α) (f : α → m β) :
    monad_lift (x >>= f) = monad_lift x >>= monad_lift ∘ f :=
  sorry

protected instance monad_cont {r : Type u} {m : Type u → Type v} : monad_cont (cont_t r m) :=
  monad_cont.mk
    fun (α β : Type u_1) (f : label α (cont_t r m) β → cont_t r m α) (g : α → m r) =>
      f (monad_cont.label.mk fun (x : α) (h : β → m r) => g x) g

protected instance is_lawful_monad_cont {r : Type u} {m : Type u → Type v} :
    is_lawful_monad_cont (cont_t r m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

protected instance monad_except {r : Type u} {m : Type u → Type v} (ε : outParam (Type u_1))
    [monad_except ε m] : monad_except ε (cont_t r m) :=
  monad_except.mk (fun (x : Type u_2) (e : ε) (f : x → m r) => throw e)
    fun (α : Type u_2) (act : cont_t r m α) (h : ε → cont_t r m α) (f : α → m r) =>
      catch (act f) fun (e : ε) => h e f

protected instance monad_run {r : Type u} {m : Type u → Type v} :
    monad_run (fun (α : Type u) => (α → m r) → ulift (m r)) (cont_t r m) :=
  monad_run.mk fun (α : Type u) (f : cont_t r m α) (x : α → m r) => ulift.up (f x)

end cont_t

def except_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} {ε : Type u} :
    label (except ε α) m β → label α (except_t ε m) β :=
  sorry

theorem except_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u}
    {ε : Type u} (x : label (except ε α) m β) (i : α) :
    goto (except_t.mk_label x) i = except_t.mk (except.ok <$> goto x (except.ok i)) :=
  monad_cont.label.cases_on x
    fun (x : except ε α → m β) => Eq.refl (goto (except_t.mk_label (monad_cont.label.mk x)) i)

def except_t.call_cc {m : Type u → Type v} [Monad m] {ε : Type u} [monad_cont m] {α : Type u}
    {β : Type u} (f : label α (except_t ε m) β → except_t ε m α) : except_t ε m α :=
  except_t.mk
    (monad_cont.call_cc fun (x : label (except ε α) m β) => except_t.run (f (except_t.mk_label x)))

protected instance except_t.monad_cont {m : Type u → Type v} [Monad m] {ε : Type u} [monad_cont m] :
    monad_cont (except_t ε m) :=
  monad_cont.mk fun (α β : Type u) => except_t.call_cc

protected instance except_t.is_lawful_monad_cont {m : Type u → Type v} [Monad m] {ε : Type u}
    [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (except_t ε m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

def option_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} :
    label (Option α) m β → label α (option_t m) β :=
  sorry

theorem option_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u}
    (x : label (Option α) m β) (i : α) :
    goto (option_t.mk_label x) i = option_t.mk (some <$> goto x (some i)) :=
  monad_cont.label.cases_on x
    fun (x : Option α → m β) => Eq.refl (goto (option_t.mk_label (monad_cont.label.mk x)) i)

def option_t.call_cc {m : Type u → Type v} [Monad m] [monad_cont m] {α : Type u} {β : Type u}
    (f : label α (option_t m) β → option_t m α) : option_t m α :=
  option_t.mk
    (monad_cont.call_cc fun (x : label (Option α) m β) => option_t.run (f (option_t.mk_label x)))

protected instance option_t.monad_cont {m : Type u → Type v} [Monad m] [monad_cont m] :
    monad_cont (option_t m) :=
  monad_cont.mk fun (α β : Type u) => option_t.call_cc

protected instance option_t.is_lawful_monad_cont {m : Type u → Type v} [Monad m] [monad_cont m]
    [is_lawful_monad_cont m] : is_lawful_monad_cont (option_t m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

def writer_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u_1} {β : Type u} {ω : Type u}
    [HasOne ω] : label (α × ω) m β → label α (writer_t ω m) β :=
  sorry

theorem writer_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u_1} {β : Type u}
    {ω : Type u} [HasOne ω] (x : label (α × ω) m β) (i : α) :
    goto (writer_t.mk_label x) i = monad_lift (goto x (i, 1)) :=
  monad_cont.label.cases_on x
    fun (x : α × ω → m β) => Eq.refl (goto (writer_t.mk_label (monad_cont.label.mk x)) i)

def writer_t.call_cc {m : Type u → Type v} [Monad m] [monad_cont m] {α : Type u} {β : Type u}
    {ω : Type u} [HasOne ω] (f : label α (writer_t ω m) β → writer_t ω m α) : writer_t ω m α :=
  writer_t.mk (monad_cont.call_cc (writer_t.run ∘ f ∘ writer_t.mk_label))

protected instance writer_t.monad_cont {m : Type u → Type v} [Monad m] (ω : Type u) [Monad m]
    [HasOne ω] [monad_cont m] : monad_cont (writer_t ω m) :=
  monad_cont.mk fun (α β : Type u) => writer_t.call_cc

def state_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} {σ : Type u} :
    label (α × σ) m (β × σ) → label α (state_t σ m) β :=
  sorry

theorem state_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} {σ : Type u}
    (x : label (α × σ) m (β × σ)) (i : α) :
    goto (state_t.mk_label x) i = state_t.mk fun (s : σ) => goto x (i, s) :=
  monad_cont.label.cases_on x
    fun (x : α × σ → m (β × σ)) => Eq.refl (goto (state_t.mk_label (monad_cont.label.mk x)) i)

def state_t.call_cc {m : Type u → Type v} [Monad m] {σ : Type u} [monad_cont m] {α : Type u}
    {β : Type u} (f : label α (state_t σ m) β → state_t σ m α) : state_t σ m α :=
  state_t.mk
    fun (r : σ) =>
      monad_cont.call_cc
        fun (f' : label (α × σ) m (β × σ)) => state_t.run (f (state_t.mk_label f')) r

protected instance state_t.monad_cont {m : Type u → Type v} [Monad m] {σ : Type u} [monad_cont m] :
    monad_cont (state_t σ m) :=
  monad_cont.mk fun (α β : Type u) => state_t.call_cc

protected instance state_t.is_lawful_monad_cont {m : Type u → Type v} [Monad m] {σ : Type u}
    [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (state_t σ m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

def reader_t.mk_label {m : Type u → Type v} [Monad m] {α : Type u_1} {β : Type u} (ρ : Type u) :
    label α m β → label α (reader_t ρ m) β :=
  sorry

theorem reader_t.goto_mk_label {m : Type u → Type v} [Monad m] {α : Type u_1} {ρ : Type u}
    {β : Type u} (x : label α m β) (i : α) :
    goto (reader_t.mk_label ρ x) i = monad_lift (goto x i) :=
  monad_cont.label.cases_on x
    fun (x : α → m β) => Eq.refl (goto (reader_t.mk_label ρ (monad_cont.label.mk x)) i)

def reader_t.call_cc {m : Type u → Type v} [Monad m] {ε : Type u} [monad_cont m] {α : Type u}
    {β : Type u} (f : label α (reader_t ε m) β → reader_t ε m α) : reader_t ε m α :=
  reader_t.mk
    fun (r : ε) =>
      monad_cont.call_cc fun (f' : label α m β) => reader_t.run (f (reader_t.mk_label ε f')) r

protected instance reader_t.monad_cont {m : Type u → Type v} [Monad m] {ρ : Type u} [monad_cont m] :
    monad_cont (reader_t ρ m) :=
  monad_cont.mk fun (α β : Type u) => reader_t.call_cc

protected instance reader_t.is_lawful_monad_cont {m : Type u → Type v} [Monad m] {ρ : Type u}
    [monad_cont m] [is_lawful_monad_cont m] : is_lawful_monad_cont (reader_t ρ m) :=
  is_lawful_monad_cont.mk sorry sorry sorry

/-- reduce the equivalence between two continuation passing monads to the equivalence between
their underlying monad -/
def cont_t.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁} {α₁ : Type u₀} {r₁ : Type u₀}
    {α₂ : Type u₁} {r₂ : Type u₁} (F : m₁ r₁ ≃ m₂ r₂) (G : α₁ ≃ α₂) :
    cont_t r₁ m₁ α₁ ≃ cont_t r₂ m₂ α₂ :=
  equiv.mk
    (fun (f : cont_t r₁ m₁ α₁) (r : α₂ → m₂ r₂) =>
      coe_fn F (f fun (x : α₁) => coe_fn (equiv.symm F) (r (coe_fn G x))))
    (fun (f : cont_t r₂ m₂ α₂) (r : α₁ → m₁ r₁) =>
      coe_fn (equiv.symm F) (f fun (x : α₂) => coe_fn F (r (coe_fn (equiv.symm G) x))))
    sorry sorry

end Mathlib


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.limits.shapes.diagonal
import category_theory.arrow
import category_theory.limits.shapes.comm_sq
import category_theory.concrete_category.basic

/-!
# Properties of morphisms

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

We provide the basic framework for talking about properties of morphisms.
The following meta-properties are defined

* `respects_iso`: `P` respects isomorphisms if `P f → P (e ≫ f)` and `P f → P (f ≫ e)`, where
  `e` is an isomorphism.
* `stable_under_composition`: `P` is stable under composition if `P f → P g → P (f ≫ g)`.
* `stable_under_base_change`: `P` is stable under base change if in all pullback
  squares, the left map satisfies `P` if the right map satisfies it.
* `stable_under_cobase_change`: `P` is stable under cobase change if in all pushout
  squares, the right map satisfies `P` if the left map satisfies it.

-/

universes v u

open category_theory category_theory.limits opposite

noncomputable theory

namespace category_theory

variables (C : Type u) [category.{v} C] {D : Type*} [category D]

/-- A `morphism_property C` is a class of morphisms between objects in `C`. -/
@[derive complete_lattice]
def morphism_property := ∀ ⦃X Y : C⦄ (f : X ⟶ Y), Prop

instance : inhabited (morphism_property C) := ⟨⊤⟩

variable {C}

namespace morphism_property

instance : has_subset (morphism_property C) :=
⟨λ P₁ P₂, ∀ ⦃X Y : C⦄ (f : X ⟶ Y) (hf : P₁ f), P₂ f⟩
instance : has_inter (morphism_property C) :=
⟨λ P₁ P₂ X Y f, P₁ f ∧ P₂ f⟩

/-- The morphism property in `Cᵒᵖ` associated to a morphism property in `C` -/
@[simp] def op (P : morphism_property C) : morphism_property Cᵒᵖ := λ X Y f, P f.unop

/-- The morphism property in `C` associated to a morphism property in `Cᵒᵖ` -/
@[simp] def unop (P : morphism_property Cᵒᵖ) : morphism_property C := λ X Y f, P f.op

lemma unop_op (P : morphism_property C) : P.op.unop = P := rfl
lemma op_unop (P : morphism_property Cᵒᵖ) : P.unop.op = P := rfl

/-- The inverse image of a `morphism_property D` by a functor `C ⥤ D` -/
def inverse_image (P : morphism_property D) (F : C ⥤ D) : morphism_property C :=
λ X Y f, P (F.map f)

/-- A morphism property `respects_iso` if it still holds when composed with an isomorphism -/
def respects_iso (P : morphism_property C) : Prop :=
  (∀ {X Y Z} (e : X ≅ Y) (f : Y ⟶ Z), P f → P (e.hom ≫ f)) ∧
  (∀ {X Y Z} (e : Y ≅ Z) (f : X ⟶ Y), P f → P (f ≫ e.hom))

lemma respects_iso.op {P : morphism_property C} (h : respects_iso P) : respects_iso P.op :=
⟨λ X Y Z e f hf, h.2 e.unop f.unop hf, λ X Y Z e f hf, h.1 e.unop f.unop hf⟩

lemma respects_iso.unop {P : morphism_property Cᵒᵖ} (h : respects_iso P) : respects_iso P.unop :=
⟨λ X Y Z e f hf, h.2 e.op f.op hf, λ X Y Z e f hf, h.1 e.op f.op hf⟩

/-- A morphism property is `stable_under_composition` if the composition of two such morphisms
still falls in the class. -/
def stable_under_composition (P : morphism_property C) : Prop :=
  ∀ ⦃X Y Z⦄ (f : X ⟶ Y) (g : Y ⟶ Z), P f → P g → P (f ≫ g)

lemma stable_under_composition.op {P : morphism_property C} (h : stable_under_composition P) :
  stable_under_composition P.op := λ X Y Z f g hf hg, h g.unop f.unop hg hf

lemma stable_under_composition.unop {P : morphism_property Cᵒᵖ} (h : stable_under_composition P) :
  stable_under_composition P.unop := λ X Y Z f g hf hg, h g.op f.op hg hf

/-- A morphism property is `stable_under_inverse` if the inverse of a morphism satisfying
the property still falls in the class. -/
def stable_under_inverse (P : morphism_property C) : Prop :=
∀ ⦃X Y⦄ (e : X ≅ Y), P e.hom → P e.inv

lemma stable_under_inverse.op {P : morphism_property C} (h : stable_under_inverse P) :
  stable_under_inverse P.op := λ X Y e he, h e.unop he

lemma stable_under_inverse.unop {P : morphism_property Cᵒᵖ} (h : stable_under_inverse P) :
  stable_under_inverse P.unop := λ X Y e he, h e.op he

/-- A morphism property is `stable_under_base_change` if the base change of such a morphism
still falls in the class. -/
def stable_under_base_change (P : morphism_property C) : Prop :=
∀ ⦃X Y Y' S : C⦄ ⦃f : X ⟶ S⦄ ⦃g : Y ⟶ S⦄ ⦃f' : Y' ⟶ Y⦄ ⦃g' : Y' ⟶ X⦄
  (sq : is_pullback f' g' g f) (hg : P g), P g'

/-- A morphism property is `stable_under_cobase_change` if the cobase change of such a morphism
still falls in the class. -/
def stable_under_cobase_change (P : morphism_property C) : Prop :=
∀ ⦃A A' B B' : C⦄ ⦃f : A ⟶ A'⦄ ⦃g : A ⟶ B⦄ ⦃f' : B ⟶ B'⦄ ⦃g' : A' ⟶ B'⦄
  (sq : is_pushout g f f' g') (hf : P f), P f'

lemma stable_under_composition.respects_iso {P : morphism_property C}
  (hP : stable_under_composition P) (hP' : ∀ {X Y} (e : X ≅ Y), P e.hom) : respects_iso P :=
⟨λ X Y Z e f hf, hP _ _ (hP' e) hf, λ X Y Z e f hf, hP _ _ hf (hP' e)⟩

lemma respects_iso.cancel_left_is_iso {P : morphism_property C}
  (hP : respects_iso P) {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso f] :
    P (f ≫ g) ↔ P g :=
⟨λ h, by simpa using hP.1 (as_iso f).symm (f ≫ g) h, hP.1 (as_iso f) g⟩

lemma respects_iso.cancel_right_is_iso {P : morphism_property C}
  (hP : respects_iso P) {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso g] :
    P (f ≫ g) ↔ P f :=
⟨λ h, by simpa using hP.2 (as_iso g).symm (f ≫ g) h, hP.2 (as_iso g) f⟩

lemma respects_iso.arrow_iso_iff {P : morphism_property C}
  (hP : respects_iso P) {f g : arrow C} (e : f ≅ g) : P f.hom ↔ P g.hom :=
by { rw [← arrow.inv_left_hom_right e.hom, hP.cancel_left_is_iso, hP.cancel_right_is_iso], refl }

lemma respects_iso.arrow_mk_iso_iff {P : morphism_property C}
  (hP : respects_iso P) {W X Y Z : C} {f : W ⟶ X} {g : Y ⟶ Z} (e : arrow.mk f ≅ arrow.mk g) :
    P f ↔ P g :=
hP.arrow_iso_iff e

lemma respects_iso.of_respects_arrow_iso (P : morphism_property C)
  (hP : ∀ (f g : arrow C) (e : f ≅ g) (hf : P f.hom), P g.hom) : respects_iso P :=
begin
  split,
  { intros X Y Z e f hf,
    refine hP (arrow.mk f) (arrow.mk (e.hom ≫ f)) (arrow.iso_mk e.symm (iso.refl _) _) hf,
    dsimp,
    simp only [iso.inv_hom_id_assoc, category.comp_id], },
  { intros X Y Z e f hf,
    refine hP (arrow.mk f) (arrow.mk (f ≫ e.hom)) (arrow.iso_mk (iso.refl _) e _) hf,
    dsimp,
    simp only [category.id_comp], },
end

lemma stable_under_base_change.mk {P : morphism_property C} [has_pullbacks C]
  (hP₁ : respects_iso P)
  (hP₂ : ∀ (X Y S : C) (f : X ⟶ S) (g : Y ⟶ S) (hg : P g), P (pullback.fst : pullback f g ⟶ X)) :
  stable_under_base_change P := λ X Y Y' S f g f' g' sq hg,
begin
  let e := sq.flip.iso_pullback,
  rw [← hP₁.cancel_left_is_iso e.inv, sq.flip.iso_pullback_inv_fst],
  exact hP₂ _ _ _ f g hg,
end

lemma stable_under_base_change.respects_iso {P : morphism_property C}
  (hP : stable_under_base_change P) : respects_iso P :=
begin
  apply respects_iso.of_respects_arrow_iso,
  intros f g e,
  exact hP (is_pullback.of_horiz_is_iso (comm_sq.mk e.inv.w)),
end

lemma stable_under_base_change.fst {P : morphism_property C}
  (hP : stable_under_base_change P) {X Y S : C} (f : X ⟶ S) (g : Y ⟶ S) [has_pullback f g]
  (H : P g) : P (pullback.fst : pullback f g ⟶ X) :=
hP (is_pullback.of_has_pullback f g).flip H

lemma stable_under_base_change.snd {P : morphism_property C}
  (hP : stable_under_base_change P) {X Y S : C} (f : X ⟶ S) (g : Y ⟶ S) [has_pullback f g]
  (H : P f) : P (pullback.snd : pullback f g ⟶ Y) :=
hP (is_pullback.of_has_pullback f g) H

lemma stable_under_base_change.base_change_obj [has_pullbacks C] {P : morphism_property C}
  (hP : stable_under_base_change P) {S S' : C} (f : S' ⟶ S)
  (X : over S) (H : P X.hom) : P ((base_change f).obj X).hom :=
hP.snd X.hom f H

lemma stable_under_base_change.base_change_map [has_pullbacks C] {P : morphism_property C}
  (hP : stable_under_base_change P) {S S' : C} (f : S' ⟶ S)
  {X Y : over S} (g : X ⟶ Y) (H : P g.left) : P ((base_change f).map g).left :=
begin
  let e := pullback_right_pullback_fst_iso Y.hom f g.left ≪≫
    pullback.congr_hom (g.w.trans (category.comp_id _)) rfl,
  have : e.inv ≫ pullback.snd = ((base_change f).map g).left,
  { apply pullback.hom_ext; dsimp; simp },
  rw [← this, hP.respects_iso.cancel_left_is_iso],
  exact hP.snd _ _ H,
end

lemma stable_under_base_change.pullback_map [has_pullbacks C] {P : morphism_property C}
  (hP : stable_under_base_change P) (hP' : stable_under_composition P) {S X X' Y Y' : C}
  {f : X ⟶ S} {g : Y ⟶ S} {f' : X' ⟶ S} {g' : Y' ⟶ S} {i₁ : X ⟶ X'} {i₂ : Y ⟶ Y'}
  (h₁ : P i₁) (h₂ : P i₂) (e₁ : f = i₁ ≫ f') (e₂ : g = i₂ ≫ g') :
    P (pullback.map f g f' g' i₁ i₂ (𝟙 _)
      ((category.comp_id _).trans e₁) ((category.comp_id _).trans e₂)) :=
begin
  have : pullback.map f g f' g' i₁ i₂ (𝟙 _)
    ((category.comp_id _).trans e₁) ((category.comp_id _).trans e₂) =
      ((pullback_symmetry _ _).hom ≫
      ((base_change _).map (over.hom_mk _ e₂.symm : over.mk g ⟶ over.mk g')).left) ≫
      (pullback_symmetry _ _).hom ≫
      ((base_change g').map (over.hom_mk _ e₁.symm : over.mk f ⟶ over.mk f')).left,
  { apply pullback.hom_ext; dsimp; simp },
  rw this,
  apply hP'; rw hP.respects_iso.cancel_left_is_iso,
  exacts [hP.base_change_map _ (over.hom_mk _ e₂.symm : over.mk g ⟶ over.mk g') h₂,
    hP.base_change_map _ (over.hom_mk _ e₁.symm : over.mk f ⟶ over.mk f') h₁],
end

lemma stable_under_cobase_change.mk {P : morphism_property C} [has_pushouts C]
  (hP₁ : respects_iso P)
  (hP₂ : ∀ (A B A' : C) (f : A ⟶ A') (g : A ⟶ B) (hf : P f), P (pushout.inr : B ⟶ pushout f g)) :
  stable_under_cobase_change P := λ A A' B B' f g f' g' sq hf,
begin
  let e := sq.flip.iso_pushout,
  rw [← hP₁.cancel_right_is_iso _ e.hom, sq.flip.inr_iso_pushout_hom],
  exact hP₂ _ _ _ f g hf,
end

lemma stable_under_cobase_change.respects_iso {P : morphism_property C}
  (hP : stable_under_cobase_change P) : respects_iso P :=
respects_iso.of_respects_arrow_iso _ (λ f g e, hP (is_pushout.of_horiz_is_iso (comm_sq.mk e.hom.w)))

lemma stable_under_cobase_change.inl {P : morphism_property C}
  (hP : stable_under_cobase_change P) {A B A' : C} (f : A ⟶ A') (g : A ⟶ B) [has_pushout f g]
  (H : P g) : P (pushout.inl : A' ⟶ pushout f g) :=
hP (is_pushout.of_has_pushout f g) H

lemma stable_under_cobase_change.inr {P : morphism_property C}
  (hP : stable_under_cobase_change P) {A B A' : C} (f : A ⟶ A') (g : A ⟶ B) [has_pushout f g]
  (H : P f) : P (pushout.inr : B ⟶ pushout f g) :=
hP (is_pushout.of_has_pushout f g).flip H

lemma stable_under_cobase_change.op {P : morphism_property C}
  (hP : stable_under_cobase_change P) : stable_under_base_change P.op :=
λ X Y Y' S f g f' g' sq hg, hP sq.unop hg

lemma stable_under_cobase_change.unop {P : morphism_property Cᵒᵖ}
  (hP : stable_under_cobase_change P) : stable_under_base_change P.unop :=
λ X Y Y' S f g f' g' sq hg, hP sq.op hg

lemma stable_under_base_change.op {P : morphism_property C}
  (hP : stable_under_base_change P) : stable_under_cobase_change P.op :=
λ A A' B B' f g f' g' sq hf, hP sq.unop hf

lemma stable_under_base_change.unop {P : morphism_property Cᵒᵖ}
  (hP : stable_under_base_change P) : stable_under_cobase_change P.unop :=
λ A A' B B' f g f' g' sq hf, hP sq.op hf

/-- If `P : morphism_property C` and `F : C ⥤ D`, then
`P.is_inverted_by F` means that all morphisms in `P` are mapped by `F`
to isomorphisms in `D`. -/
def is_inverted_by (P : morphism_property C) (F : C ⥤ D) : Prop :=
∀ ⦃X Y : C⦄ (f : X ⟶ Y) (hf : P f), is_iso (F.map f)

namespace is_inverted_by

lemma of_comp {C₁ C₂ C₃ : Type*} [category C₁] [category C₂] [category C₃]
  (W : morphism_property C₁) (F : C₁ ⥤ C₂) (hF : W.is_inverted_by F) (G : C₂ ⥤ C₃) :
  W.is_inverted_by (F ⋙ G) :=
λ X Y f hf, by { haveI := hF f hf, dsimp, apply_instance, }

lemma op {W : morphism_property C} {L : C ⥤ D} (h : W.is_inverted_by L) :
  W.op.is_inverted_by L.op :=
λ X Y f hf, by { haveI := h f.unop hf, dsimp, apply_instance, }

lemma right_op {W : morphism_property C} {L : Cᵒᵖ ⥤ D} (h : W.op.is_inverted_by L) :
  W.is_inverted_by L.right_op :=
λ X Y f hf, by { haveI := h f.op hf, dsimp, apply_instance, }

lemma left_op {W : morphism_property C} {L : C ⥤ Dᵒᵖ} (h : W.is_inverted_by L) :
  W.op.is_inverted_by L.left_op :=
λ X Y f hf, by { haveI := h f.unop hf, dsimp, apply_instance, }

lemma unop {W : morphism_property C} {L : Cᵒᵖ ⥤ Dᵒᵖ} (h : W.op.is_inverted_by L) :
  W.is_inverted_by L.unop :=
λ X Y f hf, by { haveI := h f.op hf, dsimp, apply_instance, }

end is_inverted_by

/-- Given `app : Π X, F₁.obj X ⟶ F₂.obj X` where `F₁` and `F₂` are two functors,
this is the `morphism_property C` satisfied by the morphisms in `C` with respect
to whom `app` is natural. -/
@[simp]
def naturality_property {F₁ F₂ : C ⥤ D} (app : Π X, F₁.obj X ⟶ F₂.obj X) :
  morphism_property C := λ X Y f, F₁.map f ≫ app Y = app X ≫ F₂.map f

namespace naturality_property

lemma is_stable_under_composition {F₁ F₂ : C ⥤ D} (app : Π X, F₁.obj X ⟶ F₂.obj X) :
  (naturality_property app).stable_under_composition := λ X Y Z f g hf hg,
begin
  simp only [naturality_property] at ⊢ hf hg,
  simp only [functor.map_comp, category.assoc, hg],
  slice_lhs 1 2 { rw hf },
  rw category.assoc,
end

lemma is_stable_under_inverse {F₁ F₂ : C ⥤ D} (app : Π X, F₁.obj X ⟶ F₂.obj X) :
  (naturality_property app).stable_under_inverse := λ X Y e he,
begin
  simp only [naturality_property] at ⊢ he,
  rw ← cancel_epi (F₁.map e.hom),
  slice_rhs 1 2 { rw he },
  simp only [category.assoc, ← F₁.map_comp_assoc, ← F₂.map_comp,
    e.hom_inv_id, functor.map_id, category.id_comp, category.comp_id],
end

end naturality_property

lemma respects_iso.inverse_image {P : morphism_property D} (h : respects_iso P) (F : C ⥤ D) :
  respects_iso (P.inverse_image F) :=
begin
  split,
  all_goals
  { intros X Y Z e f hf,
    dsimp [inverse_image],
    rw F.map_comp, },
  exacts [h.1 (F.map_iso e) (F.map f) hf, h.2 (F.map_iso e) (F.map f) hf],
end

lemma stable_under_composition.inverse_image {P : morphism_property D}
  (h : stable_under_composition P) (F : C ⥤ D) : stable_under_composition (P.inverse_image F) :=
λ X Y Z f g hf hg, by simpa only [← F.map_comp] using h (F.map f) (F.map g) hf hg

variable (C)

/-- The `morphism_property C` satisfied by isomorphisms in `C`. -/
def isomorphisms : morphism_property C := λ X Y f, is_iso f

/-- The `morphism_property C` satisfied by monomorphisms in `C`. -/
def monomorphisms : morphism_property C := λ X Y f, mono f

/-- The `morphism_property C` satisfied by epimorphisms in `C`. -/
def epimorphisms : morphism_property C := λ X Y f, epi f

section

variables {C} {X Y : C} (f : X ⟶ Y)

@[simp] lemma isomorphisms.iff : (isomorphisms C) f ↔ is_iso f := by refl
@[simp] lemma monomorphisms.iff : (monomorphisms C) f ↔ mono f := by refl
@[simp] lemma epimorphisms.iff : (epimorphisms C) f ↔ epi f := by refl

lemma isomorphisms.infer_property [hf : is_iso f] : (isomorphisms C) f := hf
lemma monomorphisms.infer_property [hf : mono f] : (monomorphisms C) f := hf
lemma epimorphisms.infer_property [hf : epi f] : (epimorphisms C) f := hf

end

lemma respects_iso.monomorphisms : respects_iso (monomorphisms C) :=
by { split; { intros X Y Z e f, simp only [monomorphisms.iff], introI, apply mono_comp, }, }

lemma respects_iso.epimorphisms : respects_iso (epimorphisms C) :=
by { split; { intros X Y Z e f, simp only [epimorphisms.iff], introI, apply epi_comp, }, }

lemma respects_iso.isomorphisms : respects_iso (isomorphisms C) :=
by { split; { intros X Y Z e f, simp only [isomorphisms.iff], introI, apply_instance, }, }

lemma stable_under_composition.isomorphisms : stable_under_composition (isomorphisms C) :=
λ X Y Z f g hf hg, begin
  rw isomorphisms.iff at hf hg ⊢,
  haveI := hf,
  haveI := hg,
  apply_instance,
end

lemma stable_under_composition.monomorphisms : stable_under_composition (monomorphisms C) :=
λ X Y Z f g hf hg, begin
  rw monomorphisms.iff at hf hg ⊢,
  haveI := hf,
  haveI := hg,
  apply mono_comp,
end

lemma stable_under_composition.epimorphisms : stable_under_composition (epimorphisms C) :=
λ X Y Z f g hf hg, begin
  rw epimorphisms.iff at hf hg ⊢,
  haveI := hf,
  haveI := hg,
  apply epi_comp,
end

variable {C}

/-- The full subcategory of `C ⥤ D` consisting of functors inverting morphisms in `W` -/
@[derive category, nolint has_nonempty_instance]
def functors_inverting (W : morphism_property C) (D : Type*) [category D] :=
full_subcategory (λ (F : C ⥤ D), W.is_inverted_by F)

/-- A constructor for `W.functors_inverting D` -/
def functors_inverting.mk {W : morphism_property C} {D : Type*} [category D]
(F : C ⥤ D) (hF : W.is_inverted_by F) : W.functors_inverting D := ⟨F, hF⟩

lemma is_inverted_by.iff_of_iso (W : morphism_property C) {F₁ F₂ : C ⥤ D} (e : F₁ ≅ F₂) :
  W.is_inverted_by F₁ ↔ W.is_inverted_by F₂ :=
begin
  suffices : ∀ (X Y : C) (f : X ⟶ Y), is_iso (F₁.map f) ↔ is_iso (F₂.map f),
  { split,
    exact λ h X Y f hf, by { rw ← this, exact h f hf, },
    exact λ h X Y f hf, by { rw this, exact h f hf, }, },
  intros X Y f,
  exact (respects_iso.isomorphisms D).arrow_mk_iso_iff
    (arrow.iso_mk (e.app X) (e.app Y) (by simp)),
end

section diagonal

variables [has_pullbacks C] {P : morphism_property C}

/-- For `P : morphism_property C`, `P.diagonal` is a morphism property that holds for `f : X ⟶ Y`
whenever `P` holds for `X ⟶ Y xₓ Y`. -/
def diagonal (P : morphism_property C) : morphism_property C :=
λ X Y f, P (pullback.diagonal f)

lemma diagonal_iff {X Y : C} {f : X ⟶ Y} : P.diagonal f ↔ P (pullback.diagonal f) := iff.rfl

lemma respects_iso.diagonal (hP : P.respects_iso) : P.diagonal.respects_iso :=
begin
  split,
  { introv H,
    rwa [diagonal_iff, pullback.diagonal_comp, hP.cancel_left_is_iso, hP.cancel_left_is_iso,
      ← hP.cancel_right_is_iso _ _, ← pullback.condition, hP.cancel_left_is_iso],
    apply_instance },
  { introv H,
    delta diagonal,
    rwa [pullback.diagonal_comp, hP.cancel_right_is_iso] }
end

lemma stable_under_composition.diagonal
  (hP : stable_under_composition P) (hP' : respects_iso P) (hP'' : stable_under_base_change P) :
  P.diagonal.stable_under_composition :=
begin
  introv X h₁ h₂,
  rw [diagonal_iff, pullback.diagonal_comp],
  apply hP, { assumption },
  rw hP'.cancel_left_is_iso,
  apply hP''.snd,
  assumption
end

lemma stable_under_base_change.diagonal
  (hP : stable_under_base_change P) (hP' : respects_iso P) :
  P.diagonal.stable_under_base_change :=
stable_under_base_change.mk hP'.diagonal
begin
  introv h,
  rw [diagonal_iff, diagonal_pullback_fst, hP'.cancel_left_is_iso, hP'.cancel_right_is_iso],
  convert hP.base_change_map f _ _; simp; assumption
end

end diagonal

section universally

/-- `P.universally` holds for a morphism `f : X ⟶ Y` iff `P` holds for all `X ×[Y] Y' ⟶ Y'`. -/
def universally (P : morphism_property C) : morphism_property C :=
λ X Y f, ∀ ⦃X' Y' : C⦄ (i₁ : X' ⟶ X) (i₂ : Y' ⟶ Y) (f' : X' ⟶ Y')
  (h : is_pullback f' i₁ i₂ f), P f'

lemma universally_respects_iso (P : morphism_property C) :
  P.universally.respects_iso :=
begin
  constructor,
  { intros X Y Z e f hf X' Z' i₁ i₂ f' H,
    have : is_pullback (𝟙 _) (i₁ ≫ e.hom) i₁ e.inv := is_pullback.of_horiz_is_iso
      ⟨by rw [category.id_comp, category.assoc, e.hom_inv_id, category.comp_id]⟩,
    replace this := this.paste_horiz H,
    rw [iso.inv_hom_id_assoc, category.id_comp] at this,
    exact hf _ _ _ this },
  { intros X Y Z e f hf X' Z' i₁ i₂ f' H,
    have : is_pullback (𝟙 _) i₂ (i₂ ≫ e.inv) e.inv :=
      is_pullback.of_horiz_is_iso ⟨category.id_comp _⟩,
    replace this := H.paste_horiz this,
    rw [category.assoc, iso.hom_inv_id, category.comp_id, category.comp_id] at this,
    exact hf _ _ _ this },
end

lemma universally_stable_under_base_change (P : morphism_property C) :
  P.universally.stable_under_base_change :=
λ X Y Y' S f g f' g' H h₁ Y'' X'' i₁ i₂ f'' H', h₁ _ _ _ (H'.paste_vert H.flip)

lemma stable_under_composition.universally [has_pullbacks C]
  {P : morphism_property C} (hP : P.stable_under_composition) :
  P.universally.stable_under_composition :=
begin
  intros X Y Z f g hf hg X' Z' i₁ i₂ f' H,
  have := pullback.lift_fst _ _ (H.w.trans (category.assoc _ _ _).symm),
  rw ← this at H ⊢,
  apply hP _ _ _ (hg _ _ _ $ is_pullback.of_has_pullback _ _),
  exact hf _ _ _ (H.of_right (pullback.lift_snd _ _ _) (is_pullback.of_has_pullback i₂ g))
end

lemma universally_le (P : morphism_property C) :
  P.universally ≤ P :=
begin
  intros X Y f hf,
  exact hf (𝟙 _) (𝟙 _) _ (is_pullback.of_vert_is_iso ⟨by rw [category.comp_id, category.id_comp]⟩)
end

lemma stable_under_base_change.universally_eq
  {P : morphism_property C} (hP : P.stable_under_base_change) :
  P.universally = P :=
P.universally_le.antisymm $ λ X Y f hf X' Y' i₁ i₂ f' H, hP H.flip hf

lemma universally_mono : monotone (universally : morphism_property C → morphism_property C) :=
λ P₁ P₂ h X Y f h₁ X' Y' i₁ i₂ f' H, h _ _ _ (h₁ _ _ _ H)

end universally

section bijective

variables [concrete_category C]

open function

local attribute [instance] concrete_category.has_coe_to_fun concrete_category.has_coe_to_sort

variable (C)

/-- Injectiveness (in a concrete category) as a `morphism_property` -/
protected def injective : morphism_property C := λ X Y f, injective f

/-- Surjectiveness (in a concrete category) as a `morphism_property` -/
protected def surjective : morphism_property C := λ X Y f, surjective f

/-- Bijectiveness (in a concrete category) as a `morphism_property` -/
protected def bijective : morphism_property C := λ X Y f, bijective f

lemma bijective_eq_sup : morphism_property.bijective C =
  morphism_property.injective C ⊓ morphism_property.surjective C :=
rfl

lemma injective_stable_under_composition :
  (morphism_property.injective C).stable_under_composition :=
λ X Y Z f g hf hg, by { delta morphism_property.injective, rw coe_comp, exact hg.comp hf }

lemma surjective_stable_under_composition :
  (morphism_property.surjective C).stable_under_composition :=
λ X Y Z f g hf hg, by { delta morphism_property.surjective, rw coe_comp, exact hg.comp hf }

lemma bijective_stable_under_composition :
  (morphism_property.bijective C).stable_under_composition :=
λ X Y Z f g hf hg, by { delta morphism_property.bijective, rw coe_comp, exact hg.comp hf }

lemma injective_respects_iso :
  (morphism_property.injective C).respects_iso :=
(injective_stable_under_composition C).respects_iso
  (λ X Y e, ((forget C).map_iso e).to_equiv.injective)

lemma surjective_respects_iso :
  (morphism_property.surjective C).respects_iso :=
(surjective_stable_under_composition C).respects_iso
  (λ X Y e, ((forget C).map_iso e).to_equiv.surjective)

lemma bijective_respects_iso :
  (morphism_property.bijective C).respects_iso :=
(bijective_stable_under_composition C).respects_iso
  (λ X Y e, ((forget C).map_iso e).to_equiv.bijective)

end bijective

end morphism_property

end category_theory


/-
Copyright (c) 2019 Rob Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rob Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.simp_result
import Mathlib.PostPort

namespace Mathlib

namespace tactic

/--
`delta_instance ids` tries to solve the goal by calling `apply_instance`,
first unfolding the definitions in `ids`.
-/
-- We call `dsimp_result` here because otherwise

-- `delta_target` will insert an `id` in the result.

-- See the note [locally reducible category instances]

-- https://github.com/leanprover-community/mathlib/blob/c9fca15420e2ad443707ace831679fd1762580fe/src/algebra/category/Mon/basic.lean#L27

-- for an example where this used to cause a problem.


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import data.nat.basic
import data.set.image
import tactic.simp_rw

/-!
# Tests for `simp_rw` extensions
-/

-- `simp_rw` can perform rewrites under binders:
example : (λ (x y : ℕ), x + y) = (λ x y, y + x) := by simp_rw [add_comm]

-- `simp_rw` can apply reverse rules:
example (f : ℕ → ℕ) {a b c : ℕ} (ha : f b = a) (hc : f b = c) : a = c := by simp_rw [← ha, hc]

-- `simp_rw` performs rewrites in the given order (`simp` fails on this example):
example {α β : Type} {f : α → β} {t : set β} :
  (∀ s, f '' s ⊆ t) = ∀ s : set α, ∀ x ∈ s, x ∈ f ⁻¹' t :=
by simp_rw [set.image_subset_iff, set.subset_def]

-- `simp_rw` applies rewrite rules multiple times:
example (a b c d : ℕ) : a + (b + (c + d)) = ((d + c) + b) + a := by simp_rw [add_comm]

-- `simp_rw` can also rewrite in assumptions:
example (p : ℕ → Prop) (a b : ℕ) (h : p (a + b)) : p (b + a) :=
by {simp_rw [add_comm a b] at h, exact h}
-- or explicitly rewrite at the goal:
example (p : ℕ → Prop) (a b : ℕ) (h : p (a + b)) : p (b + a) :=
by {simp_rw [add_comm b a] at ⊢, exact h}
-- or at multiple assumptions:
example (p : ℕ → Prop) (a b : ℕ) (h₁ : p (b + a) → p (a + b))  (h₂ : p (a + b)) : p (b + a) :=
by {simp_rw [add_comm a b] at h₁ h₂, exact h₁ h₂}
-- or everywhere:
example (p : ℕ → Prop) (a b : ℕ) (h₁ : p (b + a) → p (a + b))  (h₂ : p (a + b)) : p (a + b) :=
by {simp_rw [add_comm a b] at *, exact h₁ h₂}


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen

! This file was ported from Lean 3 source module data.fun_like.basic
! leanprover-community/mathlib commit a148d797a1094ab554ad4183a4ad6f130358ef64
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Logic.Function.Basic
import Mathlib.Tactic.NormCast

/-!
# Typeclass for a type `F` with an injective map to `A → B`

This typeclass is primarily for use by homomorphisms like `MonoidHom` and `LinearMap`.

## Basic usage of `FunLike`

A typical type of morphisms should be declared as:
```
structure MyHom (A B : Type _) [MyClass A] [MyClass B] :=
(toFun : A → B)
(map_op' : ∀ {x y : A}, toFun (MyClass.op x y) = MyClass.op (toFun x) (toFun y))

namespace MyHom

variables (A B : Type _) [MyClass A] [MyClass B]

-- This instance is optional if you follow the "morphism class" design below:
instance : FunLike (MyHom A B) A (λ _, B) :=
{ coe := MyHom.toFun, coe_injective' := λ f g h, by cases f; cases g; congr' }

/-- Helper instance for when there's too many metavariables to apply
`FunLike.coe` directly. -/
instance : CoeFun (MyHom A B) (λ _, A → B) := ⟨MyHom.toFun⟩

@[ext] theorem ext {f g : MyHom A B} (h : ∀ x, f x = g x) : f = g := FunLike.ext f g h

/-- Copy of a `MyHom` with a new `toFun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : MyHom A B) (f' : A → B) (h : f' = ⇑f) : MyHom A B :=
{ toFun := f',
  map_op' := h.symm ▸ f.map_op' }

end MyHom
```

This file will then provide a `CoeFun` instance and various
extensionality and simp lemmas.

## Morphism classes extending `FunLike`

The `FunLike` design provides further benefits if you put in a bit more work.
The first step is to extend `FunLike` to create a class of those types satisfying
the axioms of your new type of morphisms.
Continuing the example above:

```
/-- `MyHomClass F A B` states that `F` is a type of `MyClass.op`-preserving morphisms.
You should extend this class when you extend `MyHom`. -/
class MyHomClass (F : Type _) (A B : outParam <| Type _) [MyClass A] [MyClass B]
  extends FunLike F A (λ _, B) :=
(map_op : ∀ (f : F) (x y : A), f (MyClass.op x y) = MyClass.op (f x) (f y))

@[simp] lemma map_op {F A B : Type _} [MyClass A] [MyClass B] [MyHomClass F A B]
  (f : F) (x y : A) : f (MyClass.op x y) = MyClass.op (f x) (f y) :=
MyHomClass.map_op

-- You can replace `MyHom.FunLike` with the below instance:
instance : MyHomClass (MyHom A B) A B :=
{ coe := MyHom.toFun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := MyHom.map_op' }

-- [Insert `CoeFun`, `ext` and `copy` here]
```

The second step is to add instances of your new `MyHomClass` for all types extending `MyHom`.
Typically, you can just declare a new class analogous to `MyHomClass`:

```
structure CoolerHom (A B : Type _) [CoolClass A] [CoolClass B]
  extends MyHom A B :=
(map_cool' : toFun CoolClass.cool = CoolClass.cool)

class CoolerHomClass (F : Type _) (A B : outParam <| Type _) [CoolClass A] [CoolClass B]
  extends MyHomClass F A B :=
(map_cool : ∀ (f : F), f CoolClass.cool = CoolClass.cool)

@[simp] lemma map_cool {F A B : Type _} [CoolClass A] [CoolClass B] [CoolerHomClass F A B]
  (f : F) : f CoolClass.cool = CoolClass.cool :=
MyHomClass.map_op

-- You can also replace `MyHom.FunLike` with the below instance:
instance : CoolerHomClass (CoolHom A B) A B :=
{ coe := CoolHom.toFun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := CoolHom.map_op',
  map_cool := CoolHom.map_cool' }

-- [Insert `CoeFun`, `ext` and `copy` here]
```

Then any declaration taking a specific type of morphisms as parameter can instead take the
class you just defined:
```
-- Compare with: lemma do_something (f : MyHom A B) : sorry := sorry
lemma do_something {F : Type _} [MyHomClass F A B] (f : F) : sorry := sorry
```

This means anything set up for `MyHom`s will automatically work for `CoolerHomClass`es,
and defining `CoolerHomClass` only takes a constant amount of effort,
instead of linearly increasing the work per `MyHom`-related declaration.

-/

-- This instance should have low priority, to ensure we follow the chain
-- `FunLike → CoeFun`
-- Porting note: this is an elaboration detail from Lean 3, we are going to disable it
-- until it is clearer what the Lean 4 elaborator needs.
-- attribute [instance, priority 10] coe_fn_trans

/-- The class `FunLike F α β` expresses that terms of type `F` have an
injective coercion to functions from `α` to `β`.

This typeclass is used in the definition of the homomorphism typeclasses,
such as `ZeroHomClass`, `MulHomClass`, `MonoidHomClass`, ....
-/
@[notation_class * toFun Simps.findCoercionArgs]
class FunLike (F : Sort _) (α : outParam (Sort _)) (β : outParam <| α → Sort _) where
  /-- The coercion from `F` to a function. -/
  coe : F → ∀ a : α, β a
  /-- The coercion to functions must be injective. -/
  coe_injective' : Function.Injective coe
#align fun_like FunLike

section Dependent

/-! ### `FunLike F α β` where `β` depends on `a : α` -/

variable (F α : Sort _) (β : α → Sort _)

namespace FunLike

variable {F α β} [i : FunLike F α β]

instance (priority := 100) hasCoeToFun : CoeFun F fun _ ↦ ∀ a : α, β a where coe := FunLike.coe

#eval Lean.Elab.Command.liftTermElabM do
  Std.Tactic.Coe.registerCoercion ``FunLike.coe
    (some { numArgs := 5, coercee := 4, type := .coeFun })

-- @[simp] -- porting note: this loops in lean 4
theorem coe_eq_coe_fn : (FunLike.coe (F := F)) = (fun f => ↑f) := rfl
#align fun_like.coe_eq_coe_fn FunLike.coe_eq_coe_fn

theorem coe_injective : Function.Injective (fun f : F ↦ (f : ∀ a : α, β a)) :=
  FunLike.coe_injective'
#align fun_like.coe_injective FunLike.coe_injective

@[simp]
theorem coe_fn_eq {f g : F} : (f : ∀ a : α, β a) = (g : ∀ a : α, β a) ↔ f = g :=
  ⟨fun h ↦ FunLike.coe_injective' h, fun h ↦ by cases h; rfl⟩
#align fun_like.coe_fn_eq FunLike.coe_fn_eq

theorem ext' {f g : F} (h : (f : ∀ a : α, β a) = (g : ∀ a : α, β a)) : f = g :=
  FunLike.coe_injective' h
#align fun_like.ext' FunLike.ext'

theorem ext'_iff {f g : F} : f = g ↔ (f : ∀ a : α, β a) = (g : ∀ a : α, β a) :=
  coe_fn_eq.symm
#align fun_like.ext'_iff FunLike.ext'_iff

theorem ext (f g : F) (h : ∀ x : α, f x = g x) : f = g :=
  FunLike.coe_injective' (funext h)
#align fun_like.ext FunLike.ext

theorem ext_iff {f g : F} : f = g ↔ ∀ x, f x = g x :=
  coe_fn_eq.symm.trans Function.funext_iff
#align fun_like.ext_iff FunLike.ext_iff

protected theorem congr_fun {f g : F} (h₁ : f = g) (x : α) : f x = g x :=
  congr_fun (congr_arg _ h₁) x
#align fun_like.congr_fun FunLike.congr_fun

theorem ne_iff {f g : F} : f ≠ g ↔ ∃ a, f a ≠ g a :=
  ext_iff.not.trans not_forall
#align fun_like.ne_iff FunLike.ne_iff

/-- This is not an instance to avoid slowing down every single `Subsingleton` typeclass search.-/
lemma subsingleton_cod [∀ a, Subsingleton (β a)] : Subsingleton F :=
⟨fun _ _ ↦ coe_injective $ Subsingleton.elim _ _⟩
#align fun_like.subsingleton_cod FunLike.subsingleton_cod

end FunLike

end Dependent

section NonDependent

/-! ### `FunLike F α (λ _, β)` where `β` does not depend on `a : α` -/

variable {F α β : Sort _} [i : FunLike F α fun _ ↦ β]

namespace FunLike

protected theorem congr {f g : F} {x y : α} (h₁ : f = g) (h₂ : x = y) : f x = g y :=
  congr (congr_arg _ h₁) h₂
#align fun_like.congr FunLike.congr

protected theorem congr_arg (f : F) {x y : α} (h₂ : x = y) : f x = f y :=
  congr_arg _ h₂
#align fun_like.congr_arg FunLike.congr_arg

end FunLike

end NonDependent


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

! This file was ported from Lean 3 source module tactic.apply
! leanprover-community/mathlib commit 8f6fd1b69096c6a587f745d354306c0d46396915
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Core

/-!
This file provides an alternative implementation for `apply` to fix the so-called "apply bug".

The issue arises when the goals is a Π-type -- whether it is visible or hidden behind a definition.

For instance, consider the following proof:

```
example {α β} (x y z : α → β) (h₀ : x ≤ y) (h₁ : y ≤ z) : x ≤ z :=
begin
  apply le_trans,
end
```

Because `x ≤ z` is definitionally equal to `∀ i, x i ≤ z i`, `apply` will fail. The alternative
definition, `apply'` fixes this. When `apply` would work, `apply` is used and otherwise,
a different strategy is deployed
-/

namespace Tactic

/-- With `gs` a list of proof goals, `reorder_goals gs new_g` will use the `new_goals` policy
`new_g` to rearrange the dependent goals to either drop them, push them to the end of the list
or leave them in place. The `bool` values in `gs` indicates whether the goal is dependent or not. -/
def reorderGoals {α} (gs : List (Bool × α)) : NewGoals → List α
  | new_goals.non_dep_first =>
    let ⟨dep, non_dep⟩ := gs.partitionₓ (coe ∘ Prod.fst)
    non_dep.map Prod.snd ++ dep.map Prod.snd
  | new_goals.non_dep_only => (gs.filterₓ (coe ∘ not ∘ Prod.fst)).map Prod.snd
  | new_goals.all => gs.map Prod.snd
#align tactic.reorder_goals Tactic.reorderGoals

private unsafe def has_opt_auto_param_inst_for_apply (ms : List (Name × expr)) : tactic Bool :=
  ms.foldlM
    (fun r m => do
      let type ← infer_type m.2
      let b ← is_class type
      return <| r || type `opt_param 2 || type `auto_param 2 || b)
    false
#align tactic.has_opt_auto_param_inst_for_apply tactic.has_opt_auto_param_inst_for_apply

private unsafe def try_apply_opt_auto_param_instance_for_apply (cfg : ApplyCfg)
    (ms : List (Name × expr)) : tactic Unit :=
  whenM (has_opt_auto_param_inst_for_apply ms) do
    let gs ← get_goals
    ms fun m =>
        whenM (not <$> is_assigned m.2) <|
          ((set_goals [m.2] >> try apply_instance) >> when cfg (try apply_opt_param)) >>
            when cfg (try apply_auto_param)
    set_goals gs
#align tactic.try_apply_opt_auto_param_instance_for_apply tactic.try_apply_opt_auto_param_instance_for_apply

private unsafe def retry_apply_aux :
    ∀ (e : expr) (cfg : ApplyCfg), List (Bool × Name × expr) → tactic (List (Name × expr))
  | e, cfg, gs =>
    (focus1 do
        let tgt : expr ← target
        let t ← infer_type e
        unify t tgt
        exact e
        let gs' ← get_goals
        let r := reorderGoals gs.reverse cfg.NewGoals
        set_goals (gs' ++ r Prod.snd)
        return r) <|>
      do
      let expr.pi n bi d b ← infer_type e >>= whnf |
        apply_core e cfg
      let v ← mk_meta_var d
      let b := b.has_var
      let e ← head_beta <| e v
      retry_apply_aux e cfg ((b, n, v) :: gs)
#align tactic.retry_apply_aux tactic.retry_apply_aux

private unsafe def retry_apply (e : expr) (cfg : ApplyCfg) : tactic (List (Name × expr)) :=
  apply_core e cfg <|> retry_apply_aux e cfg []
#align tactic.retry_apply tactic.retry_apply

/-- `apply'` mimics the behavior of `apply_core`. When
`apply_core` fails, it is retried by providing the term with meta
variables as additional arguments. The meta variables can then
become new goals depending on the `cfg.new_goals` policy.

`apply'` also finds instances and applies opt_params and auto_params. -/
unsafe def apply' (e : expr) (cfg : ApplyCfg := { }) : tactic (List (Name × expr)) := do
  let r ← retry_apply e cfg
  try_apply_opt_auto_param_instance_for_apply cfg r
  return r
#align tactic.apply' tactic.apply'

/-- Same as `apply'` but __all__ arguments that weren't inferred are added to goal list. -/
unsafe def fapply' (e : expr) : tactic (List (Name × expr)) :=
  apply' e { NewGoals := NewGoals.all }
#align tactic.fapply' tactic.fapply'

/-- Same as `apply'` but only goals that don't depend on other goals are added to goal list. -/
unsafe def eapply' (e : expr) : tactic (List (Name × expr)) :=
  apply' e { NewGoals := NewGoals.non_dep_only }
#align tactic.eapply' tactic.eapply'

/-- `relation_tactic` finds a proof rule for the relation found in the goal and uses `apply'`
to make one proof step. -/
private unsafe def relation_tactic (md : Transparency) (op_for : environment → Name → Option Name)
    (tac_name : String) : tactic Unit := do
  let tgt ← target >>= instantiate_mvars
  let env ← get_env
  let r := expr.get_app_fn tgt
  match op_for env (expr.const_name r) with
    | some refl => do
      let r ← mk_const refl
      retry_apply r
          { md
            NewGoals := new_goals.non_dep_only }
      return ()
    | none =>
      fail <|
        tac_name ++
          " tactic failed, target is not a relation application with the expected property."
#align tactic.relation_tactic tactic.relation_tactic

/-- Similar to `reflexivity` with the difference that `apply'` is used instead of `apply` -/
unsafe def reflexivity' (md := semireducible) : tactic Unit :=
  relation_tactic md environment.refl_for "reflexivity"
#align tactic.reflexivity' tactic.reflexivity'

/-- Similar to `symmetry` with the difference that `apply'` is used instead of `apply` -/
unsafe def symmetry' (md := semireducible) : tactic Unit :=
  relation_tactic md environment.symm_for "symmetry"
#align tactic.symmetry' tactic.symmetry'

/-- Similar to `transitivity` with the difference that `apply'` is used instead of `apply` -/
unsafe def transitivity' (md := semireducible) : tactic Unit :=
  relation_tactic md environment.trans_for "transitivity"
#align tactic.transitivity' tactic.transitivity'

namespace Interactive

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/-- Similarly to `apply`, the `apply'` tactic tries to match the current goal against the conclusion
of the type of term.

It differs from `apply` in that it does not unfold definition in order to find out what the
assumptions of the provided term is. It is especially useful when defining relations on function
spaces (e.g. `≤`) so that rules like transitivity on `le : (α → β) → (α → β) → (α → β)` will be
considered to have three parameters and two assumptions (i.e. `f g h : α → β`, `H₀ : f ≤ g`,
`H₁ : g ≤ h`) instead of three parameters, two assumptions and then one more parameter
(i.e. `f g h : α → β`, `H₀ : f ≤ g`, `H₁ : g ≤ h`, `x : α`). Whereas `apply` would expect the goal
`f x ≤ h x`, `apply'` will work with the goal `f ≤ h`.
-/
unsafe def apply' (q : parse texpr) : tactic Unit :=
  concat_tags do
    let h ← i_to_expr_for_apply q
    tactic.apply' h
#align tactic.interactive.apply' tactic.interactive.apply'

/-- Similar to the `apply'` tactic, but does not reorder goals.
-/
unsafe def fapply' (q : parse texpr) : tactic Unit :=
  concat_tags (i_to_expr_for_apply q >>= tactic.fapply')
#align tactic.interactive.fapply' tactic.interactive.fapply'

/--
Similar to the `apply'` tactic, but only creates subgoals for non-dependent premises that have not
been fixed by type inference or type class resolution.
-/
unsafe def eapply' (q : parse texpr) : tactic Unit :=
  concat_tags (i_to_expr_for_apply q >>= tactic.eapply')
#align tactic.interactive.eapply' tactic.interactive.eapply'

/--
Similar to the `apply'` tactic, but allows the user to provide a `apply_cfg` configuration object.
-/
unsafe def apply_with' (q : parse parser.pexpr) (cfg : ApplyCfg) : tactic Unit :=
  concat_tags do
    let e ← i_to_expr_for_apply q
    tactic.apply' e cfg
#align tactic.interactive.apply_with' tactic.interactive.apply_with'

/-- Similar to the `apply'` tactic, but uses matching instead of unification.
`mapply' t` is equivalent to `apply_with' t {unify := ff}`
-/
unsafe def mapply' (q : parse texpr) : tactic Unit :=
  concat_tags do
    let e ← i_to_expr_for_apply q
    tactic.apply' e { unify := ff }
#align tactic.interactive.mapply' tactic.interactive.mapply'

/-- Similar to `reflexivity` with the difference that `apply'` is used instead of `apply`.
-/
unsafe def reflexivity' : tactic Unit :=
  tactic.reflexivity'
#align tactic.interactive.reflexivity' tactic.interactive.reflexivity'

/-- Shorter name for the tactic `reflexivity'`.
-/
unsafe def refl' : tactic Unit :=
  tactic.reflexivity'
#align tactic.interactive.refl' tactic.interactive.refl'

/--
`symmetry'` behaves like `symmetry` but also offers the option `symmetry' at h` to apply symmetry
to assumption `h`
-/
unsafe def symmetry' : parse location → tactic Unit
  | l@loc.wildcard => l.try_apply symmetry_hyp tactic.symmetry'
  | loc.ns hs => (Loc.ns hs.reverse).apply symmetry_hyp tactic.symmetry'
#align tactic.interactive.symmetry' tactic.interactive.symmetry'

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `parser.optional -/
/-- Similar to `transitivity` with the difference that `apply'` is used instead of `apply`.
-/
unsafe def transitivity' (q : parse (parser.optional texpr)) : tactic Unit :=
  tactic.transitivity' >>
    match q with
    | none => skip
    | some q => do
      let (r, lhs, rhs) ← target_lhs_rhs
      let t ← infer_type lhs
      i_to_expr ``(($(q) : $(t))) >>= unify rhs
#align tactic.interactive.transitivity' tactic.interactive.transitivity'

end Interactive

end Tactic


abbrev DelabM := Id
abbrev Delab := DelabM Nat

example : DelabM Nat := pure 1  -- works
example : Delab := pure 1       -- works


/-
Copyright (c) 2020 Dany Fabian. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Dany Fabian
-/

import tactic.split_ifs
/-!
  # Unfold cases tactic

  In Lean, pattern matching expressions are not atomic parts of the syntax, but
  rather they are compiled down into simpler terms that are later checked by the kernel.

  This allows Lean to have a minimalistic kernel but can occasionally lead an explosion
  of cases that need to be considered. What looks like one case in the `match` expression
  can in fact be compiled into many different cases that all need to proved by case analysis.

  This tactic automates the process by allowing us to write down an equation `f x = y`
  where we know that `f x = y` is provably true, but does not hold definitionally. In that
  case the `unfold_cases` tactic will continue unfolding `f` and introducing `cases` where
  necessary until the left hand side becomes definitionally equal to the right hand side.

  Consider a definition as follows:

  ```lean
  def myand : bool → bool → bool
  | ff _ := ff
  | _ ff := ff
  | _ _ := tt
  ```

  The equation compiler generates 4 equation lemmas for us:
  ```lean
  myand ff ff = ff
  myand ff tt = ff
  myand tt ff = ff
  myand tt tt = tt
  ```

  This is not in line with what one might expect looking at the definition.
  Whilst it is provably true, that `∀ x, myand ff x = ff` and `∀ x, myand x ff = ff`,
  we do not get these stronger lemmas from the compiler for free but must in fact
  prove them using `cases` or some other local reasoning.

  In other words, the following does not constitute a proof that lean accepts.
  ```lean
  example : ∀ x, myand ff x = ff :=
  begin
    intros, refl
  end
  ```

  However, you can use `unfold_cases { refl }` to prove `∀ x, myand ff x = ff` and
  `∀ x, myand x ff = ff`. For definitions with many cases, the savings can be very
  significant.

  The term that gets generated for the above definition looks like this:
  ```lean
  λ (a a_1 : bool),
  a.cases_on
    (a_1.cases_on (id_rhs bool ff) (id_rhs bool ff))
    (a_1.cases_on (id_rhs bool ff) (id_rhs bool tt))
  ```

  When the tactic tries to prove the goal `∀ x, myand ff x = ff`, it starts by `intros`,
  followed by unfolding the definition:
  ```lean
  ⊢ ff.cases_on
    (x.cases_on (id_rhs bool ff) (id_rhs bool ff))
    (x.cases_on (id_rhs bool ff) (id_rhs bool tt)) = ff
  ```

  At this point, it can make progress using `dsimp`. But then it gets stuck:
  ```lean
  ⊢ bool.rec (id_rhs bool ff) (id_rhs bool ff) x = ff
  ```

  Next, it can introduce a case split on `x`. At this point, it has to prove two
  goals:
  ```lean
  ⊢ bool.rec (id_rhs bool ff) (id_rhs bool ff) ff = ff
  ⊢ bool.rec (id_rhs bool ff) (id_rhs bool ff) tt = ff
  ```

  Now, however, both goals can be discharged using `refl`.
-/
namespace tactic
open expr
namespace unfold_cases
/--
  Given an equation `f x = y`, this tactic tries to infer an expression that can be
  used to do distinction by cases on to make progress.

  Pre-condition: assumes that the outer-most application cannot be beta-reduced
  (e.g. `whnf` or `dsimp`).
-/
meta def find_splitting_expr : expr → tactic expr
| `(@ite _ %%cond %%dec_inst _ _ = _) := pure `(@decidable.em %%cond %%dec_inst)
| `(%%(app x y) = _) := pure y
| e := fail!"expected an expression of the form: f x = y. Got:\n{e}"

/--
  Tries to finish the current goal using the `inner` tactic. If the tactic
  fails, it tries to find an expression on which to do a distinction by
  cases and calls itself recursively.

  The order of operations is significant. Because the unfolding can potentially
  be infinite, it is important to apply the `inner` tactic at every step.

  Notice, that if the `inner` tactic succeeds, the recursive unfolding is stopped.
-/
meta def unfold_cases_core (inner : interactive.itactic) : tactic unit :=
inner <|>
(do split_ifs [], all_goals unfold_cases_core, skip) <|>
do
  tgt ← target,
  e ← find_splitting_expr tgt,
  focus1 $ do
    cases e,
    all_goals $ (dsimp_target >> unfold_cases_core) <|> skip,
    skip

/--
  Given a target of the form `⊢ f x₁ ... xₙ = y`, unfolds `f` using a delta reduction.
-/
meta def unfold_tgt : expr → tactic unit
| `(%%l@(app _ _) = %%r) :=
  match l.get_app_fn with
  | const n ls := delta_target [n]
  | e := fail!"couldn't unfold:\n{e}"
  end
| e := fail!"expected an expression of the form: f x = y. Got:\n{e}"
end unfold_cases

namespace interactive
open unfold_cases

/--
  This tactic unfolds the definition of a function or `match` expression.
  Then it recursively introduces a distinction by cases. The decision what expression
  to do the distinction on is driven by the pattern matching expression.

  A typical use case is using `unfold_cases { refl }` to collapse cases that need to be
  considered in a pattern matching.

  ```lean
  have h : foo x = y, by unfold_cases { refl },
  rw h,
  ```

  The tactic expects a goal in the form of an equation, possibly universally quantified.

  We can prove a theorem, even if the various case do not directly correspond to the
  function definition. Here is an example application of the tactic:

  ```lean
  def foo : ℕ → ℕ → ℕ
  | 0     0 := 17
  | (n+2) 17 := 17
  | 1     0 := 23
  | 0     (n+18) := 15
  | 0     17 := 17
  | 1     17 := 17
  | _     (n+18) := 27
  | _     _ := 15

  example : ∀ x, foo x 17 = 17 :=
  begin
    unfold_cases { refl },
  end
  ```

  The compiler generates 57 cases for `foo`. However, when we look at the definition, we see
  that whenever the function is applied to `17` in the second argument, it returns `17`.

  Proving this property consists of merely considering all the cases, eliminating invalid ones
  and applying `refl` on the ones which remain.

  Further examples can be found in `test/unfold_cases.lean`.
-/
meta def unfold_cases (inner : itactic) : tactic unit := focus1 $ do
  tactic.intros,
  tgt ← target,
  unfold_tgt tgt,
  try dsimp_target,
  unfold_cases_core inner

add_tactic_doc
{ name       := "unfold_cases",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.unfold_cases],
  tags       := ["induction", "case bashing"] }

end interactive
end tactic