/-
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.Compiler.BorrowedAnnotation
import Lean.Meta.KAbstract
import Lean.Meta.MatchUtil
import Lean.Elab.SyntheticMVars

namespace Lean.Elab.Term
open Meta

@[builtin_term_elab coeNotation] def elabCoe : TermElab := fun stx expectedType? => do
  let stx := stx[1]
  tryPostponeIfNoneOrMVar expectedType?
  let e ← elabTerm stx none
  if expectedType?.isNone then
    throwError "invalid coercion notation, expected type is not known"
  ensureHasType expectedType? e

@[builtin_term_elab anonymousCtor] def elabAnonymousCtor : TermElab := fun stx expectedType? =>
  match stx with
  | `(⟨$args,*⟩) => do
    tryPostponeIfNoneOrMVar expectedType?
    match expectedType? with
    | some expectedType =>
      let expectedType ← whnf expectedType
      matchConstInduct expectedType.getAppFn
        (fun _ => throwError "invalid constructor ⟨...⟩, expected type must be an inductive type {indentExpr expectedType}")
        (fun ival _ => do
          match ival.ctors with
          | [ctor] =>
            if isPrivateNameFromImportedModule (← getEnv) ctor then
              throwError "invalid ⟨...⟩ notation, constructor for `{ival.name}` is marked as private"
            let cinfo ← getConstInfoCtor ctor
            let numExplicitFields ← forallTelescopeReducing cinfo.type fun xs _ => do
              let mut n := 0
              for i in [cinfo.numParams:xs.size] do
                if (← getFVarLocalDecl xs[i]!).binderInfo.isExplicit then
                  n := n + 1
              return n
            let args := args.getElems
            if args.size < numExplicitFields then
              throwError "invalid constructor ⟨...⟩, insufficient number of arguments, constructs '{ctor}' has #{numExplicitFields} explicit fields, but only #{args.size} provided"
            let newStx ← if args.size == numExplicitFields then
              `($(mkCIdentFrom stx ctor (canonical := true)) $(args)*)
            else if numExplicitFields == 0 then
              throwError "invalid constructor ⟨...⟩, insufficient number of arguments, constructs '{ctor}' does not have explicit fields, but #{args.size} provided"
            else
              let extra := args[numExplicitFields-1:args.size]
              let newLast ← `(⟨$[$extra],*⟩)
              let newArgs := args[0:numExplicitFields-1].toArray.push newLast
              `($(mkCIdentFrom stx ctor (canonical := true)) $(newArgs)*)
            withMacroExpansion stx newStx $ elabTerm newStx expectedType?
          | _ => throwError "invalid constructor ⟨...⟩, expected type must be an inductive type with only one constructor {indentExpr expectedType}")
    | none => throwError "invalid constructor ⟨...⟩, expected type must be known"
  | _ => throwUnsupportedSyntax

@[builtin_term_elab borrowed] def elabBorrowed : TermElab := fun stx expectedType? =>
  match stx with
  | `(@& $e) => return markBorrowed (← elabTerm e expectedType?)
  | _ => throwUnsupportedSyntax

@[builtin_macro Lean.Parser.Term.show] def expandShow : Macro := fun stx =>
  match stx with
  | `(show $type by%$b $tac) => `(show $type from by%$b $tac)
  | _                        => Macro.throwUnsupported

@[builtin_term_elab Lean.Parser.Term.show] def elabShow : TermElab := fun stx expectedType? => do
  match stx with
  | `(show $type from $val)  =>
    /-
    We first elaborate the type and try to unify it with the expected type if available.
    Note that, we should not throw an error if the types do not unify. Recall that we have coercions and
    the following is supported in Lean 3 and 4.
    ```
    example : Int :=
      show Nat from 0
    ```
    -/
    let type ← withSynthesize (mayPostpone := true) do
      let type ← elabType type
      if let some expectedType := expectedType? then
        -- Recall that a similiar approach is used when elaborating applications
        discard <| isDefEq expectedType type
      return type
    /-
    Recall that we do not use the same approach used to elaborate type ascriptions.
    For the `($val : $type)` notation, we just elaborate `val` using `type` and
    ensure it has type `type`. This approach only ensure the type resulting expression
    is definitionally equal to `type`. For the `show` notation we use `let_fun` to ensure the type
    of the resulting expression is *structurally equal* `type`. Structural equality is important,
    for example, if the resulting expression is a `simp`/`rw` parameter. Here is an example:
    ```
    example (x : Nat) : (x + 0) + y = x + y := by
      rw [show x + 0 = x from rfl]
    ```
    -/
    let thisId := mkIdentFrom stx `this
    let valNew ← `(let_fun $thisId : $(← exprToSyntax type) := $val; $thisId)
    elabTerm valNew expectedType?
  | _ => throwUnsupportedSyntax

@[builtin_macro Lean.Parser.Term.have] def expandHave : Macro := fun stx =>
  match stx with
  | `(have $x $bs* $[: $type]? := $val; $body)            => `(let_fun $x $bs* $[: $type]? := $val; $body)
  | `(have%$tk $[: $type]? := $val; $body)                => `(have $(mkIdentFrom tk `this (canonical := true)) $[: $type]? := $val; $body)
  | `(have $x $bs* $[: $type]? $alts; $body)              => `(let_fun $x $bs* $[: $type]? $alts; $body)
  | `(have%$tk $[: $type]? $alts:matchAlts; $body)        => `(have $(mkIdentFrom tk `this (canonical := true)) $[: $type]? $alts:matchAlts; $body)
  | `(have $pattern:term $[: $type]? := $val:term; $body) => `(let_fun $pattern:term $[: $type]? := $val:term ; $body)
  | _                                                     => Macro.throwUnsupported

@[builtin_macro Lean.Parser.Term.suffices] def expandSuffices : Macro
  | `(suffices%$tk $[$x :]? $type from $val; $body)            => `(have%$tk $[$x]? : $type := $body; $val)
  | `(suffices%$tk $[$x :]? $type by%$b $tac:tacticSeq; $body) => `(have%$tk $[$x]? : $type := $body; by%$b $tac)
  | _                                                          => Macro.throwUnsupported

open Lean.Parser in
private def elabParserMacroAux (prec e : Term) (withAnonymousAntiquot : Bool) : TermElabM Syntax := do
  let (some declName) ← getDeclName?
    | throwError "invalid `leading_parser` macro, it must be used in definitions"
  match extractMacroScopes declName with
  | { name := .str _ s, .. } =>
    let kind := quote declName
    let mut p ← ``(withAntiquot
      (mkAntiquot $(quote s) $kind $(quote withAnonymousAntiquot))
      (leadingNode $kind $prec $e))
    -- cache only unparameterized parsers
    if (← getLCtx).all (·.isAuxDecl) then
      p ← ``(withCache $kind $p)
    return p
  | _  => throwError "invalid `leading_parser` macro, unexpected declaration name"

@[builtin_term_elab «leading_parser»] def elabLeadingParserMacro : TermElab :=
  adaptExpander fun
    | `(leading_parser $[: $prec?]? $[(withAnonymousAntiquot := $anon?)]? $e) =>
        elabParserMacroAux (prec?.getD (quote Parser.maxPrec)) e (anon?.all (·.raw.isOfKind ``Parser.Term.trueVal))
    | _ => throwUnsupportedSyntax

private def elabTParserMacroAux (prec lhsPrec e : Term) : TermElabM Syntax := do
  let declName? ← getDeclName?
  match declName? with
  | some declName => let kind := quote declName; ``(Lean.Parser.trailingNode $kind $prec $lhsPrec $e)
  | none          => throwError "invalid `trailing_parser` macro, it must be used in definitions"

@[builtin_term_elab «trailing_parser»] def elabTrailingParserMacro : TermElab :=
  adaptExpander fun stx => match stx with
  | `(trailing_parser$[:$prec?]?$[:$lhsPrec?]? $e) =>
    elabTParserMacroAux (prec?.getD <| quote Parser.maxPrec) (lhsPrec?.getD <| quote 0) e
  | _ => throwUnsupportedSyntax

@[builtin_term_elab Lean.Parser.Term.panic] def elabPanic : TermElab := fun stx expectedType? => do
  match stx with
  | `(panic! $arg) =>
    let pos ← getRefPosition
    let env ← getEnv
    let stxNew ← match (← getDeclName?) with
    | some declName => `(panicWithPosWithDecl $(quote (toString env.mainModule)) $(quote (toString declName)) $(quote pos.line) $(quote pos.column) $arg)
    | none => `(panicWithPos $(quote (toString env.mainModule)) $(quote pos.line) $(quote pos.column) $arg)
    withMacroExpansion stx stxNew $ elabTerm stxNew expectedType?
  | _ => throwUnsupportedSyntax

@[builtin_macro Lean.Parser.Term.unreachable]  def expandUnreachable : Macro := fun _ =>
  `(panic! "unreachable code has been reached")

@[builtin_macro Lean.Parser.Term.assert]  def expandAssert : Macro
  | `(assert! $cond; $body) =>
    -- TODO: support for disabling runtime assertions
    match cond.raw.reprint with
    | some code => `(if $cond then $body else panic! ("assertion violation: " ++ $(quote code)))
    | none => `(if $cond then $body else panic! ("assertion violation"))
  | _ => Macro.throwUnsupported

@[builtin_macro Lean.Parser.Term.dbgTrace]  def expandDbgTrace : Macro
  | `(dbg_trace $arg:interpolatedStr; $body) => `(dbgTrace (s! $arg) fun _ => $body)
  | `(dbg_trace $arg:term; $body)            => `(dbgTrace (toString $arg) fun _ => $body)
  | _                                        => Macro.throwUnsupported

@[builtin_term_elab «sorry»] def elabSorry : TermElab := fun stx expectedType? => do
  let stxNew ← `(sorryAx _ false)
  withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?

/-- Return syntax `Prod.mk elems[0] (Prod.mk elems[1] ... (Prod.mk elems[elems.size - 2] elems[elems.size - 1])))` -/
partial def mkPairs (elems : Array Term) : MacroM Term :=
  let rec loop (i : Nat) (acc : Term) := do
    if i > 0 then
      let i    := i - 1
      let elem := elems[i]!
      let acc ← `(Prod.mk $elem $acc)
      loop i acc
    else
      pure acc
  loop (elems.size - 1) elems.back

open Parser in
partial def hasCDot : Syntax → Bool
  | Syntax.node _ k args =>
    if k == ``Term.paren || k == ``Term.typeAscription || k == ``Term.tuple then false
    else if k == ``Term.cdot then true
    else args.any hasCDot
  | _ => false

/--
  Return `some` if succeeded expanding `·` notation occurring in
  the given syntax. Otherwise, return `none`.
  Examples:
  - `· + 1` => `fun _a_1 => _a_1 + 1`
  - `f · · b` => `fun _a_1 _a_2 => f _a_1 _a_2 b` -/
partial def expandCDot? (stx : Term) : MacroM (Option Term) := do
  if hasCDot stx then
    let (newStx, binders) ← (go stx).run #[]
    `(fun $binders* => $(⟨newStx⟩))
  else
    pure none
where
  /--
    Auxiliary function for expanding the `·` notation.
    The extra state `Array Syntax` contains the new binder names.
    If `stx` is a `·`, we create a fresh identifier, store in the
    extra state, and return it. Otherwise, we just return `stx`. -/
  go : Syntax → StateT (Array Ident) MacroM Syntax
    | stx@`(($(_))) => pure stx
    | stx@`(·) => withFreshMacroScope do
      let id ← mkFreshIdent stx (canonical := true)
      modify (·.push id)
      pure id
    | stx => match stx with
      | .node _ k args => do
        let args ← args.mapM go
        return .node (.fromRef stx (canonical := true)) k args
      | _ => pure stx

/--
  Helper method for elaborating terms such as `(.+.)` where a constant name is expected.
  This method is usually used to implement tactics that function names as arguments (e.g., `simp`).
-/
def elabCDotFunctionAlias? (stx : Term) : TermElabM (Option Expr) := do
  let some stx ← liftMacroM <| expandCDotArg? stx | pure none
  let stx ← liftMacroM <| expandMacros stx
  match stx with
  | `(fun $binders* => $f $args*) =>
    if binders == args then
      try Term.resolveId? f catch _ => return none
    else
      return none
  | `(fun $binders* => binop% $f $a $b) =>
    if binders == #[a, b] then
      try Term.resolveId? f catch _ => return none
    else
      return none
  | _ => return none
where
  expandCDotArg? (stx : Term) : MacroM (Option Term) :=
    match stx with
    | `(($e)) => Term.expandCDot? e
    | _ => Term.expandCDot? stx

@[builtin_macro Lean.Parser.Term.paren] def expandParen : Macro
  | `(($e)) => return (← expandCDot? e).getD e
  | _       => Macro.throwUnsupported

@[builtin_macro Lean.Parser.Term.tuple] def expandTuple : Macro
  | `(()) => ``(Unit.unit)
  | `(($e, $es,*)) => do
    let pairs ← mkPairs (#[e] ++ es)
    return (← expandCDot? pairs).getD pairs
  | _ => Macro.throwUnsupported

@[builtin_macro Lean.Parser.Term.typeAscription] def expandTypeAscription : Macro
  | `(($e : $(type)?)) => do
    match (← expandCDot? e) with
    | some e => `(($e : $(type)?))
    | none   => Macro.throwUnsupported
  | _ => Macro.throwUnsupported

@[builtin_term_elab typeAscription] def elabTypeAscription : TermElab
  | `(($e : $type)), _ => do
    let type ← withSynthesize (mayPostpone := true) <| elabType type
    let e ← elabTerm e type
    ensureHasType type e
  | `(($e :)), expectedType? => do
    let e ← withSynthesize (mayPostpone := false) <| elabTerm e none
    ensureHasType expectedType? e
  | _, _ => throwUnsupportedSyntax

/-- Return `true` if `lhs` is a free variable and `rhs` does not depend on it. -/
private def isSubstCandidate (lhs rhs : Expr) : MetaM Bool :=
  if lhs.isFVar then
    return !(← dependsOn rhs lhs.fvarId!)
  else
    return false

/--
  Given an expression `e` that is the elaboration of `stx`, if `e` is a free variable, then return `k stx`.
  Otherwise, return `(fun x => k x) e`
-/
private def withLocalIdentFor (stx : Term) (e : Expr) (k : Term → TermElabM Expr) : TermElabM Expr := do
  if e.isFVar then
    k stx
  else
    let id ← mkFreshUserName `h
    let aux ← withLocalDeclD id (← inferType e) fun x => do mkLambdaFVars #[x] (← k (mkIdentFrom stx id))
    return mkApp aux e

@[builtin_term_elab subst] def elabSubst : TermElab := fun stx expectedType? => do
  let expectedType? ← tryPostponeIfHasMVars? expectedType?
  match stx with
  | `($heqStx ▸ $hStx) => do
     synthesizeSyntheticMVars
     let mut heq ← withSynthesize <| elabTerm heqStx none
     let heqType ← inferType heq
     let heqType ← instantiateMVars heqType
     match (← Meta.matchEq? heqType) with
     | none => throwError "invalid `▸` notation, argument{indentExpr heq}\nhas type{indentExpr heqType}\nequality expected"
     | some (α, lhs, rhs) =>
       let mut lhs := lhs
       let mut rhs := rhs
       let mkMotive (lhs typeWithLooseBVar : Expr) := do
         withLocalDeclD (← mkFreshUserName `x) α fun x => do
           withLocalDeclD (← mkFreshUserName `h) (← mkEq lhs x) fun h => do
             mkLambdaFVars #[x, h] $ typeWithLooseBVar.instantiate1 x
       match expectedType? with
       | some expectedType =>
         let mut expectedAbst ← kabstract expectedType rhs
         unless expectedAbst.hasLooseBVars do
           expectedAbst ← kabstract expectedType lhs
           unless expectedAbst.hasLooseBVars do
             throwError "invalid `▸` notation, expected result type of cast is {indentExpr expectedType}\nhowever, the equality {indentExpr heq}\nof type {indentExpr heqType}\ndoes not contain the expected result type on either the left or the right hand side"
           heq ← mkEqSymm heq
           (lhs, rhs) := (rhs, lhs)
         let hExpectedType := expectedAbst.instantiate1 lhs
         let (h, badMotive?) ← withRef hStx do
           let h ← elabTerm hStx hExpectedType
           try
             return (← ensureHasType hExpectedType h, none)
           catch ex =>
             -- if `rhs` occurs in `hType`, we try to apply `heq` to `h` too
             let hType ← inferType h
             let hTypeAbst ← kabstract hType rhs
             unless hTypeAbst.hasLooseBVars do
               throw ex
             let hTypeNew := hTypeAbst.instantiate1 lhs
             unless (← isDefEq hExpectedType hTypeNew) do
               throw ex
             let motive ← mkMotive rhs hTypeAbst
             if !(← isTypeCorrect motive) then
               return (h, some motive)
             else
               return (← mkEqRec motive h (← mkEqSymm heq), none)
         let motive ← mkMotive lhs expectedAbst
         if badMotive?.isSome || !(← isTypeCorrect motive) then
           -- Before failing try tos use `subst`
           if ← (isSubstCandidate lhs rhs <||> isSubstCandidate rhs lhs) then
             withLocalIdentFor heqStx heq fun heqStx => do
               let h ← instantiateMVars h
               if h.hasMVar then
                 -- If `h` has metavariables, we try to elaborate `hStx` again after we substitute `heqStx`
                 -- Remark: re-elaborating `hStx` may be problematic if `hStx` contains the `lhs` of `heqStx` which will be eliminated by `subst`
                 let stxNew ← `(by subst $heqStx; exact $hStx)
                 withMacroExpansion stx stxNew (elabTerm stxNew expectedType)
               else
                 withLocalIdentFor hStx h fun hStx => do
                   let stxNew ← `(by subst $heqStx; exact $hStx)
                   withMacroExpansion stx stxNew (elabTerm stxNew expectedType)
           else
             throwError "invalid `▸` notation, failed to compute motive for the substitution"
         else
           mkEqRec motive h heq
       | none =>
         let h ← elabTerm hStx none
         let hType ← inferType h
         let hTypeAbst ← kabstract hType lhs
         let motive ← mkMotive lhs hTypeAbst
         unless (← isTypeCorrect motive) do
           throwError "invalid `▸` notation, failed to compute motive for the substitution"
         mkEqRec motive h heq
  | _ => throwUnsupportedSyntax

@[builtin_term_elab stateRefT] def elabStateRefT : TermElab := fun stx _ => do
  let σ ← elabType stx[1]
  let mut mStx := stx[2]
  if mStx.getKind == ``Lean.Parser.Term.macroDollarArg then
    mStx := mStx[1]
  let m ← elabTerm mStx (← mkArrow (mkSort levelOne) (mkSort levelOne))
  let ω ← mkFreshExprMVar (mkSort levelOne)
  let stWorld ← mkAppM ``STWorld #[ω, m]
  discard <| mkInstMVar stWorld
  mkAppM ``StateRefT' #[ω, σ, m]

@[builtin_term_elab noindex] def elabNoindex : TermElab := fun stx expectedType? => do
  let e ← elabTerm stx[1] expectedType?
  return DiscrTree.mkNoindexAnnotation e

end Lean.Elab.Term


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sebastian Ullrich, Leonardo de Moura
-/
prelude
import Init.SimpLemmas
import Init.Control.Except
import Init.Control.StateRef

open Function

@[simp] theorem monadLift_self [Monad m] (x : m α) : monadLift x = x :=
  rfl

class LawfulFunctor (f : Type u → Type v) [Functor f] : Prop where
  map_const          : (Functor.mapConst : α → f β → f α) = Functor.map ∘ const β
  id_map   (x : f α) : id <$> x = x
  comp_map (g : α → β) (h : β → γ) (x : f α) : (h ∘ g) <$> x = h <$> g <$> x

export LawfulFunctor (map_const id_map comp_map)

attribute [simp] id_map

@[simp] theorem id_map' [Functor m] [LawfulFunctor m] (x : m α) : (fun a => a) <$> x = x :=
  id_map x

class LawfulApplicative (f : Type u → Type v) [Applicative f] extends LawfulFunctor f : Prop where
  seqLeft_eq  (x : f α) (y : f β)     : x <* y = const β <$> x <*> y
  seqRight_eq (x : f α) (y : f β)     : x *> y = const α id <$> x <*> y
  pure_seq    (g : α → β) (x : f α)   : pure g <*> x = g <$> x
  map_pure    (g : α → β) (x : α)     : g <$> (pure x : f α) = pure (g x)
  seq_pure    {α β : Type u} (g : f (α → β)) (x : α) : g <*> pure x = (fun h => h x) <$> g
  seq_assoc   {α β γ : Type u} (x : f α) (g : f (α → β)) (h : f (β → γ)) : h <*> (g <*> x) = ((@comp α β γ) <$> h) <*> g <*> x
  comp_map g h x := by
    repeat rw [← pure_seq]
    simp [seq_assoc, map_pure, seq_pure]

export LawfulApplicative (seqLeft_eq seqRight_eq pure_seq map_pure seq_pure seq_assoc)

attribute [simp] map_pure seq_pure

@[simp] theorem pure_id_seq [Applicative f] [LawfulApplicative f] (x : f α) : pure id <*> x = x := by
  simp [pure_seq]

class LawfulMonad (m : Type u → Type v) [Monad m] extends LawfulApplicative m : Prop where
  bind_pure_comp (f : α → β) (x : m α) : x >>= pure ∘ f = f <$> x
  bind_map       {α β : Type u} (f : m (α → β)) (x : m α) : f >>= (. <$> x) = f <*> x
  pure_bind      (x : α) (f : α → m β) : pure x >>= f = f x
  bind_assoc     (x : m α) (f : α → m β) (g : β → m γ) : x >>= f >>= g = x >>= fun x => f x >>= g
  map_pure g x    := by rw [← bind_pure_comp, pure_bind]
  seq_pure g x    := by rw [← bind_map]; simp [map_pure, bind_pure_comp]
  seq_assoc x g h := by
    -- TODO: support for applying `symm` at `simp` arguments
    let bind_pure_comp_symm {α β : Type u} (f : α → β) (x : m α) : f <$> x = x >>= pure ∘ f := by
      rw [bind_pure_comp]
    let bind_map_symm {α β : Type u} (f : m (α → (β : Type u))) (x : m α) : f <*> x = f >>= (. <$> x) := by
      rw [bind_map]
    simp[bind_pure_comp_symm, bind_map_symm, bind_assoc, pure_bind]

export LawfulMonad (bind_pure_comp bind_map pure_bind bind_assoc)
attribute [simp] pure_bind bind_assoc

@[simp] theorem bind_pure [Monad m] [LawfulMonad m] (x : m α) : x >>= pure = x := by
  show x >>= pure ∘ id = x
  rw [bind_pure_comp, id_map]

theorem map_eq_pure_bind [Monad m] [LawfulMonad m] (f : α → β) (x : m α) : f <$> x = x >>= fun a => pure (f a) := by
  rw [← bind_pure_comp]

theorem seq_eq_bind_map {α β : Type u} [Monad m] [LawfulMonad m] (f : m (α → β)) (x : m α) : f <*> x = f >>= (. <$> x) := by
  rw [← bind_map]

theorem bind_congr [Bind m] {x : m α} {f g : α → m β} (h : ∀ a, f a = g a) : x >>= f = x >>= g := by
  simp [funext h]

@[simp] theorem bind_pure_unit [Monad m] [LawfulMonad m] {x : m PUnit} : (x >>= fun _ => pure ⟨⟩) = x := by
  have : (x >>= fun _ => pure ⟨⟩) = (x >>= pure) := by
    apply bind_congr; intro u
    cases u; simp
  rw [bind_pure] at this
  assumption

theorem map_congr [Functor m] {x : m α} {f g : α → β} (h : ∀ a, f a = g a) : (f <$> x : m β) = g <$> x := by
  simp [funext h]

theorem seq_eq_bind {α β : Type u} [Monad m] [LawfulMonad m] (mf : m (α → β)) (x : m α) : mf <*> x = mf >>= fun f => f <$> x := by
  rw [bind_map]

theorem seqRight_eq_bind [Monad m] [LawfulMonad m] (x : m α) (y : m β) : x *> y = x >>= fun _ => y := by
  rw [seqRight_eq]; simp [map_eq_pure_bind, seq_eq_bind_map]

theorem seqLeft_eq_bind [Monad m] [LawfulMonad m] (x : m α) (y : m β) : x <* y = x >>= fun a => y >>= fun _ => pure a := by
  rw [seqLeft_eq]; simp [map_eq_pure_bind, seq_eq_bind_map]

/- Id -/

namespace Id

@[simp] theorem map_eq (x : Id α) (f : α → β) : f <$> x = f x := rfl
@[simp] theorem bind_eq (x : Id α) (f : α → id β) : x >>= f = f x := rfl
@[simp] theorem pure_eq (a : α) : (pure a : Id α) = a := rfl

instance : LawfulMonad Id := by
  refine' { .. } <;> intros <;> rfl

end Id

/- ExceptT -/

namespace ExceptT

theorem ext [Monad m] {x y : ExceptT ε m α} (h : x.run = y.run) : x = y := by
  simp [run] at h
  assumption

@[simp] theorem run_pure [Monad m] : run (pure x : ExceptT ε m α) = pure (Except.ok x) := rfl

@[simp] theorem run_lift [Monad m] (x : m α) : run (ExceptT.lift x : ExceptT ε m α) = (Except.ok <$> x : m (Except ε α)) := rfl

@[simp] theorem run_throw [Monad m] : run (throw e : ExceptT ε m β) = pure (Except.error e) := rfl

@[simp] theorem run_bind_lift [Monad m] [LawfulMonad m] (x : m α) (f : α → ExceptT ε m β) : run (ExceptT.lift x >>= f : ExceptT ε m β) = x >>= fun a => run (f a) := by
  simp[ExceptT.run, ExceptT.lift, bind, ExceptT.bind, ExceptT.mk, ExceptT.bindCont, map_eq_pure_bind]

@[simp] theorem bind_throw [Monad m] [LawfulMonad m] (f : α → ExceptT ε m β) : (throw e >>= f) = throw e := by
  simp [throw, throwThe, MonadExceptOf.throw, bind, ExceptT.bind, ExceptT.bindCont, ExceptT.mk]

theorem run_bind [Monad m] (x : ExceptT ε m α)
        : run (x >>= f : ExceptT ε m β)
          =
          run x >>= fun
                     | Except.ok x => run (f x)
                     | Except.error e => pure (Except.error e) :=
  rfl

@[simp] theorem lift_pure [Monad m] [LawfulMonad m] (a : α) : ExceptT.lift (pure a) = (pure a : ExceptT ε m α) := by
  simp [ExceptT.lift, pure, ExceptT.pure]

@[simp] theorem run_map [Monad m] [LawfulMonad m] (f : α → β) (x : ExceptT ε m α)
    : (f <$> x).run = Except.map f <$> x.run := by
  simp [Functor.map, ExceptT.map, map_eq_pure_bind]
  apply bind_congr
  intro a; cases a <;> simp [Except.map]

protected theorem seq_eq {α β ε : Type u} [Monad m] (mf : ExceptT ε m (α → β)) (x : ExceptT ε m α) : mf <*> x = mf >>= fun f => f <$> x :=
  rfl

protected theorem bind_pure_comp [Monad m] [LawfulMonad m] (f : α → β) (x : ExceptT ε m α) : x >>= pure ∘ f = f <$> x := by
  intros; rfl

protected theorem seqLeft_eq {α β ε : Type u} {m : Type u → Type v} [Monad m] [LawfulMonad m] (x : ExceptT ε m α) (y : ExceptT ε m β) : x <* y = const β <$> x <*> y := by
  show (x >>= fun a => y >>= fun _ => pure a) = (const (α := α) β <$> x) >>= fun f => f <$> y
  rw [← ExceptT.bind_pure_comp]
  apply ext
  simp [run_bind]
  apply bind_congr
  intro
  | Except.error _ => simp
  | Except.ok _ =>
    simp [map_eq_pure_bind]; apply bind_congr; intro b;
    cases b <;> simp [comp, Except.map, const]

protected theorem seqRight_eq [Monad m] [LawfulMonad m] (x : ExceptT ε m α) (y : ExceptT ε m β) : x *> y = const α id <$> x <*> y := by
  show (x >>= fun _ => y) = (const α id <$> x) >>= fun f => f <$> y
  rw [← ExceptT.bind_pure_comp]
  apply ext
  simp [run_bind]
  apply bind_congr
  intro a; cases a <;> simp

instance [Monad m] [LawfulMonad m] : LawfulMonad (ExceptT ε m) where
  id_map         := by intros; apply ext; simp
  map_const      := by intros; rfl
  seqLeft_eq     := ExceptT.seqLeft_eq
  seqRight_eq    := ExceptT.seqRight_eq
  pure_seq       := by intros; apply ext; simp [ExceptT.seq_eq, run_bind]
  bind_pure_comp := ExceptT.bind_pure_comp
  bind_map       := by intros; rfl
  pure_bind      := by intros; apply ext; simp [run_bind]
  bind_assoc     := by intros; apply ext; simp [run_bind]; apply bind_congr; intro a; cases a <;> simp

end ExceptT

/- ReaderT -/

namespace ReaderT

theorem ext [Monad m] {x y : ReaderT ρ m α} (h : ∀ ctx, x.run ctx = y.run ctx) : x = y := by
  simp [run] at h
  exact funext h

@[simp] theorem run_pure [Monad m] (a : α) (ctx : ρ) : (pure a : ReaderT ρ m α).run ctx = pure a := rfl

@[simp] theorem run_bind [Monad m] (x : ReaderT ρ m α) (f : α → ReaderT ρ m β) (ctx : ρ)
    : (x >>= f).run ctx = x.run ctx >>= λ a => (f a).run ctx := rfl

@[simp] theorem run_map [Monad m] (f : α → β) (x : ReaderT ρ m α) (ctx : ρ)
    : (f <$> x).run ctx = f <$> x.run ctx := rfl

@[simp] theorem run_monadLift [MonadLiftT n m] (x : n α) (ctx : ρ)
    : (monadLift x : ReaderT ρ m α).run ctx = (monadLift x : m α) := rfl

@[simp] theorem run_monadMap [Monad m] [MonadFunctor n m] (f : {β : Type u} → n β → n β) (x : ReaderT ρ m α) (ctx : ρ)
    : (monadMap @f x : ReaderT ρ m α).run ctx = monadMap @f (x.run ctx) := rfl

@[simp] theorem run_read [Monad m] (ctx : ρ) : (ReaderT.read : ReaderT ρ m ρ).run ctx = pure ctx := rfl

@[simp] theorem run_seq {α β : Type u} [Monad m] [LawfulMonad m] (f : ReaderT ρ m (α → β)) (x : ReaderT ρ m α) (ctx : ρ) : (f <*> x).run ctx = (f.run ctx <*> x.run ctx) := by
  rw [seq_eq_bind (m := m)]; rfl

@[simp] theorem run_seqRight [Monad m] [LawfulMonad m] (x : ReaderT ρ m α) (y : ReaderT ρ m β) (ctx : ρ) : (x *> y).run ctx = (x.run ctx *> y.run ctx) := by
  rw [seqRight_eq_bind (m := m)]; rfl

@[simp] theorem run_seqLeft [Monad m] [LawfulMonad m] (x : ReaderT ρ m α) (y : ReaderT ρ m β) (ctx : ρ) : (x <* y).run ctx = (x.run ctx <* y.run ctx) := by
  rw [seqLeft_eq_bind (m := m)]; rfl

instance [Monad m] [LawfulMonad m] : LawfulMonad (ReaderT ρ m) where
  id_map         := by intros; apply ext; intros; simp
  map_const      := by intros; rfl
  seqLeft_eq     := by intros; apply ext; intros; simp; apply LawfulApplicative.seqLeft_eq
  seqRight_eq    := by intros; apply ext; intros; simp; apply LawfulApplicative.seqRight_eq
  pure_seq       := by intros; apply ext; intros; simp; apply LawfulApplicative.pure_seq
  bind_pure_comp := by intros; apply ext; intros; simp; apply LawfulMonad.bind_pure_comp
  bind_map       := by intros; rfl
  pure_bind      := by intros; apply ext; intros; simp
  bind_assoc     := by intros; apply ext; intros; simp

end ReaderT

/- StateRefT -/

instance [Monad m] [LawfulMonad m] : LawfulMonad (StateRefT' ω σ m) :=
  inferInstanceAs (LawfulMonad (ReaderT (ST.Ref ω σ) m))

/- StateT -/

namespace StateT

theorem ext {x y : StateT σ m α} (h : ∀ s, x.run s = y.run s) : x = y :=
  funext h

@[simp] theorem run'_eq [Monad m] (x : StateT σ m α) (s : σ) : run' x s = (·.1) <$> run x s :=
  rfl

@[simp] theorem run_pure [Monad m] (a : α) (s : σ) : (pure a : StateT σ m α).run s = pure (a, s) := rfl

@[simp] theorem run_bind [Monad m] (x : StateT σ m α) (f : α → StateT σ m β) (s : σ)
    : (x >>= f).run s = x.run s >>= λ p => (f p.1).run p.2 := by
  simp [bind, StateT.bind, run]
  apply bind_congr
  intro p; cases p; rfl

@[simp] theorem run_map {α β σ : Type u} [Monad m] [LawfulMonad m] (f : α → β) (x : StateT σ m α) (s : σ) : (f <$> x).run s = (fun (p : α × σ) => (f p.1, p.2)) <$> x.run s := by
  simp [Functor.map, StateT.map, run, map_eq_pure_bind]
  apply bind_congr
  intro p; cases p; rfl

@[simp] theorem run_get [Monad m] (s : σ)    : (get : StateT σ m σ).run s = pure (s, s) := rfl

@[simp] theorem run_set [Monad m] (s s' : σ) : (set s' : StateT σ m PUnit).run s = pure (⟨⟩, s') := rfl

@[simp] theorem run_modify [Monad m] (f : σ → σ) (s : σ) : (modify f : StateT σ m PUnit).run s = pure (⟨⟩, f s) := rfl

@[simp] theorem run_modifyGet [Monad m] (f : σ → α × σ) (s : σ) : (modifyGet f : StateT σ m α).run s = pure ((f s).1, (f s).2) := by
  simp [modifyGet, MonadStateOf.modifyGet, StateT.modifyGet, run]; cases f s <;> rfl

@[simp] theorem run_lift {α σ : Type u} [Monad m] (x : m α) (s : σ) : (StateT.lift x : StateT σ m α).run s = x >>= fun a => pure (a, s) := rfl

@[simp] theorem run_bind_lift {α σ : Type u} [Monad m] [LawfulMonad m] (x : m α) (f : α → StateT σ m β) (s : σ) : (StateT.lift x >>= f).run s = x >>= fun a => (f a).run s := by
  simp [StateT.lift, StateT.run, bind, StateT.bind]

@[simp] theorem run_monadLift {α σ : Type u} [Monad m] [MonadLiftT n m] (x : n α) (s : σ) : (monadLift x : StateT σ m α).run s = (monadLift x : m α) >>= fun a => pure (a, s) := rfl

@[simp] theorem run_monadMap [Monad m] [MonadFunctor n m] (f : {β : Type u} → n β → n β) (x : StateT σ m α) (s : σ)
    : (monadMap @f x : StateT σ m α).run s = monadMap @f (x.run s) := rfl

@[simp] theorem run_seq {α β σ : Type u} [Monad m] [LawfulMonad m] (f : StateT σ m (α → β)) (x : StateT σ m α) (s : σ) : (f <*> x).run s = (f.run s >>= fun fs => (fun (p : α × σ) => (fs.1 p.1, p.2)) <$> x.run fs.2) := by
  show (f >>= fun g => g <$> x).run s = _
  simp

@[simp] theorem run_seqRight [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) (s : σ) : (x *> y).run s = (x.run s >>= fun p => y.run p.2) := by
  show (x >>= fun _ => y).run s = _
  simp

@[simp] theorem run_seqLeft {α β σ : Type u} [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) (s : σ) : (x <* y).run s = (x.run s >>= fun p => y.run p.2 >>= fun p' => pure (p.1, p'.2)) := by
  show (x >>= fun a => y >>= fun _ => pure a).run s = _
  simp

theorem seqRight_eq [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) : x *> y = const α id <$> x <*> y := by
  apply ext; intro s
  simp [map_eq_pure_bind]
  apply bind_congr; intro p; cases p
  simp [Prod.ext]

theorem seqLeft_eq [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) : x <* y = const β <$> x <*> y := by
  apply ext; intro s
  simp [map_eq_pure_bind]

instance [Monad m] [LawfulMonad m] : LawfulMonad (StateT σ m) where
  id_map         := by intros; apply ext; intros; simp[Prod.ext]
  map_const      := by intros; rfl
  seqLeft_eq     := seqLeft_eq
  seqRight_eq    := seqRight_eq
  pure_seq       := by intros; apply ext; intros; simp
  bind_pure_comp := by intros; apply ext; intros; simp; apply LawfulMonad.bind_pure_comp
  bind_map       := by intros; rfl
  pure_bind      := by intros; apply ext; intros; simp
  bind_assoc     := by intros; apply ext; intros; simp

end StateT


/-
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.Meta.Transform
import Lean.Meta.Tactic.Replace
import Lean.Meta.Tactic.Util
import Lean.Meta.Tactic.Clear
import Lean.Meta.Tactic.Simp.Types
import Lean.Meta.Tactic.Simp.Rewrite

namespace Lean.Meta
namespace Simp

builtin_initialize congrHypothesisExceptionId : InternalExceptionId ←
  registerInternalExceptionId `congrHypothesisFailed

def throwCongrHypothesisFailed : MetaM α :=
  throw <| Exception.internal congrHypothesisExceptionId

def Result.getProof (r : Result) : MetaM Expr := do
  match r.proof? with
  | some p => return p
  | none   => mkEqRefl r.expr

private def mkEqTrans (r₁ r₂ : Result) : MetaM Result := do
  match r₁.proof? with
  | none => return r₂
  | some p₁ => match r₂.proof? with
    | none    => return { r₂ with proof? := r₁.proof? }
    | some p₂ => return { r₂ with proof? := (← Meta.mkEqTrans p₁ p₂) }

private def mkCongrFun (r : Result) (a : Expr) : MetaM Result :=
  match r.proof? with
  | none   => return { expr := mkApp r.expr a, proof? := none }
  | some h => return { expr := mkApp r.expr a, proof? := (← Meta.mkCongrFun h a) }

private def mkCongr (r₁ r₂ : Result) : MetaM Result :=
  let e := mkApp r₁.expr r₂.expr
  match r₁.proof?, r₂.proof? with
  | none,     none   => return { expr := e, proof? := none }
  | some h,  none    => return { expr := e, proof? := (← Meta.mkCongrFun h r₂.expr) }
  | none,    some h  => return { expr := e, proof? := (← Meta.mkCongrArg r₁.expr h) }
  | some h₁, some h₂ => return { expr := e, proof? := (← Meta.mkCongr h₁ h₂) }

private def mkImpCongr (r₁ r₂ : Result) : MetaM Result := do
  let e ← mkArrow r₁.expr r₂.expr
  match r₁.proof?, r₂.proof? with
  | none,     none   => return { expr := e, proof? := none }
  | _,        _      => return { expr := e, proof? := (← Meta.mkImpCongr (← r₁.getProof) (← r₂.getProof)) } -- TODO specialize if bootleneck

private def reduceProj (e : Expr) : MetaM Expr := do
  match (← reduceProj? e) with
  | some e => return e
  | _      => return e

private def reduceProjFn? (e : Expr) : SimpM (Option Expr) := do
  matchConst e.getAppFn (fun _ => pure none) fun cinfo _ => do
    match (← getProjectionFnInfo? cinfo.name) with
    | none => return none
    | some projInfo =>
      if projInfo.fromClass then
        if (← read).simpLemmas.isDeclToUnfold cinfo.name then
          -- We only unfold class projections when the user explicitly requested them to be unfolded.
          -- Recall that `unfoldDefinition?` has support for unfolding this kind of projection.
          withReducibleAndInstances <| unfoldDefinition? e
        else
          return none
      else
        -- `structure` projection
        match (← unfoldDefinition? e) with
        | none   => pure none
        | some e =>
          match (← reduceProj? e.getAppFn) with
          | some f => return some (mkAppN f e.getAppArgs)
          | none   => return none

private def reduceFVar (cfg : Config) (e : Expr) : MetaM Expr := do
  if cfg.zeta then
    match (← getFVarLocalDecl e).value? with
    | some v => return v
    | none   => return e
  else
    return e

private def unfold? (e : Expr) : SimpM (Option Expr) := do
  let f := e.getAppFn
  if !f.isConst then
    return none
  let fName := f.constName!
  if (← isProjectionFn fName) then
    return none -- should be reduced by `reduceProjFn?`
  if (← read).simpLemmas.isDeclToUnfold e.getAppFn.constName! then
    withDefault <| unfoldDefinition? e
  else
    return none

private partial def reduce (e : Expr) : SimpM Expr := withIncRecDepth do
  let cfg := (← read).config
  if cfg.beta then
    let e' := e.headBeta
    if e' != e then
      return (← reduce e')
  -- TODO: eta reduction
  if cfg.proj then
    match (← reduceProjFn? e) with
    | some e => return (← reduce e)
    | none   => pure ()
  if cfg.iota then
    match (← reduceRecMatcher? e) with
    | some e => return (← reduce e)
    | none   => pure ()
  match (← unfold? e) with
  | some e => reduce e
  | none => return e

private partial def dsimp (e : Expr) : M Expr := do
  transform e (post := fun e => return TransformStep.done (← reduce e))

partial def simp (e : Expr) : M Result := withIncRecDepth do
  let cfg ← getConfig
  if (← isProof e) then
    return { expr := e }
  if cfg.memoize then
    if let some result := (← get).cache.find? e then
      return result
  simpLoop { expr := e }

where
  simpLoop (r : Result) : M Result := do
    let cfg ← getConfig
    if (← get).numSteps > cfg.maxSteps then
      throwError "simp failed, maximum number of steps exceeded"
    else
      let init := r.expr
      modify fun s => { s with numSteps := s.numSteps + 1 }
      match (← pre r.expr) with
      | Step.done r   => cacheResult cfg r
      | Step.visit r' =>
        let r ← mkEqTrans r r'
        let r ← mkEqTrans r (← simpStep r.expr)
        match (← post r.expr) with
        | Step.done r'  => cacheResult cfg (← mkEqTrans r r')
        | Step.visit r' =>
          let r ← mkEqTrans r r'
          if cfg.singlePass || init == r.expr then
            cacheResult cfg r
          else
            simpLoop r

  simpStep (e : Expr) : M Result := do
    match e with
    | Expr.mdata _ e _ => simp e
    | Expr.proj ..     => pure { expr := (← reduceProj e) }
    | Expr.app ..      => simpApp e
    | Expr.lam ..      => simpLambda e
    | Expr.forallE ..  => simpForall e
    | Expr.letE ..     => simpLet e
    | Expr.const ..    => simpConst e
    | Expr.bvar ..     => unreachable!
    | Expr.sort ..     => pure { expr := e }
    | Expr.lit ..      => pure { expr := e }
    | Expr.mvar ..     => pure { expr := (← instantiateMVars e) }
    | Expr.fvar ..     => pure { expr := (← reduceFVar (← getConfig) e) }

  congrDefault (e : Expr) : M Result :=
    withParent e <| e.withApp fun f args => do
      let infos := (← getFunInfoNArgs f args.size).paramInfo
      let mut r ← simp f
      let mut i := 0
      for arg in args do
        trace[Debug.Meta.Tactic.simp] "app [{i}] {infos.size} {arg} hasFwdDeps: {infos[i].hasFwdDeps}"
        if i < infos.size && !infos[i].hasFwdDeps then
          r ← mkCongr r (← simp arg)
        else if (← whnfD (← inferType r.expr)).isArrow then
          r ← mkCongr r (← simp arg)
        else
          r ← mkCongrFun r (← dsimp arg)
        i := i + 1
      return r

  /- Return true iff processing the given congruence lemma hypothesis produced a non-refl proof. -/
  processCongrHypothesis (h : Expr) : M Bool := do
    forallTelescopeReducing (← inferType h) fun xs hType => withNewLemmas xs do
      let lhs ← instantiateMVars hType.appFn!.appArg!
      let r ← simp lhs
      let rhs := hType.appArg!
      rhs.withApp fun m zs => do
        let val ← mkLambdaFVars zs r.expr
        unless (← isDefEq m val) do
          throwCongrHypothesisFailed
        unless (← isDefEq h (← mkLambdaFVars xs (← r.getProof))) do
          throwCongrHypothesisFailed
        return r.proof?.isSome

  /- Try to rewrite `e` children using the given congruence lemma -/
  tryCongrLemma? (c : CongrLemma) (e : Expr) : M (Option Result) := withNewMCtxDepth do
    trace[Debug.Meta.Tactic.simp.congr] "{c.theoremName}, {e}"
    let lemma ← mkConstWithFreshMVarLevels c.theoremName
    let (xs, bis, type) ← forallMetaTelescopeReducing (← inferType lemma)
    if c.hypothesesPos.any (· ≥ xs.size) then
      return none
    let lhs := type.appFn!.appArg!
    let rhs := type.appArg!
    if (← isDefEq lhs e) then
      let mut modified := false
      for i in c.hypothesesPos do
        let x := xs[i]
        try
          if (← processCongrHypothesis x) then
            modified := true
        catch _ =>
          trace[Meta.Tactic.simp.congr] "processCongrHypothesis {c.theoremName} failed {← inferType x}"
          return none
      unless modified do
        trace[Meta.Tactic.simp.congr] "{c.theoremName} not modified"
        return none
      unless (← synthesizeArgs c.theoremName xs bis (← read).discharge?) do
        trace[Meta.Tactic.simp.congr] "{c.theoremName} synthesizeArgs failed"
        return none
      let eNew ← instantiateMVars rhs
      let proof ← instantiateMVars (mkAppN lemma xs)
      return some { expr := eNew, proof? := proof }
    else
      return none

  congr (e : Expr) : M Result := do
    let f := e.getAppFn
    if f.isConst then
      let congrLemmas ← getCongrLemmas
      let cs := congrLemmas.get f.constName!
      for c in cs do
        match (← tryCongrLemma? c e) with
        | none   => pure ()
        | some r => return r
      congrDefault e
    else
      congrDefault e

  simpApp (e : Expr) : M Result := do
    let e ← reduce e
    if !e.isApp then
      simp e
    else
      congr e

  simpConst (e : Expr) : M Result :=
    return { expr := (← reduce e) }

  withNewLemmas {α} (xs : Array Expr) (f : M α) : M α := do
    if (← getConfig).contextual then
      let mut s ← getSimpLemmas
      let mut updated := false
      for x in xs do
        if (← isProof x) then
          s ← s.add #[] x
          updated := true
      if updated then
        withSimpLemmas s f
      else
        f
    else
      f

  simpLambda (e : Expr) : M Result :=
    withParent e <| lambdaTelescope e fun xs e => withNewLemmas xs do
      let r ← simp e
      let eNew ← mkLambdaFVars xs r.expr
      match r.proof? with
      | none   => return { expr := eNew }
      | some h =>
        let p ← xs.foldrM (init := h) fun x h => do
          mkFunExt (← mkLambdaFVars #[x] h)
        return { expr := eNew, proof? := p }

  simpArrow (e : Expr) : M Result := do
    trace[Debug.Meta.Tactic.simp] "arrow {e}"
    let p := e.bindingDomain!
    let q := e.bindingBody!
    let rp ← simp p
    trace[Debug.Meta.Tactic.simp] "arrow [{(← getConfig).contextual}] {p} [{← isProp p}] -> {q} [{← isProp q}]"
    if (← (← getConfig).contextual <&&> isProp p <&&> isProp q) then
      trace[Debug.Meta.Tactic.simp] "ctx arrow {rp.expr} -> {q}"
      withLocalDeclD e.bindingName! rp.expr fun h => do
        let s ← getSimpLemmas
        let s ← s.add #[] h
        withSimpLemmas s do
          let rq ← simp q
          match rq.proof? with
          | none    => mkImpCongr rp rq
          | some hq =>
            let hq ← mkLambdaFVars #[h] hq
            return { expr := (← mkArrow rp.expr rq.expr), proof? := (← mkImpCongrCtx (← rp.getProof) hq) }
    else
      mkImpCongr rp (← simp q)

  simpForall (e : Expr) : M Result := withParent e do
    trace[Debug.Meta.Tactic.simp] "forall {e}"
    if e.isArrow then
      simpArrow e
    else if (← isProp e) then
      withLocalDecl e.bindingName! e.bindingInfo! e.bindingDomain! fun x => withNewLemmas #[x] do
        let b := e.bindingBody!.instantiate1 x
        let rb ← simp b
        let eNew ← mkForallFVars #[x] rb.expr
        match rb.proof? with
        | none   => return { expr := eNew }
        | some h => return { expr := eNew, proof? := (← mkForallCongr (← mkLambdaFVars #[x] h)) }
    else
      return { expr := (← dsimp e) }

  simpLet (e : Expr) : M Result := do
    if (← getConfig).zeta then
      match e with
      | Expr.letE _ _ v b _ => return { expr := b.instantiate1 v }
      | _ => unreachable!
    else
      -- TODO: simplify nondependent let-decls
      return { expr := (← dsimp e) }

  cacheResult (cfg : Config) (r : Result) : M Result := do
    if cfg.memoize then
      modify fun s => { s with cache := s.cache.insert e r }
    return r

def main (e : Expr) (ctx : Context) (methods : Methods := {}) : MetaM Result := do
  withReducible do
    simp e methods ctx |>.run' {}

namespace DefaultMethods
mutual
  partial def discharge? (e : Expr) : SimpM (Option Expr) := do
    let ctx ← read
    if ctx.dischargeDepth >= ctx.config.maxDischargeDepth then
      trace[Meta.Tactic.simp.discharge] "maximum discharge depth has been reached"
      return none
    else
      withReader (fun ctx => { ctx with dischargeDepth := ctx.dischargeDepth + 1 }) do
        let r ← simp e methods
        if r.expr.isConstOf ``True then
          try
            return some (← mkOfEqTrue (← r.getProof))
          catch _ =>
            return none
        else
          return none

  partial def pre (e : Expr) : SimpM Step :=
    preDefault e discharge?

  partial def post (e : Expr) : SimpM Step :=
    postDefault e discharge?

  partial def methods : Methods :=
    { pre := pre, post := post, discharge? := discharge? }
end
end DefaultMethods

end Simp

def simp (e : Expr) (ctx : Simp.Context) : MetaM Simp.Result := do profileitM Exception "simp" (← getOptions) do
  Simp.main e ctx (methods := Simp.DefaultMethods.methods)

/-- See `simpTarget`. This method assumes `mvarId` is not assigned, and we are already using `mvarId`s local context. -/
def simpTargetCore (mvarId : MVarId) (ctx : Simp.Context) : MetaM (Option MVarId) := do
  let target ← instantiateMVars (← getMVarType mvarId)
  let r ← simp target ctx
  if r.expr.isConstOf ``True then
    match r.proof? with
    | some proof => assignExprMVar mvarId  (← mkOfEqTrue proof)
    | none => assignExprMVar mvarId (mkConst ``True.intro)
    return none
  else
    match r.proof? with
    | some proof => replaceTargetEq mvarId r.expr proof
    | none =>
      if target != r.expr then
        replaceTargetDefEq mvarId r.expr
      else
        return mvarId

/--
  Simplify the given goal target (aka type). Return `none` if the goal was closed. Return `some mvarId'` otherwise,
  where `mvarId'` is the simplified new goal. -/
def simpTarget (mvarId : MVarId) (ctx : Simp.Context) : MetaM (Option MVarId) :=
  withMVarContext mvarId do
    checkNotAssigned mvarId `simp
    simpTargetCore mvarId ctx

/--
  Simplify `prop` (which is inhabited by `proof`). Return `none` if the goal was closed. Return `some (proof', prop')`
  otherwise, where `proof' : prop'` and `prop'` is the simplified `prop`.

  This method assumes `mvarId` is not assigned, and we are already using `mvarId`s local context. -/
def simpStep (mvarId : MVarId) (proof : Expr) (prop : Expr) (ctx : Simp.Context) : MetaM (Option (Expr × Expr)) := do
  let r ← simp prop ctx
  if r.expr.isConstOf ``False then
    match r.proof? with
    | some eqProof => assignExprMVar mvarId (← mkFalseElim (← getMVarType mvarId) (← mkEqMP eqProof proof))
    | none => assignExprMVar mvarId (← mkFalseElim (← getMVarType mvarId) proof)
    return none
  else
    match r.proof? with
    | some eqProof => return some ((← mkEqMP eqProof proof), r.expr)
    | none =>
      if r.expr != prop then
        return some ((← mkExpectedTypeHint proof r.expr), r.expr)
      else
        return some (proof, r.expr)

end Lean.Meta


import Aesop

example : True := by
  aesop (rule_sets [Nonexistent])


import .util

meta def unwrap_lm_response (ident : option string) : json → tactic (list string)
| (json.array $ tactic_strings) := do
    result ← tactic_strings.mmap $ lift_option ∘ json.get_string,
    pure result
| exc := tactic.fail format!"{ident.get_or_else \"[unwrap_lm_response.anonymous]\"} run_best_beam_candidate UNEXPECTED: {exc}"

meta def json_float_array_sum : json → option json
| (json.array xs) := json.of_float <$> xs.mfoldr (λ msg acc, match msg with
  | (json.of_float val) := pure $ acc + val
  | (json.of_int val) := pure $ acc + native.float.of_int val
  | exc := none
  end) (0.0 : native.float)
| exc := none

-- WARNING(jesse, January 14 2021, 10:32 AM): instead of failing like `unwrap_lm_response`, this return an empty list when seeing an unexpected message
meta def unwrap_lm_response_logprobs (ident : option string) : json → tactic (list $ string × native.float)
| (json.array $ [(json.array predictions), (json.array scores)]) := do {
  decoded_strings ← predictions.mmap $ lift_option ∘ json.get_string,
  decoded_scores ← scores.mmap $ lift_option ∘ json.get_float,
  pure $ list.zip decoded_strings decoded_scores
}
| exc := tactic.trace format!"{ident.get_or_else \"[unwrap_lm_response_logprobs.anonymous]\"} run_best_beam_candidate UNEXPECTED: {exc}" *> pure []

section json

-- for debugging

meta def json.compare : Π (x y : json), bool
| (json.of_string s) (json.of_string s') := s = s'
| (json.of_int k) (json.of_int k') := k = k'
| (json.of_float x) (json.of_float x') := x = x' -- might have to make this tt
| (json.of_bool b) (json.of_bool b') := b = b'
| (json.null) (json.null) := tt
| (json.object kvs) (json.object kvs') := (list.zip kvs kvs').foldr
  (λ ⟨⟨k₁, v₁⟩, ⟨k₂, v₂⟩⟩ acc,
  json.compare k₁ k₂ && json.compare v₁ v₂ && acc) tt
| (json.array args) (json.array args') := (list.zip args args').foldr
  (λ ⟨j₁, j₂⟩ acc, acc && json.compare j₁ j₂) tt
| _ _ := ff

meta def json.to_raw_fmt : json → format
| (json.of_string s) := format!"(json.of_string \"{s}\")"
| (json.of_int k) := format!"(json.of_int {k})"
| (json.of_float x) := format!"(json.of_float {x})"
| (json.of_bool b) := format!"(json.of_bool {b})"
| (json.null) := "(json.null)"
| (json.object kvs) := let f : string × json → format :=
  (λ ⟨k,v⟩, json.to_raw_fmt k ++ " : " ++ json.to_raw_fmt v) in
   format!"(json.object " ++ format.join_using " " (f <$> kvs) ++ ")"
| (json.array args) := "(json.array " ++ format.join_using " " (json.to_raw_fmt <$> args) ++ ")"

end json

section derive_has_json
section has_to_tactic_json_name
open name

-- meta def has_to_tactic_json_name_aux : name → json
-- | anonymous := json.object $ [("constr", json.of_string "name.anonymous"), ("args", json.array [])]
-- | (mk_string str nm) := json.object $ [("constr", json.of_string "name.mk_string"),
--     ("args", json.array [json.of_string str, has_to_tactic_json_name_aux nm])]
-- | (mk_numeral u nm) := json.object $ [("constr", json.of_string "name.mk_numeral"),
--     ("args", json.array [json.of_int (int.of_nat ∘ unsigned.to_nat $ u), has_to_tactic_json_name_aux nm])]

meta def has_to_tactic_json_name_aux : name → json
| anonymous := json.array ∘ pure $ json.of_string "name.anonymous"
| (mk_string str nm) := json.array $
  [json.of_string "name.mk_string", json.of_string str, has_to_tactic_json_name_aux nm]
| (mk_numeral u nm) := json.array $
  [json.of_string "name.mk_numeral", json.of_int (int.of_nat u.to_nat), has_to_tactic_json_name_aux nm]

 -- json.object $ [("constr", json.of_string "name.mk_numeral"),
 --    ("args", json.array [json.of_int (int.of_nat ∘ unsigned.to_nat $ u), has_to_tactic_json_name_aux nm])]

meta instance : has_to_tactic_json name :=
⟨pure ∘ has_to_tactic_json_name_aux⟩

end has_to_tactic_json_name

section has_from_json_name

-- meta def has_from_json_name_aux : json → tactic name
-- | arg@(json.object [("constr", json.of_string c), ("args", json.array args)]) := do {
--   tactic.trace format!"GOT MATCH: {arg}",
--   match c with
--   | "name.anonymous" := pure name.anonymous
--   | "name.mk_string" := do {
--     (str, nm_json) ← (do {
--       [json.of_string str, nm_json] ← pure args,
--       pure (str, nm_json)
--     } <|> tactic.fail
--             format!"[has_from_json_name_aux.inner_match_1.mk_string] unexpected: {args}"),
--     name.mk_string str <$> has_from_json_name_aux nm_json
--   }
--   | "name.mk_numeral" := do {
--     (u, nm_json) ← (do {
--       [json.of_int u, nm_json] ← pure args,
--       pure (u, nm_json)
--     } <|> tactic.fail
--             format!"[has_from_json_name_aux.inner_match_1.mk_numeral] unexpected: {args}"),
--     name.mk_numeral (unsigned.of_nat ∘ int.to_nat $ u) <$> has_from_json_name_aux nm_json
--   }
--   | exc := tactic.fail format!"[has_from_json_name_aux.inner_match_1] unexpected: {exc}"
--   end
-- }
-- | exc := tactic.fail format!"[has_from_json_name_aux] unexpected: {exc}"

meta def has_from_json_name_aux : json → tactic name
| arg@(json.array (c::args)) := do {
  -- tactic.trace format!"GOT MATCH: {arg}",
  match c with
  | "name.anonymous" := pure name.anonymous
  | "name.mk_string" := do {
    (str, nm_json) ← (do {
      [json.of_string str, nm_json] ← pure args,
      pure (str, nm_json)
    } <|> tactic.fail
            format!"[has_from_json_name_aux.inner_match_1.mk_string] unexpected: {args}"),
    name.mk_string str <$> has_from_json_name_aux nm_json
  }
  | "name.mk_numeral" := do {
    (u, nm_json) ← (do {
      [json.of_int u, nm_json] ← pure args,
      pure (u, nm_json)
    } <|> tactic.fail
            format!"[has_from_json_name_aux.inner_match_1.mk_numeral] unexpected: {args}"),
    name.mk_numeral (unsigned.of_nat ∘ int.to_nat $ u) <$> has_from_json_name_aux nm_json
  }
  | exc := tactic.fail format!"[has_from_json_name_aux.inner_match_1] unexpected: {exc}"
  end
}
| exc := tactic.fail format!"[has_from_json_name_aux] unexpected: {exc}"

meta instance : has_from_json name :=
⟨has_from_json_name_aux⟩

end has_from_json_name

open tactic
namespace tactic
namespace interactive

meta def mk_to_tactic_json (type : name) : tactic unit := do {
  ls ← local_context,
  (x::_) ← tactic.intro_lst [`arg],
  et ← infer_type x,
  xs ← tactic.induction x,
  xs.mmap' $ λ ⟨c, args, _⟩, do
    (args', rec_call) ← args.mpartition $ λ e, do {e' ← tactic.to_expr ``(tactic json), bnot <$> e'.occurs <$> tactic.infer_type e},
    args'' ← args'.mmap (λ a, flip prod.mk a <$> (et.occurs <$> tactic.infer_type a)),
    let fn : list (bool × expr) → state_t (list expr) tactic (list expr) := λ args'', do {
      let pop : state_t (list expr) tactic (option expr) := do {
        xs ← get,
        match xs with
        | (a::as) := modify (λ _, as) *> pure (some a)
        | [] := pure none
        end
      },
      args''.mmap (λ ⟨b, a⟩, if b then do (some x) ← pop, pure x else state_t.lift $ do
      a_tp ← infer_type a,
      _inst ← mk_app ``has_to_tactic_json [a_tp] >>= mk_instance,
      tactic.to_expr ``(@has_to_tactic_json.to_tactic_json _ (%%_inst) %%a))
    },
    args''' ← prod.fst <$> (fn args'').run rec_call,

    c ← tactic.resolve_constant c,
    refine ``((λ (ys : list $ tactic json),
      (λ x, json.array [has_to_tactic_json_name_aux %%c,
        json.array x]) <$>  ys.mmap id) _), -- lol
    args'''.mmap (λ e, refine ``(list.cons %%e _)),
    tactic.to_expr ``(([] : list (tactic json))) >>= tactic.exact
}

meta def derive_has_to_tactic_json (pre : option name) : tactic unit := do {
  vs ← local_context,
  `(has_to_tactic_json %%f) ← target,
  env ← get_env,
  let n := f.get_app_fn.const_name,
  d ← get_decl n,
  refine ``( { to_tactic_json := _ } ),
  tgt ← target,
  extract_def (with_prefix pre n <.> "to_tactic_json") ff $ mk_to_tactic_json n
}

meta def has_to_tactic_json_derive_handler' (nspace : option name := none) : derive_handler :=
higher_order_derive_handler ``has_to_tactic_json (derive_has_to_tactic_json nspace) [] nspace

@[derive_handler]
meta def has_to_tactic_json_derive_handler : derive_handler :=
guard_class ``has_to_tactic_json has_to_tactic_json_derive_handler'

end interactive
end tactic
end derive_has_json

section derive_from_json
open tactic
namespace tactic

namespace interactive

meta def get_constr_and_args (arg : json) : option (string × list json) :=
match arg with
| (json.array [json.of_string c, json.array args]) := pure (c, args)
| _ := none
end

-- meta def json_to_expr : Π (arg : json), tactic expr
-- | (json.object [("constr", nm_json), ("args", json.array args)]) := do {
--   -- let c_nm := hacky_name_from_string c,
--   c_nm ← (json_to_expr nm_json) >>= eval_expr name,
--   constr ← mk_const c_nm,
--   if args.length = 0 then do {
--   tp ← tactic.infer_type constr,
--   e_id ← to_expr ``(@id %%tp),
--   pure $ e_id.mk_app [constr] -- ???????????????
--   }
--   else do
--   constr.mk_app <$> (args.mmap json_to_expr)
-- }
-- | arg@(json.of_int k) := do { -- WARNING: this is a hack for now
--   pure `(int.to_nat k)
-- }
-- | exc@(json.array $ x@(((json.of_string c))::rest)) := if ("name" < c) then do nm ← has_from_json_name_aux x, pure $ (by apply_instance : has_reflect name) nm else tactic.fail format!"[json_to_expr.name] unexpected: {exc}"
-- -- | arg@(json.of_bool b) := do { -- WARNING: this is a hack for now
-- --   pure `(tt)
-- -- }
-- -- -- TODO(jesse): as needed, built special built-in logic to handle constants
-- -- -- TODO(jesse): use `resolve_name` on `nm` to get the `has_from_json` instance
-- -- -- then make a recursive call with `json_to_expr`
-- -- -- better yet, move this logic into `mk_from_json`

-- -- | arg@(json.object [("builtin", nm_json), ("val", val_json)]) := do {
-- --   env ← get_env,
-- --   nm ← (has_from_json_name_aux nm_json),
-- --   -- d ← env.get nm,
-- --   ty_reflected ← declaration.type <$> get_decl nm,

-- --   _inst ← to_expr ``(has_from_json %%nm) >>= mk_instance,
-- --   _inst2 ← to_expr ``(has_reflect %%nm) >>= mk_instance,
-- --   to_expr ``(has_from_json.from_json _ %%_inst %%arg)
-- --   -- to_expr ``(has_from_json.from_json %%_inst $ %%arg)
-- --   }
-- | exc := tactic.fail format!"[json_to_expr] unexpected: {exc}"

meta def json_to_expr : Π (arg : json), tactic unit
| (json.array $ [nm_json, json.array args]) := do {
  -- let c_nm := hacky_name_from_string c,
  c_nm ← (has_from_json_name_aux nm_json),
  constr ← mk_const c_nm,
  if args.length = 0 then do {
  tp ← tactic.infer_type constr,
  e_id ← to_expr ``(@id %%tp),
  tactic.apply (e_id.mk_app [constr]) *> pure ()
  }
  else do
  -- tactic.apply constr.mk_app <$> (args.mmap json_to_expr)
  tactic.apply constr,
  args.mmap' json_to_expr
}
| arg@(json.of_int k) := do { -- WARNING: this is a hack for now
  tactic.exact `(int.to_nat k)
}
| exc@(json.array $ x@(((json.of_string c))::rest)) := if ("name" < c) then do nm ← has_from_json_name_aux x, tactic.exact ((by apply_instance : has_reflect name) nm) else tactic.fail format!"[json_to_expr.name] unexpected: {exc}"
-- | arg@(json.of_bool b) := do { -- WARNING: this is a hack for now
--   pure `(tt)
-- }
-- -- TODO(jesse): as needed, built special built-in logic to handle constants
-- -- TODO(jesse): use `resolve_name` on `nm` to get the `has_from_json` instance
-- -- then make a recursive call with `json_to_expr`
-- -- better yet, move this logic into `mk_from_json`

-- | arg@(json.object [("builtin", nm_json), ("val", val_json)]) := do {
--   env ← get_env,
--   nm ← (has_from_json_name_aux nm_json),
--   -- d ← env.get nm,
--   ty_reflected ← declaration.type <$> get_decl nm,

--   _inst ← to_expr ``(has_from_json %%nm) >>= mk_instance,
--   _inst2 ← to_expr ``(has_reflect %%nm) >>= mk_instance,
--   to_expr ``(has_from_json.from_json _ %%_inst %%arg)
--   -- to_expr ``(has_from_json.from_json %%_inst $ %%arg)
--   }
| exc := tactic.fail format!"[json_to_expr] unexpected: {exc}"

/- TODO(jesse): probably a better, recursive/lazy way of doing this -/
meta def mk_from_json (pre : option name) : tactic unit := do {
  (x::_) ← tactic.intro_lst [`_arg],
  real_tgt@`(tactic %%tgt) ← target,
  y ← to_expr ``(json_to_expr %%x),
  -- let real_tgt := ``(reflected $ tactic %%tgt),

  -- _ ← to_expr ``(do %%y >>= eval_expr unit),
  -- tactic.read >>= λ ts, tactic.trace format!"TACTIC STATE AFTER EVAL: {ts}",
  -- pure ()
  -- tac ← eval_expr (tactic unit) y,
  -- tac
  -- `(tactic %%tgt) ← target,
  -- -- y ← to_expr ``(@id (tactic %%tgt)) >>= (λ f, pure $ f.mk_app [y]),
  -- -- tactic.trace format!"OK?: {y}",
  -- -- tactic.unfreeze_local_instances,

  -- OK, i think this approach was the right one since `eval_expr` has type exactly `tactic alpha`
  -- although maybe we could also do... pure?
  -- before this line, y is a reflection of `json_to_expr %%x`, which returns an expr which is supposed to be the target
  -- to force this to evaluate, we turns this entire thing into a thing of type tactic tgt,

  -- result ← to_expr ``(do %%y >>= eval_expr %%tgt),
  gs ← tactic.get_goals,

  -- m ← tactic.mk_meta_var real_tgt,
  -- let m' := `([m]).to_expr,

  -- result ← to_expr ``(do %%y >>= eval_expr %%tgt),
  -- this doesn't work because `y` is just `json_to_expr %%x`, which contains the open variable `%%x`
  -- result ← to_expr ``(do %%y) >>= eval_expr expr,

  result ← to_expr ``(do try trivial, m ← mk_mvar, set_goals [m], %%y, tactic.get_assignment m >>= eval_expr %%tgt),
  tactic.exact result *> done
  -- (eval_expr json x) >>= json_to_expr
}

-- #check get_constr_and_args
-- meta def mk_from_json (pre : option name) : tactic unit := do {
--   (x::_) ← tactic.intro_lst [`_arg],
--   let rec := `(pure () : tactic unit).to_expr,
--   f ← to_expr ``(match (get_constr_and_args %%x) with
--   | (some ⟨constr, args⟩) := %%rec
--   | none := tactic.fail "[mk_from_json] unexpected failure"
--   end),
--   tactic.fail "NYI"

-- -- (constr, args))
-- }

meta def derive_has_from_json (pre : option name) : tactic unit := do {
  vs ← local_context,
  `(has_from_json %%f) ← target,
  env ← get_env,
  let n := f.get_app_fn.const_name,
  d ← get_decl n,
  refine ``( { from_json := _ } ),
  tgt ← target,
  let extract_def_nm := (with_prefix pre n <.> "from_json"),
  extract_def extract_def_nm ff $ mk_from_json n
}

meta def has_from_json_derive_handler' (nspace : option name := none) : derive_handler :=
higher_order_derive_handler ``has_from_json (derive_has_from_json nspace) [] nspace

@[derive_handler]
meta def has_from_json_derive_handler : derive_handler :=
guard_class ``has_from_json has_from_json_derive_handler'

end interactive

end tactic

end derive_from_json

section test

-- @[derive [has_to_tactic_json, has_from_json]]

inductive my_nat' : Type
-- /- `(x : α)` -/
-- | foo : DUH'
-- /- `{x : α}` -/
| bar : my_nat'
| baz : my_nat' → my_nat'
-- /- `⦃x:α⦄` -/
-- | strict_implicit : DUH'
-- /- `[x : α]`. Should be inferred with typeclass resolution. -/
-- | inst_implicit : DUH'
-- /- Auxiliary internal attribute used to mark local constants representing recursive functions
--         in recursive equations and `match` statements. -/
-- | aux_decl : DUH'

attribute [derive has_to_tactic_json] my_nat'
attribute [derive has_from_json] my_nat'

attribute [derive [has_reflect]] my_nat
attribute [derive [has_to_tactic_json]] my_nat
attribute [derive [has_from_json]] my_nat

-- run_cmd (has_to_tactic_json.to_tactic_json (my_nat.zero) >>= (has_from_json.from_json : json → tactic my_nat) >>= tactic.trace)

-- meta instance : has_to_format my_nat :=
-- ⟨λ x, match x with | my_nat.zero := "my_nat.zero" | (my_nat.succ x) := "my_nat.succ " ++ (by exact _match x) end⟩

-- meta instance : has_from_json my_nat :=
-- ⟨λ k,
-- -- match k with
-- -- | (json.object $ [("constr", c), ("args", (json.array args))]) := do
-- --   nm ← has_from_json_name_aux c,
-- --   match nm with
-- --   | `my_nat.zero := pure $ my_nat.zero
-- --   | `my_nat.succ := my_nat.succ <$> begin dedup, exact _match args.head end
-- --   | exc := tactic.fail format!"unexpected constructor: {exc}"
-- --   end
-- -- | exc := tactic.fail format!"unexpected: {exc}"
-- -- end
-- by do {tactic.interactive.json_to_expr begin exact k end >>= tactic.exact}
-- ⟩

-- run_cmd (has_to_tactic_json.to_tactic_json (my_nat.succ $ my_nat.succ $ my_nat.zero) >>= tactic.trace)

-- run_cmd (has_to_tactic_json.to_tactic_json (my_nat.succ $ my_nat.succ $ my_nat.zero) >>= (has_from_json.from_json : json → tactic my_nat) >>= tactic.trace)

@[derive [has_to_tactic_json, has_from_json]]
inductive my_tree : Type
| leaf : my_nat → my_tree
| node : my_tree → my_tree → my_nat → my_tree

meta instance : has_to_format my_tree :=
⟨λ t, match t with
| (my_tree.leaf k) := format!"(leaf {k})"
| (my_tree.node t₁ t₂ k) := by exact format!"(node {_match t₁} {_match t₂} {k})"
end
⟩

def example_tree : my_tree := my_tree.node (my_tree.leaf my_nat.zero) (my_tree.leaf my_nat.zero) my_nat.zero

-- run_cmd (has_to_tactic_json.to_tactic_json example_tree >>= tactic.trace)
-- run_cmd (has_to_tactic_json.to_tactic_json example_tree >>= (has_from_json.from_json : json → tactic my_tree) >>= tactic.trace)
end test

section instances

/-
WARNING: derived `has_to_tactic_json` and `has_from_json` instances are not guaranteed to be inverses
this can be resolved by enforcing special logic in the `has_from_json` derive handler
-/

-- meta instance : has_to_tactic_json nat :=
-- ⟨has_to_tactic_json.to_tactic_json ∘ int.of_nat⟩

-- TODO(jesse): this is insane! write the special logic.
-- attribute [derive [has_to_tactic_json, has_from_json]] nat
meta instance : has_to_tactic_json nat :=
⟨pure ∘ json.of_int ∘ int.of_nat⟩

attribute [derive has_from_json] nat -- handled by special logic in `mk_from_json`

-- run_cmd (has_to_tactic_json.to_tactic_json 3 >>=
--  λ x, tactic.trace x *> ((has_from_json.from_json : json → tactic ℕ) x >>= tactic.trace))

-- meta instance : has_from_json nat :=
-- ⟨λ msg,
--   match msg with
--   | (json.of_int (int.of_nat k)) := pure k
--   | exc := tactic.fail format!"[has_from_json_nat] unexpected: {exc}"
--   end
-- ⟩

-- meta instance : has_to_tactic_json unsigned :=
-- ⟨has_to_tactic_json.to_tactic_json ∘ unsigned.to_nat⟩

meta instance : has_from_json unsigned :=
⟨λ msg,
  match msg with
  | (json.of_int (int.of_nat k)) := pure $ unsigned.of_nat k
  | exc := tactic.fail format!"[has_from_json_unsigned] unexpected: {exc}"
  end
⟩

meta instance has_to_tactic_json_list {α} [h : has_to_tactic_json α] : has_to_tactic_json (list α) :=
⟨by mk_to_tactic_json name.anonymous⟩
universe u
-- meta instance has_from_json_list {α : Type u} [reflected α] [h : has_from_json α] : has_from_json (list α) :=
-- ⟨by mk_from_json name.anonymous⟩
-- set_option formatter.hide_full_terms false
-- run_cmd (has_to_tactic_json.to_tactic_json [1,2] >>= λ x, tactic.trace x *> (has_from_json.from_json : json → tactic (list ℕ)) x)

meta instance has_from_json_list {α} [H : has_from_json α] : has_from_json (list α) :=
⟨λ msg, do
let ⟨fn⟩ := H in
match msg with
| (json.array $ [c, json.array args]) := do
  c_nm ← has_from_json_name_aux c,
  if c_nm = `list.nil then pure [] else
  if c_nm = `list.cons then (::) <$> fn args.head <*> do x ← (args.nth 1), (by exact _match x) else
  tactic.fail format!"[has_from_json_list] unexpected {msg}"
| exc := tactic.fail "[has_from_json_list] unexpected {exc}"
end
⟩

-- run_cmd (has_to_tactic_json.to_tactic_json 2 >>= (has_from_json.from_json : json → tactic ℕ) >>= tactic.trace)

-- run_cmd (has_to_tactic_json.to_tactic_json [1,2] >>= λ x, tactic.trace x *> (has_from_json_list.from_json : json → tactic (list ℕ)) x >>= tactic.trace)

meta instance has_to_tactic_json_option {α} [has_to_tactic_json α] : has_to_tactic_json (option α) :=
⟨by mk_to_tactic_json name.anonymous⟩

meta instance has_from_json_option {α} [H : has_from_json α] : has_from_json (option α) :=
⟨λ msg, do
let ⟨fn⟩ := H in
match msg with
| (json.array $ [c, json.array args]) := do
  c_nm ← has_from_json_name_aux c,
  if c_nm = `option.none then pure none else
  if c_nm = `option.some then option.some <$> fn args.head else
  tactic.fail format!"[has_from_json_option] unexpected {msg}"
| exc := tactic.fail "[has_from_json_option] unexpected {exc}"
end
⟩

-- run_cmd (has_to_tactic_json.to_tactic_json (some [1,2]) >>= λ x, tactic.trace x *> (has_from_json.from_json : json → tactic (option $ list ℕ)) x >>= tactic.trace) -- sweet

meta instance has_to_tactic_json_prod {α β} [has_to_tactic_json α] [has_to_tactic_json β] : has_to_tactic_json (α × β) :=
⟨by mk_to_tactic_json name.anonymous⟩

meta instance has_from_json_prod {α β : Type} [H : has_from_json α] [H' : has_from_json β] : has_from_json (prod α β) :=
⟨λ msg, do
let ⟨fn₁⟩ := H in
let ⟨fn₂⟩ := H' in
match msg with
| (json.array $ [c, json.array args]) := do
  (c_nm : name) ← has_from_json_name_aux c,
  if c_nm = `prod.mk then prod.mk <$> (args.nth 0 >>= fn₁) <*> (args.nth 1 >>= fn₂) else
  tactic.fail format!"[has_from_json_prod] unexpected {msg}"
| exc := tactic.fail "[has_from_json_prod] unexpected {exc}"
end
⟩

attribute [derive [has_to_format]] binder_info
attribute [derive [has_to_tactic_json, has_from_json, has_reflect]] level
attribute [derive [has_to_tactic_json, has_from_json]] binder_info

section expr'

meta inductive expr'
| var         : nat → expr'
| sort        : level → expr'
| const       : name → list level → expr'
| mvar        (unique : name)  (pretty : name)  (type : expr') : expr'
| local_const (unique : name) (pretty : name) (bi : binder_info) (type : expr') : expr'
| app         : expr' → expr' → expr'
| lam        (var_name : name) (bi : binder_info) (var_type : expr') (body : expr') : expr'
| pi         (var_name : name) (bi : binder_info) (var_type : expr') (body : expr') : expr'
| elet       (var_name : name) (type : expr') (assignment : expr') (body : expr') : expr'

attribute [derive [has_to_tactic_json, has_from_json, has_reflect]] expr'

-- #check (by apply_instance : has_from_json expr')

attribute [derive [has_to_format]] expr'

meta def expr'.to_expr : expr' → expr
| (expr'.var k) := expr.var k
| (expr'.sort l) := (expr.sort l)
| (expr'.const n ls) := (expr.const n ls)
| (expr'.mvar un pr ty) := (expr.mvar un pr $ expr'.to_expr ty)
| (expr'.local_const un pr bi ty) := (expr.local_const un pr bi $ expr'.to_expr ty)
| (expr'.app e₁ e₂) := (expr.app (expr'.to_expr e₁) (expr'.to_expr e₂))
| (expr'.lam nm bi tp body) := (expr.lam nm bi (expr'.to_expr tp) (expr'.to_expr body))
| (expr'.pi nm bi tp body) := (expr.pi nm bi (expr'.to_expr tp) (expr'.to_expr body))
| (expr'.elet nm tp assn body) := (expr.elet nm (expr'.to_expr tp) (expr'.to_expr assn) (expr'.to_expr body))

-- meta def expr'.to_expr : expr' → tactic expr := λ x, tactic.trace "CONVERTING TO EXPR" *> (x.to_expr)

meta def expr.to_expr' : expr → tactic expr'
| (expr.var k) := pure $ expr'.var k
| (expr.sort l) := pure $ (expr'.sort l)
| (expr.const n ls) := pure $ (expr'.const n ls)
| (expr.mvar un pr ty) := (expr'.mvar un pr <$> expr.to_expr' ty)
| (expr.local_const un pr bi ty) := (expr'.local_const un pr bi <$> expr.to_expr' ty)
| (expr.app e₁ e₂) := (expr'.app <$> (expr.to_expr' e₁) <*> (expr.to_expr' e₂))
| (expr.lam nm bi tp body) := (expr'.lam nm bi <$> (expr.to_expr' tp) <*> (expr.to_expr' body))
| (expr.pi nm bi tp body) := (expr'.pi nm bi <$> (expr.to_expr' tp) <*> (expr.to_expr' body))
| (expr.elet nm tp assn body) := (expr'.elet nm <$> (expr.to_expr' tp) <*> (expr.to_expr' assn) <*> (expr.to_expr' body))
| (expr.macro md es) := tactic.fail "[expr.to_expr'] no macros allowed!"

-- @[instance, priority 9000]
-- meta def has_from_json_expr' : has_from_json expr' :=
-- ⟨λ msg, match msg with
--   | (json.object $ [("constr", c), ("args", json.array args)]) := do
--     (c_nm : name) ← has_from_json_name_aux c,
--     -- tactic.trace "NAME MSG:" *> tactic.trace nm_msg,
--     if c_nm = `expr'.const then do [nm_msg, levels_msg] ← pure args, result ← expr'.const <$> has_from_json_name_aux nm_msg <*> @has_from_json.from_json (list level) (by apply_instance : has_from_json (list level)) levels_msg, tactic.trace format!"[has_from_json_expr'] RESULT: {result}", result.to_expr.to_expr' else
--     -- tactic.fail format!"[has_from_json_expr'] unexpected: {msg}"
--     @has_from_json.from_json _ expr'.has_from_json msg
--   | exc := tactic.fail format!"[has_from_json_expr'] OH NO unexpected: {exc}"
-- end
-- ⟩

end expr'

meta instance : has_to_tactic_json expr :=
⟨λ e, e.erase_annotations.to_expr' >>= has_to_tactic_json.to_tactic_json⟩

meta instance : has_from_json expr :=
⟨λ msg, expr'.to_expr <$> (has_from_json.from_json : json → tactic expr') msg⟩

-- run_cmd (has_to_tactic_json.to_tactic_json `(2).to_expr >>= tactic.trace) -- interesting

-- #check expr
-- open tactic.interactive

-- run_cmd (has_to_tactic_json.to_tactic_json `foo.bar.baz >>= (λ x, tactic.trace x *> ((has_from_json.from_json : json → tactic name) x >>= tactic.trace)))

-- private theorem foo {p q : Prop} : p → q → ∀ r, (p ∧ q) ∨ r :=
-- λ h₁ h₂ h₃, or.inl (and.intro ‹_› ‹_›)

meta instance : has_to_tactic_json bool := ⟨λ b, pure ↑b⟩
meta instance : has_from_json bool := ⟨λ msg, match msg with
| (json.of_bool b) := pure b
| exc := tactic.fail format!"[has_from_json_bool] unexpected: {exc}"
end
⟩

end instances
-- #check tactic.set_env_core


import Cat

def main : IO Unit :=
  IO.println s!"lif sux"

theorem easy : True := by
  have nested (n : Nat) : True := by