/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Sebastian Ullrich, Leonardo de Moura
-/
import Lean.Data.Name
import Lean.Data.Format

namespace Lean

def SourceInfo.updateTrailing (trailing : Substring) : SourceInfo → SourceInfo
  | SourceInfo.original leading pos _ endPos => SourceInfo.original leading pos trailing endPos
  | info                                     => info

/- Syntax AST -/

inductive IsNode : Syntax → Prop where
  | mk (info : SourceInfo) (kind : SyntaxNodeKind) (args : Array Syntax) : IsNode (Syntax.node info kind args)

def SyntaxNode : Type := {s : Syntax // IsNode s }

def unreachIsNodeMissing {β} (h : IsNode Syntax.missing) : β := False.elim (nomatch h)
def unreachIsNodeAtom {β} {info val} (h : IsNode (Syntax.atom info val)) : β := False.elim (nomatch h)
def unreachIsNodeIdent {β info rawVal val preresolved} (h : IsNode (Syntax.ident info rawVal val preresolved)) : β := False.elim (nomatch h)

def isLitKind (k : SyntaxNodeKind) : Bool :=
  k == strLitKind || k == numLitKind || k == charLitKind || k == nameLitKind || k == scientificLitKind

namespace SyntaxNode

@[inline] def getKind (n : SyntaxNode) : SyntaxNodeKind :=
  match n with
  | ⟨Syntax.node _ k _, _⟩  => k
  | ⟨Syntax.missing, h⟩     => unreachIsNodeMissing h
  | ⟨Syntax.atom .., h⟩     => unreachIsNodeAtom h
  | ⟨Syntax.ident .., h⟩    => unreachIsNodeIdent h

@[inline] def withArgs {β} (n : SyntaxNode) (fn : Array Syntax → β) : β :=
  match n with
  | ⟨Syntax.node _ _ args, _⟩   => fn args
  | ⟨Syntax.missing, h⟩       => unreachIsNodeMissing h
  | ⟨Syntax.atom _ _, h⟩      => unreachIsNodeAtom h
  | ⟨Syntax.ident _ _ _ _, h⟩ => unreachIsNodeIdent h

@[inline] def getNumArgs (n : SyntaxNode) : Nat :=
  withArgs n fun args => args.size

@[inline] def getArg (n : SyntaxNode) (i : Nat) : Syntax :=
  withArgs n fun args => args.get! i

@[inline] def getArgs (n : SyntaxNode) : Array Syntax :=
  withArgs n fun args => args

@[inline] def modifyArgs (n : SyntaxNode) (fn : Array Syntax → Array Syntax) : Syntax :=
  match n with
  | ⟨Syntax.node i k args, _⟩  => Syntax.node i k (fn args)
  | ⟨Syntax.missing, h⟩        => unreachIsNodeMissing h
  | ⟨Syntax.atom _ _, h⟩       => unreachIsNodeAtom h
  | ⟨Syntax.ident _ _ _ _,  h⟩ => unreachIsNodeIdent h

end SyntaxNode

namespace Syntax

def getAtomVal! : Syntax → String
  | atom _ val => val
  | _          => panic! "getAtomVal!: not an atom"

def setAtomVal : Syntax → String → Syntax
  | atom info _, v => (atom info v)
  | stx,         _ => stx

@[inline] def ifNode {β} (stx : Syntax) (hyes : SyntaxNode → β) (hno : Unit → β) : β :=
  match stx with
  | Syntax.node i k args => hyes ⟨Syntax.node i k args, IsNode.mk i k args⟩
  | _                    => hno ()

@[inline] def ifNodeKind {β} (stx : Syntax) (kind : SyntaxNodeKind) (hyes : SyntaxNode → β) (hno : Unit → β) : β :=
  match stx with
  | Syntax.node i k args => if k == kind then hyes ⟨Syntax.node i k args, IsNode.mk i k args⟩ else hno ()
  | _                    => hno ()

def asNode : Syntax → SyntaxNode
  | Syntax.node info kind args => ⟨Syntax.node info kind args, IsNode.mk info kind args⟩
  | _                          => ⟨mkNullNode, IsNode.mk _ _ _⟩

def getIdAt (stx : Syntax) (i : Nat) : Name :=
  (stx.getArg i).getId

@[inline] def modifyArgs (stx : Syntax) (fn : Array Syntax → Array Syntax) : Syntax :=
  match stx with
  | node i k args => node i k (fn args)
  | stx           => stx

@[inline] def modifyArg (stx : Syntax) (i : Nat) (fn : Syntax → Syntax) : Syntax :=
  match stx with
  | node info k args => node info k (args.modify i fn)
  | stx              => stx

@[specialize] partial def replaceM {m : Type → Type} [Monad m] (fn : Syntax → m (Option Syntax)) : Syntax → m (Syntax)
  | stx@(node info kind args) => do
    match (← fn stx) with
    | some stx => return stx
    | none     => return node info kind (← args.mapM (replaceM fn))
  | stx => do
    let o ← fn stx
    return o.getD stx

@[specialize] partial def rewriteBottomUpM {m : Type → Type} [Monad m] (fn : Syntax → m (Syntax)) : Syntax → m (Syntax)
  | node info kind args   => do
    let args ← args.mapM (rewriteBottomUpM fn)
    fn (node info kind args)
  | stx => fn stx

@[inline] def rewriteBottomUp (fn : Syntax → Syntax) (stx : Syntax) : Syntax :=
  Id.run <| stx.rewriteBottomUpM fn

private def updateInfo : SourceInfo → String.Pos → String.Pos → SourceInfo
  | SourceInfo.original lead pos trail endPos, leadStart, trailStop =>
    SourceInfo.original { lead with startPos := leadStart } pos { trail with stopPos := trailStop } endPos
  | info, _, _ => info

private def chooseNiceTrailStop (trail : Substring) : String.Pos :=
trail.startPos + trail.posOf '\n'

/- Remark: the State `String.Pos` is the `SourceInfo.trailing.stopPos` of the previous token,
   or the beginning of the String. -/
@[inline]
private def updateLeadingAux : Syntax → StateM String.Pos (Option Syntax)
  | atom info@(SourceInfo.original lead _ trail _) val => do
    let trailStop := chooseNiceTrailStop trail
    let newInfo := updateInfo info (← get) trailStop
    set trailStop
    return some (atom newInfo val)
  | ident info@(SourceInfo.original lead _ trail _) rawVal val pre => do
    let trailStop := chooseNiceTrailStop trail
    let newInfo := updateInfo info (← get) trailStop
    set trailStop
    return some (ident newInfo rawVal val pre)
  | _ => pure none

/-- Set `SourceInfo.leading` according to the trailing stop of the preceding token.
    The result is a round-tripping syntax tree IF, in the input syntax tree,
    * all leading stops, atom contents, and trailing starts are correct
    * trailing stops are between the trailing start and the next leading stop.

    Remark: after parsing, all `SourceInfo.leading` fields are empty.
    The `Syntax` argument is the output produced by the parser for `source`.
    This function "fixes" the `source.leading` field.

    Additionally, we try to choose "nicer" splits between leading and trailing stops
    according to some heuristics so that e.g. comments are associated to the (intuitively)
    correct token.

    Note that the `SourceInfo.trailing` fields must be correct.
    The implementation of this Function relies on this property. -/
def updateLeading : Syntax → Syntax :=
  fun stx => (replaceM updateLeadingAux stx).run' 0

partial def updateTrailing (trailing : Substring) : Syntax → Syntax
  | Syntax.atom info val               => Syntax.atom (info.updateTrailing trailing) val
  | Syntax.ident info rawVal val pre   => Syntax.ident (info.updateTrailing trailing) rawVal val pre
  | n@(Syntax.node info k args)        =>
    if args.size == 0 then n
    else
     let i    := args.size - 1
     let last := updateTrailing trailing args[i]
     let args := args.set! i last;
     Syntax.node info k args
  | s => s

partial def getTailWithPos : Syntax → Option Syntax
  | stx@(atom info _)   => info.getPos?.map fun _ => stx
  | stx@(ident info ..) => info.getPos?.map fun _ => stx
  | node SourceInfo.none _ args => args.findSomeRev? getTailWithPos
  | stx@(node info _ _) => stx
  | _                   => none

open SourceInfo in
/-- Split an `ident` into its dot-separated components while preserving source info.
Macro scopes are first erased.  For example, `` `foo.bla.boo._@._hyg.4 `` ↦ `` [`foo, `bla, `boo] ``.
If `nFields` is set, we take that many fields from the end and keep the remaining components
as one name. For example, `` `foo.bla.boo `` with `(nFields := 1)` ↦ `` [`foo.bla, `boo] ``. -/
def identComponents (stx : Syntax) (nFields? : Option Nat := none) : List Syntax :=
  match stx with
  | ident (SourceInfo.original lead pos trail _) rawStr val _ =>
    let val := val.eraseMacroScopes
    -- With original info, we assume that `rawStr` represents `val`.
    let nameComps := nameComps val nFields?
    let rawComps := splitNameLit rawStr
    let rawComps :=
      if let some nFields := nFields? then
        let nPrefix := rawComps.length - nFields
        let prefixSz := rawComps.take nPrefix |>.foldl (init := 0) fun acc (ss : Substring) => acc + ss.bsize + 1
        let prefixSz := prefixSz - 1 -- The last component has no dot
        rawStr.extract 0 prefixSz :: rawComps.drop nPrefix
      else
        rawComps
    assert! nameComps.length == rawComps.length
    nameComps.zip rawComps |>.map fun (id, ss) =>
      let off := ss.startPos - rawStr.startPos
      let lead := if off == 0 then lead else "".toSubstring
      let trail := if ss.stopPos == rawStr.stopPos then trail else "".toSubstring
      let info := original lead (pos + off) trail (pos + off + ss.bsize)
      ident info ss id []
  | ident si _ val _ =>
    let val := val.eraseMacroScopes
    /- With non-original info:
     - `rawStr` can take all kinds of forms so we only use `val`.
     - there is no source extent to offset, so we pass it as-is. -/
    nameComps val nFields? |>.map fun n => ident si n.toString.toSubstring n []
  | _ => unreachable!
  where
    nameComps (n : Name) (nFields? : Option Nat) : List Name :=
      if let some nFields := nFields? then
        let nameComps := n.components
        let nPrefix := nameComps.length - nFields
        let namePrefix := nameComps.take nPrefix |>.foldl (init := Name.anonymous) fun acc n => acc ++ n
        namePrefix :: nameComps.drop nPrefix
      else
        n.components

structure TopDown where
  firstChoiceOnly : Bool
  stx : Syntax

/--
`for _ in stx.topDown` iterates through each node and leaf in `stx` top-down, left-to-right.
If `firstChoiceOnly` is `true`, only visit the first argument of each choice node.
-/
def topDown (stx : Syntax) (firstChoiceOnly := false) : TopDown := ⟨firstChoiceOnly, stx⟩

partial instance : ForIn m TopDown Syntax where
  forIn := fun ⟨firstChoiceOnly, stx⟩ init f => do
    let rec @[specialize] loop stx b [Inhabited (type_of% b)] := do
      match (← f stx b) with
      | ForInStep.yield b' =>
        let mut b := b'
        if let Syntax.node i k args := stx then
          if firstChoiceOnly && k == choiceKind then
            return ← loop args[0] b
          else
            for arg in args do
              match (← loop arg b) with
              | ForInStep.yield b' => b := b'
              | ForInStep.done b'  => return ForInStep.done b'
        return ForInStep.yield b
      | ForInStep.done b => return ForInStep.done b
    match (← @loop stx init ⟨init⟩) with
    | ForInStep.yield b => return b
    | ForInStep.done b  => return b

partial def reprint (stx : Syntax) : Option String :=
  OptionM.run do
    let mut s := ""
    for stx in stx.topDown (firstChoiceOnly := true) do
      match stx with
      | atom info val           => s := s ++ reprintLeaf info val
      | ident info rawVal _ _   => s := s ++ reprintLeaf info rawVal.toString
      | node info kind args     =>
        if kind == choiceKind then
          -- this visit the first arg twice, but that should hardly be a problem
          -- given that choice nodes are quite rare and small
          let s0 ← reprint args[0]
          for arg in args[1:] do
            let s' ← reprint arg
            guard (s0 == s')
      | _ => pure ()
    return s
where
  reprintLeaf (info : SourceInfo) (val : String) : String :=
    match info with
    | SourceInfo.original lead _ trail _ => s!"{lead}{val}{trail}"
    -- no source info => add gracious amounts of whitespace to definitely separate tokens
    -- Note that the proper pretty printer does not use this function.
    -- The parser as well always produces source info, so round-tripping is still
    -- guaranteed.
    | _                                => s!" {val} "

def hasMissing (stx : Syntax) : Bool := Id.run <| do
  for stx in stx.topDown do
    if stx.isMissing then
      return true
  return false

/--
Represents a cursor into a syntax tree that can be read, written, and advanced down/up/left/right.
Indices are allowed to be out-of-bound, in which case `cur` is `Syntax.missing`.
If the `Traverser` is used linearly, updates are linear in the `Syntax` object as well.
-/
structure Traverser where
  cur     : Syntax
  parents : Array Syntax
  idxs    : Array Nat

namespace Traverser

def fromSyntax (stx : Syntax) : Traverser :=
  ⟨stx, #[], #[]⟩

def setCur (t : Traverser) (stx : Syntax) : Traverser :=
  { t with cur := stx }

/-- Advance to the `idx`-th child of the current node. -/
def down (t : Traverser) (idx : Nat) : Traverser :=
  if idx < t.cur.getNumArgs then
    { cur := t.cur.getArg idx, parents := t.parents.push <| t.cur.setArg idx default, idxs := t.idxs.push idx }
  else
    { cur := Syntax.missing, parents := t.parents.push t.cur, idxs := t.idxs.push idx }

/-- Advance to the parent of the current node, if any. -/
def up (t : Traverser) : Traverser :=
  if t.parents.size > 0 then
    let cur := if t.idxs.back < t.parents.back.getNumArgs then t.parents.back.setArg t.idxs.back t.cur else t.parents.back
    { cur := cur, parents := t.parents.pop, idxs := t.idxs.pop }
  else
    t

/-- Advance to the left sibling of the current node, if any. -/
def left (t : Traverser) : Traverser :=
  if t.parents.size > 0 then
    t.up.down (t.idxs.back - 1)
  else
    t

/-- Advance to the right sibling of the current node, if any. -/
def right (t : Traverser) : Traverser :=
  if t.parents.size > 0 then
    t.up.down (t.idxs.back + 1)
  else
    t

end Traverser

/-- Monad class that gives read/write access to a `Traverser`. -/
class MonadTraverser (m : Type → Type) where
  st : MonadState Traverser m

namespace MonadTraverser

variable {m : Type → Type} [Monad m] [t : MonadTraverser m]

def getCur : m Syntax := Traverser.cur <$> t.st.get
def setCur (stx : Syntax) : m Unit := @modify _ _ t.st (fun t => t.setCur stx)
def goDown (idx : Nat)    : m Unit := @modify _ _ t.st (fun t => t.down idx)
def goUp                  : m Unit := @modify _ _ t.st (fun t => t.up)
def goLeft                : m Unit := @modify _ _ t.st (fun t => t.left)
def goRight               : m Unit := @modify _ _ t.st (fun t => t.right)

def getIdx : m Nat := do
  let st ← t.st.get
  return st.idxs.back?.getD 0

end MonadTraverser
end Syntax

namespace SyntaxNode

@[inline] def getIdAt (n : SyntaxNode) (i : Nat) : Name :=
  (n.getArg i).getId

end SyntaxNode

def mkListNode (args : Array Syntax) : Syntax :=
  mkNullNode args

namespace Syntax

-- quotation node kinds are formed from a unique quotation name plus "quot"
def isQuot : Syntax → Bool
  | Syntax.node _ (Name.str _ "quot" _)         _ => true
  | Syntax.node _ `Lean.Parser.Term.dynamicQuot _ => true
  | _                                             => false

def getQuotContent (stx : Syntax) : Syntax :=
  if stx.isOfKind `Lean.Parser.Term.dynamicQuot then
    stx[3]
  else
    stx[1]

-- antiquotation node kinds are formed from the original node kind (if any) plus "antiquot"
def isAntiquot : Syntax → Bool
  | Syntax.node _ (Name.str _ "antiquot" _) _ => true
  | _                                         => false

def mkAntiquotNode (term : Syntax) (nesting := 0) (name : Option String := none) (kind := Name.anonymous) : Syntax :=
  let nesting := mkNullNode (mkArray nesting (mkAtom "$"))
  let term := match term.isIdent with
    | true  => term
    | false => mkNode `antiquotNestedExpr #[mkAtom "(", term, mkAtom ")"]
  let name := match name with
    | some name => mkNode `antiquotName #[mkAtom ":", mkAtom name]
    | none      => mkNullNode
  mkNode (kind ++ `antiquot) #[mkAtom "$", nesting, term, name]

-- Antiquotations can be escaped as in `$$x`, which is useful for nesting macros. Also works for antiquotation splices.
def isEscapedAntiquot (stx : Syntax) : Bool :=
  !stx[1].getArgs.isEmpty

-- Also works for antiquotation splices.
def unescapeAntiquot (stx : Syntax) : Syntax :=
  if isAntiquot stx then
    stx.setArg 1 <| mkNullNode stx[1].getArgs.pop
  else
    stx

-- Also works for token antiquotations.
def getAntiquotTerm (stx : Syntax) : Syntax :=
  let e := if stx.isAntiquot then stx[2] else stx[3]
  if e.isIdent then e
  else
    -- `e` is from `"(" >> termParser >> ")"`
    e[1]

def antiquotKind? : Syntax → Option SyntaxNodeKind
  | Syntax.node _ (Name.str k "antiquot" _) args =>
    if args[3].isOfKind `antiquotName then some k
    else
      -- we treat all antiquotations where the kind was left implicit (`$e`) the same (see `elimAntiquotChoices`)
      some Name.anonymous
  | _                                          => none

-- An "antiquotation splice" is something like `$[...]?` or `$[...]*`.
def antiquotSpliceKind? : Syntax → Option SyntaxNodeKind
  | Syntax.node _ (Name.str k "antiquot_scope" _) args => some k
  | _                                                  => none

def isAntiquotSplice (stx : Syntax) : Bool :=
  antiquotSpliceKind? stx |>.isSome

def getAntiquotSpliceContents (stx : Syntax) : Array Syntax :=
  stx[3].getArgs

-- `$[..],*` or `$x,*` ~> `,*`
def getAntiquotSpliceSuffix (stx : Syntax) : Syntax :=
  if stx.isAntiquotSplice then
    stx[5]
  else
    stx[1]

def mkAntiquotSpliceNode (kind : SyntaxNodeKind) (contents : Array Syntax) (suffix : String) (nesting := 0) : Syntax :=
  let nesting := mkNullNode (mkArray nesting (mkAtom "$"))
  mkNode (kind ++ `antiquot_splice) #[mkAtom "$", nesting, mkAtom "[", mkNullNode contents, mkAtom "]", mkAtom suffix]

-- `$x,*` etc.
def antiquotSuffixSplice? : Syntax → Option SyntaxNodeKind
  | Syntax.node _ (Name.str k "antiquot_suffix_splice" _) args => some k
  | _                                                          => none

def isAntiquotSuffixSplice (stx : Syntax) : Bool :=
  antiquotSuffixSplice? stx |>.isSome

-- `$x` in the example above
def getAntiquotSuffixSpliceInner (stx : Syntax) : Syntax :=
  stx[0]

def mkAntiquotSuffixSpliceNode (kind : SyntaxNodeKind) (inner : Syntax) (suffix : String) : Syntax :=
  mkNode (kind ++ `antiquot_suffix_splice) #[inner, mkAtom suffix]

def isTokenAntiquot (stx : Syntax) : Bool :=
  stx.isOfKind `token_antiquot

def isAnyAntiquot (stx : Syntax) : Bool :=
  stx.isAntiquot || stx.isAntiquotSplice || stx.isAntiquotSuffixSplice || stx.isTokenAntiquot

end Syntax
end Lean


/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Sebastian Ullrich, Leonardo de Moura
-/
import Lean.Data.Name
import Lean.Data.Format

namespace Lean

def SourceInfo.updateTrailing (trailing : Substring) : SourceInfo → SourceInfo
  | SourceInfo.original leading pos _ endPos => SourceInfo.original leading pos trailing endPos
  | info                                     => info

/- Syntax AST -/

inductive IsNode : Syntax → Prop where
  | mk (kind : SyntaxNodeKind) (args : Array Syntax) : IsNode (Syntax.node kind args)

def SyntaxNode : Type := {s : Syntax // IsNode s }

def unreachIsNodeMissing {β} (h : IsNode Syntax.missing) : β := False.elim (nomatch h)
def unreachIsNodeAtom {β} {info val} (h : IsNode (Syntax.atom info val)) : β := False.elim (nomatch h)
def unreachIsNodeIdent {β info rawVal val preresolved} (h : IsNode (Syntax.ident info rawVal val preresolved)) : β := False.elim (nomatch h)

namespace SyntaxNode

@[inline] def getKind (n : SyntaxNode) : SyntaxNodeKind :=
  match n with
  | ⟨Syntax.node k args, _⟩ => k
  | ⟨Syntax.missing, h⟩     => unreachIsNodeMissing h
  | ⟨Syntax.atom .., h⟩     => unreachIsNodeAtom h
  | ⟨Syntax.ident .., h⟩    => unreachIsNodeIdent h

@[inline] def withArgs {β} (n : SyntaxNode) (fn : Array Syntax → β) : β :=
  match n with
  | ⟨Syntax.node _ args, _⟩   => fn args
  | ⟨Syntax.missing, h⟩       => unreachIsNodeMissing h
  | ⟨Syntax.atom _ _, h⟩      => unreachIsNodeAtom h
  | ⟨Syntax.ident _ _ _ _, h⟩ => unreachIsNodeIdent h

@[inline] def getNumArgs (n : SyntaxNode) : Nat :=
  withArgs n $ fun args => args.size

@[inline] def getArg (n : SyntaxNode) (i : Nat) : Syntax :=
  withArgs n $ fun args => args.get! i

@[inline] def getArgs (n : SyntaxNode) : Array Syntax :=
  withArgs n $ fun args => args

@[inline] def modifyArgs (n : SyntaxNode) (fn : Array Syntax → Array Syntax) : Syntax :=
  match n with
  | ⟨Syntax.node kind args, _⟩ => Syntax.node kind (fn args)
  | ⟨Syntax.missing, h⟩        => unreachIsNodeMissing h
  | ⟨Syntax.atom _ _, h⟩       => unreachIsNodeAtom h
  | ⟨Syntax.ident _ _ _ _,  h⟩ => unreachIsNodeIdent h

end SyntaxNode

namespace Syntax

def getAtomVal! : Syntax → String
  | atom _ val => val
  | _          => panic! "getAtomVal!: not an atom"

def setAtomVal : Syntax → String → Syntax
  | atom info _, v => (atom info v)
  | stx,         _ => stx

@[inline] def ifNode {β} (stx : Syntax) (hyes : SyntaxNode → β) (hno : Unit → β) : β :=
  match stx with
  | Syntax.node k args => hyes ⟨Syntax.node k args, IsNode.mk k args⟩
  | _                  => hno ()

@[inline] def ifNodeKind {β} (stx : Syntax) (kind : SyntaxNodeKind) (hyes : SyntaxNode → β) (hno : Unit → β) : β :=
  match stx with
  | Syntax.node k args => if k == kind then hyes ⟨Syntax.node k args, IsNode.mk k args⟩ else hno ()
  | _                  => hno ()

def asNode : Syntax → SyntaxNode
  | Syntax.node kind args => ⟨Syntax.node kind args, IsNode.mk kind args⟩
  | _                     => ⟨Syntax.node nullKind #[], IsNode.mk nullKind #[]⟩

def getIdAt (stx : Syntax) (i : Nat) : Name :=
  (stx.getArg i).getId

@[inline] def modifyArgs (stx : Syntax) (fn : Array Syntax → Array Syntax) : Syntax :=
  match stx with
  | node k args => node k (fn args)
  | stx         => stx

@[inline] def modifyArg (stx : Syntax) (i : Nat) (fn : Syntax → Syntax) : Syntax :=
  match stx with
  | node k args => node k (args.modify i fn)
  | stx         => stx

@[specialize] partial def replaceM {m : Type → Type} [Monad m] (fn : Syntax → m (Option Syntax)) : Syntax → m (Syntax)
  | stx@(node kind args) => do
    match (← fn stx) with
    | some stx => return stx
    | none     => return node kind (← args.mapM (replaceM fn))
  | stx => do
    let o ← fn stx
    return o.getD stx

@[specialize] partial def rewriteBottomUpM {m : Type → Type} [Monad m] (fn : Syntax → m (Syntax)) : Syntax → m (Syntax)
  | node kind args   => do
    let args ← args.mapM (rewriteBottomUpM fn)
    fn (node kind args)
  | stx => fn stx

@[inline] def rewriteBottomUp (fn : Syntax → Syntax) (stx : Syntax) : Syntax :=
  Id.run $ stx.rewriteBottomUpM fn

private def updateInfo : SourceInfo → String.Pos → String.Pos → SourceInfo
  | SourceInfo.original lead pos trail endPos, leadStart, trailStop =>
    SourceInfo.original { lead with startPos := leadStart } pos { trail with stopPos := trailStop } endPos
  | info, _, _ => info

private def chooseNiceTrailStop (trail : Substring) : String.Pos :=
trail.startPos + trail.posOf '\n'

/- Remark: the State `String.Pos` is the `SourceInfo.trailing.stopPos` of the previous token,
   or the beginning of the String. -/
@[inline]
private def updateLeadingAux : Syntax → StateM String.Pos (Option Syntax)
  | atom info@(SourceInfo.original lead _ trail _) val => do
    let trailStop := chooseNiceTrailStop trail
    let newInfo := updateInfo info (← get) trailStop
    set trailStop
    pure $ some (atom newInfo val)
  | ident info@(SourceInfo.original lead _ trail _) rawVal val pre => do
    let trailStop := chooseNiceTrailStop trail
    let newInfo := updateInfo info (← get) trailStop
    set trailStop
    pure $ some (ident newInfo rawVal val pre)
  | _ => pure none

/-- Set `SourceInfo.leading` according to the trailing stop of the preceding token.
    The result is a round-tripping syntax tree IF, in the input syntax tree,
    * all leading stops, atom contents, and trailing starts are correct
    * trailing stops are between the trailing start and the next leading stop.

    Remark: after parsing, all `SourceInfo.leading` fields are empty.
    The `Syntax` argument is the output produced by the parser for `source`.
    This function "fixes" the `source.leading` field.

    Additionally, we try to choose "nicer" splits between leading and trailing stops
    according to some heuristics so that e.g. comments are associated to the (intuitively)
    correct token.

    Note that the `SourceInfo.trailing` fields must be correct.
    The implementation of this Function relies on this property. -/
def updateLeading : Syntax → Syntax :=
  fun stx => (replaceM updateLeadingAux stx).run' 0

partial def updateTrailing (trailing : Substring) : Syntax → Syntax
  | Syntax.atom info val               => Syntax.atom (info.updateTrailing trailing) val
  | Syntax.ident info rawVal val pre   => Syntax.ident (info.updateTrailing trailing) rawVal val pre
  | n@(Syntax.node k args)             =>
    if args.size == 0 then n
    else
     let i    := args.size - 1
     let last := updateTrailing trailing args[i]
     let args := args.set! i last;
     Syntax.node k args
  | s => s

partial def getTailWithPos : Syntax → Option Syntax
  | stx@(atom info _)   => info.getPos?.map fun _ => stx
  | stx@(ident info ..) => info.getPos?.map fun _ => stx
  | node _ args         => args.findSomeRev? getTailWithPos
  | _                   => none

structure TopDown where
  firstChoiceOnly : Bool
  stx : Syntax

/--
`for _ in stx.topDown` iterates through each node and leaf in `stx` top-down, left-to-right.
If `firstChoiceOnly` is `true`, only visit the first argument of each choice node.
-/
def topDown (stx : Syntax) (firstChoiceOnly := false) : TopDown := ⟨firstChoiceOnly, stx⟩

partial instance : ForIn m TopDown Syntax where
  forIn := fun ⟨firstChoiceOnly, stx⟩ init f => do
    let rec @[specialize] loop stx b [Inhabited (typeOf% b)] := do
      match ← f stx b with
      | ForInStep.yield b' =>
        let mut b := b'
        if let Syntax.node k args := stx then
          if firstChoiceOnly && k == choiceKind then
            return ← loop args[0] b
          else
            for arg in args do
              match ← loop arg b with
              | ForInStep.yield b' => b := b'
              | ForInStep.done b'  => return ForInStep.done b'
        return ForInStep.yield b
      | ForInStep.done b => return ForInStep.done b
    match ← @loop stx init ⟨init⟩ with
    | ForInStep.yield b => return b
    | ForInStep.done b  => return b

partial def reprint (stx : Syntax) : Option String :=
  OptionM.run do
    let mut s := ""
    for stx in stx.topDown (firstChoiceOnly := true) do
      match stx with
      | atom info val           => s := s ++ reprintLeaf info val
      | ident info rawVal _ _   => s := s ++ reprintLeaf info rawVal.toString
      | node kind args          =>
        if kind == choiceKind then
          -- this visit the first arg twice, but that should hardly be a problem
          -- given that choice nodes are quite rare and small
          let s0 ← reprint args[0]
          for arg in args[1:] do
            let s' ← reprint stx
            guard (s0 == s')
      | _ => pure ()
    return s
where
  reprintLeaf (info : SourceInfo) (val : String) : String :=
    match info with
    | SourceInfo.original lead _ trail _ => s!"{lead}{val}{trail}"
    -- no source info => add gracious amounts of whitespace to definitely separate tokens
    -- Note that the proper pretty printer does not use this function.
    -- The parser as well always produces source info, so round-tripping is still
    -- guaranteed.
    | _                                => s!" {val} "

def hasMissing (stx : Syntax) : Bool := do
  for stx in stx.topDown do
    if stx.isMissing then
      return true
  return false

/--
Represents a cursor into a syntax tree that can be read, written, and advanced down/up/left/right.
Indices are allowed to be out-of-bound, in which case `cur` is `Syntax.missing`.
If the `Traverser` is used linearly, updates are linear in the `Syntax` object as well.
-/
structure Traverser where
  cur     : Syntax
  parents : Array Syntax
  idxs    : Array Nat

namespace Traverser

def fromSyntax (stx : Syntax) : Traverser :=
  ⟨stx, #[], #[]⟩

def setCur (t : Traverser) (stx : Syntax) : Traverser :=
  { t with cur := stx }

/-- Advance to the `idx`-th child of the current node. -/
def down (t : Traverser) (idx : Nat) : Traverser :=
  if idx < t.cur.getNumArgs then
    { cur := t.cur.getArg idx, parents := t.parents.push $ t.cur.setArg idx arbitrary, idxs := t.idxs.push idx }
  else
    { cur := Syntax.missing, parents := t.parents.push t.cur, idxs := t.idxs.push idx }

/-- Advance to the parent of the current node, if any. -/
def up (t : Traverser) : Traverser :=
  if t.parents.size > 0 then
    let cur := if t.idxs.back < t.parents.back.getNumArgs then t.parents.back.setArg t.idxs.back t.cur else t.parents.back
    { cur := cur, parents := t.parents.pop, idxs := t.idxs.pop }
  else
    t

/-- Advance to the left sibling of the current node, if any. -/
def left (t : Traverser) : Traverser :=
  if t.parents.size > 0 then
    t.up.down (t.idxs.back - 1)
  else
    t

/-- Advance to the right sibling of the current node, if any. -/
def right (t : Traverser) : Traverser :=
  if t.parents.size > 0 then
    t.up.down (t.idxs.back + 1)
  else
    t

end Traverser

/-- Monad class that gives read/write access to a `Traverser`. -/
class MonadTraverser (m : Type → Type) where
  st : MonadState Traverser m

namespace MonadTraverser

variable {m : Type → Type} [Monad m] [t : MonadTraverser m]

def getCur : m Syntax := Traverser.cur <$> t.st.get
def setCur (stx : Syntax) : m Unit := @modify _ _ t.st (fun t => t.setCur stx)
def goDown (idx : Nat)    : m Unit := @modify _ _ t.st (fun t => t.down idx)
def goUp                  : m Unit := @modify _ _ t.st (fun t => t.up)
def goLeft                : m Unit := @modify _ _ t.st (fun t => t.left)
def goRight               : m Unit := @modify _ _ t.st (fun t => t.right)

def getIdx : m Nat := do
  let st ← t.st.get
  st.idxs.back?.getD 0

end MonadTraverser
end Syntax

namespace SyntaxNode

@[inline] def getIdAt (n : SyntaxNode) (i : Nat) : Name :=
  (n.getArg i).getId

end SyntaxNode

def mkListNode (args : Array Syntax) : Syntax :=
  Syntax.node nullKind args

namespace Syntax

-- quotation node kinds are formed from a unique quotation name plus "quot"
def isQuot : Syntax → Bool
  | Syntax.node (Name.str _ "quot" _)         _ => true
  | Syntax.node `Lean.Parser.Term.dynamicQuot _ => true
  | _                                           => false

def getQuotContent (stx : Syntax) : Syntax :=
  if stx.isOfKind `Lean.Parser.Term.dynamicQuot then
    stx[3]
  else
    stx[1]

-- antiquotation node kinds are formed from the original node kind (if any) plus "antiquot"
def isAntiquot : Syntax → Bool
  | Syntax.node (Name.str _ "antiquot" _) _ => true
  | _                                       => false

def mkAntiquotNode (term : Syntax) (nesting := 0) (name : Option String := none) (kind := Name.anonymous) : Syntax :=
  let nesting := mkNullNode (mkArray nesting (mkAtom "$"))
  let term := match term.isIdent with
    | true  => term
    | false => mkNode `antiquotNestedExpr #[mkAtom "(", term, mkAtom ")"]
  let name := match name with
    | some name => mkNode `antiquotName #[mkAtom ":", mkAtom name]
    | none      => mkNullNode
  mkNode (kind ++ `antiquot) #[mkAtom "$", nesting, term, name]

-- Antiquotations can be escaped as in `$$x`, which is useful for nesting macros. Also works for antiquotation splices.
def isEscapedAntiquot (stx : Syntax) : Bool :=
  !stx[1].getArgs.isEmpty

-- Also works for antiquotation splices.
def unescapeAntiquot (stx : Syntax) : Syntax :=
  if isAntiquot stx then
    stx.setArg 1 $ mkNullNode stx[1].getArgs.pop
  else
    stx

-- Also works for token antiquotations.
def getAntiquotTerm (stx : Syntax) : Syntax :=
  let e := if stx.isAntiquot then stx[2] else stx[3]
  if e.isIdent then e
  else
    -- `e` is from `"(" >> termParser >> ")"`
    e[1]

def antiquotKind? : Syntax → Option SyntaxNodeKind
  | Syntax.node (Name.str k "antiquot" _) args =>
    if args[3].isOfKind `antiquotName then some k
    else
      -- we treat all antiquotations where the kind was left implicit (`$e`) the same (see `elimAntiquotChoices`)
      some Name.anonymous
  | _                                          => none

-- An "antiquotation splice" is something like `$[...]?` or `$[...]*`.
def antiquotSpliceKind? : Syntax → Option SyntaxNodeKind
  | Syntax.node (Name.str k "antiquot_scope" _) args => some k
  | _                                                => none

def isAntiquotSplice (stx : Syntax) : Bool :=
  antiquotSpliceKind? stx |>.isSome

def getAntiquotSpliceContents (stx : Syntax) : Array Syntax :=
  stx[3].getArgs

-- `$[..],*` or `$x,*` ~> `,*`
def getAntiquotSpliceSuffix (stx : Syntax) : Syntax :=
  if stx.isAntiquotSplice then
    stx[5]
  else
    stx[1]

def mkAntiquotSpliceNode (kind : SyntaxNodeKind) (contents : Array Syntax) (suffix : String) (nesting := 0) : Syntax :=
  let nesting := mkNullNode (mkArray nesting (mkAtom "$"))
  mkNode (kind ++ `antiquot_splice) #[mkAtom "$", nesting, mkAtom "[", mkNullNode contents, mkAtom "]", mkAtom suffix]

-- `$x,*` etc.
def antiquotSuffixSplice? : Syntax → Option SyntaxNodeKind
  | Syntax.node (Name.str k "antiquot_suffix_splice" _) args => some k
  | _                                                        => none

def isAntiquotSuffixSplice (stx : Syntax) : Bool :=
  antiquotSuffixSplice? stx |>.isSome

-- `$x` in the example above
def getAntiquotSuffixSpliceInner (stx : Syntax) : Syntax :=
  stx[0]

def mkAntiquotSuffixSpliceNode (kind : SyntaxNodeKind) (inner : Syntax) (suffix : String) : Syntax :=
  mkNode (kind ++ `antiquot_suffix_splice) #[inner, mkAtom suffix]

def isTokenAntiquot (stx : Syntax) : Bool :=
  stx.isOfKind `token_antiquot

def isAnyAntiquot (stx : Syntax) : Bool :=
  stx.isAntiquot || stx.isAntiquotSplice || stx.isAntiquotSuffixSplice || stx.isTokenAntiquot

end Syntax
end Lean


open tactic

lemma a1 : true :=
begin
  sleep 20000,
  trivial
end

lemma a2 : true :=
begin
  sleep 10000,
  trivial
end


def String.isInfixOf (p : String) (s : String) : Bool := do
  if s.length < p.length then false
  else do
    for i in [0:(s.length-p.length)] do
      if s.extract i (i+p.length) == p then
        return true
    return false

namespace Terminal

class Command (α : Type u) where
  writeAnsi : α → IO.FS.Stream → IO Unit

def csi (s : String) : String := "\x1B[" ++ s

/--
  A command that moves the terminal cursor to the given position (column, row).

  # Notes

  * Top left cell is represented as `0,0`.
  * Commands must be executed/queued for execution otherwise they do nothing.
-/
structure MoveTo := (c r : UInt16)

instance : Command MoveTo where
  writeAnsi self f := f.putStr <| csi s!"{self.r + 1};{self.c + 1}H"

/--
  A command that moves the terminal cursor down the given number of lines,
  and moves it to the first column.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure MoveToNextLine := (n : UInt16)

instance : Command MoveToNextLine where
  writeAnsi self f := f.putStr <| csi s!"{self.n}E"

/--
  A command that moves the terminal cursor up the given number of lines,
  and moves it to the first column.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure MoveToPreviousLine := (n : UInt16)

instance : Command MoveToPreviousLine where
  writeAnsi self f := f.putStr <| csi s!"{self.n}F"

/--
  A command that moves the terminal cursor to the given column on the current row.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure MoveToColumn := (c : UInt16)

instance : Command MoveToColumn where
  writeAnsi self f := f.putStr <| csi s!"{self.c}G"

/--
  A command that moves the terminal cursor to the given row on the current column.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure MoveToRow := (r : UInt16)

instance : Command MoveToRow where
  writeAnsi self f := f.putStr <| csi s!"{self.r}d"

/--
  A command that moves the terminal cursor a given number of rows up.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure MoveUp := (n : UInt16)

instance : Command MoveUp where
  writeAnsi self f := f.putStr <| csi s!"{self.n}A"

/--
  A command that moves the terminal cursor a given number of columns to the right.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure MoveRight := (n : UInt16)

instance : Command MoveRight where
  writeAnsi self f := f.putStr <| csi s!"{self.n}C"

/--
  A command that moves the terminal cursor a given number of rows down.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure MoveDown := (n : UInt16)

instance : Command MoveDown where
  writeAnsi self f := f.putStr <| csi s!"{self.n}B"

/--
  A command that moves the terminal cursor a given number of columns to the left.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure MoveLeft := (n : UInt16)

instance : Command MoveLeft where
  writeAnsi self f := f.putStr <| csi s!"{self.n}D"

/--
  A command that saves the current terminal cursor position.

  See the `RestorePosition` command.

  # Notes

  - The cursor position is stored globally.
  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure SavePosition

instance : Command SavePosition where
  writeAnsi self f := f.putStr <| csi "s"

/--
  A command that saves the current terminal cursor position.

  See the `SavePosition` command.

  # Notes

  - The cursor position is stored globally.
  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure RestorePosition

instance : Command RestorePosition where
  writeAnsi self f := f.putStr <| csi "u"

/--
  A command that hides the terminal cursor.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure Hide

instance : Command Hide where
  writeAnsi self f := f.putStr <| csi "?25l"

/--
  A command that shows the terminal cursor.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure Show

instance : Command Show where
  writeAnsi self f := f.putStr <| csi "?25h"

/--
  A command that enables blinking of the terminal cursor.

  # Notes

  - Windows versions lower than Windows 10 do not support this functionality.
  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure EnableBlinking

instance : Command EnableBlinking where
  writeAnsi self f := f.putStr <| csi "?12h"

/--
  A command that disables blinking of the terminal cursor.

  # Notes

  - Windows versions lower than Windows 10 do not support this functionality.
  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure DisableBlinking

instance : Command DisableBlinking where
  writeAnsi self f := f.putStr <| csi "?12l"

inductive CursorShape
  | underScore
  | line
  | block

/--
  A command that sets the shape of the cursor

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure SetCursorShape := (s : CursorShape)

instance : Command SetCursorShape where
  writeAnsi self f := f.putStr <| csi <|
    match self.s with
    | CursorShape.underScore  => "3 q"
    | CursorShape.line        => "5 q"
    | CursorShape.block       => "2 q"

-- /--
--   Returns the cursor position (column, row).

--   The top left cell is represented `0,0`.
-- -/
-- def position : IO (UInt16 × UInt16) := sorry

inductive KeyCode where
  | /-- Backspace key. -/
    backspace
  | /-- Enter key. -/
    enter
  | /-- Left arrow key. -/
    left
  | /-- Right arrow key. -/
    right
  | /-- Up arrow key. -/
    up
  | /-- Down arrow key. -/
    down
  | /-- Home key. -/
    home
  | /-- End key. -/
    «end»
  | /-- Page up key. -/
    pageUp
  | /-- Page dow key. -/
    pageDown
  | /-- Tab key.-/
    tab
  | /-- Shift + Tab key. -/
    backtab
  | /-- Delete key. -/
    delete
  | /-- Insert key. -/
    insert
  | /--
      F key.
      `KeyCode.f 1` represents F1 key, etc.
    -/
    f : UInt8 → KeyCode
  | /--
      A character.
      KeyCode::Char('c') represents c character, etc.
    -/
    char : Char → KeyCode
  | /-- Null. -/
    null
  | /-- Escape key. -/
    esc

-- TODO: something like bitflags.
/-- Represents key modifiers (shift, control, alt). -/
structure KeyModifiers

/-- Represents a key event. -/
structure KeyEvent where
  /-- The key itself. -/
  code      : KeyCode
  /-- Additional key modifiers. -/
  modifiers : KeyModifiers

/-- Represents a mouse button. -/
inductive MouseButton
  | left
  | right
  | middle

/--
  A mouse event kind.

  # Platform-specific Notes

  ## Mouse Buttons

  Some platforms/terminals do not report mouse button for the
  `MouseEventKind.up` and `MouseEventKind.drag` events. `MouseButton.left`
  is returned if we don't know which button was used.
-/
inductive MouseEventKind
  | /-- Pressed mouse button. Contains the button that was pressed. -/
    down : MouseButton → MouseEventKind
  | /-- Released mouse button. Contains the button that was released. -/
    up   : MouseButton → MouseEventKind
  | /-- Moved the mouse cursor while pressing the contained mouse button. -/
    drag : MouseButton → MouseEventKind
  |/-- Moved the mouse cursor while not pressing a mouse button. -/
    moved
  | /-- Scrolled mouse wheel downwards (towards the user). -/
    scrollDown
  | /-- Scrolled mouse wheel upwards (away from the user). -/
    scrollUp

/--
  Represents a mouse event.

  # Platform-specific Notes

  ## Mouse Buttons

  Some platforms/terminals do not report mouse button for the
  `MouseEventKind.up` and `MouseEventKind.drag` events. `MouseButton.left`
  is returned if we don't know which button was used.

  ## Key Modifiers

  Some platforms/terminals does not report all key modifiers
  combinations for all mouse event types. For example - macOS reports
  `Ctrl` + left mouse button click as a right mouse button click.
-/
structure MouseEvent where
  /-- The kind of mouse event that was caused. -/
  kind      : MouseEventKind
  /-- The column that the event occurred on. -/
  column    : UInt16
  /-- The row that the event occurred on. -/
  row       : UInt16
  /-- The key modifiers active when the event occurred. -/
  modifiers : KeyModifiers

/-- Represents an event. -/
inductive Event
  | /-- A single key event with additional pressed modifiers. -/
    key     : KeyEvent → Event
  | /-- A single mouse event with additional pressed modifiers. -/
    mouse   : MouseEvent → Event
  | /--
      An resize event with new dimensions after resize (columns, rows).
      **Note** that resize events can be occur in batches.
    -/
    resize  : UInt16 × UInt16 → Event

-- TODO: add poll

-- /--
--   Reads a single `Event`

--   This function blocks until an `Event` is available. Combine it with the
--   `poll` function to get non-blocking reads.

-- -/
-- def read : IO Event := sorry

/--
  A command that enables mouse event capturing.

  Mouse events can be captured with `read`/`poll`.
-/
structure EnableMouseCapture

instance : Command EnableMouseCapture where
  writeAnsi self f := f.putStr <|
    -- Normal tracking: Send mouse X & Y on button press and release
    csi "?1000h" ++
    -- Button-event tracking: Report button motion events (dragging)
    csi "?1002h" ++
    -- Any-event tracking: Report all motion events
    csi "?1003h" ++
    -- RXVT mouse mode: Allows mouse coordinates of >223
    csi "?1005h" ++
    -- SGR mouse mode: Allows mouse coordinates of >223, preferred over RXVT mode
    csi "?1006h"

/--
  A command that disables mouse event capturing.

  Mouse events can be captured with `read`/`poll`.
-/
structure DisableMouseCapture

instance : Command DisableMouseCapture where
  writeAnsi self f := f.putStr <|
    -- The inverse commands of EnableMouseCapture, in reverse order.
    csi "?1006l" ++
    csi "?1015l" ++
    csi "?1003l" ++
    csi "?1002l" ++
    csi "?1001l"

/--
  Represents an attribute.

  # Platform-specific Notes

  * Only UNIX and Windows 10 terminals do support text attributes.
  * Keep in mind that not all terminals support all attributes.
  * lean4-terminal implements almost all attributes listed in the
    [SGR parameters](https://en.wikipedia.org/wiki/ANSI_escape_code#SGR_parameters).

  | Attribute | Windows | UNIX | Notes |
  | :-- | :--: | :--: | :-- |
  | `reset` | ✓ | ✓ | |
  | `bold` | ✓ | ✓ | |
  | `dim` | ✓ | ✓ | |
  | `italic` | ? | ? | Not widely supported, sometimes treated as inverse. |
  | `underlined` | ✓ | ✓ | |
  | `slowBlink` | ? | ? | Not widely supported, sometimes treated as inverse. |
  | `rapidBlink` | ? | ? | Not widely supported. MS-DOS ANSI.SYS; 150+ per minute. |
  | `reverse` | ✓ | ✓ | |
  | `hidden` | ✓ | ✓ | Also known as Conceal. |
  | `fraktur` | ✗ | ✓ | Legible characters, but marked for deletion. |
  | `defaultForegroundColor` | ? | ? | Implementation specific (according to standard). |
  | `defaultBackgroundColor` | ? | ? | Implementation specific (according to standard). |
  | `framed` | ? | ? | Not widely supported. |
  | `encircled` | ? | ? | This should turn on the encircled attribute. |
  | `overLined` | ? | ? | This should draw a line at the top of the text. |
-/
inductive Attribute where
  | /-- Resets all the attributes. -/
    reset
  | /-- Increases the text intensity. -/
    bold
  | /-- Decreases the text intensity. -/
    dim
  | /-- Emphasises the text. -/
    italic
  | /-- Underlines the text. -/
    underlined
  | /-- Makes the text blinking (< 150 per minute). -/
    slowBlink
  | /-- Makes the text blinking (>= 150 per minute). -/
    rapidBlink
  | /-- Swaps foreground and background colors. -/
    reverse
  | /-- Hides the text (also known as Conceal). -/
    hidden
  | /-- Crosses the text. -/
    crossedOut
  | /--
      Sets the [Fraktur](https://en.wikipedia.org/wiki/Fraktur) typeface.

      Mostly used for [mathematical alphanumeric symbols](https://en.wikipedia.org/wiki/Mathematical_Alphanumeric_Symbols).
    -/
    fraktur
  | /-- Turns off the `bold` attribute. - Inconsistent - Prefer to use normalIntensity -/
    noBold
  | /-- Switches the text back to normal intensity (no bold, italic). -/
    normalIntensity
  | /-- Turns off the `Italic` attribute. -/
    noItalic
  | /-- Turns off the `Underlined` attribute. -/
    noUnderline
  | /-- Turns off the text blinking (`SlowBlink` or `RapidBlink`). -/
    noBlink
  | /-- Turns off the `Reverse` attribute. -/
    noReverse
  | /-- Turns off the `Hidden` attribute. -/
    noHidden
  | /-- Turns off the `CrossedOut` attribute. -/
    notCrossedOut
  | /-- Makes the text framed. -/
    framed
  | /-- Makes the text encircled. -/
    encircled
  | /--  Draws a line at the top of the text.. -/
    overLined
  | /-- Turns off the `Frame` and `Encircled` attributes. -/
    notFramedOrEncircled
  | /-- Turns off the `OverLined` attribute. -/
    notOverLined

/--
  Returns the SGR attribute value.

  See <https://en.wikipedia.org/wiki/ANSI_escape_code#SGR_parameters>
-/
def Attribute.sgr : Attribute → UInt16
  | Attribute.reset                 =>  0
  | Attribute.bold                  =>  1
  | Attribute.dim                   =>  2
  | Attribute.italic                =>  3
  | Attribute.underlined            =>  4
  | Attribute.slowBlink             =>  5
  | Attribute.rapidBlink            =>  6
  | Attribute.reverse               =>  7
  | Attribute.hidden                =>  8
  | Attribute.crossedOut            =>  9
  | Attribute.fraktur               => 20
  | Attribute.noBold                => 21
  | Attribute.normalIntensity       => 22
  | Attribute.noItalic              => 23
  | Attribute.noUnderline           => 24
  | Attribute.noBlink               => 25
  | Attribute.noReverse             => 27
  | Attribute.noHidden              => 28
  | Attribute.notCrossedOut         => 29
  | Attribute.framed                => 51
  | Attribute.encircled             => 52
  | Attribute.overLined             => 53
  | Attribute.notFramedOrEncircled  => 54
  | Attribute.notOverLined          => 55

/--
  Represents a color.

  # Platform-specific Notes

  The following list of 16 base colors are available for almost all terminals (Windows 7 and 8 included).

  | Light | dark |
  | :--| :--   |
  | `darkGrey` | `black` |
  | `red` | `darkRed` |
  | `green` | `darkGreen` |
  | `yellow` | `darkYellow` |
  | `blue` | `darkBlue` |
  | `magenta` | `darkMagenta` |
  | `cyan` | `darkCyan` |
  | `white` | `grey` |

  Most UNIX terminals and Windows 10 consoles support additional colors.
  See `Color.rgb` or `Color.ansiValue` for more info.
-/
inductive Color where
  | /-- Resets the terminal color. -/
    reset
  | /-- Black color. -/
    black
  | /-- Dark grey color. -/
    darkGrey
  | /-- Light red color. -/
    red
  | /-- Dark red color. -/
    darkRed
  | /-- Light green color. -/
    green
  | /-- Dark green color. -/
    darkGreen
  | /-- Light yellow color. -/
    yellow
  | /-- Dark yellow color. -/
    darkYellow
  | /-- Light blue color. -/
    blue
  | /-- Dark blue color. -/
    darkBlue
  | /-- Light magenta color. -/
    magenta
  | /-- Dark magenta color. -/
    darkMagenta
  | /-- Light cyan color. -/
    cyan
  | /-- Dark cyan color. -/
    darkCyan
  | /-- White color. -/
    white
  | /-- Grey color. -/
    grey
  | /--
      An RGB color. See [RGB color model](https://en.wikipedia.org/wiki/RGB_color_model) for more info.

      Most UNIX terminals and Windows 10 supported only.
      See Platform-specific notes for more info.
      -/
    rgb (r g b : UInt8) : Color
  | /--
      An ANSI color. See [256 colors - cheat sheet](https://jonasjacek.github.io/colors/) for more info.

      Most UNIX terminals and Windows 10 supported only.
      See Platform-specific notes for more info. -/
  ansiValue : UInt8 → Color

/--
  Represents a foreground or background color.
-/
inductive Colored
  | /-- A foreground color. -/
    foregroundColor : Color → Colored
  | /-- A background color. -/
    backgroundColor : Color → Colored

def Colored.toString (colored : Colored) : String :=
  match colored with
  | Colored.foregroundColor c =>
    match c with
    | Color.reset => "39"
    | Color.black => fg "5;0"
    | Color.darkGrey => fg "5;8"
    | Color.red => fg "5;9"
    | Color.darkRed => fg "5;1"
    | Color.green => fg "5;10"
    | Color.darkGreen => fg "5;2"
    | Color.yellow => fg "5;11"
    | Color.darkYellow => fg "5;3"
    | Color.blue => fg "5;12"
    | Color.darkBlue => fg "5;4"
    | Color.magenta => fg "5;13"
    | Color.darkMagenta => fg "5;5"
    | Color.cyan => fg "5;14"
    | Color.darkCyan => fg "5;6"
    | Color.white => fg "5;15"
    | Color.grey => fg "5;7"
    | Color.rgb r g b => fg s!"2;{r};{g};{b}"
    | Color.ansiValue v => fg s!"5;{v}"
  | Colored.backgroundColor c =>
    match c with
    | Color.reset => "49"
    | Color.black => bg "5;0"
    | Color.darkGrey => bg "5;8"
    | Color.red => bg "5;9"
    | Color.darkRed => bg "5;1"
    | Color.green => bg "5;10"
    | Color.darkGreen => bg "5;2"
    | Color.yellow => bg "5;11"
    | Color.darkYellow => bg "5;3"
    | Color.blue => bg "5;12"
    | Color.darkBlue => bg "5;4"
    | Color.magenta => bg "5;13"
    | Color.darkMagenta => bg "5;5"
    | Color.cyan => bg "5;14"
    | Color.darkCyan => bg "5;6"
    | Color.white => bg "5;15"
    | Color.grey => bg "5;7"
    | Color.rgb r g b => bg s!"2;{r};{g};{b}"
    | Color.ansiValue v => bg s!"5;{v}"
  where
    fg s := "38;" ++ s
    bg s := "48;" ++ s

instance : ToString Colored := ⟨ Colored.toString ⟩

/--
  Returns available color count.

  # Notes

  - This does not always provide a good result.
-/
def availableColorCount : IO UInt16 := do
  let term ← IO.getEnv "TERM"
  return match term with
  | some x => if "256color".isInfixOf x then 256 else 8
  | _      => 8

/--
  A command that sets the the foreground color.
  See `Color` for more info.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure SetForegroundColor := (c : Color)

instance : Command SetForegroundColor where
  writeAnsi self f := f.putStr <| csi s!"{Colored.foregroundColor self.c}m"

/--
  A command that sets the the background color.

  See `Color` for more info.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure SetBackgroundColor := (c : Color)

instance : Command SetBackgroundColor where
  writeAnsi self f := f.putStr <| csi s!"{Colored.backgroundColor self.c}m"

/--
  A command that prints the given displayable type.

  ## Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure Print (α : Type u) [ToString α] := (s : α)

instance [inst: ToString α] : Command (Print α) where
  writeAnsi self f := f.putStr <| ToString.toString self.s

/--
  A command that resets the colors back to default.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure ResetColor

instance : Command ResetColor where
  writeAnsi self f := f.putStr <| csi "0m"

/--
  A command that sets an attribute.

  See `Attribute` for more info.

  # Notes

  - Commands must be executed/queued for execution otherwise they do nothing.
-/
structure SetAttribute := (a : Attribute)

instance : Command SetAttribute where
  writeAnsi self f := f.putStr <| csi s!"{self.a.sgr}m"

/-- Different ways to clear the terminal buffer. -/
inductive ClearType
  | /-- All cells. -/
    all
  | /-- All plus history. -/
    purge
  | /-- All cells from the cursor position downwards. -/
    fromCursorDown
  | /-- All cells from the cursor position upwards. -/
    fromCursorUp
  | /-- All cells at the cursor row. -/
    currentLine
  | /-- All cells from the cursor position until the new line. -/
    untilNewLine

/--
  A command that clears the terminal screen buffer.

  See the `ClearType` enum.

  # Notes

  Commands must be executed/queued for execution otherwise they do nothing.
-/
structure Clear := (t : ClearType)

instance : Command Clear where
  writeAnsi self f := f.putStr <| csi <|
    match self.t with
    | ClearType.all             => "2J"
    | ClearType.purge           => "3J"
    | ClearType.fromCursorDown  => "J"
    | ClearType.fromCursorUp    => "1J"
    | ClearType.currentLine     => "2K"
    | ClearType.untilNewLine    => "K"

/-- Disables line wrapping. -/
structure DisableLineWrap

instance : Command DisableLineWrap where
  writeAnsi self f := f.putStr <| csi "?7l"

/-- Enable line wrapping. -/
structure EnableLineWrap

instance : Command EnableLineWrap where
  writeAnsi self f := f.putStr <| csi "?7h"

/--
  A command that switches to alternate screen.

  # Notes

  * Commands must be executed/queued for execution otherwise they do nothing.
  * Use `LeaveAlternateScreen` command to leave the entered alternate screen.
-/
structure EnterAlternateScreen

instance : Command EnterAlternateScreen where
  writeAnsi self f := f.putStr <| csi "?1049h"

/--
  A command that switches back to the main screen.

  # Notes

  * Commands must be executed/queued for execution otherwise they do nothing.
  * Use `EnterAlternateScreen` to enter the alternate screen.

-/
structure LeaveAlternateScreen

instance : Command LeaveAlternateScreen where
  writeAnsi self f := f.putStr <| csi "?1049l"

/--
  A command that scrolls the terminal screen a given number of rows down.

  # Notes

  Commands must be executed/queued for execution otherwise they do nothing.
-/
structure ScrollDown := (n : UInt16)

instance : Command ScrollDown where
  writeAnsi self f := f.putStr <| csi s!"{self.n}T"

/--
  A command that scrolls the terminal screen a given number of rows up.

  # Notes

  Commands must be executed/queued for execution otherwise they do nothing.
-/
structure ScrollUp := (n : UInt16)

instance : Command ScrollUp where
  writeAnsi self f := f.putStr <| csi s!"{self.n}S"

/--
  A command that sets the terminal size `(columns, rows)`.

  # Notes

  Commands must be executed/queued for execution otherwise they do nothing.
-/
structure SetSize := (c r : UInt16)

instance : Command SetSize where
  writeAnsi self f := f.putStr <| csi s!"8;{self.r};{self.c}t"

/--
  A command that sets the terminal title

  # Notes

  Commands must be executed/queued for execution otherwise they do nothing.
-/
structure SetTitle (α : Type u) [ToString α] := (s : α)

instance [inst: ToString α] : Command (SetTitle α) where
  writeAnsi self f := f.putStr <| csi s!"\x1B]0;{ToString.toString self.s}\x07"

@[extern "lean_disable_raw_mode"]
constant disableRawMode.prim : Unit → IO Unit

/-- Disables raw mode. -/
def disableRawMode : IO Unit := disableRawMode.prim ()

@[extern "lean_enable_raw_mode"]
constant enableRawMode.prim : Unit → IO Unit

/-- Enables raw mode. -/
def enableRawMode : IO Unit := enableRawMode.prim ()

@[extern "lean_is_raw_mode_enabled"]
constant isRawModeEnabled.prim : Unit → IO Bool

/-- Tells whether the raw mode is enabled. -/
def isRawModeEnabled : IO Bool := isRawModeEnabled.prim ()

@[extern "lean_get_is_tty"]
private constant isTty.prim : Unit → IO Bool

/--
  Returns true when we are in a terminal, otherwise false.
-/
def isTty : IO Bool := isTty.prim ()

@[extern "lean_get_size"]
private constant size.prim : Unit → IO (UInt16 × UInt16)

/--
  Returns the terminal size `(columns, rows)`.
-/
def size : IO (UInt16 × UInt16) := size.prim ()

/-- Queues the given command for further execution. -/
def queue [Terminal.Command α] (cs : Array α) : IO Unit := do
  cs.forM (Terminal.Command.writeAnsi · (← IO.getStdout))

/-- Executes the given command directly. -/
def execute [Terminal.Command α] (cs : Array α) : IO Unit := do
  let out ← IO.getStdout
  cs.forM (Terminal.Command.writeAnsi · out)
  out.flush

end Terminal


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

namespace Lean
namespace Parser

/-- Syntax quotation for terms. -/
@[builtin_term_parser] def Term.quot := leading_parser
  "`(" >> withoutPosition (incQuotDepth termParser) >> ")"
@[builtin_term_parser] def Term.precheckedQuot := leading_parser
  "`" >> Term.quot

namespace Command

/--
Syntax quotation for (sequences of) commands.
The identical syntax for term quotations takes priority,
so ambiguous quotations like `` `($x $y) `` will be parsed as an application,
not two commands. Use `` `($x:command $y:command) `` instead.
Multiple commands will be put in a `` `null `` node,
but a single command will not (so that you can directly
match against a quotation in a command kind's elaborator). -/
@[builtin_term_parser low] def quot := leading_parser
  "`(" >> withoutPosition (incQuotDepth (many1Unbox commandParser)) >> ")"

/-
A mutual block may be broken in different cliques,
we identify them using an `ident` (an element of the clique).
We provide two kinds of hints to the termination checker:
1- A wellfounded relation (`p` is `termParser`)
2- A tactic for proving the recursive applications are "decreasing" (`p` is `tacticSeq`)
-/
def terminationHintMany (p : Parser) := leading_parser
  atomic (lookahead (ident >> " => ")) >>
  many1Indent (group (ppLine >> ident >> " => " >> p >> optional ";"))
def terminationHint1 (p : Parser) := leading_parser p
def terminationHint (p : Parser) := terminationHintMany p <|> terminationHint1 p

def terminationByCore := leading_parser
  "termination_by' " >> terminationHint termParser
def decreasingBy := leading_parser
  "decreasing_by " >> terminationHint Tactic.tacticSeq

def terminationByElement   := leading_parser
  ppLine >> (ident <|> Term.hole) >> many (ident <|> Term.hole) >>
  " => " >> termParser >> optional ";"
def terminationBy          := leading_parser
  ppLine >> "termination_by " >> many1Indent terminationByElement

def terminationSuffix :=
  optional (terminationBy <|> terminationByCore) >> optional decreasingBy

@[builtin_command_parser]
def moduleDoc := leading_parser ppDedent <|
  "/-!" >> commentBody >> ppLine

def namedPrio := leading_parser
  atomic ("(" >> nonReservedSymbol "priority") >> " := " >> withoutPosition priorityParser >> ")"
def optNamedPrio := optional (ppSpace >> namedPrio)

def «private»        := leading_parser "private "
def «protected»      := leading_parser "protected "
def visibility       := «private» <|> «protected»
def «noncomputable»  := leading_parser "noncomputable "
def «unsafe»         := leading_parser "unsafe "
def «partial»        := leading_parser "partial "
def «nonrec»         := leading_parser "nonrec "
def declModifiers (inline : Bool) := leading_parser
  optional docComment >>
  optional (Term.«attributes» >> if inline then skip else ppDedent ppLine) >>
  optional visibility >>
  optional «noncomputable» >>
  optional «unsafe» >>
  optional («partial» <|> «nonrec»)
def declId           := leading_parser
  ident >> optional (".{" >> sepBy1 ident ", " >> "}")
def declSig          := leading_parser
  many (ppSpace >> (Term.binderIdent <|> Term.bracketedBinder)) >> Term.typeSpec
def optDeclSig       := leading_parser
  many (ppSpace >> (Term.binderIdent <|> Term.bracketedBinder)) >> Term.optType
def declValSimple    := leading_parser
  " :=" >> ppHardLineUnlessUngrouped >> termParser >> optional Term.whereDecls
def declValEqns      := leading_parser
  Term.matchAltsWhereDecls
def whereStructField := leading_parser
  Term.letDecl
def whereStructInst  := leading_parser
  ppIndent ppSpace >> "where" >> sepByIndent (ppGroup whereStructField) "; " (allowTrailingSep := true) >>
  optional Term.whereDecls
/-
  Remark: we should not use `Term.whereDecls` at `declVal`
  because `Term.whereDecls` is defined using `Term.letRecDecl` which may contain attributes.
  Issue #753 showns an example that fails to be parsed when we used `Term.whereDecls`.
-/
def declVal          :=
  withAntiquot (mkAntiquot "declVal" `Lean.Parser.Command.declVal (isPseudoKind := true)) <|
    declValSimple <|> declValEqns <|> whereStructInst
def «abbrev»         := leading_parser
  "abbrev " >> declId >> ppIndent optDeclSig >> declVal >> terminationSuffix
def optDefDeriving   :=
  optional (atomic ("deriving " >> notSymbol "instance") >> sepBy1 ident ", ")
def «def»            := leading_parser
  "def " >> declId >> ppIndent optDeclSig >> declVal >> optDefDeriving >> terminationSuffix
def «theorem»        := leading_parser
  "theorem " >> declId >> ppIndent declSig >> declVal >> terminationSuffix
def «opaque»         := leading_parser
  "opaque " >> declId >> ppIndent declSig >> optional declValSimple
/- As `declSig` starts with a space, "instance" does not need a trailing space
  if we put `ppSpace` in the optional fragments. -/
def «instance»       := leading_parser
  Term.attrKind >> "instance" >> optNamedPrio >>
  optional (ppSpace >> declId) >> ppIndent declSig >> declVal >> terminationSuffix
def «axiom»          := leading_parser
  "axiom " >> declId >> ppIndent declSig
/- As `declSig` starts with a space, "example" does not need a trailing space. -/
def «example»        := leading_parser
  "example" >> ppIndent optDeclSig >> declVal
def ctor             := leading_parser
  atomic (optional docComment >> "\n| ") >>
  ppGroup (declModifiers true >> rawIdent >> optDeclSig)
def derivingClasses  := sepBy1 (group (ident >> optional (" with " >> Term.structInst))) ", "
def optDeriving      := leading_parser
  optional (ppLine >> atomic ("deriving " >> notSymbol "instance") >> derivingClasses)
def computedField    := leading_parser
  declModifiers true >> ident >> " : " >> termParser >> Term.matchAlts
def computedFields   := leading_parser
  "with" >> manyIndent (ppLine >> ppGroup computedField)
/--
In Lean, every concrete type other than the universes
and every type constructor other than dependent arrows
is an instance of a general family of type constructions known as inductive types.
It is remarkable that it is possible to construct a substantial edifice of mathematics
based on nothing more than the type universes, dependent arrow types, and inductive types;
everything else follows from those.
Intuitively, an inductive type is built up from a specified list of constructor.
For example, `List α` is the list of elements of type `α`, and is defined as follows:
```
inductive List (α : Type u) where
| nil
| cons (head : α) (tail : List α)
```
A list of elements of type `α` is either the empty list, `nil`,
or an element `head : α` followed by a list `tail : List α`.
For more information about [inductive types](https://leanprover.github.io/theorem_proving_in_lean4/inductive_types.html).
-/
def «inductive»      := leading_parser
  "inductive " >> declId >> optDeclSig >> optional (symbol " :=" <|> " where") >>
  many ctor >> optional (ppDedent ppLine >> computedFields) >> optDeriving
def classInductive   := leading_parser
  atomic (group (symbol "class " >> "inductive ")) >>
  declId >> ppIndent optDeclSig >>
  optional (symbol " :=" <|> " where") >> many ctor >> optDeriving
def structExplicitBinder := leading_parser
  atomic (declModifiers true >> "(") >>
  withoutPosition (many1 ident >> ppIndent optDeclSig >>
    optional (Term.binderTactic <|> Term.binderDefault)) >> ")"
def structImplicitBinder := leading_parser
  atomic (declModifiers true >> "{") >> withoutPosition (many1 ident >> declSig) >> "}"
def structInstBinder     := leading_parser
  atomic (declModifiers true >> "[") >> withoutPosition (many1 ident >> declSig) >> "]"
def structSimpleBinder   := leading_parser
  atomic (declModifiers true >> ident) >> optDeclSig >>
  optional (Term.binderTactic <|> Term.binderDefault)
def structFields         := leading_parser
  manyIndent <|
    ppLine >> checkColGe >> ppGroup (
      structExplicitBinder <|> structImplicitBinder <|>
      structInstBinder <|> structSimpleBinder)
def structCtor           := leading_parser
  atomic (declModifiers true >> ident >> " :: ")
def structureTk          := leading_parser
  "structure "
def classTk              := leading_parser
  "class "
def «extends»            := leading_parser
  " extends " >> sepBy1 termParser ", "
def «structure»          := leading_parser
    (structureTk <|> classTk) >>
    declId >> many (ppSpace >> Term.bracketedBinder) >>
    optional «extends» >> Term.optType >>
    optional ((symbol " := " <|> " where ") >> optional structCtor >> structFields) >>
    optDeriving
@[builtin_command_parser] def declaration := leading_parser
  declModifiers false >>
  («abbrev» <|> «def» <|> «theorem» <|> «opaque» <|> «instance» <|> «axiom» <|> «example» <|>
   «inductive» <|> classInductive <|> «structure»)
@[builtin_command_parser] def «deriving»     := leading_parser
  "deriving " >> "instance " >> derivingClasses >> " for " >> sepBy1 ident ", "
@[builtin_command_parser] def noncomputableSection := leading_parser
  "noncomputable " >> "section " >> optional ident
@[builtin_command_parser] def «section»      := leading_parser
  "section " >> optional ident
@[builtin_command_parser] def «namespace»    := leading_parser
  "namespace " >> ident
@[builtin_command_parser] def «end»          := leading_parser
  "end " >> optional ident
@[builtin_command_parser] def «variable»     := leading_parser
  "variable" >> many1 (ppSpace >> Term.bracketedBinder)
@[builtin_command_parser] def «universe»     := leading_parser
  "universe " >> many1 ident
@[builtin_command_parser] def check          := leading_parser
  "#check " >> termParser
@[builtin_command_parser] def check_failure  := leading_parser
  "#check_failure " >> termParser -- Like `#check`, but succeeds only if term does not type check
@[builtin_command_parser] def reduce         := leading_parser
  "#reduce " >> termParser
@[builtin_command_parser] def eval           := leading_parser
  "#eval " >> termParser
@[builtin_command_parser] def synth          := leading_parser
  "#synth " >> termParser
@[builtin_command_parser] def exit           := leading_parser
  "#exit"
@[builtin_command_parser] def print          := leading_parser
  "#print " >> (ident <|> strLit)
@[builtin_command_parser] def printAxioms    := leading_parser
  "#print " >> nonReservedSymbol "axioms " >> ident
@[builtin_command_parser] def «init_quot»    := leading_parser
  "init_quot"
def optionValue := nonReservedSymbol "true" <|> nonReservedSymbol "false" <|> strLit <|> numLit
@[builtin_command_parser] def «set_option»   := leading_parser
  "set_option " >> ident >> ppSpace >> optionValue
def eraseAttr := leading_parser
  "-" >> rawIdent
@[builtin_command_parser] def «attribute»    := leading_parser
  "attribute " >> "[" >>
    withoutPosition (sepBy1 (eraseAttr <|> Term.attrInstance) ", ") >>
  "] " >> many1 ident
@[builtin_command_parser] def «export»       := leading_parser
  "export " >> ident >> " (" >> many1 ident >> ")"
@[builtin_command_parser] def «import»       := leading_parser
  "import" -- not a real command, only for error messages
def openHiding       := leading_parser
  atomic (ident >> "hiding") >> many1 (checkColGt >> ident)
def openRenamingItem := leading_parser
  ident >> unicodeSymbol " → " " -> " >> checkColGt >> ident
def openRenaming     := leading_parser
  atomic (ident >> "renaming") >> sepBy1 openRenamingItem ", "
def openOnly         := leading_parser
  atomic (ident >> " (") >> many1 ident >> ")"
def openSimple       := leading_parser
  many1 (checkColGt >> ident)
def openScoped       := leading_parser
  "scoped " >> many1 (checkColGt >> ident)
def openDecl         :=
  withAntiquot (mkAntiquot "openDecl" `Lean.Parser.Command.openDecl (isPseudoKind := true)) <|
    openHiding <|> openRenaming <|> openOnly <|> openSimple <|> openScoped
@[builtin_command_parser] def «open»    := leading_parser
  withPosition ("open " >> openDecl)

@[builtin_command_parser] def «mutual» := leading_parser
  "mutual " >> many1 (ppLine >> notSymbol "end" >> commandParser) >>
  ppDedent (ppLine >> "end") >> terminationSuffix
def initializeKeyword := leading_parser
  "initialize " <|> "builtin_initialize "
@[builtin_command_parser] def «initialize» := leading_parser
  declModifiers false >> initializeKeyword >>
  optional (atomic (ident >> Term.typeSpec >> Term.leftArrow)) >> Term.doSeq

@[builtin_command_parser] def «in»  := trailing_parser withOpen (" in " >> commandParser)

@[builtin_command_parser] def addDocString := leading_parser
  docComment >> "add_decl_doc" >> ident

/--
  This is an auxiliary command for generation constructor injectivity theorems for
  inductive types defined at `Prelude.lean`.
  It is meant for bootstrapping purposes only. -/
@[builtin_command_parser] def genInjectiveTheorems := leading_parser
  "gen_injective_theorems% " >> ident

/-- No-op parser used as syntax kind for attaching remaining whitespace to at the end of the input. -/
@[run_builtin_parser_attribute_hooks] def eoi : Parser := leading_parser ""

builtin_initialize
  registerBuiltinNodeKind ``eoi

@[run_builtin_parser_attribute_hooks] abbrev declModifiersF := declModifiers false
@[run_builtin_parser_attribute_hooks] abbrev declModifiersT := declModifiers true

builtin_initialize
  register_parser_alias (kind := ``declModifiers) "declModifiers"       declModifiersF
  register_parser_alias (kind := ``declModifiers) "nestedDeclModifiers" declModifiersT
  register_parser_alias                                                 declId
  register_parser_alias                                                 declSig
  register_parser_alias                                                 declVal
  register_parser_alias                                                 optDeclSig
  register_parser_alias                                                 openDecl
  register_parser_alias                                                 docComment

end Command

namespace Term
/--
`open Foo in e` is like `open Foo` but scoped to a single term.
It makes the given namespaces available in the term `e`.
-/
@[builtin_term_parser] def «open» := leading_parser:leadPrec
  "open " >> Command.openDecl >> withOpenDecl (" in " >> termParser)

/--
`set_option opt val in e` is like `set_option opt val` but scoped to a single term.
It sets the option `opt` to the value `val` in the term `e`.
-/
@[builtin_term_parser] def «set_option» := leading_parser:leadPrec
  "set_option " >> ident >> ppSpace >> Command.optionValue >> " in " >> termParser
end Term

namespace Tactic
/-- `open Foo in tacs` (the tactic) acts like `open Foo` at command level,
but it opens a namespace only within the tactics `tacs`. -/
@[builtin_tactic_parser] def «open» := leading_parser:leadPrec
  "open " >> Command.openDecl >> withOpenDecl (" in " >> tacticSeq)

/-- `set_option opt val in tacs` (the tactic) acts like `set_option opt val` at the command level,
but it sets the option only within the tactics `tacs`. -/
@[builtin_tactic_parser] def «set_option» := leading_parser:leadPrec
  "set_option " >> ident >> ppSpace >> Command.optionValue >> " in " >> tacticSeq
end Tactic

end Parser
end Lean


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Tactic.Constructor
import Lean.Meta.Tactic.Assert
import Lean.Meta.Tactic.Clear
import Lean.Meta.Tactic.Rename
import Lean.Elab.Tactic.Basic
import Lean.Elab.SyntheticMVars

namespace Lean.Elab.Tactic
open Meta

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

/--
Runs a term elaborator inside a tactic.

This function ensures that term elaboration fails when backtracking,
i.e., in `first| tac term | other`.
-/
def runTermElab (k : TermElabM α) (mayPostpone := false) : TacticM α := do
  /- If error recovery is disabled, we disable `Term.withoutErrToSorry` -/
  if (← read).recover then
    go
  else
    Term.withoutErrToSorry go
where
  go := k <* Term.synthesizeSyntheticMVars (mayPostpone := mayPostpone)

/-- Elaborate `stx` in the current `MVarContext`. If given, the `expectedType` will be used to help
elaboration but not enforced (use `elabTermEnsuringType` to enforce an expected type). -/
def elabTerm (stx : Syntax) (expectedType? : Option Expr) (mayPostpone := false) : TacticM Expr :=
  withRef stx do instantiateMVars <| ← runTermElab (mayPostpone := mayPostpone) do
    Term.elabTerm stx expectedType?

/-- Elaborate `stx` in the current `MVarContext`. If given, the `expectedType` will be used to help
elaboration and then a `TypeMismatchError` will be thrown if the elaborated type doesn't match.  -/
def elabTermEnsuringType (stx : Syntax) (expectedType? : Option Expr) (mayPostpone := false) : TacticM Expr := do
  let e ← elabTerm stx expectedType? mayPostpone
  -- We do use `Term.ensureExpectedType` because we don't want coercions being inserted here.
  match expectedType? with
  | none => return e
  | some expectedType =>
    let eType ← inferType e
    -- We allow synthetic opaque metavars to be assigned in the following step since the `isDefEq` is not really
    -- part of the elaboration, but part of the tactic. See issue #492
    unless (← withAssignableSyntheticOpaque <| isDefEq eType expectedType) do
      Term.throwTypeMismatchError none expectedType eType e
    return e

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

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

def filterOldMVars (mvarIds : Array MVarId) (mvarCounterSaved : Nat) : MetaM (Array MVarId) := do
  let mctx ← getMCtx
  return mvarIds.filter fun mvarId => (mctx.getDecl mvarId |>.index) >= mvarCounterSaved

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

def sortMVarIdArrayByIndex [MonadMCtx m] [Monad m] (mvarIds : Array MVarId) : m (Array MVarId) := do
  let mctx ← getMCtx
  return mvarIds.qsort fun mvarId₁ mvarId₂ =>
    let decl₁ := mctx.getDecl mvarId₁
    let decl₂ := mctx.getDecl mvarId₂
    if decl₁.index != decl₂.index then
      decl₁.index < decl₂.index
    else
      Name.quickLt mvarId₁.name mvarId₂.name

def sortMVarIdsByIndex [MonadMCtx m] [Monad m] (mvarIds : List MVarId) : m (List MVarId) :=
  return (← sortMVarIdArrayByIndex mvarIds.toArray).toList

/--
  Execute `k`, and collect new "holes" in the resulting expression.
-/
def withCollectingNewGoalsFrom (k : TacticM Expr) (tagSuffix : Name) (allowNaturalHoles := false) : TacticM (Expr × List MVarId) :=
  /-
  When `allowNaturalHoles = true`, unassigned holes should become new metavariables, including `_`s.
  Thus, we set `holesAsSynthethicOpaque` to true if it is not already set to `true`.
  See issue #1681. We have the tactic
  ```
  `refine' (fun x => _)
  ```
  If we create a natural metavariable `?m` for `_` with type `Nat`, then when we try to abstract `x`,
  a new metavariable `?n` with type `Nat -> Nat` is created, and we assign `?m := ?n x`,
  and the resulting term is `fun x => ?n x`. Then, `getMVarsNoDelayed` would return `?n` as a new goal
  which would be confusing since it has type `Nat -> Nat`.
  -/
  if allowNaturalHoles then
    withTheReader Term.Context (fun ctx => { ctx with holesAsSyntheticOpaque := ctx.holesAsSyntheticOpaque || allowNaturalHoles }) do
      /-
      We also enable the assignment of synthetic metavariables, otherwise we will fail to
      elaborate terms such as `f _ x` where `f : (α : Type) → α → α` and `x : A`.

      IMPORTANT: This is not a perfect solution. For example, `isDefEq` will be able assign metavariables associated with `by ...`.
      This should not be an immediate problem since this feature is only used to implement `refine'`. If it becomes
      an issue in practice, we should add a new kind of opaque metavariable for `refine'`, and mark the holes created using `_`
      with it, and have a flag that allows us to assign this kind of metavariable, but prevents us from assigning metavariables
      created by the `by ...` notation.
      -/
      withAssignableSyntheticOpaque go
  else
    go
where
  go := do
    let mvarCounterSaved := (← getMCtx).mvarCounter
    let val ← k
    let newMVarIds ← getMVarsNoDelayed val
    /- ignore let-rec auxiliary variables, they are synthesized automatically later -/
    let newMVarIds ← newMVarIds.filterM fun mvarId => return !(← Term.isLetRecAuxMVar mvarId)
    let newMVarIds ← if allowNaturalHoles then
      pure newMVarIds.toList
    else
      let naturalMVarIds ← newMVarIds.filterM fun mvarId => return (← mvarId.getKind).isNatural
      let syntheticMVarIds ← newMVarIds.filterM fun mvarId => return !(← mvarId.getKind).isNatural
      let naturalMVarIds ← filterOldMVars naturalMVarIds mvarCounterSaved
      logUnassignedAndAbort naturalMVarIds
      pure syntheticMVarIds.toList
    /-
    We sort the new metavariable ids by index to ensure the new goals are ordered using the order the metavariables have been created.
    See issue #1682.
    Potential problem: if elaboration of subterms is delayed the order the new metavariables are created may not match the order they
    appear in the `.lean` file. We should tell users to prefer tagged goals.
    -/
    let newMVarIds ← sortMVarIdsByIndex newMVarIds
    tagUntaggedGoals (← getMainTag) tagSuffix newMVarIds
    return (val, newMVarIds)

def elabTermWithHoles (stx : Syntax) (expectedType? : Option Expr) (tagSuffix : Name) (allowNaturalHoles := false) : TacticM (Expr × List MVarId) := do
  withCollectingNewGoalsFrom (elabTermEnsuringType stx expectedType?) tagSuffix allowNaturalHoles

/-- If `allowNaturalHoles == true`, then we allow the resultant expression to contain unassigned "natural" metavariables.
   Recall that "natutal" metavariables are created for explicit holes `_` and implicit arguments. They are meant to be
   filled by typing constraints.
   "Synthetic" metavariables are meant to be filled by tactics and are usually created using the synthetic hole notation `?<hole-name>`. -/
def refineCore (stx : Syntax) (tagSuffix : Name) (allowNaturalHoles : Bool) : TacticM Unit := do
  withMainContext do
    let (val, mvarIds') ← elabTermWithHoles stx (← getMainTarget) tagSuffix allowNaturalHoles
    let mvarId ← getMainGoal
    let val ← instantiateMVars val
    unless val == mkMVar mvarId do
      if val.findMVar? (· == mvarId) matches some _ then
        throwError "'refine' tactic failed, value{indentExpr val}\ndepends on the main goal metavariable '{mkMVar mvarId}'"
      mvarId.assign val
    replaceMainGoal mvarIds'

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

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

@[builtin_tactic «specialize»] def evalSpecialize : Tactic := fun stx => withMainContext do
  match stx with
  | `(tactic| specialize $e:term) =>
    let (e, mvarIds') ← elabTermWithHoles e none `specialize (allowNaturalHoles := true)
    let h := e.getAppFn
    if h.isFVar then
      let localDecl ← h.fvarId!.getDecl
      let mvarId ← (← getMainGoal).assert localDecl.userName (← inferType e).headBeta e
      let (_, mvarId) ← mvarId.intro1P
      let mvarId ← mvarId.tryClear h.fvarId!
      replaceMainGoal (mvarIds' ++ [mvarId])
    else
      throwError "'specialize' requires a term of the form `h x_1 .. x_n` where `h` appears in the local context"
  | _ => throwUnsupportedSyntax

/--
   Given a tactic
   ```
   apply f
   ```
   we want the `apply` tactic to create all metavariables. The following
   definition will return `@f` for `f`. That is, it will **not** create
   metavariables for implicit arguments.
   A similar method is also used in Lean 3.
   This method is useful when applying lemmas such as:
   ```
   theorem infLeRight {s t : Set α} : s ⊓ t ≤ t
   ```
   where `s ≤ t` here is defined as
   ```
   ∀ {x : α}, x ∈ s → x ∈ t
   ```
-/
def elabTermForApply (stx : Syntax) (mayPostpone := true) : TacticM Expr := do
  if stx.isIdent then
    match (← Term.resolveId? stx (withInfo := true)) with
    | some e => return e
    | _      => pure ()
  /-
    By disabling the "error recovery" (and consequently "error to sorry") feature,
    we make sure an `apply e` fails without logging an error message.
    The motivation is that `apply` is frequently used when writing tactic such as
    ```
    cases h <;> intro h' <;> first | apply t[h'] | ....
    ```
    Here the type of `h'` may be different in each case, and the term `t[h']` containing `h'` may even fail to
    be elaborated in some cases. When this happens we want the tactic to fail without reporting any error to the user,
    and the next tactic is tried.

    A drawback of disabling "error to sorry" is that there is no error recovery after the error is thrown, and features such
    as auto-completion are affected.

    By disabling "error to sorry", we also limit ourselves to at most one error at `t[h']`.

    By disabling "error to sorry", we also miss the opportunity to catch mistakes is tactic code such as
      `first | apply nonsensical-term | assumption`

    This should not be a big problem for the `apply` tactic since we usually provide small terms there.

    Note that we do not disable "error to sorry" at `exact` and `refine` since they are often used to elaborate big terms,
    and we do want error recovery there, and we want to see the error messages.

    We should probably provide options for allowing users to control this behavior.

    see issue #1037

    More complex solution:
      - We do not disable "error to sorry"
      - We elaborate term and check whether errors were produced
      - If there are other tactic braches and there are errors, we remove the errors from the log, and throw a new error to force the tactic to backtrack.
  -/
  withoutRecover <| elabTerm stx none mayPostpone

def getFVarId (id : Syntax) : TacticM FVarId := withRef id do
  -- use apply-like elaboration to suppress insertion of implicit arguments
  let e ← withMainContext do
    elabTermForApply id (mayPostpone := false)
  match e with
  | Expr.fvar fvarId => return fvarId
  | _                => throwError "unexpected term '{e}'; expected single reference to variable"

def getFVarIds (ids : Array Syntax) : TacticM (Array FVarId) := do
  withMainContext do ids.mapM getFVarId

def evalApplyLikeTactic (tac : MVarId → Expr → MetaM (List MVarId)) (e : Syntax) : TacticM Unit := do
  withMainContext do
    let mut val ← instantiateMVars (← elabTermForApply e)
    if val.isMVar then
      /-
      If `val` is a metavariable, we force the elaboration of postponed terms.
      This is useful for producing a more useful error message in examples such as
      ```
      example (h : P) : P ∨ Q := by
        apply .inl
      ```
      Recall that `apply` elaborates terms without using the expected type,
      and the notation `.inl` requires the expected type to be available.
      -/
      Term.synthesizeSyntheticMVarsNoPostponing
      val ← instantiateMVars val
    let mvarIds' ← tac (← getMainGoal) val
    Term.synthesizeSyntheticMVarsNoPostponing
    replaceMainGoal mvarIds'

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

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

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

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

@[builtin_tactic Lean.Parser.Tactic.withUnfoldingAll] def evalWithUnfoldingAll : Tactic := fun stx =>
  withTransparency TransparencyMode.all <| evalTactic stx[1]

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

@[builtin_tactic Lean.Parser.Tactic.rename] def evalRename : Tactic := fun stx =>
  match stx with
  | `(tactic| rename $typeStx:term => $h:ident) => do
    withMainContext do
      /- Remark: we also use `withoutRecover` to make sure `elabTerm` does not succeed
         using `sorryAx`, and we get `"failed to find ..."` which will not be logged because
         it contains synthetic sorry's -/
      let fvarId ← withoutModifyingState <| withNewMCtxDepth <| withoutRecover do
        let type ← elabTerm typeStx none (mayPostpone := true)
        let fvarId? ← (← getLCtx).findDeclRevM? fun localDecl => do
          if (← isDefEq type localDecl.type) then return localDecl.fvarId else return none
        match fvarId? with
        | none => throwError "failed to find a hypothesis with type{indentExpr type}"
        | some fvarId => return fvarId
      replaceMainGoal [← (← getMainGoal).rename fvarId h.getId]
  | _ => throwUnsupportedSyntax

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

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

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

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

end Lean.Elab.Tactic


import tactic.local_cache

open tactic

section example_tactic

def TEST_NS : name := `my_tactic

-- Example "expensive" function
meta def generate_some_data : tactic (list ℕ) :=
do trace "cache regenerating",
   return [1, 2, 3, 4]

meta def my_tactic : tactic unit :=
do my_cached_data ← run_once TEST_NS generate_some_data,
   -- Do some stuff with `my_cached_data`
   skip

end example_tactic

section example_usage

-- Note only a single cache regeneration (only a single trace message),
-- even upon descent to a sub-tactic-block.
lemma my_lemma : true := begin
    my_tactic,
    my_tactic,
    my_tactic,

    have h : true,
    { my_tactic,
      trivial },

    trivial
end

end example_usage

section test

meta def fail_if_cache_miss : tactic unit :=
do p ← local_cache.present TEST_NS,
   if p then skip else fail "cache miss"

meta def clear_cache : tactic unit := local_cache.clear TEST_NS

lemma my_test : true := begin
    success_if_fail { fail_if_cache_miss },

    my_tactic,

    fail_if_cache_miss,
    fail_if_cache_miss,

    have h : true,
    { fail_if_cache_miss,
      trivial },

    clear_cache,
    success_if_fail { fail_if_cache_miss },

    trivial
end

end test