988 lines
34 KiB
Text
988 lines
34 KiB
Text
/-
|
||
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
|
||
-/
|
||
prelude
|
||
import Init.Data.Option.BasicAux
|
||
import Init.Data.String.Basic
|
||
import Init.Data.Array.Basic
|
||
import Init.Data.Array.ForIn
|
||
import Init.Data.UInt
|
||
import Init.Data.Hashable
|
||
import Init.Control.Reader
|
||
import Init.Control.EState
|
||
import Init.Control.StateRef
|
||
import Init.Control.Option
|
||
|
||
namespace Lean
|
||
/-
|
||
Basic Lean types used to implement builtin commands and extensions.
|
||
Note that this file is part of the Lean `Init` library instead of
|
||
`Lean` actual implementation.
|
||
The idea is to allow users to implement simple parsers, macros and tactics
|
||
without importing the whole `Lean` module.
|
||
It also allow us to use extensions to develop the `Init` library.
|
||
-/
|
||
|
||
/- 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 isSubScriptAlnum (c : Char) : Bool :=
|
||
(0x2080 ≤ c.val && c.val ≤ 0x2089) || -- numeric subscripts
|
||
(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
|
||
|
||
/- Hierarchical names -/
|
||
inductive Name
|
||
| anonymous : Name
|
||
| str : Name → String → USize → Name
|
||
| num : Name → Nat → USize → Name
|
||
|
||
instance : Inhabited Name := ⟨Name.anonymous⟩
|
||
|
||
protected def Name.hash : Name → USize
|
||
| Name.anonymous => 1723
|
||
| Name.str p s h => h
|
||
| Name.num p v h => h
|
||
|
||
instance : Hashable Name := ⟨Name.hash⟩
|
||
|
||
@[export lean_name_mk_string]
|
||
def mkNameStr (p : Name) (s : String) : Name :=
|
||
Name.str p s $ mixHash (hash p) (hash s)
|
||
|
||
@[export lean_name_mk_numeral]
|
||
def mkNameNum (p : Name) (v : Nat) : Name :=
|
||
Name.num p v $ mixHash (hash p) (hash v)
|
||
|
||
def mkNameSimple (s : String) : Name :=
|
||
mkNameStr Name.anonymous s
|
||
|
||
namespace Name
|
||
|
||
@[extern "lean_name_eq"]
|
||
protected def beq : (@& Name) → (@& Name) → Bool
|
||
| anonymous, anonymous => true
|
||
| str p₁ s₁ _, str p₂ s₂ _ => s₁ == s₂ && Name.beq p₁ p₂
|
||
| num p₁ n₁ _, num p₂ n₂ _ => n₁ == n₂ && Name.beq p₁ p₂
|
||
| _, _ => false
|
||
|
||
instance : HasBeq Name := ⟨Name.beq⟩
|
||
|
||
def toStringWithSep (sep : String) : Name → String
|
||
| anonymous => "[anonymous]"
|
||
| str anonymous s _ => s
|
||
| num anonymous v _ => toString v
|
||
| str n s _ => toStringWithSep sep n ++ sep ++ s
|
||
| num n v _ => toStringWithSep sep n ++ sep ++ repr v
|
||
|
||
protected def toString : Name → String :=
|
||
toStringWithSep "."
|
||
|
||
instance : ToString Name := ⟨Name.toString⟩
|
||
|
||
protected def append : Name → Name → Name
|
||
| n, anonymous => n
|
||
| n, str p s _ => mkNameStr (Name.append n p) s
|
||
| n, num p d _ => mkNameNum (Name.append n p) d
|
||
|
||
instance : HasAppend Name := ⟨Name.append⟩
|
||
|
||
def capitalize : Name → Name
|
||
| Name.str p s _ => mkNameStr p s.capitalize
|
||
| n => n
|
||
|
||
def appendAfter : Name → String → Name
|
||
| str p s _, suffix => mkNameStr p (s ++ suffix)
|
||
| n, suffix => mkNameStr n suffix
|
||
|
||
def appendIndexAfter : Name → Nat → Name
|
||
| str p s _, idx => mkNameStr p (s ++ "_" ++ toString idx)
|
||
| n, idx => mkNameStr n ("_" ++ toString idx)
|
||
|
||
def appendBefore : Name → String → Name
|
||
| anonymous, pre => mkNameStr anonymous pre
|
||
| str p s _, pre => mkNameStr p (pre ++ s)
|
||
| num p n _, pre => mkNameNum (mkNameStr p pre) n
|
||
|
||
end Name
|
||
|
||
structure NameGenerator :=
|
||
(namePrefix : Name := `_uniq)
|
||
(idx : Nat := 1)
|
||
|
||
namespace NameGenerator
|
||
|
||
instance : Inhabited NameGenerator := ⟨{}⟩
|
||
|
||
@[inline] def curr (g : NameGenerator) : Name :=
|
||
mkNameNum g.namePrefix g.idx
|
||
|
||
@[inline] def next (g : NameGenerator) : NameGenerator :=
|
||
{ g with idx := g.idx + 1 }
|
||
|
||
@[inline] def mkChild (g : NameGenerator) : NameGenerator × NameGenerator :=
|
||
({ namePrefix := mkNameNum g.namePrefix g.idx, idx := 1 },
|
||
{ g with idx := g.idx + 1 })
|
||
|
||
end NameGenerator
|
||
|
||
class MonadNameGenerator (m : Type → Type) :=
|
||
(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) [MonadNameGenerator m] [MonadLift m n] : MonadNameGenerator n := {
|
||
getNGen := liftM (getNGen : m _),
|
||
setNGen := fun ngen => liftM (setNGen ngen : m _)
|
||
}
|
||
|
||
/-
|
||
Small DSL for describing parsers. We implement an interpreter for it
|
||
at `Parser.lean` -/
|
||
inductive ParserDescr
|
||
| andthen : ParserDescr → ParserDescr → ParserDescr
|
||
| orelse : ParserDescr → ParserDescr → ParserDescr
|
||
| optional : ParserDescr → ParserDescr
|
||
| lookahead : ParserDescr → ParserDescr
|
||
| «try» : ParserDescr → ParserDescr
|
||
| many : ParserDescr → ParserDescr
|
||
| many1 : ParserDescr → ParserDescr
|
||
| sepBy : ParserDescr → ParserDescr → ParserDescr
|
||
| sepBy1 : ParserDescr → ParserDescr → ParserDescr
|
||
| node : Name → Nat → ParserDescr → ParserDescr
|
||
| trailingNode : Name → Nat → ParserDescr → ParserDescr
|
||
| symbol : String → ParserDescr
|
||
| nonReservedSymbol : String → Bool → ParserDescr
|
||
| noWs : ParserDescr
|
||
| numLit : ParserDescr
|
||
| strLit : ParserDescr
|
||
| charLit : ParserDescr
|
||
| nameLit : ParserDescr
|
||
| interpolatedStr : ParserDescr → ParserDescr -- interpolated string
|
||
| ident : ParserDescr
|
||
| cat : Name → Nat → ParserDescr
|
||
| parser : Name → ParserDescr
|
||
| notFollowedBy : ParserDescr → ParserDescr
|
||
|
||
instance : Inhabited ParserDescr := ⟨ParserDescr.symbol ""⟩
|
||
abbrev TrailingParserDescr := ParserDescr
|
||
|
||
/- Syntax -/
|
||
|
||
/--
|
||
Source information of syntax atoms. All information is generally set for unquoted syntax and unset for syntax in
|
||
syntax quotations, but syntax transformations might want to invalidate only one side to make the pretty printer
|
||
reformat it. In the special case of the delaborator, we also use purely synthetic position information without
|
||
whitespace information. -/
|
||
structure SourceInfo :=
|
||
/- Will be inferred after parsing by `Syntax.updateLeading`. During parsing,
|
||
it is not at all clear what the preceding token was, especially with backtracking. -/
|
||
(leading : Option Substring := none)
|
||
(pos : Option String.Pos := none)
|
||
(trailing : Option Substring := none)
|
||
|
||
instance : Inhabited SourceInfo := ⟨{}⟩
|
||
|
||
abbrev SyntaxNodeKind := Name
|
||
|
||
/- Syntax AST -/
|
||
|
||
inductive Syntax
|
||
| missing : Syntax
|
||
| node (kind : SyntaxNodeKind) (args : Array Syntax) : Syntax
|
||
| atom (info : SourceInfo) (val : String) : Syntax
|
||
| ident (info : SourceInfo) (rawVal : Substring) (val : Name) (preresolved : List (Name × List String)) : Syntax
|
||
|
||
instance : Inhabited Syntax := ⟨Syntax.missing⟩
|
||
|
||
/- Builtin kinds -/
|
||
def choiceKind : SyntaxNodeKind := `choice
|
||
def nullKind : SyntaxNodeKind := `null
|
||
def identKind : SyntaxNodeKind := `ident
|
||
def strLitKind : SyntaxNodeKind := `strLit
|
||
def charLitKind : SyntaxNodeKind := `charLit
|
||
def numLitKind : SyntaxNodeKind := `numLit
|
||
def nameLitKind : SyntaxNodeKind := `nameLit
|
||
def fieldIdxKind : SyntaxNodeKind := `fieldIdx
|
||
def interpolatedStrLitKind : SyntaxNodeKind := `interpolatedStrLitKind
|
||
def interpolatedStrKind : SyntaxNodeKind := `interpolatedStrKind
|
||
|
||
namespace Syntax
|
||
|
||
def getKind (stx : Syntax) : SyntaxNodeKind :=
|
||
match stx with
|
||
| Syntax.node k args => k
|
||
-- We use these "pseudo kinds" for antiquotation kinds.
|
||
-- For example, an antiquotation `$id:ident` (using Lean.Parser.Term.ident)
|
||
-- is compiled to ``if stx.isOfKind `ident ...``
|
||
| Syntax.missing => `missing
|
||
| Syntax.atom _ v => mkNameSimple v
|
||
| Syntax.ident _ _ _ _ => identKind
|
||
|
||
def setKind (stx : Syntax) (k : SyntaxNodeKind) : Syntax :=
|
||
match stx with
|
||
| Syntax.node _ args => Syntax.node k args
|
||
| _ => stx
|
||
|
||
def isOfKind (stx : Syntax) (k : SyntaxNodeKind) : Bool :=
|
||
stx.getKind == k
|
||
|
||
def getArg (stx : Syntax) (i : Nat) : Syntax :=
|
||
match stx with
|
||
| Syntax.node _ args => args.get! i
|
||
| _ => Syntax.missing -- panic! "Syntax.getArg: not a node"
|
||
|
||
-- Add `stx[i]` as sugar for `stx.getArg i`
|
||
@[inline] def getOp (self : Syntax) (idx : Nat) : Syntax :=
|
||
self.getArg idx
|
||
|
||
def getArgs (stx : Syntax) : Array Syntax :=
|
||
match stx with
|
||
| Syntax.node _ args => args
|
||
| _ => #[] -- panic! "Syntax.getArgs: not a node"
|
||
|
||
/-- Retrieve the left-most leaf's info in the Syntax tree. -/
|
||
partial def getHeadInfo : Syntax → Option SourceInfo
|
||
| atom info _ => info
|
||
| ident info _ _ _ => info
|
||
| node _ args => args.findSome? getHeadInfo
|
||
| _ => none
|
||
|
||
end Syntax
|
||
|
||
/- Syntax objects for a Lean module. -/
|
||
structure Module :=
|
||
(header : Syntax)
|
||
(commands : Array Syntax)
|
||
|
||
/-
|
||
Runtime support for making quotation terms auto-hygienic, by mangling identifiers
|
||
introduced by them with a "macro scope" supplied by the context. Details to appear in a
|
||
paper soon.
|
||
-/
|
||
|
||
abbrev MacroScope := Nat
|
||
/-- Macro scope used internally. It is not available for our frontend. -/
|
||
def reservedMacroScope := 0
|
||
/-- First macro scope available for our frontend -/
|
||
def firstFrontendMacroScope := reservedMacroScope + 1
|
||
|
||
/-- A monad that supports syntax quotations. Syntax quotations (in term
|
||
position) are monadic values that when executed retrieve the current "macro
|
||
scope" from the monad and apply it to every identifier they introduce
|
||
(independent of whether this identifier turns out to be a reference to an
|
||
existing declaration, or an actually fresh binding during further
|
||
elaboration). -/
|
||
class MonadQuotation (m : Type → Type) :=
|
||
-- Get the fresh scope of the current macro invocation
|
||
(getCurrMacroScope : m MacroScope)
|
||
(getMainModule : m Name)
|
||
/- Execute action in a new macro invocation context. This transformer should be
|
||
used at all places that morally qualify as the beginning of a "macro call",
|
||
e.g. `elabCommand` and `elabTerm` in the case of the elaborator. However, it
|
||
can also be used internally inside a "macro" if identifiers introduced by
|
||
e.g. different recursive calls should be independent and not collide. While
|
||
returning an intermediate syntax tree that will recursively be expanded by
|
||
the elaborator can be used for the same effect, doing direct recursion inside
|
||
the macro guarded by this transformer is often easier because one is not
|
||
restricted to passing a single syntax tree. Modelling this helper as a
|
||
transformer and not just a monadic action ensures that the current macro
|
||
scope before the recursive call is restored after it, as expected. -/
|
||
(withFreshMacroScope {α : Type} : m α → m α)
|
||
|
||
export MonadQuotation (getCurrMacroScope getMainModule withFreshMacroScope)
|
||
|
||
/-
|
||
We represent a name with macro scopes as
|
||
```
|
||
<actual name>._@.(<module_name>.<scopes>)*.<module_name>._hyg.<scopes>
|
||
```
|
||
Example: suppose the module name is `Init.Data.List.Basic`, and name is `foo.bla`, and macroscopes [2, 5]
|
||
```
|
||
foo.bla._@.Init.Data.List.Basic._hyg.2.5
|
||
```
|
||
|
||
We may have to combine scopes from different files/modules.
|
||
The main modules being processed is always the right most one.
|
||
This situation may happen when we execute a macro generated in
|
||
an imported file in the current file.
|
||
```
|
||
foo.bla._@.Init.Data.List.Basic.2.1.Init.Lean.Expr_hyg.4
|
||
```
|
||
|
||
The delimiter `_hyg` is used just to improve the `hasMacroScopes` performance.
|
||
-/
|
||
|
||
def Name.hasMacroScopes : Name → Bool
|
||
| str _ s _ => s == "_hyg"
|
||
| num p _ _ => hasMacroScopes p
|
||
| _ => false
|
||
|
||
private def eraseMacroScopesAux : Name → Name
|
||
| Name.str p s _ => if s == "_@" then p else eraseMacroScopesAux p
|
||
| Name.num p _ _ => eraseMacroScopesAux p
|
||
| Name.anonymous => unreachable!
|
||
|
||
@[export lean_erase_macro_scopes]
|
||
def Name.eraseMacroScopes (n : Name) : Name :=
|
||
if n.hasMacroScopes then eraseMacroScopesAux n else n
|
||
|
||
private def simpMacroScopesAux : Name → Name
|
||
| Name.num p i _ => mkNameNum (simpMacroScopesAux p) i
|
||
| n => eraseMacroScopesAux n
|
||
|
||
/- Helper function we use to create binder names that do not need to be unique. -/
|
||
@[export lean_simp_macro_scopes]
|
||
def Name.simpMacroScopes (n : Name) : Name :=
|
||
if n.hasMacroScopes then simpMacroScopesAux n else n
|
||
|
||
structure MacroScopesView :=
|
||
(name : Name)
|
||
(imported : Name)
|
||
(mainModule : Name)
|
||
(scopes : List MacroScope)
|
||
|
||
instance : Inhabited MacroScopesView := ⟨⟨arbitrary _, arbitrary _, arbitrary _, arbitrary _⟩⟩
|
||
|
||
def MacroScopesView.review (view : MacroScopesView) : Name :=
|
||
if view.scopes.isEmpty then
|
||
view.name
|
||
else
|
||
let base := (mkNameStr ((mkNameStr view.name "_@") ++ view.imported ++ view.mainModule) "_hyg")
|
||
view.scopes.foldl mkNameNum base
|
||
|
||
private def assembleParts : List Name → Name → Name
|
||
| [], acc => acc
|
||
| (Name.str _ s _) :: ps, acc => assembleParts ps (mkNameStr acc s)
|
||
| (Name.num _ n _) :: ps, acc => assembleParts ps (mkNameNum acc n)
|
||
| _, _ => unreachable!
|
||
|
||
private def extractImported (scps : List MacroScope) (mainModule : Name) : Name → List Name → MacroScopesView
|
||
| n@(Name.str p str _), parts =>
|
||
if str == "_@" then
|
||
{ name := p, mainModule := mainModule, imported := assembleParts parts Name.anonymous, scopes := scps }
|
||
else
|
||
extractImported scps mainModule p (n :: parts)
|
||
| n@(Name.num p str _), parts => extractImported scps mainModule p (n :: parts)
|
||
| _, _ => unreachable!
|
||
|
||
private def extractMainModule (scps : List MacroScope) : Name → List Name → MacroScopesView
|
||
| n@(Name.str p str _), parts =>
|
||
if str == "_@" then
|
||
{ name := p, mainModule := assembleParts parts Name.anonymous, imported := Name.anonymous, scopes := scps }
|
||
else
|
||
extractMainModule scps p (n :: parts)
|
||
| n@(Name.num p num _), acc => extractImported scps (assembleParts acc Name.anonymous) n []
|
||
| _, _ => unreachable!
|
||
|
||
private def extractMacroScopesAux : Name → List MacroScope → MacroScopesView
|
||
| Name.num p scp _, acc => extractMacroScopesAux p (scp::acc)
|
||
| Name.str p str _, acc => extractMainModule acc p [] -- str must be "_hyg"
|
||
| _, _ => unreachable!
|
||
|
||
/--
|
||
Revert all `addMacroScope` calls. `v = extractMacroScopes n → n = v.review`.
|
||
This operation is useful for analyzing/transforming the original identifiers, then adding back
|
||
the scopes (via `MacroScopesView.review`). -/
|
||
def extractMacroScopes (n : Name) : MacroScopesView :=
|
||
if n.hasMacroScopes then
|
||
extractMacroScopesAux n []
|
||
else
|
||
{ name := n, scopes := [], imported := Name.anonymous, mainModule := Name.anonymous }
|
||
|
||
def addMacroScope (mainModule : Name) (n : Name) (scp : MacroScope) : Name :=
|
||
if n.hasMacroScopes then
|
||
let view := extractMacroScopes n
|
||
if view.mainModule == mainModule then
|
||
mkNameNum n scp
|
||
else
|
||
{ view with imported := view.scopes.foldl mkNameNum (view.imported ++ view.mainModule), mainModule := mainModule, scopes := [scp] }.review
|
||
else
|
||
mkNameNum (mkNameStr (mkNameStr n "_@" ++ mainModule) "_hyg") scp
|
||
|
||
@[inline] def MonadQuotation.addMacroScope {m : Type → Type} [MonadQuotation m] [Monad m] (n : Name) : m Name := do
|
||
let mainModule ← getMainModule
|
||
let scp ← getCurrMacroScope
|
||
pure $ Lean.addMacroScope mainModule n scp
|
||
|
||
def defaultMaxRecDepth := 512
|
||
|
||
def maxRecDepthErrorMessage : String :=
|
||
"maximum recursion depth has been reached (use `set_option maxRecDepth <num>` to increase limit)"
|
||
|
||
namespace Macro
|
||
|
||
/- References -/
|
||
constant MacroEnvPointed : PointedType.{0}
|
||
def MacroEnv : Type := MacroEnvPointed.type
|
||
instance : Inhabited MacroEnv := ⟨MacroEnvPointed.val⟩
|
||
|
||
structure Context :=
|
||
(macroEnv : MacroEnv)
|
||
(mainModule : Name)
|
||
(currMacroScope : MacroScope)
|
||
(currRecDepth : Nat := 0)
|
||
(maxRecDepth : Nat := defaultMaxRecDepth)
|
||
|
||
inductive Exception
|
||
| error : Syntax → String → Exception
|
||
| unsupportedSyntax : Exception
|
||
|
||
end Macro
|
||
|
||
abbrev MacroM := ReaderT Macro.Context (EStateM Macro.Exception MacroScope)
|
||
|
||
abbrev Macro := Syntax → MacroM Syntax
|
||
|
||
namespace Macro
|
||
|
||
def addMacroScope (n : Name) : MacroM Name := do
|
||
let ctx ← read
|
||
pure $ Lean.addMacroScope ctx.mainModule n ctx.currMacroScope
|
||
|
||
def throwUnsupported {α} : MacroM α :=
|
||
throw Exception.unsupportedSyntax
|
||
|
||
def throwError {α} (ref : Syntax) (msg : String) : MacroM α :=
|
||
throw $ Exception.error ref msg
|
||
|
||
@[inline] protected def withFreshMacroScope {α} (x : MacroM α) : MacroM α := do
|
||
let fresh ← modifyGet (fun s => (s, s+1))
|
||
withReader (fun ctx => { ctx with currMacroScope := fresh }) x
|
||
|
||
@[inline] def withIncRecDepth {α} (ref : Syntax) (x : MacroM α) : MacroM α := do
|
||
let ctx ← read
|
||
if ctx.currRecDepth == ctx.maxRecDepth then throw $ Exception.error ref maxRecDepthErrorMessage
|
||
withReader (fun ctx => { ctx with currRecDepth := ctx.currRecDepth + 1 }) x
|
||
|
||
instance : MonadQuotation MacroM := {
|
||
getCurrMacroScope := fun ctx => pure ctx.currMacroScope,
|
||
getMainModule := fun ctx => pure ctx.mainModule,
|
||
withFreshMacroScope := Macro.withFreshMacroScope
|
||
}
|
||
|
||
instance {m n : Type → Type} [MonadQuotation m] [MonadLift m n] [MonadFunctorT m n] : MonadQuotation n := {
|
||
getCurrMacroScope := liftM (m := m) getCurrMacroScope,
|
||
getMainModule := liftM (m := m) getMainModule,
|
||
withFreshMacroScope := monadMap (m := m) withFreshMacroScope
|
||
}
|
||
|
||
unsafe def mkMacroEnvImp (expandMacro? : Syntax → MacroM (Option Syntax)) : MacroEnv :=
|
||
unsafeCast expandMacro?
|
||
|
||
@[implementedBy mkMacroEnvImp]
|
||
constant mkMacroEnv (expandMacro? : Syntax → MacroM (Option Syntax)) : MacroEnv
|
||
|
||
def expandMacroNotAvailable? (stx : Syntax) : MacroM (Option Syntax) :=
|
||
throwError stx "expandMacro has not been set"
|
||
|
||
def mkMacroEnvSimple : MacroEnv :=
|
||
mkMacroEnv expandMacroNotAvailable?
|
||
|
||
unsafe def expandMacro?Imp (stx : Syntax) : MacroM (Option Syntax) := do
|
||
let ctx ← read
|
||
let f : Syntax → MacroM (Option Syntax) := unsafeCast (ctx.macroEnv)
|
||
f stx
|
||
|
||
/-- `expandMacro? stx` return `some stxNew` if `stx` is a macro, and `stxNew` is its expansion. -/
|
||
@[implementedBy expandMacro?Imp] constant expandMacro? : Syntax → MacroM (Option Syntax)
|
||
|
||
end Macro
|
||
|
||
export Macro (expandMacro?)
|
||
|
||
/-- Expand all macros in the given syntax -/
|
||
partial def expandMacros : Syntax → MacroM Syntax
|
||
| stx@(Syntax.node k args) => do
|
||
match (← expandMacro? stx) with
|
||
| some stxNew => expandMacros stxNew
|
||
| none => do
|
||
args ← Macro.withIncRecDepth stx $ args.mapM expandMacros
|
||
pure $ Syntax.node k args
|
||
| stx => pure stx
|
||
|
||
/- Helper functions for processing Syntax programmatically -/
|
||
|
||
/--
|
||
Create an identifier using `SourceInfo` from `src`.
|
||
To refer to a specific constant, use `mkCIdentFrom` instead. -/
|
||
def mkIdentFrom (src : Syntax) (val : Name) : Syntax :=
|
||
let info := src.getHeadInfo.getD {}
|
||
Syntax.ident info (toString val).toSubstring val []
|
||
|
||
/--
|
||
Create an identifier referring to a constant `c` using `SourceInfo` from `src`.
|
||
This variant of `mkIdentFrom` makes sure that the identifier cannot accidentally
|
||
be captured. -/
|
||
def mkCIdentFrom (src : Syntax) (c : Name) : Syntax :=
|
||
let info := src.getHeadInfo.getD {}
|
||
-- 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 info (toString id).toSubstring id [(c, [])]
|
||
|
||
def mkCIdent (c : Name) : Syntax :=
|
||
mkCIdentFrom Syntax.missing c
|
||
|
||
def mkAtomFrom (src : Syntax) (val : String) : Syntax :=
|
||
let info := src.getHeadInfo.getD {}
|
||
Syntax.atom info val
|
||
|
||
def Syntax.identToAtom (stx : Syntax) : Syntax :=
|
||
match stx with
|
||
| Syntax.ident info _ val _ => Syntax.atom info (toString val.eraseMacroScopes)
|
||
| _ => stx
|
||
|
||
@[export lean_mk_syntax_ident]
|
||
def mkIdent (val : Name) : Syntax :=
|
||
Syntax.ident {} (toString val).toSubstring val []
|
||
|
||
@[inline] def mkNullNode (args : Array Syntax := #[]) : Syntax :=
|
||
Syntax.node nullKind args
|
||
|
||
def mkSepArray (as : Array Syntax) (sep : Syntax) : Array Syntax := do
|
||
let i := 0
|
||
let 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 mkSepStx (a : Array Syntax) (sep : Syntax) : Syntax :=
|
||
mkNullNode $ mkSepArray a sep
|
||
|
||
def mkOptionalNode (arg : Option Syntax) : Syntax :=
|
||
match arg with
|
||
| some arg => Syntax.node nullKind #[arg]
|
||
| none => Syntax.node nullKind #[]
|
||
|
||
/-- Create syntax representing a Lean term application -/
|
||
def mkAppStx (fn : Syntax) (args : Array Syntax) : Syntax :=
|
||
Syntax.node `Lean.Parser.Term.app #[fn, mkNullNode args]
|
||
|
||
def mkHole (ref : Syntax) : Syntax :=
|
||
Syntax.node `Lean.Parser.Term.hole #[mkAtomFrom ref "_"]
|
||
|
||
def mkCAppStx (fn : Name) (args : Array Syntax) : Syntax :=
|
||
mkAppStx (mkCIdent fn) args
|
||
|
||
def mkStxLit (kind : SyntaxNodeKind) (val : String) (info : SourceInfo := {}) : Syntax :=
|
||
let atom : Syntax := Syntax.atom info val
|
||
Syntax.node kind #[atom]
|
||
|
||
def mkStxStrLit (val : String) (info : SourceInfo := {}) : Syntax :=
|
||
mkStxLit strLitKind (repr val) info
|
||
|
||
def mkStxNumLit (val : String) (info : SourceInfo := {}) : Syntax :=
|
||
mkStxLit numLitKind val info
|
||
|
||
namespace Syntax
|
||
|
||
/- 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
|
||
|
||
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
|
||
|
||
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 :=
|
||
let c := s.get 1
|
||
if c == '\\' then do
|
||
(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 decodeNameLitAux (s : String) (i : Nat) (r : Name) : Option Name := do
|
||
let continue? (i : Nat) (r : Name) : Option Name :=
|
||
if s.get i == '.' then
|
||
decodeNameLitAux s (s.next i) r
|
||
else if s.atEnd i then
|
||
pure r
|
||
else
|
||
none
|
||
let curr := s.get i
|
||
if isIdBeginEscape curr then
|
||
let startPart := s.next i
|
||
let stopPart := s.nextUntil isIdEndEscape startPart
|
||
if !isIdEndEscape (s.get stopPart) then none
|
||
else continue? (s.next stopPart) (mkNameStr r (s.extract startPart stopPart))
|
||
else if isIdFirst curr then
|
||
let startPart := i
|
||
let stopPart := s.nextWhile isIdRest startPart
|
||
continue? stopPart (mkNameStr r (s.extract startPart stopPart))
|
||
else
|
||
none
|
||
|
||
def decodeNameLit (s : String) : Option Name :=
|
||
if s.get 0 == '`' then
|
||
decodeNameLitAux s 1 Name.anonymous
|
||
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 identToStrLit (stx : Syntax) : Syntax :=
|
||
match stx with
|
||
| Syntax.ident info _ val _ => mkStxStrLit (toString val) info
|
||
| _ => stx
|
||
|
||
def strLitToAtom (stx : Syntax) : Syntax :=
|
||
match stx.isStrLit? with
|
||
| none => stx
|
||
| some val => Syntax.atom stx.getHeadInfo.get! val
|
||
|
||
def isAtom : Syntax → Bool
|
||
| atom _ _ => true
|
||
| _ => false
|
||
|
||
def isToken (token : String) : Syntax → Bool
|
||
| atom _ val => val.trim == token.trim
|
||
| _ => false
|
||
|
||
def isIdent : Syntax → Bool
|
||
| ident _ _ _ _ => true
|
||
| _ => false
|
||
|
||
def getId : Syntax → Name
|
||
| ident _ _ val _ => val
|
||
| _ => Name.anonymous
|
||
|
||
def isNone (stx : Syntax) : Bool :=
|
||
match stx with
|
||
| Syntax.node k args => k == nullKind && args.size == 0
|
||
| _ => false
|
||
|
||
def getOptional? (stx : Syntax) : Option Syntax :=
|
||
match stx with
|
||
| Syntax.node k args => if k == nullKind && args.size == 1 then some (args.get! 0) else none
|
||
| _ => none
|
||
|
||
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
|
||
|
||
/-- Reflect a runtime datum back to surface syntax (best-effort). -/
|
||
class HasQuote (α : Type) :=
|
||
(quote : α → Syntax)
|
||
|
||
export HasQuote (quote)
|
||
|
||
instance : HasQuote Syntax := ⟨id⟩
|
||
instance : HasQuote String := ⟨mkStxStrLit⟩
|
||
instance : HasQuote Nat := ⟨fun n => mkStxNumLit $ toString n⟩
|
||
instance : HasQuote Substring := ⟨fun s => mkCAppStx `String.toSubstring #[quote s.toString]⟩
|
||
|
||
private def quoteName : Name → Syntax
|
||
| Name.anonymous => mkCIdent `Lean.Name.anonymous
|
||
| Name.str n s _ => mkCAppStx `Lean.mkNameStr #[quoteName n, quote s]
|
||
| Name.num n i _ => mkCAppStx `Lean.mkNameNum #[quoteName n, quote i]
|
||
|
||
instance : HasQuote Name := ⟨quoteName⟩
|
||
|
||
instance {α β : Type} [HasQuote α] [HasQuote β] : HasQuote (α × β) :=
|
||
⟨fun ⟨a, b⟩ => mkCAppStx `Prod.mk #[quote a, quote b]⟩
|
||
|
||
private def quoteList {α : Type} [HasQuote α] : List α → Syntax
|
||
| [] => mkCIdent `List.nil
|
||
| (x::xs) => mkCAppStx `List.cons #[quote x, quoteList xs]
|
||
|
||
instance {α : Type} [HasQuote α] : HasQuote (List α) := ⟨quoteList⟩
|
||
|
||
instance {α : Type} [HasQuote α] : HasQuote (Array α) :=
|
||
⟨fun xs => mkCAppStx `List.toArray #[quote xs.toList]⟩
|
||
|
||
private def quoteOption {α : Type} [HasQuote α] : Option α → Syntax
|
||
| none => mkIdent `Option.none
|
||
| (some x) => mkCAppStx `Option.some #[quote x]
|
||
|
||
instance Option.hasQuote {α : Type} [HasQuote α] : HasQuote (Option α) := ⟨quoteOption⟩
|
||
|
||
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.get ⟨i, h⟩
|
||
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 from Nat.predLt hz
|
||
let sepStx := a.get ⟨i.pred, Nat.ltTrans this h⟩
|
||
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.get ⟨i, h⟩
|
||
if i % 2 == 0 then do
|
||
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
|
||
|
||
/--
|
||
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) :=
|
||
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) :=
|
||
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 expandInterpolatedStrChunks (chunks : Array Syntax) (mkAppend : Syntax → Syntax → MacroM Syntax) (mkElem : Syntax → MacroM Syntax) : MacroM Syntax := do
|
||
let i := 0
|
||
let result := Syntax.missing
|
||
for elem in chunks do
|
||
let elem ← match elem.isInterpolatedStrLit? with
|
||
| none => mkElem elem
|
||
| some str => mkElem (mkStxStrLit str)
|
||
if i == 0 then
|
||
result := elem
|
||
else
|
||
result ← mkAppend result elem
|
||
i := i+1
|
||
return result
|
||
|
||
def getSepArgs (stx : Syntax) : Array Syntax :=
|
||
stx.getArgs.getSepElems
|
||
|
||
end Lean.Syntax
|