diff --git a/tmp/Basic.lean b/tmp/Basic.lean deleted file mode 100644 index bf4521d756..0000000000 --- a/tmp/Basic.lean +++ /dev/null @@ -1,469 +0,0 @@ -/- -Copyright (c) 2019 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Leonardo de Moura, Sebastian Ullrich --/ -prelude -import Init.Control.Reader -import Init.Lean.Meta -import Init.Lean.Parser.Module - -namespace Lean -namespace Elab - -/- -structure ElabContext := -(fileName : String) -(fileMap : FileMap) - -structure ElabScope := -(cmd : String) -(header : Name) -(options : Options := {}) -(ns : Name := Name.anonymous) -- current namespace -(openDecls : List OpenDecl := []) -(univs : List Name := []) -(lctx : LocalContext := {}) -(nextInstIdx : Nat := 1) -(inPattern : Bool := false) - -namespace ElabScope - -instance : Inhabited ElabScope := ⟨{ cmd := "", header := arbitrary _ }⟩ - -end ElabScope - -structure ElabState := -(env : Environment) -(messages : MessageLog := {}) -(cmdPos : String.Pos := 0) -(ngen : NameGenerator := {}) -(mctx : MetavarContext := {}) -(scopes : List ElabScope := [{ cmd := "root", header := Name.anonymous }]) - -inductive ElabException -| io : IO.Error → ElabException -| msg : Message → ElabException -| kernel : KernelException → ElabException -| other : String → ElabException -/- ElabException.silent is used when we log an error in `messages`, and then - want to interrupt the elaborator execution. We use it to make sure the - top-level handler does not record it again in `messages`. See `logErrorAndThrow` -/ -| silent : ElabException - -namespace ElabException - -instance : Inhabited ElabException := ⟨other "error"⟩ - -end ElabException - -abbrev Elab := ReaderT ElabContext (EStateM ElabException ElabState) - -instance str2ElabException : HasCoe String ElabException := ⟨ElabException.other⟩ - -abbrev TermElab := SyntaxNode Expr → Option Expr → Elab (Syntax Expr) -abbrev CommandElab := SyntaxNode → Elab Unit - -abbrev TermElabTable : Type := SMap SyntaxNodeKind TermElab -abbrev CommandElabTable : Type := SMap SyntaxNodeKind CommandElab -def mkBuiltinTermElabTable : IO (IO.Ref TermElabTable) := IO.mkRef {} -def mkBuiltinCommandElabTable : IO (IO.Ref CommandElabTable) := IO.mkRef {} -@[init mkBuiltinTermElabTable] -constant builtinTermElabTable : IO.Ref TermElabTable := arbitrary _ -@[init mkBuiltinCommandElabTable] -constant builtinCommandElabTable : IO.Ref CommandElabTable := arbitrary _ - -def addBuiltinTermElab (k : SyntaxNodeKind) (declName : Name) (elab : TermElab) : IO Unit := -do m ← builtinTermElabTable.get; - when (m.contains k) $ - throw (IO.userError ("invalid builtin term elaborator, elaborator for '" ++ toString k ++ "' has already been defined")); - builtinTermElabTable.modify $ fun m => m.insert k elab - -def addBuiltinCommandElab (k : SyntaxNodeKind) (declName : Name) (elab : CommandElab) : IO Unit := -do m ← builtinCommandElabTable.get; - when (m.contains k) $ - throw (IO.userError ("invalid builtin command elaborator, elaborator for '" ++ toString k ++ "' has already been defined")); - builtinCommandElabTable.modify $ fun m => m.insert k elab - -def checkSyntaxNodeKind (k : Name) : IO Name := -do b ← Parser.isValidSyntaxNodeKind k; - if b then pure k - else throw (IO.userError "failed") - -def checkSyntaxNodeKindAtNamespaces (k : Name) : List Name → IO Name -| [] => throw (IO.userError "failed") -| n::ns => checkSyntaxNodeKind (n ++ k) <|> checkSyntaxNodeKindAtNamespaces ns - -def syntaxNodeKindOfAttrParam (env : Environment) (parserNamespace : Name) (arg : Syntax) : IO SyntaxNodeKind := -match attrParamSyntaxToIdentifier arg with -| some k => - checkSyntaxNodeKind k - <|> - checkSyntaxNodeKindAtNamespaces k env.getNamespaces - <|> - checkSyntaxNodeKind (parserNamespace ++ k) - <|> - throw (IO.userError ("invalid syntax node kind '" ++ toString k ++ "'")) -| none => throw (IO.userError ("syntax node kind is missing")) - -def declareBuiltinElab (env : Environment) (addFn : Name) (kind : SyntaxNodeKind) (declName : Name) : IO Environment := -let name := `_regBuiltinTermElab ++ declName; -let type := mkApp (mkConst `IO) (mkConst `Unit); -let val := mkAppN (mkConst addFn) #[toExpr kind, toExpr declName, mkConst declName]; -let decl := Declaration.defnDecl { name := name, lparams := [], type := type, value := val, hints := ReducibilityHints.opaque, isUnsafe := false }; -match env.addAndCompile {} decl with --- TODO: pretty print error -| Except.error _ => throw (IO.userError ("failed to emit registration code for builtin term elaborator '" ++ toString declName ++ "'")) -| Except.ok env => IO.ofExcept (setInitAttr env name) - -def declareBuiltinTermElab (env : Environment) (kind : SyntaxNodeKind) (declName : Name) : IO Environment := -declareBuiltinElab env `Lean.addBuiltinTermElab kind declName - -def declareBuiltinCommandElab (env : Environment) (kind : SyntaxNodeKind) (declName : Name) : IO Environment := -declareBuiltinElab env `Lean.addBuiltinCommandElab kind declName - -@[init] def registerBuiltinTermElabAttr : IO Unit := -registerAttribute { - name := `builtinTermElab, - descr := "Builtin term elaborator", - add := fun env declName arg persistent => do { - unless persistent $ throw (IO.userError ("invalid attribute 'builtinTermElab', must be persistent")); - kind ← syntaxNodeKindOfAttrParam env `Lean.Parser.Term arg; - match env.find declName with - | none => throw "unknown declaration" - | some decl => - match decl.type with - | Expr.const `Lean.TermElab _ _ => declareBuiltinTermElab env kind declName - | _ => throw (IO.userError ("unexpected term elaborator type at '" ++ toString declName ++ "' `TermElab` expected")) - }, - applicationTime := AttributeApplicationTime.afterCompilation -} - -@[init] def registerBuiltinCommandElabAttr : IO Unit := -registerAttribute { - name := `builtinCommandElab, - descr := "Builtin command elaborator", - add := fun env declName arg persistent => do { - unless persistent $ throw (IO.userError ("invalid attribute 'builtinCommandElab', must be persistent")); - kind ← syntaxNodeKindOfAttrParam env `Lean.Parser.Command arg; - match env.find declName with - | none => throw "unknown declaration" - | some decl => - match decl.type with - | Expr.const `Lean.CommandElab _ _ => declareBuiltinCommandElab env kind declName - | _ => throw (IO.userError ("unexpected command elaborator type at '" ++ toString declName ++ "' `CommandElab` expected")) - }, - applicationTime := AttributeApplicationTime.afterCompilation -} - -structure ElabAttributeEntry := -(kind : SyntaxNodeKind) -(declName : Name) - -structure ElabAttribute (σ : Type) := -(attr : AttributeImpl) -(ext : PersistentEnvExtension ElabAttributeEntry σ) -(kind : String) - -namespace ElabAttribute - -instance {σ} [Inhabited σ] : Inhabited (ElabAttribute σ) := ⟨{ attr := arbitrary _, ext := arbitrary _, kind := "" }⟩ - -end ElabAttribute - -/- -This is just the basic skeleton for the `[termElab]` attribute and environment extension. -The state is initialized using `builtinTermElabTable`. - -The current implementation just uses the bultin elaborators. --/ -def mkElabAttribute {σ} [Inhabited σ] (attrName : Name) (kind : String) (builtinTable : IO.Ref σ) : IO (ElabAttribute σ) := -do ext : PersistentEnvExtension ElabAttributeEntry σ ← registerPersistentEnvExtension { - name := attrName, - addImportedFn := fun es => do - table ← builtinTable.get; - -- TODO: populate table with `es` - pure table, - addEntryFn := fun (s : σ) _ => s, -- TODO - exportEntriesFn := fun _ => #[], -- TODO - statsFn := fun _ => fmt (kind ++ " elaborator attribute") -- TODO - }; - let attrImpl : AttributeImpl := { - name := attrName, - descr := kind ++ " elaborator", - add := fun env decl args persistent => pure env -- TODO - }; - pure { ext := ext, attr := attrImpl, kind := kind } - -abbrev TermElabAttribute := ElabAttribute TermElabTable -def mkTermElabAttribute : IO TermElabAttribute := -mkElabAttribute `elabTerm "term" builtinTermElabTable -@[init mkTermElabAttribute] -constant termElabAttribute : TermElabAttribute := arbitrary _ - -abbrev CommandElabAttribute := ElabAttribute CommandElabTable -def mkCommandElabAttribute : IO CommandElabAttribute := -mkElabAttribute `commandTerm "command" builtinCommandElabTable -@[init mkCommandElabAttribute] -constant commandElabAttribute : CommandElabAttribute := arbitrary _ - -namespace Elab -def logMessage (msg : Message) : Elab Unit := -modify $ fun s => { messages := s.messages.add msg, .. s } - -def getPosition (pos : Option String.Pos := none) : Elab Position := -do ctx ← read; - s ← get; - pure $ ctx.fileMap.toPosition (pos.getD s.cmdPos) - -def mkMessage (msg : String) (pos : Option String.Pos := none) : Elab Message := -do ctx ← read; - s ← get; - let pos := ctx.fileMap.toPosition (pos.getD s.cmdPos); - pure { fileName := ctx.fileName, pos := pos, data := msg } - -def logErrorAt (pos : String.Pos) (errorMsg : String) : Elab Unit := -mkMessage errorMsg pos >>= logMessage - -def logErrorUsingCmdPos (errorMsg : String) : Elab Unit := -do s ← get; - logErrorAt s.cmdPos errorMsg - -def getPos {α} (stx : Syntax α) : Elab String.Pos := -match stx.getPos with -| some p => pure p -| none => do s ← get; pure s.cmdPos - -def logError {α} (stx : Syntax α) (errorMsg : String) : Elab Unit := -do pos ← getPos stx; - logErrorAt pos errorMsg - -def logElabException (e : ElabException) : Elab Unit := -let log (msg : Message) : Elab Unit := - modify $ fun s => { messages := s.messages.add msg, .. s }; -match e with -| ElabException.silent => pure () -- do nothing since message was already logged -| ElabException.msg m => log m -| ElabException.io e => mkMessage (toString e) >>= log -| ElabException.other e => mkMessage e >>= log -| ElabException.kernel e => - match e with - | KernelException.other msg => mkMessage msg >>= log - | _ => mkMessage "kernel exception" >>= log -- TODO(pretty print them) - -def logErrorAndThrow {α β : Type} (stx : Syntax β) (errorMsg : String) : Elab α := -do logError stx errorMsg; - throw ElabException.silent - -def logUnknownDecl {α} (stx : Syntax α) (declName : Name) : Elab Unit := -logError stx ("unknown declaration '" ++ toString declName ++ "'") - -def getEnv : Elab Environment := -do s ← get; pure s.env - -def setEnv (env : Environment) : Elab Unit := -modify $ fun s => { env := env, .. s } - -def elabCommand (stx : Syntax) : Elab Unit := -stx.ifNode - (fun n => do - s ← get; - let tables := commandElabAttribute.ext.getState s.env; - let k := n.getKind; - match tables.find k with - | some elab => elab n - | none => logError stx ("command '" ++ toString k ++ "' has not been implemented")) - (fun _ => logErrorUsingCmdPos ("unexpected command")) --/ - -structure ElabContext := -(fileName : String) -(fileMap : FileMap) - -inductive ElabException -| io : IO.Error → ElabException -| msg : Message → ElabException -| kernel : KernelException → ElabException - -structure ElabState := -(dummy : Unit := ()) - -structure FrontendState := -(elabState : ElabState) -(parserState : Parser.ModuleParserState) - -abbrev Frontend := ReaderT Parser.ParserContextCore (EStateM ElabException FrontendState) - -/- -def getElabContext : Frontend ElabContext := -do c ← read; - pure { fileName := c.fileName, fileMap := c.fileMap } - -@[specialize] def runElab {α} (x : Elab α) : Frontend α := -do c ← getElabContext; - monadLift $ EStateM.adaptState - (fun (s : FrontendState) => (s.elabState, s.parserState)) - (fun es ps => { elabState := es, parserState := ps }) - (x c) - -def elabCommandAtFrontend (stx : Syntax) : Frontend Unit := -runElab (elabCommand stx) - -def updateCmdPos : Frontend Unit := -modify $ fun s => { elabState := { cmdPos := s.parserState.pos, .. s.elabState }, .. s } - -def processCommand : Frontend Bool := -do updateCmdPos; - s ← get; - let es := s.elabState; - let ps := s.parserState; - c ← read; - match Parser.parseCommand es.env c ps es.messages with - | (cmd, ps, messages) => do - set { elabState := { messages := messages, .. es }, parserState := ps }; - if Parser.isEOI cmd || Parser.isExitCommand cmd then do - pure true -- Done - else do - catch (elabCommandAtFrontend cmd) $ fun e => runElab (logElabException e); - pure false - -partial def processCommandsAux : Unit → Frontend Unit -| () => do - done ← processCommand; - if done then pure () - else processCommandsAux () - -def processCommands : Frontend Unit := -processCommandsAux () - -def testFrontend (input : String) (fileName : Option String := none) : IO (Environment × MessageLog) := -do env ← mkEmptyEnvironment; - let fileName := fileName.getD ""; - let ctx := Parser.mkParserContextCore env input fileName; - match Parser.parseHeader env ctx with - | (header, parserState, messages) => do - (env, messages) ← processHeader header messages ctx; - let elabState := { ElabState . env := env, messages := messages }; - match (processCommands ctx).run { elabState := elabState, parserState := parserState } with - | EStateM.Result.ok _ s => pure (s.elabState.env, s.elabState.messages) - | EStateM.Result.error _ s => pure (s.elabState.env, s.elabState.messages) - -instance {α} : Inhabited (Elab α) := -⟨fun _ => arbitrary _⟩ - -def mkFreshName : Elab Name := -modifyGet $ fun s => (s.ngen.curr, { ngen := s.ngen.next, .. s }) - -def getScope : Elab ElabScope := -do s ← get; pure s.scopes.head! - -def getOpenDecls : Elab (List OpenDecl) := -ElabScope.openDecls <$> getScope - -def getUniverses : Elab (List Name) := -ElabScope.univs <$> getScope - -def getNamespace : Elab Name := -do s ← get; - match s.scopes with - | [] => pure Name.anonymous - | (sc::_) => pure sc.ns - -@[specialize] def modifyScope (f : ElabScope → ElabScope) : Elab Unit := -modify $ fun s => - { scopes := match s.scopes with - | h::t => f h :: t - | [] => [], -- unreachable - .. s } - -@[specialize] def modifyGetScope {α} [Inhabited α] (f : ElabScope → α × ElabScope) : Elab α := -modifyGet $ fun s => - match s with - | { scopes := h::t, .. } => - let (a, h) := f h; - (a, { scopes := h :: t, .. s }) - | _ => (arbitrary _, s) - -def localContext : Elab LocalContext := -do scope ← getScope; pure scope.lctx - -def mkLocalDecl (userName : Name) (type : Expr) (bi : BinderInfo := BinderInfo.default) : Elab Expr := -do idx ← mkFreshName; - modifyScope $ fun scope => { lctx := scope.lctx.mkLocalDecl idx userName type bi, .. scope }; - pure (mkFVar idx) - -def mkLambda (xs : Array Expr) (b : Expr) : Elab Expr := -do lctx ← localContext; pure $ lctx.mkLambda xs b - -def mkForall (xs : Array Expr) (b : Expr) : Elab Expr := -do lctx ← localContext; pure $ lctx.mkForall xs b - -def anonymousInstNamePrefix := `_inst - -def mkAnonymousInstName : Elab Name := -do scope ← getScope; - let n := anonymousInstNamePrefix.appendIndexAfter scope.nextInstIdx; - modifyScope $ fun scope => { nextInstIdx := scope.nextInstIdx + 1, .. scope }; - pure n - -def resolveNamespaceUsingScopes (env : Environment) (n : Name) : List ElabScope → Option Name -| [] => none -| { ns := ns, .. } :: scopes => if isNamespace env (ns ++ n) then some (ns ++ n) else resolveNamespaceUsingScopes scopes - -def resolveNamespaceUsingOpenDecls (env : Environment) (n : Name) : List OpenDecl → Option Name -| [] => none -| OpenDecl.simple ns [] :: ds => if isNamespace env (ns ++ n) then some (ns ++ n) else resolveNamespaceUsingOpenDecls ds -| _ :: ds => resolveNamespaceUsingOpenDecls ds - -/- -Given a name `n` try to find namespace it refers to. The resolution procedure works as follows -1- If `n` is the extact name of an existing namespace, then return `n` -2- If `n` is in the scope of `namespace` commands declaring namespace headers `h_1`, ..., `h_n`, - then return `h_1 ++ ... ++ h_i ++ n` if it is the name of an existing namespace. We search "backwards". -3- Finally, for each command `open N`, return `N ++ n` if it is the name of an existing namespace. - We search "backwards" again. That is, we try the most recent `open` command first. - We only consider simple `open` commands. --/ -def resolveNamespace (n : Name) : Elab Name := -do s ← get; - if isNamespace s.env n then pure n - else match resolveNamespaceUsingScopes s.env n s.scopes with - | some n => pure n - | none => do - openDecls ← getOpenDecls; - match resolveNamespaceUsingOpenDecls s.env n openDecls with - | some n => pure n - | none => throw (ElabException.other ("unknown namespace '" ++ toString n ++ "'")) - -@[inline] def withNewScope {α} (x : Elab α) : Elab α := -do modify $ fun s => { scopes := s.scopes.head! :: s.scopes, .. s }; - a ← x; - modify $ fun s => { scopes := s.scopes.tail!, .. s}; - pure a - -@[inline] def withInPattern {α} (x : Elab α) : Elab α := -withNewScope $ do - modifyScope $ fun scope => { inPattern := true, .. scope }; - x - -def inPattern : Elab Bool := -do scope ← getScope; pure $ scope.inPattern - -/- Remark: in an ideal world where performance doesn't matter, we would define `Elab` as - ``` - ExceptT ElabException (StateT ElabException IO) - ``` - and we would not need unsafe features for implementing `runIO`. - We say `Elab` is "morally" built on top of `IO`. -/ -unsafe def runIOUnsafe {α : Type} (x : IO α) : Elab α := -match unsafeIO x with -| Except.ok a => pure a -| Except.error e => throw (ElabException.io e) - -@[implementedBy runIOUnsafe] -constant runIO {α : Type} (x : IO α) : Elab α := arbitrary _ - -end Elab --/ -end Elab -end Lean diff --git a/tmp/PreludeNew.lean b/tmp/PreludeNew.lean deleted file mode 100644 index dff4ff4975..0000000000 --- a/tmp/PreludeNew.lean +++ /dev/null @@ -1,1657 +0,0 @@ -/- -Copyright (c) 2014 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Leonardo de Moura - -notation, basic datatypes and type classes --/ -prelude - -universes u v w - -@[inline] def id {α : Sort u} (a : α) : α := a - -abbrev Function.comp {α : Sort u} {β : Sort v} {δ : Sort w} (f : β → δ) (g : α → β) : α → δ := - fun x => f (g x) - -abbrev Function.const {α : Sort u} (β : Sort v) (a : α) : β → α := - fun x => a - -set_option bootstrap.inductiveCheckResultingUniverse false in -inductive PUnit : Sort u - | unit : PUnit - -/-- An abbreviation for `PUnit.{0}`, its most common instantiation. - This Type should be preferred over `PUnit` where possible to avoid - unnecessary universe parameters. -/ -abbrev Unit : Type := PUnit - -@[matchPattern] abbrev Unit.unit : Unit := PUnit.unit - -/-- Auxiliary unsafe constant used by the Compiler when erasing proofs from code. -/ -unsafe axiom lcProof {α : Prop} : α - -/-- Auxiliary unsafe constant used by the Compiler to mark unreachable code. -/ -unsafe axiom lcUnreachable {α : Sort u} : α - -inductive True : Prop - | intro : True - -inductive False : Prop - -inductive Empty : Type - -def Not (a : Prop) : Prop := a → False - -@[macroInline] def False.elim {C : Sort u} (h : False) : C := - False.rec (fun _ => C) h - -@[macroInline] def absurd {a : Prop} {b : Sort v} (h₁ : a) (h₂ : Not a) : b := - False.elim (h₂ h₁) - -inductive Eq {α : Sort u} (a : α) : α → Prop - | refl {} : Eq a a - -abbrev Eq.ndrec.{u1, u2} {α : Sort u2} {a : α} {motive : α → Sort u1} (m : motive a) {b : α} (h : Eq a b) : motive b := - Eq.rec (motive := fun α _ => motive α) m h - -@[matchPattern] def rfl {α : Sort u} {a : α} : Eq a a := Eq.refl a - -theorem Eq.subst {α : Sort u} {motive : α → Prop} {a b : α} (h₁ : Eq a b) (h₂ : motive a) : motive b := - Eq.ndrec h₂ h₁ - -theorem Eq.symm {α : Sort u} {a b : α} (h : a = b) : b = a := - h ▸ rfl - -@[macroInline] def cast {α β : Sort u} (h : α = β) (a : α) : β := - Eq.rec (motive := fun α _ => α) a h - -theorem congrArg {α : Sort u} {β : Sort v} {a₁ a₂ : α} (f : α → β) (h : Eq a₁ a₂) : Eq (f a₁) (f a₂) := - h ▸ rfl - -/- -Initialize the Quotient Module, which effectively adds the following definitions: - -constant Quot {α : Sort u} (r : α → α → Prop) : Sort u - -constant Quot.mk {α : Sort u} (r : α → α → Prop) (a : α) : Quot r - -constant Quot.lift {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β) : - (∀ a b : α, r a b → Eq (f a) (f b)) → Quot r → β - -constant Quot.ind {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop} : - (∀ a : α, β (Quot.mk r a)) → ∀ q : Quot r, β q --/ -init_quot - -inductive HEq {α : Sort u} (a : α) : {β : Sort u} → β → Prop - | refl {} : HEq a a - -@[matchPattern] def HEq.rfl {α : Sort u} {a : α} : a ≅ a := - HEq.refl a - -theorem eqOfHEq {α : Sort u} {a a' : α} (h : HEq a a') : Eq a a' := - have (α β : Sort u) → (a : α) → (b : β) → HEq a b → (h : Eq α β) → Eq (cast h a) b from - fun α β a b h₁ => - HEq.rec (motive := fun {β} (b : β) (h : HEq a b) => (h₂ : Eq α β) → Eq (cast h₂ a) b) - (fun (h₂ : Eq α α) => rfl) - h₁ - this α α a a' h rfl - -structure Prod (α : Type u) (β : Type v) := - (fst : α) (snd : β) - -attribute [unbox] Prod - -/-- Similar to `Prod`, but `α` and `β` can be propositions. - We use this Type internally to automatically generate the brecOn recursor. -/ -structure PProd (α : Sort u) (β : Sort v) := - (fst : α) (snd : β) - -/-- Similar to `Prod`, but `α` and `β` are in the same universe. -/ -structure MProd (α β : Type u) := - (fst : α) (snd : β) - -structure And (a b : Prop) : Prop := - intro :: (left : a) (right : b) - -inductive Or (a b : Prop) : Prop - | inl (h : a) : Or a b - | inr (h : b) : Or a b - -inductive Bool : Type - | false : Bool - | true : Bool - -export Bool (false true) - -/- Remark: Subtype must take a Sort instead of Type because of the axiom strongIndefiniteDescription. -/ -structure Subtype {α : Sort u} (p : α → Prop) := - (val : α) (property : p val) - -/-- Gadget for optional parameter support. -/ -@[reducible] def optParam (α : Sort u) (default : α) : Sort u := α - -/-- Gadget for marking output parameters in type classes. -/ -@[reducible] def outParam (α : Sort u) : Sort u := α - -/-- Auxiliary Declaration used to implement the notation (a : α) -/ -@[reducible] def typedExpr (α : Sort u) (a : α) : α := a - -/-- Auxiliary Declaration used to implement the named patterns `x@p` -/ -@[reducible] def namedPattern {α : Sort u} (x a : α) : α := a - -/- Auxiliary axiom used to implement `sorry`. -/ -axiom sorryAx (α : Sort u) (synthetic := true) : α - -theorem eqFalseOfNeTrue : {b : Bool} → Not (Eq b true) → b = false - | true, h => False.elim (h rfl) - | false, h => rfl - -theorem eqTrueOfNeFalse : {b : Bool} → Not (Eq b false) → b = true - | true, h => rfl - | false, h => False.elim (h rfl) - -theorem neFalseOfEqTrue : {b : Bool} → Eq b true → Not (Eq b false) - | true, _ => fun h => Bool.noConfusion h - | false, h => Bool.noConfusion h - -theorem neTrueOfEqFalse : {b : Bool} → Eq b false → Not (Eq b true) - | true, h => Bool.noConfusion h - | false, _ => fun h => Bool.noConfusion h - -class Inhabited (α : Sort u) := - mk {} :: (default : α) - -constant arbitrary (α : Sort u) [s : Inhabited α] : α := - @Inhabited.default α s - -instance (α : Sort u) {β : Sort v} [Inhabited β] : Inhabited (α → β) := { - default := fun _ => arbitrary β -} - -instance (α : Sort u) {β : α → Sort v} [(a : α) → Inhabited (β a)] : Inhabited ((a : α) → β a) := { - default := fun a => arbitrary (β a) -} - -/-- Universe lifting operation from Sort to Type -/ -structure PLift (α : Sort u) : Type u := - up :: (down : α) - -/- Bijection between α and PLift α -/ -theorem PLift.upDown {α : Sort u} : ∀ (b : PLift α), up (down b) = b - | up a => rfl - -theorem PLift.downUp {α : Sort u} (a : α) : down (up a) = a := - rfl - -/- Pointed types -/ -structure PointedType := - (type : Type u) - (val : type) - -instance : Inhabited PointedType.{u} := { - default := { type := PUnit.{u+1}, val := ⟨⟩ } -} - -/-- Universe lifting operation -/ -structure ULift.{r, s} (α : Type s) : Type (max s r) := - up :: (down : α) - -/- Bijection between α and ULift.{v} α -/ -theorem ULift.upDown {α : Type u} : ∀ (b : ULift.{v} α), up (down b) = b - | up a => rfl - -theorem ULift.downUp {α : Type u} (a : α) : down (up.{v} a) = a := - rfl - -class inductive Decidable (p : Prop) - | isFalse (h : Not p) : Decidable p - | isTrue (h : p) : Decidable p - -@[inlineIfReduce, nospecialize] def Decidable.decide (p : Prop) [h : Decidable p] : Bool := - Decidable.casesOn (motive := fun _ => Bool) h (fun _ => false) (fun _ => true) - -export Decidable (isTrue isFalse decide) - -abbrev DecidablePred {α : Sort u} (r : α → Prop) := - (a : α) → Decidable (r a) - -abbrev DecidableRel {α : Sort u} (r : α → α → Prop) := - (a b : α) → Decidable (r a b) - -abbrev DecidableEq (α : Sort u) := - (a b : α) → Decidable (Eq a b) - -def decEq {α : Sort u} [s : DecidableEq α] (a b : α) : Decidable (Eq a b) := - s a b - -theorem decideEqTrue : {p : Prop} → [s : Decidable p] → p → Eq (decide p) true - | _, isTrue _, _ => rfl - | _, isFalse h₁, h₂ => absurd h₂ h₁ - -theorem decideEqFalse : {p : Prop} → [s : Decidable p] → Not p → Eq (decide p) false - | _, isTrue h₁, h₂ => absurd h₁ h₂ - | _, isFalse h, _ => rfl - -theorem ofDecideEqTrue {p : Prop} [s : Decidable p] : Eq (decide p) true → p := fun h => - match s with - | isTrue h₁ => h₁ - | isFalse h₁ => absurd h (neTrueOfEqFalse (decideEqFalse h₁)) - -theorem ofDecideEqFalse {p : Prop} [s : Decidable p] : Eq (decide p) false → Not p := fun h => - match s with - | isTrue h₁ => absurd h (neFalseOfEqTrue (decideEqTrue h₁)) - | isFalse h₁ => h₁ - -@[inline] instance : DecidableEq Bool := - fun a b => match a, b with - | false, false => isTrue rfl - | false, true => isFalse (fun h => Bool.noConfusion h) - | true, false => isFalse (fun h => Bool.noConfusion h) - | true, true => isTrue rfl - -class BEq (α : Type u) := (beq : α → α → Bool) - -open BEq (beq) - -instance {α : Type u} [DecidableEq α] : BEq α := - ⟨fun a b => decide (Eq a b)⟩ - --- We use "dependent" if-then-else to be able to communicate the if-then-else condition --- to the branches -@[macroInline] def dite {α : Sort u} (c : Prop) [h : Decidable c] (t : c → α) (e : Not c → α) : α := - Decidable.casesOn (motive := fun _ => α) h e t - -/- if-then-else -/ - -@[macroInline] def ite {α : Sort u} (c : Prop) [h : Decidable c] (t e : α) : α := - Decidable.casesOn (motive := fun _ => α) h (fun _ => e) (fun _ => t) - -@[macroInline] instance {p q} [Decidable p] [Decidable q] : Decidable (And p q) := - if hp : p then - if hq : q then - isTrue ⟨hp, hq⟩ - else - isFalse (fun h => hq (And.right h)) - else - isFalse (fun h => hp (And.left h)) - -@[macroInline] instance {p q} [Decidable p] [Decidable q] : Decidable (Or p q) := - if hp : p then - isTrue (Or.inl hp) - else if hq : q then - isTrue (Or.inr hq) - else - isFalse fun h => match h with - | Or.inl h => hp h - | Or.inr h => hq h - -instance {p} [Decidable p] : Decidable (Not p) := - if hp : p then isFalse (absurd hp) else isTrue hp - -/- Boolean operators -/ - -@[macroInline] def cond {a : Type u} : Bool → a → a → a - | true, x, y => x - | false, x, y => y - -@[macroInline] def or : Bool → Bool → Bool - | true, _ => true - | false, b => b - -@[macroInline] def and : Bool → Bool → Bool - | false, _ => false - | true, b => b - -@[macroInline] def not : Bool → Bool - | true => false - | false => true - -inductive Nat - | zero : Nat - | succ (n : Nat) : Nat - -/- For numeric literals notation -/ -class OfNat (α : Type u) := - (ofNat : Nat → α) - -export OfNat (ofNat) - -instance : OfNat Nat := ⟨id⟩ - -instance : Inhabited Nat := { - default := 0 -} - -class HasLessEq (α : Type u) := (LessEq : α → α → Prop) -class HasLess (α : Type u) := (Less : α → α → Prop) - -export HasLess (Less) -export HasLessEq (LessEq) - -class Add (α : Type u) := (add : α → α → α) -class Mul (α : Type u) := (mul : α → α → α) -class Neg (α : Type u) := (neg : α → α) -class Sub (α : Type u) := (sub : α → α → α) -class Div (α : Type u) := (div : α → α → α) -class Mod (α : Type u) := (mod : α → α → α) -class ModN (α : Type u) := (modn : α → Nat → α) -class Pow (α : Type u) (β : Type v) := (pow : α → β → α) -class Append (α : Type u) := (append : α → α → α) -class OrElse (α : Type u) := (orElse : α → α → α) -class AndThen (α : Type u) := (andThen : α → α → α) - -open Add (add) -open Mul (mul) -open Pow (pow) -open Append (append) - -@[reducible] def GreaterEq {α : Type u} [HasLessEq α] (a b : α) : Prop := LessEq b a -@[reducible] def Greater {α : Type u} [HasLess α] (a b : α) : Prop := Less b a - -set_option bootstrap.gen_matcher_code false in -@[extern "lean_nat_add"] -protected def Nat.add : (@& Nat) → (@& Nat) → Nat - | a, Nat.zero => a - | a, Nat.succ b => Nat.succ (Nat.add a b) - -instance : Add Nat := { - add := Nat.add -} - -set_option bootstrap.gen_matcher_code false in -@[extern "lean_nat_mul"] -protected def Nat.mul : (@& Nat) → (@& Nat) → Nat - | a, 0 => 0 - | a, Nat.succ b => Nat.add (Nat.mul a b) a - -instance : Mul Nat := { - mul := Nat.mul -} - -set_option bootstrap.gen_matcher_code false in -@[extern "lean_nat_pow"] -protected def Nat.pow (m : @& Nat) : (@& Nat) → Nat - | 0 => 1 - | succ n => Nat.mul (Nat.pow m n) m - -instance : Pow Nat Nat := { - pow := Nat.pow -} - -set_option bootstrap.gen_matcher_code false in -@[extern "lean_nat_dec_eq"] -def Nat.beq : Nat → Nat → Bool - | zero, zero => true - | zero, succ m => false - | succ n, zero => false - | succ n, succ m => beq n m - -theorem Nat.eqOfBeqEqTt : {n m : Nat} → Eq (beq n m) true → Eq n m - | zero, zero, h => rfl - | zero, succ m, h => Bool.noConfusion h - | succ n, zero, h => Bool.noConfusion h - | succ n, succ m, h => - have Eq (beq n m) true from h - have Eq n m from eqOfBeqEqTt this - this ▸ rfl - -theorem Nat.neOfBeqEqFf : {n m : Nat} → Eq (beq n m) false → Not (Eq n m) - | zero, zero, h₁, h₂ => Bool.noConfusion h₁ - | zero, succ m, h₁, h₂ => Nat.noConfusion h₂ - | succ n, zero, h₁, h₂ => Nat.noConfusion h₂ - | succ n, succ m, h₁, h₂ => - have beq n m = false from h₁ - Nat.noConfusion h₂ (fun h₂ => absurd h₂ (neOfBeqEqFf this)) - -@[extern "lean_nat_dec_eq"] -protected def Nat.decEq (n m : @& Nat) : Decidable (n = m) := - if h : beq n m = true then isTrue (eqOfBeqEqTt h) - else isFalse (neOfBeqEqFf (eqFalseOfNeTrue h)) - -@[inline] instance : DecidableEq Nat := Nat.decEq - -set_option bootstrap.gen_matcher_code false in -@[extern "lean_nat_dec_le"] -def Nat.ble : Nat → Nat → Bool - | zero, zero => true - | zero, succ m => true - | succ n, zero => false - | succ n, succ m => ble n m - -protected def Nat.le (n m : Nat) : Prop := - ble n m = true - -instance : HasLessEq Nat := ⟨Nat.le⟩ - -protected def Nat.lt (n m : Nat) : Prop := - Nat.le (succ n) m - -instance : HasLess Nat := ⟨Nat.lt⟩ - -theorem Nat.notSuccLeZero : ∀ (n : Nat), LessEq (succ n) 0 → False - | 0, h => nomatch h - | succ n, h => nomatch h - -theorem Nat.notLtZero (n : Nat) : Not (Less n 0) := - notSuccLeZero n - -@[extern "lean_nat_dec_le"] -instance Nat.decLe (n m : @& Nat) : Decidable (LessEq n m) := - decEq (Nat.ble n m) true - -@[extern "lean_nat_dec_lt"] -instance Nat.decLt (n m : @& Nat) : Decidable (Less n m) := - decLe (succ n) m - -theorem Nat.zeroLe : (n : Nat) → LessEq 0 n - | zero => rfl - | succ n => rfl - -theorem Nat.succLeSucc {n m : Nat} (h : LessEq n m) : LessEq (succ n) (succ m) := - h - -theorem Nat.zeroLtSucc (n : Nat) : Less 0 (succ n) := - succLeSucc (zeroLe n) - -theorem Nat.leStep : {n m : Nat} → LessEq n m → LessEq n (succ m) - | zero, zero, h => rfl - | zero, succ n, h => rfl - | succ n, zero, h => Bool.noConfusion h - | succ n, succ m, h => - have LessEq n m from h - have LessEq n (succ m) from leStep this - succLeSucc this - -protected theorem Nat.leTrans : {n m k : Nat} → LessEq n m → LessEq m k → LessEq n k - | zero, m, k, h₁, h₂ => zeroLe _ - | succ n, zero, k, h₁, h₂ => Bool.noConfusion h₁ - | succ n, succ m, zero, h₁, h₂ => Bool.noConfusion h₂ - | succ n, succ m, succ k, h₁, h₂ => - have h₁' : LessEq n m from h₁ - have h₂' : LessEq m k from h₂ - Nat.leTrans h₁' h₂' - -protected theorem Nat.ltTrans {n m k : Nat} (h₁ : Less n m) : Less m k → Less n k := - Nat.leTrans (leStep h₁) - -theorem Nat.leSucc : (n : Nat) → LessEq n (succ n) - | zero => rfl - | succ n => leSucc n - -theorem Nat.leSuccOfLe {n m : Nat} (h : LessEq n m) : LessEq n (succ m) := - Nat.leTrans h (leSucc m) - -protected theorem Nat.eqOrLtOfLe : {n m: Nat} → LessEq n m → Or (Eq n m) (Less n m) - | zero, zero, h => Or.inl rfl - | zero, succ n, h => Or.inr (zeroLe n) - | succ n, zero, h => Bool.noConfusion h - | succ n, succ m, h => - have LessEq n m from h - match Nat.eqOrLtOfLe this with - | Or.inl h => Or.inl (h ▸ rfl) - | Or.inr h => Or.inr (succLeSucc h) - -protected def Nat.leRefl : (n : Nat) → LessEq n n - | zero => rfl - | succ n => Nat.leRefl n - -protected theorem Nat.ltOrGe (n m : Nat) : Or (Less n m) (GreaterEq n m) := - match m with - | zero => Or.inr (zeroLe n) - | succ m => - match Nat.ltOrGe n m with - | Or.inl h => Or.inl (leSuccOfLe h) - | Or.inr h => - match Nat.eqOrLtOfLe h with - | Or.inl h1 => Or.inl (h1 ▸ Nat.leRefl _) - | Or.inr h1 => Or.inr h1 - -protected theorem Nat.leAntisymm : {n m : Nat} → LessEq n m → LessEq m n → Eq n m - | zero, zero, h₁, h₂ => rfl - | succ n, zero, h₁, h₂ => Bool.noConfusion h₁ - | zero, succ m, h₁, h₂ => Bool.noConfusion h₂ - | succ n, succ m, h₁, h₂ => - have h₁' : LessEq n m from h₁ - have h₂' : LessEq m n from h₂ - (Nat.leAntisymm h₁' h₂') ▸ rfl - -protected theorem Nat.ltOfLeOfNe {n m : Nat} (h₁ : LessEq n m) (h₂ : Not (Eq n m)) : Less n m := - match Nat.ltOrGe n m with - | Or.inl h₃ => h₃ - | Or.inr h₃ => absurd (Nat.leAntisymm h₁ h₃) h₂ - -set_option bootstrap.gen_matcher_code false in -@[extern c inline "lean_nat_sub(#1, lean_box(1))"] -def Nat.pred : Nat → Nat - | 0 => 0 - | succ a => a - -theorem Nat.predLePred : {n m : Nat} → LessEq n m → LessEq (pred n) (pred m) - | zero, zero, h => rfl - | zero, succ n, h => zeroLe n - | succ n, zero, h => Bool.noConfusion h - | succ n, succ m, h => h - -theorem Nat.leOfSuccLeSucc {n m : Nat} : LessEq (succ n) (succ m) → LessEq n m := - predLePred - -theorem Nat.leOfLtSucc {m n : Nat} : Less m (succ n) → LessEq m n := - leOfSuccLeSucc - -@[extern "lean_system_platform_nbits"] constant System.Platform.getNumBits : Unit → { n : Nat // Or (Eq n 32) (Eq n 64) } := - fun _ => ⟨64, Or.inr rfl⟩ -- inhabitant - -def System.Platform.numBits : Nat := - (getNumBits ()).val - -theorem System.Platform.numBitsEq : Or (Eq numBits 32) (Eq numBits 64) := - (getNumBits ()).property - -structure Fin (n : Nat) := - (val : Nat) - (isLt : Less val n) - -theorem Fin.eqOfVeq {n} : ∀ {i j : Fin n}, Eq i.val j.val → Eq i j - | ⟨v, h⟩, ⟨_, _⟩, rfl => rfl - -theorem Fin.veqOfEq {n} {i j : Fin n} (h : Eq i j) : i.val = j.val := - h ▸ rfl - -theorem Fin.neOfVne {n} {i j : Fin n} (h : Not (Eq i.val j.val)) : Not (Eq i j) := - fun h' => absurd (veqOfEq h') h - -instance (n : Nat) : DecidableEq (Fin n) := - fun i j => - match decEq i.val j.val with - | isTrue h => isTrue (Fin.eqOfVeq h) - | isFalse h => isFalse (Fin.neOfVne h) - -def uint8Sz : Nat := 256 -structure UInt8 := - (val : Fin uint8Sz) - -set_option bootstrap.gen_matcher_code false in -@[extern c inline "#1 == #2"] -def UInt8.decEq (a b : UInt8) : Decidable (Eq a b) := - match a, b with - | ⟨n⟩, ⟨m⟩ => if h : Eq n m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt8.noConfusion h' (fun h' => absurd h' h)) - -instance : DecidableEq UInt8 := UInt8.decEq - -instance : Inhabited UInt8 := { - default := { val := { val := 0, isLt := decide! } } -} - -def uint16Sz : Nat := 65536 -structure UInt16 := - (val : Fin uint16Sz) - -set_option bootstrap.gen_matcher_code false in -@[extern c inline "#1 == #2"] -def UInt16.decEq (a b : UInt16) : Decidable (Eq a b) := - match a, b with - | ⟨n⟩, ⟨m⟩ => if h : Eq n m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt16.noConfusion h' (fun h' => absurd h' h)) - -instance : DecidableEq UInt16 := UInt16.decEq - -instance : Inhabited UInt16 := { - default := { val := { val := 0, isLt := decide! } } -} - -def uint32Sz : Nat := 4294967296 -structure UInt32 := - (val : Fin uint32Sz) - -set_option bootstrap.gen_matcher_code false in -@[extern c inline "#1 == #2"] -def UInt32.decEq (a b : UInt32) : Decidable (Eq a b) := - match a, b with - | ⟨n⟩, ⟨m⟩ => if h : Eq n m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt32.noConfusion h' (fun h' => absurd h' h)) - -instance : DecidableEq UInt32 := UInt32.decEq - -instance : Inhabited UInt32 := { - default := { val := { val := 0, isLt := decide! } } -} - -def uint64Sz : Nat := 18446744073709551616 -structure UInt64 := - (val : Fin uint64Sz) - -set_option bootstrap.gen_matcher_code false in -@[extern c inline "#1 == #2"] -def UInt64.decEq (a b : UInt64) : Decidable (Eq a b) := - match a, b with - | ⟨n⟩, ⟨m⟩ => if h : Eq n m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt64.noConfusion h' (fun h' => absurd h' h)) - -instance : DecidableEq UInt64 := UInt64.decEq - -instance : Inhabited UInt64 := { - default := { val := { val := 0, isLt := decide! } } -} - -def usizeSz : Nat := pow 2 System.Platform.numBits - -theorem usizeSzEq : Or (Eq usizeSz 4294967296) (Eq usizeSz 18446744073709551616) := - show Or (Eq (pow 2 System.Platform.numBits) 4294967296) (Eq (pow 2 System.Platform.numBits) 18446744073709551616) from - match System.Platform.numBits, System.Platform.numBitsEq with - | _, Or.inl rfl => Or.inl (decide! : (Eq (pow 2 32) (4294967296:Nat))) - | _, Or.inr rfl => Or.inr (decide! : (Eq (pow 2 64) (18446744073709551616:Nat))) - -structure USize := - (val : Fin usizeSz) - -set_option bootstrap.gen_matcher_code false in -@[extern c inline "#1 == #2"] -def USize.decEq (a b : USize) : Decidable (Eq a b) := - match a, b with - | ⟨n⟩, ⟨m⟩ => if h : Eq n m then isTrue (h ▸ rfl) else isFalse (fun h' => USize.noConfusion h' (fun h' => absurd h' h)) - -instance : DecidableEq USize := USize.decEq - -instance : Inhabited USize := { - default := { val := { val := 0, isLt := match usizeSz, usizeSzEq with | _, Or.inl rfl => decide! | _, Or.inr rfl => decide! } } -} - -@[extern "lean_usize_of_nat"] -def USize.ofNat32 (n : @& Nat) (h : Less n 4294967296) : USize := { - val := { - val := n, - isLt := match usizeSz, usizeSzEq with - | _, Or.inl rfl => h - | _, Or.inr rfl => Nat.ltTrans h (decide! : Less 4294967296 18446744073709551616) - } -} - -@[extern "lean_usize_of_nat"] -def USize.ofNatCore (n : @& Nat) (h : Less n usizeSz) : USize := { - val := { val := n, isLt := h } -} - -abbrev Nat.isValidChar (n : Nat) : Prop := - Or (Less n 0xd800) (And (Less 0xdfff n) (Less n 0x110000)) - -abbrev UInt32.isValidChar (n : UInt32) : Prop := - n.val.val.isValidChar - -/-- The `Char` Type represents an unicode scalar value. - See http://www.unicode.org/glossary/#unicode_scalar_value). -/ -structure Char := - (val : UInt32) - (valid : val.isValidChar) - -private theorem validCharIsUInt32 {n : Nat} (h : n.isValidChar) : Less n uint32Sz := - match h with - | Or.inl h => Nat.ltTrans h (decide! : Less 55296 uint32Sz) - | Or.inr ⟨_, h⟩ => Nat.ltTrans h (decide! : Less 1114112 uint32Sz) - -abbrev Char.ofNat (n : Nat) : Char := - if h : n.isValidChar then - { val := ⟨{ val := n, isLt := validCharIsUInt32 h }⟩, valid := h } - else - { val := ⟨{ val := 0, isLt := decide! }⟩, valid := Or.inl decide! } - -theorem Char.eqOfVeq : ∀ {c d : Char}, Eq c.val d.val → Eq c d - | ⟨v, h⟩, ⟨_, _⟩, rfl => rfl - -theorem Char.veqOfEq : ∀ {c d : Char}, Eq c d → Eq c.val d.val - | _, _, rfl => rfl - -theorem Char.neOfVne {c d : Char} (h : Not (Eq c.val d.val)) : Not (Eq c d) := - fun h' => absurd (veqOfEq h') h - -theorem Char.vneOfNe {c d : Char} (h : Not (Eq c d)) : Not (Eq c.val d.val) := - fun h' => absurd (eqOfVeq h') h - -instance : DecidableEq Char := - fun c d => - match decEq c.val d.val with - | isTrue h => isTrue (Char.eqOfVeq h) - | isFalse h => isFalse (Char.neOfVne h) - -inductive Option (α : Type u) - | none : Option α - | some (val : α) : Option α - -attribute [unbox] Option - -export Option (none some) - -instance {α} : Inhabited (Option α) := { - default := none -} - -inductive List (α : Type u) - | nil : List α - | cons (head : α) (tail : List α) : List α - -instance {α} : Inhabited (List α) := { - default := List.nil -} - -protected def List.hasDecEq {α: Type u} [DecidableEq α] : (a b : List α) → Decidable (Eq a b) - | nil, nil => isTrue rfl - | cons a as, nil => isFalse (fun h => List.noConfusion h) - | nil, cons b bs => isFalse (fun h => List.noConfusion h) - | cons a as, cons b bs => - match decEq a b with - | isTrue hab => - match List.hasDecEq as bs with - | isTrue habs => isTrue (hab ▸ habs ▸ rfl) - | isFalse nabs => isFalse (fun h => List.noConfusion h (fun _ habs => absurd habs nabs)) - | isFalse nab => isFalse (fun h => List.noConfusion h (fun hab _ => absurd hab nab)) - -instance {α : Type u} [DecidableEq α] : DecidableEq (List α) := List.hasDecEq - -@[specialize] -def List.foldl {α β} (f : α → β → α) : (init : α) → List β → α - | a, nil => a - | a, cons b l => foldl f (f a b) l - -structure String := - (data : List Char) - -attribute [extern "lean_string_mk"] String.mk -attribute [extern "lean_string_data"] String.data - -@[extern "lean_string_dec_eq"] -def String.decEq (s₁ s₂ : @& String) : Decidable (s₁ = s₂) := - match s₁, s₂ with - | ⟨s₁⟩, ⟨s₂⟩ => - if h : s₁ = s₂ then isTrue (congrArg _ h) - else isFalse (fun h' => String.noConfusion h' (fun h' => absurd h' h)) - -instance : DecidableEq String := String.decEq - -/-- A byte position in a `String`. Internally, `String`s are UTF-8 encoded. -Codepoint positions (counting the Unicode codepoints rather than bytes) -are represented by plain `Nat`s instead. -Indexing a `String` by a byte position is constant-time, while codepoint -positions need to be translated internally to byte positions in linear-time. -/ -abbrev String.Pos := Nat - -structure Substring := - (str : String) - (startPos : String.Pos) - (stopPos : String.Pos) - -@[extern c inline "#3"] -unsafe def unsafeCast {α : Type u} {β : Type v} (a : α) : β := - cast lcProof (PUnit.{v}) - -@[neverExtract, extern "lean_panic_fn"] -constant panic {α : Type u} [Inhabited α] (msg : String) : α - -/- -The Compiler has special support for arrays. -They are implemented using dynamic arrays: https://en.wikipedia.org/wiki/Dynamic_array --/ -structure Array (α : Type u) := - (sz : Nat) - (data : Fin sz → α) - -attribute [extern "lean_array_mk"] Array.mk -attribute [extern "lean_array_data"] Array.data -attribute [extern "lean_array_sz"] Array.sz - -/- The parameter `c` is the initial capacity -/ -@[extern "lean_mk_empty_array_with_capacity"] -def Array.mkEmpty {α : Type u} (c : @& Nat) : Array α := { - sz := 0, - data := fun ⟨x, h⟩ => absurd h (Nat.notLtZero x) -} - -def Array.empty {α : Type u} : Array α := - mkEmpty 0 - -@[reducible, extern "lean_array_get_size"] -def Array.size {α : Type u} (a : @& Array α) : Nat := - a.sz - -@[extern "lean_array_fget"] -def Array.get {α : Type u} (a : @& Array α) (i : @& Fin a.size) : α := - a.data i - -/- "Comfortable" version of `fget`. It performs a bound check at runtime. -/ -@[extern "lean_array_get"] -def Array.get! {α : Type u} [Inhabited α] (a : @& Array α) (i : @& Nat) : α := - if h : Less i a.size then a.get ⟨i, h⟩ else arbitrary α - -@[extern "lean_array_push"] -def push {α : Type u} (a : Array α) (v : α) : Array α := { - sz := Nat.succ a.sz, - data := fun ⟨j, h₁⟩ => - if h₂ : j = a.sz then - v - else - a.data ⟨j, Nat.ltOfLeOfNe (Nat.leOfLtSucc h₁) h₂⟩ -} - -class Bind (m : Type u → Type v) := - (bind : {α β : Type u} → m α → (α → m β) → m β) - -export Bind (bind) - -class Pure (f : Type u → Type v) := - (pure {α : Type u} : α → f α) - -export Pure (pure) - -class Functor (f : Type u → Type v) : Type (max (u+1) v) := - (map : {α β : Type u} → (α → β) → f α → f β) - (mapConst : {α β : Type u} → α → f β → f α := Function.comp map (Function.const _)) - -class Seq (f : Type u → Type v) : Type (max (u+1) v) := - (seq : {α β : Type u} → f (α → β) → f α → f β) - -class SeqLeft (f : Type u → Type v) : Type (max (u+1) v) := - (seqLeft : {α : Type u} → f α → f PUnit → f α) - -class SeqRight (f : Type u → Type v) : Type (max (u+1) v) := - (seqRight : {β : Type u} → f PUnit → f β → f β) - -class Applicative (f : Type u → Type v) extends Functor f, Pure f, Seq f, SeqLeft f, SeqRight f := - (map := fun x y => Seq.seq (pure x) y) - (seqLeft := fun a b => Seq.seq (Functor.map (Function.const _) a) b) - (seqRight := fun a b => Seq.seq (Functor.map (Function.const _ id) a) b) - -class Monad (m : Type u → Type v) extends Applicative m, Bind m : Type (max (u+1) v) := - (map := fun f x => bind x (Function.comp pure f)) - (seq := fun f x => bind f (fun y => Functor.map y x)) - (seqLeft := fun x y => bind x (fun a => bind y (fun _ => pure a))) - (seqRight := fun x y => bind x (fun _ => y)) - -instance {α : Type u} {m : Type u → Type v} [Monad m] : Inhabited (α → m α) := ⟨pure⟩ - -instance {α : Type u} {m : Type u → Type v} [Monad m] [Inhabited α] : Inhabited (m α) := ⟨pure $ arbitrary _⟩ - -/-- A Function for lifting a computation from an inner Monad to an outer Monad. - Like [MonadTrans](https://hackage.haskell.org/package/transformers-0.5.5.0/docs/Control-Monad-Trans-Class.html), - but `n` does not have to be a monad transformer. - Alternatively, an implementation of [MonadLayer](https://hackage.haskell.org/package/layers-0.1/docs/Control-Monad-Layer.html#t:MonadLayer) without `layerInvmap` (so far). -/ -class MonadLift (m : Type u → Type v) (n : Type u → Type w) := - (monadLift : {α : Type u} → m α → n α) - -/-- The reflexive-transitive closure of `MonadLift`. - `monadLift` is used to transitively lift monadic computations such as `StateT.get` or `StateT.put s`. - Corresponds to [MonadLift](https://hackage.haskell.org/package/layers-0.1/docs/Control-Monad-Layer.html#t:MonadLift). -/ -class MonadLiftT (m : Type u → Type v) (n : Type u → Type w) := - (monadLift : {α : Type u} → m α → n α) - -export MonadLiftT (monadLift) - -abbrev liftM := @monadLift - -instance (m n o) [MonadLiftT m n] [MonadLift n o] : MonadLiftT m o := { - monadLift := fun x => MonadLift.monadLift (m := n) (monadLift x) -} - -instance (m) : MonadLiftT m m := { - monadLift := fun x => x -} - -/-- A functor in the category of monads. Can be used to lift monad-transforming functions. - Based on pipes' [MFunctor](https://hackage.haskell.org/package/pipes-2.4.0/docs/Control-MFunctor.html), - but not restricted to monad transformers. - Alternatively, an implementation of [MonadTransFunctor](http://duairc.netsoc.ie/layers-docs/Control-Monad-Layer.html#t:MonadTransFunctor). -/ -class MonadFunctor (m : Type u → Type v) (n : Type u → Type w) := - (monadMap {α : Type u} : (∀ {β}, m β → m β) → n α → n α) - -/-- The reflexive-transitive closure of `MonadFunctor`. - `monadMap` is used to transitively lift Monad morphisms -/ -class MonadFunctorT (m : Type u → Type v) (n : Type u → Type w) := - (monadMap {α : Type u} : (∀ {β}, m β → m β) → n α → n α) - -export MonadFunctorT (monadMap) - -instance (m n o) [MonadFunctorT m n] [MonadFunctor n o] : MonadFunctorT m o := { - monadMap := fun f => MonadFunctor.monadMap (m := n) (monadMap (m := m) f) -} - -instance monadFunctorRefl (m) : MonadFunctorT m m := { - monadMap := fun f => f -} - -inductive Except (ε : Type u) (α : Type v) - | error : ε → Except ε α - | ok : α → Except ε α - -attribute [unbox] Except - -instance {ε : Type u} {α : Type v} [Inhabited ε] : Inhabited (Except ε α) := - ⟨Except.error (arbitrary ε)⟩ - -/-- An implementation of [MonadError](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Except.html#t:MonadError) -/ -class MonadExceptOf (ε : Type u) (m : Type v → Type w) := - (throw {α : Type v} : ε → m α) - (tryCatch {α : Type v} : m α → (ε → m α) → m α) - -abbrev throwThe (ε : Type u) {m : Type v → Type w} [MonadExceptOf ε m] {α : Type v} (e : ε) : m α := - MonadExceptOf.throw e - -abbrev tryCatchThe (ε : Type u) {m : Type v → Type w} [MonadExceptOf ε m] {α : Type v} (x : m α) (handle : ε → m α) : m α := - MonadExceptOf.tryCatch x handle - -/-- Similar to `MonadExceptOf`, but `ε` is an outParam for convenience -/ -class MonadExcept (ε : outParam (Type u)) (m : Type v → Type w) := - (throw {α : Type v} : ε → m α) - (tryCatch {α : Type v} : m α → (ε → m α) → m α) - -export MonadExcept (throw tryCatch) - -instance (ε : outParam (Type u)) (m : Type v → Type w) [MonadExceptOf ε m] : MonadExcept ε m := { - throw := throwThe ε, - tryCatch := tryCatchThe ε -} - -namespace MonadExcept -variables {ε : Type u} {m : Type v → Type w} - -@[inline] protected def orelse [MonadExcept ε m] {α : Type v} (t₁ t₂ : m α) : m α := - tryCatch t₁ fun _ => t₂ - -instance [MonadExcept ε m] {α : Type v} : OrElse (m α) := ⟨MonadExcept.orelse⟩ - -end MonadExcept - -/-- An implementation of [ReaderT](https://hackage.haskell.org/package/transformers-0.5.5.0/docs/Control-Monad-Trans-Reader.html#t:ReaderT) -/ -def ReaderT (ρ : Type u) (m : Type u → Type v) (α : Type u) : Type (max u v) := - ρ → m α - -instance (ρ : Type u) (m : Type u → Type v) (α : Type u) [Inhabited (m α)] : Inhabited (ReaderT ρ m α) := - ⟨fun _ => arbitrary _⟩ - -@[inline] def ReaderT.run {ρ : Type u} {m : Type u → Type v} {α : Type u} (x : ReaderT ρ m α) (r : ρ) : m α := - x r - -@[reducible] def Reader (ρ : Type u) := ReaderT ρ id - -namespace ReaderT - -section -variables {ρ : Type u} {m : Type u → Type v} {α : Type u} - -@[inline] protected def lift (a : m α) : ReaderT ρ m α := - fun r => a - -instance : MonadLift m (ReaderT ρ m) := ⟨ReaderT.lift⟩ - -instance (ε) [MonadExceptOf ε m] : MonadExceptOf ε (ReaderT ρ m) := { - throw := Function.comp ReaderT.lift (throwThe ε), - tryCatch := fun x c r => tryCatchThe ε (x r) (fun e => (c e) r) -} - -end - -section -variables {ρ : Type u} {m : Type u → Type v} [Monad m] {α β : Type u} - -@[inline] protected def read : ReaderT ρ m ρ := - pure - -@[inline] protected def pure (a : α) : ReaderT ρ m α := - fun r => pure a - -@[inline] protected def bind (x : ReaderT ρ m α) (f : α → ReaderT ρ m β) : ReaderT ρ m β := - fun r => bind (x r) fun a => f a r - -@[inline] protected def map (f : α → β) (x : ReaderT ρ m α) : ReaderT ρ m β := - fun r => Functor.map f (x r) - -instance : Monad (ReaderT ρ m) := { - pure := ReaderT.pure, - bind := ReaderT.bind, - map := ReaderT.map -} - -instance (ρ m) [Monad m] : MonadFunctor m (ReaderT ρ m) := ⟨fun f x r => f (x r)⟩ - -@[inline] protected def adapt {ρ' : Type u} [Monad m] {α : Type u} (f : ρ' → ρ) : ReaderT ρ m α → ReaderT ρ' m α := - fun x r => x (f r) - -end -end ReaderT - -/-- An implementation of [MonadReader](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader-Class.html#t:MonadReader). - It does not contain `local` because this Function cannot be lifted using `monadLift`. - Instead, the `MonadReaderAdapter` class provides the more general `adaptReader` Function. - - Note: This class can be seen as a simplification of the more "principled" definition - ``` - class MonadReader (ρ : outParam (Type u)) (n : Type u → Type u) := - (lift {α : Type u} : (∀ {m : Type u → Type u} [Monad m], ReaderT ρ m α) → n α) - ``` - -/ -class MonadReaderOf (ρ : Type u) (m : Type u → Type v) := - (read : m ρ) - -@[inline] def readThe (ρ : Type u) {m : Type u → Type v} [MonadReaderOf ρ m] : m ρ := - MonadReaderOf.read - -/-- Similar to `MonadReaderOf`, but `ρ` is an outParam for convenience -/ -class MonadReader (ρ : outParam (Type u)) (m : Type u → Type v) := - (read : m ρ) - -export MonadReader (read) - -instance (ρ : Type u) (m : Type u → Type v) [MonadReaderOf ρ m] : MonadReader ρ m := - ⟨readThe ρ⟩ - -instance {ρ : Type u} {m : Type u → Type v} {n : Type u → Type w} [MonadReaderOf ρ m] [MonadLift m n] : MonadReaderOf ρ n := - ⟨monadLift (MonadReader.read : m ρ)⟩ - -instance {ρ : Type u} {m : Type u → Type v} [Monad m] : MonadReaderOf ρ (ReaderT ρ m) := - ⟨ReaderT.read⟩ - -class MonadWithReaderOf (ρ : Type u) (m : Type u → Type v) := - (withReader {α : Type u} : (ρ → ρ) → m α → m α) - -@[inline] def withTheReader (ρ : Type u) {m : Type u → Type v} [MonadWithReaderOf ρ m] {α : Type u} (f : ρ → ρ) (x : m α) : m α := - MonadWithReaderOf.withReader f x - -class MonadWithReader (ρ : outParam (Type u)) (m : Type u → Type v) := - (withReader {α : Type u} : (ρ → ρ) → m α → m α) - -export MonadWithReader (withReader) - -instance (ρ : Type u) (m : Type u → Type v) [MonadWithReaderOf ρ m] : MonadWithReader ρ m := ⟨withTheReader ρ⟩ - -instance {ρ : Type u} {m : Type u → Type v} {n : Type u → Type v} [MonadWithReaderOf ρ m] [MonadFunctor m n] : MonadWithReaderOf ρ n := - ⟨fun f => monadMap (m := m) (withTheReader ρ f)⟩ - -instance {ρ : Type u} {m : Type u → Type v} [Monad m] : MonadWithReaderOf ρ (ReaderT ρ m) := - ⟨fun f x ctx => x (f ctx)⟩ - -/-- An implementation of [MonadState](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-State-Class.html). - In contrast to the Haskell implementation, we use overlapping instances to derive instances - automatically from `monadLift`. -/ -class MonadStateOf (σ : Type u) (m : Type u → Type v) := - /- Obtain the top-most State of a Monad stack. -/ - (get : m σ) - /- Set the top-most State of a Monad stack. -/ - (set : σ → m PUnit) - /- Map the top-most State of a Monad stack. - - Note: `modifyGet f` may be preferable to `do s <- get; let (a, s) := f s; put s; pure a` - because the latter does not use the State linearly (without sufficient inlining). -/ - (modifyGet {α : Type u} : (σ → α × σ) → m α) - -export MonadStateOf (set) - -abbrev getThe (σ : Type u) {m : Type u → Type v} [MonadStateOf σ m] : m σ := - MonadStateOf.get - -@[inline] abbrev modifyThe (σ : Type u) {m : Type u → Type v} [MonadStateOf σ m] (f : σ → σ) : m PUnit := - MonadStateOf.modifyGet fun s => (PUnit.unit, f s) - -@[inline] abbrev modifyGetThe {α : Type u} (σ : Type u) {m : Type u → Type v} [MonadStateOf σ m] (f : σ → α × σ) : m α := - MonadStateOf.modifyGet f - -/-- Similar to `MonadStateOf`, but `σ` is an outParam for convenience -/ -class MonadState (σ : outParam (Type u)) (m : Type u → Type v) := - (get : m σ) - (set : σ → m PUnit) - (modifyGet {α : Type u} : (σ → α × σ) → m α) - -export MonadState (get modifyGet) - -instance (σ : Type u) (m : Type u → Type v) [MonadStateOf σ m] : MonadState σ m := { - set := MonadStateOf.set, - get := getThe σ, - modifyGet := fun f => MonadStateOf.modifyGet f -} - -@[inline] def modify {σ : Type u} {m : Type u → Type v} [MonadState σ m] (f : σ → σ) : m PUnit := - modifyGet fun s => (PUnit.unit, f s) - -@[inline] def getModify {σ : Type u} {m : Type u → Type v} [MonadState σ m] [Monad m] (f : σ → σ) : m σ := - modifyGet fun s => (s, f s) - --- NOTE: The Ordering of the following two instances determines that the top-most `StateT` Monad layer --- will be picked first -instance {σ : Type u} {m : Type u → Type v} {n : Type u → Type w} [MonadStateOf σ m] [MonadLift m n] : MonadStateOf σ n := { - get := liftM (m := m) MonadStateOf.get, - set := fun s => liftM (m := m) (MonadStateOf.set s), - modifyGet := fun f => monadLift (m := m) (MonadState.modifyGet f) -} - -namespace EStateM - -inductive Result (ε σ α : Type u) - | ok : α → σ → Result ε σ α - | error : ε → σ → Result ε σ α - -variables {ε σ α : Type u} - -instance [Inhabited ε] [Inhabited σ] : Inhabited (Result ε σ α) := ⟨Result.error (arbitrary _) (arbitrary _)⟩ - -end EStateM - -open EStateM (Result) in -def EStateM (ε σ α : Type u) := σ → Result ε σ α - -namespace EStateM - -variables {ε σ α β : Type u} - -instance [Inhabited ε] : Inhabited (EStateM ε σ α) := ⟨fun s => - Result.error (arbitrary ε) s⟩ - -@[inline] protected def pure (a : α) : EStateM ε σ α := fun s => - Result.ok a s - -@[inline] protected def set (s : σ) : EStateM ε σ PUnit := fun _ => - Result.ok ⟨⟩ s - -@[inline] protected def get : EStateM ε σ σ := fun s => - Result.ok s s - -@[inline] protected def modifyGet (f : σ → α × σ) : EStateM ε σ α := fun s => - match f s with - | (a, s) => Result.ok a s - -@[inline] protected def throw (e : ε) : EStateM ε σ α := fun s => - Result.error e s - -/-- Auxiliary instance for saving/restoring the "backtrackable" part of the state. -/ -class Backtrackable (δ : outParam (Type u)) (σ : Type u) := - (save : σ → δ) - (restore : σ → δ → σ) - -@[inline] protected def tryCatch {δ} [Backtrackable δ σ] {α} (x : EStateM ε σ α) (handle : ε → EStateM ε σ α) : EStateM ε σ α := fun s => - let d := Backtrackable.save s - match x s with - | Result.error e s => handle e (Backtrackable.restore s d) - | ok => ok - -@[inline] protected def orElse {δ} [Backtrackable δ σ] (x₁ x₂ : EStateM ε σ α) : EStateM ε σ α := fun s => - let d := Backtrackable.save s; - match x₁ s with - | Result.error _ s => x₂ (Backtrackable.restore s d) - | ok => ok - -@[inline] def adaptExcept {ε' : Type u} (f : ε → ε') (x : EStateM ε σ α) : EStateM ε' σ α := fun s => - match x s with - | Result.error e s => Result.error (f e) s - | Result.ok a s => Result.ok a s - -@[inline] protected def bind (x : EStateM ε σ α) (f : α → EStateM ε σ β) : EStateM ε σ β := fun s => - match x s with - | Result.ok a s => f a s - | Result.error e s => Result.error e s - -@[inline] protected def map (f : α → β) (x : EStateM ε σ α) : EStateM ε σ β := fun s => - match x s with - | Result.ok a s => Result.ok (f a) s - | Result.error e s => Result.error e s - -@[inline] protected def seqRight (x : EStateM ε σ PUnit) (y : EStateM ε σ β) : EStateM ε σ β := fun s => - match x s with - | Result.ok _ s => y s - | Result.error e s => Result.error e s - -instance : Monad (EStateM ε σ) := { - bind := EStateM.bind, - pure := EStateM.pure, - map := EStateM.map, - seqRight := EStateM.seqRight -} - -instance {δ} [Backtrackable δ σ] : OrElse (EStateM ε σ α) := { - orElse := EStateM.orElse -} - -instance : MonadStateOf σ (EStateM ε σ) := { - set := EStateM.set, - get := EStateM.get, - modifyGet := EStateM.modifyGet -} - -instance {δ} [Backtrackable δ σ] : MonadExceptOf ε (EStateM ε σ) := { - throw := EStateM.throw, - tryCatch := EStateM.tryCatch -} - -@[inline] def run (x : EStateM ε σ α) (s : σ) : Result ε σ α := - x s - -@[inline] def run' (x : EStateM ε σ α) (s : σ) : Option α := - match run x s with - | Result.ok v _ => some v - | Result.error _ _ => none - -@[inline] def dummySave : σ → PUnit := fun _ => ⟨⟩ - -@[inline] def dummyRestore : σ → PUnit → σ := fun s _ => s - -/- Dummy default instance -/ -instance nonBacktrackable : Backtrackable PUnit σ := { - save := dummySave, - restore := dummyRestore -} - -end EStateM - -class Hashable (α : Type u) := - (hash : α → USize) - -export Hashable (hash) - -@[extern "lean_usize_mix_hash"] -constant mixHash (u₁ u₂ : USize) : USize - -@[extern "lean_string_hash"] -protected constant String.hash (s : @& String) : USize - -instance : Hashable String := ⟨String.hash⟩ - -namespace Lean - -/- 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 => USize.ofNat32 1723 decide! - | 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) (if h : Less v usizeSz then USize.ofNatCore v h else USize.ofNat32 17 decide!)) - -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₂ _ => BEq.beq s₁ s₂ && Name.beq p₁ p₂ - | num p₁ n₁ _, num p₂ n₂ _ => BEq.beq n₁ n₂ && Name.beq p₁ p₂ - | _, _ => false - -instance : BEq Name := ⟨Name.beq⟩ - -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 : Append Name := ⟨Name.append⟩ - -end Name - -/- 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 (Prod 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 := - beq 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 - | _ => Array.empty - -end Syntax - -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 → Bool → ParserDescr - | sepBy1 : ParserDescr → ParserDescr → Bool → 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 - | withPosition : ParserDescr → ParserDescr - | checkCol : Bool → ParserDescr - -instance : Inhabited ParserDescr := ⟨ParserDescr.symbol ""⟩ -abbrev TrailingParserDescr := ParserDescr - -/- -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 := add 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) - -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 -} - -/- -We represent a name with macro scopes as -``` -._@.(.)*.._hyg. -``` -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 _ => beq 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 => Name.anonymous - -@[export lean_erase_macro_scopes] -def Name.eraseMacroScopes (n : Name) : Name := - match n.hasMacroScopes with - | true => eraseMacroScopesAux n - | false => 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 := - match n.hasMacroScopes with - | true => simpMacroScopesAux n - | false => 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 := - match view.scopes with - | List.nil => view.name - | List.cons _ _ => - let base := (mkNameStr (append (append (mkNameStr view.name "_@") view.imported) view.mainModule) "_hyg") - view.scopes.foldl mkNameNum base - -private def assembleParts : List Name → Name → Name - | List.nil, acc => acc - | List.cons (Name.str _ s _) ps, acc => assembleParts ps (mkNameStr acc s) - | List.cons (Name.num _ n _) ps, acc => assembleParts ps (mkNameNum acc n) - | _, acc => panic "unreachable @ assembleParts" - -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 (List.cons n parts) - | n@(Name.num p str _), parts => extractImported scps mainModule p (List.cons n parts) - | _, _ => panic "unreachable @ extractImported" - -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 (List.cons n parts) - | n@(Name.num p num _), acc => extractImported scps (assembleParts acc Name.anonymous) n List.nil - | _, _ => panic "unreachable @ extractMainModule" - -private def extractMacroScopesAux : Name → List MacroScope → MacroScopesView - | Name.num p scp _, acc => extractMacroScopesAux p (List.cons scp acc) - | Name.str p str _, acc => extractMainModule acc p List.nil -- str must be "_hyg" - | _, _ => panic "unreachable @ extractMacroScopesAux" - -/-- - 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 := - match n.hasMacroScopes with - | true => extractMacroScopesAux n List.nil - | false => { name := n, scopes := List.nil, imported := Name.anonymous, mainModule := Name.anonymous } - -def addMacroScope (mainModule : Name) (n : Name) (scp : MacroScope) : Name := - match n.hasMacroScopes with - | true => - let view := extractMacroScopes n - match beq view.mainModule mainModule with - | true => mkNameNum n scp - | false => - { view with - imported := view.scopes.foldl mkNameNum (append view.imported view.mainModule), - mainModule := mainModule, - scopes := List.cons scp List.nil - }.review - | false => - mkNameNum (mkNameStr (append (mkNameStr n "_@") mainModule) "_hyg") scp - -@[inline] def MonadQuotation.addMacroScope {m : Type → Type} [MonadQuotation m] [Monad m] (n : Name) : m Name := - bind getMainModule fun mainModule => - bind getCurrMacroScope fun scp => - pure (Lean.addMacroScope mainModule n scp) - -def defaultMaxRecDepth := 512 - -def maxRecDepthErrorMessage : String := - "maximum recursion depth has been reached (use `set_option maxRecDepth ` 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 := - bind read fun ctx => - 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 α := - bind (modifyGet (fun s => (s, add s 1))) fun fresh => - withReader (fun ctx => { ctx with currMacroScope := fresh }) x - -@[inline] def withIncRecDepth {α} (ref : Syntax) (x : MacroM α) : MacroM α := - bind read fun ctx => - if ctx.currRecDepth = ctx.maxRecDepth then - throw (Exception.error ref maxRecDepthErrorMessage) - else - withReader (fun ctx => { ctx with currRecDepth := add ctx.currRecDepth 1 }) x - -instance : MonadQuotation MacroM := { - getCurrMacroScope := fun ctx => pure ctx.currMacroScope, - getMainModule := fun ctx => pure ctx.mainModule, - withFreshMacroScope := Macro.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) := - bind read fun ctx => - 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?) - -end Lean - -syntax "foo" term : term - -macro_rules - | `(foo $x) => x - -#check foo 10 diff --git a/tmp/eqns/depelim.lean b/tmp/eqns/depelim.lean deleted file mode 100644 index 518aed35bf..0000000000 --- a/tmp/eqns/depelim.lean +++ /dev/null @@ -1,81 +0,0 @@ -import Init.Lean - -open Lean - -inductive Pattern -| Inaccessible (e : Expr) -| Var (fvarId : FVarId) -| Ctor (fields : List Pattern) -| Val (e : Expr) -| ArrayLit (xs : List Pattern) - -structure AltLHS := -(fvarIds : List FVarId) -- free variables used in the patterns -(patterns : List Pattern) -- We use `List Pattern` since we have nary match-expressions. - -abbrev AltToMinorsMap := PersistentHashMap Nat (List Nat) - -structure ElimResult := -(numMinors : Nat) -- It is the number of alternatives (Reason: support for overlapping equations) -(numEqs : Nat) -- It is the number of minors (Reason: users may want equations that hold definitionally) -(elim : Expr) -- The eliminator. It is not just `Expr.const elimName` because the type of the major premises may contain free variables. -(altMap : AltToMinorsMap) -- each alternative may be "expanded" into multiple minor premise - - -/- -Given a list of major premises `xs` and alternative left-hand-sides, generate an elimination -principle with name `elimName` and equation lemmas for it. --/ --- def mkElim (elimName : Name) (xs : List FVarId) (lhss : List AltLHS) : MetaM ElimResult := --- sorry - -universes u v - -inductive Vec (α : Type u) : Nat → Type u -| nil {} : Vec 0 -| cons : α → forall {n : Nat}, Vec n → Vec (n+1) - -def Vec.elim {α : Type u} (C : forall (n : Nat), Vec α n → Vec α n → Sort v) {n : Nat} (v w : Vec α n) - (h₁ : Unit → C 0 Vec.nil Vec.nil) - (h₂ : forall (hdv : α) (n : Nat) (tlv : Vec α n) (hdw : α) (tlw : Vec α n), C (n+1) (Vec.cons hdv tlv) (Vec.cons hdw tlw)) - : C n v w := -match n, v, w with -| .(0), Vec.nil, Vec.nil => h₁ () -| .(n+1), @Vec.cons .(α) hdv n tlv, @Vec.cons .(α) hdw .(n) tlw => h₂ hdv n tlv hdw tlw - -def Vec.elimHEq {α : Type u} (C : forall (n : Nat) (v w : Vec α n), Sort v) {n : Nat} (v w : Vec α n) - (h₁ : v ≅ @Vec.nil α → w ≅ @Vec.nil α → C 0 Vec.nil Vec.nil) - (h₂ : forall (hdv : α) (n : Nat) (tlv : Vec α n) (hdw : α) (tlw : Vec α n), v ≅ Vec.cons hdv tlv → w ≅ Vec.cons hdw tlw → C (n+1) (Vec.cons hdv tlv) (Vec.cons hdw tlw)) - : C n v w := -Vec.elim (fun n' v' w' => v ≅ v' → w ≅ w' → C n' v' w') v w - (fun _ => h₁) - h₂ - (HEq.refl _) - (HEq.refl _) - -def Vec.elimEq {α : Type u} (C : forall (n : Nat) (v w : Vec α n), Sort v) {n : Nat} (v w : Vec α n) - (h₁ : forall (h : n = 0), (Eq.rec v h : Vec α 0) = Vec.nil → (Eq.rec w h : Vec α 0) = Vec.nil → C 0 Vec.nil Vec.nil) - (h₂ : forall (hdv : α) (n' : Nat) (tlv : Vec α n') - (hdw : α) (tlw : Vec α n') - (h : n = n' + 1), - (Eq.rec v h : Vec α (n'+1)) = Vec.cons hdv tlv → - (Eq.rec w h : Vec α (n'+1)) = Vec.cons hdw tlw → - C (n'+1) (Vec.cons hdv tlv) (Vec.cons hdw tlw)) - : C n v w := -Vec.elim (fun n' v' w' => forall (h : n = n'), (Eq.rec v h : Vec α n') = v' → (Eq.rec w h : Vec α n') = w' → C n' v' w') v w - (fun _ => h₁) - h₂ - rfl - rfl - rfl - -def List.elim {α : Type u} (C : List α → Sort v) (as : List α) - (h₁ : Unit → C []) - (h₂ : forall a, C [a]) - (h₃ : forall (a₁ : α) (as₁ : List α) (a₂ : α) (as₂ : List α), as₁ = a₂ :: as₂ → C (a₁::a₂::as₂)) - : C as := -List.casesOn as - (h₁ ()) - (fun a r => @List.casesOn _ (fun as => r = as → C (a::as)) r - (fun _ => h₂ a) - (fun b bs h => h₃ a r b bs h) rfl) diff --git a/tmp/eqns/elim1.lean b/tmp/eqns/elim1.lean deleted file mode 100644 index 996c23f5de..0000000000 --- a/tmp/eqns/elim1.lean +++ /dev/null @@ -1,140 +0,0 @@ -universes u v - -inductive Foo (α : Type u) -| leaf (a : α) : Foo -| node (left : Foo) (right : Foo) : Foo -| cons (head : α) (tail : Foo) : Foo - -def Foo.elim {α : Type u} (C : Foo α → Foo α → Sort v) (x y : Foo α) - (h₁ : forall (a₁ a₂ : α), C (Foo.leaf a₁) (Foo.leaf a₂)) - (h₂ : forall (l₁ r₁ l₂ r₂ : Foo α), C (Foo.node l₁ r₁) (Foo.node l₂ r₂)) - (h₃ : forall (h₁ t₁ h₂ t₂), C (Foo.cons h₁ t₁) (Foo.cons h₂ t₂)) - (h₄ : forall (x y), C x y) - : C x y := -Foo.casesOn x - (fun a₁ => Foo.casesOn y - (fun a₂ => h₁ a₁ a₂) - (fun l₂ r₂ => h₄ (Foo.leaf a₁) (Foo.node l₂ r₂)) - (fun h₂ t₂ => h₄ (Foo.leaf a₁) (Foo.cons h₂ t₂))) - (fun l₁ r₁ => Foo.casesOn y - (fun a₂ => h₄ (Foo.node l₁ r₁) (Foo.leaf a₂)) - (fun l₂ r₂ => h₂ l₁ r₁ l₂ r₂) - (fun h₂ t₂ => h₄ (Foo.node l₁ r₁) (Foo.cons h₂ t₂))) - (fun h₁ t₁ => Foo.casesOn y - (fun a₂ => h₄ (Foo.cons h₁ t₁) (Foo.leaf a₂)) - (fun l₂ r₂ => h₄ (Foo.cons h₁ t₁) (Foo.node l₂ r₂)) - (fun h₂ t₂ => h₃ h₁ t₁ h₂ t₂)) - -def f : List Nat → List Nat → List Nat -| x::xs, _ => [] -| _, [] => [] -| xs, ys => xs ++ ys - -def List.elim (C : List Nat → List Nat → Sort v) (xs ys : List Nat) - (h₁ : forall x xs ys, C (x::xs) ys) - (h₂ : forall xs, C xs []) - (h₃ : forall xs ys, C xs ys) - : C xs ys := -List.casesOn xs - (List.casesOn ys - (h₂ []) - (fun y ys => h₃ [] (y::ys))) - (fun x xs => h₁ x xs ys) - -theorem List.elim.eq1 (C : List Nat → List Nat → Sort v) - (h₁ : forall x xs ys, C (x::xs) ys) - (h₂ : forall xs, C xs []) - (h₃ : forall xs ys, C xs ys) - (x : Nat) (xs ys : List Nat) - : List.elim C (x::xs) ys h₁ h₂ h₃ = h₁ x xs ys := -rfl - -theorem List.elim.eq2 (C : List Nat → List Nat → Sort v) - (h₁ : forall x xs ys, C (x::xs) ys) - (h₂ : forall xs, C xs []) - (h₃ : forall xs ys, C xs ys) - (xs : List Nat) - : (forall x' xs', xs = x'::xs' → False) → List.elim C xs [] h₁ h₂ h₃ = h₂ xs := -List.casesOn xs - (fun _ => rfl) - (fun x xs h => False.elim (h x xs rfl)) - -theorem List.elim.eq3 (C : List Nat → List Nat → Sort v) - (h₁ : forall x xs ys, C (x::xs) ys) - (h₂ : forall xs, C xs []) - (h₃ : forall xs ys, C xs ys) - (xs : List Nat) (ys : List Nat) - : (forall x' xs', xs = x'::xs' → False) → (ys = [] → False) → List.elim C xs ys h₁ h₂ h₃ = h₃ xs ys := -List.casesOn xs - (List.casesOn ys - (fun _ h => False.elim (h rfl)) - (fun y ys _ _ => rfl)) - (fun x xs h _ => False.elim (h x xs rfl)) - -theorem List.elim.eq3.a (C : List Nat → List Nat → Sort v) - (h₁ : forall x xs ys, C (x::xs) ys) - (h₂ : forall xs, C xs []) - (h₃ : forall xs ys, C xs ys) - (y : Nat) (ys : List Nat) - : List.elim C [] (y::ys) h₁ h₂ h₃ = h₃ [] (y::ys) := -rfl - -def List.elim2 (C : List Nat → List Nat → Sort v) (xs ys : List Nat) - (h₁ : forall x xs ys, C (x::xs) ys) - (h₂ : forall xs, (forall (x' : Nat) (xs' : List Nat), xs = x' :: xs' → False) → C xs []) - (h₃ : forall xs ys, (forall (x' : Nat) (xs' : List Nat), xs = x' :: xs' → False) → (ys = [] → False) → C xs ys) - : C xs ys := -List.casesOn xs - (List.casesOn ys - (h₂ [] (fun _ _ h => List.noConfusion h)) - (fun y ys => h₃ [] (y::ys) (fun _ _ h => List.noConfusion h) (fun h => List.noConfusion h))) - (fun x xs => h₁ x xs ys) - -def List.elim3 (C : List Nat → List Nat → List Nat → Sort v) (xs ys zs : List Nat) - (h₁ : forall zs, C [] [] zs) - (h₂ : forall xs ys, C xs ys []) - (h₃ : forall xs ys zs, C xs ys zs) - : C xs ys zs := -List.casesOn xs - (List.casesOn ys - (h₁ zs) - (fun y ys => List.casesOn zs - (h₃ [] (y::ys) []) - (fun z zs => h₃ [] (y::ys) (z::zs)))) - (fun x xs => - (List.casesOn zs - (h₂ (x::xs) ys) - (fun z zs => h₃ (x::xs) ys (z::zs)))) - -theorem List.elim3.eq (C : List Nat → List Nat → List Nat → Sort v) - (h₁ : forall zs, C [] [] zs) - (h₂ : forall xs ys, C xs ys []) - (h₃ : forall xs ys zs, C xs ys zs) - (xs ys zs : List Nat) - : (xs = [] → ys = [] → False) → (zs = [] → False) → List.elim3 C xs ys zs h₁ h₂ h₃ = h₃ xs ys zs := -List.casesOn xs - (List.casesOn ys - (fun h _ => False.elim (h rfl rfl)) - (fun y ys => List.casesOn zs - (fun _ h => False.elim (h rfl)) - (fun z zs _ _ => rfl))) - (fun x xs => - List.casesOn zs - (fun _ h => False.elim (h rfl)) - (fun z zs _ _ => rfl)) - -theorem List.elim3.eq.a (C : List Nat → List Nat → List Nat → Sort v) - (h₁ : forall zs, C [] [] zs) - (h₂ : forall xs ys, C xs ys []) - (h₃ : forall xs ys zs, C xs ys zs) - (y : Nat) (ys : List Nat) (z : Nat) (zs : List Nat) - : List.elim3 C [] (y::ys) (z::zs) h₁ h₂ h₃ = h₃ [] (y::ys) (z::zs) := -rfl - -theorem List.elim3.eq.b (C : List Nat → List Nat → List Nat → Sort v) - (h₁ : forall zs, C [] [] zs) - (h₂ : forall xs ys, C xs ys []) - (h₃ : forall xs ys zs, C xs ys zs) - (x : Nat) (xs : List Nat) (y : Nat) (ys : List Nat) (z : Nat) (zs : List Nat) - : List.elim3 C (x::xs) (y::ys) (z::zs) h₁ h₂ h₃ = h₃ (x::xs) (y::ys) (z::zs) := -rfl diff --git a/tmp/eqns/matchArrayLit.lean b/tmp/eqns/matchArrayLit.lean deleted file mode 100644 index 349ccbf588..0000000000 --- a/tmp/eqns/matchArrayLit.lean +++ /dev/null @@ -1,193 +0,0 @@ -universes u v - -namespace Experiment1 -inductive ArrayLitMatch (α : Type u) -| sz0 {} : ArrayLitMatch -| sz1 (a₁ : α) : ArrayLitMatch -| sz2 (a₁ a₂ : α) : ArrayLitMatch -| sz3 (a₁ a₂ a₃ : α) : ArrayLitMatch -| other {} : ArrayLitMatch - -def matchArrayLit {α : Type u} (a : Array α) : ArrayLitMatch α := -if a.size = 0 then - ArrayLitMatch.sz0 -else if h : a.size = 1 then - ArrayLitMatch.sz1 (a.getLit 0 h (ofDecideEqTrue rfl)) -else if h : a.size = 2 then - ArrayLitMatch.sz2 (a.getLit 0 h (ofDecideEqTrue rfl)) (a.getLit 1 h (ofDecideEqTrue rfl)) -else if h : a.size = 3 then - ArrayLitMatch.sz3 (a.getLit 0 h (ofDecideEqTrue rfl)) (a.getLit 1 h (ofDecideEqTrue rfl)) (a.getLit 2 h (ofDecideEqTrue rfl)) -else - ArrayLitMatch.other - -def matchArrayLit.eq0 {α : Type u} : matchArrayLit (#[] : Array α) = ArrayLitMatch.sz0 := -rfl - -def matchArrayLit.eq1 {α : Type u} (a₁ : α) : matchArrayLit #[a₁] = ArrayLitMatch.sz1 a₁ := -rfl - -def matchArrayLit.eq2 {α : Type u} (a₁ a₂ : α) : matchArrayLit #[a₁, a₂] = ArrayLitMatch.sz2 a₁ a₂ := -rfl - -def matchArrayLit.eq3 {α : Type u} (a₁ a₂ a₃ : α) : matchArrayLit #[a₁, a₂, a₃] = ArrayLitMatch.sz3 a₁ a₂ a₃ := -rfl - -def matchArrayLit.eq4 {α : Type u} (a₁ a₂ a₃ a₄ : α) : matchArrayLit #[a₁, a₂, a₃, a₄] = ArrayLitMatch.other := -rfl -end Experiment1 - -def toListLitAux {α : Type u} (a : Array α) (n : Nat) (hsz : a.size = n) : ∀ (i : Nat), i ≤ a.size → List α → List α -| 0, hi, acc => acc -| (i+1), hi, acc => toListLitAux i (Nat.leOfSuccLe hi) (a.getLit i hsz (Nat.ltOfLtOfEq (Nat.ltOfLtOfLe (Nat.ltSuccSelf i) hi) hsz) :: acc) - -def toArrayLit {α : Type u} (a : Array α) (n : Nat) (hsz : a.size = n) : Array α := -List.toArray $ toListLitAux a n hsz n (hsz ▸ Nat.leRefl _) [] - -theorem toArrayLitEq {α : Type u} (a : Array α) (n : Nat) (hsz : a.size = n) : a = toArrayLit a n hsz := --- TODO: this is painful to prove without proper automation -sorry -/- -First, we need to prove -∀ i j acc, i ≤ a.size → (toListLitAux a n hsz (i+1) hi acc).index j = if j < i then a.getLit j hsz _ else acc.index (j - i) -by induction - -Base case is trivial -(j : Nat) (acc : List α) (hi : 0 ≤ a.size) - |- (toListLitAux a n hsz 0 hi acc).index j = if j < 0 then a.getLit j hsz _ else acc.index (j - 0) -... |- acc.index j = acc.index j - -Induction - -(j : Nat) (acc : List α) (hi : i+1 ≤ a.size) - |- (toListLitAux a n hsz (i+1) hi acc).index j = if j < i + 1 then a.getLit j hsz _ else acc.index (j - (i + 1)) - ... |- (toListLitAux a n hsz i hi' (a.getLit i hsz _ :: acc)).index j = if j < i + 1 then a.getLit j hsz _ else acc.index (j - (i + 1)) * by def - ... |- if j < i then a.getLit j hsz _ else (a.getLit i hsz _ :: acc).index (j-i) * by induction hypothesis - = - if j < i + 1 then a.getLit j hsz _ else acc.index (j - (i + 1)) -If j < i, then both are a.getLit j hsz _ -If j = i, then lhs reduces else-branch to (a.getLit i hsz _) and rhs is then-brachn (a.getLit i hsz _) -If j >= i + 1, we use - - j - i >= 1 > 0 - - (a::as).index k = as.index (k-1) If k > 0 - - j - (i + 1) = (j - i) - 1 - Then lhs = (a.getLit i hsz _ :: acc).index (j-i) = acc.index (j-i-1) = acc.index (j-(i+1)) = rhs - -With this proof, we have - -∀ j, j < n → (toListLitAux a n hsz n _ []).index j = a.getLit j hsz _ - -We also need - -- (toListLitAux a n hsz n _ []).length = n -- j < n -> (List.toArray as).getLit j _ _ = as.index j - -Then using Array.extLit, we have that a = List.toArray $ toListLitAux a n hsz n _ [] --/ - -theorem Array.eqLitOfSize0 {α : Type u} (a : Array α) (hsz : a.size = 0) : a = #[] := -toArrayLitEq a 0 hsz -/- -Array.ext a #[] h (fun i h₁ h₂ => absurd h₂ (Nat.notLtZero _)) --/ - -theorem Array.eqLitOfSize1 {α : Type u} (a : Array α) (hsz : a.size = 1) : a = #[a.getLit 0 hsz (ofDecideEqTrue rfl)] := -toArrayLitEq a 1 hsz -/- -Array.extLit a #[a.getLit 0 hsz (ofDecideEqTrue rfl)] hsz rfl $ fun i => - match i with - | 0 => fun hi => rfl - | (n+1) => fun hi => - have n < 0 from hi; - absurd this (Nat.notLtZero _) --/ - -theorem Array.eqLitOfSize2 {α : Type u} (a : Array α) (hsz : a.size = 2) : a = #[a.getLit 0 hsz (ofDecideEqTrue rfl), a.getLit 1 hsz (ofDecideEqTrue rfl)] := -toArrayLitEq a 2 hsz -/- -Array.extLit a #[a.getLit 0 hsz (ofDecideEqTrue rfl), a.getLit 1 hsz (ofDecideEqTrue rfl)] hsz rfl $ fun i => - match i with - | 0 => fun hi => rfl - | 1 => fun hi => rfl - | (n+2) => fun hi => - have n < 0 from hi; - absurd this (Nat.notLtZero _) --/ - -theorem Array.eqLitOfSize3 {α : Type u} (a : Array α) (hsz : a.size = 3) : - a = #[a.getLit 0 hsz (ofDecideEqTrue rfl), a.getLit 1 hsz (ofDecideEqTrue rfl), a.getLit 2 hsz (ofDecideEqTrue rfl)] := -toArrayLitEq a 3 hsz -/- -Array.extLit a #[a.getLit 0 hsz (ofDecideEqTrue rfl), a.getLit 1 hsz (ofDecideEqTrue rfl), a.getLit 2 hsz (ofDecideEqTrue rfl)] hsz rfl $ fun i => - match i with - | 0 => fun hi => rfl - | 1 => fun hi => rfl - | 2 => fun hi => rfl - | (n+3) => fun hi => - have n < 0 from hi; - absurd this (Nat.notLtZero _) --/ - -/- -Matcher for the following patterns -``` -| #[] => _ -| #[a₁] => _ -| #[a₁, a₂, a₃] => _ -| a => _ -``` -/ -def matchArrayLit {α : Type u} (C : Array α → Sort v) (a : Array α) - (h₁ : Unit → C #[]) - (h₂ : ∀ a₁, C #[a₁]) - (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃]) - (h₄ : ∀ a, C a) - : C a := -if h : a.size = 0 then - @Eq.rec _ _ (fun x _ => C x) (h₁ ()) _ (toArrayLitEq a 0 h).symm -else if h : a.size = 1 then - @Eq.rec _ _ (fun x _ => C x) (h₂ (a.getLit 0 h (ofDecideEqTrue rfl))) _ (toArrayLitEq a 1 h).symm -else if h : a.size = 3 then - @Eq.rec _ _ (fun x _ => C x) (h₃ (a.getLit 0 h (ofDecideEqTrue rfl)) (a.getLit 1 h (ofDecideEqTrue rfl)) (a.getLit 2 h (ofDecideEqTrue rfl))) _ (toArrayLitEq a 3 h).symm -else - h₄ a - -/- Equational lemmas that should be generated automatically. -/ -theorem matchArrayLit.eq1 {α : Type u} (C : Array α → Sort v) - (h₁ : Unit → C #[]) - (h₂ : ∀ a₁, C #[a₁]) - (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃]) - (h₄ : ∀ a, C a) - : matchArrayLit C #[] h₁ h₂ h₃ h₄ = h₁ () := -rfl - -theorem matchArrayLit.eq2 {α : Type u} (C : Array α → Sort v) - (h₁ : Unit → C #[]) - (h₂ : ∀ a₁, C #[a₁]) - (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃]) - (h₄ : ∀ a, C a) - (a₁ : α) - : matchArrayLit C #[a₁] h₁ h₂ h₃ h₄ = h₂ a₁ := -rfl - -theorem matchArrayLit.eq3 {α : Type u} (C : Array α → Sort v) - (h₁ : Unit → C #[]) - (h₂ : ∀ a₁, C #[a₁]) - (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃]) - (h₄ : ∀ a, C a) - (a₁ a₂ a₃ : α) - : matchArrayLit C #[a₁, a₂, a₃] h₁ h₂ h₃ h₄ = h₃ a₁ a₂ a₃ := -rfl - -theorem matchArrayLit.eq4 {α : Type u} (C : Array α → Sort v) - (h₁ : Unit → C #[]) - (h₂ : ∀ a₁, C #[a₁]) - (h₃ : ∀ a₁ a₂ a₃, C #[a₁, a₂, a₃]) - (h₄ : ∀ a, C a) - (a : Array α) - (n₁ : a.size ≠ 0) (n₂ : a.size ≠ 1) (n₃ : a.size ≠ 3) - : matchArrayLit C a h₁ h₂ h₃ h₄ = h₄ a := -match a, n₁, n₂, n₃ with -| ⟨0, _⟩, n₁, _, _ => absurd rfl n₁ -| ⟨1, _⟩, _, n₂, _ => absurd rfl n₂ -| ⟨2, _⟩, _, _, _ => rfl -| ⟨3, _⟩, _, _, n₃ => absurd rfl n₃ -| ⟨n+4, _⟩, _, _, _ => rfl diff --git a/tmp/eqns/matchVal.lean b/tmp/eqns/matchVal.lean deleted file mode 100644 index e4fdada066..0000000000 --- a/tmp/eqns/matchVal.lean +++ /dev/null @@ -1,46 +0,0 @@ -universes v -/- -matcher for the following patterns -``` -| "hello" => _ -| "world" => _ -| a => _ -``` -/ -def matchString (C : String → Sort v) (s : String) - (h₁ : Unit → C "hello") - (h₂ : Unit → C "world") - (h₃ : ∀ s, C s) - : C s := -dite (s = "hello") - (fun h => @Eq.ndrec _ _ (fun x => C x) (h₁ ()) _ h.symm) - (fun _ => dite (s = "world") - (fun h => @Eq.ndrec _ _ (fun x => C x) (h₂ ()) _ h.symm) - (fun _ => h₃ s)) - -theorem matchString.Eq1 (C : String → Sort v) - (h₁ : Unit → C "hello") - (h₂ : Unit → C "world") - (h₃ : ∀ s, C s) - : matchString C "hello" h₁ h₂ h₃ = h₁ () := -difPos rfl - -axiom neg1 : "world" ≠ "hello" - -theorem matchString.Eq2 (C : String → Sort v) - (h₁ : Unit → C "hello") - (h₂ : Unit → C "world") - (h₃ : ∀ s, C s) - : matchString C "world" h₁ h₂ h₃ = h₂ () := -have aux₁ : matchString C "world" h₁ h₂ h₃ = if h : "world" = "world" then @Eq.rec _ _ (fun x _ => C x) (h₂ ()) _ h.symm else h₃ "world" from difNeg neg1; -have aux₂ : (if h : "world" = "world" then @Eq.rec _ _ (fun x _ => C x) (h₂ ()) _ h.symm else h₃ "world" : C "world") = h₂ () from difPos rfl; -Eq.trans aux₁ aux₂ - -theorem matchString.Eq3 (C : String → Sort v) - (h₁ : Unit → C "hello") - (h₂ : Unit → C "world") - (h₃ : ∀ s, C s) - (s : String) (n₁ : s ≠ "hello") (n₂ : s ≠ "world") - : matchString C s h₁ h₂ h₃ = h₃ s := -have aux₁ : matchString C s h₁ h₂ h₃ = if h : s = "world" then @Eq.rec _ _ (fun x _ => C x) (h₂ ()) _ h.symm else h₃ s from difNeg n₁; -have aux₂ : (if h : s = "world" then @Eq.rec _ _ (fun x _ => C x) (h₂ ()) _ h.symm else h₃ s : C s) = h₃ s from difNeg n₂; -Eq.trans aux₁ aux₂ diff --git a/tmp/new-frontend/elaborator.lean b/tmp/new-frontend/elaborator.lean deleted file mode 100644 index 223a7ea4b0..0000000000 --- a/tmp/new-frontend/elaborator.lean +++ /dev/null @@ -1,1004 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -Elaborator for the Lean language: takes commands and produces side effects --/ -prelude -import init.lean.parser.module -import init.lean.expander -import init.lean.expr -import init.lean.options -import init.lean.environment - -namespace Lean --- deprecated Constructor -@[extern "lean_expr_local"] -constant Expr.local (n : Name) (pp : Name) (ty : Expr) (bi : BinderInfo) : Expr := default Expr - -namespace Elaborator --- TODO(Sebastian): move --- TODO(Sebastian): should be its own Monad? -structure NameGenerator := -(«prefix» : Name) -(nextIdx : UInt32) - -structure SectionVar := -(uniqName : Name) -(BinderInfo : BinderInfo) -(type : Expr) - -/-- Simplified State of the Lean 3 Parser. Maps are replaced with lists for easier interop. -/ -structure OldElaboratorState := -(env : Environment) -(ngen : NameGenerator) -(univs : List (Name × Level)) -(vars : List (Name × SectionVar)) -(includeVars : List Name) -(Options : Options) -(nextInstIdx : Nat) -(ns : Name) - -@[extern "lean_elaborator_elaborate_command"] -constant elaborateCommand (filename : @& String) (e : Expr) (s : @& OldElaboratorState) : Option OldElaboratorState × MessageLog := (none, ⟨[]⟩) - -open Parser -open Parser.Combinators -open Parser.Term -open Parser.command -open Parser.command.NotationSpec -open Expander - --- TODO(Sebastian): move -/-- An RBMap that remembers the insertion order. -/ -structure OrderedRBMap (α β : Type) (lt : α → α → Bool) := -(entries : List (α × β)) -(map : RBMap α (Nat × β) lt) -(size : Nat) - -namespace OrderedRBMap -variables {α β : Type} {lt : α → α → Bool} (m : OrderedRBMap α β lt) - -def empty : OrderedRBMap α β lt := {entries := [], map := mkRBMap _ _ _, size := 0} - -def insert (k : α) (v : β) : OrderedRBMap α β lt := -{entries := (k, v)::m.entries, map := m.map.insert k (m.size, v), size := m.size + 1} - -def find (a : α) : Option (Nat × β) := -m.map.find a - -def ofList (l : List (α × β)) : OrderedRBMap α β lt := -l.foldl (λ m p, OrderedRBMap.insert m (Prod.fst p) (Prod.snd p)) OrderedRBMap.empty -end OrderedRBMap - -structure ElaboratorConfig extends FrontendConfig := -(initialParserCfg : ModuleParserConfig) - -instance elaboratorConfigCoeFrontendConfig : HasCoe ElaboratorConfig FrontendConfig := -⟨ElaboratorConfig.toFrontendConfig⟩ - -/-- Elaborator State that will be reverted at the end of a section or namespace. -/ -structure Scope := --- "section" or "namespace" (or "MODULE"), currently -(cmd : String) --- Scope header, should match identifier after `end`. Can be `Name.anonymous` for sections. -(header : Name) -(notations : List NotationMacro := []) -/- The set of local universe variables. - We remember their insertion order so that we can keep the order when copying them to declarations. -/ -(univs : OrderedRBMap Name Level Name.quickLt := OrderedRBMap.empty) -/- The set of local variables. -/ -(vars : OrderedRBMap Name SectionVar Name.quickLt := OrderedRBMap.empty) -/- The subset of `vars` that is tagged as always included. -/ -(includeVars : RBTree Name Name.quickLt := mkRBTree _ _) -/- The stack of nested active `namespace` commands. -/ -(nsStack : List Name := []) -/- The set of active `open` declarations. -/ -(openDecls : List openSpec.View := []) -(Options : Options := {}) - -/-- An `export` command together with the namespace it was declared in. Opening the namespace activates - the export. -/ -structure ScopedExportDecl := -(inNs : Name) -(spec : openSpec.View) - -structure ElaboratorState := --- TODO(Sebastian): retrieve from environment -(reservedNotations : List reserveNotation.View := []) -(notations : List NotationMacro := []) -(notationCounter := 0) -/- The current set of `export` declarations (active or inactive). -/ -(exportDecls : List ScopedExportDecl := []) - --- Stack of current scopes. The bottom-most Scope is the Module Scope. -(scopes : List Scope) -(messages : MessageLog := MessageLog.empty) -(parserCfg : ModuleParserConfig) -(expanderCfg : Expander.ExpanderConfig) -(env : Environment) -(ngen : NameGenerator) -(nextInstIdx : Nat := 0) - -@[derive Monad MonadRec MonadReader MonadState MonadExcept] -def ElaboratorM := RecT Syntax Unit $ ReaderT ElaboratorConfig $ StateT ElaboratorState $ ExceptT Message Id -abbrev Elaborator := Syntax → ElaboratorM Unit - -instance elaboratorInh (α : Type) : Inhabited (ElaboratorM α) := -⟨λ _ _ _, Except.error (default _)⟩ - -/-- Recursively elaborate any command. -/ -def command.elaborate : Elaborator := recurse - -def currentScope : ElaboratorM Scope := do - st ← get, - match st.scopes with - | [] := error none "currentScope: unreachable" - | sc::_ := pure sc - -def modifyCurrentScope (f : Scope → Scope) : ElaboratorM Unit := do - st ← get, - match st.scopes with - | [] := error none "modifyCurrentScope: unreachable" - | sc::scs := set {st with scopes := f sc::scs} - -def mangleIdent (id : SyntaxIdent) : Name := -id.scopes.foldl Name.mkNumeral id.val - -partial def levelGetAppArgs : Syntax → ElaboratorM (Syntax × List Syntax) -| stx := do - match stx.kind with - | some Level.leading := pure (stx, []) - | some Level.trailing := match view Level.trailing stx with - | Level.trailing.View.app lta := do - (fn, args) ← levelGetAppArgs lta.fn, - pure (fn, lta.Arg :: args) - | Level.trailing.View.addLit _ := pure (stx, []) - | _ := error stx $ "levelGetAppArgs: unexpected input: " ++ toString stx - -def levelAdd : Level → Nat → Level -| l 0 := l -| l (n+1) := (levelAdd l n).succ - -partial def toLevel : Syntax → ElaboratorM Level -| stx := do - (fn, args) ← levelGetAppArgs stx, - sc ← currentScope, - match fn.kind with - | some Level.leading := match view Level.leading fn, args with - | Level.leading.View.hole _, [] := pure $ Level.mvar Name.anonymous - | Level.leading.View.lit lit, [] := pure $ Level.ofNat lit.toNat - | Level.leading.View.var id, [] := let id := mangleIdent id in match sc.univs.find id with - | some _ := pure $ Level.Param id - | none := error stx $ "unknown universe variable '" ++ toString id ++ "'" - | Level.leading.View.max _, (Arg::args) := List.foldr Level.max <$> toLevel Arg <*> args.mmap toLevel - | Level.leading.View.imax _, (Arg::args) := List.foldr Level.imax <$> toLevel Arg <*> args.mmap toLevel - | _, _ := error stx "ill-formed universe Level" - | some Level.trailing := match view Level.trailing fn, args with - | Level.trailing.View.addLit lta, [] := do - l ← toLevel lta.lhs, - pure $ levelAdd l lta.rhs.toNat - | _, _ := error stx "ill-formed universe Level" - | _ := error stx $ "toLevel: unexpected input: " ++ toString stx - -def Expr.mkAnnotation (ann : Name) (e : Expr) := -Expr.mdata (MData.empty.setName `annotation ann) e - -def dummy : Expr := Expr.const `Prop [] - -def mkEqns (type : Expr) (eqns : List (Name × List Expr × Expr)): Expr := - let eqns := eqns.map $ λ ⟨fn, lhs, rhs⟩, do { - let fn := Expr.local fn fn type BinderInfo.auxDecl, - let lhs := Expr.mkApp (Expr.mkAnnotation `@ fn) lhs, - Expr.app lhs rhs - } in - Expr.mkAnnotation `preEquations $ Expr.mkCapp `_ eqns - -partial def toPexpr : Syntax → ElaboratorM Expr -| stx@(Syntax.rawNode {kind := k, args := args}) := do - e ← match k with - | @identUnivs := do - let v := view identUnivs stx, - e ← match v with - | {id := id, univs := some univs} := Expr.const (mangleIdent id) <$> univs.levels.mmap toLevel - | {id := id, univs := none} := pure $ Expr.const (mangleIdent id) [], - let m := MData.empty.setName `annotation `preresolved, - let m := v.id.preresolved.enum.foldl (λ (m : MData) ⟨i, n⟩, m.setName (Name.anonymous.mkNumeral i) n) m, - pure $ Expr.mdata m e - | @app := let v := view app stx in - Expr.app <$> toPexpr v.fn <*> toPexpr v.Arg - | @lambda := do - let lam := view lambda stx, - binders.View.simple bnder ← pure lam.binders - | error stx "ill-formed lambda", - (bi, id, type) ← pure bnder.toBinderInfo, - Expr.lam (mangleIdent id) bi <$> toPexpr type <*> toPexpr lam.body - | @pi := do - let v := view pi stx, - binders.View.simple bnder ← pure v.binders - | error stx "ill-formed pi", - (bi, id, type) ← pure bnder.toBinderInfo, - Expr.pi (mangleIdent id) bi <$> toPexpr type <*> toPexpr v.range - | @sort := match view sort stx with - | sort.View.Sort _ := pure $ Expr.sort Level.zero - | sort.View.Type _ := pure $ Expr.sort $ Level.succ Level.zero - | @sortApp := do - let v := view sortApp stx, - match view sort v.fn with - | sort.View.Sort _ := Expr.sort <$> toLevel v.Arg - | sort.View.Type _ := (Expr.sort ∘ Level.succ) <$> toLevel v.Arg - | @anonymousConstructor := do - let v := view anonymousConstructor stx, - p ← toPexpr $ mkApp (review hole {}) (v.args.map SepBy.Elem.View.item), - pure $ Expr.mkAnnotation `anonymousConstructor p - | @hole := pure $ Expr.mvar Name.anonymous dummy - | @«have» := do - let v := view «have» stx, - let id := (mangleIdent <$> optIdent.View.id <$> v.id).getOrElse `this, - let proof := match v.proof with - | haveProof.View.Term hpt := hpt.Term - | haveProof.View.from hpf := hpf.from.proof, - lam ← Expr.lam id BinderInfo.default <$> toPexpr v.prop <*> toPexpr v.body, - Expr.app (Expr.mkAnnotation `have lam) <$> toPexpr proof - | @«show» := do - let v := view «show» stx, - prop ← toPexpr v.prop, - proof ← toPexpr v.from.proof, - pure $ Expr.mkAnnotation `show $ Expr.app (Expr.lam `this BinderInfo.default prop $ Expr.bvar 0) proof - | @«let» := do - let v := view «let» stx, - letLhs.View.id {id := id, binders := [], type := some ty} ← pure v.lhs - | error stx "ill-formed let", - Expr.elet (mangleIdent id) <$> toPexpr ty.type <*> toPexpr v.value <*> toPexpr v.body - | @projection := do - let v := view projection stx, - let val := match v.proj with - | projectionSpec.View.id id := DataValue.ofName id.val - | projectionSpec.View.num n := DataValue.ofNat n.toNat, - Expr.mdata (MData.empty.insert `fieldNotation val) <$> toPexpr v.Term - | @explicit := do - let v := view explicit stx, - let ann := match v.mod with - | explicitModifier.View.explicit _ := `@ - | explicitModifier.View.partialExplicit _ := `@@, - Expr.mkAnnotation ann <$> toPexpr (review identUnivs v.id) - | @inaccessible := do - let v := view inaccessible stx, - Expr.mkAnnotation `innaccessible <$> toPexpr v.Term -- sic - | @borrowed := do - let v := view borrowed stx, - Expr.mkAnnotation `borrowed <$> toPexpr v.Term - | @number := do - let v := view number stx, - pure $ Expr.lit $ Literal.natVal v.toNat - | @stringLit := do - let v := view stringLit stx, - pure $ Expr.lit $ Literal.strVal (v.value.getOrElse "NOTAString") - | @choice := do - last::rev ← List.reverse <$> args.mmap (λ a, toPexpr a) - | error stx "ill-formed choice", - pure $ Expr.mdata (MData.empty.setNat `choice args.length) $ - rev.reverse.foldr Expr.app last - | @structInst := do - let v := view structInst stx, - -- order should be: fields*, sources*, catchall? - let (fields, other) := v.items.span (λ it, ↑match SepBy.Elem.View.item it with - | structInstItem.View.field _ := true - | _ := false), - let (sources, catchall) := other.span (λ it, ↑match SepBy.Elem.View.item it with - | structInstItem.View.source {source := some _} := true - | _ := false), - catchall ← match catchall with - | [] := pure false - | [{item := structInstItem.View.source _}] := pure true - | {item := it}::_ := error (review structInstItem it) $ "unexpected item in structure instance notation", - - fields ← fields.mmap (λ f, match SepBy.Elem.View.item f with - | structInstItem.View.field f := - Expr.mdata (MData.empty.setName `field $ mangleIdent f.id) <$> toPexpr f.val - | _ := error stx "toPexpr: unreachable"), - sources ← sources.mmap (λ src, match SepBy.Elem.View.item src with - | structInstItem.View.source {source := some src} := toPexpr src - | _ := error stx "toPexpr: unreachable"), - sources ← match v.with with - | none := pure sources - | some src := do { src ← toPexpr src.source, pure $ sources ++ [src]}, - - let m := MData.empty.setNat "structure instance" fields.length, - let m := m.setBool `catchall catchall, - let m := m.setName `struct $ - (mangleIdent <$> structInstType.View.id <$> v.type).getOrElse Name.anonymous, - let dummy := Expr.sort Level.zero, - pure $ Expr.mdata m $ (fields ++ sources).foldr Expr.app dummy - | @«match» := do - let v := view «match» stx, - eqns ← (v.equations.map SepBy.Elem.View.item).mmap $ λ (eqn : matchEquation.View), do { - lhs ← eqn.lhs.mmap $ λ l, toPexpr l.item, - rhs ← toPexpr eqn.rhs, - pure (`_matchFn, lhs, rhs) - }, - type ← toPexpr $ getOptType v.type, - let eqns := mkEqns type eqns, - Expr.mdata mdata e ← pure eqns - | error stx "toPexpr: unreachable", - let eqns := Expr.mdata (mdata.setBool `match true) e, - Expr.mkApp eqns <$> v.scrutinees.mmap (λ scr, toPexpr scr.item) - | _ := error stx $ "toPexpr: unexpected Node: " ++ toString k.name, - match k with - | @app := pure e -- no Position - | _ := do - cfg ← read, - match stx.getPos with - | some pos := - let pos := cfg.fileMap.toPosition pos in - pure $ Expr.mdata ((MData.empty.setNat `column pos.column).setNat `row pos.line) e - | none := pure e -| stx := error stx $ "toPexpr: unexpected: " ++ toString stx - -/-- Returns the active namespace, that is, the concatenation of all active `namespace` commands. -/ -def getNamespace : ElaboratorM Name := do - sc ← currentScope, - pure $ match sc.nsStack with - | ns::_ := ns - | _ := Name.anonymous - -def oldElabCommand (stx : Syntax) (cmd : Expr) : ElaboratorM Unit := -do cfg ← read, - let pos := cfg.fileMap.toPosition $ stx.getPos.getOrElse (default _), - let cmd := match cmd with - | Expr.mdata m e := Expr.mdata ((m.setNat `column pos.column).setNat `row pos.line) e - | e := e, - st ← get, - sc ← currentScope, - ns ← getNamespace, - let (st', msgs) := elaborateCommand cfg.filename cmd { - ns := ns, - univs := sc.univs.entries.reverse, - vars := sc.vars.entries.reverse, - includeVars := sc.includeVars.toList, - Options := sc.Options, - ..st}, - match st' with - | some st' := do modifyCurrentScope $ λ sc, {sc with - univs := OrderedRBMap.ofList st'.univs, - vars := OrderedRBMap.ofList st'.vars, - includeVars := RBTree.ofList st'.includeVars, - Options := st'.Options, - }, - modify $ λ st, {..st', ..st} - | none := pure (), -- error - modify $ λ st, {st with messages := st.messages ++ msgs} - -def namesToPexpr (ns : List Name) : Expr := -Expr.mkCapp `_ $ ns.map (λ n, Expr.const n []) - -def attrsToPexpr (attrs : List (SepBy.Elem.View attrInstance.View (Option SyntaxAtom))) : ElaboratorM Expr := -Expr.mkCapp `_ <$> attrs.mmap (λ attr, - Expr.mkCapp attr.item.Name.val <$> attr.item.args.mmap toPexpr) - -def declModifiersToPexpr (mods : declModifiers.View) : ElaboratorM Expr := do - let mdata : MData := {}, - let mdata := match mods.docComment with - | some {doc := some doc, ..} := mdata.setString `docString doc.val - | _ := mdata, - let mdata := match mods.visibility with - | some (visibility.View.private _) := mdata.setBool `private true - | some (visibility.View.protected _) := mdata.setBool `protected true - | _ := mdata, - let mdata := mdata.setBool `noncomputable mods.noncomputable.isSome, - let mdata := mdata.setBool `unsafe mods.unsafe.isSome, - Expr.mdata mdata <$> attrsToPexpr (match mods.attrs with - | some attrs := attrs.attrs - | none := []) - -def identUnivParamsToPexpr (id : identUnivParams.View) : Expr := -Expr.const (mangleIdent id.id) $ match id.univParams with - | some params := params.params.map (Level.Param ∘ mangleIdent) - | none := [] - -/-- Execute `elab` and reset local Scope (universes, ...) after it has finished. -/ -def locally (elab : ElaboratorM Unit) : - ElaboratorM Unit := do - sc ← currentScope, - elab, - modifyCurrentScope $ λ _, sc - -def simpleBindersToPexpr (bindrs : List simpleBinder.View) : ElaboratorM Expr := -Expr.mkCapp `_ <$> bindrs.mmap (λ b, do - let (bi, id, type) := b.toBinderInfo, - let id := mangleIdent id, - type ← toPexpr type, - pure $ Expr.local id id type bi) - -def elabDefLike (stx : Syntax) (mods : declModifiers.View) (dl : defLike.View) (kind : Nat) : ElaboratorM Unit := -match dl with -| {sig := {params := bracketedBinders.View.simple bbs}, ..} := do - let mdata := MData.empty.setName `command `defs, - mods ← declModifiersToPexpr mods, - let kind := Expr.lit $ Literal.natVal kind, - match dl.oldUnivParams with - | some uparams := - modifyCurrentScope $ λ sc, {sc with univs := - (uparams.ids.map mangleIdent).foldl (λ m id, OrderedRBMap.insert m id (Level.Param id)) sc.univs} - | none := pure (), - -- do we actually need this?? - let uparams := namesToPexpr $ match dl.oldUnivParams with - | some uparams := uparams.ids.map mangleIdent - | none := [], - let id := mangleIdent dl.Name.id, - let type := getOptType dl.sig.type, - type ← toPexpr type, - let fns := Expr.mkCapp `_ [Expr.local id id type BinderInfo.auxDecl], - val ← match dl.val with - | declVal.View.simple val := toPexpr val.body - | declVal.View.emptyMatch _ := pure $ mkEqns type [] - | declVal.View.match eqns := do { - eqns ← eqns.mmap (λ (eqn : equation.View), do - lhs ← eqn.lhs.mmap toPexpr, - rhs ← toPexpr eqn.rhs, - pure (id, lhs, rhs) - ), - pure $ mkEqns type eqns - }, - params ← simpleBindersToPexpr bbs, - oldElabCommand stx $ Expr.mdata mdata $ Expr.mkCapp `_ [mods, kind, uparams, fns, params, val] -| _ := error stx "elabDefLike: unexpected input" - -def inferModToPexpr (mod : Option inferModifier.View) : Expr := -Expr.lit $ Literal.natVal $ match mod with -| none := 0 -| some $ inferModifier.View.relaxed _ := 1 -| some $ inferModifier.View.strict _ := 2 - -def declaration.elaborate : Elaborator := -λ stx, locally $ do - let decl := view «declaration» stx, - match decl.inner with - | declaration.inner.View.«axiom» c@{sig := {params := bracketedBinders.View.simple [], type := type}, ..} := do - let mdata := MData.empty.setName `command `«axiom», -- CommentTo(Kha): It was `constant` here - mods ← declModifiersToPexpr decl.modifiers, - let id := identUnivParamsToPexpr c.Name, - type ← toPexpr type.type, - oldElabCommand stx $ Expr.mdata mdata $ Expr.mkCapp `_ [mods, id, type] - | declaration.inner.View.defLike dl := do - -- The numeric literals below should reflect the enum values - -- enum class declCmdKind { Theorem, Definition, OpaqueConst, Example, Instance, Var, Abbreviation }; - let kind := match dl.kind with - | defLike.kind.View.theorem _ := 0 - | defLike.kind.View.def _ := 1 - | defLike.kind.View.«constant» _ := 2 - | defLike.kind.View.abbreviation _ := 6 - | defLike.kind.View.«abbrev» _ := 6, - elabDefLike stx decl.modifiers dl kind - - -- these are almost macros for `def`, Except the Elaborator handles them specially at a few places - -- based on the kind - | declaration.inner.View.example ex := - elabDefLike stx decl.modifiers { - kind := defLike.kind.View.def, - Name := {id := Name.anonymous}, - sig := {..ex.sig}, - ..ex} 3 - | declaration.inner.View.instance i := - elabDefLike stx decl.modifiers { - kind := defLike.kind.View.def, - Name := i.Name.getOrElse {id := Name.anonymous}, - sig := {..i.sig}, - ..i} 4 - - | declaration.inner.View.inductive ind@{«class» := none, sig := {params := bracketedBinders.View.simple bbs}, ..} := do - let mdata := MData.empty.setName `command `inductives, - mods ← declModifiersToPexpr decl.modifiers, - attrs ← attrsToPexpr (match decl.modifiers.attrs with - | some attrs := attrs.attrs - | none := []), - let mutAttrs := Expr.mkCapp `_ [attrs], - match ind.oldUnivParams with - | some uparams := - modifyCurrentScope $ λ sc, {sc with univs := - (uparams.ids.map mangleIdent).foldl (λ m id, OrderedRBMap.insert m id (Level.Param id)) sc.univs} - | none := pure (), - let uparams := namesToPexpr $ match ind.oldUnivParams with - | some uparams := uparams.ids.map mangleIdent - | none := [], - let id := mangleIdent ind.Name.id, - let type := getOptType ind.sig.type, - type ← toPexpr type, - let indL := Expr.local id id type BinderInfo.default, - let inds := Expr.mkCapp `_ [indL], - params ← simpleBindersToPexpr bbs, - introRules ← ind.introRules.mmap (λ (r : introRule.View), do - ({params := bracketedBinders.View.simple [], type := some ty}) ← pure r.sig - | error stx "declaration.elaborate: unexpected input", - type ← toPexpr ty.type, - let Name := mangleIdent r.Name, - pure $ Expr.local Name Name type BinderInfo.default), - let introRules := Expr.mkCapp `_ introRules, - let introRules := Expr.mkCapp `_ [introRules], - let inferKinds := ind.introRules.map $ λ (r : introRule.View), inferModToPexpr r.inferMod, - let inferKinds := Expr.mkCapp `_ inferKinds, - let inferKinds := Expr.mkCapp `_ [inferKinds], - oldElabCommand stx $ Expr.mdata mdata $ - Expr.mkCapp `_ [mods, mutAttrs, uparams, inds, params, introRules, inferKinds] - - | declaration.inner.View.structure s@{keyword := structureKw.View.structure _, sig := {params := bracketedBinders.View.simple bbs}, ..} := do - let mdata := MData.empty.setName `command `structure, - mods ← declModifiersToPexpr decl.modifiers, - match s.oldUnivParams with - | some uparams := - modifyCurrentScope $ λ sc, {sc with univs := - (uparams.ids.map mangleIdent).foldl (λ m id, OrderedRBMap.insert m id (Level.Param id)) sc.univs} - | none := pure (), - let uparams := namesToPexpr $ match s.oldUnivParams with - | some uparams := uparams.ids.map mangleIdent - | none := [], - let Name := mangleIdent s.Name.id, - let Name := Expr.local Name Name dummy BinderInfo.default, - let type := getOptType s.sig.type, - type ← toPexpr type, - params ← simpleBindersToPexpr bbs, - let parents := match s.extends with - | some ex := ex.parents - | none := [], - parents ← parents.mmap (toPexpr ∘ SepBy.Elem.View.item), - let parents := Expr.mkCapp `_ parents, - let mk := match s.ctor with - | some ctor := mangleIdent ctor.Name - | none := `mk, - let mk := Expr.local mk mk dummy BinderInfo.default, - let infer := inferModToPexpr (s.ctor >>= structureCtor.View.inferMod), - fieldBlocks ← s.fieldBlocks.mmap (λ bl, do - (bi, content) ← match bl with - | structureFieldBlock.View.explicit {content := structExplicitBinderContent.View.notation _} := - error stx "declaration.elaborate: unexpected input" - | structureFieldBlock.View.explicit {content := structExplicitBinderContent.View.other c} := - pure (BinderInfo.default, c) - | structureFieldBlock.View.implicit {content := c} := pure (BinderInfo.implicit, c) - | structureFieldBlock.View.strictImplicit {content := c} := pure (BinderInfo.strictImplicit, c) - | structureFieldBlock.View.instImplicit {content := c} := pure (BinderInfo.instImplicit, c), - let bi := Expr.local `_ `_ dummy bi, - let ids := namesToPexpr $ content.ids.map mangleIdent, - let kind := inferModToPexpr content.inferMod, - let type := getOptType content.sig.type, - type ← toPexpr type, - pure $ Expr.mkCapp `_ [bi, ids, kind, type]), - let fieldBlocks := Expr.mkCapp `_ fieldBlocks, - oldElabCommand stx $ Expr.mdata mdata $ - Expr.mkCapp `_ [mods, uparams, Name, params, parents, type, mk, infer, fieldBlocks] - | _ := - error stx "declaration.elaborate: unexpected input" - -def variables.elaborate : Elaborator := -λ stx, do - let mdata := MData.empty.setName `command `variables, - let v := view «variables» stx, - vars ← match v.binders with - | bracketedBinders.View.simple bbs := bbs.mfilter $ λ b, do - let (bi, id, type) := b.toBinderInfo, - if type.isOfKind bindingAnnotationUpdate then do - sc ← currentScope, - let id := mangleIdent id, - match sc.vars.find id with - | some (_, v) := - modifyCurrentScope $ λ sc, {sc with vars := - sc.vars.insert id {v with BinderInfo := bi}} - | none := error (Syntax.ident id) "", - pure false - else pure true - | _ := error stx "variables.elaborate: unexpected input", - vars ← simpleBindersToPexpr vars, - oldElabCommand stx $ Expr.mdata mdata vars - -def include.elaborate : Elaborator := -λ stx, do - let v := view «include» stx, - -- TODO(Sebastian): error checking - modifyCurrentScope $ λ sc, {sc with includeVars := - v.ids.foldl (λ vars v, vars.insert $ mangleIdent v) sc.includeVars} - --- TODO: RBMap.remove -/- -def omit.elaborate : Elaborator := -λ stx, do - let v := View «omit» stx, - modify $ λ st, {st with localState := {sc with includeVars := - v.ids.foldl (λ vars v, vars.remove $ mangleIdent v) sc.includeVars}} --/ - -def Module.header.elaborate : Elaborator := -λ stx, do - let header := view Module.header stx, - match header with - | {«prelude» := some _, imports := []} := pure () - | _ := error stx "not implemented: imports" - -def precToNat : Option precedence.View → Nat -| (some prec) := prec.Term.toNat -| none := 0 - --- TODO(Sebastian): Command parsers like `structure` will need access to these -def CommandParserConfig.registerNotationTokens (spec : NotationSpec.View) (cfg : CommandParserConfig) : - Except String CommandParserConfig := -do spec.rules.mfoldl (λ (cfg : CommandParserConfig) r, match r.symbol with - | notationSymbol.View.quoted {symbol := some a, prec := prec, ..} := - pure {cfg with tokens := cfg.tokens.insert a.val.trim {«prefix» := a.val.trim, lbp := precToNat prec}} - | _ := throw "registerNotationTokens: unreachable") cfg - -def CommandParserConfig.registerNotationParser (k : SyntaxNodeKind) (nota : notation.View) - (cfg : CommandParserConfig) : Except String CommandParserConfig := -do -- build and register Parser - ps ← nota.spec.rules.mmap (λ r : rule.View, do - psym ← match r.symbol with - | notationSymbol.View.quoted {symbol := some a ..} := - pure (symbol a.val : termParser) - | _ := throw "registerNotationParser: unreachable", - ptrans ← match r.transition with - | some (transition.View.binder b) := - pure $ some $ Term.binderIdent.Parser - | some (transition.View.binders b) := - pure $ some $ Term.binders.Parser - | some (transition.View.Arg {action := none, ..}) := - pure $ some Term.Parser - | some (transition.View.Arg {action := some {kind := actionKind.View.prec prec}, ..}) := - pure $ some $ Term.Parser prec.toNat - | some (transition.View.Arg {action := some {kind := actionKind.View.scoped sc}, ..}) := - pure $ some $ Term.Parser $ precToNat sc.prec - | none := pure $ none - | _ := throw "registerNotationParser: unimplemented", - pure $ psym::ptrans.toMonad - ), - firstRule::_ ← pure nota.spec.rules | throw "registerNotationParser: unreachable", - firstTk ← match firstRule.symbol with - | notationSymbol.View.quoted {symbol := some a ..} := - pure a.val.trim - | _ := throw "registerNotationParser: unreachable", - let ps := ps.bind id, - cfg ← match nota.local, nota.spec.prefixArg with - | none, none := pure {cfg with leadingTermParsers := - cfg.leadingTermParsers.insert firstTk $ Parser.Combinators.node k ps} - | some _, none := pure {cfg with localLeadingTermParsers := - cfg.localLeadingTermParsers.insert firstTk $ Parser.Combinators.node k ps} - | none, some _ := pure {cfg with trailingTermParsers := - cfg.trailingTermParsers.insert firstTk $ Parser.Combinators.node k (getLeading::ps.map coe)} - | some _, some _ := pure {cfg with localTrailingTermParsers := - cfg.localTrailingTermParsers.insert firstTk $ Parser.Combinators.node k (getLeading::ps.map coe)}, - pure cfg - -/-- Recreate `ElaboratorState.parserCfg` from the Elaborator State and the initial config, - effectively treating it as a cache. -/ -def updateParserConfig : ElaboratorM Unit := -do st ← get, - sc ← currentScope, - cfg ← read, - let ccfg := cfg.initialParserCfg.toCommandParserConfig, - ccfg ← st.reservedNotations.mfoldl (λ ccfg rnota, - match CommandParserConfig.registerNotationTokens rnota.spec ccfg with - | Except.ok ccfg := pure ccfg - | Except.error e := error (review reserveNotation rnota) e) ccfg, - ccfg ← (st.notations ++ sc.notations).mfoldl (λ ccfg nota, - match CommandParserConfig.registerNotationTokens nota.nota.spec ccfg >>= - CommandParserConfig.registerNotationParser nota.kind nota.nota with - | Except.ok ccfg := pure ccfg - | Except.error e := error (review «notation» nota.nota) e) ccfg, - set {st with parserCfg := {cfg.initialParserCfg with toCommandParserConfig := ccfg}} - -def postprocessNotationSpec (spec : NotationSpec.View) : NotationSpec.View := --- default leading tokens to `max` --- NOTE: should happen after copying precedences from reserved notation -match spec with -| {prefixArg := none, rules := r@{symbol := notationSymbol.View.quoted sym@{prec := none, ..}, ..}::rs} := - {spec with rules := {r with symbol := notationSymbol.View.quoted {sym with prec := some - {Term := precedenceTerm.View.lit $ precedenceLit.View.num $ number.View.ofNat maxPrec} - }}::rs} -| _ := spec - -def reserveNotation.elaborate : Elaborator := -λ stx, do - let v := view reserveNotation stx, - let v := {v with spec := postprocessNotationSpec v.spec}, - -- TODO: sanity checks? - modify $ λ st, {st with reservedNotations := v::st.reservedNotations}, - updateParserConfig - -def matchPrecedence : Option precedence.View → Option precedence.View → Bool -| none (some rp) := true -| (some sp) (some rp) := sp.Term.toNat = rp.Term.toNat -| _ _ := false - -/-- Check if a notation is compatible with a reserved notation, and if so, copy missing - precedences in the notation from the reserved notation. -/ -def matchSpec (spec reserved : NotationSpec.View) : Option NotationSpec.View := -do guard $ spec.prefixArg.isSome = reserved.prefixArg.isSome, - rules ← (spec.rules.zip reserved.rules).mmap $ λ ⟨sr, rr⟩, do { - notationSymbol.View.quoted sq@{symbol := some sa, ..} ← pure sr.symbol - | failure, - notationSymbol.View.quoted rq@{symbol := some ra, ..} ← pure rr.symbol - | failure, - guard $ sa.val.trim = ra.val.trim, - guard $ matchPrecedence sq.prec rq.prec, - st ← match sr.transition, rr.transition with - | some (transition.View.binder sb), some (transition.View.binder rb) := - guard (matchPrecedence sb.prec rb.prec) *> pure rr.transition - | some (transition.View.binders sb), some (transition.View.binders rb) := - guard (matchPrecedence sb.prec rb.prec) *> pure rr.transition - | some (transition.View.Arg sarg), some (transition.View.Arg rarg) := do - sact ← match action.View.kind <$> sarg.action, action.View.kind <$> rarg.action with - | some (actionKind.View.prec sp), some (actionKind.View.prec rp) := - guard (sp.toNat = rp.toNat) *> pure sarg.action - | none, some (actionKind.View.prec rp) := - pure rarg.action - | _, _ := failure, - pure $ some $ transition.View.Arg {sarg with action := sact} - | none, none := pure none - | _, _ := failure, - pure $ {rule.View . - symbol := notationSymbol.View.quoted rq, - transition := st} - }, - pure $ {spec with rules := rules} - -def notation.elaborateAux : notation.View → ElaboratorM notation.View := -λ nota, do - st ← get, - -- check reserved notations - matched ← pure $ st.reservedNotations.filterMap $ - λ rnota, matchSpec nota.spec rnota.spec, - nota ← match matched with - | [matched] := pure {nota with spec := matched} - | [] := pure nota - | _ := error (review «notation» nota) "invalid notation, matches multiple reserved notations", - -- TODO: sanity checks - pure {nota with spec := postprocessNotationSpec nota.spec} - --- TODO(Sebastian): better kind names, Module prefix? -def mkNotationKind : ElaboratorM SyntaxNodeKind := -do st ← get, - set {st with notationCounter := st.notationCounter + 1}, - pure {name := (`_notation).mkNumeral st.notationCounter} - -/-- Register a notation in the Expander. Unlike with notation parsers, there is no harm in - keeping local notation macros registered after closing a section. -/ -def registerNotationMacro (nota : notation.View) : ElaboratorM NotationMacro := -do k ← mkNotationKind, - let m : NotationMacro := ⟨k, nota⟩, - let transf := mkNotationTransformer m, - modify $ λ st, {st with expanderCfg := {st.expanderCfg with transformers := st.expanderCfg.transformers.insert k.name transf}}, - pure m - -def notation.elaborate : Elaborator := -λ stx, do - let nota := view «notation» stx, - -- HACK: ignore List Literal notation using :fold - let usesFold := nota.spec.rules.any $ λ r, match r.transition with - | some (transition.View.Arg {action := some {kind := actionKind.View.fold _, ..}, ..}) := true - | _ := false, - if usesFold then do { - cfg ← read, - modify $ λ st, {st with messages := st.messages.add {filename := cfg.filename, pos := ⟨1,0⟩, - severity := MessageSeverity.warning, text := "ignoring notation using 'fold' action"}} - } else do { - nota ← notation.elaborateAux nota, - m ← registerNotationMacro nota, - match nota.local with - | some _ := modifyCurrentScope $ λ sc, {sc with notations := m::sc.notations} - | none := modify $ λ st, {st with notations := m::st.notations}, - updateParserConfig - } - -def universe.elaborate : Elaborator := -λ stx, do - let univ := view «universe» stx, - let id := mangleIdent univ.id, - sc ← currentScope, - match sc.univs.find id with - | none := modifyCurrentScope $ λ sc, {sc with univs := sc.univs.insert id (Level.Param id)} - | some _ := error stx $ "a universe named '" ++ toString id ++ "' has already been declared in this Scope" - -def attribute.elaborate : Elaborator := -λ stx, do - let attr := view «attribute» stx, - let mdata := MData.empty.setName `command `attribute, - let mdata := mdata.setBool `local $ attr.local.isSome, - attrs ← attrsToPexpr attr.attrs, - ids ← attr.ids.mmap (λ id, match id.preresolved with - | [] := error (Syntax.ident id) $ "unknown identifier '" ++ toString id.val ++ "'" - | [c] := pure $ Expr.const c [] - | _ := error (Syntax.ident id) "invalid 'attribute' command, identifier is ambiguous"), - let ids := Expr.mkCapp `_ ids, - oldElabCommand stx $ Expr.mdata mdata $ Expr.app attrs ids - -def check.elaborate : Elaborator := -λ stx, do - let v := view check stx, - let mdata := MData.empty.setName `command `#check, - e ← toPexpr v.Term, - oldElabCommand stx $ Expr.mdata mdata e - -def open.elaborate : Elaborator := -λ stx, do - let v := view «open» stx, - -- TODO: do eager sanity checks (namespace does not exist, etc.) - modifyCurrentScope $ λ sc, {sc with openDecls := sc.openDecls ++ v.spec} - -def export.elaborate : Elaborator := -λ stx, do - let v := view «export» stx, - ns ← getNamespace, - -- TODO: do eager sanity checks (namespace does not exist, etc.) - modify $ λ st, {st with exportDecls := st.exportDecls ++ v.spec.map (λ spec, ⟨ns, spec⟩)} - -def initQuot.elaborate : Elaborator := -λ stx, oldElabCommand stx $ Expr.mdata (MData.empty.setName `command `initQuot) dummy - -def setOption.elaborate : Elaborator := -λ stx, do - let v := view «setOption» stx, - let opt := v.opt.val, - sc ← currentScope, - let opts := sc.Options, - -- TODO(Sebastian): check registered Options - let opts := match v.val with - | optionValue.View.Bool b := opts.setBool opt (match b with boolOptionValue.View.True _ := true | _ := false) - | optionValue.View.String lit := match lit.value with - | some s := opts.setString opt s - | none := opts -- Parser already failed - | optionValue.View.num lit := opts.setNat opt lit.toNat, - modifyCurrentScope $ λ sc, {sc with Options := opts} - -/-- List of commands: recursively elaborate each command. -/ -def noKind.elaborate : Elaborator := λ stx, do - some n ← pure stx.asNode - | error stx "noKind.elaborate: unreachable", - n.args.mfor command.elaborate - -def end.elaborate : Elaborator := -λ cmd, do - let v := view «end» cmd, - st ← get, - -- NOTE: bottom-most (Module) Scope cannot be closed - sc::sc'::scps ← pure st.scopes - | error cmd "invalid 'end', there is no open Scope to end", - let endName := mangleIdent $ v.Name.getOrElse Name.anonymous, - when (endName ≠ sc.header) $ - error cmd $ "invalid end of " ++ sc.cmd ++ ", expected Name '" ++ - toString sc.header ++ "'", - set {st with scopes := sc'::scps}, - -- local notations may have vanished - updateParserConfig - -def section.elaborate : Elaborator := -λ cmd, do - let sec := view «section» cmd, - let header := mangleIdent $ sec.Name.getOrElse Name.anonymous, - sc ← currentScope, - modify $ λ st, {st with scopes := {sc with cmd := "section", header := header}::st.scopes} - -def namespace.elaborate : Elaborator := -λ cmd, do - let v := view «namespace» cmd, - let header := mangleIdent v.Name, - sc ← currentScope, - ns ← getNamespace, - let sc' := {sc with cmd := "namespace", header := header, nsStack := (ns ++ header)::sc.nsStack}, - modify $ λ st, {st with scopes := sc'::st.scopes} - -def eoi.elaborate : Elaborator := -λ cmd, do - st ← get, - when (st.scopes.length > 1) $ - error cmd "invalid end of input, expected 'end'" - --- TODO(Sebastian): replace with attribute -def elaborators : RBMap Name Elaborator Name.quickLt := RBMap.fromList [ - (Module.header.name, Module.header.elaborate), - (notation.name, notation.elaborate), - (reserveNotation.name, reserveNotation.elaborate), - (universe.name, universe.elaborate), - (noKind.name, noKind.elaborate), - (end.name, end.elaborate), - (section.name, section.elaborate), - (namespace.name, namespace.elaborate), - (variables.name, variables.elaborate), - (include.name, include.elaborate), - --(omit.name, omit.elaborate), - (declaration.name, declaration.elaborate), - (attribute.name, attribute.elaborate), - (open.name, open.elaborate), - (export.name, export.elaborate), - (check.name, check.elaborate), - (initQuot.name, initQuot.elaborate), - (setOption.name, setOption.elaborate), - (Module.eoi.name, eoi.elaborate) -] _ - --- TODO: optimize -def isOpenNamespace (sc : Scope) : Name → Bool -| Name.anonymous := true -| ns := - -- check surrounding namespaces - ns ∈ sc.nsStack ∨ - -- check opened namespaces - sc.openDecls.any (λ od, od.id.val = ns) ∨ - -- TODO: check active exports - false - --- TODO: `hiding`, `as`, `renaming` -def matchOpenSpec (n : Name) (spec : openSpec.View) : Option Name := -let matchesOnly := match spec.only with -| none := true -| some only := n = only.id.val ∨ only.ids.any (λ id, n = id.val) in -if matchesOnly then some (spec.id.val ++ n) else none - -def resolveContext : Name → ElaboratorM (List Name) -| n := do - st ← get, - sc ← currentScope, pure $ - - -- TODO(Sebastian): check the interaction betwen preresolution and section variables - match sc.vars.find n with - | some (_, v) := [v.uniqName] - | _ := - - -- global resolution - - -- check surrounding namespaces first - -- TODO: check for `protected` - match sc.nsStack.filter (λ ns, st.env.contains (ns ++ n)) with - | ns::_ := [ns ++ n] -- prefer innermost namespace - | _ := - - -- check environment directly - (let unrooted := n.replacePrefix `_root_ Name.anonymous in - match st.env.contains unrooted with - | true := [unrooted] - | _ := []) - ++ - -- check opened namespaces - (let ns' := sc.openDecls.filterMap (matchOpenSpec n) in - ns'.filter (λ n', st.env.contains n')) - ++ - -- check active exports - -- TODO: optimize - -- TODO: Lean 3 activates an export in `foo` even on `open foo (specificThing)`, but does that make sense? - (let eds' := st.exportDecls.filter (λ ed, isOpenNamespace sc ed.inNs) in - let ns' := eds'.filterMap (λ ed, matchOpenSpec n ed.spec) in - ns'.filter (λ n', st.env.contains n')) - - -- TODO: projection notation - -partial def preresolve : Syntax → ElaboratorM Syntax -| (Syntax.ident id) := do - let n := mangleIdent id, - ns ← resolveContext n, - pure $ Syntax.ident {id with preresolved := ns ++ id.preresolved} -| (Syntax.rawNode n) := do - args ← n.args.mmap preresolve, - pure $ Syntax.rawNode {n with args := args} -| stx := pure stx - -def mkState (cfg : ElaboratorConfig) (env : Environment) (opts : Options) : ElaboratorState := { - parserCfg := cfg.initialParserCfg, - expanderCfg := {transformers := Expander.builtinTransformers, ..cfg}, - env := env, - ngen := ⟨`_ngen.fixme, 0⟩, - scopes := [{cmd := "MODULE", header := `MODULE, Options := opts}]} - -def processCommand (cfg : ElaboratorConfig) (st : ElaboratorState) (cmd : Syntax) : ElaboratorState := -let st := {st with messages := MessageLog.empty} in -let r := @ExceptT.run _ Id _ $ flip StateT.run st $ flip ReaderT.run cfg $ RecT.run - (command.elaborate cmd) - (λ _, error cmd "Elaborator.run: recursion depth exceeded") - (λ cmd, do - some n ← pure cmd.asNode | - error cmd $ "not a command: " ++ toString cmd, - some elab ← pure $ elaborators.find n.kind.name | - error cmd $ "unknown command: " ++ toString n.kind.name, - cmd' ← preresolve cmd, - elab cmd') in -match r with -| Except.ok ((), st) := st -| Except.error e := {st with messages := st.messages.add e} - -end Elaborator -end Lean diff --git a/tmp/new-frontend/expander.lean b/tmp/new-frontend/expander.lean deleted file mode 100644 index 9faab85927..0000000000 --- a/tmp/new-frontend/expander.lean +++ /dev/null @@ -1,544 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -Macro Expander for the Lean language, using a variant of the [sets of scopes](http://www.cs.utah.edu/plt/Scope-sets/) hygiene algorithm. - -TODO(Sebastian): document/link to documentation of algorithm - --/ -prelude -import init.lean.parser.module -import init.lean.expr - -namespace Lean -namespace Expander -open Parser -open Parser.Combinators -open Parser.Term -open Parser.command - -structure TransformerConfig extends FrontendConfig --- TODO(Sebastian): the recursion point for `localExpand` probably needs to be stored here - -instance transformerConfigCoeFrontendConfig : HasCoe TransformerConfig FrontendConfig := -⟨TransformerConfig.toFrontendConfig⟩ - --- TODO(Sebastian): recursive expansion -@[derive Monad MonadReader MonadExcept] -def TransformM := ReaderT FrontendConfig $ ExceptT Message Id -abbrev transformer := Syntax → TransformM (Option Syntax) - -/-- We allow macros to refuse expansion. This means that nodes can decide whether to act as macros - or not depending on their contents, allowing them to unfold to some normal form without changing - the general Node kind and shape (and thus View Type). -/ -def noExpansion : TransformM (Option Syntax) := -pure none - -def error {m : Type → Type} {ρ : Type} [Monad m] [MonadReader ρ m] [HasLiftT ρ FrontendConfig] - [MonadExcept Message m] {α : Type} - (context : Option Syntax) (text : String) : m α := -do cfg ← read, - throw { - filename := FrontendConfig.filename ↑cfg, - pos := (FrontendConfig.fileMap ↑cfg).toPosition $ (context >>= Syntax.getPos).getOrElse (default _), - text := text - } - -/-- Coercion useful for introducing macro-local variables. Use `globId` to refer to global bindings instead. -/ -instance coeNameIdent : HasCoe Name SyntaxIdent := -⟨λ n, {val := n, rawVal := Substring.ofString n.toString}⟩ - -/-- Create an identifier preresolved against a global binding. Because we cannot use Syntax quotations yet, - which the Expander would have preresolved against the global context at macro declaration time, - we have to do the preresolution manually instead. -/ -def globId (n : Name) : Syntax := -review identUnivs { - id :={val := n, rawVal := Substring.ofString n.toString, preresolved := [n]}, -} - -instance coeIdentIdentUnivs : HasCoe SyntaxIdent identUnivs.View := -⟨λ id, {id := id}⟩ - -instance coeIdentBinderId : HasCoe SyntaxIdent binderIdent.View := -⟨binderIdent.View.id⟩ - -instance coeIdentsBindersExt {α : Type} [HasCoeT α binderIdent.View] : HasCoe (List α) Term.bindersExt.View := -⟨λ ids, {leadingIds := ids.map coe}⟩ - -instance coeBracketedBinderMixedBinder : HasCoe bracketedBinder.View mixedBinder.View := -⟨mixedBinder.View.bracketed⟩ - -instance coeMixedBindersBindersExt {α : Type} [HasCoeT α mixedBinder.View] : HasCoe (List α) Term.bindersExt.View := -⟨λ mbs, {leadingIds := [], remainder := some $ bindersRemainder.View.mixed $ mbs.map coe}⟩ - -instance coeBindersExtBinders : HasCoe Term.bindersExt.View Term.binders.View := -⟨Term.binders.View.extended⟩ - -instance coeSimpleBinderBinders : HasCoe Term.simpleBinder.View Term.binders.View := -⟨Term.binders.View.simple⟩ - -instance coeBinderBracketedBinder : HasCoe Term.binder.View Term.bracketedBinder.View := -⟨λ b, match b with - | binder.View.bracketed bb := bb - | binder.View.unbracketed bc := Term.bracketedBinder.View.explicit - {content := explicitBinderContent.View.other bc}⟩ - -section «notation» -open Parser.command.NotationSpec - -/-- A notation together with a unique Node kind. -/ -structure NotationMacro := -(kind : SyntaxNodeKind) -(nota : notation.View) - -/-- Helper State of the loop in `mkNotationTransformer`. -/ -structure NotationTransformerState := -(stx : Syntax) --- children of `stx` that have not been consumed yet -(stxArgs : List Syntax := []) --- substitutions for notation variables (reversed) -(substs : List (SyntaxIdent × Syntax) := []) --- filled by `binders` transitions, consumed by `scoped` actions -(scoped : Option $ Term.binders.View := none) - -private def popStxArg : StateT NotationTransformerState TransformM Syntax := -do st ← get, - match st.stxArgs with - | Arg::args := set {st with stxArgs := args} *> pure Arg - | _ := error st.stx "mkNotationTransformer: unreachable" - -def mkNotationTransformer (nota : NotationMacro) : transformer := -λ stx, do - some {args := stxArgs, ..} ← pure stx.asNode - | error stx "mkNotationTransformer: unreachable", - flip StateT.run' {NotationTransformerState . stx := stx, stxArgs := stxArgs} $ do - let spec := nota.nota.spec, - -- Walk through the notation specification, consuming `stx` args and building up substitutions - -- for the notation RHS. - -- Also see `CommandParserConfig.registerNotationParser` for the expected structure of `stx`. - match spec.prefixArg with - | none := pure () - | some Arg := do { stxArg ← popStxArg, modify $ λ st, {st with substs := (Arg, stxArg)::st.substs} }, - nota.nota.spec.rules.mfor (λ r : rule.View, do - match r.symbol with - | notationSymbol.View.quoted {symbol := some a ..} := popStxArg - | _ := error stx "mkNotationTransformer: unreachable", - match r.transition with - | some (transition.View.binder b) := - do { stxArg ← popStxArg, modify $ λ st, {st with scoped := some $ binders.View.extended {leadingIds := [view binderIdent.Parser stxArg]}} } - | some (transition.View.binders b) := - do { stxArg ← popStxArg, modify $ λ st, {st with scoped := some $ view Term.binders.Parser stxArg} } - | some (transition.View.Arg {action := none, id := id}) := - do { stxArg ← popStxArg, modify $ λ st, {st with substs := (id, stxArg)::st.substs} } - | some (transition.View.Arg {action := some {kind := actionKind.View.prec _}, id := id}) := - do { stxArg ← popStxArg, modify $ λ st, {st with substs := (id, stxArg)::st.substs} } - | some (transition.View.Arg {action := some {kind := actionKind.View.scoped sc}, id := id}) := do - stxArg ← popStxArg, - {scoped := some bnders, ..} ← get - | error stx "mkNotationTransformer: unreachable", - -- TODO(Sebastian): not correct with multiple binders - let scLam := review lambda {binders := [sc.id], body := sc.Term}, - let lam := review lambda {binders := bnders, body := stxArg}, - let Arg := review app {fn := scLam, Arg := lam}, - modify $ λ st, {st with substs := (id, Arg)::st.substs} - | none := pure () - | _ := error stx "mkNotationTransformer: unimplemented"), - st ← get, - -- apply substitutions - -- HACK: this substitution completely disregards binders on the notation's RHS. - -- We have discussed switching to a more explicit antiquotation Syntax like %%_ - -- that cannot be abstracted over. - let substs := st.substs.map (λ ⟨id, t⟩, (id.val, t)), - let t := nota.nota.Term.replace $ λ stx, match tryView identUnivs stx with - | some {id := id, univs := none} := pure $ substs.lookup id.val - | _ := pure none, - pure $ some $ t - -def mixfixToNotationSpec (k : mixfix.kind.View) (sym : notationSymbol.View) : TransformM NotationSpec.View := -let prec := match sym with -| notationSymbol.View.quoted q := q.prec -/-| _ := none -/ in --- `notation` allows more Syntax after `:` than mixfix commands, so we have to do a small conversion -let precToAction := λ prec, {action.View . kind := actionKind.View.prec prec} in -match k with -| mixfix.kind.View.prefix _ := - -- `prefix sym:prec` ~> `notation sym:prec b:prec` - pure { - rules := [{ - symbol := sym, - transition := transition.View.Arg {id := `b, - action := precToAction <$> precedence.View.Term <$> prec}}]} -| mixfix.kind.View.postfix _ := - -- `postfix tk:prec` ~> `notation a tk:prec` - pure { - prefixArg := `a, - rules := [{symbol := sym}]} -| mixfix.kind.View.infixr _ := do - -- `infixr tk:prec` ~> `notation a tk:prec b:(prec-1)` - act ← match prec with - | some prec := if prec.Term.toNat = 0 - then error (review «precedence» prec) "invalid `infixr` declaration, given precedence must greater than zero" - else pure $ some $ precToAction $ precedenceTerm.View.lit $ precedenceLit.View.num $ number.View.ofNat $ prec.Term.toNat - 1 - | none := pure none, - pure { - prefixArg := `a, - rules := [{ - symbol := sym, - transition := transition.View.Arg {id := `b, - action := act}}]} -| _ := - -- `infix/infixl tk:prec` ~> `notation a tk:prec b:prec` - pure { - prefixArg := `a, - rules := [{ - symbol := sym, - transition := transition.View.Arg {id := `b, - action := precToAction <$> precedence.View.Term <$> prec}}]} - -def mixfix.transform : transformer := -λ stx, do - let v := view mixfix stx, - let notaSym := match v.symbol with - | mixfixSymbol.View.quoted q := notationSymbol.View.quoted q - | mixfixSymbol.View.unquoted u := notationSymbol.View.quoted {symbol := u}, - spec ← mixfixToNotationSpec v.kind notaSym, - let Term := match v.kind with - | mixfix.kind.View.prefix _ := - -- `prefix tk:prec? := e` ~> `notation tk:prec? b:prec? := e b` - review app {fn := v.Term, Arg := review identUnivs `b} - | mixfix.kind.View.postfix _ := - -- `postfix tk:prec? := e` ~> `notation tk:prec? b:prec? := e b` - review app {fn := v.Term, Arg := review identUnivs `a} - | _ := - review app {fn := review app {fn := v.Term, Arg := review identUnivs `a}, Arg := review identUnivs `b}, - pure $ review «notation» {«local» := v.local, spec := spec, Term := Term} - -def reserveMixfix.transform : transformer := -λ stx, do - let v := view reserveMixfix stx, - spec ← mixfixToNotationSpec v.kind v.symbol, - pure $ review reserveNotation {spec := spec} - -end «notation» - -def mkSimpleBinder (id : SyntaxIdent) (bi : BinderInfo) (type : Syntax) : simpleBinder.View := -let bc : binderContent.View := {ids := [id], type := some {type := type}} in -match bi with -| BinderInfo.default := simpleBinder.View.explicit {id := id, type := type} -| BinderInfo.implicit := simpleBinder.View.implicit {id := id, type := type} -| BinderInfo.strictImplicit := simpleBinder.View.strictImplicit {id := id, type := type} -| BinderInfo.instImplicit := simpleBinder.View.instImplicit {id := id, type := type} -| BinderInfo.auxDecl := /- should not happen -/ - simpleBinder.View.explicit {id := id, type := type} - -def binderIdentToIdent : binderIdent.View → SyntaxIdent -| (binderIdent.View.id id) := id -| (binderIdent.View.hole _) := "a" - -def getOptType : Option typeSpec.View → Syntax -| none := review hole {} -| (some v) := v.type - -def expandBracketedBinder : bracketedBinder.View → TransformM (List simpleBinder.View) --- local notation: should have been handled by caller, erase -| (bracketedBinder.View.explicit {content := explicitBinderContent.View.notation _}) := pure [] -| mbb := do - (bi, bc) ← match mbb with - | bracketedBinder.View.explicit {content := bc} := pure (match bc with - | explicitBinderContent.View.other bc := (BinderInfo.default, bc) - | _ := (BinderInfo.default, {ids := []}) /- unreachable, see above -/) - | bracketedBinder.View.implicit {content := bc} := pure (BinderInfo.implicit, bc) - | bracketedBinder.View.strictImplicit {content := bc} := pure (BinderInfo.strictImplicit, bc) - | bracketedBinder.View.instImplicit {content := bc} := - pure $ Prod.mk BinderInfo.instImplicit $ match bc with - | instImplicitBinderContent.View.anonymous bca := - {ids := ["_inst_"], type := some {type := bca.type}} - | instImplicitBinderContent.View.named bcn := - {ids := [bcn.id], type := some {type := bcn.type}} - | bracketedBinder.View.anonymousConstructor ctor := - error (review anonymousConstructor ctor) "unexpected anonymous Constructor", - let type := getOptType bc.type, - type ← match bc.default with - | none := pure type - | some (binderDefault.View.val bdv) := pure $ mkApp (globId `optParam) [type, bdv.Term] - | some bdv@(binderDefault.View.tac bdt) := match bc.type with - | none := pure $ mkApp (globId `autoParam) [bdt.Term] - | some _ := error (review binderDefault bdv) "unexpected auto Param after Type annotation", - pure $ bc.ids.map (λ bid, mkSimpleBinder (binderIdentToIdent bid) bi type) - -/-- Unfold `binders.View.extended` into `binders.View.simple`. -/ -def expandBinders (mkBinding : binders.View → Syntax → Syntax) (bnders : binders.View) - (body : Syntax) : TransformM (Option Syntax) := do - binders.View.extended extBinders ← pure bnders - | noExpansion, - -- build Result `r` bottom-up - let r := body, - r ← match extBinders.remainder with - | bindersRemainder.View.mixed brms := brms.mfoldr (λ brm r, match brm with - -- anonymous Constructor binding ~> binding + match - | mixedBinder.View.bracketed (bracketedBinder.View.anonymousConstructor ctor) := - pure $ mkBinding (mkSimpleBinder "x" BinderInfo.default (review hole {})) $ review «match» { - scrutinees := [review identUnivs ↑"x"], - equations := [{item := {lhs := [review anonymousConstructor ctor], rhs := r}}] - } - -- local notation: should have been handled by caller, erase - | mixedBinder.View.bracketed mbb := do - bnders ← expandBracketedBinder mbb, - pure $ bnders.foldr (λ bnder, mkBinding bnder) r - | mixedBinder.View.id bid := pure $ - mkBinding (mkSimpleBinder (binderIdentToIdent bid) BinderInfo.default (review hole {})) r - ) r - | _ := pure r, - let leadingTy := match extBinders.remainder with - | bindersRemainder.View.type brt := brt.type - | _ := review hole {}, - let r := extBinders.leadingIds.foldr (λ bid r, - mkBinding (mkSimpleBinder (binderIdentToIdent bid) BinderInfo.default leadingTy) r) r, - pure r - -def bracketedBinders.transform : transformer := -λ stx, do - let v := view bracketedBinders stx, - match v with - | bracketedBinders.View.simple _ := noExpansion - | bracketedBinders.View.extended bnders := do - bnders ← bnders.mmap expandBracketedBinder, - pure $ review bracketedBinders $ bracketedBinders.View.simple $ List.join bnders - -def lambda.transform : transformer := -λ stx, do - let v := view lambda stx, - expandBinders (λ binders body, review lambda {binders := binders, body := body}) v.binders v.body - -def pi.transform : transformer := -λ stx, do - let v := view pi stx, - expandBinders (λ binders body, review pi {op := v.op, binders := binders, range := body}) v.binders v.range - -def depArrow.transform : transformer := -λ stx, do - let v := view depArrow stx, - pure $ review pi { - op := Syntax.atom {val := "Π"}, - binders := binders.View.extended [v.binder], - range := v.range} - -def arrow.transform : transformer := -λ stx, do - let v := view arrow stx, - pure $ review pi { - op := Syntax.atom {val := "Π"}, - binders := binders.View.simple $ simpleBinder.View.explicit {id := `a, type := v.dom}, - range := v.range} - -def paren.transform : transformer := -λ stx, do - let v := view paren stx, - match v.content with - | none := pure $ globId `Unit.unit - | some {Term := t, special := none} := pure t - | some {Term := t, special := parenSpecial.View.tuple tup} := - pure $ (t::tup.tail.map SepBy.Elem.View.item).foldr1Opt (λ t tup, mkApp (globId `Prod.mk) [t, tup]) - | some {Term := t, special := parenSpecial.View.typed pst} := - pure $ mkApp (globId `typedExpr) [pst.type, t] - -def assume.transform : transformer := -λ stx, do - let v := view «assume» stx, - let binders : binders.View := match v.binders with - | assumeBinders.View.anonymous aba := binders.View.simple $ - -- TODO(Sebastian): unhygienic! - simpleBinder.View.explicit {id := "this", type := aba.type} - | assumeBinders.View.binders abb := abb, - pure $ review lambda {binders := binders, body := v.body} - -def if.transform : transformer := -λ stx, do - let v := view «if» stx, - pure $ match v.id with - | some id := mkApp (globId `dite) [v.prop, - review lambda {binders := binders.View.simple $ simpleBinder.View.explicit {id := id.id, type := v.prop}, body := v.thenBranch}, - review lambda {binders := binders.View.simple $ simpleBinder.View.explicit {id := id.id, type := mkApp (globId `Not) [v.prop]}, body := v.elseBranch}] - | none := mkApp (globId `ite) [v.prop, v.thenBranch, v.elseBranch] - -def let.transform : transformer := -λ stx, do - let v := view «let» stx, - match v.lhs with - | letLhs.View.id {id := _, binders := [], type := some _} := noExpansion - | letLhs.View.id lli@{id := _, binders := [], type := none} := - pure $ review «let» {v with lhs := letLhs.View.id {lli with type := some {type := review hole {}}}} - | letLhs.View.id lli@{id := _, binders := _, type := ty} := - let bindrs := binders.View.extended lli.binders in - pure $ review «let» {v with - lhs := letLhs.View.id { - id := lli.id, - binders := [], - type := some {type := review pi {op := Syntax.atom {val := "Π"}, binders := bindrs, range := getOptType ty}}}, - value := review lambda {binders := bindrs, body := v.value}} - | letLhs.View.pattern llp := - pure $ review «match» { - scrutinees := [v.value], - equations := [{item := {lhs := [llp], rhs := v.body}}]} - --- move parameters into Type -def axiom.transform : transformer := -λ stx, do - let v := view «axiom» stx, - match v with - | {sig := {params := bracketedBinders.View.extended bindrs, type := type}, ..} := do - let bindrs := binders.View.extended bindrs, - pure $ review «axiom» {v with sig := { - params := bracketedBinders.View.simple [], - type := {type := review pi {op := Syntax.atom {val := "Π"}, binders := bindrs, range := type.type}}}} - | _ := noExpansion - -def declaration.transform : transformer := -λ stx, do - let v := view «declaration» stx, - match v.inner with - | declaration.inner.View.inductive ind@{«class» := some _, ..} := - let attrs := v.modifiers.attrs.getOrElse {attrs := []} in - pure $ review «declaration» {v with - modifiers := {v.modifiers with attrs := some {attrs with attrs := - {item := {Name := "class", args := []}} :: attrs.attrs}}, - inner := declaration.inner.View.inductive {ind with «class» := none} - } - | declaration.inner.View.structure s@{keyword := structureKw.View.class _, ..} := - let attrs := v.modifiers.attrs.getOrElse {attrs := []} in - pure $ review «declaration» {v with - modifiers := {v.modifiers with attrs := some {attrs with attrs := - {item := {Name := "class", args := []}} :: attrs.attrs}}, - inner := declaration.inner.View.structure {s with keyword := structureKw.View.structure} - } - | _ := noExpansion - -def introRule.transform : transformer := -λ stx, do - let v := view «introRule» stx, - match v.sig with - | {params := bracketedBinders.View.extended bindrs, type := some type} := do - let bindrs := binders.View.extended bindrs, - pure $ review «introRule» {v with sig := { - params := bracketedBinders.View.simple [], - type := some {type := review pi {op := Syntax.atom {val := "Π"}, binders := bindrs, - range := type.type}}}} - | _ := noExpansion - -/- We expand `variable` into `variables` instead of the other way around since, in theory, - elaborating multiple variables at the same time makes it possible to omit more information. -/ -def variable.transform : transformer := -λ stx, do - let v := view «variable» stx, - pure $ review «variables» {binders := bracketedBinders.View.extended [v.binder]} - -@[derive HasView] -def bindingAnnotationUpdate.Parser : termParser := -node! bindingAnnotationUpdate ["dummy"] -- FIXME: bad node! expansion - -def variables.transform : transformer := -λ stx, do - let v := view «variables» stx, - match v.binders with - | bracketedBinders.View.simple _ := noExpansion - | bracketedBinders.View.extended bnders := do - bnders ← bnders.mmap $ λ b, match b with - -- binding annotation update - | bracketedBinder.View.explicit eb@{content := - explicitBinderContent.View.other bc@{ids := ids, type := none, default := none}} := - expandBracketedBinder $ bracketedBinder.View.explicit {eb with content := - explicitBinderContent.View.other {bc with type := some {type := review bindingAnnotationUpdate {}}}} - | _ := expandBracketedBinder b, - pure $ review «variables» {binders := bracketedBinders.View.simple $ List.join bnders} - -def Level.leading.transform : transformer := -λ stx, do - let v := view Level.leading stx, - match v with - | Level.leading.View.paren p := pure p.inner - | _ := noExpansion - -def Subtype.transform : transformer := -λ stx, do - let v := view Term.Subtype stx, - pure $ mkApp (globId `Subtype) [review lambda { - binders := mkSimpleBinder v.id BinderInfo.default $ getOptType v.type, - body := v.prop - }] - -def universes.transform : transformer := -λ stx, do - let v := view «universes» stx, - pure $ Syntax.list $ v.ids.map (λ id, review «universe» {id := id}) - -def sorry.transform : transformer := -λ stx, pure $ mkApp (globId `sorryAx) [review hole {}, globId `Bool.false] - --- TODO(Sebastian): replace with attribute -def builtinTransformers : RBMap Name transformer Name.quickLt := RBMap.fromList [ - (mixfix.name, mixfix.transform), - (reserveMixfix.name, reserveMixfix.transform), - (bracketedBinders.name, bracketedBinders.transform), - (lambda.name, lambda.transform), - (pi.name, pi.transform), - (depArrow.name, depArrow.transform), - (arrow.name, arrow.transform), - (paren.name, paren.transform), - (assume.name, assume.transform), - (if.name, if.transform), - (let.name, let.transform), - (axiom.name, axiom.transform), - (declaration.name, declaration.transform), - (introRule.name, introRule.transform), - (variable.name, variable.transform), - (variables.name, variables.transform), - (Level.leading.name, Level.leading.transform), - (Term.Subtype.name, Subtype.transform), - (universes.name, universes.transform), - (sorry.name, sorry.transform) -] _ - -structure ExpanderState := -(nextScope : MacroScope) - -structure ExpanderConfig extends TransformerConfig := -(transformers : RBMap Name transformer Name.quickLt) - -instance ExpanderConfig.HasLift : HasLift ExpanderConfig TransformerConfig := -⟨ExpanderConfig.toTransformerConfig⟩ - -@[reducible] def ExpanderM := StateT ExpanderState $ ReaderT ExpanderConfig $ ExceptT Message Id - -section -local attribute [reducible] MacroScope -def ExpanderState.new : ExpanderState := ⟨0⟩ -def mkScope : ExpanderM MacroScope := -do st ← get, - set {st with nextScope := st.nextScope + 1}, - pure st.nextScope -end - -private def expandCore : Nat → Syntax → ExpanderM Syntax -| 0 stx := error stx "macro expansion limit exceeded" -| (fuel + 1) stx := -do some n ← pure stx.asNode | pure stx, - cfg ← read, - some t ← pure $ cfg.transformers.find n.kind.name - -- not a macro: recurse - | Syntax.mkNode n.kind <$> n.args.mmap (expandCore fuel), - sc ← mkScope, - let n' := Syntax.mkNode n.kind $ n.args.map (Syntax.flipScopes [sc]), - some stx' ← StateT.lift $ λ cfg, t n' ↑cfg - -- no unfolding: recurse - | Syntax.mkNode n.kind <$> n.args.mmap (expandCore fuel), - -- flip again, expand iteratively - expandCore fuel $ stx'.flipScopes [sc] - -def expand (stx : Syntax) : ReaderT ExpanderConfig (Except Message) Syntax := --- TODO(Sebastian): persist macro scopes across commands/files -Prod.fst <$> expandCore 1000 stx ExpanderState.new - -end Expander -end Lean diff --git a/tmp/new-frontend/frontend.lean b/tmp/new-frontend/frontend.lean deleted file mode 100644 index 5147e49261..0000000000 --- a/tmp/new-frontend/frontend.lean +++ /dev/null @@ -1,91 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich --/ - -import init.lean.parser.module init.lean.expander init.lean.elaborator init.lean.util init.io - -namespace Lean -open Lean.Parser -open Lean.Expander -open Lean.Elaborator - -def mkConfig (filename := "") (input := "") : Except String ModuleParserConfig := -do t ← Parser.mkTokenTrie $ - Parser.tokens Module.header.Parser ++ - Parser.tokens command.builtinCommandParsers ++ - Parser.tokens Term.builtinLeadingParsers ++ - Parser.tokens Term.builtinTrailingParsers, - pure $ { - filename := filename, input := input, tokens := t, - fileMap := FileMap.fromString input, - commandParsers := command.builtinCommandParsers, - leadingTermParsers := Term.builtinLeadingParsers, - trailingTermParsers := Term.builtinTrailingParsers, - } - -def runFrontend (filename input : String) (printMsg : Message → IO Unit) (collectOutputs : Bool) : - StateT Environment IO (List Syntax) := λ env, do - parserCfg ← ioOfExcept $ mkConfig filename input, - -- TODO(Sebastian): `parseHeader` should be called directly by Lean.cpp - match parseHeader parserCfg with - | (_, Except.error msg) := printMsg msg *> pure ([], env) - | (_, Except.ok (pSnap, msgs)) := do - msgs.toList.mfor printMsg, - let expanderCfg : ExpanderConfig := {transformers := builtinTransformers, ..parserCfg}, - let elabCfg : ElaboratorConfig := {filename := filename, input := input, initialParserCfg := parserCfg, ..parserCfg}, - let opts := Options.empty.setBool `trace.as_messages true, - let elabSt := Elaborator.mkState elabCfg env opts, - let addOutput (out : Syntax) outs := if collectOutputs then out::outs else [], - IO.Prim.iterate (pSnap, elabSt, parserCfg, expanderCfg, ([] : List Syntax)) $ λ ⟨pSnap, elabSt, parserCfg, expanderCfg, outs⟩, do { - let pos := parserCfg.fileMap.toPosition pSnap.it.offset, - r ← monadLift $ profileitPure "parsing" pos $ λ _, parseCommand parserCfg pSnap, - match r with - | (cmd, Except.error msg) := do { - -- fatal error (should never happen?) - printMsg msg, - msgs.toList.mfor printMsg, - pure $ Sum.inr ((addOutput cmd outs).reverse, elabSt.env) - } - | (cmd, Except.ok (pSnap, msgs)) := do { - msgs.toList.mfor printMsg, - r ← monadLift $ profileitPure "expanding" pos $ λ _, (expand cmd).run expanderCfg, - match r with - | Except.ok cmd' := do { - --IO.println cmd', - elabSt ← monadLift $ profileitPure "elaborating" pos $ λ _, Elaborator.processCommand elabCfg elabSt cmd', - elabSt.messages.toList.mfor printMsg, - if cmd'.isOfKind Module.eoi then - /-printMsg {filename := filename, severity := MessageSeverity.information, - pos := ⟨1, 0⟩, - text := "Parser cache hit rate: " ++ toString out.cache.hit ++ "/" ++ - toString (out.cache.hit + out.cache.miss)},-/ - pure $ Sum.inr ((addOutput cmd outs).reverse, elabSt.env) - else - pure (Sum.inl (pSnap, elabSt, elabSt.parserCfg, elabSt.expanderCfg, addOutput cmd outs)) - } - | Except.error e := printMsg e *> pure (Sum.inl (pSnap, elabSt, parserCfg, expanderCfg, addOutput cmd outs)) - } - } - -@[export lean_process_file] -def processFile (f s : String) (json : Bool) : StateT Environment IO Unit := do - let printMsg : Message → IO Unit := λ msg, - if json then - IO.println $ "{\"file_name\": \"\", \"pos_line\": " ++ toString msg.pos.line ++ - ", \"pos_col\": " ++ toString msg.pos.column ++ - ", \"severity\": " ++ repr (match msg.severity with - | MessageSeverity.information := "information" - | MessageSeverity.warning := "warning" - | MessageSeverity.error := "error") ++ - ", \"caption\": " ++ repr msg.caption ++ - ", \"text\": " ++ repr msg.text ++ "}" - else IO.println msg.toString, - -- print and erase uncaught exceptions - catch - (runFrontend f s printMsg false *> pure ()) - (λ e, do - monadLift (printMsg {filename := f, severity := MessageSeverity.error, pos := ⟨1, 0⟩, text := e}), - throw e) -end Lean diff --git a/tmp/new-frontend/parser/basic.lean b/tmp/new-frontend/parser/basic.lean deleted file mode 100644 index f6c7f0d7cb..0000000000 --- a/tmp/new-frontend/parser/basic.lean +++ /dev/null @@ -1,226 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -Parser for the Lean language --/ -prelude -import init.lean.parser.parsec init.lean.parser.syntax init.lean.parser.rec -import init.lean.parser.trie -import init.lean.parser.identifier init.data.rbmap init.lean.message - -namespace Lean -namespace Parser - -/- Maximum standard precedence. This is the precedence of Function application. - In the standard Lean language, only the token `.` has a left-binding power greater - than `maxPrec` (so that field accesses like `g (h x).f` are parsed as `g ((h x).f)`, - not `(g (h x)).f`). -/ -def maxPrec : Nat := 1024 - -structure TokenConfig := -(«prefix» : String) -/- Left-binding power used by the Term Parser. The Term Parser operates in the context - of a right-binding power between 0 (used by parentheses and on the top-Level) and - (usually) `maxPrec` (used by Function application). After parsing an initial Term, - it continues parsing and expanding that Term only when the left-binding power of - the next token is greater than the current right-binding power. For example, it - never continues parsing an argument after the initial parse, unless a token with - lbp > maxPrec is encountered. Conversely, the Term Parser will always continue - parsing inside parentheses until it finds a token with lbp 0 (such as `)`). -/ -(lbp : Nat := 0) --- reading a token should not need any State -/- An optional Parser that is activated after matching `prefix`. - It should return a Syntax tree with a "hole" for the - `SourceInfo` surrounding the token, which will be supplied - by the `token` Parser. - - Remark: `suffixParser` has many applications for example for parsing - hexdecimal numbers, `prefix` is `0x` and `suffixParser` is the Parser `digit*`. - We also use it to parse String literals: here `prefix` is just `"`. --/ -(suffixParser : Option (Parsec' (SourceInfo → Syntax)) := none) - --- Backtrackable State -structure ParserState := -(messages : MessageLog) - -structure TokenCacheEntry := -(startIt stopIt : String.OldIterator) -(tk : Syntax) - --- Non-backtrackable State -structure ParserCache := -(tokenCache : Option TokenCacheEntry := none) --- for profiling -(hit miss : Nat := 0) - -structure FrontendConfig := -(filename : String) -(input : String) -(fileMap : FileMap) - -/- Remark: if we have a Node in the Trie with `some TokenConfig`, the String induced by the path is equal to the `TokenConfig.prefix`. -/ -structure ParserConfig extends FrontendConfig := -(tokens : Trie TokenConfig) - -instance parserConfigCoe : HasCoe ParserConfig FrontendConfig := -⟨ParserConfig.toFrontendConfig⟩ - -@[derive Monad Alternative MonadParsec MonadExcept] -def parserCoreT (m : Type → Type) [Monad m] := -ParsecT Syntax $ StateT ParserCache $ m - -@[derive Monad Alternative MonadReader MonadParsec MonadExcept] -def ParserT (ρ : Type) (m : Type → Type) [Monad m] := ReaderT ρ $ parserCoreT m -@[derive Monad Alternative MonadReader MonadParsec MonadExcept] -def BasicParserM := ParserT ParserConfig Id -abbrev basicParser := BasicParserM Syntax -abbrev monadBasicParser := HasMonadLiftT BasicParserM - -section -local attribute [reducible] BasicParserM ParserT parserCoreT -@[inline] def getCache : BasicParserM ParserCache := -monadLift (get : StateT ParserCache Id _) - -@[inline] def putCache : ParserCache → BasicParserM PUnit := -λ c, monadLift (set c : StateT ParserCache Id _) -end - - -- an arbitrary `Parser` Type; parsers are usually some Monad stack based on `BasicParserM` returning `Syntax` -variable {ρ : Type} - -class HasTokens (r : ρ) := mk {} :: -(tokens : List TokenConfig) - -@[noinline, nospecialize] def tokens (r : ρ) [HasTokens r] := -HasTokens.tokens r - -instance HasTokens.Inhabited (r : ρ) : Inhabited (HasTokens r) := -⟨⟨[]⟩⟩ - -instance List.nil.tokens : Parser.HasTokens ([] : List ρ) := -default _ - -instance List.cons.tokens (r : ρ) (rs : List ρ) [Parser.HasTokens r] [Parser.HasTokens rs] : - Parser.HasTokens (r::rs) := -⟨tokens r ++ tokens rs⟩ - -class HasView (α : outParam Type) (r : ρ) := -(view : Syntax → α) -(review : α → Syntax) - -export HasView (view review) - -def tryView {α : Type} (k : SyntaxNodeKind) [HasView α k] (stx : Syntax) : Option α := -if stx.isOfKind k then some (HasView.view k stx) else none - -instance HasView.default (r : ρ) : Inhabited (Parser.HasView Syntax r) := -⟨{ view := id, review := id }⟩ - -class HasViewDefault (r : ρ) (α : outParam Type) [HasView α r] (default : α) := mk {} - -def messageOfParsecMessage {μ : Type} (cfg : FrontendConfig) (msg : Parsec.Message μ) : Message := -{filename := cfg.filename, pos := cfg.fileMap.toPosition msg.it.offset, text := msg.text} - -/-- Run Parser stack, returning a partial Syntax tree in case of a fatal error -/ -protected def run {m : Type → Type} {α ρ : Type} [Monad m] [HasCoeT ρ FrontendConfig] (cfg : ρ) (s : String) (r : StateT ParserState (ParserT ρ m) α) : -m (Sum α Syntax × MessageLog) := -do (r, _) ← (((r.run {messages:=MessageLog.empty}).run cfg).parse s).run {}, -pure $ match r with -| Except.ok (a, st) := (Sum.inl a, st.messages) -| Except.error msg := (Sum.inr msg.custom.get, MessageLog.empty.add (messageOfParsecMessage cfg msg)) - -open MonadParsec -open Parser.HasView -variables {α : Type} {m : Type → Type} -local notation `Parser` := m Syntax - -def logMessage {μ : Type} [Monad m] [MonadReader ρ m] [HasLiftT ρ FrontendConfig] [MonadState ParserState m] - (msg : Parsec.Message μ) : m Unit := -do cfg ← read, - modify (λ st, {st with messages := st.messages.add (messageOfParsecMessage ↑cfg msg)}) - -def mkTokenTrie (tokens : List TokenConfig) : Except String (Trie TokenConfig) := -do -- the only hardcoded tokens, because they are never directly mentioned by a `Parser` - let builtinTokens : List TokenConfig := [{«prefix» := "/-"}, {«prefix» := "--"}], - t ← (builtinTokens ++ tokens).mfoldl (λ (t : Trie TokenConfig) tk, - match t.find tk.prefix with - | some tk' := match tk.lbp, tk'.lbp with - | l, 0 := pure $ t.insert tk.prefix tk - | 0, _ := pure t - | l, l' := if l = l' then pure t else throw $ - "invalid token '" ++ tk.prefix ++ "', has been defined with precedences " ++ - toString l ++ " and " ++ toString l' - | none := pure $ t.insert tk.prefix tk) - Trie.empty, - pure t - - -/- Monad stacks used in multiple files -/ - -/- NOTE: We move `RecT` under `ParserT`'s `ReaderT` so that `termParser`, which does not - have access to `commandParser`'s ρ (=`CommandParserConfig`) can still recurse into it - (for command quotations). This means that the `CommandParserConfig` will be reset - on a recursive call to `command.Parser`, i.e. it forgets about locally registered parsers, - but that's not an issue for our intended uses of it. -/ -@[derive Monad Alternative MonadReader MonadParsec MonadExcept MonadRec] -def CommandParserM (ρ : Type) := ReaderT ρ $ RecT Unit Syntax $ parserCoreT Id - -section -local attribute [reducible] ParserT CommandParserM -instance CommandParserM.MonadReaderAdapter (ρ ρ' : Type) : - MonadReaderAdapter ρ ρ' (CommandParserM ρ) (CommandParserM ρ') := -inferInstance -instance CommandParserM.basicParser (ρ : Type) [HasLiftT ρ ParserConfig] : monadBasicParser (CommandParserM ρ) := -⟨λ _ x cfg rec, x.run ↑cfg⟩ -end - -/- The `Nat` at `RecT` is the lbp` -/ -@[derive Monad Alternative MonadReader MonadParsec MonadExcept MonadRec monadBasicParser] -def TermParserM := RecT Nat Syntax $ CommandParserM ParserConfig -abbrev termParser := TermParserM Syntax - -/-- A Term Parser for a suffix or infix notation that accepts a preceding Term. -/ -@[derive Monad Alternative MonadReader MonadParsec MonadExcept MonadRec monadBasicParser] -def TrailingTermParserM := ReaderT Syntax TermParserM -abbrev trailingTermParser := TrailingTermParserM Syntax - -instance trailingTermParserCoe : HasCoe termParser trailingTermParser := -⟨λ x _, x⟩ - -/-- A multimap indexed by tokens. Used for indexing parsers by their leading token. -/ -def TokenMap (α : Type) := RBMap Name (List α) Name.quickLt - -def TokenMap.insert {α : Type} (map : TokenMap α) (k : Name) (v : α) : TokenMap α := -match map.find k with -| none := map.insert k [v] -| some vs := map.insert k (v::vs) - -def TokenMap.ofList {α : Type} : List (Name × α) → TokenMap α -| [] := mkRBMap _ _ _ -| (⟨k,v⟩::xs) := (TokenMap.ofList xs).insert k v - -instance tokenMapNil.tokens : Parser.HasTokens $ @TokenMap.ofList ρ [] := -default _ - -instance tokenMapCons.tokens (k : Name) (r : ρ) (rs : List (Name × ρ)) [Parser.HasTokens r] [Parser.HasTokens $ TokenMap.ofList rs] : - Parser.HasTokens $ TokenMap.ofList ((k,r)::rs) := -⟨tokens r ++ tokens (TokenMap.ofList rs)⟩ - --- This needs to be a separate structure since `termParser`s cannot contain themselves in their config -structure CommandParserConfig extends ParserConfig := -(leadingTermParsers : TokenMap termParser) -(trailingTermParsers : TokenMap trailingTermParser) --- local Term parsers (such as from `local notation`) hide previous parsers instead of overloading them -(localLeadingTermParsers : TokenMap termParser := mkRBMap _ _ _) -(localTrailingTermParsers : TokenMap trailingTermParser := mkRBMap _ _ _) - -instance commandParserConfigCoeParserConfig : HasCoe CommandParserConfig ParserConfig := -⟨CommandParserConfig.toParserConfig⟩ - -abbrev commandParser := CommandParserM CommandParserConfig Syntax - -end «Parser» -end Lean diff --git a/tmp/new-frontend/parser/combinators.lean b/tmp/new-frontend/parser/combinators.lean deleted file mode 100644 index 1a9a801f1d..0000000000 --- a/tmp/new-frontend/parser/combinators.lean +++ /dev/null @@ -1,247 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -Syntax-tree creating Parser Combinators --/ -prelude -import init.lean.parser.basic -import init.data.list.instances - -namespace Lean -namespace Parser - -namespace Combinators -open HasTokens HasView MonadParsec - -variables {α : Type} {m : Type → Type} -local notation `Parser` := m Syntax -variables [Monad m] [MonadExcept (Parsec.Message Syntax) m] [MonadParsec Syntax m] [Alternative m] - -def node (k : SyntaxNodeKind) (rs : List Parser) : Parser := -do args ← rs.mfoldl (λ (args : List Syntax) r, do - -- on error, append partial Syntax tree to previous successful parses and rethrow - a ← catch r $ λ msg, match args with - -- do not wrap an error in the first argument to uphold the invariant documented at `SyntaxNode` - | [] := throw msg - | _ := - let args := msg.custom.get :: args in - throw {msg with custom := Syntax.mkNode k args.reverse}, - pure (a::args) - ) [], - pure $ Syntax.mkNode k args.reverse - -@[reducible] def seq : List Parser → Parser := node noKind - -instance node.tokens (k) (rs : List Parser) [Parser.HasTokens rs] : Parser.HasTokens (node k rs) := -⟨tokens rs⟩ - -instance node.view (k) (rs : List Parser) [i : HasView α k] : Parser.HasView α (node k rs) := -{ view := i.view, review := i.review } - --- Each Parser Combinator comes equipped with `HasView` and `HasTokens` instances - -private def many1Aux (p : Parser) : List Syntax → Nat → Parser -| as 0 := error "unreachable" -| as (n+1) := do - a ← catch p (λ msg, throw {msg with custom := - -- append `Syntax.missing` to make clear that List is incomplete - Syntax.list (Syntax.missing::msg.custom.get::as).reverse}), - many1Aux (a::as) n <|> pure (Syntax.list (a::as).reverse) - -def many1 (r : Parser) : Parser := -do rem ← remaining, many1Aux r [] (rem+1) - -instance many1.tokens (r : Parser) [Parser.HasTokens r] : Parser.HasTokens (many1 r) := -⟨tokens r⟩ - -instance many1.view (r : Parser) [Parser.HasView α r] : Parser.HasView (List α) (many1 r) := -{ view := λ stx, match stx.asNode with - | some n := n.args.map (HasView.view r) - | _ := [HasView.view r Syntax.missing], - review := λ as, Syntax.list $ as.map (review r) } - -def many (r : Parser) : Parser := -many1 r <|> pure (Syntax.list []) - -instance many.tokens (r : Parser) [Parser.HasTokens r] : Parser.HasTokens (many r) := -⟨tokens r⟩ - -instance many.view (r : Parser) [HasView α r] : Parser.HasView (List α) (many r) := -/- Remark: `many1.view` can handle empty list. -/ -{..many1.view r} - -private def sepByAux (p : m Syntax) (sep : Parser) (allowTrailingSep : Bool) : Bool → List Syntax → Nat → Parser -| pOpt as 0 := error "unreachable" -| pOpt as (n+1) := do - let p := if pOpt then some <$> p <|> pure none else some <$> p, - some a ← catch p (λ msg, throw {msg with custom := - -- append `Syntax.missing` to make clear that List is incomplete - Syntax.list (Syntax.missing::msg.custom.get::as).reverse}) - | pure (Syntax.list as.reverse), - -- I don't want to think about what the output on a failed separator parse should look like - let sep := try sep, - some s ← some <$> sep <|> pure none - | pure (Syntax.list (a::as).reverse), - sepByAux allowTrailingSep (s::a::as) n - -def sepBy (p sep : Parser) (allowTrailingSep := true) : Parser := -do rem ← remaining, sepByAux p sep allowTrailingSep true [] (rem+1) - -def sepBy1 (p sep : Parser) (allowTrailingSep := true) : Parser := -do rem ← remaining, sepByAux p sep allowTrailingSep false [] (rem+1) - -instance sepBy.tokens (p sep : Parser) (a) [Parser.HasTokens p] [Parser.HasTokens sep] : - Parser.HasTokens (sepBy p sep a) := -⟨tokens p ++ tokens sep⟩ - -structure SepBy.Elem.View (α β : Type) := -(item : α) -(separator : Option β := none) - -instance SepBy.Elem.View.itemCoe {α β : Type} : HasCoeT α (SepBy.Elem.View α β) := -⟨λ a, ⟨a, none⟩⟩ - -private def sepBy.viewAux {α β} (p sep : Parser) [Parser.HasView α p] [Parser.HasView β sep] : - List Syntax → List (SepBy.Elem.View α β) -| [] := [] -| [stx] := [⟨HasView.view p stx, none⟩] -| (stx1::stx2::stxs) := ⟨HasView.view p stx1, some $ HasView.view sep stx2⟩::sepBy.viewAux stxs - -instance sepBy.view {α β} (p sep : Parser) (a) [Parser.HasView α p] [Parser.HasView β sep] : - Parser.HasView (List (SepBy.Elem.View α β)) (sepBy p sep a) := -{ view := λ stx, match stx.asNode with - | some n := sepBy.viewAux p sep n.args - | _ := [⟨view p Syntax.missing, none⟩], - review := λ as, Syntax.list $ as.bind (λ a, match a with - | ⟨v, some vsep⟩ := [review p v, review sep vsep] - | ⟨v, none⟩ := [review p v]) } - -instance sepBy1.tokens (p sep : Parser) (a) [Parser.HasTokens p] [Parser.HasTokens sep] : - Parser.HasTokens (sepBy1 p sep a) := -⟨tokens (sepBy p sep a)⟩ - -instance sepBy1.View {α β} (p sep : Parser) (a) [Parser.HasView α p] [Parser.HasView β sep] : - Parser.HasView (List (SepBy.Elem.View α β)) (sepBy1 p sep a) := -{..sepBy.view p sep a} - -/-- Optionally parse `r`. `require` can be used to conditionally override the - behavior without changing the structure of the syntax tree. -/ -def optional (r : Parser) (require := false) : Parser := -if require then r else -do r ← optional $ - -- on error, wrap in "some" - catch r (λ msg, throw {msg with custom := Syntax.list [msg.custom.get]}), - pure $ match r with - | some r := Syntax.list [r] - | none := Syntax.list [] - -instance optional.tokens (r : Parser) [Parser.HasTokens r] (req) : Parser.HasTokens (optional r req) := -⟨tokens r⟩ -instance optional.view (r : Parser) [Parser.HasView α r] (req) : Parser.HasView (Option α) (optional r req) := -{ view := λ stx, match stx.asNode with - | some {args := [], ..} := none - | some {args := [stx], ..} := some $ HasView.view r stx - | _ := some $ view r Syntax.missing, - review := λ a, match a with - | some a := Syntax.list [review r a] - | none := Syntax.list [] } -instance optional.viewDefault (r : Parser) [Parser.HasView α r] (req) : Parser.HasViewDefault (optional r req) (Option α) none := ⟨⟩ - -/-- Parse a List `[p1, ..., pn]` of parsers as `p1 <|> ... <|> pn`. - Note that there is NO explicit encoding of which Parser was chosen; - parsers should instead produce distinct Node names for disambiguation. -/ -def anyOf (rs : List Parser) : Parser := -match rs with -| [] := error "anyOf" -| (r::rs) := rs.foldl (<|>) r - -instance anyOf.tokens (rs : List Parser) [Parser.HasTokens rs] : Parser.HasTokens (anyOf rs) := -⟨tokens rs⟩ -instance anyOf.view (rs : List Parser) : Parser.HasView Syntax (anyOf rs) := default _ - -/-- Parse a List `[p1, ..., pn]` of parsers with `MonadParsec.longestMatch`. - If the Result is ambiguous, wrap it in a `choice` Node. - Note that there is NO explicit encoding of which Parser was chosen; - parsers should instead produce distinct Node names for disambiguation. -/ -def longestMatch (rs : List Parser) : Parser := -do stxs ← MonadParsec.longestMatch rs, - match stxs with - | [stx] := pure stx - | _ := pure $ Syntax.mkNode choice stxs - -instance longestMatch.tokens (rs : List Parser) [Parser.HasTokens rs] : Parser.HasTokens (longestMatch rs) := -⟨tokens rs⟩ -instance longestMatch.view (rs : List Parser) : Parser.HasView Syntax (longestMatch rs) := default _ - -def choiceAux : List Parser → Nat → Parser -| [] _ := error "choice: Empty List" -| (r::rs) i := - do { stx ← r, - pure $ Syntax.mkNode ⟨Name.mkNumeral Name.anonymous i⟩ [stx] } - <|> choiceAux rs (i+1) - -/-- Parse a List `[p1, ..., pn]` of parsers as `p1 <|> ... <|> pn`. - The Result will be wrapped in a Node with the index of the successful - Parser as the Name. - - Remark: Does not have a `HasView` instance because we only use it in `nodeChoice!` macros - that define their own views. -/ -def choice (rs : List Parser) : Parser := -choiceAux rs 0 - -instance choice.tokens (rs : List Parser) [Parser.HasTokens rs] : Parser.HasTokens (choice rs) := -⟨tokens rs⟩ - -/-- Like `choice`, but using `longestMatch`. Does not create choice nodes, prefers the first successful Parser. -/ -def longestChoice (rs : List Parser) : Parser := -do stx::stxs ← MonadParsec.longestMatch $ rs.enum.map $ λ ⟨i, r⟩, do { - stx ← r, - pure $ Syntax.mkNode ⟨Name.mkNumeral Name.anonymous i⟩ [stx] - } | error "unreachable", - pure stx - -instance longestChoice.tokens (rs : List Parser) [Parser.HasTokens rs] : Parser.HasTokens (longestChoice rs) := - -⟨tokens rs⟩ -instance try.tokens (r : Parser) [Parser.HasTokens r] : Parser.HasTokens (try r) := -⟨tokens r⟩ -instance try.view (r : Parser) [i : Parser.HasView α r] : Parser.HasView α (try r) := -{..i} - -instance label.tokens (r : Parser) (l) [Parser.HasTokens r] : Parser.HasTokens (label r l) := -⟨tokens r⟩ -instance label.view (r : Parser) (l) [i : Parser.HasView α r] : Parser.HasView α (label r l) := -{..i} - -instance recurse.tokens (α δ m a) [MonadRec α δ m] : Parser.HasTokens (recurse a : m δ) := -default _ -- recursive use should not contribute any new tokens -instance recurse.view (α δ m a) [MonadRec α δ m] : Parser.HasView Syntax (recurse a : m δ) := default _ - -instance monadLift.tokens {m' : Type → Type} [HasMonadLiftT m m'] (r : m Syntax) [Parser.HasTokens r] : - Parser.HasTokens (monadLift r : m' Syntax) := -⟨tokens r⟩ -instance monadLift.view {m' : Type → Type} [HasMonadLiftT m m'] (r : m Syntax) [i : Parser.HasView α r] : - Parser.HasView α (monadLift r : m' Syntax) := -{..i} - -instance seqLeft.tokens {α : Type} (x : m α) (p : m Syntax) [Parser.HasTokens p] : Parser.HasTokens (p <* x) := -⟨tokens p⟩ -instance seqLeft.view {α β : Type} (x : m α) (p : m Syntax) [i : Parser.HasView β p] : Parser.HasView β (p <* x) := -{..i} - -instance seqRight.tokens {α : Type} (x : m α) (p : m Syntax) [Parser.HasTokens p] : Parser.HasTokens (x *> p) := -⟨tokens p⟩ -instance seqRight.view {α β : Type} (x : m α) (p : m Syntax) [i : Parser.HasView β p] : Parser.HasView β (x *> p) := -{..i} - -instance coe.tokens {β} (r : Parser) [Parser.HasTokens r] [HasCoeT Parser β]: Parser.HasTokens (coe r : β) := -⟨tokens r⟩ -instance coe.view {β} (r : Parser) [i : Parser.HasView α r] [HasCoeT Parser β] : Parser.HasView α (coe r : β) := -{..i} -instance coe.viewDefault {β} (d : α) (r : Parser) [HasView α r] [Parser.HasViewDefault r α d] [HasCoeT Parser β] : Parser.HasViewDefault (coe r : β) α d := ⟨⟩ - -end Combinators -end Parser -end Lean diff --git a/tmp/new-frontend/parser/command.lean b/tmp/new-frontend/parser/command.lean deleted file mode 100644 index d43aa19346..0000000000 --- a/tmp/new-frontend/parser/command.lean +++ /dev/null @@ -1,165 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -Command parsers --/ -prelude -import init.lean.parser.declaration - -namespace Lean -namespace Parser - -open Combinators MonadParsec -open Parser.HasTokens Parser.HasView - -local postfix `?`:10000 := optional -local postfix *:10000 := Combinators.many -local postfix +:10000 := Combinators.many1 - -set_option class.instance_max_depth 300 - -@[derive Parser.HasView Parser.HasTokens] -def command.Parser : commandParser := -recurse () "command" - -namespace «command» - -@[derive Parser.HasView Parser.HasTokens] -def openSpec.Parser : commandParser := -node! openSpec [ - id: ident.Parser, - as: node! openSpec.as ["as", id: ident.Parser]?, - only: node! openSpec.only [try ["(", id: ident.Parser], ids: ident.Parser*, ")"]?, - «renaming»: node! openSpec.renaming [try ["(", "renaming"], items: node! openSpec.renaming.item [«from»: ident.Parser, "->", to: ident.Parser]+, ")"]?, - «hiding»: node! openSpec.hiding ["(", "hiding", ids: ident.Parser+, ")"]? -]+ - -@[derive Parser.HasTokens] -def open.Parser : commandParser := -node! «open» ["open", spec: openSpec.Parser] - -@[derive Parser.HasTokens] -def export.Parser : commandParser := -node! «export» ["export", spec: openSpec.Parser] - -@[derive Parser.HasTokens] -def section.Parser : commandParser := -node! «section» ["section", Name: ident.Parser?] - -@[derive Parser.HasTokens] -def namespace.Parser : commandParser := -node! «namespace» ["namespace", Name: ident.Parser] - -@[derive Parser.HasTokens] -def variable.Parser : commandParser := -node! «variable» ["variable", binder: Term.binder.Parser] - -@[derive Parser.HasTokens] -def variables.Parser : commandParser := --- TODO: should require at least one binder -node! «variables» ["variables", binders: Term.bracketedBinders.Parser] - -@[derive Parser.HasTokens] -def include.Parser : commandParser := -node! «include» ["include ", ids: ident.Parser+] - -@[derive Parser.HasTokens] -def omit.Parser : commandParser := -node! «omit» ["omit ", ids: ident.Parser+] - -@[derive Parser.HasTokens] -def end.Parser : commandParser := -node! «end» ["end", Name: ident.Parser?] - -@[derive Parser.HasTokens] -def universe.Parser : commandParser := -anyOf [ - node! «universes» ["universes", ids: ident.Parser+], - node! «universe» ["universe", id: ident.Parser] -] - -@[derive Parser.HasTokens Parser.HasView] -def check.Parser : commandParser := -node! check ["#check", Term: Term.Parser] - -@[derive Parser.HasTokens Parser.HasView] -def attribute.Parser : commandParser := -node! «attribute» [ - try [«local»: (symbol "local ")?, "attribute "], - "[", - attrs: sepBy1 attrInstance.Parser (symbol ", "), - "] ", - ids: ident.Parser* -] - -@[derive Parser.HasTokens Parser.HasView] -def initQuot.Parser : commandParser := -node! «initQuot» ["initQuot"] - -@[derive Parser.HasTokens Parser.HasView] -def setOption.Parser : commandParser := -node! «setOption» ["setOption", opt: ident.Parser, val: nodeChoice! optionValue { - Bool: nodeChoice! boolOptionValue { - True: symbolOrIdent "true", - False: symbolOrIdent "false", - }, - String: stringLit.Parser, - -- TODO(Sebastian): fractional numbers - num: number.Parser, -}] - -@[derive HasTokens] -def builtinCommandParsers : TokenMap commandParser := TokenMap.ofList [ - ("/--", declaration.Parser), - ("@[", declaration.Parser), - ("private", declaration.Parser), - ("protected", declaration.Parser), - ("noncomputable", declaration.Parser), - ("unsafe", declaration.Parser), - ("def", declaration.Parser), - ("abbreviation", declaration.Parser), - ("abbrev", declaration.Parser), - ("theorem", declaration.Parser), - ("instance", declaration.Parser), - ("axiom", declaration.Parser), - ("constant", declaration.Parser), - ("class", declaration.Parser), - ("inductive", declaration.Parser), - ("structure", declaration.Parser), - - ("variable", variable.Parser), - ("variables", variables.Parser), - ("namespace", namespace.Parser), - ("end", end.Parser), - ("open", open.Parser), - ("section", section.Parser), - ("universe", universe.Parser), - ("universes", universe.Parser), - ("local", notation.Parser), - ("notation", notation.Parser), - ("reserve", reserveNotation.Parser), - ("local", mixfix.Parser), - ("prefix", mixfix.Parser), - ("infix", mixfix.Parser), - ("infixl", mixfix.Parser), - ("infixr", mixfix.Parser), - ("postfix", mixfix.Parser), - ("reserve", reserveMixfix.Parser), - ("#check", check.Parser), - ("local", attribute.Parser), - ("attribute", attribute.Parser), - ("export", export.Parser), - ("include", include.Parser), - ("omit", omit.Parser), - ("initQuot", initQuot.Parser), - ("setOption", setOption.Parser)] -end «command» - -def commandParser.run (commands : TokenMap commandParser) (p : commandParser) - : ParserT CommandParserConfig Id Syntax := -λ cfg, (p.run cfg).runParsec $ λ _, (indexed commands >>= anyOf : commandParser).run cfg - -end Parser -end Lean diff --git a/tmp/new-frontend/parser/declaration.lean b/tmp/new-frontend/parser/declaration.lean deleted file mode 100644 index 6cf4322341..0000000000 --- a/tmp/new-frontend/parser/declaration.lean +++ /dev/null @@ -1,167 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -Parsers for commands that declare things --/ - -prelude -import init.lean.parser.term - -namespace Lean -namespace Parser - -open Combinators MonadParsec -open Parser.HasTokens Parser.HasView - -instance termParserCommandParserCoe : HasCoe termParser commandParser := -⟨λ p, adaptReader coe $ p.run⟩ - -namespace «command» - -local postfix `?`:10000 := optional -local postfix *:10000 := Combinators.many -local postfix +:10000 := Combinators.many1 - -@[derive HasTokens HasView] -def docComment.Parser : commandParser := -node! docComment ["/--", doc: raw $ many' (notFollowedBy (str "-/") *> any), "-/"] - -@[derive HasTokens HasView] -def attrInstance.Parser : commandParser := --- use `rawIdent` because of attribute names such as `instance` -node! attrInstance [Name: rawIdent.Parser, args: (Term.Parser maxPrec)*] - -@[derive HasTokens HasView] -def declAttributes.Parser : commandParser := --- TODO(Sebastian): custom attribute parsers -node! declAttributes ["@[", attrs: sepBy1 attrInstance.Parser (symbol ","), "]"] - -set_option class.instance_max_depth 300 - -@[derive HasTokens HasView] -def declModifiers.Parser : commandParser := -node! declModifiers [ - docComment: docComment.Parser?, - attrs: declAttributes.Parser?, - visibility: nodeChoice! visibility {"private", "protected"}?, - «noncomputable»: (symbol "noncomputable")?, - «unsafe»: (symbol "unsafe")?, -] - -@[derive HasTokens HasView] -def declSig.Parser : commandParser := -node! declSig [ - params: Term.bracketedBinders.Parser, - type: Term.typeSpec.Parser, -] - -@[derive HasTokens HasView] -def optDeclSig.Parser : commandParser := -node! optDeclSig [ - params: Term.bracketedBinders.Parser, - type: Term.optType.Parser, -] - -@[derive HasTokens HasView] -def equation.Parser : commandParser := -node! equation ["|", lhs: (Term.Parser maxPrec)+, ":=", rhs: Term.Parser] - -@[derive HasTokens HasView] -def declVal.Parser : commandParser := -nodeChoice! declVal { - simple: node! simpleDeclVal [":=", body: Term.Parser], - emptyMatch: symbol ".", - «match»: equation.Parser+ -} - -@[derive HasTokens HasView] -def inferModifier.Parser : commandParser := -nodeChoice! inferModifier { - relaxed: try $ node! relaxedInferModifier ["{", "}"], - strict: try $ node! strictInferModifier ["(", ")"], -} - -@[derive HasTokens HasView] -def introRule.Parser : commandParser := -node! introRule [ - "|", - Name: ident.Parser, - inferMod: inferModifier.Parser?, - sig: optDeclSig.Parser, -] - -@[derive HasTokens HasView] -def structBinderContent.Parser : commandParser := -node! structBinderContent [ - ids: ident.Parser+, - inferMod: inferModifier.Parser?, - sig: optDeclSig.Parser, - default: Term.binderDefault.Parser?, -] - -@[derive HasTokens HasView] -def structureFieldBlock.Parser : commandParser := -nodeChoice! structureFieldBlock { - explicit: node! structExplicitBinder ["(", content: nodeChoice! structExplicitBinderContent { - «notation»: command.notationLike.Parser, - other: structBinderContent.Parser - }, right: symbol ")"], - implicit: node! structImplicitBinder ["{", content: structBinderContent.Parser, "}"], - strictImplicit: node! strictImplicitBinder ["⦃", content: structBinderContent.Parser, "⦄"], - instImplicit: node! instImplicitBinder ["[", content: structBinderContent.Parser, "]"], -} - -@[derive HasTokens HasView] -def oldUnivParams.Parser : commandParser := -node! oldUnivParams ["{", ids: ident.Parser+, "}"] - -@[derive Parser.HasTokens Parser.HasView] -def identUnivParams.Parser : commandParser := -node! identUnivParams [ - id: ident.Parser, - univParams: node! univParams [".{", params: ident.Parser+, "}"]? -] - -@[derive HasTokens HasView] -def structure.Parser : commandParser := -node! «structure» [ - keyword: nodeChoice! structureKw {"structure", "class"}, - oldUnivParams: oldUnivParams.Parser?, - Name: identUnivParams.Parser, - sig: optDeclSig.Parser, - «extends»: node! «extends» ["extends", parents: sepBy1 Term.Parser (symbol ",")]?, - ":=", - ctor: node! structureCtor [Name: ident.Parser, inferMod: inferModifier.Parser?, "::"]?, - fieldBlocks: structureFieldBlock.Parser*, -] - -@[derive HasTokens HasView] -def declaration.Parser : commandParser := -node! declaration [ - modifiers: declModifiers.Parser, - inner: nodeChoice! declaration.inner { - «defLike»: node! «defLike» [ - kind: nodeChoice! defLike.kind {"def", "abbreviation", "abbrev", "theorem", "constant"}, - oldUnivParams: oldUnivParams.Parser?, - Name: identUnivParams.Parser, sig: optDeclSig.Parser, val: declVal.Parser], - «instance»: node! «instance» ["instance", Name: identUnivParams.Parser?, sig: declSig.Parser, val: declVal.Parser], - «example»: node! «example» ["example", sig: declSig.Parser, val: declVal.Parser], - «axiom»: node! «axiom» [ - kw: nodeChoice! constantKeyword {"axiom"}, - Name: identUnivParams.Parser, - sig: declSig.Parser], - «inductive»: node! «inductive» [try [«class»: (symbol "class")?, "inductive"], - oldUnivParams: oldUnivParams.Parser?, - Name: identUnivParams.Parser, - sig: optDeclSig.Parser, - localNotation: notationLike.Parser?, - introRules: introRule.Parser*], - «structure»: structure.Parser, - } -] - -end «command» -end Parser -end Lean diff --git a/tmp/new-frontend/parser/identifier.lean b/tmp/new-frontend/parser/identifier.lean deleted file mode 100644 index a6c23cd3d0..0000000000 --- a/tmp/new-frontend/parser/identifier.lean +++ /dev/null @@ -1,70 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Leonardo de Moura --/ -prelude -import init.data.char.basic init.lean.parser.parsec - -namespace Lean - -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 := -(0x207f ≤ c.val && c.val ≤ 0x2089) || -- n superscript and numberic 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 = '\'' || isLetterLike c || isSubScriptAlnum c - -def idBeginEscape := '«' -def idEndEscape := '»' -def isIdBeginEscape (c : Char) : Bool := -c = idBeginEscape -def isIdEndEscape (c : Char) : Bool := -c = idEndEscape - -namespace Parser -variables {m : Type → Type} {μ : Type} [Monad m] [MonadParsec μ m] [Alternative m] -open MonadParsec - -def idPartDefault : m String := -do c ← satisfy isIdFirst, - takeWhileCont isIdRest (toString c) - -def idPartEscaped : m String := -ch idBeginEscape *> takeUntil1 isIdEndEscape <* ch idEndEscape - -def idPart : m String := -cond isIdBeginEscape - idPartEscaped - idPartDefault - -def identifier : m Name := -(try $ do s ← idPart, - foldl Name.mkString (mkSimpleName s) (ch '.' *> idPart)) "identifier" - -def cIdentifier : m String := -(try $ do c ← satisfy (λ c, c.isAlpha || c = '_'), - takeWhileCont (λ c, c.isAlphanum || c = '_') (toString c)) "C identifier" - -def cppIdentifier : m String := -(try $ do n ← cIdentifier, - ns ← many ((++) <$> str "::" <*> cIdentifier), - pure $ String.join (n::ns)) "C++ identifier" - -end Parser -end Lean diff --git a/tmp/new-frontend/parser/level.lean b/tmp/new-frontend/parser/level.lean deleted file mode 100644 index 94b54ea1ef..0000000000 --- a/tmp/new-frontend/parser/level.lean +++ /dev/null @@ -1,76 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -Level-Level parsers --/ -prelude -import init.lean.parser.pratt - -namespace Lean -namespace Parser -open Combinators Parser.HasView MonadParsec - -@[derive Monad Alternative MonadReader MonadParsec MonadExcept MonadRec monadBasicParser] -def LevelParserM := RecT Nat Syntax BasicParserM -abbrev levelParser := LevelParserM Syntax - -/-- A Level Parser for a suffix or infix notation that accepts a preceding Term Level. -/ -@[derive Monad Alternative MonadReader MonadParsec MonadExcept MonadRec monadBasicParser] -def TrailingLevelParserM := ReaderT Syntax LevelParserM -abbrev trailingLevelParser := TrailingLevelParserM Syntax - -instance trailingLevelParserCoe : HasCoe levelParser trailingLevelParser := -⟨λ x _, x⟩ - -@[derive Parser.HasTokens Parser.HasView] -def Level.Parser (rbp := 0) : levelParser := -recurse rbp "universe Level" - -namespace Level -/-- Access leading Term -/ -def getLeading : trailingLevelParser := read -instance : HasTokens getLeading := default _ -instance : HasView Syntax getLeading := default _ - -@[derive Parser.HasTokens Parser.HasView] -def paren.Parser : levelParser := -node! «paren» ["(":maxPrec, inner: Level.Parser 0, ")"] - -@[derive Parser.HasTokens Parser.HasView] -def leading.Parser : levelParser := -nodeChoice! leading { - max: symbolOrIdent "max", - imax: symbolOrIdent "imax", - hole: symbol "_" maxPrec, - paren: paren.Parser, - lit: number.Parser, - var: ident.Parser -} - -@[derive Parser.HasTokens Parser.HasView] -def app.Parser : trailingLevelParser := -node! app [fn: getLeading, Arg: Level.Parser maxPrec] - -@[derive Parser.HasTokens Parser.HasView] -def addLit.Parser : trailingLevelParser := -node! addLit [lhs: getLeading, "+", rhs: number.Parser] - -@[derive Parser.HasTokens Parser.HasView] -def trailing.Parser : trailingLevelParser := -nodeChoice! trailing { - app: app.Parser, - addLit: addLit.Parser -} -end Level - -@[derive Parser.HasTokens Parser.HasView] -def levelParser.run (p : levelParser) : basicParser := -prattParser Level.leading.Parser Level.trailing.Parser p - -instance levelParserCoe : HasCoe levelParser basicParser := -⟨levelParser.run⟩ - -end Parser -end Lean diff --git a/tmp/new-frontend/parser/module.lean b/tmp/new-frontend/parser/module.lean deleted file mode 100644 index 2ced51fdb3..0000000000 --- a/tmp/new-frontend/parser/module.lean +++ /dev/null @@ -1,133 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -Module-Level parsers --/ -prelude -import init.lean.parser.command - -namespace Lean -namespace Parser - -open Combinators MonadParsec -open Parser.HasTokens Parser.HasView - -local postfix `?`:10000 := optional -local postfix *:10000 := Combinators.many -local postfix +:10000 := Combinators.many1 - -structure ModuleParserConfig extends CommandParserConfig := -(commandParsers : TokenMap commandParser) - -instance moduleParserConfigCoe : HasCoe ModuleParserConfig CommandParserConfig := -⟨ModuleParserConfig.toCommandParserConfig⟩ - -section -@[derive Monad Alternative MonadReader MonadState MonadParsec MonadExcept] -def ModuleParserM := StateT ParserState $ ParserT ModuleParserConfig Id -abbrev moduleParser := ModuleParserM Syntax -end - -instance ModuleParserM.liftParserT (ρ : Type) [HasLiftT ModuleParserConfig ρ] : - HasMonadLift (ParserT ρ Id) ModuleParserM := -{ monadLift := λ α x st cfg, (λ a, (a, st)) <$> x.run ↑cfg } - -section -local attribute [reducible] BasicParserM -instance ModuleParserM.BasicParserM (ρ : Type) [HasLiftT ModuleParserConfig ρ] : - HasMonadLift BasicParserM ModuleParserM := - inferInstance -end - -namespace Module -@[derive Parser.HasView Parser.HasTokens] -def prelude.Parser : basicParser := -node! «prelude» ["prelude"] - -@[derive Parser.HasView Parser.HasTokens] -def importPath.Parser : basicParser := --- use `raw` to ignore registered tokens like ".." -node! importPath [ - dirups: (rawStr ".")*, - Module: ident.Parser] - -@[derive Parser.HasView Parser.HasTokens] -def import.Parser : basicParser := -node! «import» ["import", imports: importPath.Parser+] - -@[derive Parser.HasView Parser.HasTokens] -def header.Parser : basicParser := -node! «header» [«prelude»: prelude.Parser?, imports: import.Parser*] - -@[pattern] def eoi : SyntaxNodeKind := ⟨`Lean.Parser.Module.eoi⟩ - -def eoi.Parser : moduleParser := do - MonadParsec.eoi, - it ← leftOver, - -- add `eoi` Node for left-over input - let stop := it.toEnd, - pure $ Syntax.mkNode eoi [Syntax.atom ⟨some ⟨⟨stop, stop⟩, stop.offset, ⟨stop, stop⟩⟩, ""⟩] - -/-- Read command, recovering from errors inside commands (attach partial Syntax tree) - as well as unknown commands (skip input). -/ -private def commandWrecAux : Bool → Nat → ModuleParserM (Bool × Syntax) -| recovering 0 := error "unreachable" -| recovering (Nat.succ n) := do - -- terminate at EOF - Nat.succ _ ← remaining | (Prod.mk false) <$> eoi.Parser, - (recovering, c) ← catch (do { - cfg ← read, - c ← monadLift $ command.Parser.run cfg.commandParsers, - pure (false, some c) - } <|> do { - -- unknown command: try to skip token, or else single character - when (¬ recovering) $ do { - it ← leftOver, - logMessage {expected := DList.singleton "command", it := it, custom := some ()} - }, - try (monadLift token *> pure ()) <|> (any *> pure ()), - pure (true, none) - }) $ λ msg, do { - -- error inside command: log error, return partial Syntax tree - logMessage msg, - pure (true, some msg.custom.get) - }, - /- NOTE: We need to make very sure that these recursive calls are happening in tail positions. - Otherwise, resuming the coroutine is linear in the number of previous commands. -/ - match c with - | some c := pure (recovering, c) - | none := commandWrecAux recovering n - -def parseCommandWithRecovery (recovering : Bool) := -do { rem ← remaining, commandWrecAux recovering rem.succ } -end Module -open Module - -structure ModuleParserSnapshot := --- it there was a parse error in the previous command, we shouldn't complain if parsing immediately after it --- fails as well -(recovering : Bool) -(it : String.OldIterator) - --- return (partial) Syntax tree and single fatal or multiple non-fatal messages -def resumeModuleParser {α : Type} (cfg : ModuleParserConfig) (snap : ModuleParserSnapshot) (mkRes : α → Syntax × ModuleParserSnapshot) - (p : ModuleParserM α) : Syntax × Except Message (ModuleParserSnapshot × MessageLog) := -let (r, _) := ((((Prod.mk <$> p <*> leftOver).run {messages:=MessageLog.empty}).run cfg).runFrom snap.it).run {} in -match r with -| Except.ok ((a, it), st) := let (stx, snap) := mkRes a in (stx, Except.ok ({snap with it := it}, st.messages)) -| Except.error msg := (msg.custom.get, Except.error $ messageOfParsecMessage cfg msg) - -def parseHeader (cfg : ModuleParserConfig) := -let snap := {ModuleParserSnapshot . recovering := false, it := cfg.input.mkOldIterator} in -resumeModuleParser cfg snap (λ stx, (stx, snap)) $ do - -- `token` assumes that there is no leading whitespace - monadLift whitespace, - monadLift header.Parser - -def parseCommand (cfg) (snap) := resumeModuleParser cfg snap (λ p, (Prod.snd p, {snap with recovering := Prod.fst p})) - (parseCommandWithRecovery snap.recovering) - -end Parser -end Lean diff --git a/tmp/new-frontend/parser/notation.lean b/tmp/new-frontend/parser/notation.lean deleted file mode 100644 index bce3240f6d..0000000000 --- a/tmp/new-frontend/parser/notation.lean +++ /dev/null @@ -1,189 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -Notation parsers --/ -prelude -import init.lean.parser.token - -namespace Lean -namespace Parser - -open Combinators MonadParsec -open Parser.HasTokens Parser.HasView - -local postfix `?`:10000 := optional -local postfix *:10000 := Combinators.many -local postfix +:10000 := Combinators.many1 - -@[derive Parser.HasTokens Parser.HasView] -def Term.Parser (rbp := 0) : termParser := -recurse rbp "Term" - -set_option class.instance_max_depth 100 - -namespace «command» -namespace NotationSpec -@[derive Parser.HasTokens Parser.HasView] -def precedenceLit.Parser : termParser := -nodeChoice! precedenceLit { - num: number.Parser, - max: symbolOrIdent "max", - -- TODO(Sebastian): `precOf`? -} - -def precedenceLit.View.toNat : precedenceLit.View → Nat -| (precedenceLit.View.num n) := n.toNat -| (precedenceLit.View.max _) := maxPrec - -@[derive Parser.HasTokens Parser.HasView] -def precedenceTerm.Parser : termParser := -nodeChoice! precedenceTerm { - lit: precedenceLit.Parser, - offset: node! precedenceOffset ["(", lit: precedenceLit.Parser, - op: nodeChoice! precedenceOffsetOp {" + ", " - "}, - offset: number.Parser, - ")", - ] -} - -def precedenceTerm.View.toNat : precedenceTerm.View → Nat -| (precedenceTerm.View.lit l) := l.toNat -| (precedenceTerm.View.offset o) := match o.op with - | (precedenceOffsetOp.View.«+» _) := o.lit.toNat.add o.offset.toNat - | (precedenceOffsetOp.View.«-» _) := o.lit.toNat - o.offset.toNat - -@[derive Parser.HasTokens Parser.HasView] -def precedence.Parser : termParser := -node! «precedence» [":", Term: precedenceTerm.Parser] - -@[derive Parser.HasTokens Parser.HasView] -def quotedSymbol.Parser : termParser := -raw $ takeUntil (= '`') - -@[derive Parser.HasTokens Parser.HasView] -def symbolQuote.Parser : termParser := -node! symbolQuote [ - leftQuote: rawStr "`", - symbol: quotedSymbol.Parser, - rightQuote: rawStr "`" true, -- consume trailing ws - prec: precedence.Parser?] - -def unquotedSymbol.Parser : termParser := -try $ do { - it ← leftOver, - stx@(Syntax.atom _) ← monadLift token | error "" (DList.singleton "symbol") it, - pure stx -} "symbol" - -instance unquotedSymbol.tokens : Parser.HasTokens unquotedSymbol.Parser := ⟨[]⟩ -instance unquotedSymbol.View : Parser.HasView (Option SyntaxAtom) unquotedSymbol.Parser := -{ view := λ stx, match stx with - | Syntax.atom atom := some atom - | _ := none, - review := λ a, (Syntax.atom <$> a).getOrElse Syntax.missing } - ---TODO(Sebastian): cannot be called `symbol` because of hygiene problems -@[derive Parser.HasTokens Parser.HasView] -def notationSymbol.Parser : termParser := -nodeChoice! notationSymbol { - quoted: symbolQuote.Parser, - --TODO(Sebastian): decide if we want this in notations - --unquoted: unquotedSymbol.Parser -} - -@[derive Parser.HasTokens Parser.HasView] -def mixfixSymbol.Parser : termParser := -nodeChoice! mixfixSymbol { - quoted: symbolQuote.Parser, - unquoted: unquotedSymbol.Parser -} - -@[derive Parser.HasTokens Parser.HasView] -def foldAction.Parser : termParser := -node! foldAction [ - "(", - op: anyOf [symbolOrIdent "foldl", symbolOrIdent "foldr"], - sep: notationSymbol.Parser, - folder: node! foldActionFolder [ - "(", - arg1: ident.Parser, - arg2: ident.Parser, - ",", - rhs: Term.Parser, - ")" - ], - init: Term.Parser, - endTk: notationSymbol.Parser, - ")" -] - -@[derive Parser.HasTokens Parser.HasView] -def action.Parser : termParser := -node! action [":", kind: nodeChoice! actionKind { - prec: try precedenceTerm.Parser, - prev: symbolOrIdent "prev", - scoped: node! scopedAction [ - try ["(", scoped: symbolOrIdent "scoped"], - prec: precedence.Parser?, - id: ident.Parser, - ", ", - Term: Term.Parser, - ")", - ], - fold: foldAction.Parser -}] - -@[derive Parser.HasTokens Parser.HasView] -def transition.Parser : termParser := -nodeChoice! transition { - binder: node! binder [binder: symbolOrIdent "binder", prec: precedence.Parser?], - binders: node! binders [binders: symbolOrIdent "binders", prec: precedence.Parser?], - Arg: node! argument [id: ident.Parser, action: action.Parser?] -} - -@[derive Parser.HasTokens Parser.HasView] -def rule.Parser : termParser := -node! rule [symbol: notationSymbol.Parser, transition: transition.Parser?] - -end NotationSpec - -@[derive Parser.HasTokens Parser.HasView] -def NotationSpec.Parser : termParser := -node! NotationSpec [prefixArg: ident.Parser?, rules: NotationSpec.rule.Parser*] - -@[derive Parser.HasTokens Parser.HasView] -def notation.Parser : termParser := -node! «notation» [ - try [«local»: (symbol "local ")?, "notation"], - spec: NotationSpec.Parser, ":=", Term: Term.Parser] - -@[derive Parser.HasTokens Parser.HasView] -def reserveNotation.Parser : termParser := -node! «reserveNotation» [try ["reserve", "notation"], spec: NotationSpec.Parser] - -@[derive Parser.HasTokens Parser.HasView] -def mixfix.kind.Parser : termParser := -nodeChoice! mixfix.kind {"prefix", "infix", "infixl", "infixr", "postfix"} - -@[derive Parser.HasTokens Parser.HasView] -def mixfix.Parser : termParser := -node! «mixfix» [ - try [«local»: (symbol "local ")?, kind: mixfix.kind.Parser], - symbol: NotationSpec.mixfixSymbol.Parser, ":=", Term: Term.Parser] - -@[derive Parser.HasTokens Parser.HasView] -def notationLike.Parser : termParser := -nodeChoice! notationLike {«notation»: notation.Parser, mixfix: mixfix.Parser} - -@[derive Parser.HasTokens Parser.HasView] -def reserveMixfix.Parser : termParser := -node! «reserveMixfix» [ - try ["reserve", kind: mixfix.kind.Parser], - symbol: NotationSpec.notationSymbol.Parser] - -end «command» -end Parser -end Lean diff --git a/tmp/new-frontend/parser/parsec.lean b/tmp/new-frontend/parser/parsec.lean deleted file mode 100644 index 0256f5ea62..0000000000 --- a/tmp/new-frontend/parser/parsec.lean +++ /dev/null @@ -1,674 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Leonardo de Moura, Sebastian Ullrich - -Implementation for the Parsec Parser Combinators described in the -paper: -https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/Parsec-paper-letter.pdf --/ -prelude -import init.data.tostring init.data.string.basic init.data.list.basic init.control.except -import init.data.repr init.lean.name init.data.dlist init.control.monadfail init.control.combinators -import init.lean.format - -/- Old String iterator -/ -namespace String -structure OldIterator := -(s : String) (offset : Nat) (i : Nat) - -def mkOldIterator (s : String) : OldIterator := -⟨s, 0, 0⟩ - -namespace OldIterator -def remaining : OldIterator → Nat -| ⟨s, o, _⟩ := s.length - o - -def toString : OldIterator → String -| ⟨s, _, _⟩ := s - -def remainingBytes : OldIterator → Nat -| ⟨s, _, i⟩ := s.bsize - i - -def curr : OldIterator → Char -| ⟨s, _, i⟩ := get s i - -def next : OldIterator → OldIterator -| ⟨s, o, i⟩ := ⟨s, o+1, s.next i⟩ - -def prev : OldIterator → OldIterator -| ⟨s, o, i⟩ := ⟨s, o-1, s.prev i⟩ - -def hasNext : OldIterator → Bool -| ⟨s, _, i⟩ := i < utf8ByteSize s - -def hasPrev : OldIterator → Bool -| ⟨s, _, i⟩ := i > 0 - -def setCurr : OldIterator → Char → OldIterator -| ⟨s, o, i⟩ c := ⟨s.set i c, o, i⟩ - -def toEnd : OldIterator → OldIterator -| ⟨s, o, _⟩ := ⟨s, s.length, s.bsize⟩ - -def extract : OldIterator → OldIterator → String -| ⟨s₁, _, b⟩ ⟨s₂, _, e⟩ := - if s₁ ≠ s₂ || b > e then "" - else s₁.extract b e - -def forward : OldIterator → Nat → OldIterator -| it 0 := it -| it (n+1) := forward it.next n - -def remainingToString : OldIterator → String -| ⟨s, _, i⟩ := s.extract i s.bsize - -/- (isPrefixOfRemaining it₁ it₂) is `true` Iff `it₁.remainingToString` is a prefix - of `it₂.remainingToString`. -/ -def isPrefixOfRemaining : OldIterator → OldIterator → Bool -| ⟨s₁, _, i₁⟩ ⟨s₂, _, i₂⟩ := s₁.extract i₁ s₁.bsize = s₂.extract i₂ (i₂ + (s₁.bsize - i₁)) - -def nextn : OldIterator → Nat → OldIterator -| it 0 := it -| it (i+1) := nextn it.next i - -def prevn : OldIterator → Nat → OldIterator -| it 0 := it -| it (i+1) := prevn it.prev i -end OldIterator - -private def oldLineColumnAux : Nat → String.OldIterator → Nat × Nat → Nat × Nat -| 0 it r := r -| (k+1) it r@(line, col) := - if it.hasNext = false then r - else match it.curr with - | '\n' := oldLineColumnAux k it.next (line+1, 0) - | other := oldLineColumnAux k it.next (line, col+1) - -def oldLineColumn (s : String) (offset : Nat) : Nat × Nat := -oldLineColumnAux offset s.mkOldIterator (1, 0) - -end String - - -namespace Lean -namespace Parser -open String (OldIterator) - -namespace Parsec -@[reducible] def Position : Type := Nat - -structure Message (μ : Type := Unit) := -(it : OldIterator) -(unexpected : String := "") -- unexpected input -(expected : DList String := ∅) -- expected productions -(custom : Option μ) - -def expected.toString : List String → String -| [] := "" -| [e] := e -| [e1, e2] := e1 ++ " or " ++ e2 -| (e::es) := e ++ ", " ++ expected.toString es - -def Message.text {μ : Type} (msg : Message μ) : String := -let unexpected := (if msg.unexpected = "" then [] else ["unexpected " ++ msg.unexpected]) in -let exList := msg.expected.toList in -let expected := if exList = [] then [] else ["expected " ++ expected.toString exList] in -"\n".intercalate $ unexpected ++ expected - - -protected def Message.toString {μ : Type} (msg : Message μ) : String := -let (line, col) := msg.it.toString.oldLineColumn msg.it.offset in --- always print ":"; we assume at least one of `unexpected` and `expected` to be non-Empty -"error at line " ++ toString line ++ ", column " ++ toString col ++ ":\n" ++ msg.text - -instance {μ : Type} : HasToString (Message μ) := -⟨Message.toString⟩ - --- use for e.g. upcasting Parsec errors with `MonadExcept.liftExcept` -instance {μ : Type} : HasLift (Message μ) String := -⟨toString⟩ - -/- -Remark: we store expected "error" messages in `okEps` results. -They contain the error that would have occurred if a -successful "epsilon" Alternative was not taken. --/ -inductive Result (μ α : Type) -| ok {} (a : α) (it : OldIterator) (expected : Option $ DList String) : Result -| error {} (msg : Message μ) (consumed : Bool) : Result - -@[inline] def Result.mkEps {μ α : Type} (a : α) (it : OldIterator) : Result μ α := -Result.ok a it (some ∅) -end Parsec - -open Parsec - -def ParsecT (μ : Type) (m : Type → Type) (α : Type) := -OldIterator → m (Result μ α) - -abbrev Parsec (μ : Type) := ParsecT μ Id -/-- `Parsec` without custom error Message Type -/ -abbrev Parsec' := Parsec Unit - -namespace ParsecT -open Parsec.Result -variables {m : Type → Type} [Monad m] {μ α β : Type} - -def run (p : ParsecT μ m α) (s : String) (fname := "") : m (Except (Message μ) α) := -do r ← p s.mkOldIterator, - pure $ match r with - | ok a _ _ := Except.ok a - | error msg _ := Except.error msg - -def runFrom (p : ParsecT μ m α) (it : OldIterator) (fname := "") : m (Except (Message μ) α) := -do r ← p it, - pure $ match r with - | ok a _ _ := Except.ok a - | error msg _ := Except.error msg - -@[inline] protected def pure (a : α) : ParsecT μ m α := -λ it, pure (mkEps a it) - -def eps : ParsecT μ m Unit := -ParsecT.pure () - -protected def failure : ParsecT μ m α := -λ it, pure (error { unexpected := "failure", it := it, custom := none } false) - -def merge (msg₁ msg₂ : Message μ) : Message μ := -{ expected := msg₁.expected ++ msg₂.expected, ..msg₁ } - -@[inlineIfReduce] def bindMkRes (ex₁ : Option (DList String)) (r : Result μ β) : Result μ β := -match ex₁, r with -| none, ok b it _ := ok b it none -| none, error msg _ := error msg true -| some ex₁, ok b it (some ex₂) := ok b it (some $ ex₁ ++ ex₂) -| some ex₁, error msg₂ false := error { expected := ex₁ ++ msg₂.expected, .. msg₂ } false -| some ex₁, other := other - -/-- - The `bind p q` Combinator behaves as follows: - 1- If `p` fails, then it fails. - 2- If `p` succeeds and consumes input, then execute `q` - 3- If `q` succeeds but does not consume input, then execute `q` - and merge error messages if both do not consume any input. --/ -@[inline] protected def bind (p : ParsecT μ m α) (q : α → ParsecT μ m β) : ParsecT μ m β := -λ it, do - r ← p it, - match r with - | ok a it ex₁ := bindMkRes ex₁ <$> q a it - | error msg c := pure (error msg c) - -/-- More efficient `bind` that does not correctly merge `expected` and `consumed` information. -/ -@[inline] def bind' (p : ParsecT μ m α) (q : α → ParsecT μ m β) : ParsecT μ m β := -λ it, do - r ← p it, - match r with - | ok a it ex₁ := q a it - | error msg c := pure (error msg c) - -instance : Monad (ParsecT μ m) := -{ bind := λ _ _, ParsecT.bind, pure := λ _, ParsecT.pure } - -/-- `Monad` instance using `bind'`. -/ -def Monad' : Monad (ParsecT μ m) := -{ bind := λ _ _, ParsecT.bind', pure := λ _, ParsecT.pure } - -instance : MonadFail Parsec' := -{ fail := λ _ s it, error { unexpected := s, it := it, custom := () } false } - -instance : MonadExcept (Message μ) (ParsecT μ m) := -{ throw := λ _ msg it, pure (error msg false), - catch := λ _ p c it, do - r ← p it, - match r with - | error msg cns := do { - r ← c msg msg.it, - pure $ match r with - | error msg' cns' := error msg' (cns || cns') - | other := other } - | other := pure other } - -instance : HasMonadLift m (ParsecT μ m) := -{ monadLift := λ α x it, do a ← x, pure (mkEps a it) } - -def expect (msg : Message μ) (exp : String) : Message μ := -{expected := DList.singleton exp, ..msg} - -@[inlineIfReduce] def labelsMkRes (r : Result μ α) (lbls : DList String) : Result μ α := -match r with - | ok a it (some _) := ok a it (some lbls) - | error msg false := error {expected := lbls, ..msg} false - | other := other - -@[inline] def labels (p : ParsecT μ m α) (lbls : DList String) : ParsecT μ m α := -λ it, do - r ← p it, - pure $ labelsMkRes r lbls - -@[inlineIfReduce] def tryMkRes (r : Result μ α) : Result μ α := -match r with -| error msg _ := error msg false -| other := other - -/-- -`try p` behaves like `p`, but it pretends `p` hasn't -consumed any input when `p` fails. - -It is useful for implementing infinite lookahead. -The Parser `try p <|> q` will try `q` even when -`p` has consumed input. - -It is also useful for specifying both the lexer and Parser -together. -``` - (do try (ch 'l' >> ch 'e' >> ch 't'), whitespace, ...) - <|> - ... -``` -Without the `try` Combinator we will not be able to backtrack on the `let` keyword. --/ -@[inline] def try (p : ParsecT μ m α) : ParsecT μ m α := -λ it, do - r ← p it, - pure $ tryMkRes r - -@[inlineIfReduce] def orelseMkRes (msg₁ : Message μ) (r : Result μ α) : Result μ α := -match r with -| ok a it' (some ex₂) := ok a it' (some $ msg₁.expected ++ ex₂) -| error msg₂ false := error (merge msg₁ msg₂) false -| other := other - -/-- - The `orelse p q` Combinator behaves as follows: - 1- If `p` succeeds *or* consumes input, return - its Result. Otherwise, execute `q` and return its - Result. - Recall that the `try p` Combinator can be used to - pretend that `p` did not consume any input, and - simulate infinite lookahead. - 2- If both `p` and `q` did not consume any input, then - combine their error messages (even if one of - them succeeded). --/ -@[inline] protected def orelse (p q : ParsecT μ m α) : ParsecT μ m α := -λ it, do - r ← p it, - match r with - | error msg₁ false := do { r ← q it, pure $ orelseMkRes msg₁ r } - | other := pure other - -instance : Alternative (ParsecT μ m) := -{ orelse := λ _, ParsecT.orelse, - failure := λ _, ParsecT.failure, - ..ParsecT.Monad } - -/-- Run `p`, but do not consume any input when `p` succeeds. -/ -@[specialize] def lookahead (p : ParsecT μ m α) : ParsecT μ m α := -λ it, do - r ← p it, - pure $ match r with - | ok a s' _ := mkEps a it - | other := other -end ParsecT - -/- Type class for abstracting from concrete Monad stacks containing a `Parsec` somewhere. -/ -class MonadParsec (μ : outParam Type) (m : Type → Type) := --- analogous to e.g. `MonadReader.lift` before simplification (see there) -(lift {} {α : Type} : Parsec μ α → m α) --- Analogous to e.g. `MonadReaderAdapter.map` before simplification (see there). --- Its usage seems to be way too common to justify moving it into a separate type class. -(map {} {α : Type} : (∀ {m'} [Monad m'] {α}, ParsecT μ m' α → ParsecT μ m' α) → m α → m α) - -/-- `Parsec` without custom error Message Type -/ -abbrev MonadParsec' := MonadParsec Unit - -variables {μ : Type} - -instance {m : Type → Type} [Monad m] : MonadParsec μ (ParsecT μ m) := -{ lift := λ α p it, pure (p it), - map := λ α f x, f x } - -instance monadParsecTrans {m n : Type → Type} [HasMonadLift m n] [MonadFunctor m m n n] [MonadParsec μ m] : MonadParsec μ n := -{ lift := λ α p, monadLift (MonadParsec.lift p : m α), - map := λ α f x, monadMap (λ β x, (MonadParsec.map @f x : m β)) x } - -namespace MonadParsec -open ParsecT -variables {m : Type → Type} [Monad m] [MonadParsec μ m] {α β : Type} - -def error {α : Type} (unexpected : String) (expected : DList String := ∅) - (it : Option OldIterator := none) (custom : Option μ := none) : m α := -lift $ λ it', Result.error { unexpected := unexpected, expected := expected, it := it.getOrElse it', custom := custom } false - -@[inline] def leftOver : m OldIterator := -lift $ λ it, Result.mkEps it it - -/-- Return the number of characters left to be parsed. -/ -@[inline] def remaining : m Nat := -String.OldIterator.remaining <$> leftOver - -@[inline] def labels (p : m α) (lbls : DList String) : m α := -map (λ m' inst β p, @ParsecT.labels m' inst μ β p lbls) p - -@[inline] def label (p : m α) (lbl : String) : m α := -labels p (DList.singleton lbl) - -infixr ` `:2 := label - -@[inline] def hidden (p : m α) : m α := -labels p ∅ - -/-- -`try p` behaves like `p`, but it pretends `p` hasn't -consumed any input when `p` fails. - -It is useful for implementing infinite lookahead. -The Parser `try p <|> q` will try `q` even when -`p` has consumed input. - -It is also useful for specifying both the lexer and Parser -together. -``` - (do try (ch 'l' >> ch 'e' >> ch 't'), whitespace, ...) - <|> - ... -``` -Without the `try` Combinator we will not be able to backtrack on the `let` keyword. --/ - -@[inline] def try (p : m α) : m α := -map (λ m' inst β p, @ParsecT.try m' inst μ β p) p - -/-- Parse `p` without consuming any input. -/ -@[inline] def lookahead (p : m α) : m α := -map (λ m' inst β p, @ParsecT.lookahead m' inst μ β p) p - -/-- Faster version of `notFollowedBy (satisfy p)` -/ -@[inline] def notFollowedBySat (p : Char → Bool) : m Unit := -do it ← leftOver, - if !it.hasNext then pure () - else let c := it.curr in - if p c then error (repr c) - else pure () - -def eoiError (it : OldIterator) : Result μ α := -Result.error { it := it, unexpected := "end of input", custom := default _ } false - -def curr : m Char := -String.OldIterator.curr <$> leftOver - -@[inline] def cond (p : Char → Bool) (t : m α) (e : m α) : m α := -mcond (p <$> curr) t e - -/-- -If the next character `c` satisfies `p`, then -update Position and return `c`. Otherwise, -generate error Message with current Position and character. -/ -@[inline] def satisfy (p : Char → Bool) : m Char := -do it ← leftOver, - if !it.hasNext then error "end of input" - else let c := it.curr in - if p c then lift $ λ _, Result.ok c it.next none - else error (repr c) - -def ch (c : Char) : m Char := -satisfy (= c) - -def alpha : m Char := -satisfy Char.isAlpha - -def digit : m Char := -satisfy Char.isDigit - -def upper : m Char := -satisfy Char.isUpper - -def lower : m Char := -satisfy Char.isLower - -def any : m Char := -satisfy (λ _, True) - -private def strAux : Nat → OldIterator → OldIterator → Option OldIterator -| 0 _ it := some it -| (n+1) sIt it := - if it.hasNext ∧ sIt.curr = it.curr then strAux n sIt.next it.next - else none - -/-- -`str s` parses a sequence of elements that match `s`. Returns the parsed String (i.e. `s`). -This Parser consumes no input if it fails (even if a partial match). -Note: The behaviour of this Parser is different to that the `String` Parser in the ParsecT Μ M Haskell library, -as this one is all-or-nothing. --/ -def strCore (s : String) (ex : DList String) : m String := -if s.isEmpty then pure "" -else lift $ λ it, match strAux s.length s.mkOldIterator it with - | some it' := Result.ok s it' none - | none := Result.error { it := it, expected := ex, custom := none } false - -@[inline] def str (s : String) : m String := -strCore s (DList.singleton (repr s)) - -private def takeAux : Nat → String → OldIterator → Result μ String -| 0 r it := Result.ok r it none -| (n+1) r it := - if !it.hasNext then eoiError it - else takeAux n (r.push (it.curr)) it.next - -/-- Consume `n` characters. -/ -def take (n : Nat) : m String := -if n = 0 then pure "" -else lift $ takeAux n "" - -private def mkStringResult (r : String) (it : OldIterator) : Result μ String := -if r.isEmpty then Result.mkEps r it -else Result.ok r it none - -@[specialize] -private def takeWhileAux (p : Char → Bool) : Nat → String → OldIterator → Result μ String -| 0 r it := mkStringResult r it -| (n+1) r it := - if !it.hasNext then mkStringResult r it - else let c := it.curr in - if p c then takeWhileAux n (r.push c) it.next - else mkStringResult r it - -/-- -Consume input as long as the predicate returns `true`, and return the consumed input. -This Parser does not fail. It will return an Empty String if the predicate -returns `false` on the current character. -/ -@[specialize] def takeWhile (p : Char → Bool) : m String := -lift $ λ it, takeWhileAux p it.remaining "" it - -@[specialize] def takeWhileCont (p : Char → Bool) (ini : String) : m String := -lift $ λ it, takeWhileAux p it.remaining ini it - -/-- -Consume input as long as the predicate returns `true`, and return the consumed input. -This Parser requires the predicate to succeed on at least once. -/ -@[specialize] def takeWhile1 (p : Char → Bool) : m String := -do c ← satisfy p, - takeWhileCont p (toString c) - -/-- -Consume input as long as the predicate returns `false` (i.e. until it returns `true`), and return the consumed input. -This Parser does not fail. -/ -@[inline] def takeUntil (p : Char → Bool) : m String := -takeWhile (λ c, !p c) - -@[inline] def takeUntil1 (p : Char → Bool) : m String := -takeWhile1 (λ c, !p c) - -private def mkConsumedResult (consumed : Bool) (it : OldIterator) : Result μ Unit := -if consumed then Result.ok () it none -else Result.mkEps () it - -@[specialize] private def takeWhileAux' (p : Char → Bool) : Nat → Bool → OldIterator → Result μ Unit -| 0 consumed it := mkConsumedResult consumed it -| (n+1) consumed it := - if !it.hasNext then mkConsumedResult consumed it - else let c := it.curr in - if p c then takeWhileAux' n true it.next - else mkConsumedResult consumed it - -/-- Similar to `takeWhile` but it does not return the consumed input. -/ -@[specialize] def takeWhile' (p : Char → Bool) : m Unit := -lift $ λ it, takeWhileAux' p it.remaining false it - -/-- Similar to `takeWhile1` but it does not return the consumed input. -/ -@[specialize] def takeWhile1' (p : Char → Bool) : m Unit := -satisfy p *> takeWhile' p - -/-- Consume zero or more whitespaces. -/ -@[noinline] def whitespace : m Unit := -takeWhile' Char.isWhitespace - -/-- Shorthand for `p <* whitespace` -/ -@[inline] def lexeme (p : m α) : m α := -p <* whitespace - -/-- Parse a numeral in decimal. -/ -@[noinline] def num : m Nat := -String.toNat <$> (takeWhile1 Char.isDigit) - -/-- Succeed only if there are at least `n` characters left. -/ -def ensure (n : Nat) : m Unit := -do it ← leftOver, - if n ≤ it.remaining then pure () - else error "end of input" (DList.singleton ("at least " ++ toString n ++ " characters")) - -/-- Return the current Position. -/ -def pos : m Position := -String.OldIterator.offset <$> leftOver - - -/-- `notFollowedBy p` succeeds when Parser `p` fails -/ -@[inline] def notFollowedBy [MonadExcept (Message μ) m] (p : m α) (msg : String := "input") : m Unit := -do it ← leftOver, - b ← lookahead $ catch (p *> pure false) (λ _, pure true), - if b then pure () else error msg ∅ it - -def eoi : m Unit := -do it ← leftOver, - if it.remaining = 0 then pure () - else error (repr it.curr) (DList.singleton ("end of input")) - -@[specialize] def many1Aux [Alternative m] (p : m α) : Nat → m (List α) -| 0 := do a ← p, pure [a] -| (n+1) := do a ← p, - as ← (many1Aux n <|> pure []), - pure (a::as) - -@[specialize] def many1 [Alternative m] (p : m α) : m (List α) := -do r ← remaining, many1Aux p r - -@[specialize] def many [Alternative m] (p : m α) : m (List α) := -many1 p <|> pure [] - -@[specialize] def many1Aux' [Alternative m] (p : m α) : Nat → m Unit -| 0 := p *> pure () -| (n+1) := p *> (many1Aux' n <|> pure ()) - -@[inline] def many1' [Alternative m] (p : m α) : m Unit := -do r ← remaining, many1Aux' p r - -@[specialize] def many' [Alternative m] (p : m α) : m Unit := -many1' p <|> pure () - -@[specialize] def sepBy1 [Alternative m] (p : m α) (sep : m β) : m (List α) := -(::) <$> p <*> many (sep *> p) - -@[specialize] def SepBy [Alternative m] (p : m α) (sep : m β) : m (List α) := -sepBy1 p sep <|> pure [] - -@[specialize] def fixAux [Alternative m] (f : m α → m α) : Nat → m α -| 0 := error "fixAux: no progress" -| (n+1) := f (fixAux n) - -@[specialize] def fix [Alternative m] (f : m α → m α) : m α := -do n ← remaining, fixAux f (n+1) - -@[specialize] def foldrAux [Alternative m] (f : α → β → β) (p : m α) (b : β) : Nat → m β -| 0 := pure b -| (n+1) := (f <$> p <*> foldrAux n) <|> pure b - -/-- Matches zero or more occurrences of `p`, and folds the Result. -/ -@[specialize] def foldr [Alternative m] (f : α → β → β) (p : m α) (b : β) : m β := -do it ← leftOver, - foldrAux f p b it.remaining - -@[specialize] def foldlAux [Alternative m] (f : α → β → α) (p : m β) : α → Nat → m α -| a 0 := pure a -| a (n+1) := (do x ← p, foldlAux (f a x) n) <|> pure a - -/-- Matches zero or more occurrences of `p`, and folds the Result. -/ -@[specialize] def foldl [Alternative m] (f : α → β → α) (a : α) (p : m β) : m α := -do it ← leftOver, - foldlAux f p a it.remaining - -def unexpected (msg : String) : m α := -error msg - -def unexpectedAt (msg : String) (it : OldIterator) : m α := -error msg ∅ it - -/- Execute all parsers in `ps` and return the Result of the longest parse(s) if any, - or else the Result of the furthest error. If there are two parses of - equal length, the first parse wins. -/ -@[specialize] -def longestMatch [MonadExcept (Message μ) m] (ps : List (m α)) : m (List α) := -do it ← leftOver, - r ← ps.mfoldr (λ p (r : Result μ (List α)), - lookahead $ catch - (do - a ← p, - it ← leftOver, - pure $ match r with - | Result.ok as it' none := if it'.offset > it.offset then r - else if it.offset > it'.offset then Result.ok [a] it none - else Result.ok (a::as) it none - | _ := Result.ok [a] it none) - (λ msg, pure $ match r with - | Result.error msg' _ := if msg'.it.offset > msg.it.offset then r - else if msg.it.offset > msg'.it.offset then Result.error msg true - else Result.error (merge msg msg') (msg.it.offset > it.offset) - | _ := r)) - ((error "longestMatch: Empty List" : Parsec _ _) it), - lift $ λ _, r - -@[specialize] -def observing [MonadExcept (Message μ) m] (p : m α) : m (Except (Message μ) α) := -catch (Except.ok <$> p) $ λ msg, pure (Except.error msg) - -end MonadParsec - -namespace MonadParsec -open ParsecT -variables {m : Type → Type} [Monad m] [MonadParsec Unit m] {α β : Type} - -end MonadParsec - -namespace ParsecT -open MonadParsec -variables {m : Type → Type} [Monad m] {α β : Type} - -def parse (p : ParsecT μ m α) (s : String) (fname := "") : m (Except (Message μ) α) := -run p s fname - -def parseWithEoi (p : ParsecT μ m α) (s : String) (fname := "") : m (Except (Message μ) α) := -run (p <* eoi) s fname - -def parseWithLeftOver (p : ParsecT μ m α) (s : String) (fname := "") : m (Except (Message μ) (α × OldIterator)) := -run (Prod.mk <$> p <*> leftOver) s fname - -end ParsecT - -def Parsec.parse {α : Type} (p : Parsec μ α) (s : String) (fname := "") : Except (Message μ) α := -ParsecT.parse p s fname - -end Parser -end Lean diff --git a/tmp/new-frontend/parser/pratt.lean b/tmp/new-frontend/parser/pratt.lean deleted file mode 100644 index 842c5e7ce0..0000000000 --- a/tmp/new-frontend/parser/pratt.lean +++ /dev/null @@ -1,56 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -A Combinator for building Pratt parsers --/ -prelude -import init.lean.parser.token - -namespace Lean.Parser -open MonadParsec Combinators - -variables {baseM : Type → Type} -variables [Monad baseM] [monadBasicParser baseM] [MonadParsec Syntax baseM] [MonadReader ParserConfig baseM] - -local notation `m` := RecT Nat Syntax baseM -local notation `Parser` := m Syntax - -def currLbp : m Nat := -do Except.ok tk ← monadLift peekToken | pure 0, - match tk with - | Syntax.atom ⟨_, sym⟩ := do - cfg ← read, - some ⟨_, tkCfg⟩ ← pure (cfg.tokens.oldMatchPrefix sym.mkOldIterator) | error "currLbp: unreachable", - pure tkCfg.lbp - | Syntax.ident _ := pure maxPrec - | Syntax.rawNode {kind := @number, ..} := pure maxPrec - | Syntax.rawNode {kind := @stringLit, ..} := pure maxPrec - | _ := error "currLbp: unknown token kind" - -private def trailingLoop (trailing : ReaderT Syntax m Syntax) (rbp : Nat) : Nat → Syntax → Parser -| 0 _ := error "unreachable" -| (n+1) left := do -lbp ← currLbp, -if rbp < lbp then do - left ← trailing.run left, - trailingLoop n left -else - pure left - -variables [MonadExcept (Parsec.Message Syntax) baseM] [Alternative baseM] -variables (leading : m Syntax) (trailing : ReaderT Syntax m Syntax) (p : m Syntax) - -def prattParser : baseM Syntax := -RecT.runParsec p $ λ rbp, do -left ← leading, -n ← remaining, -trailingLoop trailing rbp (n+1) left - -instance prattParser.tokens [HasTokens leading] [HasTokens trailing] : HasTokens (prattParser leading trailing p) := -⟨HasTokens.tokens leading ++ HasTokens.tokens trailing⟩ -instance prattParser.View : HasView Syntax (prattParser leading trailing p) := -default _ - -end Lean.Parser diff --git a/tmp/new-frontend/parser/rec.lean b/tmp/new-frontend/parser/rec.lean deleted file mode 100644 index 69f4e50d98..0000000000 --- a/tmp/new-frontend/parser/rec.lean +++ /dev/null @@ -1,56 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -Recursion monad transformer --/ -prelude -import init.control.reader init.lean.parser.parsec init.fix - -namespace Lean.Parser - -/-- A small wrapper of `ReaderT` that simplifies introducing and invoking - recursion points in a computation. -/ -def RecT (α δ : Type) (m : Type → Type) (β : Type) := -ReaderT (α → m δ) m β - -namespace RecT -variables {m : Type → Type} {α δ β : Type} [Monad m] -local attribute [reducible] RecT - -/-- Continue at the recursion point stored at `run`. -/ -@[inline] def recurse (a : α) : RecT α δ m δ := -λ f, f a - -/-- Execute `x`, executing `rec a` whenever `recurse a` is called. - After `maxRec` recursion steps, `base` is executed instead. -/ -@[inline] protected def run (x : RecT α δ m β) (base : α → m δ) (rec : α → RecT α δ m δ) : m β := -x (fixCore base (λ a f, rec f a)) - -@[inline] protected def runParsec {γ : Type} [MonadParsec γ m] (x : RecT α δ m β) (rec : α → RecT α δ m δ) : m β := -RecT.run x (λ _, MonadParsec.error "RecT.runParsec: no progress") rec - --- not clear how to auto-derive these given the additional constraints -instance : Monad (RecT α δ m) := inferInstance -instance [Alternative m] : Alternative (RecT α δ m) := inferInstance -instance : HasMonadLift m (RecT α δ m) := inferInstance -instance (ε) [MonadExcept ε m] : MonadExcept ε (RecT α δ m) := inferInstance -instance (μ) [MonadParsec μ m] : MonadParsec μ (RecT α δ m) := -inferInstance --- NOTE: does not allow to vary `m` because of its occurrence in the Reader State -instance [Monad m] : MonadFunctor m m (RecT α δ m) (RecT α δ m) := -inferInstance -end RecT - -class MonadRec (α δ : outParam Type) (m : Type → Type) := -(recurse {} : α → m δ) -export MonadRec (recurse) - -instance MonadRec.trans (α δ m m') [HasMonadLift m m'] [MonadRec α δ m] [Monad m] : MonadRec α δ m' := -{ recurse := λ a, monadLift (recurse a : m δ) } - -instance MonadRec.base (α δ m) [Monad m] : MonadRec α δ (RecT α δ m) := -{ recurse := RecT.recurse } - -end Lean.Parser diff --git a/tmp/new-frontend/parser/stringliteral.lean b/tmp/new-frontend/parser/stringliteral.lean deleted file mode 100644 index 0440387bf3..0000000000 --- a/tmp/new-frontend/parser/stringliteral.lean +++ /dev/null @@ -1,54 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Leonardo de Moura --/ -prelude -import init.lean.parser.parsec - -namespace Lean -namespace Parser -open MonadParsec -variables {m : Type → Type} {μ : Type} [Monad m] [MonadParsec μ m] [Alternative m] - -def parseHexDigit : m Nat := -( (do d ← digit, pure $ d.toNat - '0'.toNat) - <|> (do c ← satisfy (λ c, 'a'.val ≤ c.val && c.val ≤ 'f'.val), pure $ 10 + (c.toNat - 'a'.toNat)) - <|> (do c ← satisfy (λ c, 'A'.val ≤ c.val && c.val ≤ 'F'.val), pure $ 10 + (c.toNat - 'A'.toNat))) - "hexadecimal" - -def parseQuotedChar : m Char := -do it ← leftOver, - c ← any, - if c = '\\' then pure '\\' - else if c = '\"' then pure '\"' - else if c = '\'' then pure '\'' - else if c = 'n' then pure '\n' - else if c = 't' then pure '\t' - else if c = 'x' then do { - d₁ ← parseHexDigit, - d₂ ← parseHexDigit, - pure $ Char.ofNat (16*d₁ + d₂) } - else if c = 'u' then do { - d₁ ← parseHexDigit, - d₂ ← parseHexDigit, - d₃ ← parseHexDigit, - d₄ ← parseHexDigit, - pure $ Char.ofNat (16*(16*(16*d₁ + d₂) + d₃) + d₄) } - else unexpectedAt "quoted character" it - -def parseStringLiteralAux : Nat → String → m String -| 0 s := ch '\"' *> pure s -| (n+1) s := do - c ← any, - if c = '\\' then do c ← parseQuotedChar, parseStringLiteralAux n (s.push c) - else if c = '\"' then pure s - else parseStringLiteralAux n (s.push c) - -def parseStringLiteral : m String := -do ch '\"', - r ← remaining, - parseStringLiteralAux r "" - -end Parser -end Lean diff --git a/tmp/new-frontend/parser/syntax.lean b/tmp/new-frontend/parser/syntax.lean deleted file mode 100644 index 7d30188424..0000000000 --- a/tmp/new-frontend/parser/syntax.lean +++ /dev/null @@ -1,222 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich --/ -prelude -import init.lean.name init.lean.parser.parsec - -namespace Lean -namespace Parser - ---TODO(Sebastian): move -structure Substring := -(start : String.OldIterator) -(stop : String.OldIterator) - -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 : Substring) -(pos : Parsec.Position) -(trailing : Substring) - -structure SyntaxAtom := -(info : Option SourceInfo := none) (val : String) - -/-- A simple wrapper that should remind you to use the static declaration instead - of hard-coding the Node Name. -/ -structure SyntaxNodeKind := --- should be equal to the Name of the declaration this structure instance was bound to -(name : Name) - -/-- Signifies ambiguous Syntax to be disambiguated by the Elaborator. Should have at least two children. - - This Node kind is special-cased by `Syntax.reprint` since its children's outputs should not be concatenated. -/ -@[pattern] def choice : SyntaxNodeKind := ⟨`Lean.Parser.choice⟩ -/-- A nondescriptive kind that can be used for merely grouping Syntax trees into a Node. - - This Node kind is special-cased by `Syntax.Format` to be printed as brackets `[...]` without a Node kind. -/ -@[pattern] def noKind : SyntaxNodeKind := ⟨`Lean.Parser.noKind⟩ - -/-- A hygiene marker introduced by a macro expansion. -/ -@[derive DecidableEq HasFormat] -def MacroScope := Nat -abbrev macroScopes := List MacroScope - -/- -Parsers create `SyntaxNode`'s with the following properties (see implementation of `Combinators.Node`): -- If `args` contains a `Syntax.missing`, then all subsequent elements are also `Syntax.missing`. -- The first argument in `args` is not `Syntax.missing` - -Remark: We do create `SyntaxNode`'s with an Empty `args` field (e.g. for representing `Option.none`). --/ -structure SyntaxNode (Syntax : Type) := -(kind : SyntaxNodeKind) -(args : List Syntax) --- Lazily propagated scopes. Scopes are pushed inwards when a Node is destructed via `Syntax.asNode`, --- until an ident or an atom (in which the scopes vanish) is reached. --- Scopes are stored in a stack with the most recent Scope at the top. -(scopes : macroScopes := []) - -structure SyntaxIdent := -(info : Option SourceInfo := none) -(rawVal : Substring) -(val : Name) -/- A List of overloaded, global names that this identifier could have referred to in the lexical context - where it was parsed. - If the identifier does not resolve to a local binding, it should instead resolve to one of - these preresolved constants. -/ -(preresolved : List Name := []) -(scopes : macroScopes := []) - -inductive Syntax -| atom (val : SyntaxAtom) -| ident (val : SyntaxIdent) --- note: use `Syntax.asNode` instead of matching against this Constructor so that --- macro scopes are propagated -| rawNode (val : SyntaxNode Syntax) -| missing - -instance : Inhabited Syntax := -⟨Syntax.missing⟩ - -def Substring.toString (s : Substring) : String := -s.start.extract s.stop - -def Substring.ofString (s : String) : Substring := -⟨s.mkOldIterator, s.mkOldIterator.toEnd⟩ - -instance Substring.HasToString : HasToString Substring := -⟨Substring.toString⟩ - --- TODO(Sebastian): exhaustively argue why (if?) this is correct --- The basic idea is List concatenation with elimination of adjacent identical scopes -def macroScopes.flip : macroScopes → macroScopes → macroScopes -| ys (x::xs) := match macroScopes.flip ys xs with - | y::ys := if x = y then ys else x::y::ys - | [] := [x] -| ys [] := ys - -namespace Syntax -open Lean.Format - -def flipScopes (scopes : macroScopes) : Syntax → Syntax -| (Syntax.ident n) := Syntax.ident {n with scopes := n.scopes.flip scopes} -| (Syntax.rawNode n) := Syntax.rawNode {n with scopes := n.scopes.flip scopes} -| stx := stx - -def mkNode (kind : SyntaxNodeKind) (args : List Syntax) := -Syntax.rawNode { kind := kind, args := args } - -/-- Match against `Syntax.rawNode`, propagating lazy macro scopes. -/ -def asNode : Syntax → Option (SyntaxNode Syntax) -| (Syntax.rawNode n) := some {n with args := n.args.map (flipScopes n.scopes), scopes := []} -| _ := none - -protected def list (args : List Syntax) := -mkNode noKind args - -def kind : Syntax → Option SyntaxNodeKind -| (Syntax.rawNode n) := some n.kind -| _ := none - -def isOfKind (k : SyntaxNodeKind) : Syntax → Bool -| (Syntax.rawNode n) := k.name = n.kind.name -| _ := false - -section -variables {m : Type → Type} [Monad m] (r : Syntax → m (Option Syntax)) - -partial def mreplace : Syntax → m Syntax -| stx@(rawNode n) := do - o ← r stx, - match o with - | some stx' := pure stx' - | none := do args' ← n.args.mmap mreplace, pure $ rawNode {n with args := args'} -| stx := do - o ← r stx, - pure $ o.getOrElse stx - -def replace := @mreplace Id _ -end - -/- Remark: the State `String.Iterator` is the `SourceInfo.trailing.stop` of the previous token, - or the beginning of the String. -/ -private def updateLeadingAux : Syntax → State String.OldIterator (Option Syntax) -| (atom a@{info := some info, ..}) := do - last ← get, - set info.trailing.stop, - pure $ some $ atom {a with info := some {info with leading := ⟨last, last.nextn (info.pos - last.offset)⟩}} -| (ident id@{info := some info, ..}) := do - last ← get, - set info.trailing.stop, - pure $ some $ ident {id with info := some {info with leading := ⟨last, last.nextn (info.pos - last.offset)⟩}} -| _ := pure none - -/-- Set `SourceInfo.leading` according to the trailing stop of the preceding token. - The Result is a round-tripping Syntax tree IF, in the input Syntax tree, - * all leading stops, atom contents, and trailing starts are correct - * trailing stops are between the trailing start and the next leading stop. - - Remark: after parsing all `SourceInfo.leading` fields are Empty. - The Syntax argument is the output produced by the Parser for `source`. - This Function "fixes" the `source.leanding` field. - - Note that, the `SourceInfo.trailing` fields are correct. - The implementation of this Function relies on this property. -/ -def updateLeading (source : String) : Syntax → Syntax := -λ stx, Prod.fst $ (mreplace updateLeadingAux stx).run source.mkOldIterator - -/-- Retrieve the left-most leaf's info in the Syntax tree. -/ -partial def getHeadInfo : Syntax → Option SourceInfo -| (atom a) := a.info -| (ident id) := id.info -| (rawNode n) := n.args.foldr (λ s r, getHeadInfo s <|> r) none -| _ := none - -def getPos (stx : Syntax) : Option Parsec.Position := -do i ← stx.getHeadInfo, - pure i.pos - -def reprintAtom : SyntaxAtom → String -| ⟨some info, s⟩ := info.leading.toString ++ s ++ info.trailing.toString -| ⟨none, s⟩ := s - -partial def reprint : Syntax → Option String -| (atom ⟨some info, s⟩) := pure $ info.leading.toString ++ s ++ info.trailing.toString -| (atom ⟨none, s⟩) := pure s -| (ident id@{info := some info, ..}) := pure $ info.leading.toString ++ id.rawVal.toString ++ info.trailing.toString -| (ident id@{info := none, ..}) := pure id.rawVal.toString -| (rawNode n) := - if n.kind.name = choice.name then match n.args with - -- should never happen - | [] := failure - -- check that every choice prints the same - | n::ns := do - s ← reprint n, - ss ← ns.mmap reprint, - guard $ ss.all (= s), - pure s - else String.join <$> n.args.mmap reprint -| missing := "" - -protected partial def format : Syntax → Format -| (atom ⟨_, s⟩) := fmt $ repr s -| (ident id) := - let scopes := id.preresolved.map fmt ++ id.scopes.reverse.map fmt in - let scopes := match scopes with [] := fmt "" | _ := bracket "{" (joinSep scopes ", ") "}" in - fmt "`" ++ fmt id.val ++ scopes -| stx@(rawNode n) := - let scopes := match n.scopes with [] := fmt "" | _ := bracket "{" (joinSep n.scopes.reverse ", ") "}" in - if n.kind.name = `Lean.Parser.noKind then sbracket $ scopes ++ joinSep (n.args.map format) line - else let shorterName := n.kind.name.replacePrefix `Lean.Parser Name.anonymous - in paren $ joinSep ((fmt shorterName ++ scopes) :: n.args.map format) line -| missing := "" - -instance : HasFormat Syntax := ⟨Syntax.format⟩ -instance : HasToString Syntax := ⟨toString ∘ fmt⟩ -end Syntax - -end Parser -end Lean diff --git a/tmp/new-frontend/parser/term.lean b/tmp/new-frontend/parser/term.lean deleted file mode 100644 index a92f69cbcc..0000000000 --- a/tmp/new-frontend/parser/term.lean +++ /dev/null @@ -1,455 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -Term-Level parsers --/ -prelude -import init.lean.parser.level init.lean.parser.notation -import init.lean.expr - -namespace Lean -namespace Parser -open Combinators Parser.HasView MonadParsec - -local postfix `?`:10000 := optional -local postfix *:10000 := Combinators.many -local postfix +:10000 := Combinators.many1 - -set_option class.instance_max_depth 200 - -@[derive Parser.HasTokens Parser.HasView] -def identUnivSpec.Parser : basicParser := -node! identUnivSpec [".{", levels: Level.Parser+, "}"] - -@[derive Parser.HasTokens Parser.HasView] -def identUnivs.Parser : termParser := -node! identUnivs [id: ident.Parser, univs: (monadLift identUnivSpec.Parser)?] - -namespace Term -/-- Access leading Term -/ -def getLeading : trailingTermParser := read -instance : HasTokens getLeading := default _ -instance : HasView Syntax getLeading := default _ - -@[derive Parser.HasTokens Parser.HasView] -def paren.Parser : termParser := -node! «paren» ["(":maxPrec, - content: node! parenContent [ - Term: Term.Parser, - special: nodeChoice! parenSpecial { - /- Do not allow trailing comma. Looks a bit weird and would clash with - adding support for tuple sections (https://downloads.haskell.org/~ghc/8.2.1/docs/html/usersGuide/glasgowExts.html#tuple-sections). -/ - tuple: node! tuple [", ", tail: sepBy (Term.Parser 0) (symbol ", ") false], - typed: node! typed [" : ", type: Term.Parser], - }?, - ]?, - ")" -] - -@[derive Parser.HasTokens Parser.HasView] -def hole.Parser : termParser := -node! hole [hole: symbol "_" maxPrec] - -@[derive Parser.HasTokens Parser.HasView] -def sort.Parser : termParser := -nodeChoice! sort {"Sort":maxPrec, "Type":maxPrec} - -@[derive HasTokens HasView] -def typeSpec.Parser : termParser := -node! typeSpec [" : ", type: Term.Parser 0] - -@[derive HasTokens HasView] -def optType.Parser : termParser := -typeSpec.Parser? - -instance optType.viewDefault : HasViewDefault optType.Parser _ none := ⟨⟩ - -section binder -@[derive HasTokens HasView] -def binderIdent.Parser : termParser := -nodeChoice! binderIdent {id: ident.Parser, hole: hole.Parser} - -@[derive HasTokens HasView] -def binderDefault.Parser : termParser := -nodeChoice! binderDefault { - val: node! binderDefaultVal [":=", Term: Term.Parser 0], - tac: node! binderDefaultTac [".", Term: Term.Parser 0], -} - -@[derive HasTokens HasView] -def binderContent.Parser (requireType := false) : termParser := -node! binderContent [ - ids: binderIdent.Parser+, - type: optional typeSpec.Parser requireType, - default: binderDefault.Parser? -] - -@[derive HasTokens HasView] -def simpleBinder.Parser : termParser := -nodeChoice! simpleBinder { - explicit: node! simpleExplicitBinder ["(", id: ident.Parser, " : ", type: Term.Parser 0, right: symbol ")"], - implicit: node! simpleImplicitBinder ["{", id: ident.Parser, " : ", type: Term.Parser 0, right: symbol "}"], - strictImplicit: node! simpleStrictImplicitBinder ["⦃", id: ident.Parser, " : ", type: Term.Parser 0, right: symbol "⦄"], - instImplicit: node! simpleInstImplicitBinder ["[", id: ident.Parser, " : ", type: Term.Parser 0, right: symbol "]"], -} - -def simpleBinder.View.toBinderInfo : simpleBinder.View → (BinderInfo × SyntaxIdent × Syntax) -| (simpleBinder.View.explicit {id := id, type := type}) := (BinderInfo.default, id, type) -| (simpleBinder.View.implicit {id := id, type := type}) := (BinderInfo.implicit, id, type) -| (simpleBinder.View.strictImplicit {id := id, type := type}) := (BinderInfo.strictImplicit, id, type) -| (simpleBinder.View.instImplicit {id := id, type := type}) := (BinderInfo.instImplicit, id, type) - -@[derive Parser.HasTokens Parser.HasView] -def anonymousConstructor.Parser : termParser := -node! anonymousConstructor ["⟨":maxPrec, args: sepBy (Term.Parser 0) (symbol ","), "⟩"] - -/- All binders must be surrounded with some kind of bracket. (e.g., '()', '{}', '[]'). - We use this feature when parsing examples/definitions/theorems. The goal is to avoid counter-intuitive - declarations such as: - - example p : False := trivial - def main proof : False := trivial - - which would be parsed as - - example (p : False) : _ := trivial - - def main (proof : False) : _ := trivial - - where `_` in both cases is elaborated into `True`. This issue was raised by @gebner in the slack channel. - - - Remark: we still want implicit delimiters for lambda/pi expressions. That is, we want to - write - - fun x : t, s - or - fun x, s - - instead of - - fun (x : t), s -/ -@[derive HasTokens HasView] -def bracketedBinder.Parser (requireType := false) : termParser := -nodeChoice! bracketedBinder { - explicit: node! explicitBinder ["(", content: nodeChoice! explicitBinderContent { - «notation»: command.notationLike.Parser, - other: binderContent.Parser requireType - }, right: symbol ")"], - implicit: node! implicitBinder ["{", content: binderContent.Parser, "}"], - strictImplicit: node! strictImplicitBinder ["⦃", content: binderContent.Parser, "⦄"], - instImplicit: node! instImplicitBinder ["[", content: nodeLongestChoice! instImplicitBinderContent { - named: node! instImplicitNamedBinder [id: ident.Parser, " : ", type: Term.Parser 0], - anonymous: node! instImplicitAnonymousBinder [type: Term.Parser 0] - }, "]"], - anonymousConstructor: anonymousConstructor.Parser, -} - -@[derive HasTokens HasView] -def binder.Parser : termParser := -nodeChoice! binder { - bracketed: bracketedBinder.Parser, - unbracketed: binderContent.Parser, -} - -@[derive HasTokens HasView] -def bindersExt.Parser : termParser := -node! bindersExt [ - leadingIds: binderIdent.Parser*, - remainder: nodeChoice! bindersRemainder { - type: node! bindersTypes [":", type: Term.Parser 0], - -- we allow mixing like in `a (b : β) c`, but not `a : α (b : β) c : γ` - mixed: nodeChoice! mixedBinder { - bracketed: bracketedBinder.Parser, - id: binderIdent.Parser, - }+, - }? -] - -/-- We normalize binders to simpler singleton ones during expansion. -/ -@[derive HasTokens HasView] -def binders.Parser : termParser := -nodeChoice! binders { - extended: bindersExt.Parser, - -- a strict subset of `extended`, so only useful after parsing - simple: simpleBinder.Parser, -} - -/-- We normalize binders to simpler ones during expansion. These always-bracketed - binders are used in declarations and cannot be reduced to nested singleton binders. -/ -@[derive HasTokens HasView] -def bracketedBinders.Parser : termParser := -nodeChoice! bracketedBinders { - extended: bracketedBinder.Parser*, - -- a strict subset of `extended`, so only useful after parsing - simple: simpleBinder.Parser*, -} -end binder - -@[derive Parser.HasTokens Parser.HasView] -def lambda.Parser : termParser := -node! lambda [ - op: unicodeSymbol "λ" "fun" maxPrec, - binders: binders.Parser, - ",", - body: Term.Parser 0 -] - -@[derive Parser.HasTokens Parser.HasView] -def assume.Parser : termParser := -node! «assume» [ - "assume ":maxPrec, - binders: nodeChoice! assumeBinders { - anonymous: node! assumeAnonymous [": ", type: Term.Parser], - binders: binders.Parser - }, - ", ", - body: Term.Parser 0 -] - -@[derive Parser.HasTokens Parser.HasView] -def pi.Parser : termParser := -node! pi [ - op: anyOf [unicodeSymbol "Π" "Pi" maxPrec, unicodeSymbol "∀" "forall" maxPrec], - binders: binders.Parser, - ",", - range: Term.Parser 0 -] - -@[derive Parser.HasTokens Parser.HasView] -def explicit.Parser : termParser := -node! explicit [ - mod: nodeChoice! explicitModifier { - explicit: symbol "@" maxPrec, - partialExplicit: symbol "@@" maxPrec - }, - id: identUnivs.Parser -] - -@[derive Parser.HasTokens Parser.HasView] -def from.Parser : termParser := -node! «from» ["from ", proof: Term.Parser] - -@[derive Parser.HasTokens Parser.HasView] -def let.Parser : termParser := -node! «let» [ - "let ", - lhs: nodeChoice! letLhs { - id: node! letLhsId [ - id: ident.Parser, - -- NOTE: after expansion, binders are Empty - binders: bracketedBinder.Parser*, - type: optType.Parser, - ], - pattern: Term.Parser - }, - " := ", - value: Term.Parser, - " in ", - body: Term.Parser, -] - -@[derive Parser.HasTokens Parser.HasView] -def optIdent.Parser : termParser := -(try node! optIdent [id: ident.Parser, " : "])? - -@[derive Parser.HasTokens Parser.HasView] -def have.Parser : termParser := -node! «have» [ - "have ", - id: optIdent.Parser, - prop: Term.Parser, - proof: nodeChoice! haveProof { - Term: node! haveTerm [" := ", Term: Term.Parser], - «from»: node! haveFrom [", ", «from»: from.Parser], - }, - ", ", - body: Term.Parser, -] - -@[derive Parser.HasTokens Parser.HasView] -def show.Parser : termParser := -node! «show» [ - "show ", - prop: Term.Parser, - ", ", - «from»: from.Parser, -] - -@[derive Parser.HasTokens Parser.HasView] -def match.Parser : termParser := -node! «match» [ - "match ", - scrutinees: sepBy1 Term.Parser (symbol ", ") false, - type: optType.Parser, - " with ", - optBar: (symbol " | ")?, - equations: sepBy1 - node! «matchEquation» [ - lhs: sepBy1 Term.Parser (symbol ", ") false, ":=", rhs: Term.Parser] - (symbol " | ") false, -] - -@[derive Parser.HasTokens Parser.HasView] -def if.Parser : termParser := -node! «if» [ - "if ", - id: optIdent.Parser, - prop: Term.Parser, - " then ", - thenBranch: Term.Parser, - " else ", - elseBranch: Term.Parser, -] - -@[derive Parser.HasTokens Parser.HasView] -def structInst.Parser : termParser := -node! structInst [ - "{":maxPrec, - type: (try node! structInstType [id: ident.Parser, " . "])?, - «with»: (try node! structInstWith [source: Term.Parser, " with "])?, - items: sepBy nodeChoice! structInstItem { - field: node! structInstField [id: ident.Parser, " := ", val: Term.Parser], - source: node! structInstSource ["..", source: Term.Parser?], - } (symbol ", "), - "}", -] - -@[derive Parser.HasTokens Parser.HasView] -def Subtype.Parser : termParser := -node! Subtype [ - "{":maxPrec, - id: ident.Parser, - type: optType.Parser, - "//", - prop: Term.Parser, - "}" -] - -@[derive Parser.HasTokens Parser.HasView] -def inaccessible.Parser : termParser := -node! inaccessible [".(":maxPrec, Term: Term.Parser, ")"] - -@[derive Parser.HasTokens Parser.HasView] -def anonymousInaccessible.Parser : termParser := -node! anonymousInaccessible ["._":maxPrec] - -@[derive Parser.HasTokens Parser.HasView] -def sorry.Parser : termParser := -node! «sorry» ["sorry":maxPrec] - -def borrowPrec := maxPrec - 1 -@[derive Parser.HasTokens Parser.HasView] -def borrowed.Parser : termParser := -node! borrowed ["@&":maxPrec, Term: Term.Parser borrowPrec] - ---- Agda's `(x : e) → f` -@[derive Parser.HasTokens Parser.HasView] -def depArrow.Parser : termParser := -node! depArrow [binder: bracketedBinder.Parser true, op: unicodeSymbol "→" "->" 25, range: Term.Parser 24] - --- TODO(Sebastian): replace with attribute -@[derive HasTokens] -def builtinLeadingParsers : TokenMap termParser := TokenMap.ofList [ - (`ident, identUnivs.Parser), - (number.name, number.Parser), - (stringLit.name, stringLit.Parser), - ("(", paren.Parser), - ("(", depArrow.Parser), - ("_", hole.Parser), - ("Sort", sort.Parser), - ("Type", sort.Parser), - ("λ", lambda.Parser), - ("fun", lambda.Parser), - ("Π", pi.Parser), - ("Pi", pi.Parser), - ("∀", pi.Parser), - ("forall", pi.Parser), - ("⟨", anonymousConstructor.Parser), - ("@", explicit.Parser), - ("@@", explicit.Parser), - ("let", let.Parser), - ("have", have.Parser), - ("show", show.Parser), - ("assume", assume.Parser), - ("match", match.Parser), - ("if", if.Parser), - ("{", structInst.Parser), - ("{", Subtype.Parser), - ("{", depArrow.Parser), - ("[", depArrow.Parser), - (".(", inaccessible.Parser), - ("._", anonymousInaccessible.Parser), - ("sorry", sorry.Parser), - ("@&", borrowed.Parser) -] - -@[derive Parser.HasTokens Parser.HasView] -def sortApp.Parser : trailingTermParser := -do { l ← getLeading, guard $ l.isOfKind sort } *> -node! sortApp [fn: getLeading, Arg: monadLift (Level.Parser maxPrec).run] - -@[derive Parser.HasTokens Parser.HasView] -def app.Parser : trailingTermParser := -node! app [fn: getLeading, Arg: Term.Parser maxPrec] - -def mkApp (fn : Syntax) (args : List Syntax) : Syntax := -args.foldl (λ fn Arg, Syntax.mkNode app [fn, Arg]) fn - -@[derive Parser.HasTokens Parser.HasView] -def arrow.Parser : trailingTermParser := -node! arrow [dom: getLeading, op: unicodeSymbol "→" "->" 25, range: Term.Parser 24] - -@[derive Parser.HasView] -def projection.Parser : trailingTermParser := -try $ node! projection [ - Term: getLeading, - -- do not consume trailing whitespace - «.»: rawStr ".", - proj: nodeChoice! projectionSpec { - id: Parser.ident.Parser, - num: number.Parser, - }, -] - --- register '.' manually because of `rawStr` -instance projection.tokens : HasTokens projection.Parser := -/- Use maxPrec + 1 so that it bind more tightly than application: - `a (b).c` should be parsed as `a ((b).c)`. -/ -⟨[{«prefix» := ".", lbp := maxPrec.succ}]⟩ - -@[derive HasTokens] -def builtinTrailingParsers : TokenMap trailingTermParser := TokenMap.ofList [ - ("→", arrow.Parser), - ("->", arrow.Parser), - (".", projection.Parser) -] - -end Term - -private def trailing (cfg : CommandParserConfig) : trailingTermParser := --- try local parsers first, starting with the newest one -(do ps ← indexed cfg.localTrailingTermParsers, ps.foldr (<|>) (error "")) -<|> --- next try all non-local parsers -(do ps ← indexed cfg.trailingTermParsers, longestMatch ps) -<|> --- The application parsers should only be tried as a fall-back; --- e.g. `a + b` should not be parsed as `a (+ b)`. --- TODO(Sebastian): We should be able to remove this workaround using --- the proposed more robust precedence handling -anyOf [Term.sortApp.Parser, Term.app.Parser] - -private def leading (cfg : CommandParserConfig) : termParser := -(do ps ← indexed cfg.localLeadingTermParsers, ps.foldr (<|>) (error "")) -<|> -(do ps ← indexed cfg.leadingTermParsers, longestMatch ps) - -def termParser.run (p : termParser) : commandParser := -do cfg ← read, - adaptReader coe $ prattParser (leading cfg) (trailing cfg) p - -end Parser -end Lean diff --git a/tmp/new-frontend/parser/token.lean b/tmp/new-frontend/parser/token.lean deleted file mode 100644 index c1dc404260..0000000000 --- a/tmp/new-frontend/parser/token.lean +++ /dev/null @@ -1,379 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich - -Tokenizer for the Lean language - -Even though our Parser architecture does not statically depend on a tokenizer but works directly on -the input String, we still use a "tokenizer" Parser in the Lean Parser in some circumstances: -* to distinguish between identifiers and keywords -* for error recovery: advance until next command token -* ...? --/ - -prelude -import init.lean.parser.combinators init.lean.parser.stringliteral - -namespace Lean -namespace Parser -open MonadParsec Combinators String HasView - -def matchToken : BasicParserM (Option TokenConfig) := -do cfg ← read, - it ← leftOver, - pure $ Prod.snd <$> cfg.tokens.oldMatchPrefix it - -private def finishCommentBlockAux : Nat → Nat → BasicParserM Unit -| nesting (n+1) := - str "/-" *> finishCommentBlockAux (nesting + 1) n - <|> - str "-/" *> (if nesting = 1 then pure () else finishCommentBlockAux (nesting - 1) n) - <|> - any *> finishCommentBlockAux nesting n -| _ _ := error "unreachable" - -def finishCommentBlock (nesting := 1) : BasicParserM Unit := -do r ← remaining, - finishCommentBlockAux nesting (r+1) "end of comment block" - -private def whitespaceAux : Nat → BasicParserM Unit -| (n+1) := -do whitespace, - str "--" *> takeWhile' (≠ '\n') *> whitespaceAux n - <|> - -- a "/--" doc comment is an actual token, not whitespace - try (str "/-" *> notFollowedBy (str "-")) *> finishCommentBlock *> whitespaceAux n - <|> - pure () -| 0 := error "unreachable" - -variables {m : Type → Type} -local notation `Parser` := m Syntax -local notation `lift` := @monadLift BasicParserM _ _ _ - -/-- Skip whitespace and comments. -/ -def whitespace : BasicParserM Unit := -hidden $ do - start ← leftOver, - -- every `whitespaceAux` loop reads at least one Char - whitespaceAux (start.remaining+1) - -section -variables [Monad m] [MonadParsec Syntax m] - -@[inline] def asSubstring {α : Type} (p : m α) : m Substring := -do start ← leftOver, - p, - stop ← leftOver, - pure ⟨start, stop⟩ - -variables [monadBasicParser m] - -@[specialize] def updateLast (f : Syntax → Syntax) (trailing : Substring) : List Syntax → List Syntax -| [] := [] -| [stx] := [f stx] -| (stx::stxs) := stx :: updateLast stxs - -private partial def updateTrailing : Substring → Syntax → Syntax -| trailing (Syntax.atom a@⟨some info, _⟩) := Syntax.atom {a with info := some {info with trailing := trailing}} -| trailing (Syntax.ident id@{info := some info, ..}) := Syntax.ident {id with info := some {info with trailing := trailing}} -| trailing (Syntax.rawNode n) := Syntax.rawNode {n with args := updateLast (updateTrailing trailing) trailing n.args} -| trailing stx := stx - -def withTrailing (stx : Syntax) : m Syntax := -do -- TODO(Sebastian): less greedy, more natural whitespace assignment - -- E.g. only read up to the next line break - trailing ← lift $ asSubstring $ whitespace, - pure $ updateTrailing trailing stx - -def mkRawRes (start stop : String.OldIterator) : Syntax := -let ss : Substring := ⟨start, stop⟩ in -Syntax.atom ⟨some {leading := ⟨start, start⟩, pos := start.offset, trailing := ⟨stop, stop⟩}, ss.toString⟩ - -/-- Match an arbitrary Parser and return the consumed String in a `Syntax.atom`. -/ -@[inline] def raw {α : Type} (p : m α) (trailingWs := false) : Parser := do - start ← leftOver, - p, - stop ← leftOver, - let stx := mkRawRes start stop, - if trailingWs then withTrailing stx else pure stx - -instance raw.tokens {α} (p : m α) (t) : Parser.HasTokens (raw p t : Parser) := default _ -instance raw.view {α} (p : m α) (t) : Parser.HasView (Option SyntaxAtom) (raw p t : Parser) := -{ view := λ stx, match stx with - | Syntax.atom atom := some atom - | _ := none, - review := λ a, (Syntax.atom <$> a).getOrElse Syntax.missing } - -/-- Like `raw (str s)`, but default to `s` in views. -/ -@[inline, derive HasTokens HasView] -def rawStr (s : String) (trailingWs := false) : Parser := -raw (str s) trailingWs - -instance rawStr.viewDefault (s) (t) : Parser.HasViewDefault (rawStr s t : Parser) (Option SyntaxAtom) (some {val := s}) := -⟨⟩ - -end - -set_option class.instance_max_depth 200 - -@[derive HasTokens HasView] -def detailIdentPart.Parser : BasicParserM Syntax := -nodeChoice! detailIdentPart { - escaped: node! detailIdentPartEscaped [ - escBegin: rawStr idBeginEscape.toString, - escaped: raw $ takeUntil1 isIdEndEscape, - escEnd: rawStr idEndEscape.toString, - ], - default: raw $ satisfy isIdFirst *> takeWhile isIdRest -} - -@[derive HasTokens HasView] -def detailIdentSuffix.Parser : RecT Unit Syntax BasicParserM Syntax := --- consume '.' only when followed by a character starting an detailIdentPart -try (lookahead (ch '.' *> (ch idBeginEscape <|> satisfy isIdFirst))) -*> node! detailIdentSuffix [«.»: rawStr ".", ident: recurse ()] - -def detailIdent' : RecT Unit Syntax BasicParserM Syntax := -node! detailIdent [part: monadLift detailIdentPart.Parser, suffix: optional detailIdentSuffix.Parser] - -/-- A Parser that gives a more detailed View of `SyntaxIdent.rawVal`. Not used by default for - performance reasons. -/ -def detailIdent.Parser : BasicParserM Syntax := -RecT.runParsec detailIdent' $ λ _, detailIdent' - -private def ident' : basicParser := -do - start ← leftOver, - s ← idPart, - n ← foldl Name.mkString (mkSimpleName s) $ do { - -- consume '.' only when followed by a character starting an detailIdentPart - try (lookahead (ch '.' *> (ch idBeginEscape <|> satisfy isIdFirst))), - ch '.', - idPart - }, - stop ← leftOver, - pure $ Syntax.ident { - info := some {leading := ⟨start, start⟩, pos := start.offset, trailing := ⟨stop, stop⟩}, - rawVal := ⟨start, stop⟩, - val := n - } - --- the Node macro doesn't seem to like these... ---TODO(Sebastian): these should probably generate better error messages -def parseBinLit : BasicParserM Unit := -ch '0' *> (ch 'b' <|> ch 'B') *> many1' (ch '0' <|> ch '1') - -def parseOctLit : BasicParserM String := -ch '0' *> (ch 'o' <|> ch 'O') *> takeWhile1 (λ c, c ≥ '0' && c < '8') - -def parseHexLit : BasicParserM String := -ch '0' *> (ch 'x' <|> ch 'X') *> takeWhile1 (λ c, c.isDigit || c.isAlpha) - ---TODO(Sebastian): other bases -def number' : basicParser := -nodeLongestChoice! number { - base10: raw $ takeWhile1 Char.isDigit, - base2: raw parseBinLit, - base8: raw parseOctLit, - base16: raw parseHexLit, -} - -def stringLit' : basicParser := -node! stringLit [val: raw parseStringLiteral] - -private def mkConsumeToken (tk : TokenConfig) (it : String.OldIterator) : basicParser := -let it' := it.nextn tk.prefix.length in -MonadParsec.lift $ λ _, Parsec.Result.ok (mkRawRes it it') it' none - -def numberOrStringLit : basicParser := -number' <|> stringLit' - -def tokenCont (it : String.OldIterator) (tk : TokenConfig) : basicParser := -do id ← ident', - it' ← leftOver, - -- if a token is both a symbol and a valid identifier (i.e. a keyword), - -- we want it to be recognized as a symbol - if it.offset + tk.prefix.length ≥ it'.offset then - mkConsumeToken tk it - else pure id - -def token : basicParser := -do it ← leftOver, - cache ← getCache, - -- NOTE: using `catch` instead of `<|>` so that error messages from the second block are preferred - catch (do - -- check token cache - some tkc ← pure cache.tokenCache | failure, - guard (it.offset = tkc.startIt.offset), - -- hackishly update Parsec Position - MonadParsec.lift (λ it, Parsec.Result.ok () tkc.stopIt none), - putCache {cache with hit := cache.hit + 1}, - pure tkc.tk - ) (λ _, do - -- cache failed, update cache - - identStart ← observing $ lookahead (satisfy isIdFirst <|> ch idBeginEscape), - tk ← matchToken, - tk ← match tk, identStart with - | some tk@{suffixParser := some _, ..}, _ := - error "token: not implemented" --str tk *> MonadParsec.lift r - | some tk, Except.ok _ := tokenCont it tk - | some tk, Except.error _ := mkConsumeToken tk it - | none, Except.ok _ := ident' - | none, Except.error _ := numberOrStringLit, - tk ← withTrailing tk, - newIt ← leftOver, - putCache {cache with tokenCache := some ⟨it, newIt, tk⟩, miss := cache.miss + 1}, - pure tk - ) - -def peekToken : BasicParserM (Except (Parsec.Message Syntax) Syntax) := -observing (try (lookahead token)) - -variable [monadBasicParser m] - -def symbolCore (sym : String) (lbp : Nat) (ex : DList String) : Parser := -lift $ try $ do { - it ← leftOver, - stx@(Syntax.atom ⟨_, sym'⟩) ← token | error "" ex it, - when (sym ≠ sym') $ - error sym' ex it, - pure stx -} sym - -@[inline] def symbol (sym : String) (lbp := 0) : Parser := -let sym := sym.trim in -symbolCore sym lbp (DList.singleton sym) - -instance symbol.tokens (sym lbp) : Parser.HasTokens (symbol sym lbp : Parser) := -⟨[⟨sym.trim, lbp, none⟩]⟩ -instance symbol.View (sym lbp) : Parser.HasView (Option SyntaxAtom) (symbol sym lbp : Parser) := -{ view := λ stx, match stx with - | Syntax.atom atom := some atom - | _ := none, - review := λ a, (Syntax.atom <$> a).getOrElse Syntax.missing } -instance symbol.viewDefault (sym lbp) : Parser.HasViewDefault (symbol sym lbp : Parser) _ - (some {info := none, val := sym.trim}) := ⟨⟩ - -def number.Parser : Parser := -lift $ try $ do { - it ← leftOver, - stx ← token, - if stx.isOfKind number then pure stx - else error "" (DList.singleton "number") it -} - -instance number.Parser.tokens : Parser.HasTokens (number.Parser : Parser) := default _ -instance number.Parser.view : Parser.HasView number.View (number.Parser : Parser) := -{..number.HasView} - -private def toNatCore (base : Nat) : String.OldIterator → Nat → Nat → Nat -| it 0 r := r -| it (i+1) r := - let c := it.curr in - let val := if c.isDigit then - c.toNat - '0'.toNat - else if c ≥ 'a' ∧ c ≤ 'f' then - c.toNat - 'a'.toNat - else - c.toNat - 'A'.toNat in - let r := r*base + val in - toNatCore it.next i r - -private def toNatBase (s : String) (base : Nat) : Nat := -toNatCore base s.mkOldIterator s.length 0 - -def number.View.toNat : number.View → Nat -| (number.View.base10 (some atom)) := atom.val.toNat -| (number.View.base2 (some atom)) := toNatBase atom.val 2 -| (number.View.base8 (some atom)) := toNatBase atom.val 8 -| (number.View.base16 (some atom)) := toNatBase atom.val 16 -| _ := 1138 -- should never happen, but let's still choose a grep-able number - -def number.View.ofNat (n : Nat) : number.View := -number.View.base10 (some {val := toString n}) - -def stringLit.Parser : Parser := -lift $ try $ do { - it ← leftOver, - stx ← token, - some _ ← pure $ tryView stringLit stx | error "" (DList.singleton "String") it, - pure stx -} "String" - -instance stringLit.Parser.tokens : Parser.HasTokens (stringLit.Parser : Parser) := default _ -instance stringLit.Parser.View : Parser.HasView stringLit.View (stringLit.Parser : Parser) := -{..stringLit.HasView} - -def stringLit.View.value (lit : stringLit.View) : Option String := do - atom ← lit.val, - Except.ok s ← pure $ Parsec.parse (parseStringLiteral : Parsec' _) atom.val - | failure, - pure s - -def ident.Parser : Parser := -lift $ try $ do { - it ← leftOver, - stx@(Syntax.ident _) ← token | error "" (DList.singleton "identifier") it, - pure stx -} "identifier" - -instance ident.Parser.tokens : Parser.HasTokens (ident.Parser : Parser) := default _ -instance ident.Parser.View : Parser.HasView SyntaxIdent (ident.Parser : Parser) := -{ view := λ stx, match stx with - | Syntax.ident id := id - | _ := {rawVal := Substring.ofString "NOTAnIdent", val := `NOTAnIdent}, - review := Syntax.ident } - -/-- Read identifier without consulting the token table. -/ -def rawIdent.Parser : Parser := -lift $ ident' >>= withTrailing - -instance rawIdent.Parser.tokens : Parser.HasTokens (rawIdent.Parser : Parser) := default _ -instance rawIdent.Parser.View : Parser.HasView SyntaxIdent (rawIdent.Parser : Parser) := -{..(ident.Parser.View : HasView _ (_ : Parser))} - -/-- Check if the following token is the symbol _or_ identifier `sym`. Useful for - parsing local tokens that have not been added to the token table (but may have - been so by some unrelated code). - - For example, the universe `max` Function is parsed using this Combinator so that - it can still be used as an identifier outside of universes (but registering it - as a token in a Term Syntax would not break the universe Parser). -/ -def symbolOrIdent (sym : String) : Parser := -lift $ try $ do - it ← leftOver, - stx ← token, - let sym' := match stx with - | Syntax.atom ⟨_, sym'⟩ := some sym' - | Syntax.ident id := some id.rawVal.toString - | _ := none, - when (sym' ≠ some sym) $ - error "" (DList.singleton (repr sym)) it, - pure stx - -instance symbolOrIdent.tokens (sym) : Parser.HasTokens (symbolOrIdent sym : Parser) := -default _ -instance symbolOrIdent.View (sym) : Parser.HasView Syntax (symbolOrIdent sym : Parser) := default _ - -/-- A unicode symbol with an ASCII fallback -/ -@[derive HasTokens HasView] -def unicodeSymbol (unicode ascii : String) (lbp := 0) : Parser := -lift $ anyOf [symbol unicode lbp, symbol ascii lbp] --- use unicode variant by default -instance unicodeSymbol.viewDefault (u a lbp) : Parser.HasViewDefault (unicodeSymbol u a lbp : Parser) _ (Syntax.atom ⟨none, u⟩) := ⟨⟩ - -def indexed {α : Type} (map : TokenMap α) : m (List α) := -lift $ do - Except.ok tk ← peekToken | error "", - n ← match tk with - | Syntax.atom ⟨_, s⟩ := pure $ mkSimpleName s - | Syntax.ident _ := pure `ident - | Syntax.rawNode n := pure n.kind.name - | _ := error "", - Option.toMonad $ map.find n - -end «Parser» -end Lean diff --git a/tmp/new-frontend/parser/trie.lean b/tmp/new-frontend/parser/trie.lean deleted file mode 100644 index 16b4baad8a..0000000000 --- a/tmp/new-frontend/parser/trie.lean +++ /dev/null @@ -1,109 +0,0 @@ -/- -Copyright (c) 2018 Microsoft Corporation. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Author: Sebastian Ullrich, Leonardo de Moura - -Trie for tokenizing the Lean language --/ -prelude -import init.data.rbmap -import init.lean.format init.lean.parser.parsec - -namespace Lean -namespace Parser - -inductive Trie (α : Type) -| Node : Option α → RBNode Char (λ _, Trie) → Trie - -namespace Trie -variables {α : Type} - -def empty : Trie α := -⟨none, RBNode.leaf⟩ - -instance : HasEmptyc (Trie α) := -⟨empty⟩ - -instance : Inhabited (Trie α) := -⟨Node none RBNode.leaf⟩ - -private partial def insertEmptyAux (s : String) (val : α) : String.Pos → Trie α -| i := match s.atEnd i with - | true := Trie.Node (some val) RBNode.leaf - | false := - let c := s.get i in - let t := insertEmptyAux (s.next i) in - Trie.Node none (RBNode.singleton c t) - -private partial def insertAux (s : String) (val : α) : Trie α → String.Pos → Trie α -| (Trie.Node v m) i := - match s.atEnd i with - | true := Trie.Node (some val) m -- overrides old value - | false := - let c := s.get i in - let i := s.next i in - let t := match RBNode.find Char.lt m c with - | none := insertEmptyAux s val i - | some t := insertAux t i in - Trie.Node v (RBNode.insert Char.lt m c t) - -def insert (t : Trie α) (s : String) (val : α) : Trie α := -insertAux s val t 0 - -private partial def findAux (s : String) : Trie α → String.Pos → Option α -| (Trie.Node val m) i := - match s.atEnd i with - | true := val - | false := - let c := s.get i in - let i := s.next i in - match RBNode.find Char.lt m c with - | none := none - | some t := findAux t i - -def find (t : Trie α) (s : String) : Option α := -findAux s t 0 - -private def updtAcc (v : Option α) (i : String.Pos) (acc : String.Pos × Option α) : String.Pos × Option α := -match v, acc with -| some v, (j, w) := (i, some v) -- we pattern match on `acc` to enable memory reuse -| none, acc := acc - -private partial def matchPrefixAux (s : String) : Trie α → String.Pos → (String.Pos × Option α) → String.Pos × Option α -| (Trie.Node v m) i acc := - match s.atEnd i with - | true := updtAcc v i acc - | false := - let acc := updtAcc v i acc in - let c := s.get i in - let i := s.next i in - match RBNode.find Char.lt m c with - | some t := matchPrefixAux t i acc - | none := acc - -def matchPrefix (s : String) (t : Trie α) (i : String.Pos) : String.Pos × Option α := -matchPrefixAux s t i (i, none) - --- TODO: delete -private def oldMatchPrefixAux : Nat → Trie α → String.OldIterator → Option (String.OldIterator × α) → Option (String.OldIterator × α) -| 0 (Trie.Node val map) it Acc := Prod.mk it <$> val <|> Acc -| (n+1) (Trie.Node val map) it Acc := - let Acc' := Prod.mk it <$> val <|> Acc in - match RBNode.find Char.lt map it.curr with - | some t := oldMatchPrefixAux n t it.next Acc' - | none := Acc' - --- TODO: delete -def oldMatchPrefix {α : Type} (t : Trie α) (it : String.OldIterator) : Option (String.OldIterator × α) := -oldMatchPrefixAux it.remaining t it none - -private partial def toStringAux {α : Type} : Trie α → List Format -| (Trie.Node val map) := map.fold (λ Fs c t, - format (repr c) :: (Format.group $ Format.nest 2 $ flip Format.joinSep Format.line $ toStringAux t) :: Fs) [] - -instance {α : Type} : HasToString (Trie α) := -⟨λ t, (flip Format.joinSep Format.line $ toStringAux t).pretty⟩ -end Trie - -end Parser -end Lean