Skip to content
Newer
Older
100644 309 lines (253 sloc) 9.5 KB
9dabfe0 @VincentToups microstack first
authored
1 (require 'lisp-parser)
2 (require 'functional)
3 (require 'with-stack)
4 (require 'stack-words)
7151130 @VincentToups microstack generic motion
authored
5 (require 'multi-methods)
cea7637 @VincentToups microstack doc
authored
6 (provide 'microstack)
9dabfe0 @VincentToups microstack first
authored
7
7151130 @VincentToups microstack generic motion
authored
8
9
9dabfe0 @VincentToups microstack first
authored
10 (defunc =microstack-symbol ()
ef7feb5 @VincentToups microstack doc
authored
11 "Parser for a microstack symbol, or a space (no-op)."
9dabfe0 @VincentToups microstack first
authored
12 (=let* [_ (=or (letter)
13 (=space)
14 (=other-id-char))]
15 (if _
16 (intern (concat (list _))) nil)))
17
9035699 @VincentToups Extended microstack.
authored
18 (defunc =escaped-close-bracket ()
19 "Parse an escaped close bracket."
20 "["
21 (=let* [_ (=string "\\]")]
22 (if _ ?\" nil)))
23
9cd75a7 @VincentToups microstack updates
authored
24 ;; (defunc =bracketed-string ()
25 ;; (=let* [_ (=char ?\[)
26 ;; contents (zero-or-more (=or
27 ;; (=escaped-close-bracket)
28 ;; (=satisfies
29 ;; (lex-lambda (c) (!= c ?\])))))
30 ;; _ (=char ?\])]
31 ;; (parse-and-translate-microstack (coerce (flatten contents) 'string))))
32
33 (defunc =single-quote-string ()
34 (=let* [_ (=char ?\')
9035699 @VincentToups Extended microstack.
authored
35 contents (zero-or-more (=or
36 (=escaped-close-bracket)
37 (=satisfies
9cd75a7 @VincentToups microstack updates
authored
38 (lex-lambda (c) (!= c ?\')))))
39 _ (=char ?\')]
40 (coerce (flatten contents) 'string)))
41
42 (defun =microstack-string ()
43 (=or (=single-quote-string)
44 (=lisp-string)))
9035699 @VincentToups Extended microstack.
authored
45
9dabfe0 @VincentToups microstack first
authored
46
9cd75a7 @VincentToups microstack updates
authored
47 (defun =microstack-quote ()
48 (=let* [_ (=char ?\[)
49 contents (microstack-parser)
50 _ (=char ?\])]
51 (translate-microstack contents)))
52
ef7feb5 @VincentToups microstack doc
authored
53 (defun microstack-parser ()
54 "Parser for the microstack language."
55 (zero-or-more (=or
56 (=number)
7151130 @VincentToups microstack generic motion
authored
57 (=microstack-symbol)
9cd75a7 @VincentToups microstack updates
authored
58 (=microstack-string)
59 (=microstack-quote))))
9dabfe0 @VincentToups microstack first
authored
60
61 (defun parse-microstack (code)
ef7feb5 @VincentToups microstack doc
authored
62 "Parse the microstack language and return the results as a sequence of symbols, numbers, strings. Remove no-ops."
9dabfe0 @VincentToups microstack first
authored
63 (filter
64 (f-not (cr #'eq (intern " ")))
65 (car (parse-string-det (microstack-parser) code))))
66
67 (defstackword delete-forward0
68 (backward-delete-char -1))
69 (defstackword delete-backward0
70 (backward-delete-char 1))
71 (defstackword delete-backward
72 (backward-delete-char (pop *stack*)))
73 (defstackword delete-forward
74 (backward-delete-char (- (pop *stack*))))
75 (defstackword insert (insert (pop *stack*)))
76 (defstackword microstack->quotation
77 (let ((str (pop *stack*)))
c95dfaf @VincentToups fixed microstack
authored
78 (push (translate-microstack (parse-microstack str)) *stack*)))
9dabfe0 @VincentToups microstack first
authored
79 (defstackword do-n-times
80 (let ((n (pop *stack*))
81 (q (pop *stack*)))
82 (loop for i from 0 below n do
83 (|||- {q} call))))
84
85 (defstackword call-string
86 (|||- 1>intern 1>list call))
87
88 (defstackword string->quotation
89 (|||- 1>intern 1>list))
90
91 (defstackword kill-current-region
c95dfaf @VincentToups fixed microstack
authored
92 (|||- lisp-val: (point) lisp-val: (mark) 2>kill-region))
93
94 (defstackword char-at-point->string
95 (push (buffer-substring-no-properties (point) (+ 1 (point))) *stack*))
96
97 (defstackword loop-while
98 (let ((con (pop *stack*))
99 (qtn (pop *stack*)))
100 (loop do
101 (|||- {con} call)
102 while (pop *stack*)
103 do
104 (|||- {qtn} call))))
105 (defstackword loop-until
106 (let ((con (pop *stack*))
107 (qtn (pop *stack*)))
108 (loop do
109 (|||- {con} call)
110 while (not (pop *stack*))
111 do
112 (|||- {qtn} call))))
9dabfe0 @VincentToups microstack first
authored
113
9cd75a7 @VincentToups microstack updates
authored
114 (defstackword loop-until-char
664a8db @VincentToups weighted graph monad commit
authored
115 (|||- '(char-at-point->string 2>string=) curry loop-until))
9cd75a7 @VincentToups microstack updates
authored
116
9035699 @VincentToups Extended microstack.
authored
117 (defstackword forward
118 (forward-char))
119 (defstackword backward
120 (backward-char))
121
122 (defstackword format
123 (let ((fmtstr (pop *stack*))
124 (rest (pop *stack*)))
125 (push (apply #'format (cons fmtstr rest)) *stack*)))
126
7151130 @VincentToups microstack generic motion
authored
127 (defun move-dispatcher (object)
128 "Dispatch for generic motion."
129 (cond ((numberp object) :char)
130 ((listp object) (car object))
131 (t nil)))
132
133 (defmulti move #'move-dispatcher "A generic motion function.")
134
135 (defunmethod move :char (movement)
136 (let ((n (if
137 (listp movement) (cadr movement)
138 movement)))
139 (forward-char n)))
140
141 (defunmethod move :word (movement)
142 (forward-word (cadr movement)))
143
144 (defunmethod move :line (movement)
145 (beginning-of-line)
146 (forward-line (cadr movement)))
147
148 (defunmethod move :paragraph (movement)
149 (forward-paragraph (cadr movement)))
150
151 (defstackword word
152 (|||- :word swap 2>list))
153
154 (defstackword paragraph
155 (|||- :paragraph swap 2>list))
156
157 (defstackword page
158 (|||- :page swap 2>list))
159
160 (defstackword line
161 (|||- :line swap 2>list))
162
163 (defstackword char
164 (|||- :char swap 2>list))
165
166 (defstackword sym
167 (|||- :symbol swap 2>list))
168
169 (defstackword s-expression
170 (|||- :sexp swap 2>list))
171
172 (defstackword make-quantity-of
173 (|||- 1>make-keyword swap 2>list))
174
175 ($ :char derives-from :movement-type)
176 ($ :movement-type-with-extent
177 derives-from :movement-type)
178 ($ :word derives-from :movement-type-with-extent)
179 ($ :paragraph derives-from :movement-type-with-extent)
180 ($ :line derives-from :movement-type-with-extent)
181
182
183 (defmulti move-kill #'move-dispatcher "Generic deletion method.")
184
185 (defmulti pre-delete-movement (function move-dispatcher) "Handle movement before delete.")
186 (defunmethod pre-delete-movement :movement-type (movement)
187 nil
188 )
189
190 (defmulti post-delete-movement (function move-dispatcher) "Handle movement before delete.")
191 (defunmethod post-delete-movement :movement-type (movement)
192 nil
193 )
194
195 (defun bounds-of-thing-at-point-kw (kw)
196 (bounds-of-thing-at-point (keyword->symbol kw)))
197
198 (defunmethod pre-delete-movement :movement-type-with-extent (movement)
199 (let* ((thing-bounds (bounds-of-thing-at-point-kw (car movement)))
200 (start (car thing-bounds))
201 (stop (cdr thing-bounds)))
202 (cond ((positive? (cadr movement)) (goto-char start))
203 ((negative? (cadr movement)) (goto-char stop))
204 ((zero? (cadr movement)) nil))))
205
206 (defunmethod post-delete-movement :movement-type-with-extent (movement)
207 (let* ((thing-bounds (bounds-of-thing-at-point-kw (car movement)))
208 (start (car thing-bounds))
209 (stop (cdr thing-bounds)))
210 (cond ((positive? (cadr movement)) (goto-char stop))
211 ((negative? (cadr movement)) (goto-char start))
212 ((zero? (cadr movement)) nil))))
213
214
215 (defun point-in-word? ()
216 (save-excursion (let ((pt (point)))
217 (backward-word) (forward-word)
218 (!= pt (point)))))
219
220 (defunmethod move-kill :movement-type (movement)
221 (let (p1 p2)
222 (pre-delete-movement movement)
223 (setq p1 (point))
224 (move movement)
225 (post-delete-movement movement)
226 (setq p2 (point))
227 (kill-region p1 p2)))
228
229
230
231 (defstackword move (|||- 1>move drop))
232 (defstackword kill (|||- 1>move-kill drop))
302bcda @VincentToups Multimethods library, bros
authored
233
9dabfe0 @VincentToups microstack first
authored
234 (setq micro-stack-map
664a8db @VincentToups weighted graph monad commit
authored
235 (tbl!
7151130 @VincentToups microstack generic motion
authored
236 'm 'move ; generic movement. pops an item from the stack, then moves appropriately
237 'k 'kill ; generic move-and-kil, pops and item of the stack, marks, moves, and kill-region's
238 'l 'line ; specify that a number indicates a number of lines
239 'w 'word ; specify that a number indicates a number of words
240 'y 'sym ; specify that a number indicates a number of symbols
241 'p 'paragraph ; specify that a number indicates a number of paragraphs
242 'P 'page ; specify that a number indicates a number of pages
243 'e 's-expression ; specify that a number indicates a number of s-expressions
244 'G 'make-quantity-of ; take a string and a number and create a general quantity 4"sentence"G -> (:sentence 4)
9035699 @VincentToups Extended microstack.
authored
245 'q 'microstack->quotation ; convert a STRING to a microstack compiled quotation, "..."q is eq to [...]
246 'Q 'string->quotation ;push the stack word represented by string onto the stack to be called later
247 '! 'call ; call a quotation/stack word
248 '? 'if ; if
249 '+ '+ ; plus
250 '- '- ; -
251 't 't ; push t
252 '_ 'nil ; push nil
253 'm '0>push-mark ; mark the current point as the mark
ef7feb5 @VincentToups microstack doc
authored
254 'M '0>mark ; put the mark position on the stack
9035699 @VincentToups Extended microstack.
authored
255 'g '1>goto-char ; jump to a character number popped from the stack
256 'x 'kill-current-region ; kill the current region between the point and mark
257 '* '* ; times
258 '/ '/ ; divide
259 '= '2>equal ; equals
260 'N 'do-n-times ; do a quotation n times before stopping
261 'L 'loop ; the loop word in all its general glory - execute a quotation until the top of the stack is true
262 '{ '{{ ; start a list
263 '} '}} ; end a list
264 's '1>search-forward ; search forward for the string on the stack, which is popped
265 'S '1>search-forward-regexp ; search forward for the regex on the stack, which is popped
266 'c 'concat ; concat two strings
7151130 @VincentToups microstack generic motion
authored
267 'o 'rot
9035699 @VincentToups Extended microstack.
authored
268 (intern ",") 'print-stack ; print the stack
269 (intern ":") 'dup ; dup
270 (intern "$") 'swap ; swap the top two stack elements
271 (intern "#") 'length ; pop object off the stack and push its length
272 (intern "@") 'char-at-point->string ;push the current character onto the stack
273 (intern ".") 'print ; print the top of the stack, pop it
274 (intern "%") 'format ; lst format-string format; calls format with the string format-string and lst as rest args
d3ded5e @VincentToups microstack doc
authored
275 (intern "|") 'compose ; compose two quotations
9cd75a7 @VincentToups microstack updates
authored
276 (intern "^") 'curry ; curry the value on the stack into the quotation below it.
9035699 @VincentToups Extended microstack.
authored
277 'U 'loop-until ; qt pred loop-until ; loop qt until pred is true
9cd75a7 @VincentToups microstack updates
authored
278 'u 'loop-until-char ; qt char loop-until-char; loop qt until char is beneath the cursor.
9035699 @VincentToups Extended microstack.
authored
279 'W 'loop-while ; qt pred loop-while ; loop qt while pred is true
280 'i 'insert ; insert the top of the stack as text into the buffer
d3ded5e @VincentToups microstack doc
authored
281
9035699 @VincentToups Extended microstack.
authored
282 ))
283
9dabfe0 @VincentToups microstack first
authored
284 (defun translate-microstack (code)
ef7feb5 @VincentToups microstack doc
authored
285 "Translate the single character symbols to their stack words. Process special microstack behavior words."
9dabfe0 @VincentToups microstack first
authored
286 (loop for el in code append
287 (cond
288 ((symbolp el)
664a8db @VincentToups weighted graph monad commit
authored
289 (let ((trans (tbl micro-stack-map el)))
9dabfe0 @VincentToups microstack first
authored
290 (if trans (list trans) (error "Unknown microstack word."))))
9035699 @VincentToups Extended microstack.
authored
291 ((listp el)
292 (list 'lisp-val: `(quote ,el)))
9dabfe0 @VincentToups microstack first
authored
293 (t (list el)))))
294
9035699 @VincentToups Extended microstack.
authored
295 (defun parse-and-translate-microstack (code)
296 (translate-microstack (parse-microstack code)))
297
9dabfe0 @VincentToups microstack first
authored
298 (defun do-microstack-parsed-translated (code)
ef7feb5 @VincentToups microstack doc
authored
299 "Evaluate the parsed and translated CODE for a microstack statement. Should be regular stack code at this point."
c95dfaf @VincentToups fixed microstack
authored
300 (eval `(|||p ,@code)))
9dabfe0 @VincentToups microstack first
authored
301
302 (defun do-microstack (str)
ef7feb5 @VincentToups microstack doc
authored
303 "Parse, translated and execute the microstack code in STR."
9dabfe0 @VincentToups microstack first
authored
304 (interactive "s")
305 (let* ((code (parse-microstack str))
306 (code (translate-microstack code)))
307 (do-microstack-parsed-translated code)))
fb6606c @VincentToups monad revisions.
authored
308
Something went wrong with that request. Please try again.