| /- | |
| Copyright (c) 2019 Microsoft Corporation. All rights reserved. | |
| Released under Apache 2.0 license as described in the file LICENSE. | |
| Authors: Leonardo de Moura and Sebastian Ullrich | |
| Additional goodies for writing macros | |
| -/ | |
| prelude | |
| import Init.Data.Array.Basic | |
| import Init.Data.Option.BasicAux | |
| namespace Lean | |
| @[extern c inline "lean_box(LEAN_VERSION_MAJOR)"] | |
| private opaque version.getMajor (u : Unit) : Nat | |
| def version.major : Nat := version.getMajor () | |
| @[extern c inline "lean_box(LEAN_VERSION_MINOR)"] | |
| private opaque version.getMinor (u : Unit) : Nat | |
| def version.minor : Nat := version.getMinor () | |
| @[extern c inline "lean_box(LEAN_VERSION_PATCH)"] | |
| private opaque version.getPatch (u : Unit) : Nat | |
| def version.patch : Nat := version.getPatch () | |
| @[extern "lean_get_githash"] | |
| opaque getGithash (u : Unit) : String | |
| def githash : String := getGithash () | |
| @[extern c inline "LEAN_VERSION_IS_RELEASE"] | |
| opaque version.getIsRelease (u : Unit) : Bool | |
| def version.isRelease : Bool := version.getIsRelease () | |
| /-- Additional version description like "nightly-2018-03-11" -/ | |
| @[extern c inline "lean_mk_string(LEAN_SPECIAL_VERSION_DESC)"] | |
| opaque version.getSpecialDesc (u : Unit) : String | |
| def version.specialDesc : String := version.getSpecialDesc () | |
| def versionStringCore := | |
| toString version.major ++ "." ++ toString version.minor ++ "." ++ toString version.patch | |
| def versionString := | |
| if version.specialDesc ≠ "" then | |
| versionStringCore ++ "-" ++ version.specialDesc | |
| else if version.isRelease then | |
| versionStringCore | |
| else | |
| versionStringCore ++ ", commit " ++ githash | |
| def origin := | |
| "leanprover/lean4" | |
| def toolchain := | |
| if version.specialDesc ≠ "" then | |
| if version.isRelease then | |
| origin ++ ":" ++ versionStringCore ++ "-" ++ version.specialDesc | |
| else | |
| origin ++ ":" ++ version.specialDesc | |
| else if version.isRelease then | |
| origin ++ ":" ++ versionStringCore | |
| else | |
| "" | |
| @[extern c inline "LEAN_IS_STAGE0"] | |
| opaque Internal.isStage0 (u : Unit) : Bool | |
| /-- Valid identifier names -/ | |
| def isGreek (c : Char) : Bool := | |
| 0x391 ≤ c.val && c.val ≤ 0x3dd | |
| def isLetterLike (c : Char) : Bool := | |
| (0x3b1 ≤ c.val && c.val ≤ 0x3c9 && c.val ≠ 0x3bb) || -- Lower greek, but lambda | |
| (0x391 ≤ c.val && c.val ≤ 0x3A9 && c.val ≠ 0x3A0 && c.val ≠ 0x3A3) || -- Upper greek, but Pi and Sigma | |
| (0x3ca ≤ c.val && c.val ≤ 0x3fb) || -- Coptic letters | |
| (0x1f00 ≤ c.val && c.val ≤ 0x1ffe) || -- Polytonic Greek Extended Character Set | |
| (0x2100 ≤ c.val && c.val ≤ 0x214f) || -- Letter like block | |
| (0x1d49c ≤ c.val && c.val ≤ 0x1d59f) -- Latin letters, Script, Double-struck, Fractur | |
| def isNumericSubscript (c : Char) : Bool := | |
| 0x2080 ≤ c.val && c.val ≤ 0x2089 | |
| def isSubScriptAlnum (c : Char) : Bool := | |
| isNumericSubscript c || | |
| (0x2090 ≤ c.val && c.val ≤ 0x209c) || | |
| (0x1d62 ≤ c.val && c.val ≤ 0x1d6a) | |
| def isIdFirst (c : Char) : Bool := | |
| c.isAlpha || c = '_' || isLetterLike c | |
| def isIdRest (c : Char) : Bool := | |
| c.isAlphanum || c = '_' || c = '\'' || c == '!' || c == '?' || isLetterLike c || isSubScriptAlnum c | |
| def idBeginEscape := '«' | |
| def idEndEscape := '»' | |
| def isIdBeginEscape (c : Char) : Bool := c = idBeginEscape | |
| def isIdEndEscape (c : Char) : Bool := c = idEndEscape | |
| namespace Name | |
| def getRoot : Name → Name | |
| | anonymous => anonymous | |
| | n@(str anonymous _) => n | |
| | n@(num anonymous _) => n | |
| | str n _ => getRoot n | |
| | num n _ => getRoot n | |
| @[export lean_is_inaccessible_user_name] | |
| def isInaccessibleUserName : Name → Bool | |
| | Name.str _ s => s.contains '✝' || s == "_inaccessible" | |
| | Name.num p _ => isInaccessibleUserName p | |
| | _ => false | |
| def escapePart (s : String) : Option String := | |
| if s.length > 0 && isIdFirst (s.get 0) && (s.toSubstring.drop 1).all isIdRest then s | |
| else if s.any isIdEndEscape then none | |
| else some <| idBeginEscape.toString ++ s ++ idEndEscape.toString | |
| -- NOTE: does not roundtrip even with `escape = true` if name is anonymous or contains numeric part or `idEndEscape` | |
| variable (sep : String) (escape : Bool) | |
| def toStringWithSep : Name → String | |
| | anonymous => "[anonymous]" | |
| | str anonymous s => maybeEscape s | |
| | num anonymous v => toString v | |
| | str n s => toStringWithSep n ++ sep ++ maybeEscape s | |
| | num n v => toStringWithSep n ++ sep ++ Nat.repr v | |
| where | |
| maybeEscape s := if escape then escapePart s |>.getD s else s | |
| protected def toString (n : Name) (escape := true) : String := | |
| -- never escape "prettified" inaccessible names or macro scopes or pseudo-syntax introduced by the delaborator | |
| toStringWithSep "." (escape && !n.isInaccessibleUserName && !n.hasMacroScopes && !maybePseudoSyntax) n | |
| where | |
| maybePseudoSyntax := | |
| if let .str _ s := n.getRoot then | |
| -- could be pseudo-syntax for loose bvar or universe mvar, output as is | |
| "#".isPrefixOf s || "?".isPrefixOf s | |
| else | |
| false | |
| instance : ToString Name where | |
| toString n := n.toString | |
| private def hasNum : Name → Bool | |
| | anonymous => false | |
| | num .. => true | |
| | str p .. => hasNum p | |
| protected def reprPrec (n : Name) (prec : Nat) : Std.Format := | |
| match n with | |
| | anonymous => Std.Format.text "Lean.Name.anonymous" | |
| | num p i => Repr.addAppParen ("Lean.Name.mkNum " ++ Name.reprPrec p max_prec ++ " " ++ repr i) prec | |
| | str p s => | |
| if p.hasNum then | |
| Repr.addAppParen ("Lean.Name.mkStr " ++ Name.reprPrec p max_prec ++ " " ++ repr s) prec | |
| else | |
| Std.Format.text "`" ++ n.toString | |
| instance : Repr Name where | |
| reprPrec := Name.reprPrec | |
| deriving instance Repr for Syntax | |
| def capitalize : Name → Name | |
| | .str p s => .str p s.capitalize | |
| | n => n | |
| def replacePrefix : Name → Name → Name → Name | |
| | anonymous, anonymous, newP => newP | |
| | anonymous, _, _ => anonymous | |
| | n@(str p s), queryP, newP => if n == queryP then newP else Name.mkStr (p.replacePrefix queryP newP) s | |
| | n@(num p s), queryP, newP => if n == queryP then newP else Name.mkNum (p.replacePrefix queryP newP) s | |
| /-- | |
| `eraseSuffix? n s` return `n'` if `n` is of the form `n == n' ++ s`. | |
| -/ | |
| def eraseSuffix? : Name → Name → Option Name | |
| | n, anonymous => some n | |
| | str p s, str p' s' => if s == s' then eraseSuffix? p p' else none | |
| | num p s, num p' s' => if s == s' then eraseSuffix? p p' else none | |
| | _, _ => none | |
| /-- Remove macros scopes, apply `f`, and put them back -/ | |
| @[inline] def modifyBase (n : Name) (f : Name → Name) : Name := | |
| if n.hasMacroScopes then | |
| let view := extractMacroScopes n | |
| { view with name := f view.name }.review | |
| else | |
| f n | |
| @[export lean_name_append_after] | |
| def appendAfter (n : Name) (suffix : String) : Name := | |
| n.modifyBase fun | |
| | str p s => Name.mkStr p (s ++ suffix) | |
| | n => Name.mkStr n suffix | |
| @[export lean_name_append_index_after] | |
| def appendIndexAfter (n : Name) (idx : Nat) : Name := | |
| n.modifyBase fun | |
| | str p s => Name.mkStr p (s ++ "_" ++ toString idx) | |
| | n => Name.mkStr n ("_" ++ toString idx) | |
| @[export lean_name_append_before] | |
| def appendBefore (n : Name) (pre : String) : Name := | |
| n.modifyBase fun | |
| | anonymous => Name.mkStr anonymous pre | |
| | str p s => Name.mkStr p (pre ++ s) | |
| | num p n => Name.mkNum (Name.mkStr p pre) n | |
| protected theorem beq_iff_eq {m n : Name} : m == n ↔ m = n := by | |
| show m.beq n ↔ _ | |
| induction m generalizing n <;> cases n <;> simp_all [Name.beq, And.comm] | |
| instance : LawfulBEq Name where | |
| eq_of_beq := Name.beq_iff_eq.1 | |
| rfl := Name.beq_iff_eq.2 rfl | |
| instance : DecidableEq Name := | |
| fun a b => if h : a == b then .isTrue (by simp_all) else .isFalse (by simp_all) | |
| end Name | |
| structure NameGenerator where | |
| namePrefix : Name := `_uniq | |
| idx : Nat := 1 | |
| deriving Inhabited | |
| namespace NameGenerator | |
| @[inline] def curr (g : NameGenerator) : Name := | |
| Name.mkNum g.namePrefix g.idx | |
| @[inline] def next (g : NameGenerator) : NameGenerator := | |
| { g with idx := g.idx + 1 } | |
| @[inline] def mkChild (g : NameGenerator) : NameGenerator × NameGenerator := | |
| ({ namePrefix := Name.mkNum g.namePrefix g.idx, idx := 1 }, | |
| { g with idx := g.idx + 1 }) | |
| end NameGenerator | |
| class MonadNameGenerator (m : Type → Type) where | |
| getNGen : m NameGenerator | |
| setNGen : NameGenerator → m Unit | |
| export MonadNameGenerator (getNGen setNGen) | |
| def mkFreshId {m : Type → Type} [Monad m] [MonadNameGenerator m] : m Name := do | |
| let ngen ← getNGen | |
| let r := ngen.curr | |
| setNGen ngen.next | |
| pure r | |
| instance monadNameGeneratorLift (m n : Type → Type) [MonadLift m n] [MonadNameGenerator m] : MonadNameGenerator n := { | |
| getNGen := liftM (getNGen : m _), | |
| setNGen := fun ngen => liftM (setNGen ngen : m _) | |
| } | |
| namespace Syntax | |
| abbrev Term := TSyntax `term | |
| abbrev Command := TSyntax `command | |
| protected abbrev Level := TSyntax `level | |
| abbrev Prec := TSyntax `prec | |
| abbrev Prio := TSyntax `prio | |
| abbrev Ident := TSyntax identKind | |
| abbrev StrLit := TSyntax strLitKind | |
| abbrev CharLit := TSyntax charLitKind | |
| abbrev NameLit := TSyntax nameLitKind | |
| abbrev ScientificLit := TSyntax scientificLitKind | |
| abbrev NumLit := TSyntax numLitKind | |
| end Syntax | |
| export Syntax (Term Command Prec Prio Ident StrLit CharLit NameLit ScientificLit NumLit) | |
| namespace TSyntax | |
| instance : Coe (TSyntax [k]) (TSyntax (k :: ks)) where | |
| coe stx := ⟨stx⟩ | |
| instance : Coe (TSyntax ks) (TSyntax (k' :: ks)) where | |
| coe stx := ⟨stx⟩ | |
| instance : Coe Ident Term where | |
| coe s := ⟨s.raw⟩ | |
| instance : CoeDep Term ⟨Syntax.ident info ss n res⟩ Ident where | |
| coe := ⟨Syntax.ident info ss n res⟩ | |
| instance : Coe StrLit Term where | |
| coe s := ⟨s.raw⟩ | |
| instance : Coe NameLit Term where | |
| coe s := ⟨s.raw⟩ | |
| instance : Coe ScientificLit Term where | |
| coe s := ⟨s.raw⟩ | |
| instance : Coe NumLit Term where | |
| coe s := ⟨s.raw⟩ | |
| instance : Coe CharLit Term where | |
| coe s := ⟨s.raw⟩ | |
| instance : Coe Ident Syntax.Level where | |
| coe s := ⟨s.raw⟩ | |
| instance : Coe NumLit Prio where | |
| coe s := ⟨s.raw⟩ | |
| instance : Coe NumLit Prec where | |
| coe s := ⟨s.raw⟩ | |
| namespace Compat | |
| scoped instance : CoeTail Syntax (TSyntax k) where | |
| coe s := ⟨s⟩ | |
| scoped instance : CoeTail (Array Syntax) (TSyntaxArray k) where | |
| coe := .mk | |
| end Compat | |
| end TSyntax | |
| namespace Syntax | |
| partial def structEq : Syntax → Syntax → Bool | |
| | Syntax.missing, Syntax.missing => true | |
| | Syntax.node _ k args, Syntax.node _ k' args' => k == k' && args.isEqv args' structEq | |
| | Syntax.atom _ val, Syntax.atom _ val' => val == val' | |
| | Syntax.ident _ rawVal val preresolved, Syntax.ident _ rawVal' val' preresolved' => rawVal == rawVal' && val == val' && preresolved == preresolved' | |
| | _, _ => false | |
| instance : BEq Lean.Syntax := ⟨structEq⟩ | |
| instance : BEq (Lean.TSyntax k) := ⟨(·.raw == ·.raw)⟩ | |
| partial def getTailInfo? : Syntax → Option SourceInfo | |
| | atom info _ => info | |
| | ident info .. => info | |
| | node SourceInfo.none _ args => | |
| args.findSomeRev? getTailInfo? | |
| | node info _ _ => info | |
| | _ => none | |
| def getTailInfo (stx : Syntax) : SourceInfo := | |
| stx.getTailInfo?.getD SourceInfo.none | |
| def getTrailingSize (stx : Syntax) : Nat := | |
| match stx.getTailInfo? with | |
| | some (SourceInfo.original (trailing := trailing) ..) => trailing.bsize | |
| | _ => 0 | |
| /-- | |
| Return substring of original input covering `stx`. | |
| Result is meaningful only if all involved `SourceInfo.original`s refer to the same string (as is the case after parsing). -/ | |
| def getSubstring? (stx : Syntax) (withLeading := true) (withTrailing := true) : Option Substring := | |
| match stx.getHeadInfo, stx.getTailInfo with | |
| | SourceInfo.original lead startPos _ _, SourceInfo.original _ _ trail stopPos => | |
| some { | |
| str := lead.str | |
| startPos := if withLeading then lead.startPos else startPos | |
| stopPos := if withTrailing then trail.stopPos else stopPos | |
| } | |
| | _, _ => none | |
| @[specialize] private partial def updateLast {α} [Inhabited α] (a : Array α) (f : α → Option α) (i : Nat) : Option (Array α) := | |
| if i == 0 then | |
| none | |
| else | |
| let i := i - 1 | |
| let v := a[i]! | |
| match f v with | |
| | some v => some <| a.set! i v | |
| | none => updateLast a f i | |
| partial def setTailInfoAux (info : SourceInfo) : Syntax → Option Syntax | |
| | atom _ val => some <| atom info val | |
| | ident _ rawVal val pre => some <| ident info rawVal val pre | |
| | node info k args => | |
| match updateLast args (setTailInfoAux info) args.size with | |
| | some args => some <| node info k args | |
| | none => none | |
| | _ => none | |
| def setTailInfo (stx : Syntax) (info : SourceInfo) : Syntax := | |
| match setTailInfoAux info stx with | |
| | some stx => stx | |
| | none => stx | |
| def unsetTrailing (stx : Syntax) : Syntax := | |
| match stx.getTailInfo with | |
| | SourceInfo.original lead pos _ endPos => stx.setTailInfo (SourceInfo.original lead pos "".toSubstring endPos) | |
| | _ => stx | |
| @[specialize] private partial def updateFirst {α} [Inhabited α] (a : Array α) (f : α → Option α) (i : Nat) : Option (Array α) := | |
| if h : i < a.size then | |
| let v := a[i] | |
| match f v with | |
| | some v => some <| a.set ⟨i, h⟩ v | |
| | none => updateFirst a f (i+1) | |
| else | |
| none | |
| partial def setHeadInfoAux (info : SourceInfo) : Syntax → Option Syntax | |
| | atom _ val => some <| atom info val | |
| | ident _ rawVal val pre => some <| ident info rawVal val pre | |
| | node i k args => | |
| match updateFirst args (setHeadInfoAux info) 0 with | |
| | some args => some <| node i k args | |
| | _ => none | |
| | _ => none | |
| def setHeadInfo (stx : Syntax) (info : SourceInfo) : Syntax := | |
| match setHeadInfoAux info stx with | |
| | some stx => stx | |
| | none => stx | |
| def setInfo (info : SourceInfo) : Syntax → Syntax | |
| | atom _ val => atom info val | |
| | ident _ rawVal val pre => ident info rawVal val pre | |
| | node _ kind args => node info kind args | |
| | missing => missing | |
| /-- Return the first atom/identifier that has position information -/ | |
| partial def getHead? : Syntax → Option Syntax | |
| | stx@(atom info ..) => info.getPos?.map fun _ => stx | |
| | stx@(ident info ..) => info.getPos?.map fun _ => stx | |
| | node SourceInfo.none _ args => args.findSome? getHead? | |
| | stx@(node ..) => stx | |
| | _ => none | |
| def copyHeadTailInfoFrom (target source : Syntax) : Syntax := | |
| target.setHeadInfo source.getHeadInfo |>.setTailInfo source.getTailInfo | |
| /-- Ensure head position is synthetic. The server regards syntax as "original" only if both head and tail info are `original`. -/ | |
| def mkSynthetic (stx : Syntax) : Syntax := | |
| stx.setHeadInfo (SourceInfo.fromRef stx) | |
| end Syntax | |
| /-- Use the head atom/identifier of the current `ref` as the `ref` -/ | |
| @[inline] def withHeadRefOnly {m : Type → Type} [Monad m] [MonadRef m] {α} (x : m α) : m α := do | |
| match (← getRef).getHead? with | |
| | none => x | |
| | some ref => withRef ref x | |
| @[inline] def mkNode (k : SyntaxNodeKind) (args : Array Syntax) : TSyntax k := | |
| ⟨Syntax.node SourceInfo.none k args⟩ | |
| /-- Syntax objects for a Lean module. -/ | |
| structure Module where | |
| header : Syntax | |
| commands : Array Syntax | |
| /-- | |
| Expand macros in the given syntax. | |
| A node with kind `k` is visited only if `p k` is true. | |
| Note that the default value for `p` returns false for `by ...` nodes. | |
| This is a "hack". The tactic framework abuses the macro system to implement extensible tactics. | |
| For example, one can define | |
| ```lean | |
| syntax "my_trivial" : tactic -- extensible tactic | |
| macro_rules | `(tactic| my_trivial) => `(tactic| decide) | |
| macro_rules | `(tactic| my_trivial) => `(tactic| assumption) | |
| ``` | |
| When the tactic evaluator finds the tactic `my_trivial`, it tries to evaluate the `macro_rule` expansions | |
| until one "works", i.e., the macro expansion is evaluated without producing an exception. | |
| We say this solution is a bit hackish because the term elaborator may invoke `expandMacros` with `(p := fun _ => true)`, | |
| and expand the tactic macros as just macros. In the example above, `my_trivial` would be replaced with `assumption`, | |
| `decide` would not be tried if `assumption` fails at tactic evaluation time. | |
| We are considering two possible solutions for this issue: | |
| 1- A proper extensible tactic feature that does not rely on the macro system. | |
| 2- Typed macros that know the syntax categories they're working in. Then, we would be able to select which | |
| syntatic categories are expanded by `expandMacros`. | |
| -/ | |
| partial def expandMacros (stx : Syntax) (p : SyntaxNodeKind → Bool := fun k => k != `Lean.Parser.Term.byTactic) : MacroM Syntax := | |
| match stx with | |
| | .node info k args => do | |
| if p k then | |
| match (← expandMacro? stx) with | |
| | some stxNew => expandMacros stxNew | |
| | none => do | |
| let args ← Macro.withIncRecDepth stx <| args.mapM expandMacros | |
| return .node info k args | |
| else | |
| return stx | |
| | stx => return stx | |
| /-! # Helper functions for processing Syntax programmatically -/ | |
| /-- | |
| Create an identifier copying the position from `src`. | |
| To refer to a specific constant, use `mkCIdentFrom` instead. -/ | |
| def mkIdentFrom (src : Syntax) (val : Name) : Ident := | |
| ⟨Syntax.ident (SourceInfo.fromRef src) (toString val).toSubstring val []⟩ | |
| def mkIdentFromRef [Monad m] [MonadRef m] (val : Name) : m Ident := do | |
| return mkIdentFrom (← getRef) val | |
| /-- | |
| Create an identifier referring to a constant `c` copying the position from `src`. | |
| This variant of `mkIdentFrom` makes sure that the identifier cannot accidentally | |
| be captured. -/ | |
| def mkCIdentFrom (src : Syntax) (c : Name) : Ident := | |
| -- Remark: We use the reserved macro scope to make sure there are no accidental collision with our frontend | |
| let id := addMacroScope `_internal c reservedMacroScope | |
| ⟨Syntax.ident (SourceInfo.fromRef src) (toString id).toSubstring id [(c, [])]⟩ | |
| def mkCIdentFromRef [Monad m] [MonadRef m] (c : Name) : m Syntax := do | |
| return mkCIdentFrom (← getRef) c | |
| def mkCIdent (c : Name) : Ident := | |
| mkCIdentFrom Syntax.missing c | |
| @[export lean_mk_syntax_ident] | |
| def mkIdent (val : Name) : Ident := | |
| ⟨Syntax.ident SourceInfo.none (toString val).toSubstring val []⟩ | |
| @[inline] def mkNullNode (args : Array Syntax := #[]) : Syntax := | |
| mkNode nullKind args | |
| @[inline] def mkGroupNode (args : Array Syntax := #[]) : Syntax := | |
| mkNode groupKind args | |
| def mkSepArray (as : Array Syntax) (sep : Syntax) : Array Syntax := Id.run do | |
| let mut i := 0 | |
| let mut r := #[] | |
| for a in as do | |
| if i > 0 then | |
| r := r.push sep |>.push a | |
| else | |
| r := r.push a | |
| i := i + 1 | |
| return r | |
| def mkOptionalNode (arg : Option Syntax) : Syntax := | |
| match arg with | |
| | some arg => mkNullNode #[arg] | |
| | none => mkNullNode #[] | |
| def mkHole (ref : Syntax) : Syntax := | |
| mkNode `Lean.Parser.Term.hole #[mkAtomFrom ref "_"] | |
| namespace Syntax | |
| def mkSep (a : Array Syntax) (sep : Syntax) : Syntax := | |
| mkNullNode <| mkSepArray a sep | |
| def SepArray.ofElems {sep} (elems : Array Syntax) : SepArray sep := | |
| ⟨mkSepArray elems (if sep.isEmpty then mkNullNode else mkAtom sep)⟩ | |
| def SepArray.ofElemsUsingRef [Monad m] [MonadRef m] {sep} (elems : Array Syntax) : m (SepArray sep) := do | |
| let ref ← getRef; | |
| return ⟨mkSepArray elems (if sep.isEmpty then mkNullNode else mkAtomFrom ref sep)⟩ | |
| instance : Coe (Array Syntax) (SepArray sep) where | |
| coe := SepArray.ofElems | |
| instance : Coe (TSyntaxArray k) (TSepArray k sep) where | |
| coe a := ⟨mkSepArray a.raw (mkAtom sep)⟩ | |
| /-- Create syntax representing a Lean term application, but avoid degenerate empty applications. -/ | |
| def mkApp (fn : Term) : (args : TSyntaxArray `term) → Term | |
| | #[] => fn | |
| | args => ⟨mkNode `Lean.Parser.Term.app #[fn, mkNullNode args.raw]⟩ | |
| def mkCApp (fn : Name) (args : TSyntaxArray `term) : Term := | |
| mkApp (mkCIdent fn) args | |
| def mkLit (kind : SyntaxNodeKind) (val : String) (info := SourceInfo.none) : TSyntax kind := | |
| let atom : Syntax := Syntax.atom info val | |
| mkNode kind #[atom] | |
| def mkStrLit (val : String) (info := SourceInfo.none) : StrLit := | |
| mkLit strLitKind (String.quote val) info | |
| def mkNumLit (val : String) (info := SourceInfo.none) : NumLit := | |
| mkLit numLitKind val info | |
| def mkScientificLit (val : String) (info := SourceInfo.none) : TSyntax scientificLitKind := | |
| mkLit scientificLitKind val info | |
| def mkNameLit (val : String) (info := SourceInfo.none) : NameLit := | |
| mkLit nameLitKind val info | |
| /-! Recall that we don't have special Syntax constructors for storing numeric and string atoms. | |
| The idea is to have an extensible approach where embedded DSLs may have new kind of atoms and/or | |
| different ways of representing them. So, our atoms contain just the parsed string. | |
| The main Lean parser uses the kind `numLitKind` for storing natural numbers that can be encoded | |
| in binary, octal, decimal and hexadecimal format. `isNatLit` implements a "decoder" | |
| for Syntax objects representing these numerals. -/ | |
| private partial def decodeBinLitAux (s : String) (i : String.Pos) (val : Nat) : Option Nat := | |
| if s.atEnd i then some val | |
| else | |
| let c := s.get i | |
| if c == '0' then decodeBinLitAux s (s.next i) (2*val) | |
| else if c == '1' then decodeBinLitAux s (s.next i) (2*val + 1) | |
| else none | |
| private partial def decodeOctalLitAux (s : String) (i : String.Pos) (val : Nat) : Option Nat := | |
| if s.atEnd i then some val | |
| else | |
| let c := s.get i | |
| if '0' ≤ c && c ≤ '7' then decodeOctalLitAux s (s.next i) (8*val + c.toNat - '0'.toNat) | |
| else none | |
| private def decodeHexDigit (s : String) (i : String.Pos) : Option (Nat × String.Pos) := | |
| let c := s.get i | |
| let i := s.next i | |
| if '0' ≤ c && c ≤ '9' then some (c.toNat - '0'.toNat, i) | |
| else if 'a' ≤ c && c ≤ 'f' then some (10 + c.toNat - 'a'.toNat, i) | |
| else if 'A' ≤ c && c ≤ 'F' then some (10 + c.toNat - 'A'.toNat, i) | |
| else none | |
| private partial def decodeHexLitAux (s : String) (i : String.Pos) (val : Nat) : Option Nat := | |
| if s.atEnd i then some val | |
| else match decodeHexDigit s i with | |
| | some (d, i) => decodeHexLitAux s i (16*val + d) | |
| | none => none | |
| private partial def decodeDecimalLitAux (s : String) (i : String.Pos) (val : Nat) : Option Nat := | |
| if s.atEnd i then some val | |
| else | |
| let c := s.get i | |
| if '0' ≤ c && c ≤ '9' then decodeDecimalLitAux s (s.next i) (10*val + c.toNat - '0'.toNat) | |
| else none | |
| def decodeNatLitVal? (s : String) : Option Nat := | |
| let len := s.length | |
| if len == 0 then none | |
| else | |
| let c := s.get 0 | |
| if c == '0' then | |
| if len == 1 then some 0 | |
| else | |
| let c := s.get ⟨1⟩ | |
| if c == 'x' || c == 'X' then decodeHexLitAux s ⟨2⟩ 0 | |
| else if c == 'b' || c == 'B' then decodeBinLitAux s ⟨2⟩ 0 | |
| else if c == 'o' || c == 'O' then decodeOctalLitAux s ⟨2⟩ 0 | |
| else if c.isDigit then decodeDecimalLitAux s 0 0 | |
| else none | |
| else if c.isDigit then decodeDecimalLitAux s 0 0 | |
| else none | |
| def isLit? (litKind : SyntaxNodeKind) (stx : Syntax) : Option String := | |
| match stx with | |
| | Syntax.node _ k args => | |
| if k == litKind && args.size == 1 then | |
| match args.get! 0 with | |
| | (Syntax.atom _ val) => some val | |
| | _ => none | |
| else | |
| none | |
| | _ => none | |
| private def isNatLitAux (litKind : SyntaxNodeKind) (stx : Syntax) : Option Nat := | |
| match isLit? litKind stx with | |
| | some val => decodeNatLitVal? val | |
| | _ => none | |
| def isNatLit? (s : Syntax) : Option Nat := | |
| isNatLitAux numLitKind s | |
| def isFieldIdx? (s : Syntax) : Option Nat := | |
| isNatLitAux fieldIdxKind s | |
| partial def decodeScientificLitVal? (s : String) : Option (Nat × Bool × Nat) := | |
| let len := s.length | |
| if len == 0 then none | |
| else | |
| let c := s.get 0 | |
| if c.isDigit then | |
| decode 0 0 | |
| else none | |
| where | |
| decodeAfterExp (i : String.Pos) (val : Nat) (e : Nat) (sign : Bool) (exp : Nat) : Option (Nat × Bool × Nat) := | |
| if s.atEnd i then | |
| if sign then | |
| some (val, sign, exp + e) | |
| else if exp >= e then | |
| some (val, sign, exp - e) | |
| else | |
| some (val, true, e - exp) | |
| else | |
| let c := s.get i | |
| if '0' ≤ c && c ≤ '9' then | |
| decodeAfterExp (s.next i) val e sign (10*exp + c.toNat - '0'.toNat) | |
| else | |
| none | |
| decodeExp (i : String.Pos) (val : Nat) (e : Nat) : Option (Nat × Bool × Nat) := | |
| let c := s.get i | |
| if c == '-' then | |
| decodeAfterExp (s.next i) val e true 0 | |
| else | |
| decodeAfterExp i val e false 0 | |
| decodeAfterDot (i : String.Pos) (val : Nat) (e : Nat) : Option (Nat × Bool × Nat) := | |
| if s.atEnd i then | |
| some (val, true, e) | |
| else | |
| let c := s.get i | |
| if '0' ≤ c && c ≤ '9' then | |
| decodeAfterDot (s.next i) (10*val + c.toNat - '0'.toNat) (e+1) | |
| else if c == 'e' || c == 'E' then | |
| decodeExp (s.next i) val e | |
| else | |
| none | |
| decode (i : String.Pos) (val : Nat) : Option (Nat × Bool × Nat) := | |
| if s.atEnd i then | |
| none | |
| else | |
| let c := s.get i | |
| if '0' ≤ c && c ≤ '9' then | |
| decode (s.next i) (10*val + c.toNat - '0'.toNat) | |
| else if c == '.' then | |
| decodeAfterDot (s.next i) val 0 | |
| else if c == 'e' || c == 'E' then | |
| decodeExp (s.next i) val 0 | |
| else | |
| none | |
| def isScientificLit? (stx : Syntax) : Option (Nat × Bool × Nat) := | |
| match isLit? scientificLitKind stx with | |
| | some val => decodeScientificLitVal? val | |
| | _ => none | |
| def isIdOrAtom? : Syntax → Option String | |
| | Syntax.atom _ val => some val | |
| | Syntax.ident _ rawVal _ _ => some rawVal.toString | |
| | _ => none | |
| def toNat (stx : Syntax) : Nat := | |
| match stx.isNatLit? with | |
| | some val => val | |
| | none => 0 | |
| def decodeQuotedChar (s : String) (i : String.Pos) : Option (Char × String.Pos) := do | |
| let c := s.get i | |
| let i := s.next i | |
| if c == '\\' then pure ('\\', i) | |
| else if c = '\"' then pure ('\"', i) | |
| else if c = '\'' then pure ('\'', i) | |
| else if c = 'r' then pure ('\r', i) | |
| else if c = 'n' then pure ('\n', i) | |
| else if c = 't' then pure ('\t', i) | |
| else if c = 'x' then | |
| let (d₁, i) ← decodeHexDigit s i | |
| let (d₂, i) ← decodeHexDigit s i | |
| pure (Char.ofNat (16*d₁ + d₂), i) | |
| else if c = 'u' then do | |
| let (d₁, i) ← decodeHexDigit s i | |
| let (d₂, i) ← decodeHexDigit s i | |
| let (d₃, i) ← decodeHexDigit s i | |
| let (d₄, i) ← decodeHexDigit s i | |
| pure (Char.ofNat (16*(16*(16*d₁ + d₂) + d₃) + d₄), i) | |
| else | |
| none | |
| partial def decodeStrLitAux (s : String) (i : String.Pos) (acc : String) : Option String := do | |
| let c := s.get i | |
| let i := s.next i | |
| if c == '\"' then | |
| pure acc | |
| else if s.atEnd i then | |
| none | |
| else if c == '\\' then do | |
| let (c, i) ← decodeQuotedChar s i | |
| decodeStrLitAux s i (acc.push c) | |
| else | |
| decodeStrLitAux s i (acc.push c) | |
| def decodeStrLit (s : String) : Option String := | |
| decodeStrLitAux s ⟨1⟩ "" | |
| def isStrLit? (stx : Syntax) : Option String := | |
| match isLit? strLitKind stx with | |
| | some val => decodeStrLit val | |
| | _ => none | |
| def decodeCharLit (s : String) : Option Char := do | |
| let c := s.get ⟨1⟩ | |
| if c == '\\' then do | |
| let (c, _) ← decodeQuotedChar s ⟨2⟩ | |
| pure c | |
| else | |
| pure c | |
| def isCharLit? (stx : Syntax) : Option Char := | |
| match isLit? charLitKind stx with | |
| | some val => decodeCharLit val | |
| | _ => none | |
| private partial def splitNameLitAux (ss : Substring) (acc : List Substring) : List Substring := | |
| let splitRest (ss : Substring) (acc : List Substring) : List Substring := | |
| if ss.front == '.' then | |
| splitNameLitAux (ss.drop 1) acc | |
| else if ss.isEmpty then | |
| acc | |
| else | |
| [] | |
| if ss.isEmpty then [] | |
| else | |
| let curr := ss.front | |
| if isIdBeginEscape curr then | |
| let escapedPart := ss.takeWhile (!isIdEndEscape ·) | |
| let escapedPart := { escapedPart with stopPos := ss.stopPos.min (escapedPart.str.next escapedPart.stopPos) } | |
| if !isIdEndEscape (escapedPart.get <| escapedPart.prev ⟨escapedPart.bsize⟩) then [] | |
| else splitRest (ss.extract ⟨escapedPart.bsize⟩ ⟨ss.bsize⟩) (escapedPart :: acc) | |
| else if isIdFirst curr then | |
| let idPart := ss.takeWhile isIdRest | |
| splitRest (ss.extract ⟨idPart.bsize⟩ ⟨ss.bsize⟩) (idPart :: acc) | |
| else if curr.isDigit then | |
| let idPart := ss.takeWhile Char.isDigit | |
| splitRest (ss.extract ⟨idPart.bsize⟩ ⟨ss.bsize⟩) (idPart :: acc) | |
| else | |
| [] | |
| /-- Split a name literal (without the backtick) into its dot-separated components. For example, | |
| `foo.bla.«bo.o»` ↦ `["foo", "bla", "«bo.o»"]`. If the literal cannot be parsed, return `[]`. -/ | |
| def splitNameLit (ss : Substring) : List Substring := | |
| splitNameLitAux ss [] |>.reverse | |
| def decodeNameLit (s : String) : Option Name := | |
| if s.get 0 == '`' then | |
| match splitNameLitAux (s.toSubstring.drop 1) [] with | |
| | [] => none | |
| | comps => some <| comps.foldr (init := Name.anonymous) | |
| fun comp n => | |
| let comp := comp.toString | |
| if isIdBeginEscape comp.front then | |
| Name.mkStr n (comp.drop 1 |>.dropRight 1) | |
| else if comp.front.isDigit then | |
| if let some k := decodeNatLitVal? comp then | |
| Name.mkNum n k | |
| else | |
| unreachable! | |
| else | |
| Name.mkStr n comp | |
| else | |
| none | |
| def isNameLit? (stx : Syntax) : Option Name := | |
| match isLit? nameLitKind stx with | |
| | some val => decodeNameLit val | |
| | _ => none | |
| def hasArgs : Syntax → Bool | |
| | Syntax.node _ _ args => args.size > 0 | |
| | _ => false | |
| def isAtom : Syntax → Bool | |
| | atom _ _ => true | |
| | _ => false | |
| def isToken (token : String) : Syntax → Bool | |
| | atom _ val => val.trim == token.trim | |
| | _ => false | |
| def isNone (stx : Syntax) : Bool := | |
| match stx with | |
| | Syntax.node _ k args => k == nullKind && args.size == 0 | |
| -- when elaborating partial syntax trees, it's reasonable to interpret missing parts as `none` | |
| | Syntax.missing => true | |
| | _ => false | |
| def getOptionalIdent? (stx : Syntax) : Option Name := | |
| match stx.getOptional? with | |
| | some stx => some stx.getId | |
| | none => none | |
| partial def findAux (p : Syntax → Bool) : Syntax → Option Syntax | |
| | stx@(Syntax.node _ _ args) => if p stx then some stx else args.findSome? (findAux p) | |
| | stx => if p stx then some stx else none | |
| def find? (stx : Syntax) (p : Syntax → Bool) : Option Syntax := | |
| findAux p stx | |
| end Syntax | |
| namespace TSyntax | |
| def getNat (s : NumLit) : Nat := | |
| s.raw.isNatLit?.get! | |
| def getId (s : Ident) : Name := | |
| s.raw.getId | |
| def getScientific (s : ScientificLit) : Nat × Bool × Nat := | |
| s.raw.isScientificLit?.get! | |
| def getString (s : StrLit) : String := | |
| s.raw.isStrLit?.get! | |
| def getChar (s : CharLit) : Char := | |
| s.raw.isCharLit?.get! | |
| def getName (s : NameLit) : Name := | |
| s.raw.isNameLit?.get! | |
| namespace Compat | |
| scoped instance : CoeTail (Array Syntax) (Syntax.TSepArray k sep) where | |
| coe a := (a : TSyntaxArray k) | |
| end Compat | |
| end TSyntax | |
| /-- Reflect a runtime datum back to surface syntax (best-effort). -/ | |
| class Quote (α : Type) (k : SyntaxNodeKind := `term) where | |
| quote : α → TSyntax k | |
| export Quote (quote) | |
| instance [Quote α k] [CoeHTCT (TSyntax k) (TSyntax [k'])] : Quote α k' := ⟨fun a => quote (k := k) a⟩ | |
| instance : Quote Term := ⟨id⟩ | |
| instance : Quote Bool := ⟨fun | true => mkCIdent `Bool.true | false => mkCIdent `Bool.false⟩ | |
| instance : Quote String strLitKind := ⟨Syntax.mkStrLit⟩ | |
| instance : Quote Nat numLitKind := ⟨fun n => Syntax.mkNumLit <| toString n⟩ | |
| instance : Quote Substring := ⟨fun s => Syntax.mkCApp `String.toSubstring #[quote s.toString]⟩ | |
| -- in contrast to `Name.toString`, we can, and want to be, precise here | |
| private def getEscapedNameParts? (acc : List String) : Name → Option (List String) | |
| | Name.anonymous => if acc.isEmpty then none else some acc | |
| | Name.str n s => do | |
| let s ← Name.escapePart s | |
| getEscapedNameParts? (s::acc) n | |
| | Name.num _ _ => none | |
| def quoteNameMk : Name → Term | |
| | Name.anonymous => mkCIdent ``Name.anonymous | |
| | Name.str n s => Syntax.mkCApp ``Name.mkStr #[quoteNameMk n, quote s] | |
| | Name.num n i => Syntax.mkCApp ``Name.mkNum #[quoteNameMk n, quote i] | |
| instance : Quote Name `term where | |
| quote n := match getEscapedNameParts? [] n with | |
| | some ss => ⟨mkNode `Lean.Parser.Term.quotedName #[Syntax.mkNameLit ("`" ++ ".".intercalate ss)]⟩ | |
| | none => ⟨quoteNameMk n⟩ | |
| instance [Quote α `term] [Quote β `term] : Quote (α × β) `term where | |
| quote | |
| | ⟨a, b⟩ => Syntax.mkCApp ``Prod.mk #[quote a, quote b] | |
| private def quoteList [Quote α `term] : List α → Term | |
| | [] => mkCIdent ``List.nil | |
| | (x::xs) => Syntax.mkCApp ``List.cons #[quote x, quoteList xs] | |
| instance [Quote α `term] : Quote (List α) `term where | |
| quote := quoteList | |
| instance [Quote α `term] : Quote (Array α) `term where | |
| quote xs := Syntax.mkCApp ``List.toArray #[quote xs.toList] | |
| instance Option.hasQuote {α : Type} [Quote α `term] : Quote (Option α) `term where | |
| quote | |
| | none => mkIdent ``none | |
| | (some x) => Syntax.mkCApp ``some #[quote x] | |
| /-- Evaluator for `prec` DSL -/ | |
| def evalPrec (stx : Syntax) : MacroM Nat := | |
| Macro.withIncRecDepth stx do | |
| let stx ← expandMacros stx | |
| match stx with | |
| | `(prec| $num:num) => return num.getNat | |
| | _ => Macro.throwErrorAt stx "unexpected precedence" | |
| macro_rules | |
| | `(prec| $a + $b) => do `(prec| $(quote <| (← evalPrec a) + (← evalPrec b)):num) | |
| macro_rules | |
| | `(prec| $a - $b) => do `(prec| $(quote <| (← evalPrec a) - (← evalPrec b)):num) | |
| macro "eval_prec " p:prec:max : term => return quote (k := `term) (← evalPrec p) | |
| /-- Evaluator for `prio` DSL -/ | |
| def evalPrio (stx : Syntax) : MacroM Nat := | |
| Macro.withIncRecDepth stx do | |
| let stx ← expandMacros stx | |
| match stx with | |
| | `(prio| $num:num) => return num.getNat | |
| | _ => Macro.throwErrorAt stx "unexpected priority" | |
| macro_rules | |
| | `(prio| $a + $b) => do `(prio| $(quote <| (← evalPrio a) + (← evalPrio b)):num) | |
| macro_rules | |
| | `(prio| $a - $b) => do `(prio| $(quote <| (← evalPrio a) - (← evalPrio b)):num) | |
| macro "eval_prio " p:prio:max : term => return quote (k := `term) (← evalPrio p) | |
| def evalOptPrio : Option (TSyntax `prio) → MacroM Nat | |
| | some prio => evalPrio prio | |
| | none => return 1000 -- TODO: FIX back eval_prio default | |
| end Lean | |
| namespace Array | |
| abbrev getSepElems := @getEvenElems | |
| open Lean | |
| private partial def filterSepElemsMAux {m : Type → Type} [Monad m] (a : Array Syntax) (p : Syntax → m Bool) (i : Nat) (acc : Array Syntax) : m (Array Syntax) := do | |
| if h : i < a.size then | |
| let stx := a[i] | |
| if (← p stx) then | |
| if acc.isEmpty then | |
| filterSepElemsMAux a p (i+2) (acc.push stx) | |
| else if hz : i ≠ 0 then | |
| have : i.pred < i := Nat.pred_lt hz | |
| have : i.pred < a.size := Nat.lt_trans this h | |
| let sepStx := a[i.pred] | |
| filterSepElemsMAux a p (i+2) ((acc.push sepStx).push stx) | |
| else | |
| filterSepElemsMAux a p (i+2) (acc.push stx) | |
| else | |
| filterSepElemsMAux a p (i+2) acc | |
| else | |
| pure acc | |
| def filterSepElemsM {m : Type → Type} [Monad m] (a : Array Syntax) (p : Syntax → m Bool) : m (Array Syntax) := | |
| filterSepElemsMAux a p 0 #[] | |
| def filterSepElems (a : Array Syntax) (p : Syntax → Bool) : Array Syntax := | |
| Id.run <| a.filterSepElemsM p | |
| private partial def mapSepElemsMAux {m : Type → Type} [Monad m] (a : Array Syntax) (f : Syntax → m Syntax) (i : Nat) (acc : Array Syntax) : m (Array Syntax) := do | |
| if h : i < a.size then | |
| let stx := a[i] | |
| if i % 2 == 0 then do | |
| let stx ← f stx | |
| mapSepElemsMAux a f (i+1) (acc.push stx) | |
| else | |
| mapSepElemsMAux a f (i+1) (acc.push stx) | |
| else | |
| pure acc | |
| def mapSepElemsM {m : Type → Type} [Monad m] (a : Array Syntax) (f : Syntax → m Syntax) : m (Array Syntax) := | |
| mapSepElemsMAux a f 0 #[] | |
| def mapSepElems (a : Array Syntax) (f : Syntax → Syntax) : Array Syntax := | |
| Id.run <| a.mapSepElemsM f | |
| end Array | |
| namespace Lean.Syntax | |
| def SepArray.getElems (sa : SepArray sep) : Array Syntax := | |
| sa.elemsAndSeps.getSepElems | |
| def TSepArray.getElems (sa : TSepArray k sep) : TSyntaxArray k := | |
| .mk sa.elemsAndSeps.getSepElems | |
| def TSepArray.push (sa : TSepArray k sep) (e : TSyntax k) : TSepArray k sep := | |
| if sa.elemsAndSeps.isEmpty then | |
| { elemsAndSeps := #[e] } | |
| else | |
| { elemsAndSeps := sa.elemsAndSeps.push (mkAtom sep) |>.push e } | |
| instance : EmptyCollection (SepArray sep) where | |
| emptyCollection := ⟨∅⟩ | |
| instance : EmptyCollection (TSepArray sep k) where | |
| emptyCollection := ⟨∅⟩ | |
| /- | |
| We use `CoeTail` here instead of `Coe` to avoid a "loop" when computing `CoeTC`. | |
| The "loop" is interrupted using the maximum instance size threshold, but it is a performance bottleneck. | |
| The loop occurs because the predicate `isNewAnswer` is too imprecise. | |
| -/ | |
| instance : CoeTail (SepArray sep) (Array Syntax) where | |
| coe := SepArray.getElems | |
| instance : Coe (TSepArray k sep) (TSyntaxArray k) where | |
| coe := TSepArray.getElems | |
| instance [Coe (TSyntax k) (TSyntax k')] : Coe (TSyntaxArray k) (TSyntaxArray k') where | |
| coe a := a.map Coe.coe | |
| instance : Coe (TSyntaxArray k) (Array Syntax) where | |
| coe a := a.raw | |
| instance : Coe Ident (TSyntax `Lean.Parser.Command.declId) where | |
| coe id := mkNode _ #[id, mkNullNode #[]] | |
| instance : Coe (Lean.Term) (Lean.TSyntax `Lean.Parser.Term.funBinder) where | |
| coe stx := ⟨stx⟩ | |
| end Lean.Syntax | |
| set_option linter.unusedVariables.funArgs false in | |
| /-- | |
| Gadget for automatic parameter support. This is similar to the `optParam` gadget, but it uses | |
| the given tactic. | |
| Like `optParam`, this gadget only affects elaboration. | |
| For example, the tactic will *not* be invoked during type class resolution. -/ | |
| abbrev autoParam.{u} (α : Sort u) (tactic : Lean.Syntax) : Sort u := α | |
| /-! # Helper functions for manipulating interpolated strings -/ | |
| namespace Lean.Syntax | |
| private def decodeInterpStrQuotedChar (s : String) (i : String.Pos) : Option (Char × String.Pos) := do | |
| match decodeQuotedChar s i with | |
| | some r => some r | |
| | none => | |
| let c := s.get i | |
| let i := s.next i | |
| if c == '{' then pure ('{', i) | |
| else none | |
| private partial def decodeInterpStrLit (s : String) : Option String := | |
| let rec loop (i : String.Pos) (acc : String) : Option String := | |
| let c := s.get i | |
| let i := s.next i | |
| if c == '\"' || c == '{' then | |
| pure acc | |
| else if s.atEnd i then | |
| none | |
| else if c == '\\' then do | |
| let (c, i) ← decodeInterpStrQuotedChar s i | |
| loop i (acc.push c) | |
| else | |
| loop i (acc.push c) | |
| loop ⟨1⟩ "" | |
| partial def isInterpolatedStrLit? (stx : Syntax) : Option String := | |
| match isLit? interpolatedStrLitKind stx with | |
| | none => none | |
| | some val => decodeInterpStrLit val | |
| def getSepArgs (stx : Syntax) : Array Syntax := | |
| stx.getArgs.getSepElems | |
| end Syntax | |
| namespace TSyntax | |
| def expandInterpolatedStrChunks (chunks : Array Syntax) (mkAppend : Syntax → Syntax → MacroM Syntax) (mkElem : Syntax → MacroM Syntax) : MacroM Syntax := do | |
| let mut i := 0 | |
| let mut result := Syntax.missing | |
| for elem in chunks do | |
| let elem ← match elem.isInterpolatedStrLit? with | |
| | none => mkElem elem | |
| | some str => mkElem (Syntax.mkStrLit str) | |
| if i == 0 then | |
| result := elem | |
| else | |
| result ← mkAppend result elem | |
| i := i+1 | |
| return result | |
| open TSyntax.Compat in | |
| def expandInterpolatedStr (interpStr : TSyntax interpolatedStrKind) (type : Term) (toTypeFn : Term) : MacroM Term := do | |
| let r ← expandInterpolatedStrChunks interpStr.raw.getArgs (fun a b => `($a ++ $b)) (fun a => `($toTypeFn $a)) | |
| `(($r : $type)) | |
| end TSyntax | |
| namespace Meta | |
| inductive TransparencyMode where | |
| | all | default | reducible | instances | |
| deriving Inhabited, BEq, Repr | |
| inductive EtaStructMode where | |
| | /-- Enable eta for structure and classes. -/ | |
| all | |
| | /-- Enable eta only for structures that are not classes. -/ | |
| notClasses | |
| | /-- Disable eta for structures and classes. -/ | |
| none | |
| deriving Inhabited, BEq, Repr | |
| namespace DSimp | |
| structure Config where | |
| zeta : Bool := true | |
| beta : Bool := true | |
| eta : Bool := true | |
| etaStruct : EtaStructMode := .all | |
| iota : Bool := true | |
| proj : Bool := true | |
| decide : Bool := true | |
| autoUnfold : Bool := false | |
| deriving Inhabited, BEq, Repr | |
| end DSimp | |
| namespace Simp | |
| def defaultMaxSteps := 100000 | |
| structure Config where | |
| maxSteps : Nat := defaultMaxSteps | |
| maxDischargeDepth : Nat := 2 | |
| contextual : Bool := false | |
| memoize : Bool := true | |
| singlePass : Bool := false | |
| zeta : Bool := true | |
| beta : Bool := true | |
| eta : Bool := true | |
| etaStruct : EtaStructMode := .all | |
| iota : Bool := true | |
| proj : Bool := true | |
| decide : Bool := true | |
| arith : Bool := false | |
| autoUnfold : Bool := false | |
| /-- | |
| If `dsimp := true`, then switches to `dsimp` on dependent arguments where there is no congruence theorem that allows | |
| `simp` to visit them. If `dsimp := false`, then argument is not visited. | |
| -/ | |
| dsimp : Bool := true | |
| deriving Inhabited, BEq, Repr | |
| -- Configuration object for `simp_all` | |
| structure ConfigCtx extends Config where | |
| contextual := true | |
| def neutralConfig : Simp.Config := { | |
| zeta := false | |
| beta := false | |
| eta := false | |
| iota := false | |
| proj := false | |
| decide := false | |
| arith := false | |
| autoUnfold := false | |
| } | |
| end Simp | |
| namespace Rewrite | |
| structure Config where | |
| transparency : TransparencyMode := TransparencyMode.reducible | |
| offsetCnstrs : Bool := true | |
| end Rewrite | |
| end Meta | |
| namespace Parser.Tactic | |
| /-- `erw [rules]` is a shorthand for `rw (config := { transparency := .default }) [rules]`. | |
| This does rewriting up to unfolding of regular definitions (by comparison to regular `rw` | |
| which only unfolds `@[reducible]` definitions). -/ | |
| macro "erw " s:rwRuleSeq loc:(location)? : tactic => | |
| `(rw (config := { transparency := .default }) $s $(loc)?) | |
| syntax simpAllKind := atomic("(" &"all") " := " &"true" ")" | |
| syntax dsimpKind := atomic("(" &"dsimp") " := " &"true" ")" | |
| macro (name := declareSimpLikeTactic) doc?:(docComment)? "declare_simp_like_tactic" opt:((simpAllKind <|> dsimpKind)?) tacName:ident tacToken:str updateCfg:term : command => do | |
| let (kind, tkn, stx) ← | |
| if opt.raw.isNone then | |
| pure (← `(``simp), ← `("simp "), ← `($[$doc?:docComment]? syntax (name := $tacName) $tacToken:str (config)? (discharger)? (&"only ")? ("[" (simpStar <|> simpErase <|> simpLemma),* "]")? (location)? : tactic)) | |
| else if opt.raw[0].getKind == ``simpAllKind then | |
| pure (← `(``simpAll), ← `("simp_all "), ← `($[$doc?:docComment]? syntax (name := $tacName) $tacToken:str (config)? (discharger)? (&"only ")? ("[" (simpErase <|> simpLemma),* "]")? : tactic)) | |
| else | |
| pure (← `(``dsimp), ← `("dsimp "), ← `($[$doc?:docComment]? syntax (name := $tacName) $tacToken:str (config)? (discharger)? (&"only ")? ("[" (simpErase <|> simpLemma),* "]")? (location)? : tactic)) | |
| `($stx:command | |
| @[macro $tacName] def expandSimp : Macro := fun s => do | |
| let c ← match s[1][0] with | |
| | `(config| (config := $$c)) => `(config| (config := $updateCfg $$c)) | |
| | _ => `(config| (config := $updateCfg {})) | |
| let s := s.setKind $kind | |
| let s := s.setArg 0 (mkAtomFrom s[0] $tkn) | |
| let r := s.setArg 1 (mkNullNode #[c]) | |
| return r) | |
| /-- `simp!` is shorthand for `simp` with `autoUnfold := true`. | |
| This will rewrite with all equation lemmas, which can be used to | |
| partially evaluate many definitions. -/ | |
| declare_simp_like_tactic simpAutoUnfold "simp! " fun (c : Lean.Meta.Simp.Config) => { c with autoUnfold := true } | |
| /-- `simp_arith` is shorthand for `simp` with `arith := true`. | |
| This enables the use of normalization by linear arithmetic. -/ | |
| declare_simp_like_tactic simpArith "simp_arith " fun (c : Lean.Meta.Simp.Config) => { c with arith := true } | |
| /-- `simp_arith!` is shorthand for `simp_arith` with `autoUnfold := true`. | |
| This will rewrite with all equation lemmas, which can be used to | |
| partially evaluate many definitions. -/ | |
| declare_simp_like_tactic simpArithAutoUnfold "simp_arith! " fun (c : Lean.Meta.Simp.Config) => { c with arith := true, autoUnfold := true } | |
| /-- `simp_all!` is shorthand for `simp_all` with `autoUnfold := true`. | |
| This will rewrite with all equation lemmas, which can be used to | |
| partially evaluate many definitions. -/ | |
| declare_simp_like_tactic (all := true) simpAllAutoUnfold "simp_all! " fun (c : Lean.Meta.Simp.ConfigCtx) => { c with autoUnfold := true } | |
| /-- `simp_all_arith` combines the effects of `simp_all` and `simp_arith`. -/ | |
| declare_simp_like_tactic (all := true) simpAllArith "simp_all_arith " fun (c : Lean.Meta.Simp.ConfigCtx) => { c with arith := true } | |
| /-- `simp_all_arith!` combines the effects of `simp_all`, `simp_arith` and `simp!`. -/ | |
| declare_simp_like_tactic (all := true) simpAllArithAutoUnfold "simp_all_arith! " fun (c : Lean.Meta.Simp.ConfigCtx) => { c with arith := true, autoUnfold := true } | |
| /-- `dsimp!` is shorthand for `dsimp` with `autoUnfold := true`. | |
| This will rewrite with all equation lemmas, which can be used to | |
| partially evaluate many definitions. -/ | |
| declare_simp_like_tactic (dsimp := true) dsimpAutoUnfold "dsimp! " fun (c : Lean.Meta.DSimp.Config) => { c with autoUnfold := true } | |
| end Parser.Tactic | |
| end Lean |