/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.Lean3Lib.data.buffer.parser
import Mathlib.tactic.core
import Mathlib.PostPort

namespace Mathlib

/-!
# The `alias` command

This file defines an `alias` command, which can be used to create copies
of a theorem or definition with different names.

Syntax:

```lean
/-- doc string -/

alias my_theorem ← alias1 alias2 ...
```

This produces defs or theorems of the form:

```lean
/-- doc string -/
/-- doc string -/
namespace tactic.alias

/--
The `alias` command can be used to create copies
of a theorem or definition with different names.

Syntax:

```lean
/-- doc string -/
/-- doc string -/
/-- doc string -/


/-
Copyright (c) 2022 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Lean.Elab.Command
import Lean.Linter.Util
import Std.Lean.AttributeExtra

namespace Std.Linter
open Lean Elab Command Linter

/--
Enables the 'unnecessary `<;>`' linter. This will warn whenever the `<;>` tactic combinator
is used when `;` would work.

```
example : True := by apply id <;> trivial
```
The `<;>` is unnecessary here because `apply id` only makes one subgoal.
Prefer `apply id; trivial` instead.

In some cases, the `<;>` is syntactically necessary because a single tactic is expected:
```
example : True := by
  cases () with apply id <;> apply id
  | unit => trivial
```
In this case, you should use parentheses, as in `(apply id; apply id)`:
```
example : True := by
  cases () with (apply id; apply id)
  | unit => trivial
```
-/
register_option linter.unnecessarySeqFocus : Bool := {
  defValue := true
  descr := "enable the 'unnecessary <;>' linter"
}
example : True := by
  cases () with apply id <;> apply id
  | unit => trivial

namespace UnnecessarySeqFocus

/-- Gets the value of the `linter.unnecessarySeqFocus` option. -/
def getLinterUnnecessarySeqFocus (o : Options) : Bool :=
  getLinterValue linter.unnecessarySeqFocus o

/--
The `multigoal` attribute keeps track of tactics that operate on multiple goals,
meaning that `tac` acts differently from `focus tac`. This is used by the
'unnecessary `<;>`' linter to prevent false positives where `tac <;> tac'` cannot
be replaced by `(tac; tac')` because the latter would expose `tac` to a different set of goals.
-/
initialize multigoalAttr : TagAttributeExtra ←
  registerTagAttributeExtra `multigoal "this tactic acts on multiple goals" [
    ``Parser.Tactic.«tacticNext_=>_»,
    ``Parser.Tactic.allGoals,
    ``Parser.Tactic.anyGoals,
    ``Parser.Tactic.case,
    ``Parser.Tactic.case',
    ``Parser.Tactic.Conv.«convNext_=>_»,
    ``Parser.Tactic.Conv.allGoals,
    ``Parser.Tactic.Conv.anyGoals,
    ``Parser.Tactic.Conv.case,
    ``Parser.Tactic.Conv.case',
    ``Parser.Tactic.rotateLeft,
    ``Parser.Tactic.rotateRight,
    ``Parser.Tactic.tacticShow_,
    ``Parser.Tactic.tacticStop_
  ]

/-- The information we record for each `<;>` node appearing in the syntax. -/
structure Entry where
  /-- The `<;>` node itself. -/
  stx : Syntax
  /--
  * `true`: this `<;>` has been used unnecessarily at least once
  * `false`: it has never been executed
  * If it has been used properly at least once, the entry is removed from the table.
  -/
  used : Bool

/-- The monad for collecting used tactic syntaxes. -/
abbrev M (ω) := StateRefT (HashMap String.Range Entry) (ST ω)

/-- True if this is a `<;>` node in either `tactic` or `conv` classes. -/
@[inline] def isSeqFocus (k : SyntaxNodeKind) : Bool :=
  k == ``Parser.Tactic.«tactic_<;>_» || k == ``Parser.Tactic.Conv.«conv_<;>_»

/-- Accumulates the set of tactic syntaxes that should be evaluated at least once. -/
@[specialize] partial def getTactics {ω} (stx : Syntax) : M ω Unit := do
  if let .node _ k args := stx then
    if isSeqFocus k then
      let r := stx.getRange? true
      if let some r := r then
        modify fun m => m.insert r { stx, used := false }
    args.forM getTactics

/--
Traverse the info tree down a given path.
Each `(n, i)` means that the array must have length `n` and we will descend into the `i`'th child.
-/
def getPath : Info → PersistentArray InfoTree → List ((n : Nat) × Fin n) → Option Info
  | i, _, [] => some i
  | _, c, ⟨n, i, h⟩::ns =>
    if e : c.size = n then
      if let .node i c' := c[i]'(e ▸ h) then getPath i c' ns else none
    else none

mutual
variable (env : Environment)
/-- Search for tactic executions in the info tree and remove executed tactic syntaxes. -/
partial def markUsedTacticsList (trees : PersistentArray InfoTree) : M ω Unit :=
  trees.forM markUsedTactics

/-- Search for tactic executions in the info tree and remove executed tactic syntaxes. -/
partial def markUsedTactics : InfoTree → M ω Unit
  | .node i c => do
    if let .ofTacticInfo i := i then
      if let some r := i.stx.getRange? true then
      if let some entry := (← get).find? r then
      if i.stx.getKind == ``Parser.Tactic.«tactic_<;>_» then
        let isBad := do
          unless i.goalsBefore.length == 1 || !multigoalAttr.hasTag env i.stx[0].getKind do
            none
          -- Note: this uses the exact sequence of tactic applications
          -- in the macro expansion of `<;> : tactic`
          let .ofTacticInfo i ← getPath (.ofTacticInfo i) c
            [⟨1, 0⟩, ⟨2, 1⟩, ⟨1, 0⟩, ⟨5, 0⟩] | none
          guard <| i.goalsAfter.length == 1
        modify fun s => if isBad.isSome then s.insert r { entry with used := true } else s.erase r
      else if i.stx.getKind == ``Parser.Tactic.Conv.«conv_<;>_» then
        let isBad := do
          unless i.goalsBefore.length == 1 || !multigoalAttr.hasTag env i.stx[0].getKind do
            none
          -- Note: this uses the exact sequence of tactic applications
          -- in the macro expansion of `<;> : conv`
          let .ofTacticInfo i ← getPath (.ofTacticInfo i) c
            [⟨1, 0⟩, ⟨1, 0⟩, ⟨1, 0⟩, ⟨1, 0⟩, ⟨1, 0⟩, ⟨2, 1⟩, ⟨1, 0⟩, ⟨5, 0⟩] | none
          guard <| i.goalsAfter.length == 1
        modify fun s => if isBad.isSome then s.insert r { entry with used := true } else s.erase r
    markUsedTacticsList c
  | .context _ t => markUsedTactics t
  | .hole _ => pure ()

end

/-- The main entry point to the unused tactic linter. -/
partial def unnecessarySeqFocusLinter : Linter := fun stx => do
  unless getLinterUnnecessarySeqFocus (← getOptions) && (← getInfoState).enabled do
    return
  if (← get).messages.hasErrors then
    return
  let trees ← getInfoTrees
  let env ← getEnv
  let go {ω} : M ω Unit := do
    getTactics stx
    markUsedTacticsList env trees
  let (_, map) := runST fun _ => go.run {}
  let unused := map.fold (init := #[]) fun acc r { stx, used } =>
    if used then acc.push (stx[1].getRange?.getD r, stx[1]) else acc
  let key (r : String.Range) := (r.start.byteIdx, (-r.stop.byteIdx : Int))
  let mut last : String.Range := ⟨0, 0⟩
  for (r, stx) in let _ := @lexOrd; let _ := @ltOfOrd.{0}; unused.qsort (key ·.1 < key ·.1) do
    if last.start ≤ r.start && r.stop ≤ last.stop then continue
    logLint linter.unnecessarySeqFocus stx
      "Used `tac1 <;> tac2` where `(tac1; tac2)` would suffice"
    last := r

initialize addLinter unnecessarySeqFocusLinter


theorem unsound : False := -- Error
  unsound

partial theorem unsound : False := -- Error
  unsound

unsafe theorem unsound : False := -- Error
  unsound

constant unsound : False  -- Error

axiom magic : False -- OK

partial def foo (x : Nat) : Nat := foo x  -- OK

unsafe def unsound2 : False := unsound  -- OK

partial def unsound3 : False := unsound3  -- Error

partial def badcast1 (x : Nat) : Bool :=
  unsafeCast x -- Error: partial cannot use unsafe constant

partial def badcast2 (x : Nat) : Bool :=
  if x == 0 then unsafeCast x -- Error: partial cannot use unsafe constant
  else badcast2 (x + 1)

unsafe def badcast3 (x : Nat) : Bool := -- OK
  if x == 0 then unsafeCast x
  else badcast3 (x + 1)


import Lean
import Mathlib.Control.Writer
import PremiseSelection.StatementFeatures
import PremiseSelection.ProofSource

namespace PremiseSelection

open Lean Lean.Elab Lean.Elab.Term Lean.Elab.Command Lean.Meta System

/-- Holds the name, features and premises of a single theorem. -/
structure TheoremPremises where
  name              : Name
  features          : StatementFeatures
  argumentsFeatures : Array StatementFeatures
  premises          : Multiset Name

instance : ToJson TheoremPremises where
  toJson data :=
    Json.mkObj [
      ("name",              toJson data.name),
      ("features",          toJson data.features),
      ("argumentsFeatures", toJson data.argumentsFeatures),
      ("premises",          toJson data.premises)
    ]

instance : ToString TheoremPremises where
  toString := Json.pretty ∘ toJson

/-- Used to choose the feature format: nameCounts and/or bigramCounts and/or
trigramCounts -/
structure FeatureFormat where
  n : Bool := true
  b : Bool := true
  t : Bool := true
deriving Inhabited

/-- Structure to put together all the user options: max expression depth, filter
user premises and feature format. -/
structure UserOptions where
  minDepth : UInt32        := 0
  maxDepth : UInt32        := 255
  noAux    : Bool          := false
  source   : Bool          := false
  math     : Bool          := false
  format   : FeatureFormat := default
deriving Inhabited

/-- Features used for training. All the features (arguments and theorem) should
be put together in a sequence tagged with `T` for theorem or `H` for
hypotheses.  -/
def getFeatures (tp : TheoremPremises) (format : FeatureFormat) : String :=
  Id.run <| do
    let statementF := tp.features
    let argsF := tp.argumentsFeatures
    let mut result : Array String := #[]
    if format.n then
      result := result ++ statementF.nameCounts.toTFeatures ++
        argsF.concatMap (Multiset.toHFeatures ∘ StatementFeatures.nameCounts)
    if format.b then
      result := result ++ statementF.bigramCounts.toTFeatures ++
        argsF.concatMap (Multiset.toHFeatures ∘ StatementFeatures.bigramCounts)
    if format.t then
      result := result ++ statementF.trigramCounts.toTFeatures ++
        argsF.concatMap (Multiset.toHFeatures ∘ StatementFeatures.trigramCounts)
    return " ".intercalate result.data

/-- Premises are simply concatenated. -/
def getLabels (tp : TheoremPremises) : String :=
  let thmName := tp.name.toString
  thmName ++ " : " ++ (" ".intercalate (tp.premises.toList.map toString))

section CoreExtractor

/-- Given a name `n`, if it qualifies as a premise, it returns `[n]`, otherwise
it returns the empty list. -/
private def getTheoremFromName (n : Name) : MetaM (Multiset Name) := do
  -- Get all consts whose type is of type Prop.
  if let some cinfo := (← getEnv).find? n then
    if (← inferType cinfo.type).isProp then
      pure (Multiset.singleton n)
    else
      pure Multiset.empty
  else pure Multiset.empty

private def getTheoremFromExpr (e : Expr) : MetaM (Multiset Name) := do
  if let .const n _ := e then getTheoremFromName n else pure Multiset.empty

private def visitPremise (e : Expr) : WriterT (Multiset Name) MetaM Unit := do
  getTheoremFromExpr e >>= tell

private def extractPremises (e : Expr) : MetaM (Multiset Name) := do
  let ((), premises) ← WriterT.run <| forEachExpr visitPremise e
  pure premises

/-- Given a `ConstantInfo` that holds theorem data, it finds the premises used
in the proof and constructs an object of type `PremisesData` with all. -/
private def extractPremisesFromConstantInfo
  (minDepth : UInt32 := 0) (maxDepth : UInt32 := 255)
  : ConstantInfo → MetaM (Option TheoremPremises)
  | ConstantInfo.thmInfo { name := n, type := ty, value := v, .. } => do
      let (thmFeats, argsFeats) ← getThmAndArgsFeatures ty
      -- Heuristic that can be used to ignore simple theorems and to avoid long
      -- executions for deep theorems.
      if minDepth <= v.approxDepth && v.approxDepth < maxDepth then
        pure <| TheoremPremises.mk n thmFeats argsFeats (← extractPremises v)
      else
        pure none
  | _ => pure none

end CoreExtractor

section Variants

/-- Same as `extractPremisesFromConstantInfo` but take an idenitfier and gets
its information from the environment. -/
def extractPremisesFromId
  (minDepth : UInt32 := 0) (maxDepth : UInt32 := 255) (id : Name)
  : MetaM (Option TheoremPremises) := do
  if let some cinfo := (← getEnv).find? id then
    extractPremisesFromConstantInfo minDepth maxDepth cinfo
  else pure none

/-- Extract and print premises from a single theorem. -/
def extractPremisesFromThm
  (minDepth : UInt32 := 0) (maxDepth : UInt32 := 255) (stx : Syntax)
  : MetaM (Array TheoremPremises) := do
  let mut thmData : Array TheoremPremises := #[]
  for name in ← resolveGlobalConst stx do
    if let some data ← extractPremisesFromId minDepth maxDepth name then
      thmData := thmData.push data
  return thmData

/-- Extract and print premises from all the theorems in the context. -/
def extractPremisesFromCtx (minDepth : UInt32 := 0) (maxDepth : UInt32 := 255)
  : MetaM (Array TheoremPremises) := do
  let mut ctxData : Array TheoremPremises := #[]
  for (_, cinfo) in (← getEnv).constants.toList do
    let data? ← extractPremisesFromConstantInfo minDepth maxDepth cinfo
    if let some data := data? then
      ctxData := ctxData.push data
  return ctxData

end Variants

section FromImports

open IO IO.FS

/-- Given a way to insert `TheoremPremises`, this function goes through all
the theorems in a module, extracts the premises filtering them appropriately
and inserts the resulting data. -/
private def extractPremisesFromModule
  (insert : TheoremPremises → IO Unit)
  (moduleName : Name) (moduleData : ModuleData)
  (minDepth maxDepth : UInt32) (noAux source math : Bool := false)
  : MetaM Unit := do
  dbg_trace s!"Extracting premises from {moduleName}."
  let mut filter : Name → Multiset Name → MetaM (Multiset Name × Bool) :=
    fun _ ns => pure (ns, false)
  -- Source filter.
  if source then
    if let some modulePath ← proofSourcePath moduleName then
      -- Avoid very large files. In particular mathbin files over 2MB.
      let mut fileSize := 0
      let pathFromImport :=
        if moduleName.getRoot == `Mathbin then
          pathFromMathbinImport
        else pathFromMathlibImport
      if let some synportPath ← pathFromImport moduleName then
        let mdata ← System.FilePath.metadata synportPath
        fileSize := mdata.byteSize
      if fileSize == 0 then
        dbg_trace s! "Aborted {moduleName}, ported file not found"
        return ()
      if fileSize > 2 * 1024 * 1024 then
        dbg_trace s! "Aborted {moduleName}, size {fileSize}"
        return ()

      -- If source premises and path found, then create a filter looking at
      -- proof source. If no proof source is found, no filter is applied.
      let data ← IO.FS.readFile modulePath
      let proofsJson :=
        match Json.parse data with
        | Except.ok json => json
        | Except.error _ => Json.null
      filter := fun thmName premises => do
        if let some source ← proofSource thmName proofsJson then
          return (filterUserPremises premises source, true)
        else return (premises, false)
  -- Math-only filter.
  else if math then
    let allNamesPath := "data/math_names"
    filter := fun _ premises => do
      let mut filteredPremises : Multiset Name := ∅
      for (premise, count) in premises do
        let output ← IO.Process.output {
          cmd := "grep",
          args := #["-x", premise.toString, allNamesPath] }
        if output.exitCode == 0 && !output.stdout.isEmpty then
          filteredPremises := filteredPremises.insert premise count
      return (filteredPremises, true)

  -- Go through all theorems in the module, filter premises and write.
  let mut countFoundAndNotEmpty := 0
  let mut countFound := 0
  let mut countTotal := 0
  for cinfo in moduleData.constants do
    let data? ← extractPremisesFromConstantInfo minDepth maxDepth cinfo
    if let some data := data? then
      countTotal := countTotal + 1
      let mut filteredPremises : Multiset Name := ∅
      let (filterResult, found) ← filter data.name data.premises
      filteredPremises := filterResult
      if noAux || source || math then
        filteredPremises ← noAuxFilter filteredPremises
      if !source && !filteredPremises.isEmpty then
        countFoundAndNotEmpty := countFoundAndNotEmpty + 1
        let filteredData := { data with premises := filteredPremises }
        insert filteredData
      if source then
        if found then
          countFound := countFound + 1
        if found && !filteredPremises.isEmpty then
          countFoundAndNotEmpty := countFoundAndNotEmpty + 1
          let filteredData := { data with premises := filteredPremises }
          insert filteredData
  if source then
    dbg_trace s!"Total : {countTotal}"
    dbg_trace s!"Found in source : {countFound}"
    dbg_trace s!"Found and not empty : {countFoundAndNotEmpty}"
  else
    dbg_trace s!"Total : {countTotal}"
    dbg_trace s!"Not empty : {countFoundAndNotEmpty}"
  return ()
  where
    blackList : List String := ["._", "_private.", "_Private."]

    noAuxFilter (premises : Multiset Name) : MetaM (Multiset Name) := do
      let mut result : Multiset Name := ∅
      for (p, c) in premises do
        if !(blackList.any (·.isSubstrOf p.toString)) then
          result := result.insert p c
      return result

/-- Call `extractPremisesFromModule` with an insertion mechanism that writes
to the specified files for labels and features. -/
def extractPremisesFromModuleToFiles
  (moduleName : Name) (moduleData : ModuleData)
  (labelsPath featuresPath : FilePath) (userOptions : UserOptions := default)
  : MetaM Unit := do
  let labelsHandle ← Handle.mk labelsPath Mode.append false
  let featuresHandle ← Handle.mk featuresPath Mode.append false

  let insert : TheoremPremises → IO Unit := fun data => do
    labelsHandle.putStrLn (getLabels data)
    featuresHandle.putStrLn (getFeatures data userOptions.format)

  let minDepth := userOptions.minDepth
  let maxDepth := userOptions.maxDepth
  let noAux := userOptions.noAux
  let source := userOptions.source
  let math := userOptions.math
  extractPremisesFromModule
    insert moduleName moduleData minDepth maxDepth noAux source math

/-- Go through the whole module and find the defininions that appear in the
corresponding source file. This was used to generate `math_names`. -/
def extractUserDefinitionsFromModuleToFile
  (moduleName : Name) (moduleData : ModuleData) (outputPath : FilePath)
  : MetaM Unit := do
  let labelsHandle ← Handle.mk outputPath Mode.append false
  for cinfo in moduleData.constants do
    if let some modulePath ← pathFromMathbinImport moduleName then
      let args := #[cinfo.name.toString, modulePath.toString]
      let output ← IO.Process.output { cmd := "grep", args := args }
      if output.exitCode == 0 && !output.stdout.isEmpty then
        labelsHandle.putStrLn cinfo.name.toString

/-- Looks through all the meaningful imports and applies
`extractPremisesFromModuleToFiles` to each of them. -/
def extractPremisesFromImportsToFiles
  (labelsPath featuresPath : FilePath) (userOptions : UserOptions := default)
  : MetaM Unit := do
  dbg_trace s!"Clearing {labelsPath} and {featuresPath}."

  IO.FS.writeFile labelsPath ""
  IO.FS.writeFile featuresPath ""

  dbg_trace s!"Extracting premises from imports to {labelsPath}, {featuresPath}."

  let env ← getEnv
  let imports := env.imports.map (·.module)
  let moduleNamesArray := env.header.moduleNames
  let moduleDataArray := env.header.moduleData

  let mut count := 0
  for (moduleName, moduleData) in Array.zip moduleNamesArray moduleDataArray do
    let isMathImport :=
      moduleName.getRoot == `Mathbin || moduleName.getRoot == `Mathlib
    if imports.contains moduleName && isMathImport then
      count := count + 1
      extractPremisesFromModuleToFiles
        moduleName moduleData labelsPath featuresPath userOptions
      dbg_trace s!"count = {count}."

  pure ()

end FromImports

section Json

def extractPremisesFromCtxJson : MetaM Json :=
  toJson <$> extractPremisesFromCtx

def extractPremisesFromThmJson (stx : Syntax) : MetaM Json :=
  toJson <$> extractPremisesFromThm (stx := stx)

end Json

section Commands

private def runAndPrint [ToJson α] (f : MetaM α) : CommandElabM Unit :=
  liftTermElabM <| do dbg_trace s!"{Json.pretty <| toJson <| ← f}"

elab "extract_premises_from_thm " id:term : command =>
  runAndPrint <| extractPremisesFromThm (stx := id)

elab "extract_premises_from_ctx" : command =>
  runAndPrint <| extractPremisesFromCtx

syntax (name := extract_premises_to_files)
  "extract_premises_to_files l:" str " f:" str : command

@[command_elab «extract_premises_to_files»]
unsafe def elabExtractPremisesToFiles : CommandElab
| `(extract_premises_to_files l:$lp f:$fp) => liftTermElabM <| do
  let labelsPath ← evalTerm String (mkConst `String) lp.raw
  let featuresPath ← evalTerm String (mkConst `String) fp.raw
  extractPremisesFromImportsToFiles labelsPath featuresPath
| _ => throwUnsupportedSyntax

end Commands

end PremiseSelection


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Sebastian Ullrich
-/
import Std.ShareCommon
import Lean.Parser.Command
import Lean.Util.CollectLevelParams
import Lean.Util.FoldConsts
import Lean.Meta.CollectFVars
import Lean.Elab.Command
import Lean.Elab.SyntheticMVars
import Lean.Elab.Binders
import Lean.Elab.DeclUtil
namespace Lean.Elab

inductive DefKind where
  | «def» | «theorem» | «example» | «opaque» | «abbrev»
  deriving Inhabited

def DefKind.isTheorem : DefKind → Bool
  | «theorem» => true
  | _         => false

def DefKind.isDefOrAbbrevOrOpaque : DefKind → Bool
  | «def»    => true
  | «opaque» => true
  | «abbrev» => true
  | _        => false

def DefKind.isExample : DefKind → Bool
  | «example» => true
  | _         => false

structure DefView where
  kind          : DefKind
  ref           : Syntax
  modifiers     : Modifiers
  declId        : Syntax
  binders       : Syntax
  type?         : Option Syntax
  value         : Syntax
  deriving Inhabited

namespace Command

open Meta

def mkDefViewOfAbbrev (modifiers : Modifiers) (stx : Syntax) : DefView :=
  -- leading_parser "abbrev " >> declId >> optDeclSig >> declVal
  let (binders, type) := expandOptDeclSig (stx.getArg 2)
  let modifiers       := modifiers.addAttribute { name := `inline }
  let modifiers       := modifiers.addAttribute { name := `reducible }
  { ref := stx, kind := DefKind.abbrev, modifiers := modifiers,
    declId := stx.getArg 1, binders := binders, type? := type, value := stx.getArg 3 }

def mkDefViewOfDef (modifiers : Modifiers) (stx : Syntax) : DefView :=
  -- leading_parser "def " >> declId >> optDeclSig >> declVal
  let (binders, type) := expandOptDeclSig (stx.getArg 2)
  { ref := stx, kind := DefKind.def, modifiers := modifiers,
    declId := stx.getArg 1, binders := binders, type? := type, value := stx.getArg 3 }

def mkDefViewOfTheorem (modifiers : Modifiers) (stx : Syntax) : DefView :=
  -- leading_parser "theorem " >> declId >> declSig >> declVal
  let (binders, type) := expandDeclSig (stx.getArg 2)
  { ref := stx, kind := DefKind.theorem, modifiers := modifiers,
    declId := stx.getArg 1, binders := binders, type? := some type, value := stx.getArg 3 }

namespace MkInstanceName

-- Table for `mkInstanceName`
private def kindReplacements : NameMap String :=
  Std.RBMap.ofList [
    (``Parser.Term.depArrow, "DepArrow"),
    (``Parser.Term.«forall», "Forall"),
    (``Parser.Term.arrow, "Arrow"),
    (``Parser.Term.prop,  "Prop"),
    (``Parser.Term.sort,  "Sort"),
    (``Parser.Term.type,  "Type")
  ]

abbrev M := StateRefT String CommandElabM

def isFirst : M Bool :=
  return (← get) == ""

def append (str : String) : M Unit :=
  modify fun s => s ++ str

partial def collect (stx : Syntax) : M Unit := do
  match stx with
  | Syntax.node k args =>
    unless (← isFirst) do
      match kindReplacements.find? k with
      | some r => append r
      | none   => pure ()
    for arg in args do
      collect arg
  | Syntax.ident (preresolved := preresolved) .. =>
    unless preresolved.isEmpty && (← resolveGlobalName stx.getId).isEmpty do
      match stx.getId.eraseMacroScopes with
      | Name.str _ str _ =>
          if str[0].isLower then
            append str.capitalize
          else
            append str
      | _ => pure ()
  | _ => pure ()

def mkFreshInstanceName : CommandElabM Name := do
  let s ← get
  let idx := s.nextInstIdx
  modify fun s => { s with nextInstIdx := s.nextInstIdx + 1 }
  return Lean.Elab.mkFreshInstanceName s.env idx

partial def main (type : Syntax) : CommandElabM Name := do
  /- We use `expandMacros` to expand notation such as `x < y` into `LT.lt x y` -/
  let type ← liftMacroM <| expandMacros type
  let (_, str) ← collect type |>.run ""
  if str.isEmpty then
    mkFreshInstanceName
  else
    liftMacroM <| mkUnusedBaseName <| Name.mkSimple ("inst" ++ str)

end MkInstanceName

def mkDefViewOfConstant (modifiers : Modifiers) (stx : Syntax) : CommandElabM DefView := do
  -- leading_parser "constant " >> declId >> declSig >> optional declValSimple
  let (binders, type) := expandDeclSig (stx.getArg 2)
  let val ← match (stx.getArg 3).getOptional? with
    | some val => pure val
    | none     =>
      let val ← `(arbitrary)
      pure $ Syntax.node ``Parser.Command.declValSimple #[ mkAtomFrom stx ":=", val ]
  return {
    ref := stx, kind := DefKind.opaque, modifiers := modifiers,
    declId := stx.getArg 1, binders := binders, type? := some type, value := val
  }

def mkDefViewOfInstance (modifiers : Modifiers) (stx : Syntax) : CommandElabM DefView := do
  -- leading_parser Term.attrKind >> "instance " >> optNamedPrio >> optional declId >> declSig >> declVal
  let attrKind        ← liftMacroM <| toAttributeKind stx[0]
  let prio            ← liftMacroM <| expandOptNamedPrio stx[2]
  let attrStx         ← `(attr| instance $(quote prio):numLit)
  let (binders, type) := expandDeclSig stx[4]
  let modifiers       := modifiers.addAttribute { kind := attrKind, name := `instance, stx := attrStx }
  let declId ← match stx[3].getOptional? with
    | some declId => pure declId
    | none        =>
      let id ← MkInstanceName.main type
      pure <| Syntax.node ``Parser.Command.declId #[mkIdentFrom stx id, mkNullNode]
  return {
    ref := stx, kind := DefKind.def, modifiers := modifiers,
    declId := declId, binders := binders, type? := type, value := stx[5]
  }

def mkDefViewOfExample (modifiers : Modifiers) (stx : Syntax) : DefView :=
  -- leading_parser "example " >> declSig >> declVal
  let (binders, type) := expandDeclSig (stx.getArg 1)
  let id              := mkIdentFrom stx `_example
  let declId          := Syntax.node ``Parser.Command.declId #[id, mkNullNode]
  { ref := stx, kind := DefKind.example, modifiers := modifiers,
    declId := declId, binders := binders, type? := some type, value := stx.getArg 2 }

def isDefLike (stx : Syntax) : Bool :=
  let declKind := stx.getKind
  declKind == ``Parser.Command.«abbrev» ||
  declKind == ``Parser.Command.«def» ||
  declKind == ``Parser.Command.«theorem» ||
  declKind == ``Parser.Command.«constant» ||
  declKind == ``Parser.Command.«instance» ||
  declKind == ``Parser.Command.«example»

def mkDefView (modifiers : Modifiers) (stx : Syntax) : CommandElabM DefView :=
  let declKind := stx.getKind
  if declKind == ``Parser.Command.«abbrev» then
    pure $ mkDefViewOfAbbrev modifiers stx
  else if declKind == ``Parser.Command.«def» then
    pure $ mkDefViewOfDef modifiers stx
  else if declKind == ``Parser.Command.«theorem» then
    pure $ mkDefViewOfTheorem modifiers stx
  else if declKind == ``Parser.Command.«constant» then
    mkDefViewOfConstant modifiers stx
  else if declKind == ``Parser.Command.«instance» then
    mkDefViewOfInstance modifiers stx
  else if declKind == ``Parser.Command.«example» then
    pure $ mkDefViewOfExample modifiers stx
  else
    throwError "unexpected kind of definition"

builtin_initialize registerTraceClass `Elab.definition

end Command
end Lean.Elab


example : True := by
  fail_if_success (have : False := by assumption)
  trivial

example : True := by
  have : False := by
    fail_if_success assumption
    sorry
  trivial


import Lean
import Mathlib

import Qpf.Macro.Data.Replace
import Qpf.Macro.Data.Count
import Qpf.Macro.Data.View
import Qpf.Macro.Common
import Qpf.Macro.Comp

open Lean Meta Elab.Command
open Elab (Modifiers elabModifiers)
open Parser.Term (namedArgument)
open PrettyPrinter (delab)
open Macro (elabCommand')

private def Array.enum (as : Array α) : Array (Nat × α) :=
  (Array.range as.size).zip as

/--
  Given a natural number `n`, produce a sequence of `n` calls of `.fs`, ending in `.fz`.

  The result corresponds to a `i : PFin2 _` such that `i.toNat == n`
-/
private def PFin2.quoteOfNat : Nat → Term
  | 0   => mkIdent ``PFin2.fz
  | n+1 => Syntax.mkApp (mkIdent ``PFin2.fs) #[(quoteOfNat n)]

private def Fin2.quoteOfNat : Nat → Term
  | 0   => mkIdent ``Fin2.fz
  | n+1 => Syntax.mkApp (mkIdent ``Fin2.fs) #[(quoteOfNat n)]

namespace Data.Command

/-!
  ## Parser
  for `data` and `codata` declarations
-/
section
  open Lean.Parser Lean.Parser.Command

  def inductive_like (cmd : String) : Parser
    := leading_parser cmd >> declId  >> optDeclSig
                        >> Parser.optional  (symbol " :=" <|> " where")
                        >> many ctor
                        >> optDeriving

  def data := inductive_like "data "
  def codata := inductive_like "codata "

  @[command_parser]
  def declaration : Parser
    := leading_parser declModifiers false >> (data <|> codata)
end

/-!
  ## Elaboration
-/
open Elab.Term (TermElabM)

def Name.replacePrefix (old_pref new_pref : Name) : Name → Name
  | Name.anonymous => Name.anonymous
  | Name.str p s   => let p' := if p == old_pref then new_pref
                                else replacePrefix old_pref new_pref p
                      Name.mkStr p' s
  | Name.num p v   => let p' := if p == old_pref then new_pref
                                else replacePrefix old_pref new_pref p
                      Name.mkNum p' v

def CtorView.declReplacePrefix (pref new_pref : Name) (ctor: CtorView) : CtorView :=
  let declName := Name.replacePrefix pref new_pref ctor.declName
  {
    declName,
    ref := ctor.ref
    modifiers := ctor.modifiers
    binders := ctor.binders
    type? := ctor.type?
  }

open Parser in
/--
  Defines the "head" type of a polynomial functor

  That is, it defines a type with exactly as many constructor as the input type, but such that
  all constructors are constants (take no arguments).
-/
def mkHeadT (view : InductiveView) : CommandElabM Name := do
  -- If the original declId was `MyType`, we want to register the head type under `MyType.HeadT`
  let suffix := "HeadT"
  let declName := Name.mkStr view.declName suffix
  let declId := mkNode ``Command.declId #[mkIdent declName, mkNullNode]
  let shortDeclName := Name.mkSimple suffix

  let modifiers : Modifiers := {
    isUnsafe := view.modifiers.isUnsafe
  }
  -- The head type is the same as the original type, but with all constructor arguments removed
  let ctors ← view.ctors.mapM fun ctor => do
    let declName := Name.replacePrefix view.declName declName ctor.declName
    pure {
      modifiers, declName,
      ref := ctor.ref
      binders := mkNullNode
      type? := none
      : CtorView
    }

  -- let type ← `(Type $(mkIdent `u))

  -- TODO: make `HeadT` universe polymorphic
  let view := {
    ctors, declId, declName, shortDeclName, modifiers,
    binders         := view.binders.setArgs #[]
    levelNames      := view.levelNames

    ref             := view.ref
    type?           := view.type?

    derivingClasses := view.derivingClasses
    computedFields  := #[]
    : InductiveView
  }

  trace[QPF] "mkHeadT :: elabInductiveViews"
  elabInductiveViews #[view]
  pure declName

open Parser in
private def matchAltsOfArray (matchAlts : Array Syntax) : Syntax :=
  mkNode ``Term.matchAlts #[mkNullNode matchAlts]

open Parser in
/--
  Wraps an array of `matchAltExpr` syntax objects into a single `Command.declValEqns` node, for
  use in inductive definitions
-/
private def declValEqnsOfMatchAltArray (matchAlts : Array Syntax) : TSyntax ``Command.declValEqns :=
  let body := matchAltsOfArray matchAlts
  let body := mkNode ``Term.matchAltsWhereDecls #[body, mkNullNode]
  mkNode ``Command.declValEqns #[body]

open Parser Parser.Term Parser.Command in
/--
  Defines the "child" family of type vectors for an `n`-ary polynomial functor

  That is, it defines a type `ChildT : HeadT → TypeVec n` such that number of inhabitants of
  `ChildT a i` corresponds to the times that constructor `a` takes an argument of the `i`-th type
  argument
-/
def mkChildT (view : InductiveView) (r : Replace) (headTName : Name) : CommandElabM Name := do
  -- If the original declId was `MyType`, we want to register the child type under `MyType.ChildT`
  let suffix := "ChildT"
  let declName := Name.mkStr view.declName suffix
  let declId := mkNode ``Command.declId #[mkIdent declName, mkNullNode]

  let target_type := Syntax.mkApp (mkIdent ``TypeVec) #[quote r.arity]

  let matchAlts ← view.ctors.mapM fun ctor => do
    let head := mkIdent $ Name.replacePrefix view.declName headTName ctor.declName

    let counts := countVarOccurences r ctor.type?
    let counts := counts.map fun n =>
                    Syntax.mkApp (mkIdent ``PFin2) #[quote n]

    `(matchAltExpr| | $head => (!![ $counts,* ]))

  let body := declValEqnsOfMatchAltArray matchAlts
  let headT := mkIdent headTName

  let cmd ← `(
    def $declId : $headT → $target_type
      $body:declValEqns
  )

  -- trace[QPF] "mkChildT :: elabCommand'"
  elabCommand' cmd

  pure declName

open Parser.Term in
/--
  Show that the `Shape` type is a qpf, through an isomorphism with the `Shape.P` pfunctor
-/
def mkQpf (shapeView : InductiveView) (ctorArgs : Array CtorArgs) (headT P : Ident) (arity : Nat) : CommandElabM Unit := do
  let shapeN := shapeView.declName
  let q := mkIdent $ Name.mkStr shapeN "qpf"
  let shape := mkIdent shapeN

  let ctors := shapeView.ctors.zip ctorArgs

  /-
    `box` maps objects from the curried form, to the internal uncurried form.
    See below, or [.ofPolynomial] for the signature

    Example, using a simple list type
    ```lean4
     fun x => match x with
    | MyList.Shape.nil a b => ⟨MyList.Shape.HeadT.nil, fun i => match i with
        | 0 => Fin2.elim0 (C:=fun _ => _)
        | 1 => fun j => match j with
                | (.ofNat' 0) => b
        | 2 => fun j => match j with
                | (.ofNat' 0) => a
    ⟩
    | MyList.Shape.cons a as => ⟨MyList.Shape.HeadT.cons, fun i j => match i with
        | 0 => match j with
                | .fz => as
        | 1 => Fin2.elim0 (C:=fun _ => _) j
        | 2 => match j with
                | .fz => a
    ```
  -/

  let boxBody ← ctors.mapM fun (ctor, args) => do
    let argsId  := args.args.map mkIdent
    let alt     := mkIdent ctor.declName
    let headAlt := mkIdent $ Name.replacePrefix shapeView.declName headT.getId ctor.declName

    `(matchAltExpr| | $alt:ident $argsId:ident* => ⟨$headAlt:ident, fun i => match i with
        $(
          ←args.per_type.enum.mapM fun (i, args) => do
            let i := arity - 1 - i
            let body ← if args.size == 0 then
                          -- `(fun j => Fin2.elim0 (C:=fun _ => _) j)
                          `(PFin2.elim0)
                        else
                          let alts ← args.enum.mapM fun (j, arg) =>
                              let arg := mkIdent arg
                              `(matchAltExpr| | $(PFin2.quoteOfNat j) => $arg)
                          `(
                            fun j => match j with
                              $alts:matchAlt*
                          )
            `(matchAltExpr| | $(Fin2.quoteOfNat i) => $body)
        ):matchAlt*
    ⟩)
  let box ← `(
    fun x => match x with
      $boxBody:matchAlt*
  )

  /-
    `unbox` does the opposite of `box`; it maps from uncurried to curried

    fun ⟨head, child⟩ => match head with
    | MyList.Shape.HeadT.nil  => MyList.Shape.nil (child 2 .fz) (child 1 .fz)
    | MyList.Shape.HeadT.cons => MyList.Shape.cons (child 2 .fz) (child 0 .fz)
  -/

  /- the `child` variable in the example above -/
  let unbox_child := mkIdent <|<- Elab.Term.mkFreshBinderName;
  let unboxBody ← ctors.mapM fun (ctor, args) => do
    let alt     := mkIdent ctor.declName
    let headAlt := mkIdent $ Name.replacePrefix shapeView.declName headT.getId ctor.declName

    let args : Array Term ← args.args.mapM fun arg => do
      -- find the pair `(i, j)` such that the argument is the `j`-th occurence of the `i`-th type
      let (i, j) := (args.per_type.enum.map fun (i, t) =>
        -- the order of types is reversed, since `TypeVec`s count right-to-left
        let i := arity - 1 - i
        ((t.indexOf? arg).map fun ⟨j, _⟩ => (i, j)).toList
      ).toList.join.get! 0

      `($unbox_child $(Fin2.quoteOfNat i) $(PFin2.quoteOfNat j))

    let body := Syntax.mkApp alt args

    `(matchAltExpr| | $headAlt:ident => $body)

  let unbox ← `(
    fun ⟨head, $unbox_child⟩ => match head with
        $unboxBody:matchAlt*
  )

  let cmd ← `(
    instance $q:ident : MvQPF.IsPolynomial (@TypeFun.ofCurried $(quote arity) $shape) :=
      .ofEquiv $P {
        toFun     := $box,
        invFun    := $unbox,
        left_inv  := by
          simp only [Function.LeftInverse]
          intro x
          cases x
          <;> rfl
        right_inv := by
          simp only [Function.RightInverse, Function.LeftInverse]
          intro x
          rcases x with ⟨head, child⟩;
          cases head
          <;> simp
          <;> apply congrArg
          <;> fin_destr
          <;> rfl
      }
  )
  trace[QPF] "qpf: {cmd}\n"
  elabCommand' cmd

  pure ()

structure MkShapeResult where
  (r : Replace)
  (shape : Name)
  (P : Name)

open Parser in
def mkShape (view: DataView) : CommandElabM MkShapeResult := do
  -- If the original declId was `MyType`, we want to register the shape type under `MyType.Shape`
  let suffix := "Shape"
  let declName := Name.mkStr view.declName suffix
  let declId := mkNode ``Command.declId #[mkIdent declName, mkNullNode]
  let shortDeclName := Name.mkSimple suffix

  -- Extract the "shape" functors constructors
  let shapeIdent  := mkIdent shortDeclName
  let ((ctors, ctorArgs), r) ← Replace.shapeOfCtors view shapeIdent
  let ctors := ctors.map (CtorView.declReplacePrefix view.declName declName)

  trace[QPF] "mkShape :: r.getBinders = {←r.getBinders}"
  trace[QPF] "mkShape :: r.expr = {r.expr}"

  -- Assemble it back together, into the shape inductive type
  let binders ← r.getBinders
  let binders := view.binders.setArgs #[binders]
  let modifiers : Modifiers := {
    isUnsafe := view.modifiers.isUnsafe
  }
  let view := {
    ctors, declId, declName, shortDeclName, modifiers, binders,
    levelNames      := []

    ref             := view.ref
    type?           := view.type?

    derivingClasses := view.derivingClasses
    computedFields  := #[]
    : InductiveView
  }

  trace[QPF] "mkShape :: elabInductiveViews :: binders = {view.binders}"
  elabInductiveViews #[view]

  let headTName ← mkHeadT view
  let childTName ← mkChildT view r headTName

  let PName := Name.mkStr declName "P"
  let PId := mkIdent PName
  -- let u ← Elab.Term.mkFreshBinderName
  let PDeclId := mkNode ``Command.declId #[PId, mkNullNode
    -- #[ TODO: make this universe polymorphic
    --   mkAtom ".{",
    --   mkNullNode #[u],
    --   mkAtom "}"
    -- ]
  ]

  let headTId := mkIdent headTName
  let childTId := mkIdent childTName

  elabCommand' <|<- `(
    def $PDeclId :=
      MvPFunctor.mk $headTId $childTId
  )

  mkQpf view ctorArgs headTId PId r.expr.size

  pure ⟨r, declName, PName⟩

open Elab.Term in
/--
  Checks whether the given term is a polynomial functor, i.e., whether there is an instance of
  `IsPolynomial F`, and return that instance (if it exists).
-/
def isPolynomial (F: Term) : CommandElabM (Option Term) := do
  liftTermElabM do
    trace[QPF] "isPolynomial::F = {F}"
    let inst_type ← elabTerm (← `(MvQPF.IsPolynomial $F:term)) none
    try
      let inst ← synthInstance inst_type
      return some <|<- delab inst
    catch e =>
      trace[QPF] "{e.toMessageData}"
      return none

/--
  Return a syntax tree for `MvQPF.Fix` or `MvQPF.Cofix` when self is `Data`, resp. `Codata`.
-/
def DataCommand.fixOrCofix : DataCommand → Ident
  | .Data   => mkIdent ``_root_.MvQPF.Fix
  | .Codata => mkIdent ``_root_.MvQPF.Cofix

/--
  Return a syntax tree for `MvPFunctor.W` or `MvPFunctor.M` when self is `Data`, resp. `Codata`.
-/
def DataCommand.fixOrCofixPolynomial : DataCommand → Ident
  | .Data   => mkIdent ``_root_.MvPFunctor.W
  | .Codata => mkIdent ``_root_.MvPFunctor.M

/--
  Take either the fixpoint or cofixpoint of `base` to produce an `Internal` uncurried QPF,
  and define the desired type as the curried version of `Internal`
-/
def mkType (view : DataView) (base : Term) : CommandElabM Unit := do
  let uncurriedIdent := mkIdent $ Name.mkStr view.declName "Uncurried"
  let baseIdent := mkIdent $ Name.mkStr view.declName "Base"

  let deadBinderNamedArgs ← view.deadBinderNames.mapM fun n =>
        `(namedArgument| ($n:ident := $n:term))
  let uncurriedApplied ← `($uncurriedIdent $deadBinderNamedArgs:namedArgument*)

  let arity := view.liveBinders.size

  let poly ← isPolynomial base
  trace[QPF] "poly: {poly}"

  let cmd ← match poly with
    | some poly =>
        let fix_or_cofix := DataCommand.fixOrCofixPolynomial view.command
        `(
          abbrev $baseIdent:ident $view.deadBinders:bracketedBinder* : _root_.TypeFun $(quote <| arity + 1)
            := (@MvQPF.P _ _ $poly).Obj

          abbrev $uncurriedIdent:ident $view.deadBinders:bracketedBinder* : _root_.TypeFun $(quote arity)
            := ($fix_or_cofix $base).Obj
        )
    | none =>
        let fix_or_cofix := DataCommand.fixOrCofix view.command
        `(
          abbrev $baseIdent:ident $view.deadBinders:bracketedBinder* : _root_.TypeFun $(quote <| arity + 1)
            := $base

          abbrev $uncurriedIdent:ident $view.deadBinders:bracketedBinder* : _root_.TypeFun $(quote arity)
            := $fix_or_cofix $base
        )

  trace[QPF] "elabData.cmd = {cmd}"
  elabCommand' cmd

  elabCommand' <|<- `(
    abbrev $(view.declId)   $view.deadBinders:bracketedBinder*
      := _root_.TypeFun.curried $uncurriedApplied
  )

open Parser in
/--
  Count the number of arguments to a constructor
-/
partial def countConstructorArgs : Syntax → Nat
  | Syntax.node _ ``Term.arrow #[_, _, tail]  =>  1 + (countConstructorArgs tail)
  | _                                         => 0

open Elab
/--
  Add convenient constructor functions to the environment
-/
def mkConstructors (view : DataView) (shape : Name) : CommandElabM Unit := do
  for ctor in view.ctors do
    trace[QPF] "mkConstructors\n{ctor.declName} : {ctor.type?}"
    let n_args := (ctor.type?.map countConstructorArgs).getD 0

    let args ← (List.range n_args).mapM fun _ =>
      do pure <| mkIdent <|← Elab.Term.mkFreshBinderName
    let args := args.toArray

    let mk := mkIdent ((DataCommand.fixOrCofix view.command).getId ++ `mk)
    let shapeCtor := mkIdent <| Name.replacePrefix view.declName shape ctor.declName
    trace[QPF] "shapeCtor = {shapeCtor}"

    let body := if n_args = 0 then
        `($mk $shapeCtor)
      else
        `(fun $args:ident* => $mk ($shapeCtor $args:ident*))
    let body ← body

    let explicit ← view.getExplicitExpectedType
    let type : Term := TSyntax.mk <|
      (ctor.type?.map fun type =>
        Replace.replaceAllStx view.getExpectedType explicit type
      ).getD explicit
    let modifiers : Modifiers := {
      isNoncomputable := view.modifiers.isNoncomputable
      attrs := #[{
        name := `matchPattern
      }]
    }
    let cmd ← `(
      $(quote modifiers):declModifiers
      def $(mkIdent ctor.declName) : $type
        := $body:term
    )

    trace[QPF] "mkConstructor.cmd = {cmd}"
    elabCommand' cmd
  return ()

open Macro Comp in
/--
  Top-level elaboration for both `data` and `codata` declarations
-/
@[command_elab declaration]
def elabData : CommandElab := fun stx => do
  let modifiers ← elabModifiers stx[0]
  let decl := stx[1]
  let view ← dataSyntaxToView modifiers decl

  let (nonRecView, _rho) ← makeNonRecursive view;
  trace[QPF] "nonRecView: {nonRecView}"

  let ⟨r, shape, _P⟩ ← mkShape nonRecView

  /- Composition pipeline -/
  let base ← elabQpfCompositionBody {
    liveBinders := nonRecView.liveBinders,
    deadBinders := nonRecView.deadBinders,
    type?   := none,
    target  := ←`(
      $(mkIdent shape):ident $r.expr*
    )
  }
  trace[QPF] m!"base = {base}"

  mkType view base
  -- mkConstructors view shape

end Data.Command

namespace Test
  set_option trace.Meta true
  set_option trace.Meta.debug true
  sudo set_option trace.QPF true
  sudo set_option trace.QPF.Comp true
  set_option pp.raw true

  data Wrap α
    | mk : α → Wrap α

  #print Wrap.Shape
  #check (Wrap.Shape : CurriedTypeFun 1)

  #print Test.Wrap.Uncurried
  #print Test.Wrap.Base

end Test


/-
Copyright (c) E.W.Ayers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Author: E.W.Ayers
-/
prelude
import init.meta.tactic
import init.meta.expr_address
import init.control

universe u

/-- An alternative to format that keeps structural information stored as a tag. -/
meta inductive tagged_format (α : Type u)
| tag       : α → tagged_format → tagged_format
| compose   : tagged_format → tagged_format → tagged_format
| group     : tagged_format → tagged_format
| nest      : nat → tagged_format → tagged_format
| highlight : format.color → tagged_format → tagged_format
| of_format : format → tagged_format

namespace tagged_format

variables {α β : Type u}

protected meta def map (f : α → β) : tagged_format α → tagged_format β
| (compose x y)   := compose (map x) (map y)
| (group x)       := group $ map x
| (nest i x)      := nest i $ map x
| (highlight c x) := highlight c $ map x
| (of_format x)   := of_format x
| (tag a x)       := tag (f a) (map x)

meta instance is_functor: functor tagged_format :=
{ map := @tagged_format.map }

meta def m_untag {t : Type → Type} [monad t] (f : α → format → t format) : tagged_format α → t format
| (compose x y)   := pure format.compose <*> m_untag x <*> m_untag y
| (group x)       := pure format.group <*> m_untag x
| (nest i x)      := pure (format.nest i) <*> m_untag x
| (highlight c x) := pure format.highlight <*> m_untag x <*> pure c
| (of_format x)   := pure $ x
| (tag a x)       := m_untag x >>= f a

meta def untag (f : α → format → format) : tagged_format α → format :=
@m_untag _ id _ f

meta instance has_to_fmt : has_to_format (tagged_format α) :=
⟨tagged_format.untag (λ a f, f)⟩

end tagged_format

/-- tagged_format with information about subexpressions. -/
meta def eformat := tagged_format (expr.address × expr)

/-- A special version of pp which also preserves expression boundary information.

On a tag ⟨e,a⟩, note that the given expr `e` is _not_ necessarily the subexpression of the root
expression that `tactic_state.pp_tagged` was called with. For example if the subexpression is
under a binder then all of the `expr.var 0`s will be replaced with a local constant not in
the local context with the name and type set to that of the binder.-/
meta constant tactic_state.pp_tagged : tactic_state → expr → eformat

meta def tactic.pp_tagged : expr → tactic eformat
| e := tactic.read >>= λ ts, pure $ tactic_state.pp_tagged ts e


import Lean

open Lean Server Lsp

@[codeActionProvider]
def helloProvider : CodeActionProvider := fun params _snap => do
  let td := params.textDocument
  let edit : TextEdit := {
      range := params.range,
      newText := "hello!!!"
    }
  let ca : CodeAction := {
    title := "hello world",
    kind? := "quickfix",
    edit? := WorkspaceEdit.ofTextEdit td.uri edit
  }
  let longRunner : CodeAction := {
    title := "a long-running action",
    kind? := "refactor",
  }
  let lazyResult : IO CodeAction := do
    let v? ← IO.getEnv "PWD"
    let v := v?.getD "none"
    return { longRunner with
      edit? := WorkspaceEdit.ofTextEdit td.uri { range := params.range, newText := v}
    }
  return #[ca, {eager := longRunner, lazy? := lazyResult}]

theorem asdf : (x : Nat) → x = x := by
  intro x
  --^ codeAction
  rfl


/-
Copyright (c) 2016 Gabriel Ebner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Sebastian Ullrich

Classy functions for lifting monadic actions of different shapes.

This theory is roughly modeled after the Haskell 'layers' package https://hackage.haskell.org/package/layers-0.1.
Please see https://hackage.haskell.org/package/layers-0.1/docs/Documentation-Layers-Overview.html for an exhaustive discussion of the different approaches to lift functions.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.function
import Mathlib.Lean3Lib.init.coe
import Mathlib.Lean3Lib.init.control.monad

universes u v w l u_1 u_2 u_3 u_4

namespace Mathlib

/-- A function for lifting a computation from an inner monad to an outer monad.
    Like [MonadTrans](https://hackage.haskell.org/package/transformers-0.5.5.0/docs/Control-Monad-Trans-Class.html),
    but `n` does not have to be a monad transformer.
    Alternatively, an implementation of [MonadLayer](https://hackage.haskell.org/package/layers-0.1/docs/Control-Monad-Layer.html#t:MonadLayer) without `layerInvmap` (so far). -/
class has_monad_lift (m : Type u → Type v) (n : Type u → Type w)
where
  monad_lift : {α : Type u} → m α → n α

/-- The reflexive-transitive closure of `has_monad_lift`.
    `monad_lift` is used to transitively lift monadic computations such as `state_t.get` or `state_t.put s`.
    Corresponds to [MonadLift](https://hackage.haskell.org/package/layers-0.1/docs/Control-Monad-Layer.html#t:MonadLift). -/
class has_monad_lift_t (m : Type u → Type v) (n : Type u → Type w)
where
  monad_lift : {α : Type u} → m α → n α

/-- A coercion that may reduce the need for explicit lifting.
    Because of [limitations of the current coercion resolution](https://github.com/leanprover/lean/issues/1402), this definition is not marked as a global instance and should be marked locally instead. -/
def has_monad_lift_to_has_coe {m : Type u_1 → Type u_2} {n : Type u_1 → Type u_3} [has_monad_lift_t m n] {α : Type u_1} : has_coe (m α) (n α) :=
  has_coe.mk monad_lift

protected instance has_monad_lift_t_trans (m : Type u_1 → Type u_2) (n : Type u_1 → Type u_3) (o : Type u_1 → Type u_4) [has_monad_lift_t m n] [has_monad_lift n o] : has_monad_lift_t m o :=
  has_monad_lift_t.mk fun (α : Type u_1) (ma : m α) => has_monad_lift.monad_lift (monad_lift ma)

protected instance has_monad_lift_t_refl (m : Type u_1 → Type u_2) : has_monad_lift_t m m :=
  has_monad_lift_t.mk fun (α : Type u_1) => id

@[simp] theorem monad_lift_refl {m : Type u → Type v} {α : Type u} : monad_lift = id :=
  rfl

/-- A functor in the category of monads. Can be used to lift monad-transforming functions.
    Based on pipes' [MFunctor](https://hackage.haskell.org/package/pipes-2.4.0/docs/Control-MFunctor.html),
    but not restricted to monad transformers.
    Alternatively, an implementation of [MonadTransFunctor](http://duairc.netsoc.ie/layers-docs/Control-Monad-Layer.html#t:MonadTransFunctor). -/
class monad_functor (m : Type u → Type v) (m' : Type u → Type v) (n : Type u → Type w) (n' : Type u → Type w)
where
  monad_map : {α : Type u} → ({α : Type u} → m α → m' α) → n α → n' α

/-- The reflexive-transitive closure of `monad_functor`.
    `monad_map` is used to transitively lift monad morphisms such as `state_t.zoom`.
    A generalization of [MonadLiftFunctor](http://duairc.netsoc.ie/layers-docs/Control-Monad-Layer.html#t:MonadLiftFunctor), which can only lift endomorphisms (i.e. m = m', n = n'). -/
class monad_functor_t (m : Type u → Type v) (m' : Type u → Type v) (n : Type u → Type w) (n' : Type u → Type w)
where
  monad_map : {α : Type u} → ({α : Type u} → m α → m' α) → n α → n' α

protected instance monad_functor_t_trans (m : Type u_1 → Type u_2) (m' : Type u_1 → Type u_2) (n : Type u_1 → Type u_3) (n' : Type u_1 → Type u_3) (o : Type u_1 → Type u_4) (o' : Type u_1 → Type u_4) [monad_functor_t m m' n n'] [monad_functor n n' o o'] : monad_functor_t m m' o o' :=
  monad_functor_t.mk
    fun (α : Type u_1) (f : {α : Type u_1} → m α → m' α) => monad_functor.monad_map fun (α : Type u_1) => monad_map f

protected instance monad_functor_t_refl (m : Type u_1 → Type u_2) (m' : Type u_1 → Type u_2) : monad_functor_t m m' m m' :=
  monad_functor_t.mk fun (α : Type u_1) (f : {α : Type u_1} → m α → m' α) => f

@[simp] theorem monad_map_refl {m : Type u → Type v} {m' : Type u → Type v} (f : {α : Type u} → m α → m' α) {α : Type u} : monad_map f = f :=
  rfl

/-- Run a monad stack to completion.
    `run` should be the composition of the transformers' individual `run` functions.
    This class mostly saves some typing when using highly nested monad stacks:
    ```
    @[reducible] def my_monad := reader_t my_cfg $ state_t my_state $ except_t my_err id
    -- def my_monad.run {α : Type} (x : my_monad α) (cfg : my_cfg) (st : my_state) := ((x.run cfg).run st).run
    def my_monad.run {α : Type} (x : my_monad α) := monad_run.run x
    ```
    -/
class monad_run (out : outParam (Type u → Type v)) (m : Type u → Type v)
where
  run : {α : Type u} → m α → out α


import Lean.Data.Json
import Std.Data.Option.Basic
import Init.System.FilePath
import Mathlib.Data.Option.Basic

open Lean System

namespace V2ray

class FromJsonURI (α : Type u) where
  fromJsonURI? : String → Json → Except String α

export FromJsonURI (fromJsonURI?)

instance : ToJson UInt8 where
  toJson := toJson ∘ UInt8.toNat

instance : ToJson UInt16 where
  toJson := toJson ∘ UInt16.toNat

instance : ToJson UInt32 where
  toJson := toJson ∘ UInt32.toNat

instance : ToJson UInt64 where
  toJson := toJson ∘ UInt64.toNat

instance : FromJson UInt8 where
  fromJson? n := do
    let m ← fromJson? n
    if m >= UInt8.size
      then throw s!"{n} is too large for UInt8"
      else pure m.toUInt8

instance : FromJson UInt16 where
  fromJson? n := do
    let m ← fromJson? n
    if m >= UInt16.size
      then throw s!"{n} is too large for UInt16"
      else pure m.toUInt16

instance : FromJson UInt32 where
  fromJson? n := do
    let m ← fromJson? n
    if m >= UInt32.size
      then throw s!"{n} is too large for UInt32"
      else pure m.toUInt32

instance : FromJson UInt64 where
  fromJson? n := do
    let m ← fromJson? n
    if m >= UInt64.size
      then throw s!"{n} is too large for UInt64"
      else pure m.toUInt64

def StringNat := Nat

instance : FromJson StringNat where
  fromJson? o := try fromJson? (α := Nat) o
    catch _ => do
      let s ← fromJson? (α := String) o
      s.toNat?.elim (throw s!"Can't parse {s} as a number.") pure

end V2ray

namespace Except

instance [BEq a] [BEq b] : BEq (Except a b) where
  beq
    | ok a, ok b => a == b
    | error a, error b => a == b
    | _, _ => false

end Except

unsafe def IO.lazy' (m : IO a) : IO (Thunk a) := pure $ Thunk.mk fun _ =>
  match unsafeIO m with
    | Except.ok x => x
    | Except.error e => unsafeCast (panic $ "Uncaught exception: " ++ e.toString : Nat)

@[implemented_by IO.lazy']
def IO.lazy (m : IO a) : IO (Thunk a) := m.map (Thunk.mk ∘ (fun _ => ·))

def compareFilePath (p q : FilePath) : Ordering :=
  compare p.normalize.toString q.normalize.toString

unsafe def fileReadRecord : IO.Ref (RBMap FilePath String compareFilePath) :=
  unsafeBaseIO (IO.mkRef RBMap.empty)

namespace IO.FS

unsafe def trackRead' (p : FilePath) : IO String := do
  match (← fileReadRecord.get).find? p with
    | some s => pure s
    | none   => do
        let s ← readFile p
        fileReadRecord.modify (fun m => m.insert p s)
        pure s

@[implemented_by trackRead']
def trackRead (p : FilePath) : IO String := readFile p

def createAndWrite (path : FilePath) (s : String) : IO Unit := do
  if let some p := path.parent
    then createDirAll p
  writeFile path s

unsafe def writeBack' (p : FilePath) (t : Thunk (Option String)) : IO Unit := do
  if (← fileReadRecord.get).contains p then
    if let some s := t.get then
      createAndWrite p s
      fileReadRecord.modify (fun m => m.insert p s)

@[implemented_by writeBack']
def writeBack (p : FilePath) (t : Thunk (Option String)) : IO Unit := do
  if let some s := t.get then
      createAndWrite p s

unsafe def forceWriteBack' (p : FilePath) : IO Unit := do
  fileReadRecord.modify (fun m => m.insert p "")

@[implemented_by forceWriteBack']
def forceWriteBack (_ : FilePath) : IO Unit := pure ()

end IO.FS

theorem Array.findIdx?_res_lt_size (as : Array α) (p : α → Bool) :
    as.findIdx? p = some n → n < as.size := by
  let rec prf (i : Nat) (j : Nat) (inv : i + j = as.size) :
      Array.findIdx?.loop as p i j inv = some n → n < as.size := by
    intro h
    rw [Array.findIdx?.loop] at h
    split at h
    case inl hlt =>
      split at h
      case h_1 inv =>
        rw [Nat.zero_add] at inv
        rw [inv] at hlt
        exact absurd hlt (Nat.lt_irrefl _)
      case h_2 i inv =>
        split at h
        case inl =>
          rw [← Option.some_injective Nat h]
          exact hlt
        case inr =>
          have : i + (j + 1) = as.size := by
            rw [← inv, Nat.add_comm j 1, Nat.add_assoc]
          exact prf i (j + 1) this h
    case inr => contradiction
  rw [Array.findIdx?]
  exact prf as.size 0 rfl

def Array.findFinIdx? (as : Array α) (p : α → Bool) : Option (Fin as.size) :=
  match h : as.findIdx? p with
    | none => none
    | some i => some ⟨i, Array.findIdx?_res_lt_size as p h⟩


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.function
import Mathlib.Lean3Lib.init.data.option.basic
import Mathlib.Lean3Lib.init.util
import Mathlib.Lean3Lib.init.control.combinators
import Mathlib.Lean3Lib.init.control.monad
import Mathlib.Lean3Lib.init.control.alternative
import Mathlib.Lean3Lib.init.control.monad_fail
import Mathlib.Lean3Lib.init.data.nat.div
import Mathlib.Lean3Lib.init.meta.exceptional
import Mathlib.Lean3Lib.init.meta.format
import Mathlib.Lean3Lib.init.meta.environment
import Mathlib.Lean3Lib.init.meta.pexpr
import Mathlib.Lean3Lib.init.data.repr
import Mathlib.Lean3Lib.init.data.string.basic
import Mathlib.Lean3Lib.init.meta.interaction_monad
import Mathlib.Lean3Lib.init.classical

universes l

namespace Mathlib

infixl:2 " >>=[tactic] " => Mathlib.interaction_monad_bind

infixl:2 " >>[tactic] " => Mathlib.interaction_monad_seq

namespace tactic_state

/-- Format the given tactic state. If `target_lhs_only` is true and the target
    is of the form `lhs ~ rhs`, where `~` is a simplification relation,
    then only the `lhs` is displayed.

    Remark: the parameter `target_lhs_only` is a temporary hack used to implement
    the `conv` monad. It will be removed in the future. -/
/-- Format expression with respect to the main goal in the tactic state.
   If the tactic state does not contain any goals, then format expression
   using an empty local context. -/
end tactic_state

/-- `tactic` is the monad for building tactics.
    You use this to:
    - View and modify the local goals and hypotheses in the prover's state.
    - Invoke type checking and elaboration of terms.
    - View and modify the environment.
    - Build new tactics out of existing ones such as `simp` and `rewrite`.
-/
namespace tactic

end tactic

namespace tactic_result

end tactic_result

namespace interactive

/-- Typeclass for custom interaction monads, which provides
    the information required to convert an interactive-mode
    construction to a `tactic` which can actually be executed.

    Given a `[monad m]`, `execute_with` explains how to turn a `begin ... end`
    block, or a `by ...` statement into a `tactic α` which can actually be
    executed. The `inhabited` first argument facilitates the passing of an
    optional configuration parameter `config`, using the syntax:
    ```
    begin [custom_monad] with config,
        ...
    end
    ```
-/
/-- Default `executor` instance for `tactic`s themselves -/
end interactive

namespace tactic

/-- Does nothing. -/
/--
`try_core t` acts like `t`, but succeeds even if `t` fails. It returns the
result of `t` if `t` succeeded and `none` otherwise.
-/
/--
`try t` acts like `t`, but succeeds even if `t` fails.
-/
/--
`fail_if_success t` acts like `t`, but succeeds if `t` fails and fails if `t`
succeeds. Changes made by `t` to the `tactic_state` are preserved only if `t`
succeeds.
-/
/--
`success_if_fail t` acts like `t`, but succeeds if `t` fails and fails if `t`
succeeds. Changes made by `t` to the `tactic_state` are preserved only if `t`
succeeds.
-/
/--
`iterate_at_most n t` iterates `t` `n` times or until `t` fails, returning the
result of each successful iteration.
-/
/--
`iterate_at_most' n t` repeats `t` `n` times or until `t` fails.
-/
/--
`iterate_exactly n t` iterates `t` `n` times, returning the result of
each iteration. If any iteration fails, the whole tactic fails.
-/
/--
`iterate_exactly' n t` executes `t` `n` times. If any iteration fails, the whole
tactic fails.
-/
/--
`iterate t` repeats `t` 100.000 times or until `t` fails, returning the
result of each iteration.
-/
/--
`iterate' t` repeats `t` 100.000 times or until `t` fails.
-/
/-- Decorate t's exceptions with msg. -/
/-- Set the tactic_state. -/
/-- Get the tactic_state. -/
/--
`capture t` acts like `t`, but succeeds with a result containing either the returned value
or the exception.
Changes made by `t` to the `tactic_state` are preserved in both cases.

The result can be used to inspect the error message, or passed to `unwrap` to rethrow the
failure later.
-/
/--
`unwrap r` unwraps a result previously obtained using `capture`.

If the previous result was a success, this produces its wrapped value.
If the previous result was an exception, this "rethrows" the exception as if it came
from where it originated.

`do r ← capture t, unwrap r` is identical to `t`, but allows for intermediate tactics to be inserted.
-/
/--
`resume r` continues execution from a result previously obtained using `capture`.

This is like `unwrap`, but the `tactic_state` is rolled back to point of capture even upon success.
-/
end tactic

namespace tactic

/-- A parameter representing how aggressively definitions should be unfolded when trying to decide if two terms match, unify or are definitionally equal.
By default, theorem declarations are never unfolded.
- `all` will unfold everything, including macros and theorems. Except projection macros.
- `semireducible` will unfold everything except theorems and definitions tagged as irreducible.
- `instances` will unfold all class instance definitions and definitions tagged with reducible.
- `reducible` will only unfold definitions tagged with the `reducible` attribute.
- `none` will never unfold anything.
[NOTE] You are not allowed to tag a definition with more than one of `reducible`, `irreducible`, `semireducible` attributes.
[NOTE] there is a config flag `m_unfold_lemmas`that will make it unfold theorems.
 -/
inductive transparency where
| all : transparency
| semireducible : transparency
| instances : transparency
| reducible : transparency
| none : transparency

/-- (eval_expr α e) evaluates 'e' IF 'e' has type 'α'. -/
/-- Return the partial term/proof constructed so far. Note that the resultant expression
   may contain variables that are not declarate in the current main goal. -/
/-- Display the partial term/proof constructed so far. This tactic is *not* equivalent to
   `do { r ← result, s ← read, return (format_expr s r) }` because this one will format the result with respect
   to the current goal, and trace_result will do it with respect to the initial goal. -/
/-- Return target type of the main goal. Fail if tactic_state does not have any goal left. -/
/-- Clear the given local constant. The tactic fails if the given expression is not a local constant. -/
/-- `revert_lst : list expr → tactic nat` is the reverse of `intron`. It takes a local constant `c` and puts it back as bound by a `pi` or `elet` of the main target.
If there are other local constants that depend on `c`, these are also reverted. Because of this, the `nat` that is returned is the actual number of reverted local constants.
Example: with `x : ℕ, h : P(x) ⊢ T(x)`, `revert_lst [x]` returns `2` and produces the state ` ⊢ Π x, P(x) → T(x)`.
 -/
/-- Return `e` in weak head normal form with respect to the given transparency setting.
    If `unfold_ginductive` is `tt`, then nested and/or mutually recursive inductive datatype constructors
    and types are unfolded. Recall that nested and mutually recursive inductive datatype declarations
    are compiled into primitive datatypes accepted by the Kernel. -/
/-- (head) eta expand the given expression. `f : α → β` head-eta-expands to `λ a, f a`. If `f` isn't a function then it just returns `f`.  -/
/-- (head) beta reduction. `(λ x, B) c` reduces to `B[x/c]`. -/
/-- (head) zeta reduction. Reduction of let bindings at the head of the expression. `let x : a := b in c` reduces to `c[x/b]`. -/
/-- Zeta reduction. Reduction of let bindings. `let x : a := b in c` reduces to `c[x/b]`. -/
/-- (head) eta reduction. `(λ x, f x)` reduces to `f`. -/
/-- Succeeds if `t` and `s` can be unified using the given transparency setting. -/
/-- Similar to `unify`, but it treats metavariables as constants. -/
/-- Infer the type of the given expression.
   Remark: transparency does not affect type inference -/
/-- Get the `local_const` expr for the given `name`. -/
/-- Resolve a name using the current local context, environment, aliases, etc. -/
/-- Return the hypothesis in the main goal. Fail if tactic_state does not have any goal left. -/
/-- Get a fresh name that is guaranteed to not be in use in the local context.
    If `n` is provided and `n` is not in use, then `n` is returned.
    Otherwise a number `i` is appended to give `"n_i"`.
-/
/--  Helper tactic for creating simple applications where some arguments are inferred using
    type inference.

    Example, given
    ```
        rel.{l_1 l_2} : Pi (α : Type.{l_1}) (β : α -> Type.{l_2}), (Pi x : α, β x) -> (Pi x : α, β x) -> , Prop
        nat     : Type
        real    : Type
        vec.{l} : Pi (α : Type l) (n : nat), Type.{l1}
        f g     : Pi (n : nat), vec real n
    ```
    then
    ```
    mk_app_core semireducible "rel" [f, g]
    ```
    returns the application
    ```
    rel.{1 2} nat (fun n : nat, vec real n) f g
    ```

    The unification constraints due to type inference are solved using the transparency `md`.
-/
/-- Similar to `mk_app`, but allows to specify which arguments are explicit/implicit.
   Example, given `(a b : nat)` then
   ```
   mk_mapp "ite" [some (a > b), none, none, some a, some b]
   ```
   returns the application
   ```
   @ite.{1} (a > b) (nat.decidable_gt a b) nat a b
   ```
-/
/-- (mk_congr_arg h₁ h₂) is a more efficient version of (mk_app `congr_arg [h₁, h₂]) -/
/-- (mk_congr_fun h₁ h₂) is a more efficient version of (mk_app `congr_fun [h₁, h₂]) -/
/-- (mk_congr h₁ h₂) is a more efficient version of (mk_app `congr [h₁, h₂]) -/
/-- (mk_eq_refl h) is a more efficient version of (mk_app `eq.refl [h]) -/
/-- (mk_eq_symm h) is a more efficient version of (mk_app `eq.symm [h]) -/
/-- (mk_eq_trans h₁ h₂) is a more efficient version of (mk_app `eq.trans [h₁, h₂]) -/
/-- (mk_eq_mp h₁ h₂) is a more efficient version of (mk_app `eq.mp [h₁, h₂]) -/
/-- (mk_eq_mpr h₁ h₂) is a more efficient version of (mk_app `eq.mpr [h₁, h₂]) -/
/- Given a local constant t, if t has type (lhs = rhs) apply substitution.
   Otherwise, try to find a local constant that has type of the form (t = t') or (t' = t).
   The tactic fails if the given expression is not a local constant. -/

/-- Close the current goal using `e`. Fail if the type of `e` is not definitionally equal to
    the target type. -/
/-- Elaborate the given quoted expression with respect to the current main goal.
    Note that this means that any implicit arguments for the given `pexpr` will be applied with fresh metavariables.
    If `allow_mvars` is tt, then metavariables are tolerated and become new goals if `subgoals` is tt. -/
/-- Return true if the given expression is a type class. -/
/-- Try to create an instance of the given type class. -/
/-- Change the target of the main goal.
   The input expression must be definitionally equal to the current target.
   If `check` is `ff`, then the tactic does not check whether `e`
   is definitionally equal to the current target. If it is not,
   then the error will only be detected by the kernel type checker. -/
/-- `assert_core H T`, adds a new goal for T, and change target to `T -> target`. -/
/-- `assertv_core H T P`, change target to (T -> target) if P has type T. -/
/-- `define_core H T`, adds a new goal for T, and change target to  `let H : T := ?M in target` in the current goal. -/
/-- `definev_core H T P`, change target to `let H : T := P in target` if P has type T. -/
/-- Rotate goals to the left. That is, `rotate_left 1` takes the main goal and puts it to the back of the subgoal list. -/
/-- Gets a list of metavariables, one for each goal. -/
/-- Replace the current list of goals with the given one. Each expr in the list should be a metavariable. Any assigned metavariables will be ignored.-/
/-- How to order the new goals made from an `apply` tactic.
Supposing we were applying `e : ∀ (a:α) (p : P(a)), Q`
- `non_dep_first` would produce goals `⊢ P(?m)`, `⊢ α`. It puts the P goal at the front because none of the arguments after `p` in `e` depend on `p`. It doesn't matter what the result `Q` depends on.
- `non_dep_only` would produce goal `⊢ P(?m)`.
- `all` would produce goals `⊢ α`, `⊢ P(?m)`.
-/
inductive new_goals where
| non_dep_first : new_goals
| non_dep_only : new_goals
| all : new_goals

/-- Configuration options for the `apply` tactic.
- `md` sets how aggressively definitions are unfolded.
- `new_goals` is the strategy for ordering new goals.
- `instances` if `tt`, then `apply` tries to synthesize unresolved `[...]` arguments using type class resolution.
- `auto_param` if `tt`, then `apply` tries to synthesize unresolved `(h : p . tac_id)` arguments using tactic `tac_id`.
- `opt_param` if `tt`, then `apply` tries to synthesize unresolved `(a : t := v)` arguments by setting them to `v`.
- `unify` if `tt`, then `apply` is free to assign existing metavariables in the goal when solving unification constraints.
   For example, in the goal `|- ?x < succ 0`, the tactic `apply succ_lt_succ` succeeds with the default configuration,
   but `apply_with succ_lt_succ {unify := ff}` doesn't since it would require Lean to assign `?x` to `succ ?y` where
   `?y` is a fresh metavariable.
-/
structure apply_cfg where
  md : transparency
  approx : Bool
  new_goals : new_goals
  instances : Bool
  auto_param : Bool
  opt_param : Bool
  unify : Bool

/-- Apply the expression `e` to the main goal, the unification is performed using the transparency mode in `cfg`.
    Supposing `e : Π (a₁:α₁) ... (aₙ:αₙ), P(a₁,...,aₙ)` and the target is `Q`, `apply` will attempt to unify `Q` with `P(?a₁,...?aₙ)`.
    All of the metavariables that are not assigned are added as new metavariables.
    If `cfg.approx` is `tt`, then fallback to first-order unification, and approximate context during unification.
    `cfg.new_goals` specifies which unassigned metavariables become new goals, and their order.
    If `cfg.instances` is `tt`, then use type class resolution to instantiate unassigned meta-variables.
    The fields `cfg.auto_param` and `cfg.opt_param` are ignored by this tactic (See `tactic.apply`).
    It returns a list of all introduced meta variables and the parameter name associated with them, even the assigned ones. -/
/- Create a fresh meta universe variable. -/

/- Create a fresh meta-variable with the given type.
   The scope of the new meta-variable is the local context of the main goal. -/

/-- Return the value assigned to the given universe meta-variable.
   Fail if argument is not an universe meta-variable or if it is not assigned. -/
/-- Return the value assigned to the given meta-variable.
   Fail if argument is not a meta-variable or if it is not assigned. -/
/-- Return true if the given meta-variable is assigned.
    Fail if argument is not a meta-variable. -/
/-- Make a name that is guaranteed to be unique. Eg `_fresh.1001.4667`. These will be different for each run of the tactic.  -/
/-- Induction on `h` using recursor `rec`, names for the new hypotheses
   are retrieved from `ns`. If `ns` does not have sufficient names, then use the internal binder names
   in the recursor.
   It returns for each new goal the name of the constructor (if `rec_name` is a builtin recursor),
   a list of new hypotheses, and a list of substitutions for hypotheses
   depending on `h`. The substitutions map internal names to their replacement terms. If the
   replacement is again a hypothesis the user name stays the same. The internal names are only valid
   in the original goal, not in the type context of the new goal.
   Remark: if `rec_name` is not a builtin recursor, we use parameter names of `rec_name` instead of
   constructor names.

   If `rec` is none, then the type of `h` is inferred, if it is of the form `C ...`, tactic uses `C.rec` -/
/-- Apply `cases_on` recursor, names for the new hypotheses are retrieved from `ns`.
   `h` must be a local constant. It returns for each new goal the name of the constructor, a list of new hypotheses, and a list of
   substitutions for hypotheses depending on `h`. The number of new goals may be smaller than the
   number of constructors. Some goals may be discarded when the indices to not match.
   See `induction` for information on the list of substitutions.

   The `cases` tactic is implemented using this one, and it relaxes the restriction of `h`.

   Note: There is one "new hypothesis" for every constructor argument. These are
   usually local constants, but due to dependent pattern matching, they can also
   be arbitrary terms. -/
/-- Similar to cases tactic, but does not revert/intro/clear hypotheses. -/
/-- Generalizes the target with respect to `e`.  -/
/-- instantiate assigned metavariables in the given expression -/
/-- Add the given declaration to the environment -/
/--
Changes the environment to the `new_env`.
The new environment does not need to be a descendant of the old one.
Use with care.
-/
/-- Changes the environment to the `new_env`. `new_env` needs to be a descendant from the current environment. -/
/-- `doc_string env d k` returns the doc string for `d` (if available) -/
/-- Set the docstring for the given declaration. -/
/--
Create an auxiliary definition with name `c` where `type` and `value` may contain local constants and
meta-variables. This function collects all dependencies (universe parameters, universe metavariables,
local constants (aka hypotheses) and metavariables).
It updates the environment in the tactic_state, and returns an expression of the form

          (c.{l_1 ... l_n} a_1 ... a_m)

where l_i's and a_j's are the collected dependencies.
-/
/-- Returns a list of all top-level (`/-! ... -/`) docstrings in the active module and imported ones.
The returned object is a list of modules, indexed by `(some filename)` for imported modules
and `none` for the active one, where each module in the list is paired with a list
of `(position_in_file, docstring)` pairs. -/
/-- Returns a list of docstrings in the active module. An entry in the list can be either:
- a top-level (`/-! ... -/`) docstring, represented as `(none, docstring)`
- a declaration-specific (`/-- ... -/`) docstring, represented as `(some decl_name, docstring)` -/
/-- Set attribute `attr_name` for constant `c_name` with the given priority.
   If the priority is none, then use default -/
/-- `unset_attribute attr_name c_name` -/
/-- `has_attribute attr_name c_name` succeeds if the declaration `decl_name`
   has the attribute `attr_name`. The result is the priority and whether or not
   the attribute is persistent. -/
/-- `copy_attribute attr_name c_name p d_name` copy attribute `attr_name` from
   `src` to `tgt` if it is defined for `src`; make it persistent if `p` is `tt`;
   if `p` is `none`, the copied attribute is made persistent iff it is persistent on `src`  -/
/-- Name of the declaration currently being elaborated. -/
/-- `save_type_info e ref` save (typeof e) at position associated with ref -/
/-- Return list of currently open namespaces -/
/-- Return tt iff `t` "occurs" in `e`. The occurrence checking is performed using
    keyed matching with the given transparency setting.

    We say `t` occurs in `e` by keyed matching iff there is a subterm `s`
    s.t. `t` and `s` have the same head, and `is_def_eq t s md`

    The main idea is to minimize the number of `is_def_eq` checks
    performed. -/
/-- Abstracts all occurrences of the term `t` in `e` using keyed matching.
    If `unify` is `ff`, then matching is used instead of unification.
    That is, metavariables occurring in `e` are not assigned. -/
/-- Blocks the execution of the current thread for at least `msecs` milliseconds.
    This tactic is used mainly for debugging purposes. -/
/-- Type check `e` with respect to the current goal.
    Fails if `e` is not type correct. -/
/-- A `tag` is a list of `names`. These are attached to goals to help tactics track them.-/
def tag := List name

end Mathlib


/- Copyright 2019 (c) Hans-Dieter Hiep. All rights reserved. Released under MIT license as described in the file LICENSE. -/

import objects

universe u

open objects list

/- An event is either an asynchronous method call of some caller object to a callee object, its method, and for each parameter an argument value. Or, an event is a method selection. -/
@[derive decidable_eq]
structure callsite (α β : Type) [objects α β] :=
  {c : class_name α}
  (o : {o : β // c = class_of α o})
  (m : method_name c)
  (τ : vallist (param_types m))
def callsite.elim {α β : Type} [objects α β] {γ : Sort u}
    (cs : callsite α β) (f : Π{c : class_name α}
      (o : {o : β // c = class_of α o})
      (m : method_name c) (τ : vallist (param_types m)),
      cs = ⟨o,m,τ⟩ → γ) : γ :=
  match cs, rfl : (∀ b, cs = b → γ) with
  | ⟨o,m,τ⟩, h := f o m τ h
  end

@[derive decidable_eq]
inductive event (α β : Type) [objects α β]
| call: β → callsite α β → event
| selection: callsite α β → event
def event.to_callsite {α β : Type} [objects α β] :
    event α β → callsite α β
| (event.call _ c) := c
| (event.selection c) := c
def event.o {α β : Type} [objects α β] (e : event α β) :
  β := e.to_callsite.o
def event.c {α β : Type} [objects α β] (e : event α β) :
  class_name α := e.to_callsite.c
def event.m {α β : Type} [objects α β] (e : event α β) :
  method_name e.c := e.to_callsite.m
def event.τ {α β : Type} [objects α β] (e : event α β) :
  vallist (param_types e.m) := e.to_callsite.τ
instance event.event_to_callsite {α β : Type} [objects α β] :
  has_coe (event α β) (callsite α β) := ⟨event.to_callsite⟩

/- A global history is a sequence of events. -/
@[reducible]
def global_history (α β : Type) [objects α β] :=
  list (event α β)
/- There are two subsequences of a global history. The first consists only of call events with the object as callee (abstracted to its corresponding call site), the second consists only of selection events with the object as callee. -/
def event.is_call_to {α β : Type} [objects α β] (x : β) :
    event α β → option (callsite α β)
| (event.call _ c) := if x = c.o then some c else none
| _ := none
/- Call events to an object are of that object. -/
@[simp]
lemma event.is_call_to_object {α β : Type} [objects α β]
  {x : β} {e : event α β} {c : callsite α β} :
  event.is_call_to x e = some c → c.o.val = x :=
begin
  intro, cases e; simp [event.is_call_to] at a,
  { by_cases (x = e_a_1.o); simp [h] at a,
    simp [coe,lift_t,has_lift_t.lift] at h,
    simp [coe_t,has_coe_t.coe,coe_b,has_coe.coe] at h,
    rewrite h, rewrite ← a, exfalso, assumption },
  { exfalso, assumption }
end
def event.is_selection_of {α β : Type} [objects α β] (x : β) :
    event α β → option (callsite α β)
| (event.selection c) := if x = c.o then some c else none
| _ := none
/- Selection events of an object are of that object. -/
@[simp]
lemma event.is_selection_of_object {α β : Type} [objects α β]
  {x : β} {e : event α β} {c : callsite α β} :
  event.is_selection_of x e = some c → c.o.val = x :=
begin
  intro, cases e; simp [event.is_selection_of] at a,
  { exfalso, assumption },
  { by_cases (x = e.o); simp [h] at a,
    simp [coe,lift_t,has_lift_t.lift] at h,
    simp [coe_t,has_coe_t.coe,coe_b,has_coe.coe] at h,
    rewrite h, rewrite ← a, exfalso, assumption }
end
/- The subsequences are obtained by filtering out events. -/
def global_history.calls_to {α β : Type} [objects α β]
    (θ : global_history α β) (x : β) : list (callsite α β) :=
  θ.filter_map (event.is_call_to x)
def global_history.selections_of {α β : Type} [objects α β]
    (θ : global_history α β) (x : β) : list (callsite α β) :=
  θ.filter_map (event.is_selection_of x)
reserve notation `!`:68
reserve notation `?`:68
infix ! := global_history.calls_to
infix ? := global_history.selections_of
/- The list of pending calls to an object is the list of calls to, with the selections removed. -/
def global_history.pending_calls_to {α β : Type} [objects α β]
    (θ : global_history α β) (o : β) : list (callsite α β) :=
  (θ!o).remove_all (θ?o)
/- Pending calls have the same object as requested. -/
lemma global_history.pending_calls_to_object
  {α β : Type} [objects α β] (θ : global_history α β) (o : β) :
  ∀ c : callsite α β,
    c ∈ (global_history.pending_calls_to θ o) → c.o.val = o :=
begin
  unfold global_history.pending_calls_to, intro,
  suffices : c ∈ θ!o → c.o.val = o, intro, apply this,
  simp [remove_all] at a, cases a, assumption,
  simp [global_history.calls_to], intro, intro,
  apply event.is_call_to_object
end
/- We have an optional first pending call to an object. -/
def global_history.sched {α β : Type} [objects α β]
    (θ : global_history α β) (o : β) : option (callsite α β) :=
  head (lift (θ.pending_calls_to o))
/- Scheduled calls have the same object as requested. -/
lemma global_history.sched_object {α β : Type} [objects α β]
  (θ : global_history α β) (o : β) (c : callsite α β) :
  (global_history.sched θ o) = some c → c.o.val = o :=
begin
  unfold global_history.sched,
  cases H : (global_history.pending_calls_to θ o),
  { intro, exfalso, apply head_lift_nil a },
  { intro, have : hd = c, apply tail_lift_some a,
    apply global_history.pending_calls_to_object θ,
    rewrite H, rewrite this, simp }
end
def global_history.collect {α β : Type} [objects α β]
    (θ : global_history α β) : finset β :=
  to_finset (foldr (λ(e : event α β) l, e.o :: l) [] θ)
@[reducible]
def global_history.fresh {α β : Type} [objects α β]
    (o : β) (θ : global_history α β) : Prop :=
  o ∉ θ.collect


import category_theory.preadditive.basic
import category_theory.abelian.projective
import tactic.interval_cases

noncomputable theory

open category_theory
open category_theory.limits

universe variables v u

namespace category_theory

variables {C : Type u} [category.{v} C]

namespace fin3_functor_mk

variables (F : fin 3 → C) (a : F 0 ⟶ F 1) (b : F 1 ⟶ F 2)

def map' : Π (i j : fin 3) (hij : i ≤ j), F i ⟶ F j
| ⟨0,hi⟩ ⟨0,hj⟩ _ := 𝟙 _
| ⟨1,hi⟩ ⟨1,hj⟩ _ := 𝟙 _
| ⟨2,hi⟩ ⟨2,hj⟩ _ := 𝟙 _
| ⟨0,hi⟩ ⟨1,hj⟩ _ := a
| ⟨1,hi⟩ ⟨2,hj⟩ _ := b
| ⟨0,hi⟩ ⟨2,hj⟩ _ := a ≫ b
| ⟨i+3,hi⟩ _ _ := by { exfalso, revert hi, dec_trivial }
| _ ⟨j+3,hj⟩ _ := by { exfalso, revert hj, dec_trivial }
| ⟨i+1,hi⟩ ⟨0,hj⟩ H := by { exfalso, revert H, dec_trivial }
| ⟨i+2,hi⟩ ⟨1,hj⟩ H := by { exfalso, revert H, dec_trivial }
.

lemma map'_id : ∀ (i : fin 3), map' F a b i i le_rfl = 𝟙 _
| ⟨0,hi⟩ := rfl
| ⟨1,hi⟩ := rfl
| ⟨2,hi⟩ := rfl
| ⟨i+3,hi⟩ := by { exfalso, revert hi, dec_trivial }

lemma map'_comp : Π (i j k : fin 3) (hij : i ≤ j) (hjk : j ≤ k),
  map' F a b i j hij ≫ map' F a b j k hjk = map' F a b i k (hij.trans hjk)
| ⟨0, _⟩ ⟨0, _⟩ k _ _ := category.id_comp _
| ⟨1, _⟩ ⟨1, _⟩ k _ _ := category.id_comp _
| i ⟨1, _⟩ ⟨1, _⟩ _ _ := category.comp_id _
| i ⟨2, _⟩ ⟨2, _⟩ _ _ := category.comp_id _
| ⟨0, _⟩ ⟨1, _⟩ ⟨2, _⟩ _ _ := rfl
| ⟨i+3,hi⟩ _ _ _ _ := by { exfalso, revert hi, dec_trivial }
| _ ⟨j+3,hj⟩ _ _ _ := by { exfalso, revert hj, dec_trivial }
| _ _ ⟨k+3,hk⟩ _ _ := by { exfalso, revert hk, dec_trivial }
| ⟨i+1,hi⟩ ⟨0,hj⟩ _ H _ := by { exfalso, revert H, dec_trivial }
| ⟨i+2,hi⟩ ⟨1,hj⟩ _ H _ := by { exfalso, revert H, dec_trivial }
| _ ⟨i+1,hi⟩ ⟨0,hj⟩ _ H := by { exfalso, revert H, dec_trivial }
| _ ⟨i+2,hi⟩ ⟨1,hj⟩ _ H := by { exfalso, revert H, dec_trivial }

end fin3_functor_mk

def fin3_functor_mk (F : fin 3 → C) (a : F 0 ⟶ F 1) (b : F 1 ⟶ F 2) : fin 3 ⥤ C :=
{ obj := F,
  map := λ i j hij, fin3_functor_mk.map' F a b i j hij.le,
  map_id' := λ i, fin3_functor_mk.map'_id F a b i,
  map_comp' := λ i j k hij hjk, by rw fin3_functor_mk.map'_comp F a b i j k hij.le hjk.le }

namespace fin4_functor_mk

variables (F : fin 4 → C) (a : F 0 ⟶ F 1) (b : F 1 ⟶ F 2) (c : F 2 ⟶ F 3)

def map' : Π (i j : fin 4) (hij : i ≤ j), F i ⟶ F j
| ⟨0,hi⟩ ⟨0,hj⟩ _ := 𝟙 _
| ⟨1,hi⟩ ⟨1,hj⟩ _ := 𝟙 _
| ⟨2,hi⟩ ⟨2,hj⟩ _ := 𝟙 _
| ⟨3,hi⟩ ⟨3,hj⟩ _ := 𝟙 _
| ⟨0,hi⟩ ⟨1,hj⟩ _ := a
| ⟨1,hi⟩ ⟨2,hj⟩ _ := b
| ⟨2,hi⟩ ⟨3,hj⟩ _ := c
| ⟨0,hi⟩ ⟨2,hj⟩ _ := a ≫ b
| ⟨1,hi⟩ ⟨3,hj⟩ _ := b ≫ c
| ⟨0,hi⟩ ⟨3,hj⟩ _ := a ≫ b ≫ c
| ⟨i+4,hi⟩ _ _ := by { exfalso, revert hi, dec_trivial }
| _ ⟨j+4,hj⟩ _ := by { exfalso, revert hj, dec_trivial }
| ⟨i+1,hi⟩ ⟨0,hj⟩ H := by { exfalso, revert H, dec_trivial }
| ⟨i+2,hi⟩ ⟨1,hj⟩ H := by { exfalso, revert H, dec_trivial }
| ⟨3,hi⟩ ⟨2,hj⟩ H := by { exfalso, revert H, dec_trivial }
.

lemma map'_id : ∀ (i : fin 4), map' F a b c i i le_rfl = 𝟙 _
| ⟨0,hi⟩ := rfl
| ⟨1,hi⟩ := rfl
| ⟨2,hi⟩ := rfl
| ⟨3,hi⟩ := rfl
| ⟨i+4,hi⟩ := by { exfalso, revert hi, dec_trivial }

lemma map'_comp : Π (i j k : fin 4) (hij : i ≤ j) (hjk : j ≤ k),
  map' F a b c i j hij ≫ map' F a b c j k hjk = map' F a b c i k (hij.trans hjk)
| ⟨0, _⟩ ⟨0, _⟩ k _ _ := category.id_comp _
| ⟨1, _⟩ ⟨1, _⟩ k _ _ := category.id_comp _
| ⟨2, _⟩ ⟨2, _⟩ k _ _ := category.id_comp _
| i ⟨1, _⟩ ⟨1, _⟩ _ _ := category.comp_id _
| i ⟨2, _⟩ ⟨2, _⟩ _ _ := category.comp_id _
| i ⟨3, _⟩ ⟨3, _⟩ _ _ := category.comp_id _
| ⟨0, _⟩ ⟨1, _⟩ ⟨2, _⟩ _ _ := rfl
| ⟨0, _⟩ ⟨1, _⟩ ⟨3, _⟩ _ _ := rfl
| ⟨0, _⟩ ⟨2, _⟩ ⟨3, _⟩ _ _ := category.assoc a b c
| ⟨1, _⟩ ⟨2, _⟩ ⟨3, _⟩ _ _ := rfl
| ⟨i+4,hi⟩ _ _ _ _ := by { exfalso, revert hi, dec_trivial }
| _ ⟨j+4,hj⟩ _ _ _ := by { exfalso, revert hj, dec_trivial }
| _ _ ⟨k+4,hk⟩ _ _ := by { exfalso, revert hk, dec_trivial }
| ⟨i+1,hi⟩ ⟨0,hj⟩ _ H _ := by { exfalso, revert H, dec_trivial }
| ⟨i+2,hi⟩ ⟨1,hj⟩ _ H _ := by { exfalso, revert H, dec_trivial }
| ⟨3,hi⟩ ⟨2,hj⟩ _ H _ := by { exfalso, revert H, dec_trivial }
| _ ⟨i+1,hi⟩ ⟨0,hj⟩ _ H := by { exfalso, revert H, dec_trivial }
| _ ⟨i+2,hi⟩ ⟨1,hj⟩ _ H := by { exfalso, revert H, dec_trivial }
| _ ⟨3,hi⟩ ⟨2,hj⟩ _ H := by { exfalso, revert H, dec_trivial }

end fin4_functor_mk

def fin4_functor_mk (F : fin 4 → C) (a : F 0 ⟶ F 1) (b : F 1 ⟶ F 2) (c : F 2 ⟶ F 3) : fin 4 ⥤ C :=
{ obj := F,
  map := λ i j hij, fin4_functor_mk.map' F a b c i j hij.le,
  map_id' := λ i, fin4_functor_mk.map'_id F a b c i,
  map_comp' := λ i j k hij hjk, by rw fin4_functor_mk.map'_comp F a b c i j k hij.le hjk.le }

end category_theory


open tactic

variables A B : Prop

example : A → B → A ∧ B :=
by do trace "Hi, Mom!",
      trace_state


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

/-
The State monad transformer using CPS style.
-/

def StateCpsT (σ : Type u) (m : Type u → Type v) (α : Type u) := (δ : Type u) → σ → (α → σ → m δ) → m δ

namespace StateCpsT

@[inline] def runK {α σ : Type u} {m : Type u → Type v}  (x : StateCpsT σ m α) (s : σ) (k : α → σ → m β) : m β :=
  x _ s k

@[inline] def run {α σ : Type u} {m : Type u → Type v} [Monad m] (x : StateCpsT σ m α) (s : σ) : m (α × σ) :=
  runK x s (fun a s => pure (a, s))

@[inline] def run' {α σ : Type u} {m : Type u → Type v}  [Monad m] (x : StateCpsT σ m α) (s : σ) : m α :=
  runK x s (fun a s => pure a)

instance : Monad (StateCpsT σ m) where
  map  f x := fun δ s k => x δ s fun a s => k (f a) s
  pure a   := fun δ s k => k a s
  bind x f := fun δ s k => x δ s fun a s => f a δ s k

instance : LawfulMonad (StateCpsT σ m) := by
  refine' { .. } <;> intros <;> rfl

instance : MonadStateOf σ (StateCpsT σ m) where
  get   := fun δ s k => k s s
  set s := fun δ _ k => k ⟨⟩ s
  modifyGet f := fun _ s k => let (a, s) := f s; k a s

@[inline] protected def lift [Monad m] (x : m α) : StateCpsT σ m α :=
  fun _ s k => x >>= (k . s)

instance [Monad m] : MonadLift m (StateCpsT σ m) where
  monadLift := StateCpsT.lift

@[simp] theorem runK_pure {m : Type u → Type v} (a : α) (s : σ) (k : α → σ → m β) : (pure a : StateCpsT σ m α).runK s k = k a s := rfl

@[simp] theorem runK_get {m : Type u → Type v} (s : σ) (k : σ → σ → m β) : (get : StateCpsT σ m σ).runK s k = k s s := rfl

@[simp] theorem runK_set {m : Type u → Type v} (s s' : σ) (k : PUnit → σ → m β) : (set s' : StateCpsT σ m PUnit).runK s k = k ⟨⟩ s' := rfl

@[simp] theorem runK_modify {m : Type u → Type v} (f : σ → σ) (s : σ) (k : PUnit → σ → m β) : (modify f : StateCpsT σ m PUnit).runK s k = k ⟨⟩ (f s) := rfl

@[simp] theorem runK_lift {α σ : Type u} [Monad m] (x : m α) (s : σ) (k : α → σ → m β) : (StateCpsT.lift x : StateCpsT σ m α).runK s k = x >>= (k . s) := rfl

@[simp] theorem runK_monadLift {σ : Type u} [Monad m] [MonadLiftT n m] (x : n α) (s : σ) (k : α → σ → m β)
    : (monadLift x : StateCpsT σ m α).runK s k = (monadLift x : m α) >>= (k . s) := rfl

@[simp] theorem runK_bind_pure {α σ : Type u} [Monad m] (a : α) (f : α → StateCpsT σ m β) (s : σ) (k : β → σ → m γ) : (pure a >>= f).runK s k = (f a).runK s k := rfl

@[simp] theorem runK_bind_lift {α σ : Type u} [Monad m] (x : m α) (f : α → StateCpsT σ m β) (s : σ) (k : β → σ → m γ)
    : (StateCpsT.lift x >>= f).runK s k = x >>= fun a => (f a).runK s k := rfl

@[simp] theorem runK_bind_get {σ : Type u} [Monad m] (f : σ → StateCpsT σ m β) (s : σ) (k : β → σ → m γ) : (get >>= f).runK s k = (f s).runK s k := rfl

@[simp] theorem runK_bind_set {σ : Type u} [Monad m] (f : PUnit → StateCpsT σ m β) (s s' : σ) (k : β → σ → m γ) : (set s' >>= f).runK s k = (f ⟨⟩).runK s' k := rfl

@[simp] theorem runK_bind_modify {σ : Type u} [Monad m] (f : σ → σ) (g : PUnit → StateCpsT σ m β) (s : σ) (k : β → σ → m γ) : (modify f >>= g).runK s k = (g ⟨⟩).runK (f s) k := rfl

@[simp] theorem run_eq [Monad m] (x : StateCpsT σ m α) (s : σ) : x.run s = x.runK s (fun a s => pure (a, s)) := rfl

@[simp] theorem run'_eq [Monad m] (x : StateCpsT σ m α) (s : σ) : x.run' s = x.runK s (fun a s => pure a) := rfl

end StateCpsT


import sesh.term
import sesh.eval

open matrix
open term
open debrujin_idx

inductive thread_flag: Type
| Main: thread_flag
| Child: thread_flag

namespace thread_flag

inductive add: thread_flag → thread_flag → thread_flag → Prop
| CC: add Child Child Child
| CM: add Child Main Main
| MC: add Main Child Main

lemma child_add: ∀ {Φ}, add Child Φ Φ
| Child := add.CC
| Main := add.CM

lemma add_child: ∀ {Φ}, add Φ Child Φ
| Child := add.CC
| Main := add.MC

end thread_flag
open thread_flag

/- A tactic that can solve most goals involving thread flags. -/
meta def solve_flag: tactic unit :=
  `[ exact add.CC <|> exact add.CM <|> exact add.MC
     <|> assumption <|> exact child_add <|> exact add_child
     <|> tactic.fail "Failed to solve flags goal." ]

/- The type of parallel configurations. Configurations have rules
   for well-formedness (called "typing" in the paper). These are
   enforced by the Lean (config) Type. -/
inductive config: Π {γ}, context γ → thread_flag → Type
| CNu:
  Π {γ} {Γ: context γ} {Φ: thread_flag} {S: sesh_tp},
  /- Channel names, being treated the same as standard variables,
     are added to the usual typing context. -/
  config (⟦1⬝S♯⟧::Γ) Φ
  --------------------
→ config Γ Φ

/- Inherently typed config is problematic due to the existence
   of two derivations for a parallel composition. .. but could
   work if (dual S♯) = S♯ -/
| CComp:
  Π {γ} {Γ₁ Γ₂: context γ} {Φ₁ Φ₂: thread_flag} {S: sesh_tp}
  (Γ: context (S♯::γ))
  (Φ: thread_flag)
  (C: config (⟦1⬝S⟧::Γ₁) Φ₁)
  (D: config (⟦1⬝(sesh_tp.dual S)⟧::Γ₂) Φ₂)
  /- The same auto_param technique is used for the resulting
     context and thread flag. -/
  (_: auto_param (Γ = (⟦1⬝S♯⟧::(Γ₁ + Γ₂))) ``solve_context)
  (_: auto_param (add Φ₁ Φ₂ Φ) ``solve_flag),
  ----------
  config Γ Φ

| CMain:
  Π {γ} {Γ: context γ} {A: tp},
  term Γ A
  -------------
→ config Γ Main

| CChild:
  Π {γ} {Γ: context γ},
  term Γ End!
  --------------
→ config Γ Child
open config

notation `●`C:90 := CMain C
notation `○`C:90 := CChild C

/- thread evaluation contexts -/
@[reducible]
def thread_ctx_fn {γ} (Γₑ: context γ) (A': tp) (Φ: thread_flag) :=
  Π (Γ: context γ), term Γ A' → config (Γ + Γₑ) Φ

namespace thread_ctx_fn

@[reducible]
def apply {γ} {Γₑ Γ': context γ} {A': tp} {Φ: thread_flag}
  (f: thread_ctx_fn Γₑ A' Φ)
  (Γ: context γ)
  (M: term Γ' A')
  (h: auto_param (Γ = Γ'+Γₑ) ``solve_context)
  : config Γ Φ :=
cast (by solve_context) $ f Γ' M

end thread_ctx_fn

inductive thread_ctx
  : Π {γ} {A': tp} {Φ: thread_flag} (Γₑ: context γ),
    thread_ctx_fn Γₑ A' Φ → Type
| FMain:
  ∀ {γ} {Γₑ: context γ} {A' A: tp}
  (E: eval_ctx' Γₑ A' A),
  --------------------------------------
  thread_ctx Γₑ (λ Γ M, ●(E.f Γ M))

| FChild:
  ∀ {γ} {Γₑ: context γ} {A': tp}
  (E: eval_ctx' Γₑ A' End!),
  --------------------------------------
  thread_ctx Γₑ (λ Γ M, ○(E.f Γ M))

namespace thread_ctx

def ext:
  Π {γ δ: precontext} {Γ: context γ} {A': tp} {Φ: thread_flag}
    {F: thread_ctx_fn Γ A' Φ}
  (ρ: ren_fn γ δ),
  thread_ctx Γ F
→ let Γ' := (Γ ⊛ (λ B x, identity δ B $ ρ B x)) in
  Σ F': thread_ctx_fn Γ' A' Φ,
    thread_ctx Γ' F'
| _ _ _ _ _ _ ρ (FMain E) := ⟨_, FMain $ eval_ctx'.ext ρ E⟩
| _ _ _ _ _ _ ρ (FChild E) := ⟨_, FChild $ eval_ctx'.ext ρ E⟩

end thread_ctx

structure thread_ctx' {γ} (Γₑ: context γ) (A': tp) (Φ: thread_flag) :=
(f: thread_ctx_fn Γₑ A' Φ)
(h: thread_ctx Γₑ f)

namespace thread_ctx'

def ext {γ δ: precontext} {Γ: context γ} {A': tp} {Φ: thread_flag}
  (ρ: ren_fn γ δ)
  (F: thread_ctx' Γ A' Φ)
  : thread_ctx' (Γ ⊛ (λ B x, identity δ B $ ρ B x)) A' Φ
:= ⟨_, (thread_ctx.ext ρ F.h).snd⟩

end thread_ctx'

inductive context_reduces: ∀ {γ γ'}, context γ → context γ' → Prop
| ΓId:
  ∀ {γ} {Γ: context γ},
  context_reduces Γ Γ

| ΓSend:
    ∀ {γ} {Γ: context γ} {π: mult}
      {A: tp} {S: sesh_tp},
    context_reduces (⟦π⬝(!A⬝S)♯⟧::Γ) (⟦π⬝S♯⟧::Γ)

| ΓRecv:
    ∀ {γ} {Γ: context γ} {π: mult}
      {A: tp} {S: sesh_tp},
    context_reduces (⟦π⬝(?A⬝S)♯⟧::Γ) (⟦π⬝S♯⟧::Γ)

/- An experimental rule to allow self-duality of channel types.
   Never actually used. -/
| ΓHash:
    ∀ {γ} {Γ: context γ} {π: mult} {S: sesh_tp},
    context_reduces (⟦π⬝S♯⟧::Γ) (⟦π⬝(sesh_tp.dual S)♯⟧::Γ)
open context_reduces

inductive config_reduces
  : ∀ {γ γ'} {Γ: context γ} {Γ': context γ'} {Φ},
  context_reduces Γ Γ' → config Γ Φ → config Γ' Φ → Prop
notation C` -`h`⟶C `C':55 := config_reduces h C C'
| CEvalNu:
  ∀ {γ} {Γ: context γ} {S: sesh_tp} {Φ: thread_flag}
    {C C': config (⟦1⬝S♯⟧::Γ) Φ},
  C -ΓId⟶C C'
  ---------------------
→ ((CNu C) -ΓId⟶C (CNu C'))

/- TODO the right version results from commutativity.. somehow -/
| CEvalComp:
  ∀ {γ} {Γ₁ Γ₂: context γ} {S: sesh_tp} {Φ₁ Φ₂: thread_flag}
    {C C': config (⟦1⬝S⟧::Γ₁) Φ₁}
  (Γ: context $ S♯::γ)
  (hΓ: Γ = ⟦1⬝S♯⟧::(Γ₁ + Γ₂))
  (Φ: thread_flag)
  (hΦ: add Φ₁ Φ₂ Φ)
  (D: config (⟦1⬝sesh_tp.dual S⟧::Γ₂) Φ₂),
  C -ΓId⟶C C'
  ----------------------------------------------------------
→ ((CComp Γ Φ C D) -ΓId⟶C (CComp Γ Φ C' D))

| CEvalChild:
  ∀ {γ} {Γ: context γ}
    {M M': term Γ End!},
  M ⟶M M'
  -------------------------------
→ (○M -ΓId⟶C ○M)

| CEvalMain:
  ∀ {γ} {Γ: context γ} {A: tp}
    {M M': term Γ A},
  M ⟶M M'
  --------------------------------
→ (●M -ΓId⟶C ●M')

| CEvalFork:
  ∀ {γ} {Γₑ: context γ} {S: sesh_tp} {Φ}
  (F: thread_ctx' Γₑ (sesh_tp.dual S) Φ)
  (M: term (⟦1⬝S⟧::(0: context γ)) End!),
  ---------------------------------------
  ((F.f.apply Γₑ $ Fork $ Abs M)
  -ΓId⟶C
  (CNu
    $ CComp (⟦1⬝S♯⟧::Γₑ) Φ
      (CChild M)
      $ (F.ext $ ren_fn.lift_once $ sesh_tp.dual S).f.apply
        (⟦1⬝sesh_tp.dual S⟧::Γₑ)
        (Var
          (⟦1⬝sesh_tp.dual S⟧::0)
          $ ZVar _ $ sesh_tp.dual S)
        $ by solve_context))

| CEvalComm:
  ∀ {γ} {Γv: context γ} {A: tp} {S: sesh_tp}
    {Φ₁ Φ₂: thread_flag}
  (V: term Γv A)
  (hV: value V)
  (Φ: thread_flag)
  (hΦ: add Φ₁ Φ₂ Φ)
  (F: thread_ctx' (0: context γ) S Φ₁)
  (F': thread_ctx' (0: context γ) (tp.prod A $ sesh_tp.dual S) Φ₂),
  -----------------------------------------------------------------
  ((CComp (⟦1⬝(!A⬝S)♯⟧::Γv) Φ
    ((F.ext $ ren_fn.lift_once $ !A⬝S).f.apply
      (⟦1⬝!A⬝S⟧::Γv)
      (Send
        (⟦1⬝(!A⬝S)⟧::Γv)
        (term.rename (ren_fn.lift_once $ !A⬝S) _ V)
        (Var
          (⟦1⬝(!A⬝S)⟧::0)
          $ ZVar γ $ !A⬝S)
        $ by solve_context)
      $ by solve_context)
    $ (F'.ext $ ren_fn.lift_once $ sesh_tp.dual $ !A⬝S).f.apply
      (⟦1⬝sesh_tp.dual (!A⬝S)⟧::0)
      (Recv $
        Var
          (⟦1⬝sesh_tp.dual (!A⬝S)⟧::0)
          (begin convert
            (ZVar γ $ sesh_tp.dual $ !A⬝S),
            rw [sesh_tp.dual],
          end)
        $ begin
          have h: ?A⬝sesh_tp.dual S = sesh_tp.dual (!A⬝S),
          unfold sesh_tp.dual,
          sorry
        end))
  -ΓSend⟶C
  (CComp (⟦1⬝S♯⟧::Γv) Φ
    ((F.ext $ ren_fn.lift_once S).f.apply
      (⟦1⬝S⟧::0)
      (Var
        (⟦1⬝S⟧::0)
        (ZVar γ S))
      $ by solve_context) -- now all the context used by V in thread 1 is being used by V
                          -- in thread 2. So the evaluation context must've _not_ used anything
                          -- really and must've been extended with the _entire_ context of V
    $ (F'.ext $ ren_fn.lift_once $ sesh_tp.dual S).f.apply
      (⟦1⬝sesh_tp.dual S⟧::Γv)
      $ Pair
        (⟦1⬝sesh_tp.dual S⟧::Γv)
        (term.rename (ren_fn.lift_once $ sesh_tp.dual S) _ V)
        (Var
          (⟦1⬝sesh_tp.dual S⟧::0)
          $ ZVar γ $ sesh_tp.dual S)
        $ by solve_context))

| CEvalWait:
  ∀ {γ} {Φ}
  (F: thread_ctx' (0: context γ) tp.unit Φ),
  ------------------------------------------
  ((CNu
    $ CComp (⟦1⬝End?♯⟧::0) Φ
      ((F.ext $ ren_fn.lift_once $ End?).f.apply
        (⟦1⬝End?⟧::0)
        (Wait
          $ Var
            (⟦1⬝End?⟧::0)
            $ ZVar γ End?)
        $ by solve_context)
      $ CChild
        $ Var (⟦1⬝End!⟧::0)
          (ZVar γ $ sesh_tp.dual End?)
          $ begin
            show ⟦1⬝End!⟧::0 = identity (End!::γ) End! (ZVar γ End!),
            simp with unfold_,
          end)
  -ΓId⟶C
  (F.f.apply (0: context γ) $ Unit 0))