/- 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