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

Additional goodies for writing macros
-/
prelude
import Init.Data.Array.Basic
import Init.Data.Option.BasicAux

namespace Lean

@[extern c inline "lean_box(LEAN_VERSION_MAJOR)"]
private opaque version.getMajor (u : Unit) : Nat
def version.major : Nat := version.getMajor ()

@[extern c inline "lean_box(LEAN_VERSION_MINOR)"]
private opaque version.getMinor (u : Unit) : Nat
def version.minor : Nat := version.getMinor ()

@[extern c inline "lean_box(LEAN_VERSION_PATCH)"]
private opaque version.getPatch (u : Unit) : Nat
def version.patch : Nat := version.getPatch ()

@[extern "lean_get_githash"]
opaque getGithash (u : Unit) : String
def githash : String := getGithash ()

@[extern c inline "LEAN_VERSION_IS_RELEASE"]
opaque version.getIsRelease (u : Unit) : Bool
def version.isRelease : Bool := version.getIsRelease ()

/-- Additional version description like "nightly-2018-03-11" -/
@[extern c inline "lean_mk_string(LEAN_SPECIAL_VERSION_DESC)"]
opaque version.getSpecialDesc (u : Unit) : String
def version.specialDesc : String := version.getSpecialDesc ()

def versionStringCore :=
  toString version.major ++ "." ++ toString version.minor ++ "." ++ toString version.patch

def versionString :=
  if version.specialDesc ≠ "" then
    versionStringCore ++ "-" ++ version.specialDesc
  else if version.isRelease then
    versionStringCore
  else
    versionStringCore ++ ", commit " ++ githash

def origin :=
  "leanprover/lean4"

def toolchain :=
  if version.specialDesc ≠ ""  then
    if version.isRelease then
      origin ++ ":" ++ versionStringCore ++ "-" ++ version.specialDesc
    else
      origin ++ ":" ++ version.specialDesc
  else if version.isRelease then
    origin ++ ":" ++ versionStringCore
  else
    ""

@[extern c inline "LEAN_IS_STAGE0"]
opaque Internal.isStage0 (u : Unit) : Bool

/-- Valid identifier names -/
def isGreek (c : Char) : Bool :=
  0x391 ≤ c.val && c.val ≤ 0x3dd

def isLetterLike (c : Char) : Bool :=
  (0x3b1  ≤ c.val && c.val ≤ 0x3c9 && c.val ≠ 0x3bb) ||                  -- Lower greek, but lambda
  (0x391  ≤ c.val && c.val ≤ 0x3A9 && c.val ≠ 0x3A0 && c.val ≠ 0x3A3) || -- Upper greek, but Pi and Sigma
  (0x3ca  ≤ c.val && c.val ≤ 0x3fb) ||                                   -- Coptic letters
  (0x1f00 ≤ c.val && c.val ≤ 0x1ffe) ||                                  -- Polytonic Greek Extended Character Set
  (0x2100 ≤ c.val && c.val ≤ 0x214f) ||                                  -- Letter like block
  (0x1d49c ≤ c.val && c.val ≤ 0x1d59f)                                   -- Latin letters, Script, Double-struck, Fractur

def isNumericSubscript (c : Char) : Bool :=
  0x2080 ≤ c.val && c.val ≤ 0x2089

def isSubScriptAlnum (c : Char) : Bool :=
  isNumericSubscript c ||
  (0x2090 ≤ c.val && c.val ≤ 0x209c) ||
  (0x1d62 ≤ c.val && c.val ≤ 0x1d6a)

def isIdFirst (c : Char) : Bool :=
  c.isAlpha || c = '_' || isLetterLike c

def isIdRest (c : Char) : Bool :=
  c.isAlphanum || c = '_' || c = '\'' || c == '!' || c == '?' || isLetterLike c || isSubScriptAlnum c

def idBeginEscape := '«'
def idEndEscape   := '»'
def isIdBeginEscape (c : Char) : Bool := c = idBeginEscape
def isIdEndEscape (c : Char) : Bool := c = idEndEscape

namespace Name

def getRoot : Name → Name
  | anonymous             => anonymous
  | n@(str anonymous _) => n
  | n@(num anonymous _) => n
  | str n _             => getRoot n
  | num n _             => getRoot n

@[export lean_is_inaccessible_user_name]
def isInaccessibleUserName : Name → Bool
  | Name.str _ s   => s.contains '✝' || s == "_inaccessible"
  | Name.num p _   => isInaccessibleUserName p
  | _              => false

def escapePart (s : String) : Option String :=
  if s.length > 0 && isIdFirst (s.get 0) && (s.toSubstring.drop 1).all isIdRest then s
  else if s.any isIdEndEscape then none
  else some <| idBeginEscape.toString ++ s ++ idEndEscape.toString

-- NOTE: does not roundtrip even with `escape = true` if name is anonymous or contains numeric part or `idEndEscape`
variable (sep : String) (escape : Bool)
def toStringWithSep : Name → String
  | anonymous       => "[anonymous]"
  | str anonymous s => maybeEscape s
  | num anonymous v => toString v
  | str n s         => toStringWithSep n ++ sep ++ maybeEscape s
  | num n v         => toStringWithSep n ++ sep ++ Nat.repr v
where
  maybeEscape s := if escape then escapePart s |>.getD s else s

protected def toString (n : Name) (escape := true) : String :=
  -- never escape "prettified" inaccessible names or macro scopes or pseudo-syntax introduced by the delaborator
  toStringWithSep "." (escape && !n.isInaccessibleUserName && !n.hasMacroScopes && !maybePseudoSyntax) n
where
  maybePseudoSyntax :=
    if let .str _ s := n.getRoot then
      -- could be pseudo-syntax for loose bvar or universe mvar, output as is
      "#".isPrefixOf s || "?".isPrefixOf s
    else
      false

instance : ToString Name where
  toString n := n.toString

private def hasNum : Name → Bool
  | anonymous => false
  | num ..    => true
  | str p ..  => hasNum p

protected def reprPrec (n : Name) (prec : Nat) : Std.Format :=
  match n with
  | anonymous => Std.Format.text "Lean.Name.anonymous"
  | num p i => Repr.addAppParen ("Lean.Name.mkNum " ++ Name.reprPrec p max_prec ++ " " ++ repr i) prec
  | str p s =>
    if p.hasNum then
      Repr.addAppParen ("Lean.Name.mkStr " ++ Name.reprPrec p max_prec ++ " " ++ repr s) prec
    else
      Std.Format.text "`" ++ n.toString

instance : Repr Name where
  reprPrec := Name.reprPrec

def capitalize : Name → Name
  | .str p s => .str p s.capitalize
  | n        => n

def replacePrefix : Name → Name → Name → Name
  | anonymous,   anonymous, newP => newP
  | anonymous,   _,         _    => anonymous
  | n@(str p s), queryP,    newP => if n == queryP then newP else Name.mkStr (p.replacePrefix queryP newP) s
  | n@(num p s), queryP,    newP => if n == queryP then newP else Name.mkNum (p.replacePrefix queryP newP) s

/--
  `eraseSuffix? n s` return `n'` if `n` is of the form `n == n' ++ s`.
-/
def eraseSuffix? : Name → Name → Option Name
  | n,       anonymous => some n
  | str p s, str p' s' => if s == s' then eraseSuffix? p p' else none
  | num p s, num p' s' => if s == s' then eraseSuffix? p p' else none
  | _,       _         => none

/-- Remove macros scopes, apply `f`, and put them back -/
@[inline] def modifyBase (n : Name) (f : Name → Name) : Name :=
  if n.hasMacroScopes then
    let view := extractMacroScopes n
    { view with name := f view.name }.review
  else
    f n

@[export lean_name_append_after]
def appendAfter (n : Name) (suffix : String) : Name :=
  n.modifyBase fun
    | str p s => Name.mkStr p (s ++ suffix)
    | n       => Name.mkStr n suffix

@[export lean_name_append_index_after]
def appendIndexAfter (n : Name) (idx : Nat) : Name :=
  n.modifyBase fun
    | str p s => Name.mkStr p (s ++ "_" ++ toString idx)
    | n       => Name.mkStr n ("_" ++ toString idx)

@[export lean_name_append_before]
def appendBefore (n : Name) (pre : String) : Name :=
  n.modifyBase fun
    | anonymous => Name.mkStr anonymous pre
    | str p s => Name.mkStr p (pre ++ s)
    | num p n => Name.mkNum (Name.mkStr p pre) n

protected theorem beq_iff_eq {m n : Name} : m == n ↔ m = n := by
  show m.beq n ↔ _
  induction m generalizing n <;> cases n <;> simp_all [Name.beq, And.comm]

instance : LawfulBEq Name where
  eq_of_beq := Name.beq_iff_eq.1
  rfl := Name.beq_iff_eq.2 rfl

instance : DecidableEq Name :=
  fun a b => if h : a == b then .isTrue (by simp_all) else .isFalse (by simp_all)

end Name

structure NameGenerator where
  namePrefix : Name := `_uniq
  idx        : Nat  := 1
  deriving Inhabited

namespace NameGenerator

@[inline] def curr (g : NameGenerator) : Name :=
  Name.mkNum g.namePrefix g.idx

@[inline] def next (g : NameGenerator) : NameGenerator :=
  { g with idx := g.idx + 1 }

@[inline] def mkChild (g : NameGenerator) : NameGenerator × NameGenerator :=
  ({ namePrefix := Name.mkNum g.namePrefix g.idx, idx := 1 },
   { g with idx := g.idx + 1 })

end NameGenerator

class MonadNameGenerator (m : Type → Type) where
  getNGen : m NameGenerator
  setNGen : NameGenerator → m Unit

export MonadNameGenerator (getNGen setNGen)

def mkFreshId {m : Type → Type} [Monad m] [MonadNameGenerator m] : m Name := do
  let ngen ← getNGen
  let r := ngen.curr
  setNGen ngen.next
  pure r

instance monadNameGeneratorLift (m n : Type → Type) [MonadLift m n] [MonadNameGenerator m] : MonadNameGenerator n := {
  getNGen := liftM (getNGen : m _),
  setNGen := fun ngen => liftM (setNGen ngen : m _)
}

namespace Syntax

deriving instance Repr for Syntax.Preresolved
deriving instance Repr for Syntax
deriving instance Repr for TSyntax

abbrev Term := TSyntax `term
abbrev Command := TSyntax `command
protected abbrev Level := TSyntax `level
protected abbrev Tactic := TSyntax `tactic
abbrev Prec := TSyntax `prec
abbrev Prio := TSyntax `prio
abbrev Ident := TSyntax identKind
abbrev StrLit := TSyntax strLitKind
abbrev CharLit := TSyntax charLitKind
abbrev NameLit := TSyntax nameLitKind
abbrev ScientificLit := TSyntax scientificLitKind
abbrev NumLit := TSyntax numLitKind

end Syntax

export Syntax (Term Command Prec Prio Ident StrLit CharLit NameLit ScientificLit NumLit)

namespace TSyntax

instance : Coe (TSyntax [k]) (TSyntax (k :: ks)) where
  coe stx := ⟨stx⟩

instance : Coe (TSyntax ks) (TSyntax (k' :: ks)) where
  coe stx := ⟨stx⟩

instance : Coe Ident Term where
  coe s := ⟨s.raw⟩

instance : CoeDep Term ⟨Syntax.ident info ss n res⟩ Ident where
  coe := ⟨Syntax.ident info ss n res⟩

instance : Coe StrLit Term where
  coe s := ⟨s.raw⟩

instance : Coe NameLit Term where
  coe s := ⟨s.raw⟩

instance : Coe ScientificLit Term where
  coe s := ⟨s.raw⟩

instance : Coe NumLit Term where
  coe s := ⟨s.raw⟩

instance : Coe CharLit Term where
  coe s := ⟨s.raw⟩

instance : Coe Ident Syntax.Level where
  coe s := ⟨s.raw⟩

instance : Coe NumLit Prio where
  coe s := ⟨s.raw⟩

instance : Coe NumLit Prec where
  coe s := ⟨s.raw⟩

namespace Compat

scoped instance : CoeTail Syntax (TSyntax k) where
  coe s := ⟨s⟩

scoped instance : CoeTail (Array Syntax) (TSyntaxArray k) where
  coe := .mk

end Compat

end TSyntax

namespace Syntax

deriving instance BEq for Syntax.Preresolved

/-- Compare syntax structures modulo source info. -/
partial def structEq : Syntax → Syntax → Bool
  | Syntax.missing, Syntax.missing => true
  | Syntax.node _ k args, Syntax.node _ k' args' => k == k' && args.isEqv args' structEq
  | Syntax.atom _ val, Syntax.atom _ val' => val == val'
  | Syntax.ident _ rawVal val preresolved, Syntax.ident _ rawVal' val' preresolved' => rawVal == rawVal' && val == val' && preresolved == preresolved'
  | _, _ => false

instance : BEq Lean.Syntax := ⟨structEq⟩
instance : BEq (Lean.TSyntax k) := ⟨(·.raw == ·.raw)⟩

partial def getTailInfo? : Syntax → Option SourceInfo
  | atom info _   => info
  | ident info .. => info
  | node SourceInfo.none _ args =>
      args.findSomeRev? getTailInfo?
  | node info _ _    => info
  | _             => none

def getTailInfo (stx : Syntax) : SourceInfo :=
  stx.getTailInfo?.getD SourceInfo.none

def getTrailingSize (stx : Syntax) : Nat :=
  match stx.getTailInfo? with
  | some (SourceInfo.original (trailing := trailing) ..) => trailing.bsize
  | _ => 0

/--
  Return substring of original input covering `stx`.
  Result is meaningful only if all involved `SourceInfo.original`s refer to the same string (as is the case after parsing). -/
def getSubstring? (stx : Syntax) (withLeading := true) (withTrailing := true) : Option Substring :=
  match stx.getHeadInfo, stx.getTailInfo with
  | SourceInfo.original lead startPos _ _, SourceInfo.original _ _ trail stopPos =>
    some {
      str      := lead.str
      startPos := if withLeading then lead.startPos else startPos
      stopPos  := if withTrailing then trail.stopPos else stopPos
    }
  | _, _ => none

@[specialize] private partial def updateLast {α} [Inhabited α] (a : Array α) (f : α → Option α) (i : Nat) : Option (Array α) :=
  if i == 0 then
    none
  else
    let i := i - 1
    let v := a[i]!
    match f v with
    | some v => some <| a.set! i v
    | none   => updateLast a f i

partial def setTailInfoAux (info : SourceInfo) : Syntax → Option Syntax
  | atom _ val             => some <| atom info val
  | ident _ rawVal val pre => some <| ident info rawVal val pre
  | node info k args       =>
    match updateLast args (setTailInfoAux info) args.size with
    | some args => some <| node info k args
    | none      => none
  | _                      => none

def setTailInfo (stx : Syntax) (info : SourceInfo) : Syntax :=
  match setTailInfoAux info stx with
  | some stx => stx
  | none     => stx

def unsetTrailing (stx : Syntax) : Syntax :=
  match stx.getTailInfo with
  | SourceInfo.original lead pos _ endPos => stx.setTailInfo (SourceInfo.original lead pos "".toSubstring endPos)
  | _                                     => stx

@[specialize] private partial def updateFirst {α} [Inhabited α] (a : Array α) (f : α → Option α) (i : Nat) : Option (Array α) :=
  if h : i < a.size then
    let v := a[i]
    match f v with
    | some v => some <| a.set ⟨i, h⟩ v
    | none   => updateFirst a f (i+1)
  else
    none

partial def setHeadInfoAux (info : SourceInfo) : Syntax → Option Syntax
  | atom _ val             => some <| atom info val
  | ident _ rawVal val pre => some <| ident info rawVal val pre
  | node i k args          =>
    match updateFirst args (setHeadInfoAux info) 0 with
    | some args => some <| node i k args
    | _         => none
  | _                      => none

def setHeadInfo (stx : Syntax) (info : SourceInfo) : Syntax :=
  match setHeadInfoAux info stx with
  | some stx => stx
  | none     => stx

def setInfo (info : SourceInfo) : Syntax → Syntax
  | atom _ val             => atom info val
  | ident _ rawVal val pre => ident info rawVal val pre
  | node _ kind args       => node info kind args
  | missing                => missing

/-- Return the first atom/identifier that has position information -/
partial def getHead? : Syntax → Option Syntax
  | stx@(atom info ..)  => info.getPos?.map fun _ => stx
  | stx@(ident info ..) => info.getPos?.map fun _ => stx
  | node SourceInfo.none _ args => args.findSome? getHead?
  | stx@(node ..) => stx
  | _ => none

def copyHeadTailInfoFrom (target source : Syntax) : Syntax :=
  target.setHeadInfo source.getHeadInfo |>.setTailInfo source.getTailInfo

/-- Ensure head position is synthetic. The server regards syntax as "original" only if both head and tail info are `original`. -/
def mkSynthetic (stx : Syntax) : Syntax :=
  stx.setHeadInfo (SourceInfo.fromRef stx)

end Syntax

/-- Use the head atom/identifier of the current `ref` as the `ref` -/
@[inline] def withHeadRefOnly {m : Type → Type} [Monad m] [MonadRef m] {α} (x : m α) : m α := do
  match (← getRef).getHead? with
  | none => x
  | some ref => withRef ref x

/-- Syntax objects for a Lean module. -/
structure Module where
  header   : Syntax
  commands : Array Syntax

/--
  Expand macros in the given syntax.
  A node with kind `k` is visited only if `p k` is true.

  Note that the default value for `p` returns false for `by ...` nodes.
  This is a "hack". The tactic framework abuses the macro system to implement extensible tactics.
  For example, one can define
  ```lean
  syntax "my_trivial" : tactic -- extensible tactic

  macro_rules | `(tactic| my_trivial) => `(tactic| decide)
  macro_rules | `(tactic| my_trivial) => `(tactic| assumption)
  ```
  When the tactic evaluator finds the tactic `my_trivial`, it tries to evaluate the `macro_rule` expansions
  until one "works", i.e., the macro expansion is evaluated without producing an exception.
  We say this solution is a bit hackish because the term elaborator may invoke `expandMacros` with `(p := fun _ => true)`,
  and expand the tactic macros as just macros. In the example above, `my_trivial` would be replaced with `assumption`,
  `decide` would not be tried if `assumption` fails at tactic evaluation time.

  We are considering two possible solutions for this issue:
  1- A proper extensible tactic feature that does not rely on the macro system.

  2- Typed macros that know the syntax categories they're working in. Then, we would be able to select which
     syntatic categories are expanded by `expandMacros`.
-/
partial def expandMacros (stx : Syntax) (p : SyntaxNodeKind → Bool := fun k => k != `Lean.Parser.Term.byTactic) : MacroM Syntax :=
  withRef stx do
    match stx with
    | .node info k args => do
      if p k then
        match (← expandMacro? stx) with
        | some stxNew => expandMacros stxNew
        | none        => do
          let args ← Macro.withIncRecDepth stx <| args.mapM expandMacros
          return .node info k args
      else
        return stx
    | stx => return stx

/-! # Helper functions for processing Syntax programmatically -/

/--
  Create an identifier copying the position from `src`.
  To refer to a specific constant, use `mkCIdentFrom` instead. -/
def mkIdentFrom (src : Syntax) (val : Name) (canonical := false) : Ident :=
  ⟨Syntax.ident (SourceInfo.fromRef src canonical) (toString val).toSubstring val []⟩

def mkIdentFromRef [Monad m] [MonadRef m] (val : Name) (canonical := false) : m Ident := do
  return mkIdentFrom (← getRef) val canonical

/--
  Create an identifier referring to a constant `c` copying the position from `src`.
  This variant of `mkIdentFrom` makes sure that the identifier cannot accidentally
  be captured. -/
def mkCIdentFrom (src : Syntax) (c : Name) (canonical := false) : Ident :=
  -- Remark: We use the reserved macro scope to make sure there are no accidental collision with our frontend
  let id   := addMacroScope `_internal c reservedMacroScope
  ⟨Syntax.ident (SourceInfo.fromRef src canonical) (toString id).toSubstring id [.decl c []]⟩

def mkCIdentFromRef [Monad m] [MonadRef m] (c : Name) (canonical := false) : m Syntax := do
  return mkCIdentFrom (← getRef) c canonical

def mkCIdent (c : Name) : Ident :=
  mkCIdentFrom Syntax.missing c

@[export lean_mk_syntax_ident]
def mkIdent (val : Name) : Ident :=
  ⟨Syntax.ident SourceInfo.none (toString val).toSubstring val []⟩

@[inline] def mkGroupNode (args : Array Syntax := #[]) : Syntax :=
  mkNode groupKind args

def mkSepArray (as : Array Syntax) (sep : Syntax) : Array Syntax := Id.run do
  let mut i := 0
  let mut r := #[]
  for a in as do
    if i > 0 then
      r := r.push sep |>.push a
    else
      r := r.push a
    i := i + 1
  return r

def mkOptionalNode (arg : Option Syntax) : Syntax :=
  match arg with
  | some arg => mkNullNode #[arg]
  | none     => mkNullNode #[]

def mkHole (ref : Syntax) (canonical := false) : Syntax :=
  mkNode `Lean.Parser.Term.hole #[mkAtomFrom ref "_" canonical]

namespace Syntax

def mkSep (a : Array Syntax) (sep : Syntax) : Syntax :=
  mkNullNode <| mkSepArray a sep

def SepArray.ofElems {sep} (elems : Array Syntax) : SepArray sep :=
⟨mkSepArray elems (if sep.isEmpty then mkNullNode else mkAtom sep)⟩

def SepArray.ofElemsUsingRef [Monad m] [MonadRef m] {sep} (elems : Array Syntax) : m (SepArray sep) := do
  let ref ← getRef;
  return ⟨mkSepArray elems (if sep.isEmpty then mkNullNode else mkAtomFrom ref sep)⟩

instance : Coe (Array Syntax) (SepArray sep) where
  coe := SepArray.ofElems

instance : Coe (TSyntaxArray k) (TSepArray k sep) where
  coe a := ⟨mkSepArray a.raw (mkAtom sep)⟩

/-- Create syntax representing a Lean term application, but avoid degenerate empty applications. -/
def mkApp (fn : Term) : (args : TSyntaxArray `term) → Term
  | #[]  => fn
  | args => ⟨mkNode `Lean.Parser.Term.app #[fn, mkNullNode args.raw]⟩

def mkCApp (fn : Name) (args : TSyntaxArray `term) : Term :=
  mkApp (mkCIdent fn) args

def mkLit (kind : SyntaxNodeKind) (val : String) (info := SourceInfo.none) : TSyntax kind :=
  let atom : Syntax := Syntax.atom info val
  mkNode kind #[atom]

def mkStrLit (val : String) (info := SourceInfo.none) : StrLit :=
  mkLit strLitKind (String.quote val) info

def mkNumLit (val : String) (info := SourceInfo.none) : NumLit :=
  mkLit numLitKind val info

def mkScientificLit (val : String) (info := SourceInfo.none) : TSyntax scientificLitKind :=
  mkLit scientificLitKind val info

def mkNameLit (val : String) (info := SourceInfo.none) : NameLit :=
  mkLit nameLitKind val info

/-! Recall that we don't have special Syntax constructors for storing numeric and string atoms.
   The idea is to have an extensible approach where embedded DSLs may have new kind of atoms and/or
   different ways of representing them. So, our atoms contain just the parsed string.
   The main Lean parser uses the kind `numLitKind` for storing natural numbers that can be encoded
   in binary, octal, decimal and hexadecimal format. `isNatLit` implements a "decoder"
   for Syntax objects representing these numerals. -/

private partial def decodeBinLitAux (s : String) (i : String.Pos) (val : Nat) : Option Nat :=
  if s.atEnd i then some val
  else
    let c := s.get i
    if c == '0' then decodeBinLitAux s (s.next i) (2*val)
    else if c == '1' then decodeBinLitAux s (s.next i) (2*val + 1)
    else none

private partial def decodeOctalLitAux (s : String) (i : String.Pos) (val : Nat) : Option Nat :=
  if s.atEnd i then some val
  else
    let c := s.get i
    if '0' ≤ c && c ≤ '7' then decodeOctalLitAux s (s.next i) (8*val + c.toNat - '0'.toNat)
    else none

private def decodeHexDigit (s : String) (i : String.Pos) : Option (Nat × String.Pos) :=
  let c := s.get i
  let i := s.next i
  if '0' ≤ c && c ≤ '9' then some (c.toNat - '0'.toNat, i)
  else if 'a' ≤ c && c ≤ 'f' then some (10 + c.toNat - 'a'.toNat, i)
  else if 'A' ≤ c && c ≤ 'F' then some (10 + c.toNat - 'A'.toNat, i)
  else none

private partial def decodeHexLitAux (s : String) (i : String.Pos) (val : Nat) : Option Nat :=
  if s.atEnd i then some val
  else match decodeHexDigit s i with
    | some (d, i) => decodeHexLitAux s i (16*val + d)
    | none        => none

private partial def decodeDecimalLitAux (s : String) (i : String.Pos) (val : Nat) : Option Nat :=
  if s.atEnd i then some val
  else
    let c := s.get i
    if '0' ≤ c && c ≤ '9' then decodeDecimalLitAux s (s.next i) (10*val + c.toNat - '0'.toNat)
    else none

def decodeNatLitVal? (s : String) : Option Nat :=
  let len := s.length
  if len == 0 then none
  else
    let c := s.get 0
    if c == '0' then
      if len == 1 then some 0
      else
        let c := s.get ⟨1⟩
        if c == 'x' || c == 'X' then decodeHexLitAux s ⟨2⟩ 0
        else if c == 'b' || c == 'B' then decodeBinLitAux s ⟨2⟩ 0
        else if c == 'o' || c == 'O' then decodeOctalLitAux s ⟨2⟩ 0
        else if c.isDigit then decodeDecimalLitAux s 0 0
        else none
    else if c.isDigit then decodeDecimalLitAux s 0 0
    else none

def isLit? (litKind : SyntaxNodeKind) (stx : Syntax) : Option String :=
  match stx with
  | Syntax.node _ k args =>
    if k == litKind && args.size == 1 then
      match args.get! 0 with
      | (Syntax.atom _ val) => some val
      | _ => none
    else
      none
  | _ => none

private def isNatLitAux (litKind : SyntaxNodeKind) (stx : Syntax) : Option Nat :=
  match isLit? litKind stx with
  | some val => decodeNatLitVal? val
  | _        => none

def isNatLit? (s : Syntax) : Option Nat :=
  isNatLitAux numLitKind s

def isFieldIdx? (s : Syntax) : Option Nat :=
  isNatLitAux fieldIdxKind s

/-- Decodes a 'scientific number' string which is consumed by the `OfScientific` class.
  Takes as input a string such as `123`, `123.456e7` and returns a triple `(n, sign, e)` with value given by
  `n * 10^-e` if `sign` else `n * 10^e`.
-/
partial def decodeScientificLitVal? (s : String) : Option (Nat × Bool × Nat) :=
  let len := s.length
  if len == 0 then none
  else
    let c := s.get 0
    if c.isDigit then
      decode 0 0
    else none
where
  decodeAfterExp (i : String.Pos) (val : Nat) (e : Nat) (sign : Bool) (exp : Nat) : Option (Nat × Bool × Nat) :=
    if s.atEnd i then
      if sign then
        some (val, sign, exp + e)
      else if exp >= e then
        some (val, sign, exp - e)
      else
        some (val, true, e - exp)
    else
      let c := s.get i
      if '0' ≤ c && c ≤ '9' then
        decodeAfterExp (s.next i) val e sign (10*exp + c.toNat - '0'.toNat)
      else
        none

  decodeExp (i : String.Pos) (val : Nat) (e : Nat) : Option (Nat × Bool × Nat) :=
    if s.atEnd i then none else
    let c := s.get i
    if c == '-' then
       decodeAfterExp (s.next i) val e true 0
    else if c == '+' then
       decodeAfterExp (s.next i) val e false 0
    else
       decodeAfterExp i val e false 0

  decodeAfterDot (i : String.Pos) (val : Nat) (e : Nat) : Option (Nat × Bool × Nat) :=
    if s.atEnd i then
      some (val, true, e)
    else
      let c := s.get i
      if '0' ≤ c && c ≤ '9' then
        decodeAfterDot (s.next i) (10*val + c.toNat - '0'.toNat) (e+1)
      else if c == 'e' || c == 'E' then
        decodeExp (s.next i) val e
      else
        none

  decode (i : String.Pos) (val : Nat) : Option (Nat × Bool × Nat) :=
    if s.atEnd i then
      none
    else
      let c := s.get i
      if '0' ≤ c && c ≤ '9' then
        decode (s.next i) (10*val + c.toNat - '0'.toNat)
      else if c == '.' then
        decodeAfterDot (s.next i) val 0
      else if c == 'e' || c == 'E' then
        decodeExp (s.next i) val 0
      else
        none

def isScientificLit? (stx : Syntax) : Option (Nat × Bool × Nat) :=
  match isLit? scientificLitKind stx with
  | some val => decodeScientificLitVal? val
  | _        => none

def isIdOrAtom? : Syntax → Option String
  | Syntax.atom _ val           => some val
  | Syntax.ident _ rawVal _ _   => some rawVal.toString
  | _ => none

def toNat (stx : Syntax) : Nat :=
  match stx.isNatLit? with
  | some val => val
  | none     => 0

def decodeQuotedChar (s : String) (i : String.Pos) : Option (Char × String.Pos) := do
  let c := s.get i
  let i := s.next i
  if c == '\\' then pure ('\\', i)
  else if c = '\"' then pure ('\"', i)
  else if c = '\'' then pure ('\'', i)
  else if c = 'r'  then pure ('\r', i)
  else if c = 'n'  then pure ('\n', i)
  else if c = 't'  then pure ('\t', i)
  else if c = 'x'  then
    let (d₁, i) ← decodeHexDigit s i
    let (d₂, i) ← decodeHexDigit s i
    pure (Char.ofNat (16*d₁ + d₂), i)
  else if c = 'u'  then do
    let (d₁, i) ← decodeHexDigit s i
    let (d₂, i) ← decodeHexDigit s i
    let (d₃, i) ← decodeHexDigit s i
    let (d₄, i) ← decodeHexDigit s i
    pure (Char.ofNat (16*(16*(16*d₁ + d₂) + d₃) + d₄), i)
  else
    none

partial def decodeStrLitAux (s : String) (i : String.Pos) (acc : String) : Option String := do
  let c := s.get i
  let i := s.next i
  if c == '\"' then
    pure acc
  else if s.atEnd i then
    none
  else if c == '\\' then do
    let (c, i) ← decodeQuotedChar s i
    decodeStrLitAux s i (acc.push c)
  else
    decodeStrLitAux s i (acc.push c)

def decodeStrLit (s : String) : Option String :=
  decodeStrLitAux s ⟨1⟩ ""

def isStrLit? (stx : Syntax) : Option String :=
  match isLit? strLitKind stx with
  | some val => decodeStrLit val
  | _        => none

def decodeCharLit (s : String) : Option Char := do
  let c := s.get ⟨1⟩
  if c == '\\' then do
    let (c, _) ← decodeQuotedChar s ⟨2⟩
    pure c
  else
    pure c

def isCharLit? (stx : Syntax) : Option Char :=
  match isLit? charLitKind stx with
  | some val => decodeCharLit val
  | _        => none

private partial def splitNameLitAux (ss : Substring) (acc : List Substring) : List Substring :=
  let splitRest (ss : Substring) (acc : List Substring) : List Substring :=
    if ss.front == '.' then
      splitNameLitAux (ss.drop 1) acc
    else if ss.isEmpty then
      acc
    else
      []
  if ss.isEmpty then []
  else
    let curr := ss.front
    if isIdBeginEscape curr then
      let escapedPart := ss.takeWhile (!isIdEndEscape ·)
      let escapedPart := { escapedPart with stopPos := ss.stopPos.min (escapedPart.str.next escapedPart.stopPos) }
      if !isIdEndEscape (escapedPart.get <| escapedPart.prev ⟨escapedPart.bsize⟩) then []
      else splitRest (ss.extract ⟨escapedPart.bsize⟩ ⟨ss.bsize⟩) (escapedPart :: acc)
    else if isIdFirst curr then
      let idPart := ss.takeWhile isIdRest
      splitRest (ss.extract ⟨idPart.bsize⟩ ⟨ss.bsize⟩) (idPart :: acc)
    else if curr.isDigit then
      let idPart := ss.takeWhile Char.isDigit
      splitRest (ss.extract ⟨idPart.bsize⟩ ⟨ss.bsize⟩) (idPart :: acc)
    else
      []

/-- Split a name literal (without the backtick) into its dot-separated components. For example,
`foo.bla.«bo.o»` ↦ `["foo", "bla", "«bo.o»"]`. If the literal cannot be parsed, return `[]`. -/
def splitNameLit (ss : Substring) : List Substring :=
  splitNameLitAux ss [] |>.reverse

def decodeNameLit (s : String) : Option Name :=
  if s.get 0 == '`' then
    match splitNameLitAux (s.toSubstring.drop 1) [] with
    | [] => none
    | comps => some <| comps.foldr (init := Name.anonymous)
      fun comp n =>
        let comp := comp.toString
        if isIdBeginEscape comp.front then
          Name.mkStr n (comp.drop 1 |>.dropRight 1)
        else if comp.front.isDigit then
          if let some k := decodeNatLitVal? comp then
            Name.mkNum n k
          else
            unreachable!
        else
          Name.mkStr n comp
  else
    none

def isNameLit? (stx : Syntax) : Option Name :=
  match isLit? nameLitKind stx with
  | some val => decodeNameLit val
  | _        => none

def hasArgs : Syntax → Bool
  | Syntax.node _ _ args => args.size > 0
  | _                    => false

def isAtom : Syntax → Bool
  | atom _ _ => true
  | _        => false

def isToken (token : String) : Syntax → Bool
  | atom _ val => val.trim == token.trim
  | _          => false

def isNone (stx : Syntax) : Bool :=
  match stx with
  | Syntax.node _ k args => k == nullKind && args.size == 0
  -- when elaborating partial syntax trees, it's reasonable to interpret missing parts as `none`
  | Syntax.missing     => true
  | _                  => false

def getOptionalIdent? (stx : Syntax) : Option Name :=
  match stx.getOptional? with
  | some stx => some stx.getId
  | none     => none

partial def findAux (p : Syntax → Bool) : Syntax → Option Syntax
  | stx@(Syntax.node _ _ args) => if p stx then some stx else args.findSome? (findAux p)
  | stx                        => if p stx then some stx else none

def find? (stx : Syntax) (p : Syntax → Bool) : Option Syntax :=
  findAux p stx

end Syntax

namespace TSyntax

def getNat (s : NumLit) : Nat :=
  s.raw.isNatLit?.getD 0

def getId (s : Ident) : Name :=
  s.raw.getId

def getScientific (s : ScientificLit) : Nat × Bool × Nat :=
  s.raw.isScientificLit?.getD (0, false, 0)

def getString (s : StrLit) : String :=
  s.raw.isStrLit?.getD ""

def getChar (s : CharLit) : Char :=
  s.raw.isCharLit?.getD default

def getName (s : NameLit) : Name :=
  s.raw.isNameLit?.getD .anonymous

namespace Compat

scoped instance : CoeTail (Array Syntax) (Syntax.TSepArray k sep) where
  coe a := (a : TSyntaxArray k)

end Compat

end TSyntax

/-- Reflect a runtime datum back to surface syntax (best-effort). -/
class Quote (α : Type) (k : SyntaxNodeKind := `term) where
  quote : α → TSyntax k

export Quote (quote)

instance [Quote α k] [CoeHTCT (TSyntax k) (TSyntax [k'])] : Quote α k' := ⟨fun a => quote (k := k) a⟩

instance : Quote Term := ⟨id⟩
instance : Quote Bool := ⟨fun | true => mkCIdent ``Bool.true | false => mkCIdent ``Bool.false⟩
instance : Quote String strLitKind := ⟨Syntax.mkStrLit⟩
instance : Quote Nat numLitKind := ⟨fun n => Syntax.mkNumLit <| toString n⟩
instance : Quote Substring := ⟨fun s => Syntax.mkCApp ``String.toSubstring' #[quote s.toString]⟩

-- in contrast to `Name.toString`, we can, and want to be, precise here
private def getEscapedNameParts? (acc : List String) : Name → Option (List String)
  | Name.anonymous => if acc.isEmpty then none else some acc
  | Name.str n s => do
    let s ← Name.escapePart s
    getEscapedNameParts? (s::acc) n
  | Name.num _ _ => none

def quoteNameMk : Name → Term
  | .anonymous => mkCIdent ``Name.anonymous
  | .str n s => Syntax.mkCApp ``Name.mkStr #[quoteNameMk n, quote s]
  | .num n i => Syntax.mkCApp ``Name.mkNum #[quoteNameMk n, quote i]

instance : Quote Name `term where
  quote n := match getEscapedNameParts? [] n with
    | some ss => ⟨mkNode `Lean.Parser.Term.quotedName #[Syntax.mkNameLit ("`" ++ ".".intercalate ss)]⟩
    | none    => ⟨quoteNameMk n⟩

instance [Quote α `term] [Quote β `term] : Quote (α × β) `term where
  quote
    | ⟨a, b⟩ => Syntax.mkCApp ``Prod.mk #[quote a, quote b]

private def quoteList [Quote α `term] : List α → Term
  | []      => mkCIdent ``List.nil
  | (x::xs) => Syntax.mkCApp ``List.cons #[quote x, quoteList xs]

instance [Quote α `term] : Quote (List α) `term where
  quote := quoteList

private def quoteArray [Quote α `term] (xs : Array α) : Term :=
  if xs.size <= 8 then
    go 0 #[]
  else
    Syntax.mkCApp ``List.toArray #[quote xs.toList]
where
  go (i : Nat) (args : Array Term) : Term :=
    if h : i < xs.size then
      go (i+1) (args.push (quote xs[i]))
    else
      Syntax.mkCApp (Name.mkStr2 "Array" ("mkArray" ++ toString xs.size)) args
termination_by go i _ => xs.size - i

instance [Quote α `term] : Quote (Array α) `term where
  quote := quoteArray

instance Option.hasQuote {α : Type} [Quote α `term] : Quote (Option α) `term where
  quote
    | none     => mkIdent ``none
    | (some x) => Syntax.mkCApp ``some #[quote x]

/-- Evaluator for `prec` DSL -/
def evalPrec (stx : Syntax) : MacroM Nat :=
  Macro.withIncRecDepth stx do
    let stx ← expandMacros stx
    match stx with
    | `(prec| $num:num) => return num.getNat
    | _ => Macro.throwErrorAt stx "unexpected precedence"

macro_rules
  | `(prec| $a + $b) => do `(prec| $(quote <| (← evalPrec a) + (← evalPrec b)):num)

macro_rules
  | `(prec| $a - $b) => do `(prec| $(quote <| (← evalPrec a) - (← evalPrec b)):num)

macro "eval_prec " p:prec:max : term => return quote (k := `term) (← evalPrec p)

/-- Evaluator for `prio` DSL -/
def evalPrio (stx : Syntax) : MacroM Nat :=
  Macro.withIncRecDepth stx do
    let stx ← expandMacros stx
    match stx with
    | `(prio| $num:num) => return num.getNat
    | _ => Macro.throwErrorAt stx "unexpected priority"

macro_rules
  | `(prio| $a + $b) => do `(prio| $(quote <| (← evalPrio a) + (← evalPrio b)):num)

macro_rules
  | `(prio| $a - $b) => do `(prio| $(quote <| (← evalPrio a) - (← evalPrio b)):num)

macro "eval_prio " p:prio:max : term => return quote (k := `term) (← evalPrio p)

def evalOptPrio : Option (TSyntax `prio) → MacroM Nat
  | some prio => evalPrio prio
  | none      => return 1000 -- TODO: FIX back eval_prio default

end Lean

namespace Array

abbrev getSepElems := @getEvenElems

open Lean

private partial def filterSepElemsMAux {m : Type → Type} [Monad m] (a : Array Syntax) (p : Syntax → m Bool) (i : Nat) (acc : Array Syntax) : m (Array Syntax) := do
  if h : i < a.size then
    let stx := a[i]
    if (← p stx) then
      if acc.isEmpty then
        filterSepElemsMAux a p (i+2) (acc.push stx)
      else if hz : i ≠ 0 then
        have : i.pred < i := Nat.pred_lt hz
        have : i.pred < a.size := Nat.lt_trans this h
        let sepStx := a[i.pred]
        filterSepElemsMAux a p (i+2) ((acc.push sepStx).push stx)
      else
        filterSepElemsMAux a p (i+2) (acc.push stx)
    else
      filterSepElemsMAux a p (i+2) acc
  else
    pure acc

def filterSepElemsM {m : Type → Type} [Monad m] (a : Array Syntax) (p : Syntax → m Bool) : m (Array Syntax) :=
  filterSepElemsMAux a p 0 #[]

def filterSepElems (a : Array Syntax) (p : Syntax → Bool) : Array Syntax :=
  Id.run <| a.filterSepElemsM p

private partial def mapSepElemsMAux {m : Type → Type} [Monad m] (a : Array Syntax) (f : Syntax → m Syntax) (i : Nat) (acc : Array Syntax) : m (Array Syntax) := do
  if h : i < a.size then
    let stx := a[i]
    if i % 2 == 0 then do
      let stx ← f stx
      mapSepElemsMAux a f (i+1) (acc.push stx)
    else
      mapSepElemsMAux a f (i+1) (acc.push stx)
  else
    pure acc

def mapSepElemsM {m : Type → Type} [Monad m] (a : Array Syntax) (f : Syntax → m Syntax) : m (Array Syntax) :=
  mapSepElemsMAux a f 0 #[]

def mapSepElems (a : Array Syntax) (f : Syntax → Syntax) : Array Syntax :=
  Id.run <| a.mapSepElemsM f

end Array

namespace Lean.Syntax

def SepArray.getElems (sa : SepArray sep) : Array Syntax :=
  sa.elemsAndSeps.getSepElems

def TSepArray.getElems (sa : TSepArray k sep) : TSyntaxArray k :=
  .mk sa.elemsAndSeps.getSepElems

def TSepArray.push (sa : TSepArray k sep) (e : TSyntax k) : TSepArray k sep :=
  if sa.elemsAndSeps.isEmpty then
    { elemsAndSeps := #[e] }
  else
    { elemsAndSeps := sa.elemsAndSeps.push (mkAtom sep) |>.push e }

instance : EmptyCollection (SepArray sep) where
  emptyCollection := ⟨∅⟩

instance : EmptyCollection (TSepArray sep k) where
  emptyCollection := ⟨∅⟩

instance : CoeOut (SepArray sep) (Array Syntax) where
  coe := SepArray.getElems

instance : CoeOut (TSepArray k sep) (TSyntaxArray k) where
  coe := TSepArray.getElems

instance [Coe (TSyntax k) (TSyntax k')] : Coe (TSyntaxArray k) (TSyntaxArray k') where
  coe a := a.map Coe.coe

instance : CoeOut (TSyntaxArray k) (Array Syntax) where
  coe a := a.raw

instance : Coe Ident (TSyntax `Lean.Parser.Command.declId) where
  coe id := mkNode _ #[id, mkNullNode #[]]

instance : Coe (Lean.Term) (Lean.TSyntax `Lean.Parser.Term.funBinder) where
  coe stx := ⟨stx⟩

end Lean.Syntax

set_option linter.unusedVariables.funArgs false in
/--
  Gadget for automatic parameter support. This is similar to the `optParam` gadget, but it uses
  the given tactic.
  Like `optParam`, this gadget only affects elaboration.
  For example, the tactic will *not* be invoked during type class resolution. -/
abbrev autoParam.{u} (α : Sort u) (tactic : Lean.Syntax) : Sort u := α

/-! # Helper functions for manipulating interpolated strings -/

namespace Lean.Syntax

private def decodeInterpStrQuotedChar (s : String) (i : String.Pos) : Option (Char × String.Pos) := do
  match decodeQuotedChar s i with
  | some r => some r
  | none   =>
    let c := s.get i
    let i := s.next i
    if c == '{' then pure ('{', i)
    else none

private partial def decodeInterpStrLit (s : String) : Option String :=
  let rec loop (i : String.Pos) (acc : String) : Option String :=
    let c := s.get i
    let i := s.next i
    if c == '\"' || c == '{' then
      pure acc
    else if s.atEnd i then
      none
    else if c == '\\' then do
      let (c, i) ← decodeInterpStrQuotedChar s i
      loop i (acc.push c)
    else
      loop i (acc.push c)
  loop ⟨1⟩ ""

partial def isInterpolatedStrLit? (stx : Syntax) : Option String :=
  match isLit? interpolatedStrLitKind stx with
  | none     => none
  | some val => decodeInterpStrLit val

def getSepArgs (stx : Syntax) : Array Syntax :=
  stx.getArgs.getSepElems

end Syntax

namespace TSyntax

def expandInterpolatedStrChunks (chunks : Array Syntax) (mkAppend : Syntax → Syntax → MacroM Syntax) (mkElem : Syntax → MacroM Syntax) : MacroM Syntax := do
  let mut i := 0
  let mut result := Syntax.missing
  for elem in chunks do
    let elem ← match elem.isInterpolatedStrLit? with
      | none     => mkElem elem
      | some str => mkElem (Syntax.mkStrLit str)
    if i == 0 then
      result := elem
    else
      result ← mkAppend result elem
    i := i+1
  return result

open TSyntax.Compat in
def expandInterpolatedStr (interpStr : TSyntax interpolatedStrKind) (type : Term) (toTypeFn : Term) : MacroM Term := do
  let r ← expandInterpolatedStrChunks interpStr.raw.getArgs (fun a b => `($a ++ $b)) (fun a => `($toTypeFn $a))
  `(($r : $type))

end TSyntax

namespace Meta

inductive TransparencyMode where
  | all | default | reducible | instances
  deriving Inhabited, BEq, Repr

inductive EtaStructMode where
  /-- Enable eta for structure and classes. -/
  | all
  /-- Enable eta only for structures that are not classes. -/
  | notClasses
  /-- Disable eta for structures and classes. -/
  | none
  deriving Inhabited, BEq, Repr

namespace DSimp

structure Config where
  zeta              : Bool := true
  beta              : Bool := true
  eta               : Bool := true
  etaStruct         : EtaStructMode := .all
  iota              : Bool := true
  proj              : Bool := true
  decide            : Bool := false
  autoUnfold        : Bool := false
  deriving Inhabited, BEq, Repr

end DSimp

namespace Simp

def defaultMaxSteps := 100000

structure Config where
  maxSteps          : Nat  := defaultMaxSteps
  maxDischargeDepth : Nat  := 2
  contextual        : Bool := false
  memoize           : Bool := true
  singlePass        : Bool := false
  zeta              : Bool := true
  beta              : Bool := true
  eta               : Bool := true
  etaStruct         : EtaStructMode := .all
  iota              : Bool := true
  proj              : Bool := true
  decide            : Bool := true
  arith             : Bool := false
  autoUnfold        : Bool := false
  /--
    If `dsimp := true`, then switches to `dsimp` on dependent arguments where there is no congruence theorem that allows
    `simp` to visit them. If `dsimp := false`, then argument is not visited.
  -/
  dsimp             : Bool := true
  deriving Inhabited, BEq, Repr

-- Configuration object for `simp_all`
structure ConfigCtx extends Config where
  contextual := true

def neutralConfig : Simp.Config := {
  zeta              := false
  beta              := false
  eta               := false
  iota              := false
  proj              := false
  decide            := false
  arith             := false
  autoUnfold        := false
}

end Simp

namespace Rewrite

structure Config where
  transparency : TransparencyMode := TransparencyMode.reducible
  offsetCnstrs : Bool := true

end Rewrite

end Meta

namespace Parser.Tactic

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

syntax simpAllKind := atomic("(" &"all") " := " &"true" ")"
syntax dsimpKind   := atomic("(" &"dsimp") " := " &"true" ")"

macro (name := declareSimpLikeTactic) doc?:(docComment)? "declare_simp_like_tactic" opt:((simpAllKind <|> dsimpKind)?) tacName:ident tacToken:str updateCfg:term : command => do
  let (kind, tkn, stx) ←
    if opt.raw.isNone then
      pure (← `(``simp), ← `("simp"), ← `($[$doc?:docComment]? syntax (name := $tacName) $tacToken:str (config)? (discharger)? (&" only")? (" [" (simpStar <|> simpErase <|> simpLemma),* "]")? (location)? : tactic))
    else if opt.raw[0].getKind == ``simpAllKind then
      pure (← `(``simpAll), ← `("simp_all"), ← `($[$doc?:docComment]? syntax (name := $tacName) $tacToken:str (config)? (discharger)? (&" only")? (" [" (simpErase <|> simpLemma),* "]")? : tactic))
    else
      pure (← `(``dsimp), ← `("dsimp"), ← `($[$doc?:docComment]? syntax (name := $tacName) $tacToken:str (config)? (discharger)? (&" only")? (" [" (simpErase <|> simpLemma),* "]")? (location)? : tactic))
  `($stx:command
    @[macro $tacName] def expandSimp : Macro := fun s => do
      let c ← match s[1][0] with
        | `(config| (config := $$c)) => `(config| (config := $updateCfg $$c))
        | _ => `(config| (config := $updateCfg {}))
      let s := s.setKind $kind
      let s := s.setArg 0 (mkAtomFrom s[0] $tkn (canonical := true))
      let r := s.setArg 1 (mkNullNode #[c])
      return r)

/-- `simp!` is shorthand for `simp` with `autoUnfold := true`.
This will rewrite with all equation lemmas, which can be used to
partially evaluate many definitions. -/
declare_simp_like_tactic simpAutoUnfold "simp! " fun (c : Lean.Meta.Simp.Config) => { c with autoUnfold := true }

/-- `simp_arith` is shorthand for `simp` with `arith := true`.
This enables the use of normalization by linear arithmetic. -/
declare_simp_like_tactic simpArith "simp_arith " fun (c : Lean.Meta.Simp.Config) => { c with arith := true }

/-- `simp_arith!` is shorthand for `simp_arith` with `autoUnfold := true`.
This will rewrite with all equation lemmas, which can be used to
partially evaluate many definitions. -/
declare_simp_like_tactic simpArithAutoUnfold "simp_arith! " fun (c : Lean.Meta.Simp.Config) => { c with arith := true, autoUnfold := true }

/-- `simp_all!` is shorthand for `simp_all` with `autoUnfold := true`.
This will rewrite with all equation lemmas, which can be used to
partially evaluate many definitions. -/
declare_simp_like_tactic (all := true) simpAllAutoUnfold "simp_all! " fun (c : Lean.Meta.Simp.ConfigCtx) => { c with autoUnfold := true }

/-- `simp_all_arith` combines the effects of `simp_all` and `simp_arith`. -/
declare_simp_like_tactic (all := true) simpAllArith "simp_all_arith " fun (c : Lean.Meta.Simp.ConfigCtx) => { c with arith := true }

/-- `simp_all_arith!` combines the effects of `simp_all`, `simp_arith` and `simp!`. -/
declare_simp_like_tactic (all := true) simpAllArithAutoUnfold "simp_all_arith! " fun (c : Lean.Meta.Simp.ConfigCtx) => { c with arith := true, autoUnfold := true }

/-- `dsimp!` is shorthand for `dsimp` with `autoUnfold := true`.
This will rewrite with all equation lemmas, which can be used to
partially evaluate many definitions. -/
declare_simp_like_tactic (dsimp := true) dsimpAutoUnfold "dsimp! " fun (c : Lean.Meta.DSimp.Config) => { c with autoUnfold := true }

end Parser.Tactic

end Lean


-- TODO:
-- * Derive handler
-- * test
-- * cleanup code
-- * add argument type to usage string

import Lean.Elab.AuxDef
import Lean.Elab.BindersUtil
import Lean.Elab.Deriving.Basic
import Lean.Elab.Deriving.Util
import Lean.Elab.MacroArgUtil
import Lean.Elab.Quotation.Precheck
import Lean.Elab.Term

import Lean.Parser.Term
import Lean.PrettyPrinter.Delaborator.Basic

import Lean.Parser.Term
import Lean.Meta.Closure
import Lean.Meta.Check
import Lean.Elab.Command
import Lean.Elab.DefView
import Lean.Elab.PreDefinition
import Lean.Elab.DeclarationRange

import Std.Data.HashMap

import CLI.Format

open Lean Lean.Meta

class CLIArg (α : Type u) where
  typeName : String
  parse : String → Option α

def parseArg (α) [CLIArg α] : String → Option α :=
CLIArg.parse

instance : CLIArg String where
  typeName := "STRING"
  parse := some

instance : CLIArg Nat where
  typeName := "NAT"
  parse := String.toNat?

inductive StreamReader (α : Type u) (β : Type v) where
  | read (f : α → StreamReader α β) : StreamReader α β
  | pure : β → StreamReader α β
  | error : String → StreamReader α β

class CLIArgRecord (α : Type u) where
  init : α
  parse : String → α → Option (StreamReader String α)
  usageString : String

@[simp]
theorem measure_foo (f : α → Nat) :
  (measure f).1 x y ↔ f x < f y := Iff.rfl

@[simp]
theorem dec_double (x k : Nat) :
  x < x + k ↔ 0 < k := sorry

@[simp]
theorem dec_double''' (i j : Nat) :
  x + i.succ + j = x + i + j.succ := sorry

@[simp]
theorem dec_double'' (i j : Nat) :
  x + i < x + j ↔ i < j := sorry

@[simp]
theorem dec_double' (x y : Nat) :
  x * y.succ = x*y + x := sorry

mutual

variable (α : Type) [CLIArgRecord α]
variable (interspersedArgs : Bool)

@[inline]
def parseArgsFeed (acc : List String)
    (args : List String)
     : StreamReader String α →
       Except String (α × Array String)
| StreamReader.pure x' => parseArgsAux acc x' args
| StreamReader.error msg => Except.error msg
| StreamReader.read f =>
  match args with
  | [] => Except.error "expecting more arguments"
  | y::ys => parseArgsFeed acc ys (f y)

@[inline]
def parseArgsAux (acc : List String) (x : α)
     : List String →
  Except String (α × Array String)
| [] => pure (x, acc.reverse.toArray)
| y :: ys =>
  match CLIArgRecord.parse y x with
  | none =>
    if interspersedArgs
    then parseArgsAux (y :: acc) x ys
    else pure (x, (acc.reverse ++ y :: ys).toArray)
  | some r =>
    parseArgsFeed acc ys r

end

termination_by
  parseArgsFeed x _ => (2 * x.length) + 1
  parseArgsAux x => 2 * x.length
decreasing_by simp [InvImage, WellFoundedRelation.rel, sizeOf]

@[specialize]
def parseArgs (α : Type) [CLIArgRecord α]
    (args : Array String) (interspersedArgs : Bool) :
  Except String (α × Array String) :=
parseArgsAux α
  interspersedArgs [] CLIArgRecord.init args.toList

def LeftOvers (α : Type) (allowed : Bool) :=
  cond allowed (α × Array String) α

instance [Repr α] {allowed} : Repr (LeftOvers α allowed) :=
match allowed with
| true => inferInstanceAs (Repr (α × Array String))
| false => inferInstanceAs (Repr α)

def processCmdLine  (α : Type) [CLIArgRecord α]
    (args : Array String)
    (interspersedArgs := false)
    (allowLeftOvers := false) :
  IO (LeftOvers α allowLeftOvers) := do
let (r, ar) ←
  match parseArgs α args interspersedArgs with
  | Except.error msg =>
    throw <| IO.userError
      <| s!"{msg}\n\n{CLIArgRecord.usageString α}"
  | Except.ok (r, ar) => pure (r, ar)
match allowLeftOvers with
| true => return (r, ar)
| false =>
  if ar.isEmpty then return r
  else throw
      <| IO.userError
      <| s!"Excess arguments: {ar}\n\n{CLIArgRecord.usageString α}"

abbrev CmdLineFlag (short : String) (long : Option String) (descr : String) := Bool

abbrev CmdLineOpt (short : String) (long : Option String) (t : Type) [CLIArg t]
  (descr : String) := Option t

structure Flags where
  traceCmd :
    CmdLineFlag "-c" (some "--cmd")
    "tracing: print command"
  traceSubst :
    CmdLineFlag "-s" none
    "tracing: print module renaming"
  traceRoot :
    CmdLineFlag "-r" none
    "tracing: print command"
  optValue :
    CmdLineOpt "-t" none Nat
    "tracing: test option parsing"
  dryRun :
    CmdLineFlag "-d" none
    "dry run: calculate parameters but perform no action"
  forward : Array String := #[]
                           -- array of -f, -i, -n, -v, -k
  deriving Repr, Inhabited

namespace CLI
open Lean

def instantiateBVarAux (i : Nat) (vs : List Expr) (e : Expr) :
  Expr :=
if e.looseBVarRange > 0 then e else
  match e with
  | Expr.forallE n d b data =>
    Expr.forallE n
      (instantiateBVarAux i vs d)
      (instantiateBVarAux (i+1) vs b) data
  | Expr.lam n d b data     =>
    Expr.lam n
      (instantiateBVarAux i vs d)
      (instantiateBVarAux (i+1) vs b) data
  | Expr.mdata m e d        =>
    Expr.mdata m (instantiateBVarAux i vs e) d
  | Expr.letE n t v b data  =>
    Expr.letE n
      (instantiateBVarAux i vs t)
      (instantiateBVarAux i vs v)
      (instantiateBVarAux (i+1) vs b) data
  | Expr.app f a data       =>
    Expr.app
      (instantiateBVarAux i vs f)
      (instantiateBVarAux i vs a)
      data
  | Expr.proj r j e data    =>
    Expr.proj r j (instantiateBVarAux i vs e) data
  | e@(Expr.bvar j _)  => vs.getD (j - i) e
  | e                       => e

def instantiateBVar (vs : List Expr) (e : Expr) : Expr :=
instantiateBVarAux 0 vs e

def mkFieldTypeAux (vs : List Expr) (s' : Name) :
  Expr → MetaM (List Expr × Expr)
| Expr.forallE n d b _  =>
  Lean.Meta.withLocalDeclD n d λ v =>
    if d.isConstOf s'
    then return (v :: vs, instantiateBVar (v :: vs) b)
    else mkFieldTypeAux (v :: vs) s' b
| e => return (vs, e)

def mkFieldType : Name → Expr → MetaM (List Expr × Expr) :=
mkFieldTypeAux []

def typeOfField' (s field : Name) : OptionT MetaM Expr := do
let env ← getEnv
let s' ← liftOption <| findField? env s field
let info ← liftOption <| getFieldInfo? env s' field
let d ← liftOption <| env.find? info.projFn
let t := d.type
Prod.snd <$> mkFieldType s' t

def typeOfField (s field : Name) : MetaM Expr := do
let some a ← typeOfField' s field |>.run
    | throwError "cannot infer field type of {s}.{field}"
return a

def getFieldInfo' (s field : Name) : OptionT MetaM StructureFieldInfo := do
let env ← getEnv
let s' ← liftOption <| findField? env s field
liftOption <| getFieldInfo? env s' field

def getFieldInfo! (s field : Name) : MetaM StructureFieldInfo := do
let some a ← getFieldInfo' s field |>.run
    | throwError "cannot find field info for {s}.{field}"
return a

structure FlagDescr where
  field : Name
  projection : Name
  shortOpt : String
  longOpt : Option String
  optType : Option Syntax
  description : String
  deriving Repr, Inhabited

def parseStringLit [Monad m] [MonadError m] (s : Syntax) :
  m String := do
  let some x := Syntax.isStrLit? s
    | throwError "expecting string literal {s}"
  return x

def parseShortOpt [Monad m] [MonadError m]
    (s : Syntax) : m String := do
  let x ← parseStringLit s
  unless ("-".isPrefixOf x ∧ x.length = 2) do
    throwError "invalid short option '{x}'"
  return x

def parseLongOpt [Monad m] [MonadError m] :
  Syntax → m (Option String)
| `(none) => pure none
| `(some $x) => do
  let x ← parseStringLit x
  unless ("--".isPrefixOf x ∧ x.length > 2) do
    throwError "invalid long option '{x}'"
  return some x
| e => throwError "Expecting a literal string: {e}"

open Lean.Elab.Term

def mkFlagDescr (struct field : Name) :
  TermElabM (Option FlagDescr) := do
let t ← typeOfField struct field
let proj := (← getFieldInfo! struct field).projFn
let s ← Lean.PrettyPrinter.delab t
match s with
| `(CmdLineFlag $x $y $descr) =>
  return some {
    field := field,
    projection := proj,
    shortOpt := ← parseShortOpt x,
    longOpt := ← parseLongOpt y,
    optType := none,
    description := ← parseStringLit descr : FlagDescr }
| `(CmdLineOpt $x $y $t $descr) =>
  return some {
    field := field,
    projection := proj,
    shortOpt := ← parseShortOpt x,
    longOpt := ← parseLongOpt y,
    optType := some t,
    description := ← parseStringLit descr : FlagDescr }
| _ => return none

section

open Lean.Meta
open Lean Parser Term Elab Term

def optionParsingFailure (x : String) :
  Option (StreamReader String α) :=
if "-".isPrefixOf x then
  some <| StreamReader.error s!"Invalid option: {x}"
else
  none

def mkOptParser (arg₀ obj : Syntax)
                (flag : FlagDescr) :
    TermElabM Syntax :=
withFreshMacroScope do
  let field := mkIdent flag.field
  let proj := mkIdent flag.projection
  let flagString :=
    match flag.longOpt with
    | some opt =>  opt
    | none =>  flag.shortOpt
  let parsingErrorMsg :=
    s!"Flag {flagString} requires an argument of type "
  let parsingErrorMsg := Syntax.mkStrLit parsingErrorMsg
  let redundantOptMsg :=
    s!"Flag {flagString} should be provided only once"
  let redundantOptMsg := Syntax.mkStrLit redundantOptMsg
  if let some type := flag.optType then
    let successCode ← `(StreamReader.pure
           { $obj with $field:ident := some val } )
    let errorCode ← `(StreamReader.error <|
        $parsingErrorMsg ++ CLIArg.typeName $type)
    let redundantOpt ← `(StreamReader.error <| $redundantOptMsg)
    let br1 ← `(matchAltExpr| | none => $errorCode)
    let br2 ← `(matchAltExpr| | some val => $successCode)
    let brs := #[br1, br2]
    let discr ← `(parseArg $type arg₁)
    let body ← `(match $discr:term with $brs:matchAlt*)
    let parseArg ← `(StreamReader.read λ arg₁ => $body)
    `(some <| if ($proj $obj).isNone
              then $parseArg
              else $redundantOpt )
  else
    `(some <| StreamReader.pure
        { $obj with $field:ident := true } )

end

/--
Generate a function

def MyStruct.parseArg (s : String) (x : MyStruct) : Option MyStruct := ...

Note: this is broken because I don't know how to create
and elaborate a syntax object of the form `{x with foo := 7}`
-/
def mkArgParserAux
  -- [Monad m] [MonadRef m] [MonadQuotation m]
  (type : Name) (arg obj : Syntax) :
  List FlagDescr → TermElabM Syntax
| [] => `(optionParsingFailure $arg)
| flag :: fs => do
  let code ← mkArgParserAux type arg obj fs
  let field := mkIdent flag.field
  let thenBr ← mkOptParser arg obj flag
  let elseBr ←
    if let some longOpt := flag.longOpt then
      `(if $arg = $(Syntax.mkStrLit longOpt)
        then $thenBr
        else $code )
    else pure code
  `(if $arg = $(Syntax.mkStrLit flag.shortOpt)
    then $thenBr
    else $elseBr)

def addDef (n : Name) (t : Expr) (d : Expr) : MetaM Name := do
let t ← instantiateMVars t
let d ← instantiateMVars d
addAndCompile
  <| Declaration.defnDecl
  <| DefinitionVal.mk
    (ConstantVal.mk n [] t) d
    (ReducibilityHints.regular 10)
    DefinitionSafety.safe
return n

def mkArgParser (type : Name)
  (flags : List FlagDescr) : TermElabM Name :=
let n := type.mkStr "parseArg"
withDeclName n do
withFreshMacroScope do
  let arg ← `(arg)
  let obj ← `(obj)
  let b ← mkArgParserAux type arg obj flags
  let type' := mkIdent type
  let t ← Elab.Term.elabTerm
      (← `(String → $type' →
           Option (StreamReader String $type'))) none
  let d ← withDeclName n <| Elab.Term.elabTerm
    (← `(λ ($arg : String)
           ($obj : $type') => $b))
    (some t)
  addDef n t d

open Lean.Parser.Term
open Lean.Elab Term Meta

def mkInitAux (type : Name)
  (flags : List FlagDescr) : TermElabM Syntax := do
let fieldInits := flags.toArray
let fieldInits ← fieldInits.mapM λ fl => do
  let field := mkIdent fl.field
  let val ←
    if fl.optType.isSome then `(none)
    else `(false)
  `(structInstField| $field:ident := $val )
`({ $[$fieldInits,]* : $(mkIdent type) })

def mkInitialization (type : Name)
  (flags : List FlagDescr) : TermElabM Name :=
let n := type.mkStr "init"
withDeclName n do
withFreshMacroScope do
  let t := Lean.mkConst type
  let d ← withDeclName n <| Elab.Term.elabTerm
    (← mkInitAux type flags)
    (some t)
  addDef n t d

-- #check ConstantInfo
open Std

section UsageString

open Document.Table
open Document.Paragraph

def mkUsageString' (flags : List FlagDescr) : String :=
let t := flags.map λ fl =>
  (#[rightAlign fl.shortOpt,
     leftAlign <| fl.longOpt.getD ""],
   fl.description)
let descrWidth := 60
let t := t.map <| Prod.map id <| wrapParagraph descrWidth
let empty := leftAlign ""
let t := t.bind λ
  | (a,[]) => [a.push <| empty]
  | (a,l::ls) =>
    a.push (leftAlign l) ::
    ls.map (#[empty,empty].push ∘ leftAlign)
let t :=
  #[leftAlign "Flags", empty, leftAlign "Description"] ::
  t
renderTable t

def mkUsageString (struct : Name)
    (flags : List FlagDescr) : MetaM Name := do
let usage := mkUsageString' flags
let n := struct.mkStr "usageString"
let t ← mkConstWithLevelParams ``String
let e := mkStrLit usage
println!"name: {n}"
addDef n t e

end UsageString

def elabCLIArgRecordInst (struct : Name)
    (init parser usage : Syntax) :
  TermElabM (Expr × Expr) := do
let t ← elabTerm (← `(CLIArgRecord $(mkIdent struct))) none
let e ← elabTerm
  (← `( { init := $init,
          parse := $parser,
          usageString := $usage } ))
  (some t)
return (t, e)

def mkCLIArgRecordInst' (struct : Name)
    (flags : List FlagDescr) : TermElabM Name := do
let usage := mkIdent (← mkUsageString struct flags)
let parser := mkIdent (← mkArgParser struct flags)
let init := mkIdent (← mkInitialization struct flags)
let (t, e) ← elabCLIArgRecordInst struct init parser usage
let n := struct.mkStr "instCLIArgRecord"
addDef n t e

def mkCLIArgRecordInst (struct : Name) : TermElabM Name :=
withDeclName struct do
let env ← getEnv
let fields := getStructureFieldsFlattened env struct
let flags ← fields.toList.filterMapM <| mkFlagDescr struct
let inst ← mkCLIArgRecordInst' struct flags
addInstance inst AttributeKind.«global» 0
return inst

def test : MetaM Unit := do
let env ← getEnv
let struct := ``Flags
IO.println <| (← mkCLIArgRecordInst struct |>.run')
IO.println <| repr struct

-- #eval mkCLIArgRecordInst ``Flags
#eval test

-- #check Flags.usageString
-- #check Flags.parseArg

-- instance : CLIArgRecord Flags where
--   init := {}
--   parse := Flags.parseArg
--   usageString :=  Flags.usageString
namespace Derive
open Lean.Elab.Command

def mkCLIArgRecordInstanceHandler' : Array Name → CommandElabM Bool
| #[t] => do
  -- println! "foo"
  -- liftTermElabM none <| discard <| mkCLIArgRecordInst t
  return true
| _ => do
  -- throwError "Mutually inductive types not supported"
  return false

def mkCLIArgRecordInstanceHandler : Array Name → CommandElabM Bool
| #[t] => do
  return true
| _ => do
  return true

builtin_initialize
  Lean.Elab.registerBuiltinDerivingHandler `CLIArgRecord
    mkCLIArgRecordInstanceHandler

-- structure Foo where
--   field1 := false
--   deriving CLIArgRecord

end Derive

#eval parseArgs Flags #["-d", "a", "-r", "-t", "3", "z"] false

#eval processCmdLine Flags #["-d", "a", "-r", "-t", "3"] true true
-- #eval parseArgsUnordered Flags #["--cmd", "a", "-r"]

end CLI


-- Trying to reproduce a bug with $(..) within a large syntax object
import Lean.Parser
import Lean.Parser.Extra

open Lean
open Lean.Parser

-- | TODO: factor Symbol out from AttrVal
inductive AttrVal : Type where
| str : String -> AttrVal

inductive AttrEntry : Type where
  | mk: (key: String)
      -> (value: AttrVal)
      -> AttrEntry

declare_syntax_cat mlir_attr_val
syntax str: mlir_attr_val
syntax "[mlir_attr_val|" incQuotDepth(mlir_attr_val) "]" : term

macro_rules
| `([mlir_attr_val| $$($x) ]) => `($x)
| `([mlir_attr_val| $s:strLit]) => `(AttrVal.str $s)

-- Attribute Entries
declare_syntax_cat mlir_attr_entry

syntax strLit "=" mlir_attr_val : mlir_attr_entry
syntax "[mlir_attr_entry|" incQuotDepth(mlir_attr_entry) "]" : term

macro_rules
  | `([mlir_attr_entry| $name:strLit  = $v:mlir_attr_val]) =>
     `(AttrEntry.mk $name [mlir_attr_val| $v])

def attrVal0Str : AttrVal := [mlir_attr_val| "add"]
#reduce attrVal0Str

def attrVal1Escape : AttrVal := [mlir_attr_val| $(attrVal0Str)]
#reduce attrVal1Escape

def AttrEntry0Str : AttrEntry := [mlir_attr_entry| "sym_name" = "add"]
#reduce AttrEntry0Str

-- vv example SHOULD NOT FAIL?
def AttrEntry1Escape : AttrEntry := [mlir_attr_entry| "sym_name" = $(attrVal0Str)]
#reduce AttrEntry1Escape

declare_syntax_cat inner
declare_syntax_cat outer

syntax "<[" inner "]>" : outer

syntax "[inner|" incQuotDepth(inner) "]" : term
macro_rules
| `([inner| $$($s)]) => return s

syntax "[outer|" outer "]" : term
macro_rules
| `([outer| <[ $k:inner ]> ]) => `([inner| $k])

syntax "[outerIncQuotDepth|" incQuotDepth(outer) "]" : term
macro_rules
| `([outerIncQuotDepth|  <[ $k:inner ]> ]) => `([inner| $k])

def g := "global string"

def innerQuot := [inner| $(g) ]
def outerIncQuotDepth := [outerIncQuotDepth| <[ $(g) ]> ]
-- I would expect `outerDoesNotWork` to work, because the quoting comes from inner, not outer!
def outerDoesNotWork := [outer| <[ $(g) ]> ]


import Lean
import Lean.Meta
import LeanCodePrompts.CheckParse
import LeanCodePrompts.ParseJson
import Mathlib.Mathport.Rename

open Lean Meta Elab

partial def camelSplitAux (s : String)(accum: List String) : List String :=
  if s.length == 0 then accum
  else
    let head := s.decapitalize.takeWhile (fun c => 'a' ≤ c)
    if head.length = 0 then accum ++ [s]
    else
      let tail := s.drop (head.length)
      camelSplitAux tail (accum ++ [head])

def camelSplit(s : String) : List String :=
  camelSplitAux s []

-- #eval camelSplit "CamelCaseWord"

def fullSplit (s : String) : List String :=
  let parts := s.splitOn "_"
  parts.bind (fun s => camelSplit s)

-- #eval fullSplit "CamelCaseWord"
-- #eval fullSplit "snake_caseBut_wordWithCamel"

initialize caseNameCache : IO.Ref (HashMap String String)
  ← IO.mkRef (HashMap.empty)

-- initialize xNameCache : IO.Ref (HashMap String String)
--   ← IO.mkRef (HashMap.empty)

-- initialize xxNameCache : IO.Ref (HashMap String String)
--   ← IO.mkRef (HashMap.empty)

initialize dotNameCache : IO.Ref (HashMap String String)
  ← IO.mkRef (HashMap.empty)

initialize binNamesCache : IO.Ref (Array String) ← IO.mkRef (#[])

initialize binNameMapCache : IO.Ref (HashMap (List String) String)
  ← IO.mkRef (HashMap.empty)

initialize binNameNoIsMapCache : IO.Ref (HashMap (List String) String)
  ← IO.mkRef (HashMap.empty)

initialize elabPromptsCache : IO.Ref (HashSet String) ← IO.mkRef (HashSet.empty)

def caseNames : MetaM (HashMap String String) := do
  let cache ← caseNameCache.get
  if cache.isEmpty then
      let jsBlob ←
        IO.FS.readFile (← reroutePath <| System.mkFilePath ["data", "case_dictionary.json"])
      let json ← readJson jsBlob
      match json.getArr? with
      | Except.error e => throwError e
      | Except.ok arr => do
        let mut m : HashMap String String := HashMap.empty
        for js in arr do
          let snakeCase? :=
            (js.getObjVal? "snakecase").toOption.bind (fun s =>
                s.getStr?.toOption)
          let camelCase? :=
            (js.getObjVal? "camelcase").toOption.bind (fun s =>
                s.getStr?.toOption)
          m := match (snakeCase?, camelCase?) with
            | (some sc, some cc) =>  m.insert sc cc
            | _ =>  m
        caseNameCache.set m
        return m
  else return cache

-- def xNames : MetaM (HashMap String String) := do
--   let cache ← xNameCache.get
--   if cache.isEmpty then
--       let lines ←
--         IO.FS.lines (← reroutePath <| System.mkFilePath ["data", "x_names.txt"])
--       let mut m : HashMap String String := HashMap.empty
--       for xname in lines do
--         m := m.insert (xname.dropRight 1) xname
--       xNameCache.set m
--       return m
--   else return cache

-- def xxNames : MetaM (HashMap String String) := do
--   let cache ← xxNameCache.get
--   if cache.isEmpty then
--       let lines ←
--         IO.FS.lines (← reroutePath <| System.mkFilePath ["data", "xx_names.txt"])
--       let mut m : HashMap String String := HashMap.empty
--       for xxname in lines do
--         m := m.insert (xxname.dropRight 2) xxname
--       xxNameCache.set m
--       return m
--   else return cache

def dotNames : MetaM (HashMap String String) := do
  let cache ← dotNameCache.get
  if cache.isEmpty then
      let lines ←
        IO.FS.lines (← reroutePath <| System.mkFilePath ["data", "simple_dot_names.txt"])
      let mut m : HashMap String String := HashMap.empty
      for name in lines do
        m := m.insert (name.toLower) name
      dotNameCache.set m
      return m
  else return cache

def caseName?(s: String) : MetaM (Option String) := do
  let cache ← caseNames
  return cache.find? s

-- def xName?(s: String) : MetaM (Option String) := do
--   let cache ← xNames
--   return cache.find? s

-- def xxName?(s: String) : MetaM (Option String) := do
--   let cache ← xxNames
--   return cache.find? s

def dotName?(s: String) : MetaM (Option String) := do
match s.splitOn "." with
| [head, field] =>
  if head.length ≤ 2 then
    let cache ← dotNames
    return cache.find? field |>.map (fun s => head ++ "." ++ s)
  else return none
| _ => return none

def binNames : IO (Array String) := do
  let cacheStr ← binNamesCache.get
  if cacheStr.size > 0 then
    return cacheStr
  else
    let all ←
      IO.FS.lines (← reroutePath <| System.mkFilePath ["data", "binport_names.txt"])
    let filtered := all.filter (fun s => s.length > 0)
    let filtered := filtered.toList
    binNamesCache.set filtered.toArray
    return all.filter (fun s => !(s.contains  '.'))

def binNameMap : IO (HashMap (List String) String) := do
  let cacheMap ← binNameMapCache.get
  if cacheMap.isEmpty then
    let names ← binNames
    let res := names.foldl
      (fun m s => m.insert (fullSplit s) s) (HashMap.empty)
    binNameMapCache.set res
    return res
  else
    return cacheMap

def elabPrompts : IO (HashSet String) := do
  let cacheStr ← elabPromptsCache.get
  if !cacheStr.isEmpty then
    return cacheStr
  else
    let arr ←
      IO.FS.lines (←
       reroutePath <| System.mkFilePath ["data", "elab_thms.txt"])
    return arr.foldl (fun acc n => acc.insert n) HashSet.empty

def isElabPrompt(s: String) : IO Bool := do
  let prompts ← elabPrompts
  return prompts.contains s

def withoutIs? : List String → Option (List String)
| x :: ys =>
  if x = "is" || x = "has" then some ys else none
| [] => none

def binNameNoIsMap : IO (HashMap (List String) String) := do
  let cacheMap ← binNameNoIsMapCache.get
  if cacheMap.isEmpty then
    let names ← binNames
    let res := names.foldl
      (fun m s =>
        match withoutIs? (fullSplit s) with
        | some ys => m.insert ys s
        | none => m
          ) (HashMap.empty)
    binNameNoIsMapCache.set res
    return res
  else
    return cacheMap

def binName?(s : String) : MetaM <| Option String := do
  let map ← binNameMap
  let mapNoIs ← binNameNoIsMap
  let split := fullSplit s
  let splitNoIs? := withoutIs? split
  let res := ((map.find? split).orElse
              (fun _ => mapNoIs.find? split)).orElse
              (fun _ => splitNoIs?.bind (
                  fun splitNoIs => map.find? splitNoIs))
  return res

def lean4Name?(s: String) : MetaM (Option String) := do
  let m := Mathlib.Prelude.Rename.getRenameMap (← getEnv)
  return m.find? s |>.map (fun (_, name) => name.toString)

def caseOrBinName?(s : String) : MetaM (Option String) := do
  match ← lean4Name? s with
  | some name => return some name
  | none => do
    let res ← caseName? s
    if res.isNone then do
      let res ← binName? s
      return res
    else return res

-- #eval lean4Name? "has_abs"

def identErr (err: String) : Option String :=
  let head := "unknown identifier '"
  let tail := "' (during elaboration)"
  if err.startsWith head && err.endsWith tail then
    some <| (err.drop (head.length)).dropRight (tail.length)
  else
    none

def identCorrection(s err: String) : MetaM (Option String) := do
  match identErr err with
  | none => return none
  | some id => match ←  binName? id with
    | none => return none
    | some name => return some (s.replace id name)

/-- identifier substrings -/
partial def identSubs : Syntax → List Substring
| Syntax.ident _ s .. => [s]
| Syntax.node _ _ ss => ss.toList.bind identSubs
| _ => []

partial def extractByteAux (s: String) (start stop : String.Pos) (accum: String)
    := if start ≥  stop then accum else
        let h := s.get start
        extractByteAux s (s.next start) stop (accum ++ h.toString)

def extractBytes (s: String) (start stop : String.Pos) :=
      extractByteAux s start stop ""

def interleaveAux (full: Substring)(cursor: String.Pos)
  (accum: List (Substring × Substring))(idents: List Substring) :
      (List (Substring × Substring)) × Substring :=
  match idents with
  | [] => (accum, full.extract cursor full.stopPos)
  | h :: ts =>
      let pred := full.extract cursor h.startPos
      interleaveAux full (h.stopPos)
          (accum ++ [(pred, h)]) ts

def interLeave(full: Substring)(idents: List Substring) :
      (List (Substring × Substring)) × Substring :=
          interleaveAux full 0 [] idents

/-- given a string expected to be a *theorem statement* such as `{A: Type} (a : A) : P a`, transforms to one of the type `{A: Type} → (a : A) → P a`, parses this as a term and returns segments and a tail, with each segment a pair with the second part an identifier and the first an identifier-free part preceding it. -/
def identThmSegments (s : String)(opens: List String := [])
  : MetaM <| Except String ((Array (String × String)) × String) := do
  let env ← getEnv
  let chk := Lean.Parser.runParserCategory env `thmStat  s
  match chk with
  | Except.ok stx  =>
      match stx with
      | `(thmStat|$_: docComment theorem  $args:argument* : $type:term) =>
        identsAux type args
      | `(thmStat|$vars:argument* $_: docComment theorem $args:argument* : $type:term) =>
        identsAux type (vars ++ args)
      | `(thmStat|theorem $_ $args:argument* : $type:term) =>
        identsAux type args
      | `(thmStat|def $_ $args:argument* : $type:term) =>
        identsAux type args
      | `(thmStat|$args:argument* : $type:term) =>
        identsAux type args
      | _ => return Except.error "not a theorem statement"
  | Except.error _  => return Except.error "not a theorem statement"
  where identsAux (type: Syntax)(args: Array Syntax) :
        MetaM <| Except String ((Array (String × String)) × String) := do
        let header := if opens.isEmpty then "" else
          (opens.foldl (fun acc s => acc ++ " " ++ s) "open ") ++ " in "
        let mut argS := ""
        for arg in args do
          argS := argS ++ (showSyntax arg) ++ " -> "
        let funTypeStr := s!"{header}{argS}{showSyntax type}"

        match Lean.Parser.runParserCategory (← getEnv) `term funTypeStr with
        | Except.ok termStx =>
              let mut fullString := funTypeStr
              let mut segments : Array (String × String) := #[]
              let mut cursor : String.Pos := 0
              let res := identSubs termStx
              for ss in res do
                fullString := ss.str
                let pred := fullString.extract cursor ss.startPos
                segments := segments.push (pred, ss.toString)
                cursor := ss.stopPos
              let tail := fullString.extract cursor fullString.endPos
              return Except.ok (segments, tail)
        | Except.error e => return Except.error e

def transformBuild (segs: (Array (String × String)) × String)
        (transf : String → MetaM (Option String)) : MetaM (String) := do
        let (pairs, tail) := segs
        let res : Array (String × String) ←
          pairs.mapM (fun (pred, ident) => do
            let ident'? ← transf ident
            let ident' := ident'?.getD ident
            return (pred, ident'))
        let out : String :=
          res.foldr (fun (init, ident) acc => (init ++ ident ++ acc)) tail
        return out

/-- given a string like `{A: Type} → (a : A) → P a` broken up into identifiers and intermediate segments, transforms this by translating identifiers using a given one-one and a given one-many transformation and returns corresponding lists of segments -/
def polyTransform (pairs: (List (String × String)))
        (transf : String → MetaM (Option String))
        (extraTransf : List (String → MetaM (Option String))) :
            MetaM (List (List (String × String))) := do
        match pairs with
        | [] => return [[]]
        | h :: ts =>
          let (pred, ident) := h
          let ident' :=  (← transf ident).getD ident
          let extraIdents ←
              extraTransf.filterMapM (fun f => f ident')
          let h' := (ident' :: extraIdents).map ((pred, .))
          let prev ← polyTransform ts  transf extraTransf
          return h'.bind (fun x => prev.map (x :: .))

/-- given a string like `{A: Type} → (a : A) → P a` broken up into identifiers and intermediate segments, transforms this by translating identifiers using a given one-one and a given one-many transformation and builds strings from the results -/
def polyTransformBuild (segs: (Array (String × String)) × String)
        (transf : String → MetaM (Option String))
        (extraTransf : List (String → MetaM (Option String))) (limit : Option Nat := none) :
        MetaM (List String) := do
        let (pairs, tail) := segs
        if (pairs.size ≥  limit.getD (pairs.size + 1)) then return []
        else
        -- IO.println s!"building {pairs.size} segments"
        let transformed ← polyTransform pairs.toList transf extraTransf
        -- IO.println s!"transformed to {transformed.length} pieces"
        let strings :=
          transformed.map (fun res =>
            res.foldr (fun (init, ident) acc => (init ++ ident ++ acc)) tail)
        -- IO.println "built strings"
        return strings.eraseDups

def identMappedFunStx (s: String)
    (transf : String → MetaM (Option String) := binName?)(opens: List String := [])  : MetaM (Except String String) := do
    let corr?  ← identThmSegments s opens
    match corr? with
    | Except.ok corr => do
          let t ← transformBuild corr transf
          return Except.ok t
    | Except.error e => return Except.error e

/-- transforms a string expected to be of a form like `{A: Type} → (a : A) → P a` by translating identifiers using a given one-one and a given one-many transformation  -/
def polyIdentMappedFunStx (s: String)
    (transf : String → MetaM (Option String) := caseOrBinName?)
    (extraTransf : List (String → MetaM (Option String))
        := [])
    (opens: List String := [])(limit : Option Nat := none)  : MetaM (Except String (List String)) := do
    let corr?  ← identThmSegments s opens
    match corr? with
    | Except.ok corr => do
          let t ← polyTransformBuild corr transf extraTransf limit
          return Except.ok t
    | Except.error e => return Except.error e

-- #eval identThmSegments "{K : Type u} [Field K] : is_ring K"

/-- attempts to elaborate a string expected to be of a form like  `{A: Type} → (a : A) → P a` via parsing to a term; in principle any term is parsed -/
def elabFuncTyp (funTypeStr : String) (levelNames : List Lean.Name := levelNames) : TermElabM (Except String <| Syntax ×  Expr) := do
    -- IO.println s!"matching syntax {funTypeStr}"
    match Lean.Parser.runParserCategory (← getEnv) `term funTypeStr with
        | Except.ok termStx => Term.withLevelNames levelNames <|
          try
            -- IO.println "elaborating"
            let expr ← Term.withoutErrToSorry <|
                Term.elabTerm termStx none
            return Except.ok (termStx, expr)
          catch e =>
            return Except.error s!"{← e.toMessageData.toString} for {termStx.reprint} (during elaboration)"
        | Except.error e =>
            return Except.error s!"parsed func-type to {funTypeStr}; error while parsing as theorem: {e}"

/-- elaborates the string with translations and auto-corrections, including the one-to-many compatibility transformations and (optionally) returns a list of translations and translated strings -/
def polyElabThmTrans (s : String)(limit : Option Nat := none)
  (transf : String → MetaM (Option String) := caseOrBinName?)
  (extraTransf : List (String → MetaM (Option String))
        := [])
  (opens: List String := [])
  (levelNames : List Lean.Name := levelNames)
  : TermElabM <| Except String (List (Expr × Syntax × String)) := do
  match ← polyIdentMappedFunStx s transf extraTransf opens limit with
  | Except.ok funTypeStrList => do
    -- IO.println s!"elaborating {funTypeStrList.length} strings"
    let pairs: List (Expr × Syntax × String) ←
      funTypeStrList.filterMapM (fun funTypeStr => do
        let expE? ← elabFuncTyp funTypeStr levelNames
        let exp? := expE?.toOption
        return exp?.map <| fun (stx, expr) => (expr, stx , funTypeStr))
    return Except.ok pairs
  | Except.error e => return Except.error e

/-- elaborates the string with translations and auto-corrections, including the one-to-many compatibility transformations and (optionally) returns a  translation and translated string -/
def elabThmTrans? (s : String)(limit : Option Nat := none)
  (transf : String → MetaM (Option String) := caseOrBinName?)
  (extraTransf : List (String → MetaM (Option String))
        := [])
  (opens: List String := [])
  (levelNames : List Lean.Name := levelNames)
  : TermElabM <| (Option (Expr × Syntax × String)) := do
  match ← polyIdentMappedFunStx s transf extraTransf opens limit with
  | Except.ok funTypeStrList => do
    -- IO.println s!"elaborating {funTypeStrList.length} strings"
    funTypeStrList.findSomeM? (fun funTypeStr => do
        let expE? ← elabFuncTyp funTypeStr levelNames
        let exp? := expE?.toOption
        return exp?.map <| fun (stx, expr) => (expr, stx , funTypeStr))
  | Except.error _ => return none

def polyStrThmTrans (s : String)
  (transf : String → MetaM (Option String) := caseOrBinName?)
  (extraTransf : List (String → MetaM (Option String))
        := [])
  (opens: List String := [])
  : TermElabM (List String) := do
  match ← polyIdentMappedFunStx s transf extraTransf opens with
  | Except.ok funTypeStrList => do
    return funTypeStrList
  | Except.error _ => return [s]

def elabThmTrans (s : String)
  (transf : String → MetaM (Option String) := caseOrBinName?)
  (opens: List String := [])
  (levelNames : List Lean.Name := levelNames)
  : TermElabM <| Except String (Expr × String) := do
  match ← identMappedFunStx s transf opens with
  | Except.ok funTypeStr => do
    match (← elabFuncTyp funTypeStr levelNames) with
    | Except.ok (_, expr) => return Except.ok (expr, funTypeStr)
    | Except.error e => return Except.error e
  | Except.error e => return Except.error e

def compareFuncStrs(s₁ s₂ : String)
  (levelNames : List Lean.Name := levelNames)
  : TermElabM <| Except String Bool := do
  let e₁ ← elabFuncTyp s₁  levelNames
  let e₂ ← elabFuncTyp s₂ levelNames
  match e₁ with
  | Except.ok (_, e₁) => match e₂ with
    | Except.ok (_, e₂) =>
        let p := (← provedEqual e₁ e₂) ||
          (← provedEquiv e₁ e₂)
        return Except.ok p
    | Except.error e₂ => return Except.error e₂
  | Except.error e₁ => return Except.error e₁

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

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

def elabCorrected(depth: Nat)(ss : Array String) :
  TermElabM (Array String) := do
  let mut elabs : Array String := #[]
  let mut corrected : Array String := #[]
  for s  in ss do
    match ← elabThm s with
    | Except.ok _ => elabs := elabs.push s
    | Except.error err => do
      logInfo m!"s: {s}, err: {err}"
      match ← identCorrection s err with
      | none => pure ()
      | some s' => corrected := corrected.push s'
  if elabs.isEmpty then
    match depth with
    | 0 => return #[]
    | d + 1 => if corrected.isEmpty then return #[] else do
      elabCorrected d corrected
  else return elabs