/
idris-highlighting-text.rkt
148 lines (119 loc) · 5.19 KB
/
idris-highlighting-text.rkt
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
#lang racket
(require racket/gui)
(require data/interval-map)
(require "idris-tag.rkt")
(provide idris-highlighting-text% idris-highlighting-editor<%>)
(define idris-basic-style-delta
(make-parameter
(let ([δ (make-object style-delta%)])
(send δ set-delta 'change-family 'modern))))
(define idris-highlighting-editor<%>
(interface ()
;; Allow for hidden lines
[idris-line->editor-line (->m exact-nonnegative-integer? exact-nonnegative-integer?)]
[editor-line->idris-line (->m exact-nonnegative-integer? exact-nonnegative-integer?)]
;; Interpret a tag to get a style
[get-idris-decor-style (->m idris-tag? (or/c #f (is-a?/c style<%>)))]
;; Style part of the editor
[add-idris-highlight (->m exact-nonnegative-integer?
exact-nonnegative-integer?
idris-tag?
void?)]
[remove-highlighting (->m void?)]
[tag-at-position (->m exact-nonnegative-integer?
(or/c idris-tag? #f))]))
(define idris-highlighting-text%
(class* text% (idris-highlighting-editor<%>)
(init [line-spacing 1.0]
[tab-stops null]
[auto-wrap #f])
(init-field [tag-menu-callback #f])
(super-new [line-spacing line-spacing]
[tab-stops tab-stops]
[auto-wrap auto-wrap])
(inherit change-style
find-position
get-active-canvas
get-style-list
last-position)
(define/public (idris-line->editor-line line) (sub1 line))
(define/public (editor-line->idris-line line) (add1 line))
(define my-style-list (get-style-list))
(define basic-style (send my-style-list basic-style))
(let ([new-basic-style
(send my-style-list find-or-create-style
basic-style
(idris-basic-style-delta))])
(send my-style-list replace-named-style "Standard" basic-style))
(define idris-semantic-function-highlight-style
(let ((delta (make-object style-delta% 'change-nothing)))
(send delta set-delta-foreground (make-object color% 31 122 122 1.0))
delta))
(define idris-semantic-type-highlight-style
(let ((delta (make-object style-delta% 'change-nothing)))
(send delta set-delta-foreground (make-object color% 0 0 174 1.0))
delta))
(define idris-semantic-data-highlight-style
(let ((delta (make-object style-delta% 'change-nothing)))
(send delta set-delta-foreground (make-object color% 200 0 0 1.0))
delta))
(define idris-semantic-bound-highlight-style
(let ((delta (make-object style-delta% 'change-nothing)))
(send delta set-delta-foreground (make-object color% 200 0 200 1.0))
delta))
(define idris-keyword-highlight-style
(make-object style-delta% 'change-bold))
(define idris-hole-highlight-style
(make-object style-delta% 'change-italic))
;; Map an Idris decor keyword to a style
(define/public (get-idris-decor-style tag)
(match (idris-tag-decor tag)
[':type idris-semantic-type-highlight-style]
[':function idris-semantic-function-highlight-style]
[':data idris-semantic-data-highlight-style]
[':bound idris-semantic-bound-highlight-style]
[':keyword idris-keyword-highlight-style]
[':metavar idris-hole-highlight-style]
[other #f]))
;;; Highlight a region
(define highlights (make-interval-map))
(define/public (add-idris-highlight start end tag)
(when (<= end start)
(error (format "Invalid range ~a--~a" start end)))
(when tag
(interval-map-set! highlights start end tag)
(let ([style (get-idris-decor-style tag)])
(when style
(queue-callback
(thunk
(change-style style start end #f)))))))
(define/public (remove-highlighting)
(queue-callback
(thunk
(change-style (let ([δ (make-object style-delta%)])
(send* δ
(set-delta 'change-normal-color)
(set-delta 'change-weight 'normal)
(set-delta 'change-style 'normal))
δ)
0
(last-position))))
(set! highlights (make-interval-map)))
(define/augment (on-insert start len)
(interval-map-expand! highlights start (+ start len)))
(define/augment (on-delete start len)
(interval-map-contract! highlights start (+ start len)))
(define/public (tag-at-position position)
(interval-map-ref highlights position #f))
(define/override (on-default-event mouse-event)
(if (equal? (send mouse-event get-event-type)
'right-down)
(let* ([x (send mouse-event get-x)]
[y (send mouse-event get-y)]
[maybe-tag (tag-at-position (find-position x y))])
(when (and tag-menu-callback maybe-tag)
(let ([menu (tag-menu-callback maybe-tag)]
[canvas (get-active-canvas)])
(when (and menu canvas)
(send canvas popup-menu menu x y)))))
(super on-default-event mouse-event)))))