/-
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.CollectMVars
import Lean.Meta.Tactic.Apply
import Lean.Meta.Tactic.Constructor
import Lean.Meta.Tactic.Assert
import Lean.Elab.Tactic.Basic
import Lean.Elab.SyntheticMVars

namespace Lean.Elab.Tactic
open Meta

/- `elabTerm` for Tactics and basic tactics that use it. -/

def elabTerm (stx : Syntax) (expectedType? : Option Expr) (mayPostpone := false) : TacticM Expr := do
  /- We have disabled `Term.withoutErrToSorry` to improve error recovery.
     When we were using it, any tactic using `elabTerm` would be interrupted at elaboration errors.
     Tactics that do not want to proceed should check whether the result contains sythetic sorrys or
     disable `errToSorry` before invoking `elabTerm` -/
  withRef stx do -- <| Term.withoutErrToSorry do
    let e ← Term.elabTerm stx expectedType?
    Term.synthesizeSyntheticMVars mayPostpone
    instantiateMVars e

def elabTermEnsuringType (stx : Syntax) (expectedType? : Option Expr) (mayPostpone := false) : TacticM Expr := do
  let e ← elabTerm stx expectedType? mayPostpone
  -- We do use `Term.ensureExpectedType` because we don't want coercions being inserted here.
  match expectedType? with
  | none => return e
  | some expectedType =>
    let eType ← inferType e
    unless (← isDefEq eType expectedType) do
      Term.throwTypeMismatchError none expectedType eType e
    return e

/- Try to close main goal using `x target`, where `target` is the type of the main goal.  -/
def closeMainGoalUsing (x : Expr → TacticM Expr) (checkUnassigned := true) : TacticM Unit :=
  withMainContext do
    closeMainGoal (checkUnassigned := checkUnassigned) (← x (← getMainTarget))

private def logUnassignedAndAbort (mvarIds : Array MVarId) : TacticM Unit := do
   if (← Term.logUnassignedUsingErrorInfos mvarIds) then
     throwAbortTactic

@[builtinTactic «exact»] def evalExact : Tactic := fun stx =>
  match stx with
  | `(tactic| exact $e) => closeMainGoalUsing (checkUnassigned := false) fun type => do
    let r ← elabTermEnsuringType e type
    logUnassignedAndAbort (← getMVars r)
    return r
  | _ => throwUnsupportedSyntax

def elabTermWithHoles (stx : Syntax) (expectedType? : Option Expr) (tagSuffix : Name) (allowNaturalHoles := false) : TacticM (Expr × List MVarId) := do
  let val ← elabTermEnsuringType stx expectedType?
  let newMVarIds ← getMVarsNoDelayed val
  /- ignore let-rec auxiliary variables, they are synthesized automatically later -/
  let newMVarIds ← newMVarIds.filterM fun mvarId => return !(← Term.isLetRecAuxMVar mvarId)
  let newMVarIds ←
    if allowNaturalHoles then
      pure newMVarIds.toList
    else
      let naturalMVarIds ← newMVarIds.filterM fun mvarId => return (← getMVarDecl mvarId).kind.isNatural
      let syntheticMVarIds ← newMVarIds.filterM fun mvarId => return !(← getMVarDecl mvarId).kind.isNatural
      logUnassignedAndAbort naturalMVarIds
      pure syntheticMVarIds.toList
  tagUntaggedGoals (← getMainTag) tagSuffix newMVarIds
  pure (val, newMVarIds)

/- If `allowNaturalHoles == true`, then we allow the resultant expression to contain unassigned "natural" metavariables.
   Recall that "natutal" metavariables are created for explicit holes `_` and implicit arguments. They are meant to be
   filled by typing constraints.
   "Synthetic" metavariables are meant to be filled by tactics and are usually created using the synthetic hole notation `?<hole-name>`. -/
def refineCore (stx : Syntax) (tagSuffix : Name) (allowNaturalHoles : Bool) : TacticM Unit := do
  withMainContext do
    let (val, mvarIds') ← elabTermWithHoles stx (← getMainTarget) tagSuffix allowNaturalHoles
    assignExprMVar (← getMainGoal) val
    replaceMainGoal mvarIds'

@[builtinTactic «refine»] def evalRefine : Tactic := fun stx =>
  match stx with
  | `(tactic| refine $e) => refineCore e `refine (allowNaturalHoles := false)
  | _                    => throwUnsupportedSyntax

@[builtinTactic «refine'»] def evalRefine' : Tactic := fun stx =>
  match stx with
  | `(tactic| refine' $e) => refineCore e `refine' (allowNaturalHoles := true)
  | _                     => throwUnsupportedSyntax

/--
   Given a tactic
   ```
   apply f
   ```
   we want the `apply` tactic to create all metavariables. The following
   definition will return `@f` for `f`. That is, it will **not** create
   metavariables for implicit arguments.
   A similar method is also used in Lean 3.
   This method is useful when applying lemmas such as:
   ```
   theorem infLeRight {s t : Set α} : s ⊓ t ≤ t
   ```
   where `s ≤ t` here is defined as
   ```
   ∀ {x : α}, x ∈ s → x ∈ t
   ```
-/
def elabTermForApply (stx : Syntax) : TacticM Expr := do
  if stx.isIdent then
    match (← Term.resolveId? stx (withInfo := true)) with
    | some e => return e
    | _      => pure ()
  elabTerm stx none (mayPostpone := true)

def evalApplyLikeTactic (tac : MVarId → Expr → MetaM (List MVarId)) (e : Syntax) : TacticM Unit := do
  withMainContext do
    let val  ← elabTermForApply e
    let mvarIds'  ← tac (← getMainGoal) val
    Term.synthesizeSyntheticMVarsNoPostponing
    replaceMainGoal mvarIds'

@[builtinTactic Lean.Parser.Tactic.apply] def evalApply : Tactic := fun stx =>
  match stx with
  | `(tactic| apply $e) => evalApplyLikeTactic Meta.apply e
  | _ => throwUnsupportedSyntax

@[builtinTactic Lean.Parser.Tactic.constructor] def evalConstructor : Tactic := fun stx =>
  withMainContext do
    let mvarIds'  ← Meta.constructor (← getMainGoal)
    Term.synthesizeSyntheticMVarsNoPostponing
    replaceMainGoal mvarIds'

@[builtinTactic Lean.Parser.Tactic.existsIntro] def evalExistsIntro : Tactic := fun stx =>
  match stx with
  | `(tactic| exists $e) => evalApplyLikeTactic (fun mvarId e => return [(← Meta.existsIntro mvarId e)]) e
  | _ => throwUnsupportedSyntax

@[builtinTactic Lean.Parser.Tactic.withReducible] def evalWithReducible : Tactic := fun stx =>
  withReducible <| evalTactic stx[1]

@[builtinTactic Lean.Parser.Tactic.withReducibleAndInstances] def evalWithReducibleAndInstances : Tactic := fun stx =>
  withReducibleAndInstances <| evalTactic stx[1]

/--
  Elaborate `stx`. If it a free variable, return it. Otherwise, assert it, and return the free variable.
  Note that, the main goal is updated when `Meta.assert` is used in the second case. -/
def elabAsFVar (stx : Syntax) (userName? : Option Name := none) : TacticM FVarId :=
  withMainContext do
    let e ← elabTerm stx none
    match e with
    | Expr.fvar fvarId _ => pure fvarId
    | _ =>
      let type ← inferType e
      let intro (userName : Name) (preserveBinderNames : Bool) : TacticM FVarId := do
        let mvarId ← getMainGoal
        let (fvarId, mvarId) ← liftMetaM do
          let mvarId ← Meta.assert mvarId userName type e
          Meta.intro1Core mvarId preserveBinderNames
        replaceMainGoal [mvarId]
        return fvarId
      match userName? with
      | none          => intro `h false
      | some userName => intro userName true

@[builtinTactic Lean.Parser.Tactic.rename] def evalRename : Tactic := fun stx =>
  match stx with
  | `(tactic| rename $typeStx:term => $h:ident) => do
    withMainContext do
      let fvarId ← withoutModifyingState <| withNewMCtxDepth do
        let type ← elabTerm typeStx none (mayPostpone := true)
        let fvarId? ← (← getLCtx).findDeclRevM? fun localDecl => do
          if (← isDefEq type localDecl.type) then return localDecl.fvarId else return none
        match fvarId? with
        | none => throwError "failed to find a hypothesis with type{indentExpr type}"
        | some fvarId => return fvarId
      let lctxNew := (← getLCtx).setUserName fvarId h.getId
      let mvarNew ← mkFreshExprMVarAt lctxNew (← getLocalInstances) (← getMainTarget) MetavarKind.syntheticOpaque (← getMainTag)
      assignExprMVar (← getMainGoal) mvarNew
      replaceMainGoal [mvarNew.mvarId!]
  | _ => throwUnsupportedSyntax

/--
   Make sure `expectedType` does not contain free and metavariables.
   It applies zeta-reduction to eliminate let-free-vars.
-/
private def preprocessPropToDecide (expectedType : Expr) : TermElabM Expr := do
  let mut expectedType ← instantiateMVars expectedType
  if expectedType.hasFVar then
    expectedType ← zetaReduce expectedType
  if expectedType.hasFVar || expectedType.hasMVar then
    throwError "expected type must not contain free or meta variables{indentExpr expectedType}"
  return expectedType

@[builtinTactic Lean.Parser.Tactic.decide] def evalDecide : Tactic := fun stx =>
  closeMainGoalUsing fun expectedType => do
    let expectedType ← preprocessPropToDecide expectedType
    let d ← mkDecide expectedType
    let d ← instantiateMVars d
    let r ← withDefault <| whnf d
    unless r.isConstOf ``true do
      throwError "failed to reduce to 'true'{indentExpr r}"
    let s := d.appArg! -- get instance from `d`
    let rflPrf ← mkEqRefl (toExpr true)
    return mkApp3 (Lean.mkConst `ofDecideEqTrue) expectedType s rflPrf

private def mkNativeAuxDecl (baseName : Name) (type val : Expr) : TermElabM Name := do
  let auxName ← Term.mkAuxName baseName
  let decl := Declaration.defnDecl {
    name := auxName, levelParams := [], type := type, value := val,
    hints := ReducibilityHints.abbrev,
    safety := DefinitionSafety.safe
  }
  addDecl decl
  compileDecl decl
  pure auxName

@[builtinTactic Lean.Parser.Tactic.nativeDecide] def evalNativeDecide : Tactic := fun stx =>
  closeMainGoalUsing fun expectedType => do
    let expectedType ← preprocessPropToDecide expectedType
    let d ← mkDecide expectedType
    let auxDeclName ← mkNativeAuxDecl `_nativeDecide (Lean.mkConst `Bool) d
    let rflPrf ← mkEqRefl (toExpr true)
    let s := d.appArg! -- get instance from `d`
    return mkApp3 (Lean.mkConst `ofDecideEqTrue) expectedType s <| mkApp3 (Lean.mkConst `Lean.ofReduceBool) (Lean.mkConst auxDeclName) (toExpr true) rflPrf

end Lean.Elab.Tactic


/-
Copyright (c) 2021 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg, Asta Halkjær From
-/

import Lean.Elab.Syntax
import Lean.Elab.Tactic.Basic
import Lean.Message
import Lean.Meta.DiscrTree
import Lean.Meta.Tactic.Simp.SimpLemmas
import Lean.Syntax
import Std.Data.BinomialHeap

namespace String

def joinSep (sep : String)  : List String → String
  | [] => ""
  | "" :: ss => joinSep sep ss
  | s :: ss =>
    let tail := joinSep sep ss
    match tail with
    | "" => s
    | _ => s ++ sep ++ tail

end String

namespace Std.Format

@[inlineIfReduce]
def isEmptyShallow : Format → Bool
  | nil => true
  | text "" => true
  | _ => false

@[inline]
def indentDSkipEmpty [ToFormat α] (f : α) : Format :=
  let f := format f
  if f.isEmptyShallow then nil else indentD f

@[inline]
def unlines [ToFormat α] (fs : List α) : Format :=
  Format.joinSep fs line

@[inline]
def indentDUnlines [ToFormat α] : List α → Format :=
  indentDSkipEmpty ∘ unlines

@[inline]
def indentDUnlinesSkipEmpty [ToFormat α] (fs : List α) : Format :=
  indentDSkipEmpty $ unlines (fs.map format |>.filter (¬ ·.isEmptyShallow))

def formatIf (b : Bool) (f : Thunk Format) : Format :=
  if b then f.get else nil

end Std.Format

namespace Lean.MessageData

@[inline]
def join (ms : List MessageData) : MessageData :=
ms.foldl (· ++ ·) nil

@[inlineIfReduce]
def isEmptyShallow : MessageData → Bool
  | ofFormat f => f.isEmptyShallow
  | _ => false

@[inline]
def indentDSkipEmpty (m : MessageData) : MessageData :=
  if m.isEmptyShallow then nil else indentD m

@[inline]
def unlines (ms : List MessageData) : MessageData :=
  joinSep ms Format.line

@[inline]
def indentDUnlines : List MessageData → MessageData :=
  indentDSkipEmpty ∘ unlines

@[inline]
def indentDUnlinesSkipEmpty (fs : List MessageData) : MessageData :=
  indentDSkipEmpty $ unlines $ fs.filter (¬ ·.isEmptyShallow)

def toMessageDataIf (b : Bool) (f : Thunk MessageData) : MessageData :=
  if b then f.get else nil

def nodeFiltering (fs : Array (Option MessageData)) : MessageData :=
  node $ fs.filterMap id

end Lean.MessageData

namespace Std.PersistentHashSet

@[inline]
def merge [BEq α] [Hashable α] (s t : PersistentHashSet α) : PersistentHashSet α :=
  if s.size < t.size then loop s t else loop t s
  where
    @[inline]
    loop s t := s.fold (init := t) λ s a => s.insert a

-- Elements are returned in unspecified order.
def toList [BEq α] [Hashable α] (s : PersistentHashSet α) : List α :=
  s.fold (init := []) λ as a => a :: as

-- Elements are returned in unspecified order. (In fact, they are currently
-- returned in reverse order of `toList`.)
def toArray [BEq α] [Hashable α] (s : PersistentHashSet α) : Array α :=
  s.fold (init := #[]) λ as a => as.push a

end Std.PersistentHashSet

namespace Std.PersistentHashMap

@[inline]
def merge [BEq α] [Hashable α] (m n : PersistentHashMap α β) (f : α → β → β → β) :
    PersistentHashMap α β :=
  if m.size < n.size then loop m n f else loop n m (λ a b b' => f a b' b)
  where
    @[inline]
    loop m n f := m.foldl (init := n) λ map k v =>
      match map.find? k with
      | some v' => map.insert k (f k v v')
      | none => map.insert k v

end Std.PersistentHashMap

namespace Lean.Meta.DiscrTree.Trie

unsafe def foldMUnsafe [Monad m] (initialKeys : Array Key)
    (f : σ → Array Key → α → m σ) (init : σ) : Trie α → m σ
  | Trie.node vs children => do
    let s ← vs.foldlM (init := init) λ s v => f s initialKeys v
    children.foldlM (init := s) λ s (k, t) =>
      t.foldMUnsafe (initialKeys.push k) f s

@[implementedBy foldMUnsafe]
constant foldM [Monad m] (initalKeys : Array Key)
    (f : σ → Array Key → α → m σ) (init : σ) (t : Trie α) : m σ :=
  pure init

@[inline]
def fold (initialKeys : Array Key) (f : σ → Array Key → α → σ) (init : σ)
    (t : Trie α) : σ :=
  Id.run $ t.foldM initialKeys (init := init) λ s k a => return f s k a

end Trie

@[inline]
def foldM [Monad m] (f : σ → Array Key → α → m σ) (init : σ) (t : DiscrTree α) :
    m σ :=
  t.root.foldlM (init := init) λ s k t => t.foldM #[k] (init := s) f

@[inline]
def fold (f : σ → Array Key → α → σ) (init : σ) (t : DiscrTree α) : σ :=
  Id.run $ t.foldM (init := init) λ s keys a => return f s keys a

-- TODO inefficient since it doesn't take advantage of the Trie structure at all
@[inline]
def merge [BEq α] (t u : DiscrTree α) : DiscrTree α :=
  if t.root.size < u.root.size then loop t u else loop u t
  where
    @[inline]
    loop t u := t.fold (init := u) DiscrTree.insertCore

def values (t : DiscrTree α) : Array α :=
  t.fold (init := #[]) λ as _ a => as.push a

def toArray (t : DiscrTree α) : Array (Array Key × α) :=
  t.fold (init := #[]) λ as keys a => as.push (keys, a)

end DiscrTree

namespace SimpLemmas

def merge (s t : SimpLemmas) : SimpLemmas where
  pre := s.pre.merge t.pre
  post := s.post.merge t.post
  lemmaNames := s.lemmaNames.merge t.lemmaNames
  toUnfold := s.toUnfold.merge t.toUnfold
  erased := s.erased.merge t.erased

def addSimpEntry (s : SimpLemmas) : SimpEntry → SimpLemmas
  | SimpEntry.lemma l => addSimpLemmaEntry s l
  | SimpEntry.toUnfold d => s.addDeclToUnfold d

open MessageData in
protected def toMessageData (s : SimpLemmas) : MessageData :=
  node #[
    "pre lemmas:" ++ node (s.pre.values.map toMessageData),
    "post lemmas:" ++ node (s.post.values.map toMessageData),
    "definitions to unfold:" ++ node
      (s.toUnfold.toArray.qsort Name.lt |>.map toMessageData),
    "erased entries:" ++ node
      (s.erased.toArray.qsort Name.lt |>.map toMessageData)
  ]

end SimpLemmas

def copyMVar (mvarId : MVarId) : MetaM MVarId := do
  let decl ← getMVarDecl mvarId
  let mv ← mkFreshExprMVarAt decl.lctx decl.localInstances decl.type decl.kind
    decl.userName decl.numScopeArgs
  return mv.mvarId!

end Lean.Meta

namespace Std.BinomialHeap

@[inline]
def removeMin {lt : α → α → Bool} (h : BinomialHeap α lt) :
    Option (α × BinomialHeap α lt) :=
  match h.head? with
  | some hd => some (hd, h.tail)
  | none => none

end Std.BinomialHeap

namespace MonadStateOf

@[inline]
def ofLens [Monad m] [MonadStateOf α m] (project : α → β) (inject : β → α → α) :
    MonadStateOf β m where
  get := return project (← get)
  set b := modify λ a => inject b a
  modifyGet f := modifyGet λ a =>
    let (r, b) := f (project a)
    (r, inject b a)

end MonadStateOf

@[inline]
abbrev setThe (σ) {m} [MonadStateOf σ m] (s : σ) : m PUnit :=
  MonadStateOf.set s

namespace ST.Ref

variable {m} [Monad m] [MonadLiftT (ST σ) m]

@[inline]
unsafe def modifyMUnsafe (r : Ref σ α) (f : α → m α) : m Unit := do
  let v ← r.take
  r.set (← f v)

@[implementedBy modifyMUnsafe]
def modifyM (r : Ref σ α) (f : α → m α) : m Unit := do
  let v ← r.get
  r.set (← f v)

@[inline]
unsafe def modifyGetMUnsafe (r : Ref σ α) (f : α → m (β × α)) : m β := do
  let v ← r.take
  let (b, a) ← f v
  r.set a
  return b

@[implementedBy modifyGetMUnsafe]
def modifyGetM (r : Ref σ α) (f : α → m (β × α)) : m β := do
  let v ← r.get
  let (b, a) ← f v
  r.set a
  return b

end ST.Ref

namespace Lean.Meta

def instantiateMVarsMVarType (mvarId : MVarId) : MetaM Expr := do
  let type ← instantiateMVars (← getMVarDecl mvarId).type
  setMVarType mvarId type
  return type

end Lean.Meta

namespace Lean.Syntax

-- TODO for debugging, maybe remove
partial def formatRaw : Syntax → String
  | missing => "missing"
  | node kind args =>
    let args := ", ".joinSep $ args.map formatRaw |>.toList
    s!"(node {kind} [{args}])"
  | atom _ val => s!"(atom {val})"
  | ident _ _ val _ => s!"(ident {val})"

end Lean.Syntax

namespace Lean

open Lean.Elab.Tactic

def runTacticMAsMetaM (tac : TacticM Unit) (goal : MVarId) :
    MetaM (List MVarId) :=
  run goal tac |>.run'

def runMetaMAsImportM (x : MetaM α) : ImportM α := do
  let ctx : Core.Context := { options := (← read).opts }
  let state : Core.State := { env := (← read).env }
  let r ← x |>.run {} {} |>.run ctx state |>.toIO'
  match r with
  | Except.ok ((a, _), _) => pure a
  | Except.error e => throw $ IO.userError (← e.toMessageData.toString)

def runMetaMAsCoreM (x : MetaM α) : CoreM α :=
  Prod.fst <$> x.run {} {}

end Lean

namespace Lean.Elab.Command

syntax (name := syntaxCatWithUnreservedTokens)
  "declare_syntax_cat' " ident
    (&"allow_leading_unreserved_tokens" <|> &"force_leading_unreserved_tokens")? : command

-- Copied from Lean/Elab/Syntax.lean
private def declareSyntaxCatQuotParser (catName : Name) : CommandElabM Unit := do
  if let Name.str _ suffix _ := catName then
    let quotSymbol := "`(" ++ suffix ++ "|"
    let name := catName ++ `quot
    -- TODO(Sebastian): this might confuse the pretty printer, but it lets us reuse the elaborator
    let kind := ``Lean.Parser.Term.quot
    let cmd ← `(
      @[termParser] def $(mkIdent name) : Lean.ParserDescr :=
        Lean.ParserDescr.node $(quote kind) $(quote Lean.Parser.maxPrec)
          (Lean.ParserDescr.binary `andthen (Lean.ParserDescr.symbol $(quote quotSymbol))
            (Lean.ParserDescr.binary `andthen
              (Lean.ParserDescr.unary `incQuotDepth (Lean.ParserDescr.cat $(quote catName) 0))
              (Lean.ParserDescr.symbol ")"))))
    elabCommand cmd

open Lean.Parser (LeadingIdentBehavior) in
@[builtinCommandElab syntaxCatWithUnreservedTokens]
def elabDeclareSyntaxCatWithUnreservedTokens : CommandElab := fun stx => do
  let catName  := stx[1].getId
  let leadingIdentBehavior :=
    match stx[2].getOptional? with
    | none => LeadingIdentBehavior.default
    | some b =>
      match b.getAtomVal! with
      | "allow_leading_unreserved_tokens" => LeadingIdentBehavior.both
      | "force_leading_unreserved_tokens" => LeadingIdentBehavior.symbol
      | _ => unreachable!
  let attrName := catName.appendAfter "Parser"
  let env ← getEnv
  let env ←
    liftIO $ Parser.registerParserCategory env attrName catName
      leadingIdentBehavior
  setEnv env
  declareSyntaxCatQuotParser catName

end Lean.Elab.Command


inductive Wrapper where
  | wrap: Wrapper

def Wrapper.extend: Wrapper → (Unit × Unit)
  | .wrap => ((), ())

mutual
inductive Op where
  | mk: String → Block → Op

inductive Assign where
  | mk : String → Op → Assign

inductive Block where
  | mk: Assign → Block
  | empty: Block
end

mutual
def runOp: Op → Wrapper
  | .mk _ r => let r' := runBlock r; .wrap

def runAssign: Assign → Wrapper
  | .mk _ op => runOp op

def runBlock: Block → Wrapper
  | .mk a => runAssign a
  | .empty => .wrap
end

private def b: Assign := .mk "r" (.mk "APrettyLongString" .empty)

theorem bug: (runAssign b).extend.snd = (runAssign b).extend.snd := by
  --unfold b -- extremely slow
  sorry


import GMLInit.Meta.Prelude
import GMLInit.Logic.Cast
import GMLInit.Logic.Congr
import GMLInit.Logic.HEq
import Lean

open Lean
open Lean.Meta
open Lean.Parser.Tactic (location)
open Lean.Elab
open Lean.Elab.Tactic (Location expandLocation joinLocation)

namespace Meta

syntax termOrHole := term <|> hole <|> syntheticHole

syntax termList := "[" (term <|> hole <|> syntheticHole),* ("|" (term <|> hole <|> syntheticHole))? "]"

macro mods:declModifiers "lemma" n:declId sig:declSig val:declVal : command =>
  `($mods:declModifiers theorem $n $sig $val)

syntax (name := clean) "clean " (colGt tactic)? (colGe location)? : tactic
macro_rules
| `(tactic| clean $[$loc:location]?) =>
  `(tactic| simp only [clean] $[$loc]?)
| `(tactic| clean $tac $[$loc:location]?) => do
  let mut loc : Location := match loc with
  | some loc => expandLocation loc
  | none => .targets #[] false
  for stx in Lean.Syntax.filter tac fun stx => stx.getKind == ``location do
    loc := joinLocation loc (expandLocation stx)
  match loc with
  | .wildcard =>
    `(tactic| $tac; simp only [clean] at *)
  | .targets hs true =>
    let locs := hs.map Lean.TSyntax.mk
    `(tactic| $tac; simp only [clean] at $[$locs]* ⊢)
  | .targets hs false =>
    let locs := hs.map Lean.TSyntax.mk
    `(tactic| $tac; simp only [clean] at $[$locs]*)

syntax "elim_casts" (location)? : tactic
set_option hygiene false in macro_rules
| `(tactic| elim_casts $[$loc]?) =>
  `(tactic| first | rw [←heq_iff_eq] $[$loc]?; simp only [elim_casts] $[$loc]?; rw [heq_iff_eq] $[$loc]? | simp only [elim_casts] $[$loc]?)

macro "exfalso" : tactic => `(tactic| apply False.elim)

macro "absurd " h:term : tactic => `(tactic| first | apply absurd _ $h | apply absurd $h)

def Tactic.constr (mvarId : MVarId) : MetaM (List MVarId) := do
  mvarId.withContext do
    mvarId.checkNotAssigned `constr
    let target ← mvarId.getType'
    matchConstStruct target.getAppFn
      (fun _ => throwTacticEx `constr mvarId "target is not an inductive datatype with one constructor")
      fun _ us cval => do
        let ctor := mkAppN (Lean.mkConst cval.name us) target.getAppArgs[:cval.numParams]
        let ctorType ← inferType ctor
        let (mvars, _, _) ← forallMetaTelescopeReducing ctorType (some cval.numFields)
        mvarId.apply <| mkAppN ctor mvars

elab "constr" : tactic => Tactic.withMainContext do
  let gs ← Tactic.constr (← Tactic.getMainGoal)
  Term.synthesizeSyntheticMVarsNoPostponing
  Tactic.replaceMainGoal gs

def Tactic.left (mvarId : MVarId) : MetaM (List MVarId) := do
  mvarId.withContext do
    mvarId.checkNotAssigned `left
    let target ← mvarId.getType'
    matchConstInduct target.getAppFn
      (fun _ => throwTacticEx `left mvarId "target is not an inductive datatype")
      fun ival us => do
        match ival.ctors with
        | [ctor,_] => mvarId.apply (mkConst ctor us)
        | _ => throwTacticEx `left mvarId "target is not an inductive datatype with two constructors"

elab "left" : tactic => Tactic.withMainContext do
  let gs ← Tactic.left (← Tactic.getMainGoal)
  Term.synthesizeSyntheticMVarsNoPostponing
  Tactic.replaceMainGoal gs

def Tactic.right (mvarId : MVarId) : MetaM (List MVarId) := do
  mvarId.withContext do
    mvarId.checkNotAssigned `right
    let target ← mvarId.getType'
    matchConstInduct target.getAppFn
      (fun _ => throwTacticEx `right mvarId "target is not an inductive datatype")
      fun ival us => do
        match ival.ctors with
        | [_,ctor] => mvarId.apply (mkConst ctor us)
        | _ => throwTacticEx `right mvarId "target is not an inductive datatype with two constructors"

elab "right" : tactic => Tactic.withMainContext do
  let gs ← Tactic.right (← Tactic.getMainGoal)
  Term.synthesizeSyntheticMVarsNoPostponing
  Tactic.replaceMainGoal gs

end Meta


import for_mathlib.composable_morphisms
import algebra.homology.additive
import for_mathlib.homological_complex_map_d_to_d_from

noncomputable theory

open category_theory category_theory.category category_theory.limits

variables {C D : Type*} [category C] [category D]

section

variables (C)

/- Category of complexes `X ⟶ Y ⟶ Z` -/
@[derive category]
def short_complex [has_zero_morphisms C] := full_subcategory $ λ S : composable_morphisms C, S.zero

end

open category_theory

namespace homological_complex

variables [has_zero_morphisms C] {M : Type*} {c : complex_shape M}

lemma prev_id (X : homological_complex C c) (i : M) : hom.prev (𝟙 X) i = 𝟙 (X.X_prev i) := rfl

lemma next_id (X : homological_complex C c) (i : M) : hom.next (𝟙 X) i = 𝟙 (X.X_next i) := rfl

lemma prev_comp {X Y Z : homological_complex C c} (f : X ⟶ Y) (g : Y ⟶ Z)
  (i : M) : hom.prev (f ≫ g) i = hom.prev f i ≫ hom.prev g i := rfl

lemma next_comp {X Y Z : homological_complex C c} (f : X ⟶ Y) (g : Y ⟶ Z)
  (i : M) : hom.next (f ≫ g) i = hom.next f i ≫ hom.next g i := rfl

end homological_complex

namespace short_complex

@[simp, reassoc]
lemma zero [has_zero_morphisms C] (S : short_complex C) : S.1.f ≫ S.1.g = 0 := S.2

@[simps]
def mk [has_zero_morphisms C] {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (zero : f ≫ g = 0) :
  short_complex C := ⟨composable_morphisms.mk f g, zero⟩

@[simp]
lemma mk_id_τ₁ [has_zero_morphisms C] {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (zero : f ≫ g = 0) :
composable_morphisms.hom.τ₁ (𝟙 (mk f g zero)) = 𝟙 X := rfl
@[simp]
lemma mk_id_τ₂ [has_zero_morphisms C] {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (zero : f ≫ g = 0) :
composable_morphisms.hom.τ₂ (𝟙 (mk f g zero)) = 𝟙 Y := rfl
@[simp]
lemma mk_id_τ₃ [has_zero_morphisms C] {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (zero : f ≫ g = 0) :
composable_morphisms.hom.τ₃ (𝟙 (mk f g zero)) = 𝟙 Z := rfl

@[simp]
lemma comp_τ₁ [has_zero_morphisms C] {S₁ S₂ S₃ : short_complex C} (f : S₁ ⟶ S₂) (g : S₂ ⟶ S₃) :
  (f ≫ g).τ₁ = f.τ₁ ≫ g.τ₁ := rfl
@[simp]
lemma comp_τ₂ [has_zero_morphisms C] {S₁ S₂ S₃ : short_complex C} (f : S₁ ⟶ S₂) (g : S₂ ⟶ S₃) :
  (f ≫ g).τ₂ = f.τ₂ ≫ g.τ₂ := rfl
@[simp]
lemma comp_τ₃ [has_zero_morphisms C] {S₁ S₂ S₃ : short_complex C} (f : S₁ ⟶ S₂) (g : S₂ ⟶ S₃) :
  (f ≫ g).τ₃ = f.τ₃ ≫ g.τ₃ := rfl

@[simps]
def hom_mk [has_zero_morphisms C] {X₁ Y₁ Z₁ X₂ Y₂ Z₂ : C} {f₁ : X₁ ⟶ Y₁} {g₁ : Y₁ ⟶ Z₁}
  {f₂ : X₂ ⟶ Y₂} {g₂ : Y₂ ⟶ Z₂} {zero₁ : f₁ ≫ g₁ = 0} {zero₂ : f₂ ≫ g₂ = 0}
  (τ₁ : X₁ ⟶ X₂) (τ₂ : Y₁ ⟶ Y₂) (τ₃ : Z₁ ⟶ Z₂) (comm₁₂ : f₁ ≫ τ₂ = τ₁ ≫ f₂)
  (comm₂₃ : g₁ ≫ τ₃ = τ₂ ≫ g₂) :
  mk f₁ g₁ zero₁ ⟶ mk f₂ g₂ zero₂ := ⟨τ₁, τ₂, τ₃, comm₁₂, comm₂₃⟩

@[simps]
def iso_mk [has_zero_morphisms C] {S₁ S₂ : short_complex C}
  (τ₁ : S₁.1.X ≅ S₂.1.X) (τ₂ : S₁.1.Y ≅ S₂.1.Y) (τ₃ : S₁.1.Z ≅ S₂.1.Z)
  (comm₁₂ : S₁.1.f ≫ τ₂.hom = τ₁.hom ≫ S₂.1.f)
  (comm₂₃ : S₁.1.g ≫ τ₃.hom = τ₂.hom ≫ S₂.1.g) :
  S₁ ≅ S₂ :=
{ hom := ⟨τ₁.hom, τ₂.hom, τ₃.hom, comm₁₂, comm₂₃⟩,
  inv := begin
    refine ⟨τ₁.inv, τ₂.inv, τ₃.inv, _, _⟩,
    { simp only [← cancel_mono τ₂.hom, ← cancel_epi τ₁.hom,
        assoc, iso.inv_hom_id, comp_id, iso.hom_inv_id_assoc, comm₁₂], },
    { simp only [← cancel_mono τ₃.hom, ← cancel_epi τ₂.hom,
        assoc, iso.inv_hom_id, comp_id, iso.hom_inv_id_assoc, comm₂₃], },
  end,
  hom_inv_id' := begin
    ext,
    { simpa only [comp_τ₁, hom_mk_τ₁, iso.hom_inv_id], },
    { simpa only [comp_τ₂, hom_mk_τ₂, iso.hom_inv_id], },
    { simpa only [comp_τ₃, hom_mk_τ₃, iso.hom_inv_id], },
  end,
  inv_hom_id' := begin
    ext,
    { simpa only [iso.inv_hom_id, comp_τ₁, hom_mk_τ₁], },
    { simpa only [iso.inv_hom_id, comp_τ₂, hom_mk_τ₂], },
    { simpa only [iso.inv_hom_id, comp_τ₃, hom_mk_τ₃], },
  end, }

lemma is_iso_of_is_isos [has_zero_morphisms C] {S₁ S₂ : short_complex C}
  (φ : S₁ ⟶ S₂) (h₁ : is_iso φ.τ₁) (h₂ : is_iso φ.τ₂) (h₃ : is_iso φ.τ₃) : is_iso φ :=
begin
  let e : S₁ ≅ S₂ := iso_mk (as_iso φ.τ₁) (as_iso φ.τ₂) (as_iso φ.τ₃) φ.comm₁₂ φ.comm₂₃,
  unfreezingI { rcases φ with ⟨τ₁, τ₂, τ₃, comm₁₂, comm₂₂⟩, },
  exact is_iso.of_iso e,
end

def homology [abelian C] (S : short_complex C) : C := homology S.1.f S.1.g S.2

@[simps]
def homology_functor [abelian C] : short_complex C ⥤ C :=
{ obj := λ X, X.homology,
  map := λ X Y φ, homology.map X.2 Y.2 ⟨φ.τ₁, φ.τ₂, φ.comm₁₂.symm⟩
    ⟨φ.τ₂, φ.τ₃, φ.comm₂₃.symm⟩ rfl,
  map_id' := λ X, by apply homology.map_id,
  map_comp' := λ X Y Z φ ψ, by { symmetry, apply homology.map_comp, }, }

variable (C)

@[simps]
def functor_homological_complex [has_zero_morphisms C]
  {M : Type*} (c : complex_shape M) (i : M) :
  homological_complex C c ⥤ short_complex C :=
{ obj := λ X, mk (X.d_to i) (X.d_from i) (X.d_to_comp_d_from i),
  map := λ X Y f, composable_morphisms.hom.mk (f.prev i) (f.f i) (f.next i)
    (f.comm_to i).symm (f.comm_from i).symm,
  map_id' := λ X, begin
    ext,
    { exact X.prev_id i, },
    { refl, },
    { exact X.next_id i, },
  end,
  map_comp' := λ X Y Z f g, begin
    ext,
    { exact homological_complex.prev_comp f g i, },
    { refl, },
    { exact homological_complex.next_comp f g i, },
  end, }

@[simps]
def homology_functor_iso [abelian C] {M : Type*} (c : complex_shape M) (i : M) :
  _root_.homology_functor C c i ≅
  functor_homological_complex C c i ⋙ short_complex.homology_functor :=
nat_iso.of_components (λ X, iso.refl _)
  (λ X Y f, by { ext, simpa only [iso.refl_hom, id_comp, comp_id], })

end short_complex

namespace category_theory

namespace functor

@[simps]
def map_short_complex [has_zero_morphisms C] [has_zero_morphisms D] (F : C ⥤ D)
  [F.preserves_zero_morphisms] :
  short_complex C ⥤ short_complex D :=
full_subcategory.lift _ (induced_functor _ ⋙ F.map_composable_morphisms)
(λ X, begin
  have h := X.2,
  dsimp [composable_morphisms.zero] at h ⊢,
  rw [← F.map_comp, h, F.map_zero],
end)

end functor

namespace nat_trans

@[simps]
def map_short_complex [has_zero_morphisms C] [has_zero_morphisms D] {F G : C ⥤ D}
  [F.preserves_zero_morphisms] [G.preserves_zero_morphisms] (φ : F ⟶ G) :
  F.map_short_complex ⟶ G.map_short_complex :=
{ app := λ X, ⟨φ.app _, φ.app _, φ.app _, φ.naturality _, φ.naturality _⟩, }

end nat_trans

end category_theory

open category_theory

namespace short_complex

variable {C}

def functor_homological_complex_map [preadditive C] [preadditive D] (F : C ⥤ D) [F.additive]
  {M : Type*} (c : complex_shape M) (i : M) :
short_complex.functor_homological_complex C c i ⋙ F.map_short_complex ≅
F.map_homological_complex c ⋙ short_complex.functor_homological_complex D c i :=
iso.refl _

variables [preadditive C] [preadditive D] {F G : C ⥤ D} [functor.additive F] [functor.additive G]
  {M : Type*} (c : complex_shape M) (i : M) (φ : F ⟶ G) (X : homological_complex C c)

lemma nat_trans.map_short_complex_app :
  (nat_trans.map_short_complex φ).app ((short_complex.functor_homological_complex C c i).obj X) =
  (short_complex.functor_homological_complex D c i).map
    ((nat_trans.map_homological_complex φ c).app X) := rfl

lemma naturality_functor_homological_complex_map :
  (nat_trans.map_short_complex φ).app
    ((short_complex.functor_homological_complex C c i).obj X) ≫
    (short_complex.functor_homological_complex_map G c i).hom.app X =
  (short_complex.functor_homological_complex_map F c i).hom.app X ≫
    (short_complex.functor_homological_complex D c i).map
      ((nat_trans.map_homological_complex φ c).app X) :=
begin
  dsimp only [functor_homological_complex_map, iso.refl_hom, nat_trans.id_app],
  erw [nat_trans.map_short_complex_app, category.id_comp, category.comp_id],
end

end short_complex


import LeanCodePrompts.CheckParse
import Lean
open Lean Meta Parser Elab Tactic

def contractInductionStx (tac : Syntax) : MetaM Syntax := do
match tac with
| `(tactic| induction $name $_:inductionAlts) =>
  `(tactic| induction $name)
| `(tactic| cases $name $_:inductionAlts) =>
  `(tactic| cases $name)
| _ => return tac

def contractPolyTactic (tac: String): String :=
  if tac.contains ',' then
    let head := tac.splitOn "," |>.head!
    if head.contains '['
      then head ++ "]"
      else tac
  else tac

def partialParser  (parser : Parser) (input : String) (fileName := "<input>") : MetaM <| Option (Syntax × String × String) := do
  let env ← getEnv
  -- let c := mkParserContext (mkInputContext input fileName) { env := env, options := {} }
  let p := andthenFn whitespace parser.fn
  let ictx := mkInputContext input fileName
  let s := p.run ictx { env, options := {} } (getTokenTable env) (mkParserState input)
  let stack := s.stxStack.toSubarray.as.filter fun s => !s.hasMissing
  if stack.isEmpty &&  s.hasError then
    return    none
  else
    -- IO.println s!"errors: {s.errorMsg}"
    let head := input.extract 0 s.pos
    let stx := stack.back
    return some (stx, head, input.drop head.length)

declare_syntax_cat defHead
syntax "theorem" : defHead
syntax "def" : defHead
syntax "lemma" : defHead
syntax "instance" : defHead
syntax "example" : defHead

declare_syntax_cat theoremAndTactic

syntax
  defHead (ident)? (argument)* ":" term ":=" "by" tacticSeq : theoremAndTactic

declare_syntax_cat variableStatement
syntax "variable" (argument)* : variableStatement

declare_syntax_cat sectionHead
syntax "section" (colGt ident)? : sectionHead

declare_syntax_cat sectionEnd
syntax "end" (ident)? : sectionEnd

-- code from Leo de Moura
def getTactics (s : TSyntax ``tacticSeq) : Array (TSyntax `tactic) :=
  match s with
  | `(tacticSeq| { $[$t]* }) => t
  | `(tacticSeq| $[$t]*) => t
  | _ => #[]

def parseTactics (s: String) : MetaM <| Array Syntax := do
  match ← partialParser tacticSeq s with
  | some (stx, _, _) =>
    let seq := getTactics stx
    IO.println seq[0]!.raw.reprint.get!
    return seq
  | none => return #[]

def parseTactics? (s: String) : MetaM <| Option <| Array Syntax := do
  let parsed? ← partialParser tacticSeq s
  let seq := parsed?.map fun (stx, _, _) => getTactics stx
  return seq

def parseTacticBlocks(s: String) : MetaM <| List <| Array String := do
  let blocks := s.splitOn "by" |>.tailD []
  let stxs ←  blocks.filterMapM fun b => parseTactics? b
  return stxs.map (fun arr =>
    arr.map (fun stx => stx.reprint.getD "" |>.trim))

structure TheoremAndTactic where
  kind: String
  name: String
  args: String
  type: String
  firstTactic : String
deriving Repr

namespace TheoremAndTactic

def corePrompt (x: TheoremAndTactic) : String :=
  s!"{x.args} : {x.type}"

def tacticPrompt (x: TheoremAndTactic) : String :=
  s!"{x.kind} {x.corePrompt} := by {x.firstTactic}; sorry"

def toJson (x: TheoremAndTactic) : Json :=
  Json.mkObj [
    ("kind", x.kind),
    ("name", x.name),
    ("args", x.args),
    ("type", x.type),
    ("first-tactic", x.firstTactic),
    ("core-prompt", x.corePrompt),
    ("tactic-prompt", x.tacticPrompt)
  ]

end TheoremAndTactic

def getTheoremAndTactic? (input : Syntax)(vars : String) :
      MetaM <| Option TheoremAndTactic := do
    match input with
    | `(theoremAndTactic|$kind:defHead $name:ident $args:argument* : $type := by $tac:tacticSeq) =>
        let seq := getTactics tac
        let tac ← contractInductionStx (seq[0]!)
        let tac := tac.reprint.get!.splitOn "--" |>.head! |>.trim
        let tac := tac.splitOn "<;>" |>.head! |>.trim
        let tac := contractPolyTactic tac
        let argString :=
          (args.map fun a => a.raw.reprint.get!).foldl (fun a b => a ++ " " ++ b) (vars)
        let argString := argString.replace "\n" " " |>.trim
        return some ⟨kind.raw.reprint.get!.trim, name.raw.reprint.get!.trim,
        argString, type.raw.reprint.get!.trim, tac⟩
    | `(theoremAndTactic|$kind:defHead  $args:argument* : $type := by $tac:tacticSeq) =>
        let seq := getTactics tac
        let tac ← contractInductionStx (seq[0]!)
        let tac := tac.reprint.get!.splitOn "--" |>.head! |>.trim
        let tac := tac.splitOn "<;>" |>.head! |>.trim
        let tac := contractPolyTactic tac
        let argString :=
          (args.map fun a => a.raw.reprint.get!).foldl (fun a b => a ++ " " ++ b) (vars)
        let argString := argString.replace "\n" " " |>.trim
        return some ⟨kind.raw.reprint.get!.trim,"",
        argString, type.raw.reprint.get!.trim,
        tac⟩
    | _ =>
      IO.println s!"could not parse theorem {input.reprint.get!} to get tactic"
      return none

def parseTheoremAndTactic? (input: String) : MetaM <| Option TheoremAndTactic := do
  match ← partialParser (categoryParser `theoremAndTactic 0) input with
  | some (stx, _, _) =>
      getTheoremAndTactic? stx ""
  | none =>
    IO.println s!"could not parse theorem {input}"
    throwUnsupportedSyntax

def getVariables! (input : Syntax) :
      MetaM String := do
    match input with
    | `(variableStatement|variable $args:argument*) =>
        let argString :=
          (args.map fun a => a.raw.reprint.get!).foldl (fun a b => a ++ " " ++ b) ""
        return argString.replace "\n" " " |>.trim
    | _ =>
      IO.println s!"could not parse theorem {input.reprint.get!}"
      throwUnsupportedSyntax

partial def getTheoremsTacticsAux (text: String) (vars : Array String)
                        (sections : Array String)
                        (accum : Array TheoremAndTactic) : MetaM (Array TheoremAndTactic) := do
  if text.isEmpty then
      return accum
  else
      match (← partialParser (categoryParser `theoremAndTactic 0) text) with
      | some (stx, _, tail) =>
          let entry? ← getTheoremAndTactic? stx (vars.foldl (fun a b => a ++ " " ++ b) "")
          let accum := match entry? with
            | some entry => accum.push entry
            | none => accum
          getTheoremsTacticsAux tail vars sections (accum)
      | none =>
        match
          (← partialParser (categoryParser `variableStatement 0) text) with
        | some (stx, _, tail) =>
          let newVars ← getVariables! stx
          let innerVars := vars.back
          getTheoremsTacticsAux tail (vars.pop.push (innerVars ++ " " ++ newVars)) sections accum
        | none =>
          match
            (← partialParser (categoryParser `sectionHead 0) text) with
          | some (stx, _, tail) =>
            -- IO.println s!"\nsection head found {stx.reprint.get!} followed by {tail.take 30}"
            match stx with
            | `(sectionHead|section $name) =>
            getTheoremsTacticsAux tail (vars.push "")
              (sections.push name.raw.reprint.get!.trim) accum
            | `(sectionHead|section) =>
              getTheoremsTacticsAux tail (vars.push "") (sections.push "") accum
            | _ =>
              getTheoremsTacticsAux tail vars sections accum
          | none =>
            match
              (← partialParser (categoryParser `sectionEnd 0) text) with
            | some (stx, _, tail) =>
              -- IO.println s!"\nend found {stx.reprint.get!} with sections {sections} and vars {vars} followed by {tail.take 30}"
              match stx with
              | `(sectionEnd|end $name) =>
                if sections.back? == some name.raw.reprint.get!.trim then
                  getTheoremsTacticsAux tail (vars.pop) (sections.pop) accum
                else
                  getTheoremsTacticsAux tail vars sections accum
              | `(sectionEnd|end) =>
                getTheoremsTacticsAux tail (vars.pop) sections accum
              | _ =>
                getTheoremsTacticsAux tail (vars) sections accum
            | none =>
              match ← partialParser Command.docComment text with
              | some (_, _, tail) =>
                getTheoremsTacticsAux tail vars sections accum
              | none =>
                match ← partialParser Command.moduleDoc text with
              | some (_, _, tail) =>
                getTheoremsTacticsAux tail vars sections accum
              | none =>
                let head := text.get 0
                if ('a' ≤ head && head ≤ 'z') ||
                  ('A' ≤ head && head ≤ 'Z') then
                  let tail := text.dropWhile fun c =>
                    ('a' ≤ c && c ≤ 'z') ||
                  ('A' ≤ c && c ≤ 'Z')
                  getTheoremsTacticsAux tail vars sections accum
                else
                  getTheoremsTacticsAux (text.drop 1) vars sections accum

def getTheoremsTactics (text: String) : MetaM (Array TheoremAndTactic) := do
  getTheoremsTacticsAux text #[""] #[] #[]

def leanFiles (paths: List String) : IO (Array System.FilePath) := do
  Lean.SearchPath.findAllWithExt [System.mkFilePath paths] "lean"

def polyLeanFiles := leanFiles (["/home/gadgil/code/polylean/Polylean"])

def getTheoremsTacticsFromFiles (files: Array System.FilePath) : MetaM (Array TheoremAndTactic) := do
  let mut accum := #[]
  IO.println s!"parsing {files.size} lean files"
  let mut parsedCount := 0
  for file in files do
    IO.println s!"parsing {file}"
    let text ← IO.FS.readFile file
    let theorems ← getTheoremsTactics text
    IO.println s!"parsed {theorems.size} theorems with tactics"
    parsedCount := parsedCount + 1
    IO.println s!"parsed {parsedCount} files out of {files.size}"
    accum := accum ++ theorems
  return accum

def readAndSaveTheoremTacticsM (inps: List String ) : MetaM String := do
  let mut files := #[]
  for inp in inps do
    let fs ←  leanFiles [inp]
    files := files ++ fs
  IO.println s!"found {files.size} files"
  let all ← getTheoremsTacticsFromFiles files
  let js := Json.arr <| all.map fun a => a.toJson
  return js.pretty

def readAndSaveTheoremTacticsCore
  (inps: List String ) : CoreM String :=
  readAndSaveTheoremTacticsM inps |>.run'

-- example
def getTheoremsTacticsFromPolyLean : MetaM (Array TheoremAndTactic) := do
  let files ← polyLeanFiles
  logInfo m!"found {files.size} files"
  let files := files.toList.take 12 |>.toArray
  getTheoremsTacticsFromFiles files

#eval "rw [Subsingleton.elim hd] -- align the Decidable instances implicitly used by `dite`" |>.splitOn "--" |>.head!


variable (x : Id Nat) (h : x = x)

theorem Id_def : Id α = α := rfl

theorem bar : x = x.succ := by
  rw [Id_def] at x
  -- rw should not expose the auxdecl `bar`:
  fail_if_success assumption
  sorry


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

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

-- DSL for specifying parser precedences and priorities

namespace Lean.Parser.Syntax

syntax:65 (name := addPrec) prec " + " prec:66 : prec
syntax:65 (name := subPrec) prec " - " prec:66 : prec

syntax:65 (name := addPrio) prio " + " prio:66 : prio
syntax:65 (name := subPrio) prio " - " prio:66 : prio

end Lean.Parser.Syntax

macro "max"  : prec => `(1024) -- maximum precedence used in term parsers, in particular for terms in function position (`ident`, `paren`, ...)
macro "arg"  : prec => `(1023) -- precedence used for application arguments (`do`, `by`, ...)
macro "lead" : prec => `(1022) -- precedence used for terms not supposed to be used as arguments (`let`, `have`, ...)
macro "(" p:prec ")" : prec => return p
macro "min"  : prec => `(10)   -- minimum precedence used in term parsers
macro "min1" : prec => `(11)   -- `(min+1) we can only `min+1` after `Meta.lean`
/-
  `max:prec` as a term. It is equivalent to `eval_prec max` for `eval_prec` defined at `Meta.lean`.
  We use `max_prec` to workaround bootstrapping issues. -/
macro "max_prec" : term => `(1024)

macro "default" : prio => `(1000)
macro "low"     : prio => `(100)
macro "mid"     : prio => `(1000)
macro "high"    : prio => `(10000)
macro "(" p:prio ")" : prio => return p

-- Basic notation for defining parsers
-- NOTE: precedence must be at least `arg` to be used in `macro` without parentheses
syntax:arg stx:max "+" : stx
syntax:arg stx:max "*" : stx
syntax:arg stx:max "?" : stx
syntax:2 stx:2 " <|> " stx:1 : stx

macro_rules
  | `(stx| $p +) => `(stx| many1($p))
  | `(stx| $p *) => `(stx| many($p))
  | `(stx| $p ?) => `(stx| optional($p))
  | `(stx| $p₁ <|> $p₂) => `(stx| orelse($p₁, $p₂))

/- Comma-separated sequence. -/
macro:arg x:stx:max ",*"   : stx => `(stx| sepBy($x, ",", ", "))
macro:arg x:stx:max ",+"   : stx => `(stx| sepBy1($x, ",", ", "))
/- Comma-separated sequence with optional trailing comma. -/
macro:arg x:stx:max ",*,?" : stx => `(stx| sepBy($x, ",", ", ", allowTrailingSep))
macro:arg x:stx:max ",+,?" : stx => `(stx| sepBy1($x, ",", ", ", allowTrailingSep))

macro:arg "!" x:stx:max : stx => `(stx| notFollowedBy($x))

syntax (name := rawNatLit) "nat_lit " num : term

infixr:90 " ∘ "  => Function.comp
infixr:35 " × "  => Prod

infixl:55 " ||| " => HOr.hOr
infixl:58 " ^^^ " => HXor.hXor
infixl:60 " &&& " => HAnd.hAnd
infixl:65 " + "   => HAdd.hAdd
infixl:65 " - "   => HSub.hSub
infixl:70 " * "   => HMul.hMul
infixl:70 " / "   => HDiv.hDiv
infixl:70 " % "   => HMod.hMod
infixl:75 " <<< " => HShiftLeft.hShiftLeft
infixl:75 " >>> " => HShiftRight.hShiftRight
infixr:80 " ^ "   => HPow.hPow
infixl:65 " ++ "  => HAppend.hAppend
prefix:100 "-"    => Neg.neg
prefix:100 "~~~"  => Complement.complement
/-
  Remark: the infix commands above ensure a delaborator is generated for each relations.
  We redefine the macros below to be able to use the auxiliary `binop%` elaboration helper for binary operators.
  It addresses issue #382. -/
macro_rules | `($x ||| $y) => `(binop% HOr.hOr $x $y)
macro_rules | `($x ^^^ $y) => `(binop% HXor.hXor $x $y)
macro_rules | `($x &&& $y) => `(binop% HAnd.hAnd $x $y)
macro_rules | `($x + $y)   => `(binop% HAdd.hAdd $x $y)
macro_rules | `($x - $y)   => `(binop% HSub.hSub $x $y)
macro_rules | `($x * $y)   => `(binop% HMul.hMul $x $y)
macro_rules | `($x / $y)   => `(binop% HDiv.hDiv $x $y)
macro_rules | `($x ++ $y)  => `(binop% HAppend.hAppend $x $y)

-- declare ASCII alternatives first so that the latter Unicode unexpander wins
infix:50 " <= " => LE.le
infix:50 " ≤ "  => LE.le
infix:50 " < "  => LT.lt
infix:50 " >= " => GE.ge
infix:50 " ≥ "  => GE.ge
infix:50 " > "  => GT.gt
infix:50 " = "  => Eq
infix:50 " == " => BEq.beq
/-
  Remark: the infix commands above ensure a delaborator is generated for each relations.
  We redefine the macros below to be able to use the auxiliary `binrel%` elaboration helper for binary relations.
  It has better support for applying coercions. For example, suppose we have `binrel% Eq n i` where `n : Nat` and
  `i : Int`. The default elaborator fails because we don't have a coercion from `Int` to `Nat`, but
  `binrel%` succeeds because it also tries a coercion from `Nat` to `Int` even when the nat occurs before the int. -/
macro_rules | `($x <= $y) => `(binrel% LE.le $x $y)
macro_rules | `($x ≤ $y)  => `(binrel% LE.le $x $y)
macro_rules | `($x < $y)  => `(binrel% LT.lt $x $y)
macro_rules | `($x > $y)  => `(binrel% GT.gt $x $y)
macro_rules | `($x >= $y) => `(binrel% GE.ge $x $y)
macro_rules | `($x ≥ $y)  => `(binrel% GE.ge $x $y)
macro_rules | `($x = $y)  => `(binrel% Eq $x $y)
macro_rules | `($x == $y) => `(binrel_no_prop% BEq.beq $x $y)

infixr:35 " /\\ " => And
infixr:35 " ∧ "   => And
infixr:30 " \\/ " => Or
infixr:30 " ∨  "  => Or
notation:max "¬" p:40 => Not p

infixl:35 " && " => and
infixl:30 " || " => or
notation:max "!" b:40 => not b

infixr:67 " :: " => List.cons
syntax:20 term:21 " <|> " term:20 : term
syntax:60 term:61 " >> " term:60 : term
infixl:55  " >>= " => Bind.bind
notation:60 a:60 " <*> " b:61 => Seq.seq a fun _ : Unit => b
notation:60 a:60 " <* " b:61 => SeqLeft.seqLeft a fun _ : Unit => b
notation:60 a:60 " *> " b:61 => SeqRight.seqRight a fun _ : Unit => b
infixr:100 " <$> " => Functor.map

macro_rules | `($x <|> $y) => `(binop_lazy% HOrElse.hOrElse $x $y)
macro_rules | `($x >> $y)  => `(binop_lazy% HAndThen.hAndThen $x $y)

syntax (name := termDepIfThenElse)
  ppRealGroup(ppRealFill(ppIndent("if " ident " : " term " then") ppSpace term)
    ppDedent(ppSpace) ppRealFill("else " term)) : term

macro_rules
  | `(if $h:ident : $c then $t:term else $e:term) => `(let_mvar% ?m := $c; wait_if_type_mvar% ?m; dite ?m (fun $h:ident => $t) (fun $h:ident => $e))

syntax (name := termIfThenElse)
  ppRealGroup(ppRealFill(ppIndent("if " term " then") ppSpace term)
    ppDedent(ppSpace) ppRealFill("else " term)) : term

macro_rules
  | `(if $c then $t:term else $e:term) => `(let_mvar% ?m := $c; wait_if_type_mvar% ?m; ite ?m $t $e)

macro "if " "let " pat:term " := " d:term " then " t:term " else " e:term : term =>
  `(match $d:term with | $pat:term => $t | _ => $e)

syntax:min term " <| " term:min : term

macro_rules
  | `($f $args* <| $a) => let args := args.push a; `($f $args*)
  | `($f <| $a) => `($f $a)

syntax:min term " |> " term:min1 : term

macro_rules
  | `($a |> $f $args*) => let args := args.push a; `($f $args*)
  | `($a |> $f)        => `($f $a)

-- Haskell-like pipe <|
-- Note that we have a whitespace after `$` to avoid an ambiguity with the antiquotations.
syntax:min term atomic(" $" ws) term:min : term

macro_rules
  | `($f $args* $ $a) => let args := args.push a; `($f $args*)
  | `($f $ $a) => `($f $a)

syntax "{ " ident (" : " term)? " // " term " }" : term

macro_rules
  | `({ $x : $type // $p }) => ``(Subtype (fun ($x:ident : $type) => $p))
  | `({ $x // $p })         => ``(Subtype (fun ($x:ident : _) => $p))

/-
  `without_expected_type t` instructs Lean to elaborate `t` without an expected type.
  Recall that terms such as `match ... with ...` and `⟨...⟩` will postpone elaboration until
  expected type is known. So, `without_expected_type` is not effective in this case. -/
macro "without_expected_type " x:term : term => `(let aux := $x; aux)

syntax "[" term,* "]"  : term
syntax "%[" term,* "|" term "]" : term -- auxiliary notation for creating big list literals

namespace Lean

macro_rules
  | `([ $elems,* ]) => do
    let rec expandListLit (i : Nat) (skip : Bool) (result : Syntax) : MacroM Syntax := do
      match i, skip with
      | 0,   _     => pure result
      | i+1, true  => expandListLit i false result
      | i+1, false => expandListLit i true  (← ``(List.cons $(elems.elemsAndSeps[i]) $result))
    if elems.elemsAndSeps.size < 64 then
      expandListLit elems.elemsAndSeps.size false (← ``(List.nil))
    else
      `(%[ $elems,* | List.nil ])

notation:50 e:51 " matches " p:51 => ((match e with | p => true | _ => false) : Bool)

-- Declare `this` as a keyword that unhygienically binds to a scope-less `this` assumption (or other binding).
-- The keyword prevents declaring a `this` binding except through metapgrogramming, as is done by `have`/`show`.
/-- Special identifier introduced by "anonymous" `have : ...`, `suffices p ...` etc. -/
macro tk:"this" : term => return Syntax.ident tk.getHeadInfo "this".toSubstring `this []

namespace Parser.Tactic
/--
Introduce one or more hypotheses, optionally naming and/or pattern-matching them.
For each hypothesis to be introduced, the remaining main goal's target type must be a `let` or function type.
* `intro` by itself introduces one anonymous hypothesis, which can be accessed by e.g. `assumption`.
* `intro x y` introduces two hypotheses and names them. Individual hypotheses can be anonymized via `_`,
  or matched against a pattern:
  ```lean
  -- ... ⊢ α × β → ...
  intro (a, b)
  -- ..., a : α, b : β ⊢ ...
  ```
* Alternatively, `intro` can be combined with pattern matching much like `fun`:
  ```lean
  intro
  | n + 1, 0 => tac
  | ...
  ```
-/
syntax (name := intro) "intro " notFollowedBy("|") (colGt term:max)* : tactic
/-- `intros x...` behaves like `intro x...`, but then keeps introducing (anonymous) hypotheses until goal is not of a function type. -/
syntax (name := intros) "intros " (colGt (ident <|> "_"))* : tactic
/--
`rename t => x` renames the most recent hypothesis whose type matches `t` (which may contain placeholders) to `x`,
or fails if no such hypothesis could be found. -/
syntax (name := rename) "rename " term " => " ident : tactic
/-- `revert x...` is the inverse of `intro x...`: it moves the given hypotheses into the main goal's target type. -/
syntax (name := revert) "revert " (colGt term:max)+ : tactic
/-- `clear x...` removes the given hypotheses, or fails if there are remaining references to a hypothesis. -/
syntax (name := clear) "clear " (colGt term:max)+ : tactic
/--
`subst x...` substitutes each `x` with `e` in the goal if there is a hypothesis of type `x = e` or `e = x`.
If `x` is itself a hypothesis of type `y = e` or `e = y`, `y` is substituted instead. -/
syntax (name := subst) "subst " (colGt term:max)+ : tactic
/--
`assumption` tries to solve the main goal using a hypothesis of compatible type, or else fails.
Note also the `‹t›` term notation, which is a shorthand for `show t by assumption`. -/
syntax (name := assumption) "assumption" : tactic
/--
`contradiction` closes the main goal if its hypotheses are "trivially contradictory".
```lean
example (h : False) : p := by contradiction  -- inductive type/family with no applicable constructors
example (h : none = some true) : p := by contradiction  -- injectivity of constructors
example (h : 2 + 2 = 3) : p := by contradiction  -- decidable false proposition
example (h : p) (h' : ¬ p) : q := by contradiction
example (x : Nat) (h : x ≠ x) : p := by contradiction
```
-/
syntax (name := contradiction) "contradiction" : tactic
/--
`apply e` tries to match the current goal against the conclusion of `e`'s type.
If it succeeds, then the tactic returns as many subgoals as the number of premises that
have not been fixed by type inference or type class resolution.
Non-dependent premises are added before dependent ones.

The `apply` tactic uses higher-order pattern matching, type class resolution, and first-order unification with dependent types.
-/
syntax (name := apply) "apply " term : tactic
/--
`exact e` closes the main goal if its target type matches that of `e`.
-/
syntax (name := exact) "exact " term : tactic
/--
`refine e` behaves like `exact e`, except that named (`?x`) or unnamed (`?_`) holes in `e` that are not solved
by unification with the main goal's target type are converted into new goals, using the hole's name, if any, as the goal case name.
-/
syntax (name := refine) "refine " term : tactic
/-- `refine' e` behaves like `refine e`, except that unsolved placeholders (`_`) and implicit parameters are also converted into new goals. -/
syntax (name := refine') "refine' " term : tactic
/-- If the main goal's target type is an inductive type, `constructor` solves it with the first matching constructor, or else fails. -/
syntax (name := constructor) "constructor" : tactic
/--
`case tag => tac` focuses on the goal with case name `tag` and solves it using `tac`, or else fails.
`case tag x₁ ... xₙ => tac` additionally renames the `n` most recent hypotheses with inaccessible names to the given names. -/
syntax (name := case) "case " (ident <|> "_") (ident <|> "_")* " => " tacticSeq : tactic
/--
`next => tac` focuses on the next goal solves it using `tac`, or else fails.
`next x₁ ... xₙ => tac` additionally renames the `n` most recent hypotheses with inaccessible names to the given names. -/
macro "next " args:(ident <|> "_")* " => " tac:tacticSeq : tactic => `(tactic| case _ $(args.getArgs)* => $tac)

/-- `allGoals tac` runs `tac` on each goal, concatenating the resulting goals, if any. -/
syntax (name := allGoals) "all_goals " tacticSeq : tactic
/-- `anyGoals tac` applies the tactic `tac` to every goal, and succeeds if at least one application succeeds.  -/
syntax (name := anyGoals) "any_goals " tacticSeq : tactic
/--
`focus tac` focuses on the main goal, suppressing all other goals, and runs `tac` on it.
Usually `· tac`, which enforces that the goal is closed by `tac`, should be preferred. -/
syntax (name := focus) "focus " tacticSeq : tactic
/-- `skip` does nothing. -/
syntax (name := skip) "skip" : tactic
/-- `done` succeeds iff there are no remaining goals. -/
syntax (name := done) "done" : tactic
syntax (name := traceState) "trace_state" : tactic
syntax (name := failIfSuccess) "fail_if_success " tacticSeq : tactic
syntax (name := paren) "(" tacticSeq ")" : tactic
syntax (name := withReducible) "with_reducible " tacticSeq : tactic
syntax (name := withReducibleAndInstances) "with_reducible_and_instances " tacticSeq : tactic
/-- `first | tac | ...` runs each `tac` until one succeeds, or else fails. -/
syntax (name := first) "first " withPosition((group(colGe "|" tacticSeq))+) : tactic
syntax (name := rotateLeft) "rotate_left" (num)? : tactic
syntax (name := rotateRight) "rotate_right" (num)? : tactic
/-- `try tac` runs `tac` and succeeds even if `tac` failed. -/
macro "try " t:tacticSeq : tactic => `(first | $t | skip)
/-- `tac <;> tac'` runs `tac` on the main goal and `tac'` on each produced goal, concatenating all goals produced by `tac'`. -/
macro:1 x:tactic " <;> " y:tactic:0 : tactic => `(tactic| focus ($x:tactic; all_goals $y:tactic))

/-- `rfl` is a shorthand for `exact rfl`. -/
macro "rfl" : tactic => `(exact rfl)
/-- `admit` is a shorthand for `exact sorry`. -/
macro "admit" : tactic => `(exact sorry)
/-- The `sorry` tactic is a shorthand for `exact sorry`. -/
macro "sorry" : tactic => `(exact sorry)
macro "infer_instance" : tactic => `(exact inferInstance)

/-- Optional configuration option for tactics -/
syntax config := atomic("(" &"config") " := " term ")"

syntax locationWildcard := "*"
syntax locationHyp      := (colGt term:max)+ ("⊢" <|> "|-")?
syntax location         := withPosition(" at " (locationWildcard <|> locationHyp))

syntax (name := change) "change " term (location)? : tactic
syntax (name := changeWith) "change " term " with " term (location)? : tactic

syntax rwRule    := ("← " <|> "<- ")? term
syntax rwRuleSeq := "[" rwRule,*,? "]"

syntax (name := rewriteSeq) "rewrite " (config)? rwRuleSeq (location)? : tactic

syntax (name := rwSeq) "rw " (config)? rwRuleSeq (location)? : tactic

def rwWithRfl (kind : SyntaxNodeKind) (atom : String) (stx : Syntax) : MacroM Syntax := do
  -- We show the `rfl` state on `]`
  let seq   := stx[2]
  let rbrak := seq[2]
  -- Replace `]` token with one without position information in the expanded tactic
  let seq   := seq.setArg 2 (mkAtom "]")
  let tac   := stx.setKind kind |>.setArg 0 (mkAtomFrom stx atom) |>.setArg 2 seq
  `(tactic| $tac; try (with_reducible rfl%$rbrak))

@[macro rwSeq] def expandRwSeq : Macro :=
  rwWithRfl ``Lean.Parser.Tactic.rewriteSeq "rewrite"

syntax (name := injection) "injection " term (" with " (colGt (ident <|> "_"))+)? : tactic

syntax (name := injections) "injections" : tactic

syntax discharger := atomic("(" (&"discharger" <|> &"disch")) " := " tacticSeq ")"

syntax simpPre   := "↓"
syntax simpPost  := "↑"
syntax simpLemma := (simpPre <|> simpPost)? ("← " <|> "<- ")? term
syntax simpErase := "-" term:max
syntax simpStar  := "*"
syntax (name := simp) "simp " (config)? (discharger)? (&"only ")? ("[" (simpStar <|> simpErase <|> simpLemma),* "]")? (location)? : tactic
syntax (name := simpAll) "simp_all " (config)? (discharger)? (&"only ")? ("[" (simpErase <|> simpLemma),* "]")? : tactic

/--
  Delta expand the given definition.
  This is a low-level tactic, it will expose how recursive definitions have been compiled by Lean. -/
syntax (name := delta) "delta " ident (location)? : tactic
/--
  Unfold definition. For non-recursive definitions, this tactic is identical to `delta`.
  For recursive definitions, it hides the encoding tricks used by the Lean frontend to convince the
  kernel that the definition terminates. -/
syntax (name := unfold) "unfold " ident (location)? : tactic

-- Auxiliary macro for lifting have/suffices/let/...
-- It makes sure the "continuation" `?_` is the main goal after refining
macro "refine_lift " e:term : tactic => `(focus (refine no_implicit_lambda% $e; rotate_right))

macro "have " d:haveDecl : tactic => `(refine_lift have $d:haveDecl; ?_)
/- We use a priority > default, to avoid ambiguity with previous `have` notation -/
macro (priority := high) "have" x:ident " := " p:term : tactic => `(have $x:ident : _ := $p)
macro "suffices " d:sufficesDecl : tactic => `(refine_lift suffices $d:sufficesDecl; ?_)
macro "let " d:letDecl : tactic => `(refine_lift let $d:letDecl; ?_)
macro "show " e:term : tactic => `(refine_lift show $e:term from ?_)
syntax (name := letrec) withPosition(atomic(group("let " &"rec ")) letRecDecls) : tactic
macro_rules
  | `(tactic| let rec $d:letRecDecls) => `(tactic| refine_lift let rec $d:letRecDecls; ?_)

-- Similar to `refineLift`, but using `refine'`
macro "refine_lift' " e:term : tactic => `(focus (refine' no_implicit_lambda% $e; rotate_right))
macro "have' " d:haveDecl : tactic => `(refine_lift' have $d:haveDecl; ?_)
macro (priority := high) "have'" x:ident " := " p:term : tactic => `(have' $x:ident : _ := $p)
macro "let' " d:letDecl : tactic => `(refine_lift' let $d:letDecl; ?_)

syntax inductionAlt  := ppDedent(ppLine) "| " (group("@"? ident) <|> "_") (ident <|> "_")* " => " (hole <|> syntheticHole <|> tacticSeq)
syntax inductionAlts := "with " (tactic)? withPosition( (colGe inductionAlt)+)
syntax (name := induction) "induction " term,+ (" using " ident)?  ("generalizing " (colGt term:max)+)? (inductionAlts)? : tactic

syntax generalizeArg := atomic(ident " : ")? term:51 " = " ident
/--
`generalize ([h :] e = x),+` replaces all occurrences `e`s in the main goal with a fresh hypothesis `x`s.
If `h` is given, `h : e = x` is introduced as well. -/
syntax (name := generalize) "generalize " generalizeArg,+ : tactic

syntax casesTarget := atomic(ident " : ")? term
syntax (name := cases) "cases " casesTarget,+ (" using " ident)? (inductionAlts)? : tactic

syntax (name := existsIntro) "exists " term : tactic

/-- `rename_i x_1 ... x_n` renames the last `n` inaccessible names using the given names. -/
syntax (name := renameI) "rename_i " (colGt (ident <|> "_"))+ : tactic

syntax "repeat " tacticSeq : tactic
macro_rules
  | `(tactic| repeat $seq) => `(tactic| first | ($seq); repeat $seq | skip)

syntax "trivial" : tactic

syntax (name := split) "split " (colGt term)? (location)? : tactic

/--
The tactic `specialize h a₁ ... aₙ` works on local hypothesis `h`.
The premises of this hypothesis, either universal quantifications or non-dependent implications,
are instantiated by concrete terms coming either from arguments `a₁` ... `aₙ`.
The tactic adds a new hypothesis with the same name `h := h a₁ ... aₙ` and tries to clear the previous one.
-/
syntax (name := specialize) "specialize " term : tactic

macro_rules | `(tactic| trivial) => `(tactic| assumption)
macro_rules | `(tactic| trivial) => `(tactic| rfl)
macro_rules | `(tactic| trivial) => `(tactic| contradiction)
macro_rules | `(tactic| trivial) => `(tactic| apply True.intro)
macro_rules | `(tactic| trivial) => `(tactic| apply And.intro <;> trivial)

macro "unhygienic " t:tacticSeq : tactic => `(set_option tactic.hygienic false in $t:tacticSeq)

end Tactic

namespace Attr
-- simp attribute syntax
syntax (name := simp) "simp" (Tactic.simpPre <|> Tactic.simpPost)? (prio)? : attr
end Attr

end Parser
end Lean

macro "‹" type:term "›" : term => `((by assumption : $type))


import data.multiset.basic
import tactic.where

-- First set up the testing framework...

section framework

-- Note that we cannot have any explicit `open`s, we are currently working around this bug:
-- https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/What's.20the.20deal.20with.20.60open.60

@[user_command]
meta def run_parser_from_command_cmd
  (_ : interactive.parse $ lean.parser.tk "run_parser_from_command")
  : lean.parser unit :=
do ns ← lean.parser.ident,
   let ns := if ns = `NONE then name.anonymous else ns,
   n ← lean.parser.ident,
   prog ← lean.parser.of_tactic $ tactic.mk_const (ns ++ n) >>= tactic.eval_expr (lean.parser unit),
   if ns = name.anonymous then tactic.skip else lean.parser.emit_code_here $
     "namespace " ++ ns.to_string,
   prog,
   if ns = name.anonymous then tactic.skip else lean.parser.emit_code_here $
     "end " ++ ns.to_string

meta def remove_dot_aux : list char → list char
| [] := []
| (c :: rest) := (if c = '.' then '_' else c) :: remove_dot_aux rest

meta def remove_dot (s : string) : string :=
(remove_dot_aux s.data).as_string

-- NOTE We must emit fully qualified names below in order to not influence the real tests!
@[user_command]
meta def run_parser_from_tactic_cmd
  (_ : interactive.parse $ lean.parser.tk "run_parser_from_tactic")
  : lean.parser unit :=
do ns ← lean.parser.ident,
   let ns := if ns = `NONE then name.anonymous else ns,
   n ← lean.parser.ident,
   let tac_name := "try_test_" ++ (remove_dot (ns ++ n).to_string),
   lean.parser.emit_code_here $
     "meta def tactic.interactive." ++ tac_name ++
       " (_ : interactive.parse " ++ (ns ++ n).to_string ++ ")" ++ ": tactic unit := tactic.triv",
   if ns = name.anonymous then tactic.skip else lean.parser.emit_code_here $
     "namespace " ++ ns.to_string,
   lean.parser.emit_code_here $
      "example : true := by " ++ (name.mk_string tac_name name.anonymous).to_string,
   if ns = name.anonymous then tactic.skip else lean.parser.emit_code_here $
     "end " ++ ns.to_string

meta def assert_name_eq (n₁ n₂ : name) : lean.parser unit :=
if n₁ = n₂ then return () else tactic.fail sformat!"violation: '{n₁}' ≠ '{n₂}'!"

meta def assert_list_noorder_eq {α : Type} [decidable_eq α] [has_to_string α]
  (l₁ l₂ : list α) : lean.parser unit :=
if (l₁ : multiset α) = (l₂ : multiset α) then return ()
else tactic.fail sformat!"violation: '{l₁}' ≠ '{l₂}'!"

meta def assert_where_msg_eq (s : string) : lean.parser unit :=
do tw ← where.build_msg,
   if s = tw then return ()
   else tactic.fail sformat!"violation:\n'\n{tw}\n'\n\n          ≠\n\n'\n{s}\n'!"

-- Test the test framework...

meta def dummy : lean.parser unit := return ()

run_parser_from_command NONE dummy
run_parser_from_tactic  NONE dummy

end framework

-- TESTS START

-- TEST: `#where` output
-- NOTE: This section must come first because of the `open_namespaces` bug referenced above.
-- NOTE: All other sections have correct answers, but the order of variables (say) may be safely
--       reordered here: changes to `#where` which break this set of tests are possible, without an
--       error.

meta def test_output_1 : lean.parser unit :=
assert_where_msg_eq "namespace [root namespace]\n\n\n\n\nend [root namespace]\n"
meta def test_output_2 : lean.parser unit :=
assert_where_msg_eq "namespace [root namespace]\n\nopen list nat\n\n\n\nend [root namespace]\n"
meta def test_output_3 : lean.parser unit :=
assert_where_msg_eq "namespace [root namespace]\n\nopen list nat\nvariables {c : ℕ → list ℕ} (b a : ℕ) [decidable_eq : ℕ]\n\n\n\nend [root namespace]\n"
meta def test_output_4 : lean.parser unit :=
assert_where_msg_eq "namespace [root namespace]\n\nopen list nat\nvariables {c : ℕ → list ℕ} (b a : ℕ) [decidable_eq : ℕ]\ninclude c a\n\n\n\nend [root namespace]\n"
meta def test_output_5 : lean.parser unit :=
assert_where_msg_eq "namespace a\n\nopen list nat\nvariables {c : ℕ → list ℕ} (b a : ℕ) [decidable_eq : ℕ]\ninclude c a\n\n\n\nend a\n"
meta def test_output_6 : lean.parser unit :=
assert_where_msg_eq "namespace a.b\n\nopen a list nat\nvariables {c : ℕ → list ℕ} (b a : ℕ) [decidable_eq : ℕ]\ninclude c a\n\n\n\nend a.b\n"

section b1

-- #where
run_parser_from_command NONE test_output_1

open nat list

-- #where
run_parser_from_command NONE test_output_2

variables (a b : ℕ) [decidable_eq : ℕ] {c : ℕ → list ℕ}

-- #where
run_parser_from_command NONE test_output_3

include a c

-- #where
run_parser_from_command NONE test_output_4

end b1

namespace a

variables (a b : ℕ) [decidable_eq : ℕ] {c : ℕ → list ℕ}
include a c
open nat list

-- #where
run_parser_from_command NONE test_output_5

namespace b

-- #where
run_parser_from_command NONE test_output_6

end b

end a

-- TEST: `lean.parser.get_current_namespace`

-- Check no namespace
meta def test_no_namespace : lean.parser unit :=
do ns ← lean.parser.get_current_namespace,
   assert_name_eq ns name.anonymous,
   return ()

run_parser_from_command NONE test_no_namespace
run_parser_from_tactic  NONE test_no_namespace

section a1

open nat list

-- Check no namespace with opens
meta def test_no_namespace_w_opens : lean.parser unit :=
do ns ← lean.parser.get_current_namespace,
   assert_name_eq ns name.anonymous,
   return ()

run_parser_from_command NONE test_no_namespace_w_opens
run_parser_from_tactic  NONE test_no_namespace_w_opens

end a1

namespace test1

-- Check a namespace
meta def test_1 : lean.parser unit :=
do ns ← lean.parser.get_current_namespace,
   assert_name_eq ns `test1,
   return ()

open nat list

-- Check a 2 namespaces with opens
meta def test_2 : lean.parser unit :=
do ns ← lean.parser.get_current_namespace,
   assert_name_eq ns `test1,
   return ()

end test1

run_parser_from_command test1 test_1
run_parser_from_command test1 test_2
run_parser_from_tactic  test1 test_1
run_parser_from_tactic  test1 test_2

namespace test1.test2

-- Check a 2 namespaces
meta def test_1 : lean.parser unit :=
do ns ← lean.parser.get_current_namespace,
   assert_name_eq ns `test1.test2,
   return ()

open nat list

-- Check a 2 namespaces with opens
meta def test_2 : lean.parser unit :=
do ns ← lean.parser.get_current_namespace,
   assert_name_eq ns `test1.test2,
   return ()

end test1.test2

run_parser_from_command test1.test2 test_1
run_parser_from_command test1.test2 test_2
run_parser_from_tactic  test1.test2 test_1
run_parser_from_tactic  test1.test2 test_2

-- TEST: `lean.parser.get_variables` and `lean.parser.get_included_variables`

-- Check no variables
meta def test_no_variables : lean.parser unit :=
do ns ← lean.parser.get_variables,
   assert_list_noorder_eq (ns.map prod.fst) [],
   return ()

run_parser_from_command NONE test_no_variables
run_parser_from_tactic  NONE test_no_variables

section a1

variables (a : ℕ)

-- Check 1 variable from command
meta def test_1_variable_from_command : lean.parser unit :=
do ns ← lean.parser.get_variables,
   assert_list_noorder_eq (ns.map prod.fst) [`a],
   return ()

run_parser_from_command NONE test_1_variable_from_command

-- Check 1 variable from tactic
meta def test_1_variable_from_tactic : lean.parser unit :=
do ns ← lean.parser.get_variables,
   assert_list_noorder_eq (ns.map prod.fst) [],
   return ()

run_parser_from_tactic  NONE test_1_variable_from_tactic

end a1

namespace a2

variables (a : ℕ)

-- Check 1 variable from command inside namespace
meta def test_1_variable_from_command : lean.parser unit :=
do ns ← lean.parser.get_variables,
   assert_list_noorder_eq (ns.map prod.fst) [`a],
   return ()

run_parser_from_command NONE test_1_variable_from_command

-- Check 1 variable from tactic inside namespace
meta def test_1_variable_from_tactic : lean.parser unit :=
do ns ← lean.parser.get_variables,
   assert_list_noorder_eq (ns.map prod.fst) [],
   return ()

run_parser_from_tactic NONE test_1_variable_from_tactic

end a2

section a3

-- Check 3 variables with 1 include
meta def test_2_variable_from_command : lean.parser unit :=
do ns ← lean.parser.get_variables,
   assert_list_noorder_eq (ns.map prod.fst) [`a, `b, `c],
   ns ← lean.parser.get_included_variables,
   assert_list_noorder_eq (ns.map prod.fst) [`b],
   return ()

variables (a b c : ℕ)
include b

run_parser_from_command NONE test_2_variable_from_command

end a3


import Runtime.Execution.ReactionInputs

namespace Network.Graph.Class.Reaction

inductive Trigger (net : Network)
  | port {kind} (id : PortId net kind)
  | action (id : ActionId net)
  | timer (id : TimerId net)
  | startup
  | shutdown

def Trigger.lift {reactor : ReactorId net} {reaction : Reaction reactor.class} :
  reaction.val.triggerType → Trigger net
  | .action a => .action ⟨reactor, reaction.subAS.coe a⟩
  | .timer t  => .timer ⟨reactor, reaction.eqTimers ▸ t⟩
  | .startup  => .startup
  | .shutdown => .shutdown
  | .port p =>
    match reaction.subPS.coe p with
    | .inl input =>
      (.port (kind := .input) ⟨reactor, input⟩)
    | .inr ⟨c, output⟩ =>
      (.port (kind := .output) ⟨reactor.extend c, cast (by rw [Path.extend_class]) output⟩)

inductive Trigger.Equiv {reactor : ReactorId net} {reaction : Reaction reactor.class} :
  (Trigger net) → reaction.val.triggerType → Prop
  | action :   Equiv (.action ⟨reactor, reaction.subAS.coe a⟩) (.action a)
  | timer :    Equiv (.timer ⟨reactor, reaction.eqTimers ▸ t⟩) (.timer t)
  | startup :  Equiv .startup .startup
  | shutdown : Equiv .shutdown .shutdown
  | input :
    (reaction.subPS.coe p = .inl input) →
    Equiv (.port (kind := .input) ⟨reactor, input⟩) (.port p)
  | output :
    (reaction.subPS.coe p = .inr ⟨c, output⟩) →
    Equiv (.port (kind := .output) ⟨reactor.extend c, cast (by rw [Path.extend_class]) output⟩) (.port p)

infix:50 " ≡ " => Trigger.Equiv

theorem Trigger.Equiv.lift
  {reactor : ReactorId net} {reaction : Reaction reactor.class} (t : reaction.val.triggerType) :
  Trigger.lift t ≡ t := by
  cases t
  all_goals
    simp [Trigger.lift]
    first
    | constructor
    | split <;> (constructor; assumption)

end Network.Graph.Class.Reaction

namespace Execution.Executable
open Network Graph Class

/--
A predicate indicating whether a given executable triggers a given reaction by means of a given
trigger. The main use case for this predicate is its closure: `Triggers`.
-/
inductive Activates (exec : Executable net) : (Class.Reaction.Trigger net) → Prop
  | port     : (exec.portIsPresent p)       → Activates _ (.port p)
  | action   : (exec.actionIsPresent a)     → Activates _ (.action a)
  | timer    : (exec.timer t |>.isFiring)   → Activates _ (.timer t)
  | startup  : (exec.isStartingUp)          → Activates _ .startup
  | shutdown : (exec.state = .shuttingDown) → Activates _ .shutdown

/-- A predicate indicating whether a given executable triggers a given reaction. -/
inductive Triggers (exec) {reactor : ReactorId net} (reaction : Reaction reactor.class) : Prop
  | witness (equiv : t ≡ t') (mem : t' ∈ reaction.val.triggers.data) (active : Activates exec t)

/-- A decision procedure for `Triggers`. -/
private def triggers (exec : Executable net) {reactor : ReactorId net} (reaction : Reaction reactor.class) :=
  reaction.val.triggers.any (activated ·)
where
  activated : reaction.val.triggerType → Bool
  | .port   port   => exec.reactionInputs reactor |>.isPresent (reaction.subPS.coe port)
  | .action action => exec.interface reactor .actions |>.isPresent (reaction.subAS.coe action)
  | .timer  timer  => exec.reactors reactor |>.timer (reaction.eqTimers ▸ timer) |>.isFiring
  | .startup       => exec.isStartingUp
  | .shutdown      => exec.state = .shuttingDown

set_option pp.proofs.withType false in
theorem Activates.port_iff_equiv_port_activated {p'} :
  (.port p ≡ .port p') →
  ((Activates exec <| .port p) ↔ (triggers.activated exec reaction <| .port p')) := by
  intro he
  constructor <;> intro h
  case mp reactor =>
    simp only [triggers.activated, reactionInputs]
    cases hp : reaction.subPS.coe p'
    case inl loc =>
      simp
      cases he
      case input hi =>
        simp [hi] at hp
        cases h
        case port h =>
          simp [portIsPresent, hp] at h
          exact h
      case output ho =>
        rw [ho] at hp
        contradiction
    case inr sub =>
      have ⟨c, output⟩ := sub
      simp at output ⊢
      cases he
      case input hi =>
        rw [hi] at hp
        contradiction
      case output c' output' ho =>
        simp [ho] at hp
        injection hp with hc ho
        subst hc
        subst ho
        cases h
        case port h =>
          simp [portIsPresent] at h
          have ⟨v, hv⟩ := h
          exists cast sorry v
          simp [hv]
          -- https://leanprover.zulipchat.com/#narrow/stream/270676-lean4
          sorry
  case mpr =>
    sorry

theorem Activates.iff_equiv_trigger_activated {t'} :
  (t ≡ t') → (Activates exec t ↔ triggers.activated exec reaction t') := by
  intro equiv
  unfold triggers.activated
  constructor
  case mp =>
    intro activates
    cases t <;> cases t' <;> (try contradiction)
    case port.port => exact Activates.port_iff_equiv_port_activated equiv |>.mp activates
    all_goals
      cases activates
      cases equiv
      all_goals
        simp_all [actionIsPresent, portIsPresent, reactionInputs]
        try assumption
  case mpr =>
    intro h
    cases t <;> cases t' <;> (try contradiction)
    case port.port => exact Activates.port_iff_equiv_port_activated equiv |>.mpr h
    all_goals
      simp at h
      constructor
      cases equiv
      all_goals
        simp_all [actionIsPresent, portIsPresent, reactionInputs]
        try assumption

theorem Triggers.iff_triggers_eq_true : (Triggers exec reaction) ↔ (exec.triggers reaction) := by
  unfold triggers
  constructor
  case mp =>
    intro ⟨equiv, mem, active⟩
    rw [Array.any_iff_mem_where]
    refine ⟨_, mem, ?_⟩
    exact Activates.iff_equiv_trigger_activated equiv |>.mp active
  case mpr =>
    intro h
    have ⟨t', mem, active⟩ := Array.any_iff_mem_where.mp h
    have ⟨_, equiv⟩ : ∃ t, t ≡ t' := ⟨_, Reaction.Trigger.Equiv.lift t'⟩
    refine .witness equiv mem ?_
    exact Activates.iff_equiv_trigger_activated equiv |>.mpr active

instance : Decidable (Triggers exec reaction) :=
  decidable_of_iff' _ Triggers.iff_triggers_eq_true

end Execution.Executable


example : (p → q) ∧ r := by
  refine ⟨?a, ?b⟩

example : (p → q) ∧ r := by
  refine ⟨fun h => ?a, ?b⟩


import Std.Data.AssocList

import LeanSat.Data.Sexp
import LeanSat.Dsl.Sexp

def argsCvc4 : IO.Process.SpawnArgs := {
  cmd := "cvc4"
  args := #["--lang", "smt", "/tmp/temp.smt"] }

def argsCvc5 : IO.Process.SpawnArgs := {
  cmd := "cvc5"
  args := #["--lang", "smt", "/tmp/temp.smt"] }

def argsZ3 : IO.Process.SpawnArgs := {
  cmd := "z3/bin/z3"
  args := #["-smt2", "/tmp/temp.smt"] }

def argsBoolector : IO.Process.SpawnArgs := {
  cmd := "boolector"
  args := #["--smt2", "/tmp/temp.smt"] }

-- Same as IO.Process.run, but does not require exitcode = 0
def run' (args : IO.Process.SpawnArgs) : IO String := do
  let out ← IO.Process.output args
  pure out.stdout

/-- Executes the solver with the provided list of commands in SMT-LIB s-expression format.
Returns the solver output as s-expressions. -/
def callSolver (args : IO.Process.SpawnArgs) (commands : List Sexp) (verbose : Bool := false)
    : IO (List Sexp) := do
  let cmdStr := Sexp.serializeMany commands
  if verbose then
    IO.println "Sending SMT-LIB problem:"
    IO.println cmdStr
  IO.FS.writeFile "/tmp/temp.smt" cmdStr
  let out ← run' args
  if verbose then
    IO.println "\nSolver replied:"
    IO.println out
  let out ← IO.ofExcept (Sexp.parse out)
  return out

def callCvc4 := @callSolver argsCvc4
def callCvc5 := @callSolver argsCvc5
def callZ3 := @callSolver argsZ3
def callBoolector := @callSolver argsBoolector

private def hexdigits : Array Char :=
  #[ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f' ]

def enhexByte (x : UInt8) : String :=
  ⟨[hexdigits.get! $ UInt8.toNat $ (x.land 0xf0).shiftRight 4,
    hexdigits.get! $ UInt8.toNat $ x.land 0xf ]⟩

/-- Convert a little-endian (LSB first) list of bytes to hexadecimal. -/
def enhexLE : List UInt8 → String
  | [] => ""
  | b::bs => enhexLE bs ++ enhexByte b

/-- Converts a number `n` to its hexadecimal SMT-LIB representation as a `nBits`-bit vector.
For example `toBVConst 32 0xf == "#x0000000f"`. -/
def toBVConst (nBits : Nat) (n : Nat) : String :=
  assert! nBits % 8 == 0
  let nBytes := nBits/8
  let bytes := List.range nBytes |>.map fun i => UInt8.ofNat ((n >>> (i*8)) &&& 0xff)
  "#x" ++ enhexLE bytes

open Std (AssocList)

/-- Extracts constants assigned in a model returned from an SMT solver.
The model is expected to be a single s-expression representing a list,
with constant expressions represented by `(define-fun <name> () <type> <body>)`. -/
def decodeModelConsts : Sexp → AssocList String Sexp
  | Sexp.expr ss =>
    ss.foldl (init := AssocList.empty) fun
      | acc, sexp!{(define-fun {Sexp.atom x} () {_} {body})} =>
        acc.insert x body
      | acc, _ => acc
  | _ => AssocList.empty

/-- Evaluates an SMT-LIB constant numeral such as `0` or `#b01` or `#x02`. -/
def evalNumConst : Sexp → Option Nat
  | Sexp.atom s =>
    let s' :=
      if s.startsWith "#b" then "0" ++ s.drop 1
      else if s.startsWith "#x" then "0" ++ s.drop 1
      else s
    Lean.Syntax.decodeNatLitVal? s'
  | Sexp.expr _ => none


/-
Copyright (c) 2022 Mac Malone. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mac Malone
-/
import Lake.Util.Name

namespace Lake

/-- The type of keys in the Lake build store. -/
inductive BuildKey
| moduleFacet (module : Name) (facet : Name)
| packageFacet (package : Name) (facet : Name)
| targetFacet (package : Name) (target : Name) (facet : Name)
| customTarget (package : Name) (target : Name)
deriving Inhabited, Repr, DecidableEq, Hashable

namespace BuildKey

def toString : (self : BuildKey) → String
| moduleFacet m f => s!"+{m}:{f}"
| packageFacet p f => s!"@{p}:{f}"
| targetFacet p t f => s!"{p}/{t}:{f}"
| customTarget p t => s!"{p}/{t}"

instance : ToString BuildKey := ⟨(·.toString)⟩

def quickCmp (k k' : BuildKey) : Ordering :=
  match k with
  | moduleFacet m f =>
    match k' with
    | moduleFacet m' f' =>
      match m.quickCmp m' with
      | .eq => f.quickCmp f'
      | ord => ord
    | _ => .lt
  | packageFacet p f =>
    match k' with
    | moduleFacet .. => .gt
    | packageFacet p' f' =>
      match p.quickCmp p' with
      | .eq => f.quickCmp f'
      | ord => ord
    | _ => .lt
  | targetFacet p t f =>
    match k' with
    | customTarget .. => .lt
    | targetFacet p' t' f' =>
      match p.quickCmp p' with
      | .eq =>
        match t.quickCmp t' with
        | .eq => f.quickCmp f'
        | ord => ord
      | ord => ord
    | _=> .gt
  | customTarget p t =>
    match k' with
    | customTarget p' t' =>
      match p.quickCmp p' with
      | .eq => t.quickCmp t'
      | ord => ord
    | _ => .gt

theorem eq_of_quickCmp {k k' : BuildKey}  :
quickCmp k k' = Ordering.eq → k = k' := by
  unfold quickCmp
  cases k with
  | moduleFacet m f =>
    cases k'
    case moduleFacet m' f' =>
      dsimp only; split
      next m_eq => intro f_eq; rw [eq_of_cmp m_eq, eq_of_cmp f_eq]
      next => intro; contradiction
    all_goals (intro; contradiction)
  | packageFacet p f =>
    cases k'
    case packageFacet p' f' =>
      dsimp only; split
      next p_eq => intro f_eq; rw [eq_of_cmp p_eq, eq_of_cmp f_eq]
      next => intro; contradiction
    all_goals (intro; contradiction)
  | targetFacet p t f =>
    cases k'
    case targetFacet p' t' f' =>
      dsimp only; split
      next p_eq =>
        split
        next t_eq =>
          intro f_eq
          rw [eq_of_cmp p_eq, eq_of_cmp t_eq, eq_of_cmp f_eq]
        next => intro; contradiction
      next => intro; contradiction
    all_goals (intro; contradiction)
  | customTarget p t =>
    cases k'
    case customTarget p' t' =>
      dsimp only; split
      next p_eq => intro t_eq; rw [eq_of_cmp p_eq, eq_of_cmp t_eq]
      next => intro; contradiction
    all_goals (intro; contradiction)

instance : LawfulCmpEq BuildKey quickCmp where
  eq_of_cmp := eq_of_quickCmp
  cmp_rfl {k} := by cases k <;> simp [quickCmp]


import breen_deligne.eval

noncomputable theory

namespace breen_deligne

open category_theory category_theory.limits category_theory.category
  category_theory.preadditive

variables {A₁ A₂ A₃ : Type*} [category A₁] [preadditive A₁] [has_finite_biproducts A₁]
  [category A₂] [preadditive A₂] --[has_finite_biproducts A₂]
  [category A₃] [preadditive A₃] --[has_finite_biproducts A₃]

namespace universal_map

variables {m n : ℕ} (f : universal_map m n)

def eval_Pow' (F : A₁ ⥤ A₂) : universal_map m n →+ (Pow m ⋙ F ⟶ Pow n ⋙ F) :=
free_abelian_group.lift $ λ g : basic_universal_map m n, whisker_right g.eval_Pow F

@[simp]
lemma eval_Pow'_of (F : A₁ ⥤ A₂) (f : basic_universal_map m n) :
  eval_Pow' F (free_abelian_group.of f) = whisker_right f.eval_Pow F :=
free_abelian_group.lift.of _ _

lemma eval_Pow'_hcomp (F : A₁ ⥤ A₂) (H : A₂ ⥤ A₃) [H.additive] :
  eval_Pow' F f ◫ 𝟙 H = eval_Pow' (F ⋙ H) f :=
begin
  revert f,
  let φ : universal_map m n →+ ((Pow m ⋙ F) ⋙ H ⟶ (Pow n ⋙ F) ⋙ H) :=
  { to_fun := λ f, whisker_right (eval_Pow' F f) H,
    map_zero' := by { ext, dsimp, simp only [map_zero, nat_trans.app_zero, functor.map_zero], },
    map_add' := λ f₁ f₂, by { ext, dsimp, simp only [map_add, nat_trans.app_add,
      functor.map_add], }, },
  suffices : φ = eval_Pow' (F ⋙ H),
  { intro f,
    change 𝟙 _ ≫ φ f = _,
    rw [category.id_comp, this], },
  ext1 f,
  simp only [add_monoid_hom.coe_mk, eval_Pow'_of, whisker_right_twice],
end

lemma map_eval_Pow' (F : A₁ ⥤ A₂) (H : A₂ ⥤ A₃) [H.additive] (M₁ : A₁) :
  H.map ((eval_Pow' F f).app M₁) = (eval_Pow' (F ⋙ H) f).app M₁ :=
by simpa only [nat_trans.hcomp_id_app] using nat_trans.congr_app (f.eval_Pow'_hcomp F H) M₁

lemma map_eval_Pow (F : A₁ ⥤ A₁) (H : A₁ ⥤ A₂) [H.additive] (M₁ : A₁) :
  H.map ((eval_Pow F f).app M₁) = (eval_Pow' (F ⋙ H) f).app M₁ :=
map_eval_Pow' f F H M₁

@[reassoc]
lemma congr_eval_Pow' {F F' : A₁ ⥤ A₂} (φ : F ⟶ F') (M₁ : A₁) :
  (eval_Pow' F f).app M₁ ≫ φ.app ((Pow n).obj M₁) =
  φ.app ((Pow m).obj M₁) ≫ (eval_Pow' F' f).app M₁ :=
begin
  revert f,
  let φ₁ : universal_map m n →+ ((Pow m ⋙ F).obj M₁ ⟶ (Pow n ⋙ F').obj M₁) :=
  { to_fun := λ f, (eval_Pow' F f).app M₁ ≫ φ.app ((Pow n).obj M₁),
    map_zero' := by simp only [map_zero, nat_trans.app_zero, zero_comp],
    map_add' := λ f₁ f₂, by simp only [map_add, nat_trans.app_add, add_comp], },
  let φ₂ : universal_map m n →+ ((Pow m ⋙ F).obj M₁ ⟶ (Pow n ⋙ F').obj M₁) :=
  { to_fun := λ f, φ.app ((Pow m).obj M₁) ≫ (eval_Pow' F' f).app M₁,
    map_zero' := by simp only [map_zero, nat_trans.app_zero, comp_zero],
    map_add' := λ f₁ f₂, by simp only [map_add, nat_trans.app_add, comp_add], },
  suffices : φ₁ = φ₂,
  { intro f,
    change φ₁ f = φ₂ f,
    rw this, },
  ext,
  dsimp only [φ₁, φ₂],
  simp only [add_monoid_hom.coe_mk, eval_Pow'_of, whisker_right_app, nat_trans.naturality],
end

end universal_map

end breen_deligne


import Lean.Data.Json
open Lean

deriving instance BEq for Except

example : Json.parse "\"\\u7406\\u79d1\"" == .ok "理科" := by native_decide
example : Json.parse "\"\\u7406\\u79D1\"" == .ok "理科" := by native_decide

example : Json.pretty "\x0b" == "\"\\u000b\"" := by native_decide
example : Json.pretty "\x1b" == "\"\\u001b\"" := by native_decide
example : Json.parse "\"\\u000b\"" == .ok "\x0b" := by native_decide
example : Json.parse "\"\\u001b\"" == .ok "\x1b" := by native_decide
example : Json.parse "\"\\u000B\"" == .ok "\x0b" := by native_decide
example : Json.parse "\"\\u001B\"" == .ok "\x1b" := by native_decide


import Qpf.Qpf

namespace Macro
  open Lean Meta Elab Term
  open Elab.Command (CommandElabM)

  open Lean.Parser.Term (binderIdent bracketedBinder)

  initialize
    registerTraceClass `QPF

  def elabCommand' (stx : TSyntax `command) : CommandElabM Unit := do
    trace[QPF] "CUSTOM ELABCOMMAND"
    try
      Elab.Command.elabCommand stx
    catch e =>
      throwError "{e.toMessageData}\n\n Error thrown while elaborating:\n\n {stx}"

  variable [MonadControlT MetaM n] [Monad n] [MonadLiftT MetaM n]
            [MonadError n] [MonadLog n] [AddMessageContext n]
            [MonadQuotation n] [MonadTrace n] [MonadOptions n]
            [MonadLiftT IO n]

  /--
    Takes an expression `e` of type `CurriedTypeFun n` and returns an expression of type `TypeFun n`
    representing the uncurried version of `e`.
    Tries to prevent unneccesary `ofCurried / curried` roundtrips
  -/
  def uncurry (F : Expr) (arity : Option Expr := none) : n Expr := do
    mkAppOptM ``TypeFun.ofCurried #[arity, some F]

    --
    -- Although preventing unneccesary `ofCurried / curried` roundtrips seems like a good idea,
    -- leaving them in actually causes more definitional equality (e.g., in the `_02_Tree` example)
    --

    -- let n       ← mkFreshExprMVar (mkConst ``Nat)
    -- let F_inner ← mkFreshExprMVar (kind:=MetavarKind.synthetic) none
    -- let us      ← mkFreshLevelMVars 2
    -- let app     := mkApp2 (mkConst ``TypeFun.curried us) n F_inner

    -- trace[QPF] "\nChecking defEq of {F} and {app}"
    -- if (←isDefEq F app) then
    --   if let some F' :=  (← getExprMVarAssignment? F_inner.mvarId!) then
    --     trace[QPF] "yes: {F'}"
    --     return F'

    -- trace[QPF] "no"
    -- mkAppM ``TypeFun.ofCurried #[F]

  def withLiveBinders [Inhabited α]
                  (binders : Array Syntax)
                  (f : Array Expr → n α) : n α
  := do
    let u := mkLevelSucc <|← mkFreshLevelMVar;
    let decls := binders.map fun α => (
      α.getId,
      fun _ => pure (mkSort u)
    )

    withLocalDeclsD decls f

  /--
    Takes an array of bracketed binders, and allocate a fresh identifier for each hole in the binders.
    Returns a pair of the binder syntax with all holes replaced, and an array of all bound identifiers,
    both pre-existing and newly created
  -/
  def mkFreshNamesForBinderHoles (binders : Array Syntax) :
      n ((TSyntaxArray ``bracketedBinder) × (Array Ident))
  := do
    let mut bindersNoHoles := #[]
    let mut binderNames := #[]

    for stx in binders do
      let mut newArgStx := Syntax.missing
      let kind := stx.getKind

      if kind == ``Lean.Parser.Term.instBinder then
        if stx[1].isNone then
          throwErrorAt stx "Instances without names are not supported yet"
          -- let id := mkIdentFrom stx (← mkFreshBinderName)
          -- binderNames := binderNames.push id
          -- newArgStx := stx[1].setArgs #[id, Syntax.atom SourceInfo.none ":"]
        else
          trace[QPF] stx[1]
          let id := stx[1][0]
          binderNames := binderNames.push ⟨id⟩
          newArgStx := stx[1]

      else
        -- replace each hole with a fresh id
        let ids ← stx[1].getArgs.mapM fun (id : Syntax) => do
          trace[QPF] "{id}"
          let kind := id.getKind
          if kind == identKind then
            return id
          else if kind == ``Lean.Parser.Term.hole then
            return mkIdentFrom id (← mkFreshBinderName)
          else
            throwErrorAt id "identifier or `_` expected, found {kind}"

        for id in ids do
          binderNames := binderNames.push ⟨id⟩
        newArgStx := stx[1].setArgs ids

      let newStx := stx.setArg 1 newArgStx
      bindersNoHoles := bindersNoHoles.push ⟨newStx⟩

    return (bindersNoHoles, binderNames)

  inductive BinderKind
    | explicit
    | implicit
    | ident
    deriving DecidableEq, BEq, Inhabited

  open Lean.Parser.Term (explicitBinder implicitBinder) in
  /-- Parse a `BinderKind` from a `SyntaxNodeKind` -/
  def BinderKind.ofSyntaxKind (kind : SyntaxNodeKind) : BinderKind :=
    if kind == ``implicitBinder then
          .implicit
        else if kind == ``Lean.binderIdent
                || kind == ``Lean.Parser.Term.binderIdent
                || kind == ``Lean.Parser.Term.ident
                || kind == ``Lean.Parser.ident
                -- HACK: this one should be just a single backquote
                || kind == `ident
                then
          .ident
        else if kind == ``explicitBinder then
          .explicit
        else
          panic s!"Bug: unexpected binder kind `{kind}"

  open Lean.Parser.Term in
  /--
    Takes a list of binders, and split it into live and dead binders, respectively.
    For the live binders, return an array of with syntax of kind `binderIdent`, unwrapping
    `simpleBinder` nodes if needed (while asserting that there were no type annotations)
  -/
  def splitLiveAndDeadBinders (binders : Array Syntax)
      : n (TSyntaxArray ``Lean.Parser.Term.binderIdent × TSyntaxArray ``bracketedBinder) := do
    let mut liveVars := #[]
    let mut deadBinders := #[]

    let mut isLive := false
    for binder in binders do
      let kind := BinderKind.ofSyntaxKind binder.getKind

      if kind == .ident then
        isLive := true
        liveVars := liveVars.push ⟨binder⟩

      -- else if kind == .explicit then
      --   isLive := true
      --   for id in binder[0].getArgs do
      --     liveVars := liveVars.push id

      --   if !binder[1].isNone then
      --     trace[QPF] binder[1]
      --     throwErrorAt binder "live variable may not have a type annotation.\nEither add brackets to mark the variable as dead, or remove the type"

      else if isLive then
        throwErrorAt binder f!"Unexpected bracketed binder, dead arguments must precede all live arguments.\nPlease reorder your arguments or mark this binder as live by removing brackets and/or type ascriptions"

      else
        deadBinders := deadBinders.push ⟨binder⟩

    return (liveVars, deadBinders)

  /--
    Takes a list of binders, and returns an array of just the bound identifiers,
    for use in applications
  -/
  def getBinderIdents (binders : Array Syntax) (includeImplicits := true)
    : Array Term :=
  Id.run do
    let mut idents : Array Term := #[]

    for binder in binders do
      let kind := BinderKind.ofSyntaxKind binder.getKind

      if kind == .implicit && !includeImplicits then
        continue

      else if kind == .ident then
        idents := idents.push ⟨binder⟩

      else
        for id in binder[1].getArgs do
          idents := idents.push ⟨id⟩

    -- dbg_trace "idents = {idents}"
    pure idents

open Parser.Command in
instance : Quote Modifiers (k := ``declModifiers) where
  quote mod :=
    let isNoncomputable : Syntax :=
      if mod.isNoncomputable then
        mkNode ``«noncomputable» #[mkAtom "noncomputable "]
      else
        mkNullNode

    let visibility := match mod.visibility with
      | .regular     => mkNullNode
      | .«protected» => mkNode ``«protected» #[mkAtom "protected "]
      | .«private»   => mkNode ``«private» #[mkAtom "private "]

    mkNode ``declModifiers #[
      mkNullNode, -- docComment
      mkNullNode, -- Term.attributes
      visibility, -- visibility
      isNoncomputable, -- isNoncomputable
      mkNullNode, -- unsafe
      mkNullNode  -- partial / nonrec
    ]

  -- open Lean.Parser.Term in
  -- elab "#dbg_syntax " t:term : command => do
  --   dbg_trace t

  -- open Lean.Parser.Term Elab.Command in
  -- elab "#dbg_expr " t:term : command => do
  --   let expr ← liftTermElabM none $ elabTerm t none
  --   dbg_trace expr
  --   dbg_trace expr.isForall

  -- #dbg_expr (Nat → Int)

end Macro

-- set_option pp.raw true

-- open Lean in
-- elab "#dbg_ident" id:binderIdent : command => do
--   dbg_trace "{id}"
--   let id := id.raw
--   dbg_trace "kind: {id.getKind}"
--   dbg_trace "args: {id.getArgs}"
--   dbg_trace "args[0].getKind: {id.getArgs[0]!.getKind}"

-- #dbg_ident x
-- #dbg_ident _

-- example : ``Lean.binderIdent = ``Lean.Parser.Term.binderIdent :=
--   by rfl


import Architectural.ArchWithContracts
import Architectural.proofObligations

@[derive [fintype, decidable_eq]]
inductive PORTS
| fault_LAAPRequest_LACU
| fault_armPositionAngle1_LACU
| fault_LAAPSetpoint_LAAP
| fault_lockingSwitchPosition_LACU
| fault_LAAPRequest_LAAP
| fault_operatorControlLever_LAAP
| fault_operatorControlLever_LACU
| fault_LAAPFlow_armController
| fault_groundSpeed_LACU
| fault_armDeactivated_armController
| fault_input1_armPosition
| fault_output_armPosition
| fault_LAAPFlow_LAAP
| fault_armPositionAngle2_LACU
| fault_armFlow_armController
| fault_LAAPActive_LAAP
| fault_groundSpeed_armController
| fault_operatorConstrolLever_armController
| fault_LAAPSetpoint_LACU
| fault_PWMFlow_LACU
| fault_angleSensor_armController
| fault_input2_armPosition
| fault_LAAPActive_armController
| fault_angleSensor_LAAP
| fault_groundSpeed_LAAP
open PORTS

def LAAP : Component PORTS := {
  ports :=
    ⟨
      [fault_angleSensor_LAAP,
        fault_LAAPRequest_LAAP,
        fault_LAAPSetpoint_LAAP,
        fault_operatorControlLever_LAAP,
        fault_groundSpeed_LAAP,
        fault_LAAPFlow_LAAP,
      fault_LAAPActive_LAAP]
    ,
    by {dec_trivial}⟩
  }

@[reducible]
def LACU : Component PORTS := {
  ports := {
    val := [
      fault_armPositionAngle1_LACU,
      fault_armPositionAngle2_LACU,
      fault_LAAPRequest_LACU,
      fault_LAAPSetpoint_LACU,
      fault_operatorControlLever_LACU,
      fault_groundSpeed_LACU,
      fault_lockingSwitchPosition_LACU,
      fault_PWMFlow_LACU
    ],
    nodup := by {dec_trivial}
  }
}

@[reducible]
def armPosition : Component PORTS := {
  ports := {
    val := [
      fault_input1_armPosition,
      fault_input2_armPosition,
      fault_output_armPosition
    ],
    nodup := by {dec_trivial}
  }
}

@[reducible]
def armController : Component PORTS := {
  ports := {
    val := [
      fault_angleSensor_armController,
      fault_LAAPFlow_armController,
      fault_LAAPActive_armController,
      fault_operatorConstrolLever_armController,
      fault_groundSpeed_armController,
      fault_armDeactivated_armController,
      fault_armFlow_armController
    ],
    nodup := by {dec_trivial}
  }
}

@[reducible]
def LACU_ARCH_MODEL : Architecture LACU :=
{
  subs := [
    armPosition,
    LAAP,
    armController
  ],
  delegation :=
  [
  (fault_armPositionAngle1_LACU, fault_input1_armPosition),
  (fault_armPositionAngle2_LACU, fault_input2_armPosition),
  (fault_PWMFlow_LACU, fault_armFlow_armController),
  (fault_output_armPosition, fault_angleSensor_LAAP),
  (fault_output_armPosition, fault_angleSensor_armController),
  (fault_LAAPRequest_LACU, fault_LAAPRequest_LAAP),
  (fault_operatorControlLever_LAAP, fault_operatorControlLever_LACU),
  (fault_LAAPActive_armController, fault_LAAPActive_LAAP),
  (fault_LAAPFlow_armController, fault_LAAPFlow_LAAP),
  (fault_operatorConstrolLever_armController, fault_operatorControlLever_LACU)
  ]
}

theorem distinct_1 : armPosition ≠ armController := by {exact of_to_bool_ff rfl,}
theorem distinct_2 : armPosition ≠ LAAP := by {exact of_to_bool_ff rfl,}
theorem distinct_3 : armController ≠ LAAP := by {exact of_to_bool_ff rfl,}