/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Data.LOption
import Lean.Environment
import Lean.Class
import Lean.ReducibilityAttrs
import Lean.Util.Trace
import Lean.Util.RecDepth
import Lean.Util.PPExt
import Lean.Util.OccursCheck
import Lean.Util.MonadBacktrack
import Lean.Compiler.InlineAttrs
import Lean.Meta.TransparencyMode
import Lean.Meta.DiscrTreeTypes
import Lean.Eval
import Lean.CoreM

/-
This module provides four (mutually dependent) goodies that are needed for building the elaborator and tactic frameworks.
1- Weak head normal form computation with support for metavariables and transparency modes.
2- Definitionally equality checking with support for metavariables (aka unification modulo definitional equality).
3- Type inference.
4- Type class resolution.

They are packed into the MetaM monad.
-/

namespace Lean.Meta

builtin_initialize isDefEqStuckExceptionId : InternalExceptionId ← registerInternalExceptionId `isDefEqStuck

structure Config where
  foApprox           : Bool := false
  ctxApprox          : Bool := false
  quasiPatternApprox : Bool := false
  /- When `constApprox` is set to true,
     we solve `?m t =?= c` using
     `?m := fun _ => c`
     when `?m t` is not a higher-order pattern and `c` is not an application as -/
  constApprox        : Bool := false
  /-
    When the following flag is set,
    `isDefEq` throws the exeption `Exeption.isDefEqStuck`
    whenever it encounters a constraint `?m ... =?= t` where
    `?m` is read only.
    This feature is useful for type class resolution where
    we may want to notify the caller that the TC problem may be solveable
    later after it assigns `?m`. -/
  isDefEqStuckEx     : Bool := false
  transparency       : TransparencyMode := TransparencyMode.default
  /- If zetaNonDep == false, then non dependent let-decls are not zeta expanded. -/
  zetaNonDep         : Bool := true
  /- When `trackZeta == true`, we store zetaFVarIds all free variables that have been zeta-expanded. -/
  trackZeta          : Bool := false
  unificationHints   : Bool := true

structure ParamInfo where
  implicit     : Bool      := false
  instImplicit : Bool      := false
  hasFwdDeps   : Bool      := false
  backDeps     : Array Nat := #[]
  deriving Inhabited

def ParamInfo.isExplicit (p : ParamInfo) : Bool :=
  !p.implicit && !p.instImplicit

structure FunInfo where
  paramInfo  : Array ParamInfo := #[]
  resultDeps : Array Nat       := #[]

structure InfoCacheKey where
  transparency : TransparencyMode
  expr         : Expr
  nargs?       : Option Nat
  deriving Inhabited, BEq

namespace InfoCacheKey
instance : Hashable InfoCacheKey :=
  ⟨fun ⟨transparency, expr, nargs⟩ => mixHash (hash transparency) <| mixHash (hash expr) (hash nargs)⟩
end InfoCacheKey

open Std (PersistentArray PersistentHashMap)

abbrev SynthInstanceCache := PersistentHashMap Expr (Option Expr)

abbrev InferTypeCache := PersistentExprStructMap Expr
abbrev FunInfoCache   := PersistentHashMap InfoCacheKey FunInfo
abbrev WhnfCache      := PersistentExprStructMap Expr
structure Cache where
  inferType     : InferTypeCache := {}
  funInfo       : FunInfoCache   := {}
  synthInstance : SynthInstanceCache := {}
  whnfDefault   : WhnfCache := {} -- cache for closed terms and `TransparencyMode.default`
  whnfAll       : WhnfCache := {} -- cache for closed terms and `TransparencyMode.all`
  deriving Inhabited

/--
 "Context" for a postponed universe constraint.
 `lhs` and `rhs` are the surrounding `isDefEq` call when the postponed constraint was created.
-/
structure DefEqContext where
  lhs            : Expr
  rhs            : Expr
  lctx           : LocalContext
  localInstances : LocalInstances

/--
  Auxiliary structure for representing postponed universe constraints.
  Remark: the fields `ref` and `rootDefEq?` are used for error message generation only.
  Remark: we may consider improving the error message generation in the future.
-/
structure PostponedEntry where
  ref  : Syntax -- We save the `ref` at entry creation time
  lhs  : Level
  rhs  : Level
  ctx? : Option DefEqContext -- Context for the surrounding `isDefEq` call when entry was created
  deriving Inhabited

structure State where
  mctx        : MetavarContext := {}
  cache       : Cache := {}
  /- When `trackZeta == true`, then any let-decl free variable that is zeta expansion performed by `MetaM` is stored in `zetaFVarIds`. -/
  zetaFVarIds : NameSet := {}
  postponed   : PersistentArray PostponedEntry := {}
  deriving Inhabited

structure SavedState where
  core        : Core.State
  meta        : State
  deriving Inhabited

structure Context where
  config         : Config               := {}
  lctx           : LocalContext         := {}
  localInstances : LocalInstances       := #[]
  /-- Not `none` when inside of an `isDefEq` test. See `PostponedEntry`. -/
  defEqCtx?      : Option DefEqContext  := none

abbrev MetaM  := ReaderT Context $ StateRefT State CoreM

instance : Inhabited (MetaM α) where
  default := fun _ _ => arbitrary

instance : MonadLCtx MetaM where
  getLCtx := return (← read).lctx

instance : MonadMCtx MetaM where
  getMCtx    := return (← get).mctx
  modifyMCtx f := modify fun s => { s with mctx := f s.mctx }

instance : AddMessageContext MetaM where
  addMessageContext := addMessageContextFull

protected def saveState : MetaM SavedState :=
  return { core := (← getThe Core.State), meta := (← get) }

/-- Restore backtrackable parts of the state. -/
def SavedState.restore (b : SavedState) : MetaM Unit := do
  Core.restore b.core
  modify fun s => { s with mctx := b.meta.mctx, zetaFVarIds := b.meta.zetaFVarIds, postponed := b.meta.postponed }

instance : MonadBacktrack SavedState MetaM where
  saveState      := Meta.saveState
  restoreState s := s.restore

@[inline] def MetaM.run (x : MetaM α) (ctx : Context := {}) (s : State := {}) : CoreM (α × State) :=
  x ctx |>.run s

@[inline] def MetaM.run' (x : MetaM α) (ctx : Context := {}) (s : State := {}) : CoreM α :=
  Prod.fst <$> x.run ctx s

@[inline] def MetaM.toIO (x : MetaM α) (ctxCore : Core.Context) (sCore : Core.State) (ctx : Context := {}) (s : State := {}) : IO (α × Core.State × State) := do
  let ((a, s), sCore) ← (x.run ctx s).toIO ctxCore sCore
  pure (a, sCore, s)

instance [MetaEval α] : MetaEval (MetaM α) :=
  ⟨fun env opts x _ => MetaEval.eval env opts x.run' true⟩

protected def throwIsDefEqStuck : MetaM α :=
  throw <| Exception.internal isDefEqStuckExceptionId

builtin_initialize
  registerTraceClass `Meta
  registerTraceClass `Meta.debug

@[inline] def liftMetaM [MonadLiftT MetaM m] (x : MetaM α) : m α :=
  liftM x

@[inline] def mapMetaM [MonadControlT MetaM m] [Monad m] (f : forall {α}, MetaM α → MetaM α) {α} (x : m α) : m α :=
  controlAt MetaM fun runInBase => f <| runInBase x

@[inline] def map1MetaM [MonadControlT MetaM m] [Monad m] (f : forall {α}, (β → MetaM α) → MetaM α) {α} (k : β → m α) : m α :=
  controlAt MetaM fun runInBase => f fun b => runInBase <| k b

@[inline] def map2MetaM [MonadControlT MetaM m] [Monad m] (f : forall {α}, (β → γ → MetaM α) → MetaM α) {α} (k : β → γ → m α) : m α :=
  controlAt MetaM fun runInBase => f fun b c => runInBase <| k b c

section Methods
variable [MonadControlT MetaM n] [Monad n]

@[inline] def modifyCache (f : Cache → Cache) : MetaM Unit :=
  modify fun ⟨mctx, cache, zetaFVarIds, postponed⟩ => ⟨mctx, f cache, zetaFVarIds, postponed⟩

@[inline] def modifyInferTypeCache (f : InferTypeCache → InferTypeCache) : MetaM Unit :=
  modifyCache fun ⟨ic, c1, c2, c3, c4⟩ => ⟨f ic, c1, c2, c3, c4⟩

def getLocalInstances : MetaM LocalInstances :=
  return (← read).localInstances

def getConfig : MetaM Config :=
  return (← read).config

def setMCtx (mctx : MetavarContext) : MetaM Unit :=
  modify fun s => { s with mctx := mctx }

def resetZetaFVarIds : MetaM Unit :=
  modify fun s => { s with zetaFVarIds := {} }

def getZetaFVarIds : MetaM NameSet :=
  return (← get).zetaFVarIds

def getPostponed : MetaM (PersistentArray PostponedEntry) :=
  return (← get).postponed

def setPostponed (postponed : PersistentArray PostponedEntry) : MetaM Unit :=
  modify fun s => { s with postponed := postponed }

@[inline] def modifyPostponed (f : PersistentArray PostponedEntry → PersistentArray PostponedEntry) : MetaM Unit :=
  modify fun s => { s with postponed := f s.postponed }

builtin_initialize whnfRef : IO.Ref (Expr → MetaM Expr) ← IO.mkRef fun _ => throwError "whnf implementation was not set"
builtin_initialize inferTypeRef : IO.Ref (Expr → MetaM Expr) ← IO.mkRef fun _ => throwError "inferType implementation was not set"
builtin_initialize isExprDefEqAuxRef : IO.Ref (Expr → Expr → MetaM Bool) ← IO.mkRef fun _ _ => throwError "isDefEq implementation was not set"
builtin_initialize synthPendingRef : IO.Ref (MVarId → MetaM Bool) ← IO.mkRef fun _ => pure false

def whnf (e : Expr) : MetaM Expr :=
  withIncRecDepth do (← whnfRef.get) e

def whnfForall (e : Expr) : MetaM Expr := do
  let e' ← whnf e
  if e'.isForall then pure e' else pure e

def inferType (e : Expr) : MetaM Expr :=
  withIncRecDepth do (← inferTypeRef.get) e

protected def isExprDefEqAux (t s : Expr) : MetaM Bool :=
  withIncRecDepth do (← isExprDefEqAuxRef.get) t s

protected def synthPending (mvarId : MVarId) : MetaM Bool :=
  withIncRecDepth do (← synthPendingRef.get) mvarId

-- withIncRecDepth for a monad `n` such that `[MonadControlT MetaM n]`
protected def withIncRecDepth (x : n α) : n α :=
  mapMetaM (withIncRecDepth (m := MetaM)) x

private def mkFreshExprMVarAtCore
    (mvarId : MVarId) (lctx : LocalContext) (localInsts : LocalInstances) (type : Expr) (kind : MetavarKind) (userName : Name) (numScopeArgs : Nat) : MetaM Expr := do
  modifyMCtx fun mctx => mctx.addExprMVarDecl mvarId userName lctx localInsts type kind numScopeArgs;
  return mkMVar mvarId

def mkFreshExprMVarAt
    (lctx : LocalContext) (localInsts : LocalInstances) (type : Expr)
    (kind : MetavarKind := MetavarKind.natural) (userName : Name := Name.anonymous) (numScopeArgs : Nat := 0)
    : MetaM Expr := do
  let mvarId ← mkFreshId
  mkFreshExprMVarAtCore mvarId lctx localInsts type kind userName numScopeArgs

def mkFreshLevelMVar : MetaM Level := do
  let mvarId ← mkFreshId
  modifyMCtx fun mctx => mctx.addLevelMVarDecl mvarId;
  return mkLevelMVar mvarId

private def mkFreshExprMVarCore (type : Expr) (kind : MetavarKind) (userName : Name) : MetaM Expr := do
  let lctx ← getLCtx
  let localInsts ← getLocalInstances
  mkFreshExprMVarAt lctx localInsts type kind userName

private def mkFreshExprMVarImpl (type? : Option Expr) (kind : MetavarKind) (userName : Name) : MetaM Expr :=
  match type? with
  | some type => mkFreshExprMVarCore type kind userName
  | none      => do
    let u ← mkFreshLevelMVar
    let type ← mkFreshExprMVarCore (mkSort u) MetavarKind.natural Name.anonymous
    mkFreshExprMVarCore type kind userName

def mkFreshExprMVar (type? : Option Expr) (kind := MetavarKind.natural) (userName := Name.anonymous) : MetaM Expr :=
  mkFreshExprMVarImpl type? kind userName

def mkFreshTypeMVar (kind := MetavarKind.natural) (userName := Name.anonymous) : MetaM Expr := do
  let u ← mkFreshLevelMVar
  mkFreshExprMVar (mkSort u) kind userName

/- Low-level version of `MkFreshExprMVar` which allows users to create/reserve a `mvarId` using `mkFreshId`, and then later create
   the metavar using this method. -/
private def mkFreshExprMVarWithIdCore (mvarId : MVarId) (type : Expr)
    (kind : MetavarKind := MetavarKind.natural) (userName : Name := Name.anonymous) (numScopeArgs : Nat := 0)
    : MetaM Expr := do
  let lctx ← getLCtx
  let localInsts ← getLocalInstances
  mkFreshExprMVarAtCore mvarId lctx localInsts type kind userName numScopeArgs

def mkFreshExprMVarWithId (mvarId : MVarId) (type? : Option Expr := none) (kind : MetavarKind := MetavarKind.natural) (userName := Name.anonymous) : MetaM Expr :=
  match type? with
  | some type => mkFreshExprMVarWithIdCore mvarId type kind userName
  | none      => do
    let u ← mkFreshLevelMVar
    let type ← mkFreshExprMVar (mkSort u)
    mkFreshExprMVarWithIdCore mvarId type kind userName

def mkFreshLevelMVars (num : Nat) : MetaM (List Level) :=
  num.foldM (init := []) fun _ us =>
    return (← mkFreshLevelMVar)::us

def mkFreshLevelMVarsFor (info : ConstantInfo) : MetaM (List Level) :=
  mkFreshLevelMVars info.numLevelParams

def mkConstWithFreshMVarLevels (declName : Name) : MetaM Expr := do
  let info ← getConstInfo declName
  return mkConst declName (← mkFreshLevelMVarsFor info)

def getTransparency : MetaM TransparencyMode :=
  return (← getConfig).transparency

def shouldReduceAll : MetaM Bool :=
  return (← getTransparency) == TransparencyMode.all

def shouldReduceReducibleOnly : MetaM Bool :=
  return (← getTransparency) == TransparencyMode.reducible

def getMVarDecl (mvarId : MVarId) : MetaM MetavarDecl := do
  let mctx ← getMCtx
  match mctx.findDecl? mvarId with
  | some d => pure d
  | none   => throwError "unknown metavariable '?{mvarId}'"

def setMVarKind (mvarId : MVarId) (kind : MetavarKind) : MetaM Unit :=
  modifyMCtx fun mctx => mctx.setMVarKind mvarId kind

/- Update the type of the given metavariable. This function assumes the new type is
   definitionally equal to the current one -/
def setMVarType (mvarId : MVarId) (type : Expr) : MetaM Unit := do
  modifyMCtx fun mctx => mctx.setMVarType mvarId type

def isReadOnlyExprMVar (mvarId : MVarId) : MetaM Bool := do
  let mvarDecl ← getMVarDecl mvarId
  let mctx     ← getMCtx
  return mvarDecl.depth != mctx.depth

def isReadOnlyOrSyntheticOpaqueExprMVar (mvarId : MVarId) : MetaM Bool := do
  let mvarDecl ← getMVarDecl mvarId
  match mvarDecl.kind with
  | MetavarKind.syntheticOpaque => pure true
  | _ =>
    let mctx ← getMCtx
    return mvarDecl.depth != mctx.depth

def isReadOnlyLevelMVar (mvarId : MVarId) : MetaM Bool := do
  let mctx ← getMCtx
  match mctx.findLevelDepth? mvarId with
  | some depth => return depth != mctx.depth
  | _          => throwError "unknown universe metavariable '?{mvarId}'"

def renameMVar (mvarId : MVarId) (newUserName : Name) : MetaM Unit :=
  modifyMCtx fun mctx => mctx.renameMVar mvarId newUserName

def isExprMVarAssigned (mvarId : MVarId) : MetaM Bool :=
  return (← getMCtx).isExprAssigned mvarId

def getExprMVarAssignment? (mvarId : MVarId) : MetaM (Option Expr) :=
  return (← getMCtx).getExprAssignment? mvarId

/-- Return true if `e` contains `mvarId` directly or indirectly -/
def occursCheck (mvarId : MVarId) (e : Expr) : MetaM Bool :=
  return (← getMCtx).occursCheck mvarId e

def assignExprMVar (mvarId : MVarId) (val : Expr) : MetaM Unit :=
  modifyMCtx fun mctx => mctx.assignExpr mvarId val

def isDelayedAssigned (mvarId : MVarId) : MetaM Bool :=
  return (← getMCtx).isDelayedAssigned mvarId

def getDelayedAssignment? (mvarId : MVarId) : MetaM (Option DelayedMetavarAssignment) :=
  return (← getMCtx).getDelayedAssignment? mvarId

def hasAssignableMVar (e : Expr) : MetaM Bool :=
  return (← getMCtx).hasAssignableMVar e

def throwUnknownFVar (fvarId : FVarId) : MetaM α :=
  throwError "unknown free variable '{mkFVar fvarId}'"

def findLocalDecl? (fvarId : FVarId) : MetaM (Option LocalDecl) :=
  return (← getLCtx).find? fvarId

def getLocalDecl (fvarId : FVarId) : MetaM LocalDecl := do
  match (← getLCtx).find? fvarId with
  | some d => pure d
  | none   => throwUnknownFVar fvarId

def getFVarLocalDecl (fvar : Expr) : MetaM LocalDecl :=
  getLocalDecl fvar.fvarId!

def getLocalDeclFromUserName (userName : Name) : MetaM LocalDecl := do
  match (← getLCtx).findFromUserName? userName with
  | some d => pure d
  | none   => throwError "unknown local declaration '{userName}'"

def instantiateLevelMVars (u : Level) : MetaM Level :=
  MetavarContext.instantiateLevelMVars u

def instantiateMVars (e : Expr) : MetaM Expr :=
  (MetavarContext.instantiateExprMVars e).run

def instantiateLocalDeclMVars (localDecl : LocalDecl) : MetaM LocalDecl := do
  match localDecl with
  | LocalDecl.cdecl idx id n type bi  =>
    let type ← instantiateMVars type
    return LocalDecl.cdecl idx id n type bi
  | LocalDecl.ldecl idx id n type val nonDep =>
    let type ← instantiateMVars type
    let val ← instantiateMVars val
    return LocalDecl.ldecl idx id n type val nonDep

@[inline] def liftMkBindingM (x : MetavarContext.MkBindingM α) : MetaM α := do
  match x (← getLCtx) { mctx := (← getMCtx), ngen := (← getNGen) } with
  | EStateM.Result.ok e newS => do
    setNGen newS.ngen;
    setMCtx newS.mctx;
    pure e
  | EStateM.Result.error (MetavarContext.MkBinding.Exception.revertFailure mctx lctx toRevert decl) newS => do
    setMCtx newS.mctx;
    setNGen newS.ngen;
    throwError "failed to create binder due to failure when reverting variable dependencies"

def mkForallFVars (xs : Array Expr) (e : Expr) (usedOnly : Bool := false) (usedLetOnly : Bool := true) : MetaM Expr :=
  if xs.isEmpty then pure e else liftMkBindingM <| MetavarContext.mkForall xs e usedOnly usedLetOnly

def mkLambdaFVars (xs : Array Expr) (e : Expr) (usedOnly : Bool := false) (usedLetOnly : Bool := true) : MetaM Expr :=
  if xs.isEmpty then pure e else liftMkBindingM <| MetavarContext.mkLambda xs e usedOnly usedLetOnly

def mkLetFVars (xs : Array Expr) (e : Expr) (usedLetOnly := true) : MetaM Expr :=
  mkLambdaFVars xs e (usedLetOnly := usedLetOnly)

def mkArrow (d b : Expr) : MetaM Expr := do
  let n ← mkFreshUserName `x
  return Lean.mkForall n BinderInfo.default d b

def elimMVarDeps (xs : Array Expr) (e : Expr) (preserveOrder : Bool := false) : MetaM Expr :=
  if xs.isEmpty then pure e else liftMkBindingM <| MetavarContext.elimMVarDeps xs e preserveOrder

@[inline] def withConfig (f : Config → Config) : n α → n α :=
  mapMetaM <| withReader (fun ctx => { ctx with config := f ctx.config })

@[inline] def withTrackingZeta (x : n α) : n α :=
  withConfig (fun cfg => { cfg with trackZeta := true }) x

@[inline] def withTransparency (mode : TransparencyMode) : n α → n α :=
  mapMetaM <| withConfig (fun config => { config with transparency := mode })

@[inline] def withDefault (x : n α) : n α :=
  withTransparency TransparencyMode.default x

@[inline] def withReducible (x : n α) : n α :=
  withTransparency TransparencyMode.reducible x

@[inline] def withReducibleAndInstances (x : n α) : n α :=
  withTransparency TransparencyMode.instances x

@[inline] def withAtLeastTransparency (mode : TransparencyMode) (x : n α) : n α :=
  withConfig
    (fun config =>
      let oldMode := config.transparency
      let mode    := if oldMode.lt mode then mode else oldMode
      { config with transparency := mode })
    x

/-- Save cache, execute `x`, restore cache -/
@[inline] private def savingCacheImpl (x : MetaM α) : MetaM α := do
  let s ← get
  let savedCache := s.cache
  try x finally modify fun s => { s with cache := savedCache }

@[inline] def savingCache : n α → n α :=
  mapMetaM savingCacheImpl

def getTheoremInfo (info : ConstantInfo) : MetaM (Option ConstantInfo) := do
  if (← shouldReduceAll) then
    return some info
  else
    return none

private def getDefInfoTemp (info : ConstantInfo) : MetaM (Option ConstantInfo) := do
  match (← getTransparency) with
  | TransparencyMode.all => return some info
  | TransparencyMode.default => return some info
  | _ =>
    if (← isReducible info.name) then
      return some info
    else
      return none

/- Remark: we later define `getConst?` at `GetConst.lean` after we define `Instances.lean`.
   This method is only used to implement `isClassQuickConst?`.
   It is very similar to `getConst?`, but it returns none when `TransparencyMode.instances` and
   `constName` is an instance. This difference should be irrelevant for `isClassQuickConst?`. -/
private def getConstTemp? (constName : Name) : MetaM (Option ConstantInfo) := do
  let env ← getEnv
  match env.find? constName with
  | some (info@(ConstantInfo.thmInfo _))  => getTheoremInfo info
  | some (info@(ConstantInfo.defnInfo _)) => getDefInfoTemp info
  | some info                             => pure (some info)
  | none                                  => throwUnknownConstant constName

private def isClassQuickConst? (constName : Name) : MetaM (LOption Name) := do
  let env ← getEnv
  if isClass env constName then
    pure (LOption.some constName)
  else
    match (← getConstTemp? constName) with
    | some _ => pure LOption.undef
    | none   => pure LOption.none

private partial def isClassQuick? : Expr → MetaM (LOption Name)
  | Expr.bvar ..         => pure LOption.none
  | Expr.lit ..          => pure LOption.none
  | Expr.fvar ..         => pure LOption.none
  | Expr.sort ..         => pure LOption.none
  | Expr.lam ..          => pure LOption.none
  | Expr.letE ..         => pure LOption.undef
  | Expr.proj ..         => pure LOption.undef
  | Expr.forallE _ _ b _ => isClassQuick? b
  | Expr.mdata _ e _     => isClassQuick? e
  | Expr.const n _ _     => isClassQuickConst? n
  | Expr.mvar mvarId _   => do
    match (← getExprMVarAssignment? mvarId) with
    | some val => isClassQuick? val
    | none     => pure LOption.none
  | Expr.app f _ _       =>
    match f.getAppFn with
    | Expr.const n .. => isClassQuickConst? n
    | Expr.lam ..     => pure LOption.undef
    | _              => pure LOption.none

def saveAndResetSynthInstanceCache : MetaM SynthInstanceCache := do
  let s ← get
  let savedSythInstance := s.cache.synthInstance
  modifyCache fun c => { c with synthInstance := {} }
  pure savedSythInstance

def restoreSynthInstanceCache (cache : SynthInstanceCache) : MetaM Unit :=
  modifyCache fun c => { c with synthInstance := cache }

@[inline] private def resettingSynthInstanceCacheImpl (x : MetaM α) : MetaM α := do
  let savedSythInstance ← saveAndResetSynthInstanceCache
  try x finally restoreSynthInstanceCache savedSythInstance

/-- Reset `synthInstance` cache, execute `x`, and restore cache -/
@[inline] def resettingSynthInstanceCache : n α → n α :=
  mapMetaM resettingSynthInstanceCacheImpl

@[inline] def resettingSynthInstanceCacheWhen (b : Bool) (x : n α) : n α :=
  if b then resettingSynthInstanceCache x else x

private def withNewLocalInstanceImp (className : Name) (fvar : Expr) (k : MetaM α) : MetaM α := do
  let localDecl ← getFVarLocalDecl fvar
  /- Recall that we use `auxDecl` binderInfo when compiling recursive declarations. -/
  match localDecl.binderInfo with
  | BinderInfo.auxDecl => k
  | _ =>
    resettingSynthInstanceCache <|
      withReader
        (fun ctx => { ctx with localInstances := ctx.localInstances.push { className := className, fvar := fvar } })
        k

/-- Add entry `{ className := className, fvar := fvar }` to localInstances,
    and then execute continuation `k`.
    It resets the type class cache using `resettingSynthInstanceCache`. -/
def withNewLocalInstance (className : Name) (fvar : Expr) : n α → n α :=
  mapMetaM <| withNewLocalInstanceImp className fvar

private def fvarsSizeLtMaxFVars (fvars : Array Expr) (maxFVars? : Option Nat) : Bool :=
  match maxFVars? with
  | some maxFVars => fvars.size < maxFVars
  | none          => true

mutual
  /--
    `withNewLocalInstances isClassExpensive fvars j k` updates the vector or local instances
    using free variables `fvars[j] ... fvars.back`, and execute `k`.

    - `isClassExpensive` is defined later.
    - The type class chache is reset whenever a new local instance is found.
    - `isClassExpensive` uses `whnf` which depends (indirectly) on the set of local instances.
      Thus, each new local instance requires a new `resettingSynthInstanceCache`. -/
  private partial def withNewLocalInstancesImp
      (fvars : Array Expr) (i : Nat) (k : MetaM α) : MetaM α := do
    if h : i < fvars.size then
      let fvar := fvars.get ⟨i, h⟩
      let decl ← getFVarLocalDecl fvar
      match (← isClassQuick? decl.type) with
      | LOption.none   => withNewLocalInstancesImp fvars (i+1) k
      | LOption.undef  =>
        match (← isClassExpensive? decl.type) with
        | none   => withNewLocalInstancesImp fvars (i+1) k
        | some c => withNewLocalInstance c fvar <| withNewLocalInstancesImp fvars (i+1) k
      | LOption.some c => withNewLocalInstance c fvar <| withNewLocalInstancesImp fvars (i+1) k
    else
      k

  /--
    `forallTelescopeAuxAux lctx fvars j type`
    Remarks:
    - `lctx` is the `MetaM` local context extended with declarations for `fvars`.
    - `type` is the type we are computing the telescope for. It contains only
      dangling bound variables in the range `[j, fvars.size)`
    - if `reducing? == true` and `type` is not `forallE`, we use `whnf`.
    - when `type` is not a `forallE` nor it can't be reduced to one, we
      excute the continuation `k`.

    Here is an example that demonstrates the `reducing?`.
    Suppose we have
    ```
    abbrev StateM s a := s -> Prod a s
    ```
    Now, assume we are trying to build the telescope for
    ```
    forall (x : Nat), StateM Int Bool
    ```
    if `reducing == true`, the function executes `k #[(x : Nat) (s : Int)] Bool`.
    if `reducing == false`, the function executes `k #[(x : Nat)] (StateM Int Bool)`

    if `maxFVars?` is `some max`, then we interrupt the telescope construction
    when `fvars.size == max`
  -/
  private partial def forallTelescopeReducingAuxAux
      (reducing          : Bool) (maxFVars? : Option Nat)
      (type              : Expr)
      (k                 : Array Expr → Expr → MetaM α) : MetaM α := do
    let rec process (lctx : LocalContext) (fvars : Array Expr) (j : Nat) (type : Expr) : MetaM α := do
      match type with
      | Expr.forallE n d b c =>
        if fvarsSizeLtMaxFVars fvars maxFVars? then
          let d     := d.instantiateRevRange j fvars.size fvars
          let fvarId ← mkFreshId
          let lctx  := lctx.mkLocalDecl fvarId n d c.binderInfo
          let fvar  := mkFVar fvarId
          let fvars := fvars.push fvar
          process lctx fvars j b
        else
          let type := type.instantiateRevRange j fvars.size fvars;
          withReader (fun ctx => { ctx with lctx := lctx }) do
            withNewLocalInstancesImp fvars j do
              k fvars type
      | _ =>
        let type := type.instantiateRevRange j fvars.size fvars;
        withReader (fun ctx => { ctx with lctx := lctx }) do
          withNewLocalInstancesImp fvars j do
            if reducing && fvarsSizeLtMaxFVars fvars maxFVars? then
              let newType ← whnf type
              if newType.isForall then
                process lctx fvars fvars.size newType
              else
                k fvars type
            else
              k fvars type
    process (← getLCtx) #[] 0 type

  private partial def forallTelescopeReducingAux (type : Expr) (maxFVars? : Option Nat) (k : Array Expr → Expr → MetaM α) : MetaM α := do
    match maxFVars? with
    | some 0 => k #[] type
    | _ => do
      let newType ← whnf type
      if newType.isForall then
        forallTelescopeReducingAuxAux true maxFVars? newType k
      else
        k #[] type

  private partial def isClassExpensive? : Expr → MetaM (Option Name)
    | type => withReducible <| -- when testing whether a type is a type class, we only unfold reducible constants.
      forallTelescopeReducingAux type none fun xs type => do
        let env ← getEnv
        match type.getAppFn with
        | Expr.const c _ _ => do
          if isClass env c then
            return some c
          else
            -- make sure abbreviations are unfolded
            match (← whnf type).getAppFn with
            | Expr.const c _ _ => return if isClass env c then some c else none
            | _ => return none
        | _ => return none

  private partial def isClassImp? (type : Expr) : MetaM (Option Name) := do
    match (← isClassQuick? type) with
    | LOption.none   => pure none
    | LOption.some c => pure (some c)
    | LOption.undef  => isClassExpensive? type

end

def isClass? (type : Expr) : MetaM (Option Name) :=
  try isClassImp? type catch _ => pure none

private def withNewLocalInstancesImpAux (fvars : Array Expr) (j : Nat) : n α → n α :=
  mapMetaM <| withNewLocalInstancesImp fvars j

partial def withNewLocalInstances (fvars : Array Expr) (j : Nat) : n α → n α :=
  mapMetaM <| withNewLocalInstancesImpAux fvars j

@[inline] private def forallTelescopeImp (type : Expr) (k : Array Expr → Expr → MetaM α) : MetaM α := do
  forallTelescopeReducingAuxAux (reducing := false) (maxFVars? := none) type k

/--
  Given `type` of the form `forall xs, A`, execute `k xs A`.
  This combinator will declare local declarations, create free variables for them,
  execute `k` with updated local context, and make sure the cache is restored after executing `k`. -/
def forallTelescope (type : Expr) (k : Array Expr → Expr → n α) : n α :=
  map2MetaM (fun k => forallTelescopeImp type k) k

private def forallTelescopeReducingImp (type : Expr) (k : Array Expr → Expr → MetaM α) : MetaM α :=
  forallTelescopeReducingAux type (maxFVars? := none) k

/--
  Similar to `forallTelescope`, but given `type` of the form `forall xs, A`,
  it reduces `A` and continues bulding the telescope if it is a `forall`. -/
def forallTelescopeReducing (type : Expr) (k : Array Expr → Expr → n α) : n α :=
  map2MetaM (fun k => forallTelescopeReducingImp type k) k

private def forallBoundedTelescopeImp (type : Expr) (maxFVars? : Option Nat) (k : Array Expr → Expr → MetaM α) : MetaM α :=
  forallTelescopeReducingAux type maxFVars? k

/--
  Similar to `forallTelescopeReducing`, stops constructing the telescope when
  it reaches size `maxFVars`. -/
def forallBoundedTelescope (type : Expr) (maxFVars? : Option Nat) (k : Array Expr → Expr → n α) : n α :=
  map2MetaM (fun k => forallBoundedTelescopeImp type maxFVars? k) k

/-- Similar to `forallTelescopeAuxAux` but for lambda and let expressions. -/
private partial def lambdaTelescopeAux
    (k : Array Expr → Expr → MetaM α)
    : Bool → LocalContext → Array Expr → Nat → Expr → MetaM α
  | consumeLet, lctx, fvars, j, Expr.lam n d b c => do
    let d := d.instantiateRevRange j fvars.size fvars
    let fvarId ← mkFreshId
    let lctx := lctx.mkLocalDecl fvarId n d c.binderInfo
    let fvar := mkFVar fvarId
    lambdaTelescopeAux k consumeLet lctx (fvars.push fvar) j b
  | true, lctx, fvars, j, Expr.letE n t v b _ => do
    let t := t.instantiateRevRange j fvars.size fvars
    let v := v.instantiateRevRange j fvars.size fvars
    let fvarId ← mkFreshId
    let lctx := lctx.mkLetDecl fvarId n t v
    let fvar := mkFVar fvarId
    lambdaTelescopeAux k true lctx (fvars.push fvar) j b
  | _, lctx, fvars, j, e =>
    let e := e.instantiateRevRange j fvars.size fvars;
    withReader (fun ctx => { ctx with lctx := lctx }) do
      withNewLocalInstancesImp fvars j do
        k fvars e

private partial def lambdaTelescopeImp (e : Expr) (consumeLet : Bool) (k : Array Expr → Expr → MetaM α) : MetaM α := do
  let rec process (consumeLet : Bool) (lctx : LocalContext) (fvars : Array Expr) (j : Nat) (e : Expr) : MetaM α := do
    match consumeLet, e with
    | _, Expr.lam n d b c =>
      let d := d.instantiateRevRange j fvars.size fvars
      let fvarId ← mkFreshId
      let lctx := lctx.mkLocalDecl fvarId n d c.binderInfo
      let fvar := mkFVar fvarId
      process consumeLet lctx (fvars.push fvar) j b
    | true, Expr.letE n t v b _ => do
      let t := t.instantiateRevRange j fvars.size fvars
      let v := v.instantiateRevRange j fvars.size fvars
      let fvarId ← mkFreshId
      let lctx := lctx.mkLetDecl fvarId n t v
      let fvar := mkFVar fvarId
      process true lctx (fvars.push fvar) j b
    | _, e =>
      let e := e.instantiateRevRange j fvars.size fvars
      withReader (fun ctx => { ctx with lctx := lctx }) do
        withNewLocalInstancesImp fvars j do
          k fvars e
  process consumeLet (← getLCtx) #[] 0 e

/-- Similar to `forallTelescope` but for lambda and let expressions. -/
def lambdaLetTelescope (type : Expr) (k : Array Expr → Expr → n α) : n α :=
  map2MetaM (fun k => lambdaTelescopeImp type true k) k

/-- Similar to `forallTelescope` but for lambda expressions. -/
def lambdaTelescope (type : Expr) (k : Array Expr → Expr → n α) : n α :=
  map2MetaM (fun k => lambdaTelescopeImp type false k) k

/-- Return the parameter names for the givel global declaration. -/
def getParamNames (declName : Name) : MetaM (Array Name) := do
  let cinfo ← getConstInfo declName
  forallTelescopeReducing cinfo.type fun xs _ => do
    xs.mapM fun x => do
      let localDecl ← getLocalDecl x.fvarId!
      pure localDecl.userName

-- `kind` specifies the metavariable kind for metavariables not corresponding to instance implicit `[ ... ]` arguments.
private partial def forallMetaTelescopeReducingAux
    (e : Expr) (reducing : Bool) (maxMVars? : Option Nat) (kind : MetavarKind) : MetaM (Array Expr × Array BinderInfo × Expr) :=
  let rec process (mvars : Array Expr) (bis : Array BinderInfo) (j : Nat) (type : Expr) : MetaM (Array Expr × Array BinderInfo × Expr) := do
    match type with
    | Expr.forallE n d b c =>
      let cont : Unit → MetaM (Array Expr × Array BinderInfo × Expr) := fun _ => do
        let d  := d.instantiateRevRange j mvars.size mvars
        let k  := if c.binderInfo.isInstImplicit then  MetavarKind.synthetic else kind
        let mvar ← mkFreshExprMVar d k n
        let mvars := mvars.push mvar
        let bis   := bis.push c.binderInfo
        process mvars bis j b
      match maxMVars? with
      | none          => cont ()
      | some maxMVars =>
        if mvars.size < maxMVars then
          cont ()
        else
          let type := type.instantiateRevRange j mvars.size mvars;
          pure (mvars, bis, type)
    | _ =>
      let type := type.instantiateRevRange j mvars.size mvars;
      if reducing then do
        let newType ← whnf type;
        if newType.isForall then
          process mvars bis mvars.size newType
        else
          pure (mvars, bis, type)
      else
        pure (mvars, bis, type)
  process #[] #[] 0 e

/-- Similar to `forallTelescope`, but creates metavariables instead of free variables. -/
def forallMetaTelescope (e : Expr) (kind := MetavarKind.natural) : MetaM (Array Expr × Array BinderInfo × Expr) :=
  forallMetaTelescopeReducingAux e (reducing := false) (maxMVars? := none) kind

/-- Similar to `forallTelescopeReducing`, but creates metavariables instead of free variables. -/
def forallMetaTelescopeReducing (e : Expr) (maxMVars? : Option Nat := none) (kind := MetavarKind.natural) : MetaM (Array Expr × Array BinderInfo × Expr) :=
  forallMetaTelescopeReducingAux e (reducing := true) maxMVars? kind

/-- Similar to `forallMetaTelescopeReducingAux` but for lambda expressions. -/
partial def lambdaMetaTelescope (e : Expr) (maxMVars? : Option Nat := none) : MetaM (Array Expr × Array BinderInfo × Expr) :=
  let rec process (mvars : Array Expr) (bis : Array BinderInfo) (j : Nat) (type : Expr) : MetaM (Array Expr × Array BinderInfo × Expr) := do
    let finalize : Unit → MetaM (Array Expr × Array BinderInfo × Expr) := fun _ => do
      let type := type.instantiateRevRange j mvars.size mvars
      pure (mvars, bis, type)
    let cont : Unit → MetaM (Array Expr × Array BinderInfo × Expr) := fun _ => do
      match type with
      | Expr.lam n d b c =>
        let d     := d.instantiateRevRange j mvars.size mvars
        let mvar ← mkFreshExprMVar d
        let mvars := mvars.push mvar
        let bis   := bis.push c.binderInfo
        process mvars bis j b
      | _ => finalize ()
    match maxMVars? with
    | none          => cont ()
    | some maxMVars =>
      if mvars.size < maxMVars then
        cont ()
      else
        finalize ()
  process #[] #[] 0 e

private def withNewFVar (fvar fvarType : Expr) (k : Expr → MetaM α) : MetaM α := do
  match (← isClass? fvarType) with
  | none   => k fvar
  | some c => withNewLocalInstance c fvar <| k fvar

private def withLocalDeclImp (n : Name) (bi : BinderInfo) (type : Expr) (k : Expr → MetaM α) : MetaM α := do
  let fvarId ← mkFreshId
  let ctx ← read
  let lctx := ctx.lctx.mkLocalDecl fvarId n type bi
  let fvar := mkFVar fvarId
  withReader (fun ctx => { ctx with lctx := lctx }) do
    withNewFVar fvar type k

def withLocalDecl (name : Name) (bi : BinderInfo) (type : Expr) (k : Expr → n α) : n α :=
  map1MetaM (fun k => withLocalDeclImp name bi type k) k

def withLocalDeclD (name : Name) (type : Expr) (k : Expr → n α) : n α :=
  withLocalDecl name BinderInfo.default type k

partial def withLocalDecls
    [Inhabited α]
    (declInfos : Array (Name × BinderInfo × (Array Expr → n Expr)))
    (k : (xs : Array Expr) → n α)
    : n α :=
  let rec loop
      [Inhabited α]
      (acc : Array Expr) : n α := do
    if acc.size < declInfos.size then
      let (name, bi, typeCtor) := declInfos[acc.size]
      withLocalDecl name bi (←typeCtor acc) fun x => loop (acc.push x)
    else k acc

  loop #[]

def withLocalDeclsD
    [Inhabited α]
    (declInfos : Array (Name × (Array Expr → n Expr)))
    (k : (xs : Array Expr) → n α)
    : n α :=
  withLocalDecls
    (declInfos.map (fun (name, typeCtor) => (name, BinderInfo.default, typeCtor))) k

private def withNewBinderInfosImp (bs : Array (FVarId × BinderInfo)) (k : MetaM α) : MetaM α := do
  let lctx := bs.foldl (init := (← getLCtx)) fun lctx (fvarId, bi) =>
      lctx.setBinderInfo fvarId bi
  withReader (fun ctx => { ctx with lctx := lctx }) k

def withNewBinderInfos (bs : Array (FVarId × BinderInfo)) (k : n α) : n α :=
  mapMetaM (fun k => withNewBinderInfosImp bs k) k

private def withLetDeclImp (n : Name) (type : Expr) (val : Expr) (k : Expr → MetaM α) : MetaM α := do
  let fvarId ← mkFreshId
  let ctx ← read
  let lctx := ctx.lctx.mkLetDecl fvarId n type val
  let fvar := mkFVar fvarId
  withReader (fun ctx => { ctx with lctx := lctx }) do
    withNewFVar fvar type k

def withLetDecl (name : Name) (type : Expr) (val : Expr) (k : Expr → n α) : n α :=
  map1MetaM (fun k => withLetDeclImp name type val k) k

private def withExistingLocalDeclsImp (decls : List LocalDecl) (k : MetaM α) : MetaM α := do
  let ctx ← read
  let numLocalInstances := ctx.localInstances.size
  let lctx := decls.foldl (fun (lctx : LocalContext) decl => lctx.addDecl decl) ctx.lctx
  withReader (fun ctx => { ctx with lctx := lctx }) do
    let newLocalInsts ← decls.foldlM
      (fun (newlocalInsts : Array LocalInstance) (decl : LocalDecl) => (do {
        match (← isClass? decl.type) with
        | none   => pure newlocalInsts
        | some c => pure <| newlocalInsts.push { className := c, fvar := decl.toExpr } } : MetaM _))
      ctx.localInstances;
    if newLocalInsts.size == numLocalInstances then
      k
    else
      resettingSynthInstanceCache <| withReader (fun ctx => { ctx with localInstances := newLocalInsts }) k

def withExistingLocalDecls (decls : List LocalDecl) : n α → n α :=
  mapMetaM <| withExistingLocalDeclsImp decls

private def withNewMCtxDepthImp (x : MetaM α) : MetaM α := do
  let saved ← get
  modify fun s => { s with mctx := s.mctx.incDepth, postponed := {} }
  try
    x
  finally
    modify fun s => { s with mctx := saved.mctx, postponed := saved.postponed }

/--
  Save cache and `MetavarContext`, bump the `MetavarContext` depth, execute `x`,
  and restore saved data. -/
def withNewMCtxDepth : n α → n α :=
  mapMetaM withNewMCtxDepthImp

private def withLocalContextImp (lctx : LocalContext) (localInsts : LocalInstances) (x : MetaM α) : MetaM α := do
  let localInstsCurr ← getLocalInstances
  withReader (fun ctx => { ctx with lctx := lctx, localInstances := localInsts }) do
    if localInsts == localInstsCurr then
      x
    else
      resettingSynthInstanceCache x

def withLCtx (lctx : LocalContext) (localInsts : LocalInstances) : n α → n α :=
  mapMetaM <| withLocalContextImp lctx localInsts

private def withMVarContextImp (mvarId : MVarId) (x : MetaM α) : MetaM α := do
  let mvarDecl ← getMVarDecl mvarId
  withLocalContextImp mvarDecl.lctx mvarDecl.localInstances x

/--
  Execute `x` using the given metavariable `LocalContext` and `LocalInstances`.
  The type class resolution cache is flushed when executing `x` if its `LocalInstances` are
  different from the current ones. -/
def withMVarContext (mvarId : MVarId) : n α → n α :=
  mapMetaM <| withMVarContextImp mvarId

private def withMCtxImp (mctx : MetavarContext) (x : MetaM α) : MetaM α := do
  let mctx' ← getMCtx
  setMCtx mctx
  try x finally setMCtx mctx'

def withMCtx (mctx : MetavarContext) : n α → n α :=
  mapMetaM <| withMCtxImp mctx

@[inline] private def approxDefEqImp (x : MetaM α) : MetaM α :=
  withConfig (fun config => { config with foApprox := true, ctxApprox := true, quasiPatternApprox := true}) x

/-- Execute `x` using approximate unification: `foApprox`, `ctxApprox` and `quasiPatternApprox`.  -/
@[inline] def approxDefEq : n α → n α :=
  mapMetaM approxDefEqImp

@[inline] private def fullApproxDefEqImp (x : MetaM α) : MetaM α :=
  withConfig (fun config => { config with foApprox := true, ctxApprox := true, quasiPatternApprox := true, constApprox := true }) x

/--
  Similar to `approxDefEq`, but uses all available approximations.
  We don't use `constApprox` by default at `approxDefEq` because it often produces undesirable solution for monadic code.
  For example, suppose we have `pure (x > 0)` which has type `?m Prop`. We also have the goal `[Pure ?m]`.
  Now, assume the expected type is `IO Bool`. Then, the unification constraint `?m Prop =?= IO Bool` could be solved
  as `?m := fun _ => IO Bool` using `constApprox`, but this spurious solution would generate a failure when we try to
  solve `[Pure (fun _ => IO Bool)]` -/
@[inline] def fullApproxDefEq : n α → n α :=
  mapMetaM fullApproxDefEqImp

def normalizeLevel (u : Level) : MetaM Level := do
  let u ← instantiateLevelMVars u
  pure u.normalize

def assignLevelMVar (mvarId : MVarId) (u : Level) : MetaM Unit := do
  modifyMCtx fun mctx => mctx.assignLevel mvarId u

def whnfR (e : Expr) : MetaM Expr :=
  withTransparency TransparencyMode.reducible <| whnf e

def whnfD (e : Expr) : MetaM Expr :=
  withTransparency TransparencyMode.default <| whnf e

def whnfI (e : Expr) : MetaM Expr :=
  withTransparency TransparencyMode.instances <| whnf e

def setInlineAttribute (declName : Name) (kind := Compiler.InlineAttributeKind.inline): MetaM Unit := do
  let env ← getEnv
  match Compiler.setInlineAttribute env declName kind with
  | Except.ok env    => setEnv env
  | Except.error msg => throwError msg

private partial def instantiateForallAux (ps : Array Expr) (i : Nat) (e : Expr) : MetaM Expr := do
  if h : i < ps.size then
    let p := ps.get ⟨i, h⟩
    let e ← whnf e
    match e with
    | Expr.forallE _ _ b _ => instantiateForallAux ps (i+1) (b.instantiate1 p)
    | _                    => throwError "invalid instantiateForall, too many parameters"
  else
    pure e

/- Given `e` of the form `forall (a_1 : A_1) ... (a_n : A_n), B[a_1, ..., a_n]` and `p_1 : A_1, ... p_n : A_n`, return `B[p_1, ..., p_n]`. -/
def instantiateForall (e : Expr) (ps : Array Expr) : MetaM Expr :=
  instantiateForallAux ps 0 e

private partial def instantiateLambdaAux (ps : Array Expr) (i : Nat) (e : Expr) : MetaM Expr := do
  if h : i < ps.size then
    let p := ps.get ⟨i, h⟩
    let e ← whnf e
    match e with
    | Expr.lam _ _ b _ => instantiateLambdaAux ps (i+1) (b.instantiate1 p)
    | _                => throwError "invalid instantiateLambda, too many parameters"
  else
    pure e

/- Given `e` of the form `fun (a_1 : A_1) ... (a_n : A_n) => t[a_1, ..., a_n]` and `p_1 : A_1, ... p_n : A_n`, return `t[p_1, ..., p_n]`.
   It uses `whnf` to reduce `e` if it is not a lambda -/
def instantiateLambda (e : Expr) (ps : Array Expr) : MetaM Expr :=
  instantiateLambdaAux ps 0 e

/-- Return true iff `e` depends on the free variable `fvarId` -/
def dependsOn (e : Expr) (fvarId : FVarId) : MetaM Bool :=
  return (← getMCtx).exprDependsOn e fvarId

def ppExpr (e : Expr) : MetaM Format := do
  let env  ← getEnv
  let mctx ← getMCtx
  let lctx ← getLCtx
  let opts ← getOptions
  let ctxCore  ← readThe Core.Context
  Lean.ppExpr { env := env, mctx := mctx, lctx := lctx, opts := opts, currNamespace := ctxCore.currNamespace, openDecls := ctxCore.openDecls  } e

@[inline] protected def orelse (x y : MetaM α) : MetaM α := do
  let env  ← getEnv
  let mctx ← getMCtx
  try x catch _ => setEnv env; setMCtx mctx; y

instance : OrElse (MetaM α) := ⟨Meta.orelse⟩

@[inline] private def orelseMergeErrorsImp (x y : MetaM α)
    (mergeRef : Syntax → Syntax → Syntax := fun r₁ r₂ => r₁)
    (mergeMsg : MessageData → MessageData → MessageData := fun m₁ m₂ => m₁ ++ Format.line ++ m₂) : MetaM α := do
  let env  ← getEnv
  let mctx ← getMCtx
  try
    x
  catch ex =>
    setEnv env
    setMCtx mctx
    match ex with
    | Exception.error ref₁ m₁ =>
      try
        y
      catch
        | Exception.error ref₂ m₂ => throw <| Exception.error (mergeRef ref₁ ref₂) (mergeMsg m₁ m₂)
        | ex => throw ex
    | ex => throw ex

/--
  Similar to `orelse`, but merge errors. Note that internal errors are not caught.
  The default `mergeRef` uses the `ref` (position information) for the first message.
  The default `mergeMsg` combines error messages using `Format.line ++ Format.line` as a separator. -/
@[inline] def orelseMergeErrors [MonadControlT MetaM m] [Monad m] (x y : m α)
    (mergeRef : Syntax → Syntax → Syntax := fun r₁ r₂ => r₁)
    (mergeMsg : MessageData → MessageData → MessageData := fun m₁ m₂ => m₁ ++ Format.line ++ Format.line ++ m₂) : m α := do
  controlAt MetaM fun runInBase => orelseMergeErrorsImp (runInBase x) (runInBase y) mergeRef mergeMsg

/-- Execute `x`, and apply `f` to the produced error message -/
def mapErrorImp (x : MetaM α) (f : MessageData → MessageData) : MetaM α := do
  try
    x
  catch
    | Exception.error ref msg => throw <| Exception.error ref <| f msg
    | ex => throw ex

@[inline] def mapError [MonadControlT MetaM m] [Monad m] (x : m α) (f : MessageData → MessageData) : m α :=
  controlAt MetaM fun runInBase => mapErrorImp (runInBase x) f

end Methods
end Meta

export Meta (MetaM)

end Lean


import Architectural.proofObligations
import Architectural.lang
import tactic

open LANG PORTS tactic

local infix ` OR `:50 := LANG.disj
local infix ` & `:50 := LANG.conj
variables {Var : Type} [fintype Var] [decidable_eq Var] [reflected Var]

theorem asdff (x : Trace PORTS) {A : LANG} : x ∈ (@AssertionLang.sem LANG PORTS _ _ _ A) ↔ x ∈ LANG.sem A := by {refl,}

theorem fsadfdsa (x : Trace PORTS) (A B : LANG) : x ∈ LANG.sem (A & B).always ↔ x ∈ LANG.sem (A).always ∧ x ∈ LANG.sem (B).always :=
begin
simp, rw forall_and_distrib,
end

theorem disj_comm_guarded (x : Trace PORTS) (A B : LANG) : x ∈ LANG.sem (A OR B).always ↔ x ∈ LANG.sem (B OR A).always :=
begin
simp,
end
theorem conj_comm_guarded (x : Trace PORTS) (A B : LANG) : x ∈ LANG.sem (A & B).always ↔ x ∈ LANG.sem (B & A).always :=
begin
split, all_goals {intros h i, replace h := h i, cases h, split, assumption, assumption,},
end

theorem fasdjbasdf {x : Trace PORTS} (A B : LANG) : x ∈ LANG.sem (A & B) ↔ x ∈ LANG.sem A ∧ x ∈ LANG.sem B :=
begin
rw conj_def, simp,
end

theorem foobars {x : Trace PORTS} (A B C D : LANG) :
                            x ∈ LANG.sem ((A & B & C).always & D.always)
              ↔
                            x ∈ LANG.sem (((A & B).always &C.always) & D.always)  :=
begin
repeat {rw fasdjbasdf,  rw fsadfdsa,},
end

theorem portation_left {x : Trace PORTS} (A B : LANG) : (x ∈ @AssertionLang.sem LANG PORTS _ _ _ (A & B).always) → x ∈ (A).always.sem :=
begin
intro h, intro i, rw forall_conj_distrib_mem at h, cases h with h1 h2, apply h1 i,
end

theorem portation_right {x : Trace PORTS} (A B : LANG) : (x ∈ @AssertionLang.sem LANG PORTS _ _ _ (A & B).always) → x ∈ (B).always.sem :=
begin
intro h, intro i, rw forall_conj_distrib_mem at h, cases h with h1 h2, apply h2 i,
end

------

meta structure model_info :=
(del : list (expr × expr))
(comps : list expr)

meta def preprocess_rpo_fst : tactic (name × name) := do
  x ← tactic.get_unused_name `x,
  H ← tactic.get_unused_name `H,
  tactic.intro x,
  `[simp],
  `[rw AssertionLang.impl_def],
  tactic.intro H,
  `[rw [list_conj_iff, get_nfs] at H, simp at H, rw toMap at H],
  return ⟨x, H⟩

meta def decompose_conj : expr →  expr → tactic (unit)
| h `(and %%left %%right) := do
    left_nm ← get_unused_name,
    right_nm ← get_unused_name,
    cases_core h [left_nm, right_nm] transparency.semireducible,
    right_e ← get_local right_nm,
    decompose_conj right_e right
| _ _ := do return ()

meta def decompose_conj_left : expr →  expr → tactic (unit)
| h `(and %%left %%right) := do
    left_nm ← get_unused_name,
    right_nm ← get_unused_name,
    cases_core h [left_nm, right_nm] transparency.semireducible,
    left_e ← get_local left_nm,
    decompose_conj left_e left
| _ _ := do return ()

meta def collect_assertions : list expr → tactic (list expr)
| (h::t ) := do
  τ ← infer_type h,
  match τ with
  | `(_ ∈ _) := do
                l ← collect_assertions t,
                return $ [h]++l
  | `(_ ∈ _ → _) := do
                l ← collect_assertions t,
                return $ [h]++l
  | _ := collect_assertions t
  end
| [] := return []

theorem  IFf_pos (c : Prop) (H : decidable c) : ∀ {α : Type} {t e  :α}, c → ite c t e = t := by {intros a b c h, apply if_pos h,}
theorem  IFf_neg  : Π (c : Prop) [H : decidable c], ∀ {α : Type} {t e  :α}, ¬c → (@ite _ c H t e) = e := by {intros a b c h a f, apply if_neg, exact f}

meta def get_conds_aux : expr → tactic (list expr)
| `(@ite %%A %%B %%C %%D %%E) := do
        let cond := [B],
        r ← get_conds_aux E,
        return $ cond ++ r
| _ := return []

meta def get_conds : expr → tactic (list expr)
| `(%%x ∈ AssertionLang.sem (%%E)) :=
  match E with
    | `(Contract.nf (option.iget %%Y)) := get_conds_aux Y
    | `(Contract.A (option.iget %%Y)) := get_conds_aux Y
    | _ := return []
  end
| `(_ → %%x ∈ AssertionLang.sem (%%E)) :=
  match E with
    | `(Contract.nf (option.iget %%Y)) := get_conds_aux Y
    | _ := return []
  end
| x :=  return []

meta def GFSAUIHasd : list expr → tactic (list (list expr))
| (h::t) := do
    -- tactic.trace "here",
    -- τ ← infer_type h,
    -- tactic.trace τ,
    l← get_conds h, t ← GFSAUIHasd t, return (l::t)
| _ := do return []

meta def aiuhsfd : list expr → list (expr × bool)
| [] :=  []
| (h::t) := match h with
           | `(eq %%A %%B) :=
              if B = A then  ([(h,tt)]++(aiuhsfd t)) else ([(h,ff)]++(aiuhsfd t))
           | _ :=  []
          end

meta def sjdioaf (hyp : expr) : list (expr × bool) → tactic unit
| [] := return ()
| ((e, b)::t) := do
                  if b then do
                  let ef := expr.mk_app `(IFf_pos) [e],
                  rewrite_hyp ef hyp, return  ()
                  else do
                  sjdioaf t

meta def suihfa : list (expr × list (expr × bool)) → tactic unit
| [] := return ()
| ((e, l)::xs) := do a ← sjdioaf e l,
                  suihfa xs

meta def extract_contracts : expr →  tactic unit := λ h, do
  infer_type h >>= decompose_conj h, dedup,
  tactic.repeat `[rw Map.find_val at *],
  xs ← local_context >>= collect_assertions,
  l ← xs.mmap infer_type >>= GFSAUIHasd,
  let ls := xs.zip (l.map aiuhsfd),
  suihfa ls,
  iterate `[rw if_neg at *],
  any_goals `[dec_trivial],
  `[rw nf_def at *, simp at *],
  return ()

meta def collect_consequents : list (expr × expr) → (list (expr × expr))
| []   := []
| ((h, τ)::t) := match τ with
                | `(%%P → %%Q) := (collect_consequents t).cons (h,Q)
                | _ := collect_consequents t
                end

meta def collect_vars_aux : expr → list expr
| `(LANG.atom %%a) := [a]
| `(LANG.lt %%a %%v) := [a,v]
| `(LANG.neg %%A) := collect_vars_aux A
| `(LANG.conj %%A %%B) := collect_vars_aux A ++ collect_vars_aux B
| `(LANG.disj %%A %%B) := collect_vars_aux A ++ collect_vars_aux B
| `(LANG.always %%A) := collect_vars_aux A
|_ := []

meta def collect_vars : expr → list expr
| `(_ ∈ AssertionLang.sem %%P) := collect_vars_aux P
| _ := []

meta def find_matches_aux : expr → list (expr × expr) → list (expr × expr)
| h ((a,b)::l) := if h=a then [(b,h)] else if h=b then [(a,h)]else (find_matches_aux h l)
| _ _ := []

meta def find_matches (del : list (expr × expr))  : list expr → list (expr × expr)
| [] := []
| (h::t) := find_matches_aux h del++(find_matches t )
-- find_matches_aux es del

open tactic.interactive («have»)

meta def mk_sync_apply (x : expr) : (expr × expr) →  tactic unit
| (a,b) := do
 -- ((synchronize' x fault_PWMFlow_LACU fault_armFlow_armController) (atom fault_PWMFlow_LACU).neg.always).mpr
 `(_ ∈ AssertionLang.sem %%FOO) ← target,
 let e := expr.mk_app `(synchronize') [x, b, a, FOO],
--  tactic.trace e,
 τ ← infer_type e,
 match τ with
 | `(%%GOAL → %%FOO) := do
   h ← get_unused_name `h,
   «have» h ``(%%GOAL) ``(by dec_trivial),
   h_e ← get_local h,
   let e' := expr.mk_app e [h_e],
    τ ← infer_type e',
   match τ  with
   | `(%%l ↔ %%r) := do
   let e'' := `(@iff.mpr %%l %%r %%e'),
   apply e'',
   `[simp],
   clear h_e,
   return ()
   | _ :=  return ()
   end
 | _ := return ()
 end

meta def try_application : list expr → tactic unit
| [] := return ()
| (h::t) :=  (do apply h, return ()) <|> try_application t

meta def synchronize_ports (x : name) (Γ : model_info): tactic unit := do
  tgt ← target,
  let cs := collect_vars tgt,
  let ls := find_matches Γ.del cs, -- vars to sub will be on LEFT
  x ← get_local x,
  ls.mmap (mk_sync_apply x),
  return ()

meta def decompose_env_assumptions (x_nm : name) : tactic unit := do
  A ← get_unused_name `A,
  intro A,
  A_e ← get_local A, x ← get_local x_nm,
  let e := expr.mk_app `(asdff) [x],
  tactic.rewrite_hyp e A_e,
  let e' := expr.mk_app `(fsadfdsa) [x],
  tactic.repeat (do A_e ← get_local A,tactic.rewrite_hyp e' A_e, return ()),
  A_e ← get_local A,
  tactic.repeat (do A_e ← get_local A, cases_core A_e [A] transparency.semireducible, return ()),
  return ()

meta def try_rewrites : expr → tactic unit
| `(_ ∈ AssertionLang.sem _) := do `[rw asdff],  tactic.repeat (`[rw fsadfdsa]), return ()
| _ := do tactic.repeat (`[rw fsadfdsa]), return ()

meta def check_for_portation_aux (e : expr) : list expr → tactic unit
| (h::t) := match h with
            | `(_ → (_ ∈ AssertionLang.sem (%%A & %%B).always)) :=
              if A = e then do `[apply portation_left], return ()
              else if B = e then do `[apply portation_right], return ()
              else check_for_portation_aux t
            | _ := check_for_portation_aux t
            end
| [] := return ()

meta def check_for_portation_aux' (e : expr) : list expr → tactic unit
| (h::t) := match h with
            | `(_ → _ → (_ ∈ AssertionLang.sem (%%A & %%B).always)) :=
              if A = e then do `[apply portation_left], return ()
              else if B = e then do `[apply portation_right], return ()
              else check_for_portation_aux' t
            | _ := check_for_portation_aux' t
            end
| [] := return ()

meta def check_for_portation : tactic unit := do
`(_ ∈ LANG.sem (LANG.always %%FOO)) ← target,
local_context >>= (list.mmap infer_type) >>= check_for_portation_aux FOO

meta def check_for_portation' : tactic unit := do
`(_ ∈ LANG.sem (LANG.always %%FOO)) ← target,
local_context >>= (list.mmap infer_type) >>= check_for_portation_aux' FOO

meta def find_assumption : list expr → tactic bool
| [] := return ff
| (h::t) := do apply h >> return tt <|> find_assumption t

meta def try_terminal_rws : tactic unit := do
 `[rwa disj_comm_guarded] <|> `[rwa conj_comm_guarded] <|> return ()

meta def core_rpo_loop (x : name) (Γ : model_info) : tactic unit := do
check_for_portation,
local_context >>= try_application,
synchronize_ports x Γ,
target >>= try_rewrites,
b ← local_context >>= find_assumption,
if !b then try_terminal_rws else return ()

meta def solve_rpo_fst_new (Γ : model_info) : tactic unit := do
  ⟨x, H⟩ ← preprocess_rpo_fst,
  get_local H >>= extract_contracts,
  decompose_env_assumptions x,
  synchronize_ports x Γ,
  local_context >>= try_application,
  synchronize_ports x Γ,
  target >>= try_rewrites,
  repeat `[split],
  all_goals $ core_rpo_loop x Γ,
  try (`[repeat {split}, repeat {assumption}]), -- can fix.
  return ()

meta def make_cases (H : name) : tactic unit := do
  H_e ← get_local H,
  τ ← infer_type H_e,
  match τ with
  |`(or _ _) := do cases_core H_e [] transparency.semireducible,
                   all_goals (make_cases ),
                   return ()
  | _ := return ()
  end

meta def find_this_component (Γ : model_info) : list expr → tactic expr
| [] := return default
| (h::t) := do
            τ ← infer_type h,
            match τ with
            | `(_ = %%FOO) :=
                  if FOO ∈ Γ.comps then return FOO else find_this_component t
            | _ := find_this_component t
            end

meta def get_comp_contract (H : expr)  (comp : expr): tactic unit := do
  h ← get_unused_name,
  let e : expr := (expr.mk_app H [comp]),
  τ ← infer_type e,
  tactic.local_proof h (τ) (tactic.exact e),
  return ()

meta def get_other_comp_contracts (Γ : model_info) (H2 : expr) : tactic expr := do
  e ← local_context >>= find_this_component Γ,
  let l := Γ.comps.erase e,
  l.mmap (get_comp_contract H2),
  return e

meta def rewrite_this_comp  (comp : expr ) : list expr → tactic unit
| (h::t) := do
          τ ← infer_type h,
          match τ with
          | `(_ = %%FOO) := if FOO = comp then subst h else rewrite_this_comp t
          | _ := rewrite_this_comp t
          end
| [] := return ()

meta def decompose_fst_hyp (Γ : model_info) : tactic unit := do
  Ha ← tactic.get_unused_name `Ha,
  `[rw AssertionLang.impl_def],
  tactic.intro Ha,
  `[rw AssertionLang.conj_def at *],
  H_e ← get_local Ha,
  H1 ← get_unused_name `H1,
  H2 ← get_unused_name `H2,
  cases_core H_e [H1,H2] transparency.semireducible,
  `[rw list_conj_iff at *, simp only [list.mem_map, forall_exists_index, and_imp, forall_apply_eq_imp_iff₂] at *],
   this_comp ← get_local H2 >>= get_other_comp_contracts Γ,
   local_context >>= rewrite_this_comp this_comp,
   H1_e ← get_local H1,
   tactic.rewrite_hyp `(asdff) H1_e,
   repeat `[rw fsadfdsa at *],
  tactic.iterate (do H1_e ← get_local H1, cases_core H1_e [H1] transparency.semireducible),
  return ()

meta def clear_goal_rewrites_aux : expr → tactic unit
| `(ite (%%X = %%Y) %%B %%C) :=  if X = Y then do `[rw if_pos] else do `[rw if_neg], clear_goal_rewrites_aux C
| _ := do  return ()

meta def clear_goal_of_rewrites : tactic unit := do
 tgt ← target,
 match tgt with
 | `(_ ∈ AssertionLang.sem (Contract.A (option.iget (%%FOO)))) := clear_goal_rewrites_aux FOO
 | _ := do tactic.trace "hmm", return ()
 end

meta def rpo_snd_core : tactic unit := do
  repeat (`[rw Map.find_val at *]),
  clear_goal_of_rewrites,
  xs ← local_context >>= collect_assertions,
  l ← xs.mmap infer_type >>= GFSAUIHasd,
  let ls := xs.zip (l.map aiuhsfd),
  suihfa ls,
  clear_goal_of_rewrites,
  iterate `[rw if_neg at *],
  any_goals `[dec_trivial],
  `[rw nf_def at *, simp only [Map.find_val] at *],
  try (`[rw asdff, repeat {rw fsadfdsa}, rw ← asdff, repeat {split}]),
  return ()

meta def check_for_semantic_unfolding : expr → tactic unit
| `(_ ∈ AssertionLang.sem _) := do return ()
| _ := do try `[rw ← asdff]

meta def finish_conjunctions : tactic unit := do
 any_goals $ `[rw fsadfdsa],
 any_goals $ split,
 any_goals $ assumption,
 any_goals $ `[rw ← asdff], assumption,
 return ()

meta def new_tac_finisher (x : name) (Γ : model_info) : tactic unit := do
  synchronize_ports x Γ,
  `[rw asdff],
  try_terminal_rws,
  -- finish_conjunctions,
  -- `[rw fsadfdsa],
    -- split, -- copied from above
    -- assumption,rw ← asdff,assumption],
  return ()

meta def solve_rpo_snd_new (Γ : model_info) : tactic unit := do
  S ← tactic.get_unused_name `S,
  H ← tactic.get_unused_name `H,
  x ← tactic.get_unused_name `x,
  tactic.intro S, tactic.intro H, tactic.intro x,
  `[simp at *],
  make_cases H,
  all_goals $ decompose_fst_hyp Γ,
  all_goals $ rpo_snd_core,
  all_goals $ try $ `[rw ← asdff],
  all_goals (do x_e ← get_local x,synchronize_ports x Γ),
  all_goals $ `[rw asdff],
  all_goals $ local_context >>= try_application,
  any_goals `[dec_trivial],
  any_goals $ try_terminal_rws,
  all_goals $ try (check_for_portation'),
  all_goals $ local_context >>= try_application,
  any_goals $ `[dec_trivial],
  all_goals $ new_tac_finisher x Γ,
  all_goals $ (do `[rw fsadfdsa, split], assumption <|> `[rw ← asdff], assumption),
  return ()


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

Notation for operators defined at Prelude.lean
-/
prelude
import Init.NotationExtra

namespace Lean.Parser.Tactic.Conv

/-- `conv` is the syntax category for a "conv tactic", where "conv" is short
for conversion. A conv tactic is a program which receives a target, printed as
`| a`, and is tasked with coming up with some term `b` and a proof of `a = b`.
It is mainly used for doing targeted term transformations, for example rewriting
only on the left side of an equality. -/
declare_syntax_cat conv (behavior := both)

syntax convSeq1Indented := sepBy1IndentSemicolon(conv)
syntax convSeqBracketed := "{" withoutPosition(sepByIndentSemicolon(conv)) "}"
-- Order is important: a missing `conv` proof should not be parsed as `{ <missing> }`,
-- automatically closing goals
syntax convSeq := convSeqBracketed <|> convSeq1Indented

/-- The `*` occurrence list means to apply to all occurrences of the pattern. -/
syntax occsWildcard := "*"

/--
A list `1 2 4` of occurrences means to apply to the first, second, and fourth
occurrence of the pattern.
-/
syntax occsIndexed := num+

/-- An occurrence specification, either `*` or a list of numbers. The default is `[1]`. -/
syntax occs := atomic("(" &"occs") " := " (occsWildcard <|> occsIndexed) ") "

/--
`with_annotate_state stx t` annotates the lexical range of `stx : Syntax` with
the initial and final state of running tactic `t`.
-/
scoped syntax (name := withAnnotateState)
  "with_annotate_state " rawStx ppSpace conv : conv

/-- `skip` does nothing. -/
syntax (name := skip) "skip" : conv

/-- Traverses into the left subterm of a binary operator.
(In general, for an `n`-ary operator, it traverses into the second to last argument.) -/
syntax (name := lhs) "lhs" : conv

/-- Traverses into the right subterm of a binary operator.
(In general, for an `n`-ary operator, it traverses into the last argument.) -/
syntax (name := rhs) "rhs" : conv

/-- Reduces the target to Weak Head Normal Form. This reduces definitions
in "head position" until a constructor is exposed. For example, `List.map f [a, b, c]`
weak head normalizes to `f a :: List.map f [b, c]`. -/
syntax (name := whnf) "whnf" : conv

/-- Expands let-declarations and let-variables. -/
syntax (name := zeta) "zeta" : conv

/-- Puts term in normal form, this tactic is meant for debugging purposes only. -/
syntax (name := reduce) "reduce" : conv

/-- Performs one step of "congruence", which takes a term and produces
subgoals for all the function arguments. For example, if the target is `f x y` then
`congr` produces two subgoals, one for `x` and one for `y`. -/
syntax (name := congr) "congr" : conv

/--
* `arg i` traverses into the `i`'th argument of the target. For example if the
  target is `f a b c d` then `arg 1` traverses to `a` and `arg 3` traverses to `c`.
* `arg @i` is the same as `arg i` but it counts all arguments instead of just the
  explicit arguments. -/
syntax (name := arg) "arg " "@"? num : conv

/-- `ext x` traverses into a binder (a `fun x => e` or `∀ x, e` expression)
to target `e`, introducing name `x` in the process. -/
syntax (name := ext) "ext" (colGt ident)* : conv

/-- `change t'` replaces the target `t` with `t'`,
assuming `t` and `t'` are definitionally equal. -/
syntax (name := change) "change " term : conv

/-- `delta id1 id2 ...` unfolds all occurrences of `id1`, `id2`, ... in the target.
Like the `delta` tactic, this ignores any definitional equations and uses
primitive delta-reduction instead, which may result in leaking implementation details.
Users should prefer `unfold` for unfolding definitions. -/
syntax (name := delta) "delta " (colGt ident)+ : conv

/--
* `unfold foo` unfolds all occurrences of `foo` in the target.
* `unfold id1 id2 ...` is equivalent to `unfold id1; unfold id2; ...`.
Like the `unfold` tactic, this uses equational lemmas for the chosen definition
to rewrite the target. For recursive definitions,
only one layer of unfolding is performed. -/
syntax (name := unfold) "unfold " (colGt ident)+ : conv

/--
* `pattern pat` traverses to the first subterm of the target that matches `pat`.
* `pattern (occs := *) pat` traverses to every subterm of the target that matches `pat`
  which is not contained in another match of `pat`. It generates one subgoal for each matching
  subterm.
* `pattern (occs := 1 2 4) pat` matches occurrences `1, 2, 4` of `pat` and produces three subgoals.
  Occurrences are numbered left to right from the outside in.

Note that skipping an occurrence of `pat` will traverse inside that subexpression, which means
it may find more matches and this can affect the numbering of subsequent pattern matches.
For example, if we are searching for `f _` in `f (f a) = f b`:
* `occs := 1 2` (and `occs := *`) returns `| f (f a)` and `| f b`
* `occs := 2` returns `| f a`
* `occs := 2 3` returns `| f a` and `| f b`
* `occs := 1 3` is an error, because after skipping `f b` there is no third match.
-/
syntax (name := pattern) "pattern " (occs)? term : conv

/-- `rw [thm]` rewrites the target using `thm`. See the `rw` tactic for more information. -/
syntax (name := rewrite) "rewrite" (config)? rwRuleSeq : conv

/-- `simp [thm]` performs simplification using `thm` and marked `@[simp]` lemmas.
See the `simp` tactic for more information. -/
syntax (name := simp) "simp" (config)? (discharger)? (&" only")?
  (" [" withoutPosition((simpStar <|> simpErase <|> simpLemma),*) "]")? : conv

/--
`dsimp` is the definitional simplifier in `conv`-mode. It differs from `simp` in that it only
applies theorems that hold by reflexivity.

Examples:

```lean
example (a : Nat): (0 + 0) = a - a := by
  conv =>
    lhs
    dsimp
    rw [← Nat.sub_self a]
```
-/
syntax (name := dsimp) "dsimp " (config)? (discharger)? (&"only ")?
  ("[" withoutPosition((simpErase <|> simpLemma),*) "]")? : conv

/-- `simp_match` simplifies match expressions. For example,
```
match [a, b] with
| [] => 0
| hd :: tl => hd
```
simplifies to `a`. -/
syntax (name := simpMatch) "simp_match" : conv

/-- Executes the given tactic block without converting `conv` goal into a regular goal. -/
syntax (name := nestedTacticCore) "tactic'" " => " tacticSeq : conv

/-- Focuses, converts the `conv` goal `⊢ lhs` into a regular goal `⊢ lhs = rhs`, and then executes the given tactic block. -/
syntax (name := nestedTactic) "tactic" " => " tacticSeq : conv

/-- Executes the given conv block without converting regular goal into a `conv` goal. -/
syntax (name := convTactic) "conv'" " => " convSeq : tactic

/-- `{ convs }` runs the list of `convs` on the current target, and any subgoals that
remain are trivially closed by `skip`. -/
syntax (name := nestedConv) convSeqBracketed : conv

/-- `(convs)` runs the `convs` in sequence on the current list of targets.
This is pure grouping with no added effects. -/
syntax (name := paren) "(" withoutPosition(convSeq) ")" : conv

/-- `rfl` closes one conv goal "trivially", by using reflexivity
(that is, no rewriting). -/
macro "rfl" : conv => `(conv| tactic => rfl)

/-- `done` succeeds iff there are no goals remaining. -/
macro "done" : conv => `(conv| tactic' => done)

/-- `trace_state` prints the current goal state. -/
macro "trace_state" : conv => `(conv| tactic' => trace_state)

/-- `all_goals tac` runs `tac` on each goal, concatenating the resulting goals, if any. -/
macro (name := allGoals) tk:"all_goals " s:convSeq : conv =>
  `(conv| tactic' => all_goals%$tk conv' => $s)

/--
`any_goals tac` applies the tactic `tac` to every goal, and succeeds if at
least one application succeeds.
-/
macro (name := anyGoals) tk:"any_goals " s:convSeq : conv =>
  `(conv| tactic' => any_goals%$tk conv' => $s)

/--
* `case tag => tac` focuses on the goal with case name `tag` and solves it using `tac`,
  or else fails.
* `case tag x₁ ... xₙ => tac` additionally renames the `n` most recent hypotheses
  with inaccessible names to the given names.
* `case tag₁ | tag₂ => tac` is equivalent to `(case tag₁ => tac); (case tag₂ => tac)`.
-/
macro (name := case) tk:"case " args:sepBy1(caseArg, " | ") arr:" => " s:convSeq : conv =>
  `(conv| tactic' => case%$tk $args|* =>%$arr conv' => ($s); all_goals rfl)

/--
`case'` is similar to the `case tag => tac` tactic, but does not ensure the goal
has been solved after applying `tac`, nor admits the goal if `tac` failed.
Recall that `case` closes the goal using `sorry` when `tac` fails, and
the tactic execution is not interrupted.
-/
macro (name := case') tk:"case' " args:sepBy1(caseArg, " | ") arr:" => " s:convSeq : conv =>
  `(conv| tactic' => case'%$tk $args|* =>%$arr conv' => $s)

/--
`next => tac` focuses on the next goal and solves it using `tac`, or else fails.
`next x₁ ... xₙ => tac` additionally renames the `n` most recent hypotheses with
inaccessible names to the given names.
-/
macro "next " args:binderIdent* " => " tac:convSeq : conv => `(conv| case _ $args* => $tac)

/--
`focus tac` focuses on the main goal, suppressing all other goals, and runs `tac` on it.
Usually `· tac`, which enforces that the goal is closed by `tac`, should be preferred.
-/
macro (name := focus) tk:"focus " s:convSeq : conv => `(conv| tactic' => focus%$tk conv' => $s)

/-- `conv => cs` runs `cs` in sequence on the target `t`,
resulting in `t'`, which becomes the new target subgoal. -/
syntax (name := convConvSeq) "conv" " => " convSeq : conv

/-- `· conv` focuses on the main conv goal and tries to solve it using `s`. -/
macro dot:patternIgnore("·" <|> ".") s:convSeq : conv => `(conv| {%$dot ($s) })

/-- `fail_if_success t` fails if the tactic `t` succeeds. -/
macro (name := failIfSuccess) tk:"fail_if_success " s:convSeq : conv =>
  `(conv| tactic' => fail_if_success%$tk conv' => $s)

/-- `rw [rules]` applies the given list of rewrite rules to the target.
See the `rw` tactic for more information. -/
macro "rw" c:(config)? s:rwRuleSeq : conv => `(conv| rewrite $[$c]? $s)

/-- `erw [rules]` is a shorthand for `rw (config := { transparency := .default }) [rules]`.
This does rewriting up to unfolding of regular definitions (by comparison to regular `rw`
which only unfolds `@[reducible]` definitions). -/
macro "erw" s:rwRuleSeq : conv => `(conv| rw (config := { transparency := .default }) $s)

/-- `args` traverses into all arguments. Synonym for `congr`. -/
macro "args" : conv => `(conv| congr)
/-- `left` traverses into the left argument. Synonym for `lhs`. -/
macro "left" : conv => `(conv| lhs)
/-- `right` traverses into the right argument. Synonym for `rhs`. -/
macro "right" : conv => `(conv| rhs)
/-- `intro` traverses into binders. Synonym for `ext`. -/
macro "intro" xs:(colGt ident)* : conv => `(conv| ext $xs*)

syntax enterArg := ident <|> ("@"? num)

/-- `enter [arg, ...]` is a compact way to describe a path to a subterm.
It is a shorthand for other conv tactics as follows:
* `enter [i]` is equivalent to `arg i`.
* `enter [@i]` is equivalent to `arg @i`.
* `enter [x]` (where `x` is an identifier) is equivalent to `ext x`.
For example, given the target `f (g a (fun x => x b))`, `enter [1, 2, x, 1]`
will traverse to the subterm `b`. -/
syntax "enter" " [" (colGt enterArg),+ "]": conv
macro_rules
  | `(conv| enter [$i:num]) => `(conv| arg $i)
  | `(conv| enter [@$i]) => `(conv| arg @$i)
  | `(conv| enter [$id:ident]) => `(conv| ext $id)
  | `(conv| enter [$arg, $args,*]) => `(conv| (enter [$arg]; enter [$args,*]))

/-- The `apply thm` conv tactic is the same as `apply thm` the tactic.
There are no restrictions on `thm`, but strange results may occur if `thm`
cannot be reasonably interpreted as proving one equality from a list of others. -/
-- TODO: error if non-conv subgoals?
macro "apply " e:term : conv => `(conv| tactic => apply $e)

/-- `first | conv | ...` runs each `conv` until one succeeds, or else fails. -/
syntax (name := first) "first " withPosition((colGe "|" convSeq)+) : conv

/-- `try tac` runs `tac` and succeeds even if `tac` failed. -/
macro "try " t:convSeq : conv => `(conv| first | $t | skip)

macro:1 x:conv tk:" <;> " y:conv:0 : conv =>
  `(conv| tactic' => (conv' => $x:conv) <;>%$tk (conv' => $y:conv))

/-- `repeat convs` runs the sequence `convs` repeatedly until it fails to apply. -/
syntax "repeat" convSeq : conv
macro_rules
  | `(conv| repeat $seq) => `(conv| first | ($seq); repeat $seq | rfl)

/--
`conv => ...` allows the user to perform targeted rewriting on a goal or hypothesis,
by focusing on particular subexpressions.

See <https://leanprover.github.io/theorem_proving_in_lean4/conv.html> for more details.

Basic forms:
* `conv => cs` will rewrite the goal with conv tactics `cs`.
* `conv at h => cs` will rewrite hypothesis `h`.
* `conv in pat => cs` will rewrite the first subexpression matching `pat` (see `pattern`).
-/
-- HACK: put this at the end so that references to `conv` above
-- refer to the syntax category instead of this syntax
syntax (name := conv) "conv " (" at " ident)? (" in " (occs)? term)? " => " convSeq : tactic

end Lean.Parser.Tactic.Conv