/
UserWidget.lean
190 lines (159 loc) · 6.59 KB
/
UserWidget.lean
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: E.W.Ayers
-/
import Lean.Elab.Eval
import Lean.Server.Rpc.RequestHandling
open Lean
namespace Lean.Widget
/-- A custom piece of code that is run on the editor client.
The editor can use the `Lean.Widget.getWidgetSource` RPC method to
get this object.
See the [manual entry](doc/widgets.md) above this declaration for more information on
how to use the widgets system.
-/
structure WidgetSource where
/-- Sourcetext of the code to run.-/
sourcetext : String
deriving Inhabited, ToJson, FromJson
/-- Use this structure and the `@[widget]` attribute to define your own widgets.
```lean
@[widget]
def rubiks : UserWidgetDefinition :=
{ name := "Rubiks cube app"
javascript := include_str ...
}
```
-/
structure UserWidgetDefinition where
/-- Pretty name of user widget to display to the user. -/
name : String
/-- An ESmodule that exports a react component to render. -/
javascript: String
deriving Inhabited, ToJson, FromJson
structure UserWidget where
id : Name
/-- Pretty name of widget to display to the user.-/
name : String
javascriptHash: UInt64
deriving Inhabited, ToJson, FromJson
private abbrev WidgetSourceRegistry := SimplePersistentEnvExtension
(UInt64 × Name)
(RBMap UInt64 Name compare)
-- Mapping widgetSourceId to hash of sourcetext
builtin_initialize userWidgetRegistry : MapDeclarationExtension UserWidget ← mkMapDeclarationExtension
builtin_initialize widgetSourceRegistry : WidgetSourceRegistry ←
registerSimplePersistentEnvExtension {
addImportedFn := fun xss => xss.foldl (Array.foldl (fun s n => s.insert n.1 n.2)) ∅
addEntryFn := fun s n => s.insert n.1 n.2
toArrayFn := fun es => es.toArray
}
private unsafe def getUserWidgetDefinitionUnsafe
(decl : Name) : CoreM UserWidgetDefinition :=
evalConstCheck UserWidgetDefinition ``UserWidgetDefinition decl
@[implemented_by getUserWidgetDefinitionUnsafe]
private opaque getUserWidgetDefinition
(decl : Name) : CoreM UserWidgetDefinition
private def attributeImpl : AttributeImpl where
name := `widget
descr := "Mark a string as static code that can be loaded by a widget handler."
applicationTime := AttributeApplicationTime.afterCompilation
add decl _stx _kind := do
let env ← getEnv
let defn ← getUserWidgetDefinition decl
let javascriptHash := hash defn.javascript
let env := userWidgetRegistry.insert env decl {id := decl, name := defn.name, javascriptHash}
let env := widgetSourceRegistry.addEntry env (javascriptHash, decl)
setEnv <| env
builtin_initialize registerBuiltinAttribute attributeImpl
/-- Input for `getWidgetSource` RPC. -/
structure GetWidgetSourceParams where
/-- The hash of the sourcetext to retrieve. -/
hash: UInt64
pos : Lean.Lsp.Position
deriving ToJson, FromJson
open Server RequestM in
@[server_rpc_method]
def getWidgetSource (args : GetWidgetSourceParams) : RequestM (RequestTask WidgetSource) := do
let doc ← readDoc
let pos := doc.meta.text.lspPosToUtf8Pos args.pos
let notFound := throwThe RequestError ⟨.invalidParams, s!"No registered user-widget with hash {args.hash}"⟩
withWaitFindSnap doc (notFoundX := notFound)
(fun s => s.endPos >= pos || (widgetSourceRegistry.getState s.env).contains args.hash)
fun snap => do
if let some id := widgetSourceRegistry.getState snap.env |>.find? args.hash then
runCoreM snap do
return {sourcetext := (← getUserWidgetDefinition id).javascript}
else
notFound
open Lean Elab
/--
Try to retrieve the `UserWidgetInfo` at a particular position.
-/
def widgetInfosAt? (text : FileMap) (t : InfoTree) (hoverPos : String.Pos) : List UserWidgetInfo :=
t.deepestNodes fun
| _ctx, i@(Info.ofUserWidgetInfo wi), _cs => do
if let (some pos, some tailPos) := (i.pos?, i.tailPos?) then
let trailSize := i.stx.getTrailingSize
-- show info at EOF even if strictly outside token + trail
let atEOF := tailPos.byteIdx + trailSize == text.source.endPos.byteIdx
guard <| pos ≤ hoverPos ∧ (hoverPos.byteIdx < tailPos.byteIdx + trailSize || atEOF)
return wi
else
failure
| _, _, _ => none
/-- UserWidget accompanied by component props. -/
structure UserWidgetInstance extends UserWidget where
/-- Arguments to be fed to the widget's main component. -/
props : Json
/-- The location of the widget instance in the Lean file. -/
range? : Option Lsp.Range
deriving ToJson, FromJson
/-- Output of `getWidgets` RPC.-/
structure GetWidgetsResponse where
widgets : Array UserWidgetInstance
deriving ToJson, FromJson
open Lean Server RequestM in
/-- Get the `UserWidget`s present at a particular position. -/
@[server_rpc_method]
def getWidgets (args : Lean.Lsp.Position) : RequestM (RequestTask (GetWidgetsResponse)) := do
let doc ← readDoc
let filemap := doc.meta.text
let pos := filemap.lspPosToUtf8Pos args
withWaitFindSnap doc (·.endPos >= pos) (notFoundX := return ⟨∅⟩) fun snap => do
let env := snap.env
let ws := widgetInfosAt? filemap snap.infoTree pos
let ws ← ws.toArray.mapM (fun (w : UserWidgetInfo) => do
let some widget := userWidgetRegistry.find? env w.widgetId
| throw <| RequestError.mk .invalidParams s!"No registered user-widget with id {w.widgetId}"
return {
widget with
props := w.props
range? := String.Range.toLspRange filemap <$> Syntax.getRange? w.stx
})
return {widgets := ws}
/-- Save a user-widget instance to the infotree.
The given `widgetId` should be the declaration name of the widget definition. -/
def saveWidgetInfo [Monad m] [MonadEnv m] [MonadError m] [MonadInfoTree m] (widgetId : Name) (props : Json) (stx : Syntax): m Unit := do
let info := Info.ofUserWidgetInfo {
widgetId := widgetId
props := props
stx := stx
}
pushInfoLeaf info
/-! # Widget command -/
/-- Use `#widget <widgetname> <props>` to display a widget. Useful for debugging widgets. -/
syntax (name := widgetCmd) "#widget " ident term : command
open Lean Lean.Meta Lean.Elab Lean.Elab.Term in
private unsafe def evalJsonUnsafe (stx : Syntax) : TermElabM Json :=
Lean.Elab.Term.evalTerm Json (mkConst ``Json) stx
@[implemented_by evalJsonUnsafe]
private opaque evalJson (stx : Syntax) : TermElabM Json
open Elab Command in
@[command_elab widgetCmd] def elabWidgetCmd : CommandElab := fun
| stx@`(#widget $id:ident $props) => do
let props : Json ← runTermElabM fun _ => evalJson props
saveWidgetInfo id.getId props stx
| _ => throwUnsupportedSyntax
end Lean.Widget