Pantograph/Pantograph/Environment.lean

154 lines
5.8 KiB
Plaintext
Raw Normal View History

import Pantograph.Protocol
import Pantograph.Serial
import Lean
open Lean
open Pantograph
namespace Pantograph.Environment
2024-07-28 13:46:14 -07:00
@[export pantograph_is_name_internal]
def isNameInternal (n: Name): Bool :=
-- Returns true if the name is an implementation detail which should not be shown to the user.
2024-10-04 12:58:16 -07:00
n.isAuxLemma n.hasMacroScopes
2024-07-29 18:39:22 -07:00
/-- Catalog all the non-internal and safe names -/
2024-07-28 13:46:14 -07:00
@[export pantograph_environment_catalog]
2024-10-04 12:58:16 -07:00
def env_catalog (env: Environment): Array Name := env.constants.fold (init := #[]) (λ acc name _ =>
match isNameInternal name with
2024-07-28 14:19:47 -07:00
| false => acc.push name
| true => acc)
2024-07-28 13:46:14 -07:00
@[export pantograph_environment_module_of_name]
def module_of_name (env: Environment) (name: Name): Option Name := do
let moduleId ← env.getModuleIdxFor? name
return env.allImportedModuleNames.get! moduleId.toNat
def toCompactSymbolName (n: Name) (info: ConstantInfo): String :=
let pref := match info with
| .axiomInfo _ => "a"
| .defnInfo _ => "d"
| .thmInfo _ => "t"
| .opaqueInfo _ => "o"
| .quotInfo _ => "q"
| .inductInfo _ => "i"
| .ctorInfo _ => "c"
| .recInfo _ => "r"
s!"{pref}{toString n}"
def toFilteredSymbol (n: Lean.Name) (info: Lean.ConstantInfo): Option String :=
if isNameInternal n || info.isUnsafe
then Option.none
else Option.some <| toCompactSymbolName n info
2024-03-09 16:50:36 -08:00
def catalog (_: Protocol.EnvCatalog): CoreM Protocol.EnvCatalogResult := do
let env ← Lean.MonadEnv.getEnv
let names := env.constants.fold (init := #[]) (λ acc name info =>
match toFilteredSymbol name info with
| .some x => acc.push x
| .none => acc)
2024-03-09 16:50:36 -08:00
return { symbols := names }
2024-03-11 21:31:59 -07:00
def inspect (args: Protocol.EnvInspect) (options: @&Protocol.Options): CoreM (Protocol.CR Protocol.EnvInspectResult) := do
let env ← Lean.MonadEnv.getEnv
let name := args.name.toName
let info? := env.find? name
2024-01-16 13:29:30 -08:00
let info ← match info? with
| none => return .error $ Protocol.errorIndex s!"Symbol not found {args.name}"
| some info => pure info
let module? := env.getModuleIdxFor? name >>=
(λ idx => env.allImportedModuleNames.get? idx.toNat) |>.map toString
let value? := match args.value?, info with
| .some true, _ => info.value?
| .some false, _ => .none
| .none, .defnInfo _ => info.value?
| .none, _ => .none
2024-06-16 13:44:57 -07:00
let type ← unfoldAuxLemmas info.type
let value? ← value?.mapM (λ v => unfoldAuxLemmas v)
2024-01-16 13:29:30 -08:00
-- Information common to all symbols
let core := {
2024-06-16 13:44:57 -07:00
type := ← (serializeExpression options type).run',
isUnsafe := info.isUnsafe,
value? := ← value?.mapM (λ v => serializeExpression options v |>.run'),
2024-01-16 13:29:30 -08:00
publicName? := Lean.privateToUserName? name |>.map (·.toString),
-- BUG: Warning: getUsedConstants here will not include projections. This is a known bug.
typeDependency? := if args.dependency?.getD false
2024-06-16 13:44:57 -07:00
then .some <| type.getUsedConstants.map (λ n => serializeName n)
else .none,
valueDependency? := if args.dependency?.getD false
then value?.map (λ e =>
e.getUsedConstants.filter (!isNameInternal ·) |>.map (λ n => serializeName n) )
else .none,
2024-01-16 13:29:30 -08:00
module? := module?
}
2024-04-09 21:24:08 -07:00
let result ← match info with
| .inductInfo induct => pure { core with inductInfo? := .some {
2024-01-16 13:29:30 -08:00
numParams := induct.numParams,
numIndices := induct.numIndices,
2024-03-14 22:40:14 -07:00
all := induct.all.toArray.map (·.toString),
ctors := induct.ctors.toArray.map (·.toString),
2024-01-16 13:29:30 -08:00
isRec := induct.isRec,
isReflexive := induct.isReflexive,
isNested := induct.isNested,
} }
2024-04-09 21:24:08 -07:00
| .ctorInfo ctor => pure { core with constructorInfo? := .some {
induct := ctor.induct.toString,
cidx := ctor.cidx,
numParams := ctor.numParams,
numFields := ctor.numFields,
} }
2024-04-09 21:24:08 -07:00
| .recInfo r => pure { core with recursorInfo? := .some {
2024-03-14 22:40:14 -07:00
all := r.all.toArray.map (·.toString),
numParams := r.numParams,
numIndices := r.numIndices,
numMotives := r.numMotives,
numMinors := r.numMinors,
2024-04-09 21:24:08 -07:00
rules := ← r.rules.toArray.mapM (λ rule => do
pure {
ctor := rule.ctor.toString,
nFields := rule.nfields,
rhs := ← (serializeExpression options rule.rhs).run',
2024-04-09 21:24:08 -07:00
})
k := r.k,
} }
2024-04-09 21:24:08 -07:00
| _ => pure core
2024-01-16 13:29:30 -08:00
return .ok result
def addDecl (args: Protocol.EnvAdd): CoreM (Protocol.CR Protocol.EnvAddResult) := do
let env ← Lean.MonadEnv.getEnv
let tvM: Elab.TermElabM (Except String (Expr × Expr)) := do
2024-03-31 15:55:08 -07:00
let type ← match parseTerm env args.type with
| .ok syn => do
2024-03-31 15:55:08 -07:00
match ← elabTerm syn with
| .error e => return .error e
| .ok expr => pure expr
| .error e => return .error e
2024-03-31 15:55:08 -07:00
let value ← match parseTerm env args.value with
| .ok syn => do
try
let expr ← Elab.Term.elabTerm (stx := syn) (expectedType? := .some type)
Lean.Elab.Term.synthesizeSyntheticMVarsNoPostponing
let expr ← instantiateMVars expr
pure $ expr
catch ex => return .error (← ex.toMessageData.toString)
| .error e => return .error e
pure $ .ok (type, value)
let (type, value) ← match ← tvM.run' (ctx := {}) |>.run' with
| .ok t => pure t
| .error e => return .error $ Protocol.errorExpr e
let constant := Lean.Declaration.defnDecl <| Lean.mkDefinitionValEx
(name := args.name.toName)
(levelParams := [])
(type := type)
(value := value)
(hints := Lean.mkReducibilityHintsRegularEx 1)
(safety := Lean.DefinitionSafety.safe)
(all := [])
2024-07-06 19:53:50 -07:00
let env' ← match env.addDecl (← getOptions) constant with
| .error e => do
let options ← Lean.MonadOptions.getOptions
let desc ← (e.toMessageData options).toString
return .error $ { error := "kernel", desc }
| .ok env' => pure env'
Lean.MonadEnv.modifyEnv (λ _ => env')
return .ok {}
end Pantograph.Environment