/-
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.Structure
import Lean.Util.Recognizers
import Lean.Meta.GetConst
import Lean.Meta.FunInfo
import Lean.Meta.Match.MatcherInfo
import Lean.Meta.Match.MatchPatternAttr

namespace Lean.Meta

-- ===========================
/-! # Smart unfolding support -/
-- ===========================

/--
Forward declaration. It is defined in the module `src/Lean/Elab/PreDefinition/Structural/Eqns.lean`.
It is possible to avoid this hack if we move `Structural.EqnInfo` and `Structural.eqnInfoExt`
to this module.
-/
@[extern "lean_get_structural_rec_arg_pos"]
opaque getStructuralRecArgPos? (declName : Name) : CoreM (Option Nat)

def smartUnfoldingSuffix := "_sunfold"

@[inline] def mkSmartUnfoldingNameFor (declName : Name) : Name :=
  Name.mkStr declName smartUnfoldingSuffix

def hasSmartUnfoldingDecl (env : Environment) (declName : Name) : Bool :=
  env.contains (mkSmartUnfoldingNameFor declName)

register_builtin_option smartUnfolding : Bool := {
  defValue := true
  descr := "when computing weak head normal form, use auxiliary definition created for functions defined by structural recursion"
}

/-- Add auxiliary annotation to indicate the `match`-expression `e` must be reduced when performing smart unfolding. -/
def markSmartUnfoldingMatch (e : Expr) : Expr :=
  mkAnnotation `sunfoldMatch e

def smartUnfoldingMatch? (e : Expr) : Option Expr :=
  annotation? `sunfoldMatch e

/-- Add auxiliary annotation to indicate expression `e` (a `match` alternative rhs) was successfully reduced by smart unfolding. -/
def markSmartUnfoldingMatchAlt (e : Expr) : Expr :=
  mkAnnotation `sunfoldMatchAlt e

def smartUnfoldingMatchAlt? (e : Expr) : Option Expr :=
  annotation? `sunfoldMatchAlt e

-- ===========================
/-! # Helper methods -/
-- ===========================

def isAuxDef (constName : Name) : MetaM Bool := do
  let env ← getEnv
  return isAuxRecursor env constName || isNoConfusion env constName

@[inline] private def matchConstAux {α} (e : Expr) (failK : Unit → MetaM α) (k : ConstantInfo → List Level → MetaM α) : MetaM α :=
  match e with
  | Expr.const name lvls => do
    let (some cinfo) ← getConst? name | failK ()
    k cinfo lvls
  | _ => failK ()

-- ===========================
/-! # Helper functions for reducing recursors -/
-- ===========================

private def getFirstCtor (d : Name) : MetaM (Option Name) := do
  let some (ConstantInfo.inductInfo { ctors := ctor::_, ..}) ← getConstNoEx? d | pure none
  return some ctor

private def mkNullaryCtor (type : Expr) (nparams : Nat) : MetaM (Option Expr) := do
  match type.getAppFn with
  | Expr.const d lvls =>
    let (some ctor) ← getFirstCtor d | pure none
    return mkAppN (mkConst ctor lvls) (type.getAppArgs.shrink nparams)
  | _ =>
    return none

private def getRecRuleFor (recVal : RecursorVal) (major : Expr) : Option RecursorRule :=
  match major.getAppFn with
  | Expr.const fn _ => recVal.rules.find? fun r => r.ctor == fn
  | _               => none

private def toCtorWhenK (recVal : RecursorVal) (major : Expr) : MetaM Expr := do
  let majorType ← inferType major
  let majorType ← instantiateMVars (← whnf majorType)
  let majorTypeI := majorType.getAppFn
  if !majorTypeI.isConstOf recVal.getInduct then
    return major
  else if majorType.hasExprMVar && majorType.getAppArgs[recVal.numParams:].any Expr.hasExprMVar then
    return major
  else do
    let (some newCtorApp) ← mkNullaryCtor majorType recVal.numParams | pure major
    let newType ← inferType newCtorApp
    /- TODO: check whether changing reducibility to default hurts performance here.
       We do that to make sure auxiliary `Eq.rec` introduced by the `match`-compiler
       are reduced even when `TransparencyMode.reducible` (like in `simp`).

       We use `withNewMCtxDepth` to make sure metavariables at `majorType` are not assigned.
       For example, given `major : Eq ?x y`, we don't want to apply K by assigning `?x := y`.
    -/
    if (← withAtLeastTransparency TransparencyMode.default <| withNewMCtxDepth <| isDefEq majorType newType) then
      return newCtorApp
    else
      return major

/--
  Create the `i`th projection `major`. It tries to use the auto-generated projection functions if available. Otherwise falls back
  to `Expr.proj`.
-/
def mkProjFn (ctorVal : ConstructorVal) (us : List Level) (params : Array Expr) (i : Nat) (major : Expr) : CoreM Expr := do
  match getStructureInfo? (← getEnv) ctorVal.induct with
  | none => return mkProj ctorVal.induct i major
  | some info => match info.getProjFn? i with
    | none => return mkProj ctorVal.induct i major
    | some projFn => return mkApp (mkAppN (mkConst projFn us) params) major

/--
  If `major` is not a constructor application, and its type is a structure `C ...`, then return `C.mk major.1 ... major.n`

  \pre `inductName` is `C`.

  If `Meta.Config.etaStruct` is `false` or the condition above does not hold, this method just returns `major`. -/
private def toCtorWhenStructure (inductName : Name) (major : Expr) : MetaM Expr := do
  unless (← useEtaStruct inductName) do
    return major
  let env ← getEnv
  if !isStructureLike env inductName then
    return major
  else if let some _ := major.isConstructorApp? env then
    return major
  else
    let majorType ← inferType major
    let majorType ← instantiateMVars (← whnf majorType)
    let majorTypeI := majorType.getAppFn
    if !majorTypeI.isConstOf inductName then
      return major
    match majorType.getAppFn with
    | Expr.const d us =>
      if (← whnfD (← inferType majorType)) == mkSort levelZero then
        return major -- We do not perform eta for propositions, see implementation in the kernel
      else
        let some ctorName ← getFirstCtor d | pure major
        let ctorInfo ← getConstInfoCtor ctorName
        let params := majorType.getAppArgs.shrink ctorInfo.numParams
        let mut result := mkAppN (mkConst ctorName us) params
        for i in [:ctorInfo.numFields] do
          result := mkApp result (← mkProjFn ctorInfo us params i major)
        return result
    | _ => return major

/-- Auxiliary function for reducing recursor applications. -/
private def reduceRec (recVal : RecursorVal) (recLvls : List Level) (recArgs : Array Expr) (failK : Unit → MetaM α) (successK : Expr → MetaM α) : MetaM α :=
  let majorIdx := recVal.getMajorIdx
  if h : majorIdx < recArgs.size then do
    let major := recArgs.get ⟨majorIdx, h⟩
    let mut major ← whnf major
    if recVal.k then
      major ← toCtorWhenK recVal major
    major := major.toCtorIfLit
    major ← toCtorWhenStructure recVal.getInduct major
    match getRecRuleFor recVal major with
    | some rule =>
      let majorArgs := major.getAppArgs
      if recLvls.length != recVal.levelParams.length then
        failK ()
      else
        let rhs := rule.rhs.instantiateLevelParams recVal.levelParams recLvls
        -- Apply parameters, motives and minor premises from recursor application.
        let rhs := mkAppRange rhs 0 (recVal.numParams+recVal.numMotives+recVal.numMinors) recArgs
        /- The number of parameters in the constructor is not necessarily
           equal to the number of parameters in the recursor when we have
           nested inductive types. -/
        let nparams := majorArgs.size - rule.nfields
        let rhs := mkAppRange rhs nparams majorArgs.size majorArgs
        let rhs := mkAppRange rhs (majorIdx + 1) recArgs.size recArgs
        successK rhs
    | none => failK ()
  else
    failK ()

-- ===========================
/-! # Helper functions for reducing Quot.lift and Quot.ind -/
-- ===========================

/-- Auxiliary function for reducing `Quot.lift` and `Quot.ind` applications. -/
private def reduceQuotRec (recVal  : QuotVal) (recLvls : List Level) (recArgs : Array Expr) (failK : Unit → MetaM α) (successK : Expr → MetaM α) : MetaM α :=
  let process (majorPos argPos : Nat) : MetaM α :=
    if h : majorPos < recArgs.size then do
      let major := recArgs.get ⟨majorPos, h⟩
      let major ← whnf major
      match major with
      | Expr.app (Expr.app (Expr.app (Expr.const majorFn _) _) _) majorArg => do
        let some (ConstantInfo.quotInfo { kind := QuotKind.ctor, .. }) ← getConstNoEx? majorFn | failK ()
        let f := recArgs[argPos]!
        let r := mkApp f majorArg
        let recArity := majorPos + 1
        successK <| mkAppRange r recArity recArgs.size recArgs
      | _ => failK ()
    else
      failK ()
  match recVal.kind with
  | QuotKind.lift => process 5 3
  | QuotKind.ind  => process 4 3
  | _             => failK ()

-- ===========================
/-! # Helper function for extracting "stuck term" -/
-- ===========================

mutual
  private partial def isRecStuck? (recVal : RecursorVal) (recArgs : Array Expr) : MetaM (Option MVarId) :=
    if recVal.k then
      -- TODO: improve this case
      return none
    else do
      let majorIdx := recVal.getMajorIdx
      if h : majorIdx < recArgs.size then do
        let major := recArgs.get ⟨majorIdx, h⟩
        let major ← whnf major
        getStuckMVar? major
      else
        return none

  private partial def isQuotRecStuck? (recVal : QuotVal) (recArgs : Array Expr) : MetaM (Option MVarId) :=
    let process? (majorPos : Nat) : MetaM (Option MVarId) :=
      if h : majorPos < recArgs.size then do
        let major := recArgs.get ⟨majorPos, h⟩
        let major ← whnf major
        getStuckMVar? major
      else
        return none
    match recVal.kind with
    | QuotKind.lift => process? 5
    | QuotKind.ind  => process? 4
    | _             => return none

  /-- Return `some (Expr.mvar mvarId)` if metavariable `mvarId` is blocking reduction. -/
  partial def getStuckMVar? (e : Expr) : MetaM (Option MVarId) := do
    match e with
    | .mdata _ e  => getStuckMVar? e
    | .proj _ _ e => getStuckMVar? (← whnf e)
    | .mvar .. =>
      let e ← instantiateMVars e
      match e with
      | .mvar mvarId => return some mvarId
      | _ => getStuckMVar? e
    | .app f .. =>
      let f := f.getAppFn
      match f with
      | .mvar .. =>
        let e ← instantiateMVars e
        match e.getAppFn with
        | .mvar mvarId => return some mvarId
        | _ => getStuckMVar? e
      | .const fName _ =>
        match (← getConstNoEx? fName) with
        | some <| .recInfo recVal  => isRecStuck? recVal e.getAppArgs
        | some <| .quotInfo recVal => isQuotRecStuck? recVal e.getAppArgs
        | _  =>
          unless e.hasExprMVar do return none
          -- Projection function support
          let some projInfo ← getProjectionFnInfo? fName | return none
          -- This branch is relevant if `e` is a type class projection that is stuck because the instance has not been synthesized yet.
          unless projInfo.fromClass do return none
          let args := e.getAppArgs
          -- First check whether `e`s instance is stuck.
          if let some major := args.get? projInfo.numParams then
            if let some mvarId ← getStuckMVar? major then
              return mvarId
          /-
          Then, recurse on the explicit arguments
          We want to detect the stuck instance in terms such as
          `HAdd.hAdd Nat Nat Nat (instHAdd Nat instAddNat) n (OfNat.ofNat Nat 2 ?m)`
          See issue https://github.com/leanprover/lean4/issues/1408 for an example where this is needed.
          -/
          let info ← getFunInfo f
          for pinfo in info.paramInfo, arg in args do
            if pinfo.isExplicit then
              if let some mvarId ← getStuckMVar? arg then
                return some mvarId
          return none
      | .proj _ _ e => getStuckMVar? (← whnf e)
      | _ => return none
    | _ => return none
end

-- ===========================
/-! # Weak Head Normal Form auxiliary combinators -/
-- ===========================

/-- Auxiliary combinator for handling easy WHNF cases. It takes a function for handling the "hard" cases as an argument -/
@[specialize] partial def whnfEasyCases (e : Expr) (k : Expr → MetaM Expr) : MetaM Expr := do
  match e with
  | .forallE ..    => return e
  | .lam ..        => return e
  | .sort ..       => return e
  | .lit ..        => return e
  | .bvar ..       => unreachable!
  | .letE ..       => k e
  | .const ..      => k e
  | .app ..        => k e
  | .proj ..       => k e
  | .mdata _ e     => whnfEasyCases e k
  | .fvar fvarId   =>
    let decl ← fvarId.getDecl
    match decl with
    | .cdecl .. => return e
    | .ldecl (value := v) (nonDep := nonDep) .. =>
      let cfg ← getConfig
      if nonDep && !cfg.zetaNonDep then
        return e
      else
        if cfg.trackZeta then
          modify fun s => { s with zetaFVarIds := s.zetaFVarIds.insert fvarId }
        whnfEasyCases v k
  | .mvar mvarId   =>
    match (← getExprMVarAssignment? mvarId) with
    | some v => whnfEasyCases v k
    | none   => return e

@[specialize] private def deltaDefinition (c : ConstantInfo) (lvls : List Level)
    (failK : Unit → MetaM α) (successK : Expr → MetaM α) : MetaM α := do
  if c.levelParams.length != lvls.length then
    failK ()
  else
    successK (← instantiateValueLevelParams c lvls)

@[specialize] private def deltaBetaDefinition (c : ConstantInfo) (lvls : List Level) (revArgs : Array Expr)
    (failK : Unit → MetaM α) (successK : Expr → MetaM α) (preserveMData := false) : MetaM α := do
  if c.levelParams.length != lvls.length then
    failK ()
  else
    let val ← instantiateValueLevelParams c lvls
    let val := val.betaRev revArgs (preserveMData := preserveMData)
    successK val

inductive ReduceMatcherResult where
  | reduced (val : Expr)
  | stuck   (val : Expr)
  | notMatcher
  | partialApp

/--
  The "match" compiler uses `if-then-else` expressions and other auxiliary declarations to compile match-expressions such as
  ```
  match v with
  | 'a' => 1
  | 'b' => 2
  | _   => 3
  ```
  because it is more efficient than using `casesOn` recursors.
  The method `reduceMatcher?` fails if these auxiliary definitions (e.g., `ite`) cannot be unfolded in the current
  transparency setting. This is problematic because tactics such as `simp` use `TransparencyMode.reducible`, and
  most users assume that expressions such as
  ```
  match 0 with
  | 0 => 1
  | 100 => 2
  | _ => 3
  ```
  should reduce in any transparency mode.
  Thus, we define a custom `canUnfoldAtMatcher` predicate for `whnfMatcher`.

  This solution is not very modular because modications at the `match` compiler require changes here.
  We claim this is defensible because it is reducing the auxiliary declaration defined by the `match` compiler.

  Alternative solution: tactics that use `TransparencyMode.reducible` should rely on the equations we generated for match-expressions.
  This solution is also not perfect because the match-expression above will not reduce during type checking when we are not using
  `TransparencyMode.default` or `TransparencyMode.all`.
-/
def canUnfoldAtMatcher (cfg : Config) (info : ConstantInfo) : CoreM Bool := do
  match cfg.transparency with
  | TransparencyMode.all     => return true
  | TransparencyMode.default => return true
  | _ =>
    if (← isReducible info.name) || isGlobalInstance (← getEnv) info.name then
      return true
    else if hasMatchPatternAttribute (← getEnv) info.name then
      return true
    else
      return info.name == ``ite
       || info.name == ``dite
       || info.name == ``decEq
       || info.name == ``Nat.decEq
       || info.name == ``Char.ofNat   || info.name == ``Char.ofNatAux
       || info.name == ``String.decEq || info.name == ``List.hasDecEq
       || info.name == ``Fin.ofNat
       || info.name == ``UInt8.ofNat  || info.name == ``UInt8.decEq
       || info.name == ``UInt16.ofNat || info.name == ``UInt16.decEq
       || info.name == ``UInt32.ofNat || info.name == ``UInt32.decEq
       || info.name == ``UInt64.ofNat || info.name == ``UInt64.decEq
       /- Remark: we need to unfold the following two definitions because they are used for `Fin`, and
          lazy unfolding at `isDefEq` does not unfold projections.  -/
       || info.name == ``HMod.hMod || info.name == ``Mod.mod

private def whnfMatcher (e : Expr) : MetaM Expr := do
  /- When reducing `match` expressions, if the reducibility setting is at `TransparencyMode.reducible`,
     we increase it to `TransparencyMode.instance`. We use the `TransparencyMode.reducible` in many places (e.g., `simp`),
     and this setting prevents us from reducing `match` expressions where the discriminants are terms such as `OfNat.ofNat α n inst`.
     For example, `simp [Int.div]` will not unfold the application `Int.div 2 1` occuring in the target.

     TODO: consider other solutions; investigate whether the solution above produces counterintuitive behavior.  -/
  let mut transparency ← getTransparency
  if transparency == TransparencyMode.reducible then
    transparency := TransparencyMode.instances
  withTransparency transparency <| withReader (fun ctx => { ctx with canUnfold? := canUnfoldAtMatcher }) do
    whnf e

def reduceMatcher? (e : Expr) : MetaM ReduceMatcherResult := do
  match e.getAppFn with
  | Expr.const declName declLevels =>
    let some info ← getMatcherInfo? declName
      | return ReduceMatcherResult.notMatcher
    let args := e.getAppArgs
    let prefixSz := info.numParams + 1 + info.numDiscrs
    if args.size < prefixSz + info.numAlts then
      return ReduceMatcherResult.partialApp
    else
      let constInfo ← getConstInfo declName
      let f ← instantiateValueLevelParams constInfo declLevels
      let auxApp := mkAppN f args[0:prefixSz]
      let auxAppType ← inferType auxApp
      forallBoundedTelescope auxAppType info.numAlts fun hs _ => do
        let auxApp ← whnfMatcher (mkAppN auxApp hs)
        let auxAppFn := auxApp.getAppFn
        let mut i := prefixSz
        for h in hs do
          if auxAppFn == h then
            let result := mkAppN args[i]! auxApp.getAppArgs
            let result := mkAppN result args[prefixSz + info.numAlts:args.size]
            return ReduceMatcherResult.reduced result.headBeta
          i := i + 1
        return ReduceMatcherResult.stuck auxApp
  | _ => pure ReduceMatcherResult.notMatcher

private def projectCore? (e : Expr) (i : Nat) : MetaM (Option Expr) := do
  let e := e.toCtorIfLit
  matchConstCtor e.getAppFn (fun _ => pure none) fun ctorVal _ =>
    let numArgs := e.getAppNumArgs
    let idx := ctorVal.numParams + i
    if idx < numArgs then
      return some (e.getArg! idx)
    else
      return none

def project? (e : Expr) (i : Nat) : MetaM (Option Expr) := do
  projectCore? (← whnf e) i

/-- Reduce kernel projection `Expr.proj ..` expression. -/
def reduceProj? (e : Expr) : MetaM (Option Expr) := do
  match e with
  | Expr.proj _ i c => project? c i
  | _               => return none

/--
  Auxiliary method for reducing terms of the form `?m t_1 ... t_n` where `?m` is delayed assigned.
  Recall that we can only expand a delayed assignment when all holes/metavariables in the assigned value have been "filled".
-/
private def whnfDelayedAssigned? (f' : Expr) (e : Expr) : MetaM (Option Expr) := do
  if f'.isMVar then
    match (← getDelayedMVarAssignment? f'.mvarId!) with
    | none => return none
    | some { fvars, mvarIdPending } =>
      let args := e.getAppArgs
      if fvars.size > args.size then
        -- Insufficient number of argument to expand delayed assignment
        return none
      else
        let newVal ← instantiateMVars (mkMVar mvarIdPending)
        if newVal.hasExprMVar then
           -- Delayed assignment still contains metavariables
           return none
        else
           let newVal := newVal.abstract fvars
           let result := newVal.instantiateRevRange 0 fvars.size args
           return mkAppRange result fvars.size args.size args
  else
    return none

/--
Apply beta-reduction, zeta-reduction (i.e., unfold let local-decls), iota-reduction,
expand let-expressions, expand assigned meta-variables.

The parameter `deltaAtProj` controls how to reduce projections `s.i`. If `deltaAtProj == true`,
then delta reduction is used to reduce `s` (i.e., `whnf` is used), otherwise `whnfCore`.

If `simpleReduceOnly`, then `iota` and projection reduction are not performed.
Note that the value of `deltaAtProj` is irrelevant if `simpleReduceOnly = true`.
-/
partial def whnfCore (e : Expr) (deltaAtProj : Bool := true) (simpleReduceOnly := false) : MetaM Expr :=
  go e
where
  go (e : Expr) : MetaM Expr :=
    whnfEasyCases e fun e => do
      trace[Meta.whnf] e
      match e with
      | Expr.const ..  => pure e
      | Expr.letE _ _ v b _ => go <| b.instantiate1 v
      | Expr.app f ..       =>
        let f := f.getAppFn
        let f' ← go f
        if f'.isLambda then
          let revArgs := e.getAppRevArgs
          go <| f'.betaRev revArgs
        else if let some eNew ← whnfDelayedAssigned? f' e then
          go eNew
        else
          let e := if f == f' then e else e.updateFn f'
          if simpleReduceOnly then
            return e
          else
            match (← reduceMatcher? e) with
            | ReduceMatcherResult.reduced eNew => go eNew
            | ReduceMatcherResult.partialApp   => pure e
            | ReduceMatcherResult.stuck _      => pure e
            | ReduceMatcherResult.notMatcher   =>
              matchConstAux f' (fun _ => return e) fun cinfo lvls =>
                match cinfo with
                | ConstantInfo.recInfo rec    => reduceRec rec lvls e.getAppArgs (fun _ => return e) go
                | ConstantInfo.quotInfo rec   => reduceQuotRec rec lvls e.getAppArgs (fun _ => return e) go
                | c@(ConstantInfo.defnInfo _) => do
                  if (← isAuxDef c.name) then
                    deltaBetaDefinition c lvls e.getAppRevArgs (fun _ => return e) go
                  else
                    return e
                | _ => return e
      | Expr.proj _ i c =>
        if simpleReduceOnly then
          return e
        else
          let c ← if deltaAtProj then whnf c else whnfCore c
          match (← projectCore? c i) with
          | some e => go e
          | none => return e
      | _ => unreachable!

/--
  Recall that `_sunfold` auxiliary definitions contains the markers: `markSmartUnfoldingMatch` (*) and `markSmartUnfoldingMatchAlt` (**).
  For example, consider the following definition
  ```
  def r (i j : Nat) : Nat :=
    i +
      match j with
      | Nat.zero => 1
      | Nat.succ j =>
        i + match j with
            | Nat.zero => 2
            | Nat.succ j => r i j
  ```
  produces the following `_sunfold` auxiliary definition with the markers
  ```
  def r._sunfold (i j : Nat) : Nat :=
    i +
      (*) match j with
      | Nat.zero => (**) 1
      | Nat.succ j =>
        i + (*) match j with
            | Nat.zero => (**) 2
            | Nat.succ j => (**) r i j
  ```

  `match` expressions marked with `markSmartUnfoldingMatch` (*) must be reduced, otherwise the resulting term is not definitionally
   equal to the given expression. The recursion may be interrupted as soon as the annotation `markSmartUnfoldingAlt` (**) is reached.

  For example, the term `r i j.succ.succ` reduces to the definitionally equal term `i + i * r i j`
-/
partial def smartUnfoldingReduce? (e : Expr) : MetaM (Option Expr) :=
  go e |>.run
where
  go (e : Expr) : OptionT MetaM Expr := do
    match e with
    | Expr.letE n t v b _ => withLetDecl n t (← go v) fun x => do mkLetFVars #[x] (← go (b.instantiate1 x))
    | Expr.lam .. => lambdaTelescope e fun xs b => do mkLambdaFVars xs (← go b)
    | Expr.app f a .. => return mkApp (← go f) (← go a)
    | Expr.proj _ _ s => return e.updateProj! (← go s)
    | Expr.mdata _ b  =>
      if let some m := smartUnfoldingMatch? e then
        goMatch m
      else
        return e.updateMData! (← go b)
    | _ => return e

  goMatch (e : Expr) : OptionT MetaM Expr := do
    match (← reduceMatcher? e) with
    | ReduceMatcherResult.reduced e =>
      if let some alt := smartUnfoldingMatchAlt? e then
        return alt
      else
        go e
    | ReduceMatcherResult.stuck e' =>
      let mvarId ← getStuckMVar? e'
      /- Try to "unstuck" by resolving pending TC problems -/
      if (← Meta.synthPending mvarId) then
        goMatch e
      else
        failure
    | _ => failure

mutual

  /--
    Auxiliary method for unfolding a class projection.
  -/
  partial def unfoldProjInst? (e : Expr) : MetaM (Option Expr) := do
    match e.getAppFn with
    | Expr.const declName .. =>
      match (← getProjectionFnInfo? declName) with
      | some { fromClass := true, .. } =>
        match (← withDefault <| unfoldDefinition? e) with
        | none   => return none
        | some e =>
          match (← withReducibleAndInstances <| reduceProj? e.getAppFn) with
          | none   => return none
          | some r => return mkAppN r e.getAppArgs |>.headBeta
      | _ => return none
    | _ => return none

  /--
    Auxiliary method for unfolding a class projection. when transparency is set to `TransparencyMode.instances`.
    Recall that class instance projections are not marked with `[reducible]` because we want them to be
    in "reducible canonical form".
  -/
  partial def unfoldProjInstWhenIntances? (e : Expr) : MetaM (Option Expr) := do
    if (← getTransparency) != TransparencyMode.instances then
      return none
    else
      unfoldProjInst? e

  /-- Unfold definition using "smart unfolding" if possible. -/
  partial def unfoldDefinition? (e : Expr) : MetaM (Option Expr) :=
    match e with
    | Expr.app f _ =>
      matchConstAux f.getAppFn (fun _ => unfoldProjInstWhenIntances? e) fun fInfo fLvls => do
        if fInfo.levelParams.length != fLvls.length then
          return none
        else
          let unfoldDefault (_ : Unit) : MetaM (Option Expr) :=
            if fInfo.hasValue then
              deltaBetaDefinition fInfo fLvls e.getAppRevArgs (fun _ => pure none) (fun e => pure (some e))
            else
              return none
          if smartUnfolding.get (← getOptions) then
            match ((← getEnv).find? (mkSmartUnfoldingNameFor fInfo.name)) with
            | some fAuxInfo@(ConstantInfo.defnInfo _) =>
              -- We use `preserveMData := true` to make sure the smart unfolding annotation are not erased in an over-application.
              deltaBetaDefinition fAuxInfo fLvls e.getAppRevArgs (preserveMData := true) (fun _ => pure none) fun e₁ => do
                let some r ← smartUnfoldingReduce? e₁ | return none
                /-
                  If `smartUnfoldingReduce?` succeeds, we should still check whether the argument the
                  structural recursion is recursing on reduces to a constructor.
                  This extra check is necessary in definitions (see issue #1081) such as
                  ```
                  inductive Vector (α : Type u) : Nat → Type u where
                    | nil  : Vector α 0
                    | cons : α → Vector α n → Vector α (n+1)

                  def Vector.insert (a: α) (i : Fin (n+1)) (xs : Vector α n) : Vector α (n+1) :=
                    match i, xs with
                    | ⟨0,   _⟩,        xs => cons a xs
                    | ⟨i+1, h⟩, cons x xs => cons x (xs.insert a ⟨i, Nat.lt_of_succ_lt_succ h⟩)
                  ```
                  The structural recursion is being performed using the vector `xs`. That is, we used `Vector.brecOn` to define
                  `Vector.insert`. Thus, an application `xs.insert a ⟨0, h⟩` is **not** definitionally equal to
                  `Vector.cons a xs` because `xs` is not a constructor application (the `Vector.brecOn` application is blocked).

                  Remark 1: performing structural recursion on `Fin (n+1)` is not an option here because it is a `Subtype` and
                  and the repacking in recursive applications confuses the structural recursion module.

                  Remark 2: the match expression reduces reduces to `cons a xs` when the discriminants are `⟨0, h⟩` and `xs`.

                  Remark 3: this check is unnecessary in most cases, but we don't need dependent elimination to trigger the issue                        fixed by this extra check. Here is another example that triggers the issue fixed by this check.
                  ```
                  def f : Nat → Nat → Nat
                    | 0,   y   => y
                    | x+1, y+1 => f (x-2) y
                    | x+1, 0   => 0

                  theorem ex : f 0 y = y := rfl
                  ```

                  Remark 4: the `return some r` in the following `let` is not a typo. Binport generated .olean files do not
                  store the position of recursive arguments for definitions using structural recursion.
                  Thus, we should keep `return some r` until Mathlib has been ported to Lean 3.
                  Note that the `Vector` example above does not even work in Lean 3.
                -/
                let some recArgPos ← getStructuralRecArgPos? fInfo.name | return some r
                let numArgs := e.getAppNumArgs
                if recArgPos >= numArgs then return none
                let recArg := e.getArg! recArgPos numArgs
                if !(← whnfMatcher recArg).isConstructorApp (← getEnv) then return none
                return some r
            | _ =>
              if (← getMatcherInfo? fInfo.name).isSome then
                -- Recall that `whnfCore` tries to reduce "matcher" applications.
                return none
              else
                unfoldDefault ()
          else
            unfoldDefault ()
    | Expr.const declName lvls => do
      if smartUnfolding.get (← getOptions) && (← getEnv).contains (mkSmartUnfoldingNameFor declName) then
        return none
      else
        let (some (cinfo@(ConstantInfo.defnInfo _))) ← getConstNoEx? declName | pure none
        deltaDefinition cinfo lvls
          (fun _ => pure none)
          (fun e => pure (some e))
    | _ => return none
end

def unfoldDefinition (e : Expr) : MetaM Expr := do
  let some e ← unfoldDefinition? e | throwError "failed to unfold definition{indentExpr e}"
  return e

@[specialize] partial def whnfHeadPred (e : Expr) (pred : Expr → MetaM Bool) : MetaM Expr :=
  whnfEasyCases e fun e => do
    let e ← whnfCore e
    if (← pred e) then
        match (← unfoldDefinition? e) with
        | some e => whnfHeadPred e pred
        | none   => return e
    else
      return e

def whnfUntil (e : Expr) (declName : Name) : MetaM (Option Expr) := do
  let e ← whnfHeadPred e (fun e => return !e.isAppOf declName)
  if e.isAppOf declName then
    return e
  else
    return none

/-- Try to reduce matcher/recursor/quot applications. We say they are all "morally" recursor applications. -/
def reduceRecMatcher? (e : Expr) : MetaM (Option Expr) := do
  if !e.isApp then
    return none
  else match (← reduceMatcher? e) with
    | ReduceMatcherResult.reduced e => return e
    | _ => matchConstAux e.getAppFn (fun _ => pure none) fun cinfo lvls => do
      match cinfo with
      | ConstantInfo.recInfo «rec»  => reduceRec «rec» lvls e.getAppArgs (fun _ => pure none) (fun e => pure (some e))
      | ConstantInfo.quotInfo «rec» => reduceQuotRec «rec» lvls e.getAppArgs (fun _ => pure none) (fun e => pure (some e))
      | c@(ConstantInfo.defnInfo _) =>
        if (← isAuxDef c.name) then
          deltaBetaDefinition c lvls e.getAppRevArgs (fun _ => pure none) (fun e => pure (some e))
        else
          return none
      | _ => return none

unsafe def reduceBoolNativeUnsafe (constName : Name) : MetaM Bool := evalConstCheck Bool `Bool constName
unsafe def reduceNatNativeUnsafe (constName : Name) : MetaM Nat := evalConstCheck Nat `Nat constName
@[implemented_by reduceBoolNativeUnsafe] opaque reduceBoolNative (constName : Name) : MetaM Bool
@[implemented_by reduceNatNativeUnsafe] opaque reduceNatNative (constName : Name) : MetaM Nat

def reduceNative? (e : Expr) : MetaM (Option Expr) :=
  match e with
  | Expr.app (Expr.const fName _) (Expr.const argName _) =>
    if fName == ``Lean.reduceBool then do
      return toExpr (← reduceBoolNative argName)
    else if fName == ``Lean.reduceNat then do
      return toExpr (← reduceNatNative argName)
    else
      return none
  | _ =>
    return none

@[inline] def withNatValue {α} (a : Expr) (k : Nat → MetaM (Option α)) : MetaM (Option α) := do
  let a ← whnf a
  match a with
  | Expr.const `Nat.zero _      => k 0
  | Expr.lit (Literal.natVal v) => k v
  | _                           => return none

def reduceUnaryNatOp (f : Nat → Nat) (a : Expr) : MetaM (Option Expr) :=
  withNatValue a fun a =>
  return mkRawNatLit <| f a

def reduceBinNatOp (f : Nat → Nat → Nat) (a b : Expr) : MetaM (Option Expr) :=
  withNatValue a fun a =>
  withNatValue b fun b => do
  trace[Meta.isDefEq.whnf.reduceBinOp] "{a} op {b}"
  return mkRawNatLit <| f a b

def reduceBinNatPred (f : Nat → Nat → Bool) (a b : Expr) : MetaM (Option Expr) := do
  withNatValue a fun a =>
  withNatValue b fun b =>
  return toExpr <| f a b

def reduceNat? (e : Expr) : MetaM (Option Expr) :=
  if e.hasFVar || e.hasMVar then
    return none
  else match e with
    | Expr.app (Expr.const fn _) a                =>
      if fn == ``Nat.succ then
        reduceUnaryNatOp Nat.succ a
      else
        return none
    | Expr.app (Expr.app (Expr.const fn _) a1) a2 =>
      if fn == ``Nat.add then reduceBinNatOp Nat.add a1 a2
      else if fn == ``Nat.sub then reduceBinNatOp Nat.sub a1 a2
      else if fn == ``Nat.mul then reduceBinNatOp Nat.mul a1 a2
      else if fn == ``Nat.div then reduceBinNatOp Nat.div a1 a2
      else if fn == ``Nat.mod then reduceBinNatOp Nat.mod a1 a2
      else if fn == ``Nat.beq then reduceBinNatPred Nat.beq a1 a2
      else if fn == ``Nat.ble then reduceBinNatPred Nat.ble a1 a2
      else return none
    | _ =>
      return none

@[inline] private def useWHNFCache (e : Expr) : MetaM Bool := do
  -- We cache only closed terms without expr metavars.
  -- Potential refinement: cache if `e` is not stuck at a metavariable
  if e.hasFVar || e.hasExprMVar || (← read).canUnfold?.isSome then
    return false
  else
    match (← getConfig).transparency with
    | TransparencyMode.default => return true
    | TransparencyMode.all     => return true
    | _                        => return false

@[inline] private def cached? (useCache : Bool) (e : Expr) : MetaM (Option Expr) := do
  if useCache then
    match (← getConfig).transparency with
    | TransparencyMode.default => return (← get).cache.whnfDefault.find? e
    | TransparencyMode.all     => return (← get).cache.whnfAll.find? e
    | _                        => unreachable!
  else
    return none

private def cache (useCache : Bool) (e r : Expr) : MetaM Expr := do
  if useCache then
    match (← getConfig).transparency with
    | TransparencyMode.default => modify fun s => { s with cache.whnfDefault := s.cache.whnfDefault.insert e r }
    | TransparencyMode.all     => modify fun s => { s with cache.whnfAll     := s.cache.whnfAll.insert e r }
    | _                        => unreachable!
  return r

@[export lean_whnf]
partial def whnfImp (e : Expr) : MetaM Expr :=
  withIncRecDepth <| whnfEasyCases e fun e => do
    checkMaxHeartbeats "whnf"
    let useCache ← useWHNFCache e
    match (← cached? useCache e) with
    | some e' => pure e'
    | none    =>
      let e' ← whnfCore e
      match (← reduceNat? e') with
      | some v => cache useCache e v
      | none   =>
        match (← reduceNative? e') with
        | some v => cache useCache e v
        | none   =>
          match (← unfoldDefinition? e') with
          | some e => whnfImp e
          | none   => cache useCache e e'

/-- If `e` is a projection function that satisfies `p`, then reduce it -/
def reduceProjOf? (e : Expr) (p : Name → Bool) : MetaM (Option Expr) := do
  if !e.isApp then
    pure none
  else match e.getAppFn with
    | Expr.const name .. => do
      let env ← getEnv
      match env.getProjectionStructureName? name with
      | some structName =>
        if p structName then
          Meta.unfoldDefinition? e
        else
          pure none
      | none => pure none
    | _ => pure none

builtin_initialize
  registerTraceClass `Meta.whnf
  registerTraceClass `Meta.isDefEq.whnf.reduceBinOp

end Lean.Meta


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

/- Basic support for auto bound implicit local names -/

namespace Lean.Elab

register_builtin_option autoImplicit : Bool := {
    defValue := true
    descr    := "Unbound local variables in declaration headers become implicit arguments. In \"relaxed\" mode (default), any atomic identifier is eligible, otherwise only a lower case or greek letter followed by numeric digits are eligible. For example, `def f (x : Vector α n) : Vector α n :=` automatically introduces the implicit variables {α n}."
  }

register_builtin_option relaxedAutoImplicit : Bool := {
    defValue := true
    descr    := "When \"relaxed\" mode is enabled, any atomic nonempty identifier is eligible for auto bound implicit locals (see optin `autoBoundImplicitLocal`."
  }

private def isValidAutoBoundSuffix (s : String) : Bool :=
  s.toSubstring.drop 1 |>.all fun c => c.isDigit || isSubScriptAlnum c || c == '_' || c == '\''

/-
Remark: Issue #255 exposed a nasty interaction between macro scopes and auto-bound-implicit names.
```
local notation "A" => id x
theorem test : A = A := sorry
```
We used to use `n.eraseMacroScopes` at `isValidAutoBoundImplicitName` and `isValidAutoBoundLevelName`.
Thus, in the example above, when `A` is expanded, a `x` with a fresh macro scope is created.
`x`+macros-scope is not in scope and is a valid auto-bound implicit name after macro scopes are erased.
So, an auto-bound exception would be thrown, and `x`+macro-scope would be added as a new implicit.
When, we try again, a `x` with a new macro scope is created and this process keeps repeating.
Therefore, we do consider identifier with macro scopes anymore.
-/

def isValidAutoBoundImplicitName (n : Name) (relaxed : Bool) : Bool :=
  match n with
  | Name.str Name.anonymous s _ => s.length > 0 && (relaxed || ((isGreek s[0] || s[0].isLower) && isValidAutoBoundSuffix s))
  | _ => false

def isValidAutoBoundLevelName (n : Name) (relaxed : Bool) : Bool :=
  match n with
  | Name.str Name.anonymous s _ => s.length > 0 && (relaxed || (s[0].isLower && isValidAutoBoundSuffix s))
  | _ => false

end Lean.Elab


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

The writer monad transformer for passing immutable state.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.monad.basic
import Mathlib.algebra.group.basic
import Mathlib.PostPort

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

namespace Mathlib

structure writer_t (ω : Type u) (m : Type u → Type v) (α : Type u)
where
  run : m (α × ω)

def writer (ω : Type u) (α : Type u) :=
  writer_t ω id

namespace writer_t

protected theorem ext {ω : Type u} {m : Type u → Type v} [Monad m] {α : Type u} (x : writer_t ω m α) (x' : writer_t ω m α) (h : run x = run x') : x = x' := sorry

protected def tell {ω : Type u} {m : Type u → Type v} [Monad m] (w : ω) : writer_t ω m PUnit :=
  mk (pure (PUnit.unit, w))

protected def listen {ω : Type u} {m : Type u → Type v} [Monad m] {α : Type u} : writer_t ω m α → writer_t ω m (α × ω) :=
  sorry

protected def pass {ω : Type u} {m : Type u → Type v} [Monad m] {α : Type u} : writer_t ω m (α × (ω → ω)) → writer_t ω m α :=
  sorry

protected def pure {ω : Type u} {m : Type u → Type v} [Monad m] {α : Type u} [HasOne ω] (a : α) : writer_t ω m α :=
  mk (pure (a, 1))

protected def bind {ω : Type u} {m : Type u → Type v} [Monad m] {α : Type u} {β : Type u} [Mul ω] (x : writer_t ω m α) (f : α → writer_t ω m β) : writer_t ω m β :=
  mk
    (do
      let x ← run x
      let x' ← run (f (prod.fst x))
      pure (prod.fst x', prod.snd x * prod.snd x'))

protected instance monad {ω : Type u} {m : Type u → Type v} [Monad m] [HasOne ω] [Mul ω] : Monad (writer_t ω m) := sorry

protected instance is_lawful_monad {ω : Type u} {m : Type u → Type v} [Monad m] [monoid ω] [is_lawful_monad m] : is_lawful_monad (writer_t ω m) := sorry

protected def lift {ω : Type u} {m : Type u → Type v} [Monad m] {α : Type u} [HasOne ω] (a : m α) : writer_t ω m α :=
  mk (flip Prod.mk 1 <$> a)

protected instance has_monad_lift {ω : Type u} (m : Type u → Type u_1) [Monad m] [HasOne ω] : has_monad_lift m (writer_t ω m) :=
  has_monad_lift.mk fun (α : Type u) => writer_t.lift

protected def monad_map {ω : Type u} {m : Type u → Type u_1} {m' : Type u → Type u_2} [Monad m] [Monad m'] {α : Type u} (f : {α : Type u} → m α → m' α) : writer_t ω m α → writer_t ω m' α :=
  fun (x : writer_t ω m α) => mk (f (run x))

protected instance monad_functor {ω : Type u} (m : Type u → Type u_1) (m' : Type u → Type u_1) [Monad m] [Monad m'] : monad_functor m m' (writer_t ω m) (writer_t ω m') :=
  monad_functor.mk writer_t.monad_map

protected def adapt {ω : Type u} {m : Type u → Type v} [Monad m] {ω' : Type u} {α : Type u} (f : ω → ω') : writer_t ω m α → writer_t ω' m α :=
  fun (x : writer_t ω m α) => mk (prod.map id f <$> run x)

protected instance monad_except {ω : Type u} {m : Type u → Type v} [Monad m] (ε : outParam (Type u_1)) [HasOne ω] [Monad m] [monad_except ε m] : monad_except ε (writer_t ω m) :=
  monad_except.mk (fun (α : Type u) => writer_t.lift ∘ throw)
    fun (α : Type u) (x : writer_t ω m α) (c : ε → writer_t ω m α) => mk (catch (run x) fun (e : ε) => run (c e))

end writer_t

/--
An implementation of [MonadReader](
https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader-Class.html#t:MonadReader).
It does not contain `local` because this function cannot be lifted using `monad_lift`.
Instead, the `monad_reader_adapter` class provides the more general `adapt_reader` function.

Note: This class can be seen as a simplification of the more "principled" definition
```
class monad_reader (ρ : out_param (Type u)) (n : Type u → Type u) :=
(lift {α : Type u} : (∀ {m : Type u → Type u} [monad m], reader_t ρ m α) → n α)
```
-/
class monad_writer (ω : outParam (Type u)) (m : Type u → Type v)
where
  tell : ω → m PUnit
  listen : {α : Type u} → m α → m (α × ω)
  pass : {α : Type u} → m (α × (ω → ω)) → m α

protected instance writer_t.monad_writer {ω : Type u} {m : Type u → Type v} [Monad m] : monad_writer ω (writer_t ω m) :=
  monad_writer.mk writer_t.tell (fun (α : Type u) => writer_t.listen) fun (α : Type u) => writer_t.pass

protected instance reader_t.monad_writer {ω : Type u} {ρ : Type u} {m : Type u → Type v} [Monad m] [monad_writer ω m] : monad_writer ω (reader_t ρ m) :=
  monad_writer.mk (fun (x : ω) => monad_lift (monad_writer.tell x)) (fun (α : Type u) (_x : reader_t ρ m α) => sorry)
    fun (α : Type u) (_x : reader_t ρ m (α × (ω → ω))) => sorry

def swap_right {α : Type u_1} {β : Type u_2} {γ : Type u_3} : (α × β) × γ → (α × γ) × β :=
  sorry

protected instance state_t.monad_writer {ω : Type u} {σ : Type u} {m : Type u → Type v} [Monad m] [monad_writer ω m] : monad_writer ω (state_t σ m) :=
  monad_writer.mk (fun (x : ω) => monad_lift (monad_writer.tell x)) (fun (α : Type u) (_x : state_t σ m α) => sorry)
    fun (α : Type u) (_x : state_t σ m (α × (ω → ω))) => sorry

def except_t.pass_aux {ε : Type u_1} {α : Type u_2} {ω : Type u_3} : except ε (α × (ω → ω)) → except ε α × (ω → ω) :=
  sorry

protected instance except_t.monad_writer {ω : Type u} {ε : Type u} {m : Type u → Type v} [Monad m] [monad_writer ω m] : monad_writer ω (except_t ε m) :=
  monad_writer.mk (fun (x : ω) => monad_lift (monad_writer.tell x)) (fun (α : Type u) (_x : except_t ε m α) => sorry)
    fun (α : Type u) (_x : except_t ε m (α × (ω → ω))) => sorry

def option_t.pass_aux {α : Type u_1} {ω : Type u_2} : Option (α × (ω → ω)) → Option α × (ω → ω) :=
  sorry

protected instance option_t.monad_writer {ω : Type u} {m : Type u → Type v} [Monad m] [monad_writer ω m] : monad_writer ω (option_t m) :=
  monad_writer.mk (fun (x : ω) => monad_lift (monad_writer.tell x)) (fun (α : Type u) (_x : option_t m α) => sorry)
    fun (α : Type u) (_x : option_t m (α × (ω → ω))) => sorry

/-- Adapt a monad stack, changing the type of its top-most environment.

This class is comparable to
[Control.Lens.Magnify](https://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-Zoom.html#t:Magnify),
but does not use lenses (why would it), and is derived automatically for any transformer
implementing `monad_functor`.

Note: This class can be seen as a simplification of the more "principled" definition
```
class monad_reader_functor (ρ ρ' : out_param (Type u)) (n n' : Type u → Type u) :=
(map {α : Type u} : (∀ {m : Type u → Type u} [monad m], reader_t ρ m α → reader_t ρ' m α) → n α → n' α)
```
-/
class monad_writer_adapter (ω : outParam (Type u)) (ω' : outParam (Type u)) (m : Type u → Type v) (m' : Type u → Type v)
where
  adapt_writer : {α : Type u} → (ω → ω') → m α → m' α

/-- Transitivity.

This instance generates the type-class problem with a metavariable argument (which is why this
is marked as `[nolint dangerous_instance]`).
Currently that is not a problem, as there are almost no instances of `monad_functor` or
`monad_writer_adapter`.

see Note [lower instance priority] -/
protected instance monad_writer_adapter_trans {ω : Type u} {ω' : Type u} {m : Type u → Type v} {m' : Type u → Type v} {n : Type u → Type v} {n' : Type u → Type v} [monad_writer_adapter ω ω' m m'] [monad_functor m m' n n'] : monad_writer_adapter ω ω' n n' :=
  monad_writer_adapter.mk fun (α : Type u) (f : ω → ω') => monad_map fun (α : Type u) => adapt_writer f

protected instance writer_t.monad_writer_adapter {ω : Type u} {ω' : Type u} {m : Type u → Type v} [Monad m] : monad_writer_adapter ω ω' (writer_t ω m) (writer_t ω' m) :=
  monad_writer_adapter.mk fun (α : Type u) => writer_t.adapt

protected instance writer_t.monad_run (ω : Type u) (m : Type u → Type (max u u_1)) (out : outParam (Type u → Type (max u u_1))) [monad_run out m] : monad_run (fun (α : Type u) => out (α × ω)) (writer_t ω m) :=
  monad_run.mk fun (α : Type u) (x : writer_t ω m α) => run (writer_t.run x)

/-- reduce the equivalence between two writer monads to the equivalence between
their underlying monad -/
def writer_t.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁} {α₁ : Type u₀} {ω₁ : Type u₀} {α₂ : Type u₁} {ω₂ : Type u₁} (F : m₁ (α₁ × ω₁) ≃ m₂ (α₂ × ω₂)) : writer_t ω₁ m₁ α₁ ≃ writer_t ω₂ m₂ α₂ :=
  equiv.mk (fun (_x : writer_t ω₁ m₁ α₁) => sorry) (fun (_x : writer_t ω₂ m₂ α₂) => sorry) sorry sorry


/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
prelude
import Init.Control.Basic
import Init.Data.List.Basic

namespace List
universes u v w u₁ u₂

/-
Remark: we can define `mapM`, `mapM₂` and `forM` using `Applicative` instead of `Monad`.
Example:
```
def mapM {m : Type u → Type v} [Applicative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m (List β)
  | []    => pure []
  | a::as => List.cons <$> (f a) <*> mapM as
```

However, we consider `f <$> a <*> b` an anti-idiom because the generated code
may produce unnecessary closure allocations.
Suppose `m` is a `Monad`, and it uses the default implementation for `Applicative.seq`.
Then, the compiler expands `f <$> a <*> b <*> c` into something equivalent to
```
(Functor.map f a >>= fun g_1 => Functor.map g_1 b) >>= fun g_2 => Functor.map g_2 c
```
In an ideal world, the compiler may eliminate the temporary closures `g_1` and `g_2` after it inlines
`Functor.map` and `Monad.bind`. However, this can easily fail. For example, suppose
`Functor.map f a >>= fun g_1 => Functor.map g_1 b` expanded into a match-expression.
This is not unreasonable and can happen in many different ways, e.g., we are using a monad that
may throw exceptions. Then, the compiler has to decide whether it will create a join-point for
the continuation of the match or float it. If the compiler decides to float, then it will
be able to eliminate the closures, but it may not be feasible since floating match expressions
may produce exponential blowup in the code size.

Finally, we rarely use `mapM` with something that is not a `Monad`.

Users that want to use `mapM` with `Applicative` should use `mapA` instead.
-/

@[specialize]
def mapM {m : Type u → Type v} [Monad m] {α : Type w} {β : Type u} (f : α → m β) : List α → m (List β)
  | []    => pure []
  | a::as => return (← f a) :: (← mapM f as)

@[specialize]
def mapA {m : Type u → Type v} [Applicative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m (List β)
  | []    => pure []
  | a::as => List.cons <$> f a <*> mapA f as

@[specialize]
protected def forM {m : Type u → Type v} [Monad m] {α : Type w} (as : List α) (f : α → m PUnit) : m PUnit :=
  match as with
  | []      => pure ⟨⟩
  | a :: as => do f a; List.forM as f

@[specialize]
def forA {m : Type u → Type v} [Applicative m] {α : Type w} (as : List α) (f : α → m PUnit) : m PUnit :=
  match as with
  | []      => pure ⟨⟩
  | a :: as => f a *> forA as f

@[specialize]
def filterAuxM {m : Type → Type v} [Monad m] {α : Type} (f : α → m Bool) : List α → List α → m (List α)
  | [],     acc => pure acc
  | h :: t, acc => do
    let b ← f h
    filterAuxM f t (cond b (h :: acc) acc)

@[inline]
def filterM {m : Type → Type v} [Monad m] {α : Type} (f : α → m Bool) (as : List α) : m (List α) := do
  let as ← filterAuxM f as []
  pure as.reverse

@[inline]
def filterRevM {m : Type → Type v} [Monad m] {α : Type} (f : α → m Bool) (as : List α) : m (List α) :=
  filterAuxM f as.reverse []

@[inline]
def filterMapM {m : Type u → Type v} [Monad m] {α β : Type u} (f : α → m (Option β)) (as : List α) : m (List β) :=
  let rec @[specialize] loop
    | [],     bs => pure bs
    | a :: as, bs => do
      match (← f a) with
      | none   => loop as bs
      | some b => loop as (b::bs)
  loop as.reverse []

@[specialize]
protected def foldlM {m : Type u → Type v} [Monad m] {s : Type u} {α : Type w} : (f : s → α → m s) → (init : s) → List α → m s
  | f, s, []      => pure s
  | f, s, a :: as => do
    let s' ← f s a
    List.foldlM f s' as

@[specialize]
def foldrM {m : Type u → Type v} [Monad m] {s : Type u} {α : Type w} : (f : α → s → m s) → (init : s) → List α → m s
  | f, s, []      => pure s
  | f, s, a :: as => do
    let s' ← foldrM f s as
    f a s'

@[specialize]
def firstM {m : Type u → Type v} [Monad m] [Alternative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m β
  | []    => failure
  | a::as => f a <|> firstM f as

@[specialize]
def anyM {m : Type → Type u} [Monad m] {α : Type v} (f : α → m Bool) : List α → m Bool
  | []    => pure false
  | a::as => do
    match (← f a) with
    | true  => pure true
    | false => anyM f as

@[specialize]
def allM {m : Type → Type u} [Monad m] {α : Type v} (f : α → m Bool) : List α → m Bool
  | []    => pure true
  | a::as => do
    match (← f a) with
    | true  => allM f as
    | false => pure false

@[specialize]
def findM? {m : Type → Type u} [Monad m] {α : Type} (p : α → m Bool) : List α → m (Option α)
  | []    => pure none
  | a::as => do
    match (← p a) with
    | true  => pure (some a)
    | false => findM? p as

@[specialize]
def findSomeM? {m : Type u → Type v} [Monad m] {α : Type w} {β : Type u} (f : α → m (Option β)) : List α → m (Option β)
  | []    => pure none
  | a::as => do
    match (← f a) with
    | some b => pure (some b)
    | none   => findSomeM? f as

@[inline] protected def forIn {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : List α) (init : β) (f : α → β → m (ForInStep β)) : m β :=
  let rec @[specialize] loop
    | [], b    => pure b
    | a::as, b => do
      match (← f a b) with
      | ForInStep.done b  => pure b
      | ForInStep.yield b => loop as b
  loop as init

instance : ForIn m (List α) α where
  forIn := List.forIn

@[simp] theorem forIn_nil [Monad m] (f : α → β → m (ForInStep β)) (b : β) : forIn [] b f = pure b :=
  rfl

@[simp] theorem forIn_cons [Monad m] (f : α → β → m (ForInStep β)) (a : α) (as : List α) (b : β)
    : forIn (a::as) b f = f a b >>= fun | ForInStep.done b => pure b | ForInStep.yield b => forIn as b f :=
  rfl

instance : ForM m (List α) α where
  forM := List.forM

@[simp] theorem forM_nil  [Monad m] (f : α → m PUnit) : forM [] f = pure ⟨⟩ :=
  rfl
@[simp] theorem forM_cons [Monad m] (f : α → m PUnit) (a : α) (as : List α) : forM (a::as) f = f a >>= fun _ => forM as f :=
  rfl

end List


import dag
import tactic
import crawler
import data.list.defs
-- import data.int.basic
-- import number_theory.quadratic_reciprocity
-- import topology.algebra.module
-- import topology.algebra.ordered.basic
-- import ring_theory.discrete_valuation_ring
-- import algebra.lie.classical
-- import system.io
-- import init.meta.widget.tactic_component
-- import data.list.lex

-- TODO replace igets with get or else for surity
/-!
Notes:

* Sometimes files need changing beyond their imports, this can either be a insufficiency of this
  code or a weirdness in the file being modified, here are some ways this can happen:
  - The file being modified opens a namespace but never uses it, this will fail when the import is
    removed, but it wasn't doing anything in the first place, solution: delete the `open blah`
  - The file being modified applies simp with some attribute but then so simp lemmas with that
    attribute are applied so the dependency is missed, solution change to another or no simp set.
  - The file being modified uses notation but only notation from another file, solution, ignore it
    or move the notation next to the defs it refers to.
  - If a file contains an `example` which introduces extra dependencies this won't be visible in the
    environment after, so will be missed.

-/

section generic_io_stuff

/-- Remove a trailing newline character from a `list char` (if there is one) -/
meta def remove_trail : list char → list char
| ['\n'] := []
| (a :: b) := a :: remove_trail b
| [] := []

open io
/-- read one line of the file `f` as a string -/
meta def io.handle.get_line_as_string (f : handle) : io string :=
do g ← fs.get_line f, return $ (remove_trail g.to_list).as_string

end generic_io_stuff

local attribute [-instance] string_to_name -- this tends to cause confusion
open tactic declaration environment io io.fs (put_str_ln close)

/-- These decls are special as they are magically defined in cpp and don't have a genuine lean file
    source to point to, also they can never not be imported. -/
def magic_homeless_decls := [`quot, `quot.mk, `quot.lift, `quot.ind]

/-- These are user attributes that we can use to check for imports not obvious from the final
    proof term, i.e.
    ```
    @[ext]
    structure blah := (n : ℕ)
    ```
    will produce a lemma `blah.ext` that doesn't contain any references to the file where the `ext`
    attribute is defined, nevertheless by looking up the place where the user attribute is defined
    we can track the dependency on that file.

    Putting every possible attribute in this list would be too slow so we restrict to a hand-crafted
    list we found useful.
    -/
def evidence_attrs : list name :=
-- [`_can_lift, `_ext_core, `_ext_lemma_core, `_localized, `_refl_lemma, `_simp.sizeof, `_simp_cache, `_simps_str, `_squeeze_loc, `algebra, `alias, `ancestor, `breakpoint, `class, `congr, `continuity, `derive, `derive_handle, `elab_as_eliminator, `elab_simple, `elab_strategy, `elab_with_expected_type, `elementwise, `ematch, `ematch_lhs, `equiv_rw_simp, `ext, `field_simps, `functor_norm, `ghost_simps, `higher_order, `hint_tactic, `hole_command, `inline, `instance, `integral_simps, `interactive, `intro, `inverse, `irreducible, `is_poly, `library_note, `linter, `main_declaration, `measurability, `mfld_simps, `mk_iff, `monad_norm, `mono, `monotonicity, `no_inst_pattern, `no_rsimp, `nolint, `nontriviality, `norm, `norm_cast, `norm_num, `notation_class, `obviously, `parity_simps, `parsing_only, `pattern, `pp_nodot, `pp_using_anonymous_constructor, `pre_smt, `protect_proj, `protected, `push_cast, `reassoc, `recursor, `reducibility, `reducible, `refl, `replaceable, `rewrite, `rsimp, `semireducible, `simp, `simps, `split_if_reduction, `subst, `sugar, `sugar_nat, `symm, `tactic_doc, `tidy, `to_additive, `to_additive_aux, `to_additive_ignore_args, `to_additive_relevant_arg, `to_additive_reorder, `trans, `transport_simps, `typevec, `unify, `user_attribute, `user_command, `user_notation, `vm_monitor, `vm_override, `wrapper_eq, `zify]
-- [`_ext_core, `_ext_lemma_core, `alias, `ancestor, `congr, `continuity, `elementwise, `ematch, `equiv_rw_simp, `ext, `field_simps, `functor_norm, `ghost_simps, `higher_order, `integral_simps, `interactive, `intro, `inverse, `irreducible, `is_poly, `library_note, `linter, `main_declaration, `measurability, `mfld_simps, `mk_iff, `monad_norm, `mono, `monotonicity, `no_inst_pattern, `no_rsimp, `nolint, `nontriviality, `norm, `norm_cast, `norm_num, `notation_class, `obviously, `parity_simps, `pattern, `pp_nodot, `protect_proj, `protected, `push_cast, `reassoc, `recursor, `reducibility, `reducible, `refl, `replaceable, `rewrite, `rsimp, `semireducible, `simp, `simps, `split_if_reduction, `subst, `symm, `tactic_doc, `tidy, `to_additive, `trans, `transport_simps, `unify, `user_attribute, `user_command, `zify]
[`ext,
 `simps,
 `continuity,
 `mono,
 `_localized, -- sadly this only makes files that depend on localized not remove, TODO localized still
 `nolint,
 `to_additive,
 `protect_proj,
 `linter,
 `higher_order, -- TODO double check
 `derive_handler, -- TODO double check
 `deriver, -- TODO double check
 `hint_tactic,
 `obviously,
 `ancestor,
 `norm_cast,
 `nontriviality,
 `measurability,
 `mk_iff,
 `tidy
 ]
-- TODO map to get prios also
/-- get the attributes on a decl that tell us about necessary imports. -/
meta def get_decl_evidence_attrs (decna : name) : tactic $ list name :=
evidence_attrs.mfilter (λ ana, do (tactic.has_attribute ana decna >> return tt) <|> return ff)

/-- Convert an import name like `data.list.defs` to a filename by appending a prefix `pre`.
    `pre` should have a slash at the end, this does not check that a real file exists, so
    if `foo.blah` refers to `/files/mathlib/src/foo/bar/default.lean` this will not be the right
    filename. -/
def import_to_file (pre : string) (im : name) : string :=
pre ++ im.to_string_with_sep "/" ++ ".lean"-- TODO windows lol

section
open name
/-- Remove default from the end of an (import) `name`. -/
def name.remove_default : name → name
| (mk_string "default" p) := p
| p := p
end

/-- A hackish way to get the `src` directory of any project.
  Requires as argument any declaration name `n` in that project, and `k`, the number of characters
  in the path of the file where `n` is declared not part of the `src` directory.
  Example: For `mathlib_dir_locator` this is the length of `tactic/project_dir.lean`, so `23`.
  Note: does not work in the file where `n` is declared.
  This is copied from mathlib but abstracts over the environment instead.
   -/
meta def environment.get_project_dir (e : environment) (n : name) (k : ℕ) : string :=
(do
  s ← e.decl_olean n,
  return $ s.popn_back k).get_or_else sformat!"Hello! I'm {n} trapped in an error string, please let me out"

/-- A hackish way to get the `src` directory of mathlib.
    This is copied from mathlib but abstracts over the environment instead.  -/
meta def environment.get_mathlib_dir (e : environment) : string :=
e.get_project_dir `mathlib_dir_locator 23

/-- A hackish way to get the `src` directory of core.
    This is copied from mathlib but abstracts over the environment instead.  -/
meta def environment.get_core_dir (e : environment) : string :=
e.get_project_dir `nat 14

/-- Checks whether a declaration with the given name is declared in mathlib.
If you want to run this tactic many times, you should use `environment.is_prefix_of_file` instead,
since it is expensive to execute `get_mathlib_dir` many times. -/
meta def environment.is_in_mathlib (e : environment) (n : name) : bool :=
e.is_prefix_of_file e.get_mathlib_dir n

@[derive inhabited]
structure import_data : Type :=
(decl_name : name)
(file_name : name)
(file_pos : option pos)
(deps : list name)

lemma import_data.ext (d e : import_data) :
  d = e ↔ d.decl_name = e.decl_name ∧ d.file_name = e.file_name ∧ d.file_pos = e.file_pos ∧ d.deps = e.deps :=
begin
  split, { intro h, cases h, repeat { split, refl }, refl },
  cases d, cases e, dsimp, intro h,
  repeat { cases h with h' h, cases h' },
  cases h', congr,
end

-- attribute [derive inhabited] pos
meta instance : has_lt import_data := ⟨λ n m, n.decl_name < m.decl_name⟩
meta instance : decidable_eq import_data :=
begin
  intros d e, cases d, cases e,
  rw import_data.ext,
  dsimp,
  apply_instance,
end

meta instance : has_to_format import_data :=
  ⟨λ i, to_fmt i.decl_name
        ++ " : " ++ to_fmt i.file_name
        ++ " : " ++ to_fmt (i.file_pos.iget)
        ++ " : " ++ to_fmt (i.deps)
        ⟩

meta instance : has_to_string import_data :=
⟨λ b, to_string $ to_fmt b⟩

meta instance : has_to_tactic_format import_data :=
⟨λ b, return $ to_fmt b⟩

meta def get_attr_deps (n : name) : tactic (list name) :=
do
  ll ← get_decl_evidence_attrs n,
  ll.mmap_filter (λ n, do (option.some <$> get_user_attribute_name n) <|> return none)
  -- o ←  ll.mmap_filter (λ ana, pure $ get_user_attribute_name ana),
  -- return o

/-- Given a declaration `decl` return a structure of its name, position, list of dependent decl
    names and filename.
    Note that the dependent decl names includes the names of decls needed to declare the attributes
    on `decl`, that means that `decl` may originally have been defined without all of the
    dependent declarations returned by this function imported, and it may be necessary to prune this
    list.  -/
meta def mk_data (env : environment) (fname : name)
  (decl : declaration) : tactic import_data :=
let na := decl.to_name,
    po := env.decl_pos na
    --fname := file_to_import $ file_name $ env.decl_olean na
    in
  (λ attrd,
    { decl_name := na,
      file_name := fname,
      file_pos := po,
      deps := -- dont even consider quot and friends
        (list_items decl.type ++ list_items decl.value ++ attrd).dedup.diff magic_homeless_decls, }) <$>
  get_attr_deps na

-- #eval (λ inp : list nat, do l ← inp, guardb (l = 1), pure l) [1,2]
-- meta def aa (env : environment) (fname : name) (file_to_import : string → name) : list declaration → tactic (list import_data)
-- | (d :: l) :=
-- let fn_string := import_to_file env.get_mathlib_dir fname in
-- aa l >>= (
--   if (env.decl_olean d.to_name = fn_string) then
--  (do
--   of ← mk_data env file_to_import fname d,
--     ((::) of ))
--     else
--  id)
-- | [] := pure []
/-- Creates an import data tuple for every declaration in file `fname`. -/
meta def get_file_data (env : environment) (fname : name) (proj_dir : string := env.get_mathlib_dir) :
  tactic $ list import_data :=
let fn_string := import_to_file proj_dir fname in
-- aa env fname file_to_import env.get_decls
-- (λ decls : list declaration, do d ← decls,
--   guardb (env.decl_olean d.to_name = fn_string) >>
--   mk_data env file_to_import fname d,
--   skip
-- ) env.get_decls
  -- (λ d : declaration, env.decl_olean d.to_name = fn_string)).mmap
    -- (mk_data env file_to_import fname)
(env.get_decls.filter
  (λ d : declaration, env.decl_olean d.to_name = fn_string)).mmap
    (mk_data env fname)

-- /-- Given a declaration return a structure of its name, position, list of dependent decl names and
--     filename. -/
-- meta def mk_data (env : environment) (file_to_import : string → name)
--   (decl : declaration) (na : name) : tactic import_data :=
-- let po := env.decl_pos na,
--     fname := file_to_import $ file_name $ env.decl_olean na in
--   (λ attrd,
--     { decl_name := na,
--       file_name := fname,
--       file_pos := po,
--       deps := (list_items decl.type ++ list_items decl.value ++ attrd).dedup, }) <$>
--   get_attr_deps env na

-- /-- Creates an import data tuple for every declaration in file `fname`. -/
-- meta def get_file_data (env : environment) (fname : name) (file_to_import : string → name) :
--   tactic $ list import_data :=
-- let fn_string := import_to_file env.get_mathlib_dir fname in
-- env.get_decls.mmap_filter (λ d, let na := d.to_name in if
--   env.decl_olean na = fn_string then
--     option.some <$> mk_data env d na else none)

open native
/-- Creates a dag of input data. -/
meta def mk_file_dag_of_file_data (fdata : rb_map name import_data) :
  dag import_data :=
-- let fdata := mk_file_data env fname file_to_import,
  -- let decl_names := fdata.map import_data.decl_name in
fdata.fold
  (dag.mk _)
  (λ _ id G,
    id.deps.foldl
      (λ G2 dep,
        ((fdata.find dep).map -- todo maybe replace with an rb_map
          (λ a, G2.insert_edge a id)).get_or_else G2)
      (G.insert_vertex id))

section rb_counter
open native
variables (T : Type)
meta def rb_counter := rb_map T ℕ
namespace rb_counter
variable {T}
meta def incr_by (t : T) (n : ℕ) (A : rb_counter T) : rb_counter T :=
rb_map.insert A t ((rb_map.zfind A t) + n)
meta def incr (t : T) (A : rb_counter T) : rb_counter T := A.incr_by t 1
meta def mk (key : Type) [has_lt key] [decidable_rel ((<) : key → key → Prop)] : rb_counter key :=
rb_map.mk _ _

meta instance [has_to_format T] : has_to_format (rb_counter T) := rb_map.has_to_format
meta instance [has_to_string T] : has_to_string (rb_counter T) := rb_map.has_to_string
meta instance {R : Type*} [has_to_string T] [has_to_string R]: has_to_string (rb_lmap T R) := rb_map.has_to_string
end rb_counter
end rb_counter

open native

-- meta def dfs_all_paths' {T : Type*} [has_lt T] [decidable_rel ((<) : T → T → Prop)] [decidable_eq T] (d : dag T)
--   : T → (list (list T) × rb_set T) → (list (list T) × rb_set T)
-- -- vertex and stack, visited pair
-- | v stavis :=
--   (λ a : list (list T) × rb_set T, (a.fst.map ((::) v), a.snd))
--     ((d.find v).foldl
--       (λ stavis' w,
--         if stavis'.snd.contains w then
--           stavis'
--         else
--           dfs_all_paths' w stavis')
--       (stavis.fst, stavis.snd.insert v))

-- TODO convert this to use the `dfs` function
/-- Depth first search all paths. -/
meta def dfs_all_paths {T : Type*} [has_lt T] [decidable_rel ((<) : T → T → Prop)]
  (d : dag T) : T → rb_lmap T (list T) → rb_lmap T (list T)
| v paths :=
  if paths.contains v then paths else
    let npaths := (d.find v).foldl (λ opaths de, dfs_all_paths de opaths) paths in
    rb_map.insert npaths v $ (d.find v).foldl (λ acc de,
      let dep_paths := (npaths.find de) in
      acc ++ dep_paths.map ((::) v)) []
    -- (d.find v).foldl (λ opaths de, rb_map.insert opaths v _) npaths
    -- rb_map.insert npaths v $ (npaths.find de).map ((::) v) _
    -- (d.find v).foldl (λ opa de,
    -- let npa :=
    --   if paths.contains de then opa else dfs_all_paths de opa in
    --     rb_map.insert npa v $ (npa.find de).map ((::) v)) paths
      -- else
      --   (dfs_all_paths de opa).map (λ p, v :: p)) paths
  -- let a := ((d.find v).foldl
      -- (λ (rea' : rb_map T (list T)) w, let n :=
      --   if rea'.contains w then
      --     rea'
      -- ()  else
      --     dfs_reach_table w rea' in
      --   n.insert v $ (((n.find v).get_or_else mk_rb_set).union $ (n.find w).get_or_else mk_rb_set))
      -- rea) in a.insert v $ ((a.find v).get_or_else mk_rb_set).insert v

-- TODO convert this to use the `dfs` function
/-- Find all paths from `src` to `target` in the dag, not used currently but helpful for debugging-/
meta def dag.all_paths {T : Type*} [has_lt T] [decidable_rel ((<) : T → T → Prop)]
  (d : dag T) (src tgt : T) : list (list T) :=
(dfs_all_paths d src $ (mk_rb_map).insert tgt [[tgt]]).find src

-- run_cmd (do
--   e ← get_env,
--   G ← unsafe_run_io $ get_import_dag e `algebra.group_power.lemmas,
--   trace (all_paths G `data.int.cast `data.equiv.basic),
  -- skip)

-- #eval all_paths ((dag.mk ℕ).insert_edges [(1, 5), (3, 2), (4,5), (2,5), (5,6),(5,8),(8,7),(8,6), (5,19),(19,7), (6,7)]) 1 7

meta def dag.count_descendents {T : Type*} [has_lt T] [decidable_rel ((<) : T → T → Prop)]
  [decidable_eq T] (d : dag T) (start : list T) : ℕ :=
d.dfs (λ _, nat.succ) 0 start

meta def dag.count_all_descendents {T : Type*} [has_lt T] [decidable_rel ((<) : T → T → Prop)]
  [decidable_eq T] (d : dag T) (start : list T := d.vertices) : rb_counter T :=
d.dfs (λ v acc, acc.insert v $ 1 + ((d.find v).map $ λ de, acc.zfind de).sum) mk_rb_map start
-- #eval count_descendents (((dag.mk ℕ).insert_vertex 3).insert_edges [(1, 5), (4,5), (2,5)]) ([1,4,3])

open tactic native

/-- -/
meta def mk_file_dep_counts_basic (env : environment) (fname : name) (file_to_import : string → name)
  (fdata : rb_map name import_data) :
  rb_counter name :=
let G := mk_file_dag_of_file_data fdata,
    Gr := G.count_all_descendents in
(Gr.fold (rb_counter.mk _) (λ k d o, k.deps.foldl
  (λ o2 dep,
    let imp := file_to_import $ file_name $ env.decl_olean dep in
    if ¬ (`init).is_prefix_of imp then
      o2.incr_by imp d
    else
      o2) o)).erase fname -- erase the file itself as most likely it will depend on itself

/-- parse a files imports by reading the first few lines of the file.
  Note this function is quite brittle, some examples of things that probably break it but are valid
  lean. Most of these are banned / not done in mathlib though

  TODO handle relative imports, e.g. `import .blah` this is done once in mathlib (in tests), or
    remove from mathlib
```
  /-hi-/ import tactic
  import algebra.add_torsor
-- asddd
import data.list.basic
```
  -/
meta def get_imports_aux : handle → bool → io (list name)
| f b :=
do
  eo ← io.fs.is_eof f,
  if eo then return []
  else do
    l ← f.get_line_as_string,
    let ls := l.split_on ' ',
    -- if ls.tail.head = "graph." hen return [] else --stupid hack around the file reserved notation
    (if ls.head = "import" then
      do a ← get_imports_aux f tt,
        return ((((ls.tail.split_on_p (λ s, "--".is_prefix_of s)).head.filter (≠ "")).map
          name.from_string).map name.remove_default ++ a) -- space separated lists on imports (in core)
    else
      -- stop parsing imports if we see a non-newline line after seeing an import already
      -- or if we see a module docstring header
      if (b ∧ l ≠ "\n") ∨ "/-!".is_prefix_of l then
        return []
      else
        get_imports_aux f b)

meta def get_imports (e : environment) (file : name) (project_dir : string := e.get_mathlib_dir) :
  io (list name) :=
do
  -- get the file handle by trying a bunch of possibilities in order
  f ← mk_file_handle (import_to_file e.get_mathlib_dir file) io.mode.read <|>
      mk_file_handle (import_to_file e.get_mathlib_dir $ file.append `default) io.mode.read <|>
      mk_file_handle (import_to_file project_dir file) io.mode.read <|>
      mk_file_handle (import_to_file project_dir $ file.append `default) io.mode.read <|>
      mk_file_handle (import_to_file e.get_core_dir file) io.mode.read <|>
      mk_file_handle (import_to_file e.get_core_dir $ file.append `default) io.mode.read,
  l ← get_imports_aux f ff,
  fs.close f,
  return l

open io io.fs
/-- Checks whether the import given by name `file` refers to a default file, this simply checks if
    the corresponding filename with default appended appears in either mathlib or core.
    Note that if default is already a prefix of the file this does the wrong thing.
    We assume all default suffixes are stripped. TODO maybe change this
     -/
meta def is_default (e : environment) (file : name) : io bool :=
do
  bm ← file_exists $ import_to_file e.get_mathlib_dir $ file.append `default,
  bc ← file_exists $ import_to_file e.get_core_dir $ file.append `default,
  return $ bm ∨ bc

/-- Checks whether the file whose import name is `file` is in the mathlib directory.
    Compare `environment.is_in_mathlib` which checks if a declaration is in mathlib. -/
meta def file_is_in_mathlib (e : environment) (file : name) : io bool :=
do
  b ← file_exists $ import_to_file e.get_mathlib_dir $ file,
  if b then return tt else do
    bd ← file_exists $ import_to_file e.get_mathlib_dir $ file.append `default,
    return $ bd

/-- Checks whether the file whose import name is `file` is in the project directory.
    Compare `environment.is_in_mathlib` which checks if a declaration is in mathlib. -/
meta def file_is_in_project (file : name) (project_dir : string) : io bool :=
do
  b ← file_exists $ import_to_file project_dir $ file,
  if b then return tt else do
  bd ← file_exists $ import_to_file project_dir $ file.append `default,
  return $ bd

/-- Auxiliary function to make the import dag. -/
meta def get_dag_aux (e : environment) (project_dir : string) :
  name → dag name → io (dag name)
| n d := do
if d.contains n then return d else do
  l ← get_imports e n project_dir,
  l.mfoldl (λ od im, do
    G ← get_dag_aux im od,
    return $ G.insert_edge n im) d

/-- get a dag of all imports between files with edges from later dependencies to earlier.
   the environment is used to find the location of files, to parse their imports -/
meta def get_import_dag (e : environment) (files : list name) (project_dir : string := e.get_mathlib_dir) :
  io (dag name) :=
files.mfoldl (λ ol file, get_dag_aux e project_dir file ol) (dag.mk _)

open native
-- TODO we should probably not pass this function around anymore
/-- Given an environment creates a function `file_to_import` that translates a filename into an
    import `name`.
    We remove `default` by default.
    E.g. this will send
    `/users/alex/mathlib/src/group_theory/subgroup/default.lean` to `group_theory.subgroup`. -/
meta def mk_file_to_import (e : environment) (proj_pre : string := "this will never be a prefix") :
  string → name :=
let mathlib_pre := e.get_mathlib_dir,
    core_pre := e.get_core_dir in
λ file,
  let rest := (file.get_rest mathlib_pre).get_or_else $ -- take off the mathlib or core prefix
              (file.get_rest proj_pre).get_or_else $
              (file.get_rest core_pre).get_or_else $
              sformat!"Hello, I'm {file} trapped in an error string, please let me out" in
  (name.from_components -- create the name from the suffix
    ((rest.popn_back 5 -- remove the `.lean` suffix
      ).split_on '/')).remove_default

meta def mk_file_dep_counts (env : environment) (fname : name) (Gr : rb_map name (rb_set name))
  (fdata : rb_map name import_data) (proj_pre : string := "this will never be a prefix") :
  rb_counter name :=
let file_to_import := mk_file_to_import env proj_pre,
    dcb := mk_file_dep_counts_basic env fname file_to_import fdata,
    -- now we copy accross only those deps which were transitive imports of the original, to prevent
    -- spurious deps being added
    dc : rb_counter name := (Gr.ifind fname).fold mk_rb_map (λ dn acc, acc.insert dn $ dcb.zfind dn)
     in
  (dc.fold dc
    (λ nam co acc, (Gr.ifind nam).fold acc (λ de acc', acc'.incr_by de $ dc.zfind nam))).erase fname
  -- return $ (Gr.fold dc (λ na ln odc, ln.fold odc (λ de odc', odc'.incr_by de ((dc.find na).get_or_else 0)))).erase fname

meta def get_minimal_imports (e : environment) (n : name) (G : dag name) (Gr : rb_map name (rb_set name))
  (fdata : rb_map name import_data) (proj_pre : string := "this will never be a prefix") (robust : bool := tt) :
  rb_set name :=
  let b := mk_file_dep_counts e n Gr fdata proj_pre in
  G.minimal_vertices $
    (b.keys.filter (λ k, b.find k ≠ some 0)).union $ -- the needed imports
      ((Gr.find n).iget).to_list.filter
        -- if "robust" add some extra original imports back so we never remove imports from tactics
        -- this is a heuristic but quite effective
        (λ dn, robust ∧ dn ≠ n ∧ ((`tactic).is_prefix_of dn ∨ dn = `data.rbtree.default_lt))

meta def optimize_imports (e : environment) (nam : name) (G : dag name) (Gr := G.reachable_table)
  (fdata : rb_map name import_data) (proj_pre : string := "this will never be a prefix") :
  name × list name × ℕ :=
  let new_imp := get_minimal_imports e nam G Gr fdata proj_pre in
  (nam,
  --  old_imp.qsort (λ a b, a.to_string < b.to_string : name → name → bool),
   new_imp.to_list,
  --  G.count_descendents (old_imp : list name),
   G.count_descendents (new_imp.keys : list name))

/-- Convert the output of `optimize_imports` into a sed script for removing these imports. Note:
  * This clobbers import comments
  * Mac users should replace `sed` with `gsed` (via homebrew) in the script to ensure it works
  * This pipes to stdout by default, append `-i` after every `sed` to replace in-place

  We add the decidable_eq name argument so this function stays non-meta, this is probably pointless
  but it just feels weird to have this function meta.
-/
meta def output_to_sed [decidable_eq name] -- TODO remove numbers
 (o : name × rb_set name × rb_set name × rb_set name × ℕ × ℕ) : string :=
let ⟨na, ol, ne, dif, oli, nei⟩ := o,
    fn := na.to_string_with_sep "/",
    -- https://unix.stackexchange.com/questions/342516/sed-remove-all-matches-in-the-file-and-insert-some-lines-where-the-first-match
    ne2 := ne.to_list,
    ol2 := ol.to_list,
    imps := "\\\n".intercalate $ (ne2.map (λ i, sformat!"import {i}")).qsort (λ a b, a <  b) in
if ne2 ≠ ol2 then
sformat!"# {oli} → {nei} {ol2}, removed {dif.to_list}\n" ++
-- (if oli = nei then "# only transitive imports removed\n" else "") ++
"sed '/^import /{x;//!c\\
" ++ sformat!"{imps}
" ++ "d}' " ++ sformat!"src/{fn}.lean\n"
else ""

-- set_option profiler true
-- run_cmd unsafe_run_io (do
--   e ← run_tactic get_env,
--   -- let L := [`all],
-- --   -- let L := [`data.list.defs],
-- --   let L := [`tactic.basic],
-- --   -- let L := [`linear_algebra.affine_space.basic],
-- --   -- let L := [`linear_algebra.matrix.determinant],
--   let L := [`algebra.char_p.invertible],
--   fdata ← run_tactic $ get_file_data e L.head,
--   print_ln fdata,
--   G ← get_import_dag e L,
--   -- print_ln $ to_string G.size,
--   -- print_ln $ to_fmt $ G.find `algebra.char_p.invertible,
--   let Gr := G.reachable_table,
--   let T := L.map (λ nam, optimize_imports e nam G Gr fdata),
--   -- print_ln $ to_fmt $ (G.reverse.reachable_table.find `linear_algebra.tensor_product).map (rb_set.size)
--   -- print_ln $ to_fmt $ G.reverse.reachable_table.fold (mk_rb_map : rb_counter name) (λ v es acc, acc.insert v es.size),
--   print_ln $ to_string T
--   )
--   -- print_ln (to_fmt G),
--   -- let file_to_import := mk_file_to_import e,
--   -- let G' := mk_file_dag e `algebra.group_with_zero.basic file_to_import,
--   -- print_ln G'.keys,
--   -- print_ln $to_fmt G,
--   let Gr := G.reachable_table,
--   let T := L.map (λ nam, optimize_imports e nam G Gr fdata),
--   -- print_ln T,
--   ((T.filter (λ R : name × list string × list string × ℕ × ℕ, R.2.2.1 ≠ R.2.1 ∧ R.2.2.2.2 ≠ 0)).map
--     output_to_sed).mmap print_ln)

-- run_cmd silly `group_theory.free_abelian_group
-- run_cmd silly `algebra.module.linear_map -- quite successful
-- run_cmd silly `data.fin.basic
-- run_cmd silly `data.matrix.basic
-- run_cmd silly `data.polynomial.field_division
-- run_cmd silly `group_theory.perm.basic
-- run_cmd silly `group_theory.perm.sign
-- run_cmd silly `linear_algebra.coevaluation
-- run_cmd silly `linear_algebra.dimension
-- run_cmd silly `linear_algebra.eigenspace
-- run_cmd silly `linear_algebra.matrix.determinant
-- run_cmd silly `linear_algebra.matrix.transvection
-- run_cmd silly `algebra.group_power.identities
-- run_cmd silly `number_theory.number_field

-- (λ ana, do
--   ⟨b, prio⟩ ← tactic.has_attribute ana decna,
--   guardb b,
--   return (ana, prio))


import Lean
import Lean.Meta
import Lean.Elab
import Lean.Parser
import Lean.Parser.Extension
import LeanCodePrompts.Utils
open Lean Meta Elab Parser  Tactic

def depsPrompt : IO (Array String) := do
  let file ← reroutePath <| System.mkFilePath ["data/types.txt"]
  IO.FS.lines file

declare_syntax_cat typed_ident
syntax "(" ident ":" term ")" : typed_ident
syntax "{" ident ":" term "}" : typed_ident

#check Array.foldrM
#check TSyntaxArray.rawImpl
#check TSyntax.mk

instance : Coe (Syntax) (TSyntax n) where
  coe := TSyntax.mk

instance : Coe (Array Syntax) (Array (TSyntax n)) where
  coe := Array.map Coe.coe

/-- check whether a string parses as a term -/
def checkTerm (s : String) : MetaM Bool := do
  let env ← getEnv
  let chk := Lean.Parser.runParserCategory env `term  s
  match chk with
  | Except.ok _  => pure true
  | Except.error _  => pure false

/-- split prompts into those that parse -/
def promptsSplit : MetaM ((Array String) × (Array String)) := do
  let deps ← depsPrompt
  let mut succ: Array String := Array.empty
  let mut fail: Array String := Array.empty
  for type in deps do
    let chk ←  checkTerm type
    if chk then
      succ := succ.push type
    else
      fail := fail.push type
  return (succ, fail)

declare_syntax_cat argument
syntax "(" ident+ " : " term ")" : argument
syntax "{" ident+ " : " term "}" : argument
syntax "[" ident " : " term "]" : argument
syntax "[" term "]" : argument

declare_syntax_cat thmStat
syntax argument* docComment "theorem"  argument*  ":" term : thmStat
syntax "theorem" (ident)? argument*  ":" term : thmStat
syntax "def" ident argument*  ":" term : thmStat
syntax argument*  ":" term : thmStat

def thmsPrompt : IO (Array String) := do
  let file ← reroutePath <| System.mkFilePath ["data/thms.txt"]
  IO.FS.lines file

/-- check whether a string parses as a theorem -/
def checkThm (s : String) : MetaM Bool := do
  let env ← getEnv
  let chk := Lean.Parser.runParserCategory env `thmStat  s
  match chk with
  | Except.ok stx  =>
      IO.println stx
      pure true
  | Except.error _  => pure false

#check Syntax
partial def tokens (s : Syntax) : Array String :=
match s with
| .missing => Array.empty
| .node _ _ args => args.foldl (fun acc x => acc ++ tokens x) Array.empty
| .atom _  val => #[val]
| .ident _ val .. => #[val.toString]

def getTokens (s: String) : MetaM <| Array String := do
  let env ← getEnv
  let chk := Lean.Parser.runParserCategory env `thmStat  s
  match chk with
  | Except.ok stx  =>
      pure <| tokens stx
  | Except.error _  => pure Array.empty

-- #eval getTokens "{α : Type u} [group α] [has_lt α] [covariant_class α α (function.swap has_mul.mul) has_lt.lt] {a : α} : 1 < a⁻¹ ↔ a < 1"

/-- split prompts into those that parse -/
def promptsThmSplit : MetaM ((Array String) × (Array String)) := do
  let deps ← thmsPrompt
  let mut succ: Array String := Array.empty
  let mut fail: Array String := Array.empty
  for type in deps do
    let chk ←  checkThm type
    if chk then
      succ := succ.push type
    else
      fail := fail.push type
  return (succ, fail)

def promptsThmSplitCore : CoreM ((Array String) × (Array String)) :=
  promptsThmSplit.run'

def levelNames :=
  [`u, `v, `u_1, `u_2, `u_3, `u_4, `u_5, `u_6, `u_7, `u_8, `u_9, `u_10, `u_11, `u₁, `u₂, `W₁, `W₂, `w₁, `w₂, `u', `v', `uu, `w, `wE]

partial def idents : Syntax → List String
| Syntax.ident _ s .. => [s.toString]
| Syntax.node _ _ ss => ss.toList.bind idents
| _ => []

def elabThm (s : String)(opens: List String := [])
  (levelNames : List Lean.Name := levelNames)
  : TermElabM <| Except String Expr := do
  let env ← getEnv
  let chk := Lean.Parser.runParserCategory env `thmStat  s
  match chk with
  | Except.ok stx  =>
      match stx with
      | `(thmStat| $_:docComment theorem  $args:argument* : $type:term) =>
        elabAux type args
      | `(thmStat|theorem $_ $args:argument* : $type:term) =>
        elabAux type args
      | `(thmStat|theorem $args:argument* : $type:term) =>
        elabAux type args
      | `(thmStat|$vars:argument* $_:docComment  theorem $args:argument* : $type:term ) =>
        elabAux type (vars ++ args)
      | `(thmStat|def $_ $args:argument* : $type:term) =>
        elabAux type args
      | `(thmStat|$args:argument* : $type:term) =>
        elabAux type args
      | _ => return Except.error s!"parsed incorrectly to {stx}"
  | Except.error e  => return Except.error e
  where elabAux (type: Syntax)(args: Array Syntax) :
        TermElabM <| Except String Expr := do
        let header := if opens.isEmpty then "" else
          (opens.foldl (fun acc s => acc ++ " " ++ s) "open ") ++ " in "
        let mut argS := ""
        for arg in args do
          argS := argS ++ (showSyntax arg) ++ " -> "
        let funStx := s!"{header}{argS}{showSyntax type}"
        match Lean.Parser.runParserCategory (← getEnv) `term funStx with
        | Except.ok termStx => Term.withLevelNames levelNames <|
          try
            let expr ← Term.withoutErrToSorry <|
                Term.elabTerm termStx none
            return Except.ok expr
          catch e =>
            return Except.error s!"{← e.toMessageData.toString} ; identifiers {idents termStx} (during elaboration)"
        | Except.error e =>
            return Except.error s!"parsed to {funStx}; error while parsing as theorem: {e}"

def elabThmCore (s : String)(opens: List String := [])
  (levelNames : List Lean.Name := levelNames)
  : CoreM <| Except String Expr :=
    (elabThm s opens levelNames).run'.run'

theorem true_true_iff_True : true = true ↔ True := by
    apply Iff.intro
    intros
    exact True.intro
    intros
    rfl

theorem true_false_iff_false : false = true ↔ False := by
    apply Iff.intro
    intro hyp
    simp at hyp
    intro hyp
    contradiction

syntax "lynx" ("at" ident)? : tactic
syntax "lynx" "at" "*" : tactic
macro_rules
| `(tactic| lynx) =>
  `(tactic|try(repeat rw [true_true_iff_True]);try (repeat (rw [true_false_iff_false])))
| `(tactic| lynx at $t:ident) =>
  `(tactic| try(repeat rw [true_true_iff_True] at $t:ident);try (repeat (rw [true_false_iff_false] at $t:ident)))
| `(tactic| lynx at *) =>
  `(tactic|try(repeat rw [true_true_iff_True] at *);try (repeat (rw [true_false_iff_false] at *)))

def provedEqual (e₁ e₂ : Expr) : TermElabM Bool := do
  let type ← mkEq e₁ e₂
  let mvar ← mkFreshExprMVar <| some type
  let mvarId := mvar.mvarId!
  let stx ← `(tactic| lynx;  try (rfl))
  let res ←  runTactic mvarId stx
  let (remaining, _) := res
  return remaining.isEmpty

def provedEquiv (e₁ e₂ : Expr) : TermElabM Bool := do
  try
  let type ← mkAppM ``Iff #[e₁, e₂]
  let mvar ← mkFreshExprMVar <| some type
  let mvarId := mvar.mvarId!
  let stx ← `(tactic| intros; lynx at *<;> apply Iff.intro <;> intro hyp  <;> (lynx at *) <;> (try assumption) <;> try (intros; apply Eq.symm; apply hyp))
  let res ←  runTactic mvarId stx
  let (remaining, _) := res
  return remaining.isEmpty
  catch _ => pure false

def compareThms(s₁ s₂ : String)(opens: List String := [])
  (levelNames : List Lean.Name := levelNames)
  : TermElabM <| Except String Bool := do
  let e₁ ← elabThm s₁ opens levelNames
  let e₂ ← elabThm s₂ opens levelNames
  match e₁ with
  | Except.ok e₁ => match e₂ with
    | Except.ok e₂ =>
        let p := (← provedEqual e₁ e₂) ||
          (← provedEquiv e₁ e₂)
        return Except.ok p
    | Except.error e₂ => return Except.error e₂
  | Except.error e₁ => return Except.error e₁

def compareThmsCore(s₁ s₂ : String)(opens: List String := [])
  (levelNames : List Lean.Name := levelNames)
  : CoreM <| Except String Bool :=
    (compareThms s₁ s₂ opens levelNames).run'.run'

def compareThmExps(e₁ e₂: Expr)
  : TermElabM <| Except String Bool := do
      let p := (← provedEqual e₁ e₂) ||
        (← provedEquiv e₁ e₂)
      return Except.ok p

def compareThmExpsCore(e₁ e₂: Expr)
  : CoreM <| Except String Bool := do
      (compareThmExps e₁ e₂).run'.run'

def equalThms(s₁ s₂ : String)(opens: List String := [])
  (levelNames : List Lean.Name := levelNames)
  : TermElabM Bool := do
  match ← compareThms s₁ s₂ opens levelNames with
  | Except.ok p => return p
  | Except.error _ => return false

def groupThms(ss: Array String)(opens: List String := [])
  (levelNames : List Lean.Name := levelNames)
  : TermElabM (Array (Array String)) := do
    let mut groups: Array (Array String) := Array.empty
    for s in ss do
      match ← groups.findIdxM? (fun g =>
          equalThms s g[0]! opens levelNames) with
      |none  =>
        groups := groups.push #[s]
      | some j =>
        groups := groups.set! j (groups[j]!.push s)
    return groups

def groupTheoremsCore(ss: Array String)(opens: List String := [])
  (levelNames : List Lean.Name := levelNames)
  : CoreM (Array (Array String)) :=
    (groupThms ss opens levelNames).run'.run'

def groupThmsSort(ss: Array String)(opens: List String := [])
  (levelNames : List Lean.Name := levelNames)
  : TermElabM (Array (Array String)) := do
  let gps ← groupThms ss opens levelNames
  return gps.qsort (fun xs ys => xs.size > ys.size)

def groupThmsSortCore(ss: Array String)(opens: List String := [])
  (levelNames : List Lean.Name := levelNames)
  : CoreM (Array (Array String)) :=
    (groupThmsSort ss opens levelNames).run'.run'

-- Tests

-- #eval checkTerm "(fun x : Nat => x + 1)"

-- #eval checkTerm "a • s"

-- #eval checkTerm "λ x : Nat, x + 1"

-- #eval checkTerm "a - t = 0"

def checkStatements : MetaM (List (String × Bool)) := do
  let prompts ← depsPrompt
  (prompts.toList.take 50).mapM fun s =>
    do return (s, ← checkTerm s)

def tryParseThm (s : String) : MetaM String := do
  let env ← getEnv
  let chk := Lean.Parser.runParserCategory env `thmStat  s
  match chk with
  | Except.ok stx  =>
      match stx with
      | `(thmStat|theorem $_ $args:argument* : $type:term) =>
        let mut argS := ""
        for arg in args do
          argS := argS ++ (showSyntax arg) ++ " -> "
        let funStx := s!"{argS}{showSyntax type}"
        pure s!"match: {funStx}"
      | `(thmStat|$args:argument* : $type:term) =>
        let mut argS := ""
        for arg in args do
          argS := argS ++ (showSyntax arg) ++ " -> "
        let funStx := s!"{argS}{showSyntax type}"
        pure s!"match: {funStx}"
      | _ => pure s!"parsed to mysterious {stx}"
  | Except.error e  => pure s!"error: {e}"

-- #eval tryParseThm "theorem blah (n : Nat) {m: Type} : n  = n"

-- #eval elabThm "(p: Nat)/-- blah test -/ theorem  (n : Nat) {m: Type} : n  = p"

def eg :=
"section
variable (α : Type) {n : Nat}
/-- A doc that should be ignored -/
theorem blah (m: Nat) : n  = m "

-- #eval checkThm eg

-- #eval checkThm "(n : Nat) {m: Type} : n  = n"

-- #eval tryParseThm "theorem subfield.list_sum_mem {K : Type u} [field K] (s : subfield K) {l : list K} : (∀ (x : K), x ∈ l → x ∈ s) → l.sum ∈ s"

def checkElabThm (s : String) : TermElabM String := do
  let env ← getEnv
  let chk := Lean.Parser.runParserCategory env `thmStat  s
  match chk with
  | Except.ok stx  =>
      match stx with
      | `(thmStat|theorem $_ $args:argument* : $type:term) =>
        let mut argS := ""
        for arg in args do
          argS := argS ++ (showSyntax arg) ++ " -> "
        let funStx := s!"{argS}{showSyntax type}"
        match Lean.Parser.runParserCategory env `term funStx with
        | Except.ok termStx => Term.withLevelNames levelNames <|
          try
            let expr ← Term.withoutErrToSorry <|
                Term.elabTerm termStx none
            pure s!"elaborated: {← expr.view} from {funStx}"
          catch e =>
            pure s!"{← e.toMessageData.toString} during elaboration"
        | Except.error e =>
            pure s!"parsed to {funStx}; error while parsing: {e}"
      | `(thmStat|$vars:argument* $_:docComment theorem $args:argument* : $type:term ) =>
        let mut argS := ""
        for arg in vars ++ args do
          argS := argS ++ (showSyntax arg) ++ " -> "
        let funStx := s!"{argS}{showSyntax type}"
        match Lean.Parser.runParserCategory env `term funStx with
        | Except.ok termStx => Term.withLevelNames levelNames <|
          try
            let expr ← Term.withoutErrToSorry <|
                Term.elabTerm termStx none
            pure s!"elaborated: {← expr.view} from {funStx}"
          catch e =>
            pure s!"{← e.toMessageData.toString} during elaboration"
        | Except.error e =>
            pure s!"parsed to {funStx}; error while parsing: {e}"
      | `(thmStat|$args:argument* : $type:term) =>
        let mut argS := ""
        for arg in args do
          argS := argS ++ (showSyntax arg) ++ " -> "
        let funStx := s!"{argS}{showSyntax type}"
        match Lean.Parser.runParserCategory env `term funStx with
        | Except.ok termStx => Term.withLevelNames levelNames <|
          try
            let expr ← Term.withoutErrToSorry <|
                Term.elabTerm termStx none
            pure s!"elaborated: {← expr.view} from {funStx}"
          catch e =>
            pure s!"{← e.toMessageData.toString} during elaboration"
        | Except.error e =>
            pure s!"parsed to {funStx}; error while parsing: {e}"
      | _ => pure s!"parsed to mysterious {stx}"
  | Except.error e  => pure s!"error: {e}"

-- #eval checkElabThm "theorem blah (n : Nat) {m : Nat} : n  = m"

-- #eval checkElabThm eg

-- #eval checkElabThm "theorem subfield.list_sum_mem {K : Type u} [field K] (s : subfield K) {l : list K} : (∀ (x : K), x ∈ l → x ∈ s) → l.sum ∈ s"

-- #eval elabThm "theorem blah (n : Nat) {m : Nat} : n  = m"

-- #eval elabThm "theorem (n : Nat) {m : Nat} : n  = m"

-- #eval elabThm "theorem blah (n : Nat) {m : Nat} : n  = succ n" ["Nat"]

-- #eval elabThm "theorem blah (n : Nat) {m : Nat} : n  = succ n" ["Nat"]

-- #eval elabThm "(n : Nat) {m : Nat} : n  = succ n" ["Nat"]

-- #eval elabThmCore "(n : Nat) {m : Nat} : n  = succ n" ["Nat"]

-- #eval elabThm "theorem subfield.list_sum_mem {K : Type u} [field K] (s : subfield K) {l : list K} : (∀ (x : K), x ∈ l → x ∈ s) → l.sum ∈ s"

-- #eval compareThms "theorem nonsense(n : Nat) (m : Nat) : n = m" "(p : Nat)(q: Nat) : p = q"

-- #eval compareThms ": True" ": true = true"

-- #eval compareThms "{A: Type} : A →  True" "{A: Type}: A →  true"

-- #eval compareThms ": False" ": false = true"

-- #eval compareThms "{A: Sort} : False →  A" "{A: Sort} : false = true →  A"

example : (∀ {A: Sort}, False → A) ↔ (∀ {A: Sort}, false = true → A) := by
  intros; lynx at *<;> apply Iff.intro <;> intro hyp  <;> (lynx at *) <;> (try assumption) <;> try (intros; apply Eq.symm; apply hyp)

example : (∀ (a b c: Nat),
  a + (b + c) = (a + b) + c) ↔ (∀ (a b c: Nat), (a + b) + c = a + (b + c)) := by
  intros; apply Iff.intro <;> intro hyp  <;> (try assumption) <;> try (intros; apply Eq.symm; apply hyp)

-- #eval compareThms "(a b c: Nat): a + (b + c) = (a + b) + c" "(a b c: Nat): (a + b) + c = a + (b + c)"