refactor: implement attribute hooks using CoreM
We were using a mix of `IO` and `Except`
This commit is contained in:
Leonardo de Moura
parent
75e6b5b379
commit
68a4c145f7
16 changed files with 168 additions and 146 deletions
|
|
@ -5,6 +5,7 @@ Authors: Leonardo de Moura
|
|||
-/
|
||||
import Lean.Scopes
|
||||
import Lean.Syntax
|
||||
import Lean.CoreM
|
||||
|
||||
namespace Lean
|
||||
|
||||
|
|
@ -25,7 +26,7 @@ instance AttributeApplicationTime.hasBeq : HasBeq AttributeApplicationTime :=
|
|||
structure AttributeImpl :=
|
||||
(name : Name)
|
||||
(descr : String)
|
||||
(add (env : Environment) (decl : Name) (args : Syntax) (persistent : Bool) : IO Environment)
|
||||
(add (decl : Name) (args : Syntax) (persistent : Bool) : CoreM Unit)
|
||||
/-
|
||||
(addScoped (env : Environment) (decl : Name) (args : Syntax) : IO Environment
|
||||
:= throw (IO.userError ("attribute '" ++ toString name ++ "' does not support scopes")))
|
||||
|
|
@ -38,7 +39,7 @@ structure AttributeImpl :=
|
|||
(applicationTime := AttributeApplicationTime.afterTypeChecking)
|
||||
|
||||
instance AttributeImpl.inhabited : Inhabited AttributeImpl :=
|
||||
⟨{ name := arbitrary _, descr := arbitrary _, add := fun env _ _ _ => pure env }⟩
|
||||
⟨{ name := arbitrary _, descr := arbitrary _, add := fun env _ _ _ => pure () }⟩
|
||||
|
||||
open Std (PersistentHashMap)
|
||||
|
||||
|
|
@ -190,7 +191,8 @@ namespace Environment
|
|||
@[export lean_add_attribute]
|
||||
def addAttribute (env : Environment) (decl : Name) (attrName : Name) (args : Syntax := Syntax.missing) (persistent := true) : IO Environment := do
|
||||
attr ← IO.ofExcept $ getAttributeImpl env attrName;
|
||||
attr.add env decl args persistent
|
||||
(env, _) ← Core.runCore (attr.add decl args persistent) env;
|
||||
pure env
|
||||
|
||||
/-
|
||||
/- Add a scoped attribute `attr` to declaration `decl` with arguments `args` and scope `decl.getPrefix`.
|
||||
|
|
@ -262,7 +264,7 @@ structure TagAttribute :=
|
|||
(attr : AttributeImpl)
|
||||
(ext : PersistentEnvExtension Name Name NameSet)
|
||||
|
||||
def registerTagAttribute (name : Name) (descr : String) (validate : Environment → Name → Except String Unit := fun _ _ => Except.ok ()) : IO TagAttribute := do
|
||||
def registerTagAttribute (name : Name) (descr : String) (validate : Name → CoreM Unit := fun _ => pure ()) : IO TagAttribute := do
|
||||
ext : PersistentEnvExtension Name Name NameSet ← registerPersistentEnvExtension {
|
||||
name := name,
|
||||
mkInitial := pure {},
|
||||
|
|
@ -276,14 +278,14 @@ ext : PersistentEnvExtension Name Name NameSet ← registerPersistentEnvExtensio
|
|||
let attrImpl : AttributeImpl := {
|
||||
name := name,
|
||||
descr := descr,
|
||||
add := fun env decl args persistent => do
|
||||
when args.hasArgs $ throw (IO.userError ("invalid attribute '" ++ toString name ++ "', unexpected argument"));
|
||||
unless persistent $ throw (IO.userError ("invalid attribute '" ++ toString name ++ "', must be persistent"));
|
||||
add := fun decl args persistent => do
|
||||
when args.hasArgs $ Core.throwError ("invalid attribute '" ++ toString name ++ "', unexpected argument");
|
||||
unless persistent $ Core.throwError ("invalid attribute '" ++ toString name ++ "', must be persistent");
|
||||
env ← Core.getEnv;
|
||||
unless (env.getModuleIdxFor? decl).isNone $
|
||||
throw (IO.userError ("invalid attribute '" ++ toString name ++ "', declaration is in an imported module"));
|
||||
match validate env decl with
|
||||
| Except.error msg => throw (IO.userError ("invalid attribute '" ++ toString name ++ "', " ++ msg))
|
||||
| _ => pure $ ext.addEntry env decl
|
||||
Core.throwError ("invalid attribute '" ++ toString name ++ "', declaration is in an imported module");
|
||||
validate decl;
|
||||
Core.setEnv $ ext.addEntry env decl
|
||||
};
|
||||
registerBuiltinAttribute attrImpl;
|
||||
pure { attr := attrImpl, ext := ext }
|
||||
|
|
@ -310,8 +312,8 @@ structure ParametricAttribute (α : Type) :=
|
|||
(ext : PersistentEnvExtension (Name × α) (Name × α) (NameMap α))
|
||||
|
||||
def registerParametricAttribute {α : Type} [Inhabited α] (name : Name) (descr : String)
|
||||
(getParam : Environment → Name → Syntax → Except String α)
|
||||
(afterSet : Environment → Name → α → Except String Environment := fun env _ _ => Except.ok env)
|
||||
(getParam : Name → Syntax → CoreM α)
|
||||
(afterSet : Name → α → CoreM Unit := fun env _ _ => pure ())
|
||||
(appTime := AttributeApplicationTime.afterTypeChecking)
|
||||
: IO (ParametricAttribute α) := do
|
||||
ext : PersistentEnvExtension (Name × α) (Name × α) (NameMap α) ← registerPersistentEnvExtension {
|
||||
|
|
@ -328,17 +330,15 @@ let attrImpl : AttributeImpl := {
|
|||
name := name,
|
||||
descr := descr,
|
||||
applicationTime := appTime,
|
||||
add := fun env decl args persistent => do
|
||||
unless persistent $ throw (IO.userError ("invalid attribute '" ++ toString name ++ "', must be persistent"));
|
||||
add := fun decl args persistent => do
|
||||
unless persistent $ Core.throwError ("invalid attribute '" ++ toString name ++ "', must be persistent");
|
||||
env ← Core.getEnv;
|
||||
unless (env.getModuleIdxFor? decl).isNone $
|
||||
throw (IO.userError ("invalid attribute '" ++ toString name ++ "', declaration is in an imported module"));
|
||||
match getParam env decl args with
|
||||
| Except.error msg => throw (IO.userError ("invalid attribute '" ++ toString name ++ "', " ++ msg))
|
||||
| Except.ok val => do
|
||||
let env := ext.addEntry env (decl, val);
|
||||
match afterSet env decl val with
|
||||
| Except.error msg => throw (IO.userError ("invalid attribute '" ++ toString name ++ "', " ++ msg))
|
||||
| Except.ok env => pure env
|
||||
Core.throwError ("invalid attribute '" ++ toString name ++ "', declaration is in an imported module");
|
||||
val ← getParam decl args;
|
||||
let env' := ext.addEntry env (decl, val);
|
||||
Core.setEnv env';
|
||||
catch (afterSet decl val) (fun _ => Core.setEnv env)
|
||||
};
|
||||
registerBuiltinAttribute attrImpl;
|
||||
pure { attr := attrImpl, ext := ext }
|
||||
|
|
@ -373,7 +373,9 @@ structure EnumAttributes (α : Type) :=
|
|||
(attrs : List AttributeImpl)
|
||||
(ext : PersistentEnvExtension (Name × α) (Name × α) (NameMap α))
|
||||
|
||||
def registerEnumAttributes {α : Type} [Inhabited α] (extName : Name) (attrDescrs : List (Name × String × α)) (validate : Environment → Name → α → Except String Unit := fun _ _ _ => Except.ok ()) (applicationTime := AttributeApplicationTime.afterTypeChecking) : IO (EnumAttributes α) := do
|
||||
def registerEnumAttributes {α : Type} [Inhabited α] (extName : Name) (attrDescrs : List (Name × String × α))
|
||||
(validate : Name → α → CoreM Unit := fun _ _ => pure ())
|
||||
(applicationTime := AttributeApplicationTime.afterTypeChecking) : IO (EnumAttributes α) := do
|
||||
ext : PersistentEnvExtension (Name × α) (Name × α) (NameMap α) ← registerPersistentEnvExtension {
|
||||
name := extName,
|
||||
mkInitial := pure {},
|
||||
|
|
@ -388,13 +390,13 @@ let attrs := attrDescrs.map $ fun ⟨name, descr, val⟩ => {
|
|||
name := name,
|
||||
descr := descr,
|
||||
applicationTime := applicationTime,
|
||||
add := (fun env decl args persistent => do
|
||||
unless persistent $ throw (IO.userError ("invalid attribute '" ++ toString name ++ "', must be persistent"));
|
||||
add := (fun decl args persistent => do
|
||||
unless persistent $ Core.throwError ("invalid attribute '" ++ toString name ++ "', must be persistent");
|
||||
env ← Core.getEnv;
|
||||
unless (env.getModuleIdxFor? decl).isNone $
|
||||
throw (IO.userError ("invalid attribute '" ++ toString name ++ "', declaration is in an imported module"));
|
||||
match validate env decl val with
|
||||
| Except.error msg => throw (IO.userError ("invalid attribute '" ++ toString name ++ "', " ++ msg))
|
||||
| _ => pure $ ext.addEntry env (decl, val))
|
||||
Core.throwError ("invalid attribute '" ++ toString name ++ "', declaration is in an imported module");
|
||||
validate decl val;
|
||||
Core.setEnv $ ext.addEntry env (decl, val))
|
||||
: AttributeImpl
|
||||
};
|
||||
attrs.forM registerBuiltinAttribute;
|
||||
|
|
|
|||
|
|
@ -139,10 +139,12 @@ partial def getClassName (env : Environment) : Expr → Option Name
|
|||
registerBuiltinAttribute {
|
||||
name := `class,
|
||||
descr := "type class",
|
||||
add := fun env decl args persistent => do
|
||||
when args.hasArgs $ throw (IO.userError ("invalid attribute 'class', unexpected argument"));
|
||||
unless persistent $ throw (IO.userError ("invalid attribute 'class', must be persistent"));
|
||||
IO.ofExcept (addClass env decl)
|
||||
add := fun decl args persistent => do
|
||||
env ← Core.getEnv;
|
||||
when args.hasArgs $ Core.throwError "invalid attribute 'class', unexpected argument";
|
||||
unless persistent $ Core.throwError "invalid attribute 'class', must be persistent";
|
||||
env ← Core.ofExcept (addClass env decl);
|
||||
Core.setEnv env
|
||||
}
|
||||
|
||||
-- TODO: delete
|
||||
|
|
|
|||
|
|
@ -17,12 +17,12 @@ private def isValidCppName : Name → Bool
|
|||
| _ => false
|
||||
|
||||
def mkExportAttr : IO (ParametricAttribute Name) :=
|
||||
registerParametricAttribute `export "name to be used by code generators" $ fun _ _ stx =>
|
||||
registerParametricAttribute `export "name to be used by code generators" $ fun _ stx =>
|
||||
match attrParamSyntaxToIdentifier stx with
|
||||
| some exportName =>
|
||||
if isValidCppName exportName then Except.ok exportName
|
||||
else Except.error "invalid 'export' function name, is not a valid C++ identifier"
|
||||
| _ => Except.error "unexpected kind of argument"
|
||||
if isValidCppName exportName then pure exportName
|
||||
else Core.throwError "invalid 'export' function name, is not a valid C++ identifier"
|
||||
| _ => Core.throwError "unexpected kind of argument"
|
||||
|
||||
@[init mkExportAttr]
|
||||
constant exportAttr : ParametricAttribute Name := arbitrary _
|
||||
|
|
|
|||
|
|
@ -80,12 +80,14 @@ constant addExtern (env : Environment) (n : Name) : ExceptT String Id Environmen
|
|||
|
||||
def mkExternAttr : IO (ParametricAttribute ExternAttrData) :=
|
||||
registerParametricAttribute `extern "builtin and foreign functions"
|
||||
(fun _ _ => syntaxToExternAttrData)
|
||||
(fun env declName _ =>
|
||||
if env.isProjectionFn declName || env.isConstructor declName then
|
||||
addExtern env declName
|
||||
(fun _ stx => Core.ofExcept $ syntaxToExternAttrData stx)
|
||||
(fun declName _ => do
|
||||
env ← Core.getEnv;
|
||||
if env.isProjectionFn declName || env.isConstructor declName then do
|
||||
env ← Core.ofExcept $ addExtern env declName;
|
||||
Core.setEnv env
|
||||
else
|
||||
pure env)
|
||||
pure ())
|
||||
|
||||
@[init mkExternAttr]
|
||||
constant externAttr : ParametricAttribute ExternAttrData := arbitrary _
|
||||
|
|
|
|||
|
|
@ -11,14 +11,13 @@ namespace IR
|
|||
namespace UnboxResult
|
||||
|
||||
def mkUnboxAttr : IO TagAttribute :=
|
||||
registerTagAttribute `unbox "compiler tries to unbox result values if their types are tagged with `[unbox]`" $ fun env declName =>
|
||||
match env.find? declName with
|
||||
| none => Except.error "unknown declaration"
|
||||
| some cinfo => match cinfo with
|
||||
| ConstantInfo.inductInfo v =>
|
||||
if v.isRec then Except.error "recursive inductive datatypes are not supported"
|
||||
else Except.ok ()
|
||||
| _ => Except.error "constant must be an inductive type"
|
||||
registerTagAttribute `unbox "compiler tries to unbox result values if their types are tagged with `[unbox]`" $ fun declName => do
|
||||
cinfo ← Core.getConstInfo declName;
|
||||
match cinfo with
|
||||
| ConstantInfo.inductInfo v =>
|
||||
if v.isRec then Core.throwError "recursive inductive datatypes are not supported"
|
||||
else pure ()
|
||||
| _ => Core.throwError "constant must be an inductive type"
|
||||
|
||||
@[init mkUnboxAttr]
|
||||
constant unboxAttr : TagAttribute := arbitrary _
|
||||
|
|
|
|||
|
|
@ -9,18 +9,14 @@ namespace Lean
|
|||
namespace Compiler
|
||||
|
||||
def mkImplementedByAttr : IO (ParametricAttribute Name) :=
|
||||
registerParametricAttribute `implementedBy "name of the Lean (probably unsafe) function that implements opaque constant" $ fun env declName stx =>
|
||||
match env.find? declName with
|
||||
| none => Except.error "unknown declaration"
|
||||
| some decl =>
|
||||
match attrParamSyntaxToIdentifier stx with
|
||||
| some fnName =>
|
||||
match env.find? fnName with
|
||||
| none => Except.error ("unknown function '" ++ toString fnName ++ "'")
|
||||
| some fnDecl =>
|
||||
if decl.type == fnDecl.type then Except.ok fnName
|
||||
else Except.error ("invalid function '" ++ toString fnName ++ "' type mismatch")
|
||||
| _ => Except.error "expected identifier"
|
||||
registerParametricAttribute `implementedBy "name of the Lean (probably unsafe) function that implements opaque constant" fun declName stx => do
|
||||
decl ← Core.getConstInfo declName;
|
||||
match attrParamSyntaxToIdentifier stx with
|
||||
| some fnName => do
|
||||
fnDecl ← Core.getConstInfo fnName;
|
||||
if decl.type == fnDecl.type then pure fnName
|
||||
else Core.throwError ("invalid function '" ++ fnName ++ "' type mismatch")
|
||||
| _ => Core.throwError "expected identifier"
|
||||
|
||||
@[init mkImplementedByAttr]
|
||||
constant implementedByAttr : ParametricAttribute Name := arbitrary _
|
||||
|
|
|
|||
|
|
@ -22,25 +22,21 @@ match getIOTypeArg type with
|
|||
| _ => false
|
||||
|
||||
def mkInitAttr : IO (ParametricAttribute Name) :=
|
||||
registerParametricAttribute `init "initialization procedure for global references" $ fun env declName stx =>
|
||||
match env.find? declName with
|
||||
| none => Except.error "unknown declaration"
|
||||
| some decl =>
|
||||
match attrParamSyntaxToIdentifier stx with
|
||||
| some initFnName =>
|
||||
match env.find? initFnName with
|
||||
| none => Except.error ("unknown initialization function '" ++ toString initFnName ++ "'")
|
||||
| some initDecl =>
|
||||
match getIOTypeArg initDecl.type with
|
||||
| none => Except.error ("initialization function '" ++ toString initFnName ++ "' must have type of the form `IO <type>`")
|
||||
| some initTypeArg =>
|
||||
if decl.type == initTypeArg then Except.ok initFnName
|
||||
else Except.error ("initialization function '" ++ toString initFnName ++ "' type mismatch")
|
||||
| _ => match stx with
|
||||
| Syntax.missing =>
|
||||
if isIOUnit decl.type then Except.ok Name.anonymous
|
||||
else Except.error "initialization function must have type `IO Unit`"
|
||||
| _ => Except.error "unexpected kind of argument"
|
||||
registerParametricAttribute `init "initialization procedure for global references" $ fun declName stx => do
|
||||
decl ← Core.getConstInfo declName;
|
||||
match attrParamSyntaxToIdentifier stx with
|
||||
| some initFnName => do
|
||||
initDecl ← Core.getConstInfo initFnName;
|
||||
match getIOTypeArg initDecl.type with
|
||||
| none => Core.throwError ("initialization function '" ++ initFnName ++ "' must have type of the form `IO <type>`")
|
||||
| some initTypeArg =>
|
||||
if decl.type == initTypeArg then pure initFnName
|
||||
else Core.throwError ("initialization function '" ++ initFnName ++ "' type mismatch")
|
||||
| _ => match stx with
|
||||
| Syntax.missing =>
|
||||
if isIOUnit decl.type then pure Name.anonymous
|
||||
else Core.throwError "initialization function must have type `IO Unit`"
|
||||
| _ => Core.throwError "unexpected kind of argument"
|
||||
|
||||
@[init mkInitAttr]
|
||||
constant initAttr : ParametricAttribute Name := arbitrary _
|
||||
|
|
|
|||
|
|
@ -33,7 +33,9 @@ registerEnumAttributes `inlineAttrs
|
|||
(`inlineIfReduce, "mark definition to be inlined when resultant term after reduction is not a `cases_on` application", InlineAttributeKind.inlineIfReduce),
|
||||
(`noinline, "mark definition to never be inlined", InlineAttributeKind.noinline),
|
||||
(`macroInline, "mark definition to always be inlined before ANF conversion", InlineAttributeKind.macroInline)]
|
||||
(fun env declName _ => checkIsDefinition env declName)
|
||||
(fun declName _ => do
|
||||
env ← Core.getEnv;
|
||||
Core.ofExcept $ checkIsDefinition env declName)
|
||||
|
||||
@[init mkInlineAttrs]
|
||||
constant inlineAttrs : EnumAttributes InlineAttributeKind := arbitrary _
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ registerEnumAttributes `specializeAttrs
|
|||
In the new equation compiler we should pass all attributes and allow it to apply them to auxiliary definitions.
|
||||
In the current implementation, we workaround this issue by using functions such as `hasSpecializeAttrAux`.
|
||||
-/
|
||||
(fun env declName _ => Except.ok ())
|
||||
(fun declName _ => pure ())
|
||||
AttributeApplicationTime.beforeElaboration
|
||||
|
||||
@[init mkSpecializeAttrs]
|
||||
|
|
|
|||
|
|
@ -54,6 +54,11 @@ def throwError {α} (msg : MessageData) : CoreM α := do
|
|||
ctx ← read;
|
||||
throw $ Exception.error ctx.ref msg
|
||||
|
||||
def ofExcept {ε α} [HasToString ε] (x : Except ε α) : CoreM α :=
|
||||
match x with
|
||||
| Except.ok a => pure a
|
||||
| Except.error e => throwError $ toString e
|
||||
|
||||
def checkRecDepth : CoreM Unit := do
|
||||
ctx ← read;
|
||||
when (ctx.currRecDepth == ctx.maxRecDepth) $ throwError maxRecDepthErrorMessage
|
||||
|
|
@ -70,6 +75,9 @@ s ← get; pure s.env
|
|||
def setEnv (env : Environment) : CoreM Unit :=
|
||||
modify $ fun s => { s with env := env }
|
||||
|
||||
@[inline] def modifyEnv (f : Environment → Environment) : CoreM Unit :=
|
||||
modify $ fun s => { s with env := f s.env }
|
||||
|
||||
def getOptions {ε} : ECoreM ε Options := do
|
||||
ctx ← read; pure ctx.options
|
||||
|
||||
|
|
|
|||
|
|
@ -159,7 +159,7 @@ attrs.forM $ fun attr => do
|
|||
| Except.ok attrImpl =>
|
||||
when (attrImpl.applicationTime == applicationTime) $ do
|
||||
env ← getEnv;
|
||||
env ← liftIO $ attrImpl.add env declName attr.args true;
|
||||
(env, _) ← liftIO $ Core.runCore (attrImpl.add declName attr.args true) env; -- TODO: revise after MetaM refactoring
|
||||
setEnv env
|
||||
|
||||
end Command
|
||||
|
|
|
|||
|
|
@ -127,27 +127,29 @@ ext : Extension γ ← registerPersistentEnvExtension {
|
|||
registerBuiltinAttribute {
|
||||
name := df.builtinName,
|
||||
descr := "(builtin) " ++ df.descr,
|
||||
add := fun env declName arg persistent => do {
|
||||
unless persistent $ throw (IO.userError ("invalid attribute '" ++ toString df.builtinName ++ "', must be persistent"));
|
||||
key ← IO.ofExcept $ df.evalKey true env arg;
|
||||
match env.find? declName with
|
||||
| none => throw $ IO.userError "unknown declaration"
|
||||
| some decl =>
|
||||
match decl.type with
|
||||
| Expr.const c _ _ =>
|
||||
if c != df.valueTypeName then throw (IO.userError ("unexpected type at '" ++ toString declName ++ "', `" ++ toString df.valueTypeName ++ "` expected"))
|
||||
else declareBuiltin df attrDeclName env key declName
|
||||
| _ => throw (IO.userError ("unexpected type at '" ++ toString declName ++ "', `" ++ toString df.valueTypeName ++ "` expected"))
|
||||
add := fun declName arg persistent => do {
|
||||
env ← Core.getEnv;
|
||||
unless persistent $ Core.throwError ("invalid attribute '" ++ df.builtinName ++ "', must be persistent");
|
||||
key ← Core.ofExcept $ df.evalKey true env arg;
|
||||
decl ← Core.getConstInfo declName;
|
||||
match decl.type with
|
||||
| Expr.const c _ _ =>
|
||||
if c != df.valueTypeName then Core.throwError ("unexpected type at '" ++ toString declName ++ "', `" ++ toString df.valueTypeName ++ "` expected")
|
||||
else do
|
||||
env ← liftM $ declareBuiltin df attrDeclName env key declName;
|
||||
Core.setEnv env
|
||||
| _ => Core.throwError ("unexpected type at '" ++ toString declName ++ "', `" ++ toString df.valueTypeName ++ "` expected")
|
||||
},
|
||||
applicationTime := AttributeApplicationTime.afterCompilation
|
||||
};
|
||||
registerBuiltinAttribute {
|
||||
name := df.name,
|
||||
descr := df.descr,
|
||||
add := fun env constName arg persistent => do
|
||||
key ← IO.ofExcept $ df.evalKey false env arg;
|
||||
val ← IO.ofExcept $ env.evalConstCheck γ df.valueTypeName constName;
|
||||
pure $ ext.addEntry env { key := key, decl := constName, value := val },
|
||||
add := fun constName arg persistent => do
|
||||
env ← Core.getEnv;
|
||||
key ← Core.ofExcept $ df.evalKey false env arg;
|
||||
val ← Core.ofExcept $ env.evalConstCheck γ df.valueTypeName constName;
|
||||
Core.setEnv $ ext.addEntry env { key := key, decl := constName, value := val },
|
||||
applicationTime := AttributeApplicationTime.afterCompilation
|
||||
};
|
||||
pure { tableRef := tableRef, ext := ext }
|
||||
|
|
|
|||
|
|
@ -46,11 +46,13 @@ match env.find? constName with
|
|||
registerBuiltinAttribute {
|
||||
name := `instance,
|
||||
descr := "type class instance",
|
||||
add := fun env declName args persistent => do
|
||||
when args.hasArgs $ throw (IO.userError ("invalid attribute 'instance', unexpected argument"));
|
||||
unless persistent $ throw (IO.userError ("invalid attribute 'instance', must be persistent"));
|
||||
env ← IO.ofExcept (addGlobalInstanceOld env declName); -- TODO: delete
|
||||
addGlobalInstance env declName
|
||||
add := fun declName args persistent => do
|
||||
when args.hasArgs $ Core.throwError "invalid attribute 'instance', unexpected argument";
|
||||
unless persistent $ Core.throwError "invalid attribute 'instance', must be persistent";
|
||||
env ← Core.getEnv;
|
||||
env ← Core.ofExcept (addGlobalInstanceOld env declName); -- TODO: delete
|
||||
env ← liftM $ addGlobalInstance env declName;
|
||||
Core.setEnv env
|
||||
}
|
||||
|
||||
end Meta
|
||||
|
|
|
|||
|
|
@ -290,11 +290,13 @@ match cinfo with
|
|||
|
||||
def mkRecursorAttr : IO (ParametricAttribute Nat) :=
|
||||
registerParametricAttribute `recursor "user defined recursor, numerical parameter specifies position of the major premise"
|
||||
(fun _ _ => syntaxToMajorPos)
|
||||
(fun env declName majorPos =>
|
||||
match Meta.run env (mkRecursorInfoCore declName (some majorPos)) with
|
||||
| Except.ok _ => pure env
|
||||
| Except.error ex => Except.error $ toString ex)
|
||||
(fun _ stx => Core.ofExcept $ syntaxToMajorPos stx)
|
||||
(fun declName majorPos => do
|
||||
-- TODO: new code after CoreM refactoring
|
||||
-- Meta.run $ mkRecursorInfoCore declName (some majorPos)
|
||||
env ← Core.getEnv;
|
||||
(info, env) ← liftM $ IO.runMeta (mkRecursorInfoCore declName (some majorPos)) env;
|
||||
Core.setEnv env)
|
||||
|
||||
@[init mkRecursorAttr] constant recursorAttribute : ParametricAttribute Nat := arbitrary _
|
||||
|
||||
|
|
|
|||
|
|
@ -225,7 +225,7 @@ mkParserOfConstantAux env categories constName (compileParserDescr env categorie
|
|||
|
||||
structure ParserAttributeHook :=
|
||||
/- Called after a parser attribute is applied to a declaration. -/
|
||||
(postAdd : forall (catName : Name) (env : Environment) (declName : Name) (builtin : Bool), IO Environment)
|
||||
(postAdd : forall (catName : Name) (env : Environment) (declName : Name) (builtin : Bool), IO Environment) -- TODO: use CoreM?
|
||||
|
||||
def mkParserAttributeHooks : IO (IO.Ref (List ParserAttributeHook)) := IO.mkRef {}
|
||||
@[init mkParserAttributeHooks] constant parserAttributeHooks : IO.Ref (List ParserAttributeHook) := arbitrary _
|
||||
|
|
@ -357,28 +357,31 @@ match env.addAndCompile {} decl with
|
|||
| Except.error _ => throw (IO.userError ("failed to emit registration code for builtin parser '" ++ toString declName ++ "'"))
|
||||
| Except.ok env => IO.ofExcept (setInitAttr env name)
|
||||
|
||||
def declareLeadingBuiltinParser (env : Environment) (catName : Name) (declName : Name) : IO Environment :=
|
||||
def declareLeadingBuiltinParser (env : Environment) (catName : Name) (declName : Name) : IO Environment := -- TODO: use CoreM?
|
||||
declareBuiltinParser env `Lean.Parser.addBuiltinLeadingParser catName declName
|
||||
|
||||
def declareTrailingBuiltinParser (env : Environment) (catName : Name) (declName : Name) : IO Environment :=
|
||||
def declareTrailingBuiltinParser (env : Environment) (catName : Name) (declName : Name) : IO Environment := -- TODO: use CoreM?
|
||||
declareBuiltinParser env `Lean.Parser.addBuiltinTrailingParser catName declName
|
||||
|
||||
private def BuiltinParserAttribute.add (attrName : Name) (catName : Name)
|
||||
(env : Environment) (declName : Name) (args : Syntax) (persistent : Bool) : IO Environment := do
|
||||
when args.hasArgs $ throw (IO.userError ("invalid attribute '" ++ toString attrName ++ "', unexpected argument"));
|
||||
unless persistent $ throw (IO.userError ("invalid attribute '" ++ toString attrName ++ "', must be persistent"));
|
||||
env ← match env.find? declName with
|
||||
| none => throw $ IO.userError "unknown declaration"
|
||||
| some decl =>
|
||||
match decl.type with
|
||||
| Expr.const `Lean.Parser.TrailingParser _ _ =>
|
||||
declareTrailingBuiltinParser env catName declName
|
||||
| Expr.const `Lean.Parser.Parser _ _ =>
|
||||
declareLeadingBuiltinParser env catName declName
|
||||
| _ =>
|
||||
throw (IO.userError ("unexpected parser type at '" ++ toString declName ++ "' (`Parser` or `TrailingParser` expected"));
|
||||
(declName : Name) (args : Syntax) (persistent : Bool) : CoreM Unit := do
|
||||
when args.hasArgs $ Core.throwError ("invalid attribute '" ++ attrName ++ "', unexpected argument");
|
||||
unless persistent $ Core.throwError ("invalid attribute '" ++ attrName ++ "', must be persistent");
|
||||
decl ← Core.getConstInfo declName;
|
||||
env ← Core.getEnv;
|
||||
match decl.type with
|
||||
| Expr.const `Lean.Parser.TrailingParser _ _ => do
|
||||
env ← liftM $ declareTrailingBuiltinParser env catName declName;
|
||||
Core.setEnv env
|
||||
| Expr.const `Lean.Parser.Parser _ _ => do
|
||||
env ← liftM $ declareLeadingBuiltinParser env catName declName;
|
||||
Core.setEnv env
|
||||
| _ => Core.throwError ("unexpected parser type at '" ++ declName ++ "' (`Parser` or `TrailingParser` expected");
|
||||
hooks ← parserAttributeHooks.get;
|
||||
hooks.foldlM (fun env hook => hook.postAdd catName env declName /- builtin -/ true) env
|
||||
hooks.forM fun hook => do
|
||||
env ← Core.getEnv;
|
||||
env ← liftM $ hook.postAdd catName env declName /- builtin -/ true;
|
||||
Core.setEnv env
|
||||
|
||||
/-
|
||||
The parsing tables for builtin parsers are "stored" in the extracted source code.
|
||||
|
|
@ -392,28 +395,32 @@ registerBuiltinAttribute {
|
|||
applicationTime := AttributeApplicationTime.afterCompilation
|
||||
}
|
||||
|
||||
private def ParserAttribute.add (attrName : Name) (catName : Name) (env : Environment) (declName : Name) (args : Syntax) (persistent : Bool) : IO Environment := do
|
||||
when args.hasArgs $ throw (IO.userError ("invalid attribute '" ++ toString attrName ++ "', unexpected argument"));
|
||||
private def ParserAttribute.add (attrName : Name) (catName : Name) (declName : Name) (args : Syntax) (persistent : Bool) : CoreM Unit := do
|
||||
when args.hasArgs $ Core.throwError ("invalid attribute '" ++ attrName ++ "', unexpected argument");
|
||||
env ← Core.getEnv;
|
||||
let categories := (parserExtension.getState env).categories;
|
||||
match mkParserOfConstant env categories declName with
|
||||
| Except.error ex => throw (IO.userError ex)
|
||||
| Except.error ex => Core.throwError ex
|
||||
| Except.ok p => do
|
||||
let leading := p.1;
|
||||
let parser := p.2;
|
||||
let tokens := parser.info.collectTokens [];
|
||||
env ← tokens.foldlM
|
||||
(fun env token =>
|
||||
match addToken env token with
|
||||
| Except.ok env => pure env
|
||||
| Except.error msg => throw (IO.userError ("invalid parser '" ++ toString declName ++ "', " ++ msg)))
|
||||
env;
|
||||
tokens.forM fun token => do {
|
||||
env ← Core.getEnv;
|
||||
match addToken env token with
|
||||
| Except.ok env => Core.setEnv env
|
||||
| Except.error msg => Core.throwError ("invalid parser '" ++ toString declName ++ "', " ++ msg)
|
||||
};
|
||||
let kinds := parser.info.collectKinds {};
|
||||
let env := kinds.foldl (fun env kind _ => addSyntaxNodeKind env kind) env;
|
||||
env ← match addParser categories catName declName leading parser with
|
||||
| Except.ok _ => pure $ parserExtension.addEntry env $ ParserExtensionEntry.parser catName declName leading parser
|
||||
| Except.error ex => throw (IO.userError ex);
|
||||
kinds.forM fun kind _ => Core.modifyEnv fun env => addSyntaxNodeKind env kind;
|
||||
match addParser categories catName declName leading parser with
|
||||
| Except.ok _ => Core.modifyEnv fun env => parserExtension.addEntry env $ ParserExtensionEntry.parser catName declName leading parser
|
||||
| Except.error ex => Core.throwError ex;
|
||||
hooks ← parserAttributeHooks.get;
|
||||
hooks.foldlM (fun env hook => hook.postAdd catName env declName /- builtin -/ false) env
|
||||
hooks.forM fun hook => do
|
||||
env ← Core.getEnv;
|
||||
env ← liftM $ hook.postAdd catName env declName /- builtin -/ false;
|
||||
Core.setEnv env
|
||||
|
||||
def mkParserAttributeImpl (attrName : Name) (catName : Name) : AttributeImpl :=
|
||||
{ name := attrName,
|
||||
|
|
|
|||
|
|
@ -30,11 +30,13 @@ ext : SimplePersistentEnvExtension (Name × Name) (NameMap Name) ← registerSim
|
|||
let attrImpl : AttributeImpl := {
|
||||
name := name,
|
||||
descr := descr,
|
||||
add := fun env decl args _ => match attrParamSyntaxToIdentifier args with
|
||||
| some parserDecl => match env.find? parserDecl with
|
||||
| some _ => pure $ ext.addEntry env (parserDecl, decl)
|
||||
| none => throw $ IO.userError $ "invalid [" ++ toString name ++ "] argument, unknown declaration '" ++ toString parserDecl ++ "'"
|
||||
| none => throw $ IO.userError $ "invalid [" ++ toString name ++ "] argument, expected identifier"
|
||||
add := fun decl args _ => do
|
||||
env ← Core.getEnv;
|
||||
match attrParamSyntaxToIdentifier args with
|
||||
| some parserDeclName => do
|
||||
_ ← Core.getConstInfo parserDeclName;
|
||||
Core.setEnv $ ext.addEntry env (parserDeclName, decl)
|
||||
| none => Core.throwError $ "invalid [" ++ name ++ "] argument, expected identifier"
|
||||
};
|
||||
registerBuiltinAttribute attrImpl;
|
||||
pure { attr := attrImpl, ext := ext }
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue