]> gitweb.factorcode.org Git - factor.git/blob - misc/fuel/fuel-markup.el
Merge branch 'emacs' of http://git.hacks-galore.org/jao/factor
[factor.git] / misc / fuel / fuel-markup.el
1 ;;; fuel-markup.el -- printing factor help markup
2
3 ;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
4 ;; See http://factorcode.org/license.txt for BSD license.
5
6 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
7 ;; Keywords: languages, fuel, factor
8 ;; Start date: Thu Jan 01, 2009 21:43
9
10 ;;; Comentary:
11
12 ;; Utilities for printing Factor's help markup.
13
14 ;;; Code:
15
16 (require 'fuel-eval)
17 (require 'fuel-font-lock)
18 (require 'fuel-base)
19 (require 'fuel-table)
20
21 (require 'button)
22
23 \f
24 ;;; Customization:
25
26 (fuel-font-lock--defface fuel-font-lock-markup-title
27   'bold fuel-help "article titles in help buffers")
28
29 (fuel-font-lock--defface fuel-font-lock-markup-heading
30   'bold fuel-help "headlines in help buffers")
31
32 (fuel-font-lock--defface fuel-font-lock-markup-link
33   'link fuel-help "links to topics in help buffers")
34
35 (fuel-font-lock--defface fuel-font-lock-markup-emphasis
36   'italic fuel-help "emphasized words in help buffers")
37
38 (fuel-font-lock--defface fuel-font-lock-markup-strong
39   'link fuel-help "bold words in help buffers")
40
41 \f
42 ;;; Links:
43
44 (make-variable-buffer-local
45  (defvar fuel-markup--follow-link-function 'fuel-markup--echo-link))
46
47 (define-button-type 'fuel-markup--button
48   'action 'fuel-markup--follow-link
49   'face 'fuel-font-lock-markup-link
50   'follow-link t)
51
52 (defun fuel-markup--follow-link (button)
53   (when fuel-markup--follow-link-function
54     (funcall fuel-markup--follow-link-function
55              (button-get button 'markup-link)
56              (button-get button 'markup-label)
57              (button-get button 'markup-link-type))))
58
59 (defun fuel-markup--echo-link (link label type)
60   (message "Link %s pointing to %s named %s" label type link))
61
62 (defun fuel-markup--insert-button (label link type)
63   (let ((label (format "%s" label))
64         (link (if (listp link) link (format "%s" link))))
65     (insert-text-button label
66                         :type 'fuel-markup--button
67                         'markup-link link
68                         'markup-label label
69                         'markup-link-type type
70                         'help-echo (format "%s (%s)" label type))))
71
72 (defun fuel-markup--article-title (name)
73   (let ((name (if (listp name) (cons :seq name) name)))
74     (fuel-eval--retort-result
75      (fuel-eval--send/wait `(:fuel* ((,name fuel-get-article-title)) "fuel")))))
76
77 (defun fuel-markup--link-at-point ()
78   (let ((button (condition-case nil (forward-button 0) (error nil))))
79     (when button
80       (list (button-get button 'markup-link)
81             (button-get button 'markup-label)
82             (button-get button 'markup-link-type)))))
83
84 \f
85 ;;; Markup printers:
86
87 (defconst fuel-markup--printers
88   '(($all-tags . fuel-markup--all-tags)
89     ($all-authors . fuel-markup--all-authors)
90     ($author . fuel-markup--author)
91     ($authors . fuel-markup--authors)
92     ($class-description . fuel-markup--class-description)
93     ($code . fuel-markup--code)
94     ($command . fuel-markup--command)
95     ($command-map . fuel-markup--null)
96     ($contract . fuel-markup--contract)
97     ($curious . fuel-markup--curious)
98     ($definition . fuel-markup--definition)
99     ($describe-vocab . fuel-markup--describe-vocab)
100     ($description . fuel-markup--description)
101     ($doc-path . fuel-markup--doc-path)
102     ($emphasis . fuel-markup--emphasis)
103     ($error-description . fuel-markup--error-description)
104     ($errors . fuel-markup--errors)
105     ($example . fuel-markup--example)
106     ($examples . fuel-markup--examples)
107     ($heading . fuel-markup--heading)
108     ($index . fuel-markup--index)
109     ($instance . fuel-markup--instance)
110     ($io-error . fuel-markup--io-error)
111     ($link . fuel-markup--link)
112     ($links . fuel-markup--links)
113     ($list . fuel-markup--list)
114     ($low-level-note . fuel-markup--low-level-note)
115     ($markup-example . fuel-markup--markup-example)
116     ($maybe . fuel-markup--maybe)
117     ($methods . fuel-markup--methods)
118     ($nl . fuel-markup--newline)
119     ($notes . fuel-markup--notes)
120     ($operation . fuel-markup--link)
121     ($or . fuel-markup--or)
122     ($parsing-note . fuel-markup--parsing-note)
123     ($predicate . fuel-markup--predicate)
124     ($prettyprinting-note . fuel-markup--prettyprinting-note)
125     ($quotation . fuel-markup--quotation)
126     ($references . fuel-markup--references)
127     ($related . fuel-markup--related)
128     ($see . fuel-markup--see)
129     ($see-also . fuel-markup--see-also)
130     ($shuffle . fuel-markup--shuffle)
131     ($side-effects . fuel-markup--side-effects)
132     ($slot . fuel-markup--snippet)
133     ($snippet . fuel-markup--snippet)
134     ($strong . fuel-markup--strong)
135     ($subheading . fuel-markup--subheading)
136     ($subsection . fuel-markup--subsection)
137     ($synopsis . fuel-markup--synopsis)
138     ($syntax . fuel-markup--syntax)
139     ($table . fuel-markup--table)
140     ($tag . fuel-markup--tag)
141     ($tags . fuel-markup--tags)
142     ($unchecked-example . fuel-markup--example)
143     ($value . fuel-markup--value)
144     ($values . fuel-markup--values)
145     ($values-x/y . fuel-markup--values-x/y)
146     ($var-description . fuel-markup--var-description)
147     ($vocab-link . fuel-markup--vocab-link)
148     ($vocab-links . fuel-markup--vocab-links)
149     ($vocab-subsection . fuel-markup--vocab-subsection)
150     ($vocabulary . fuel-markup--vocabulary)
151     ($warning . fuel-markup--warning)
152     (article . fuel-markup--article)
153     (describe-words . fuel-markup--describe-words)
154     (vocab-list . fuel-markup--vocab-list)))
155
156 (make-variable-buffer-local
157  (defvar fuel-markup--maybe-nl nil))
158
159 (defun fuel-markup--print (e)
160   (cond ((null e) (insert "f"))
161         ((stringp e) (fuel-markup--insert-string e))
162         ((and (listp e) (symbolp (car e))
163               (assoc (car e) fuel-markup--printers))
164          (funcall (cdr (assoc (car e) fuel-markup--printers)) e))
165         ((and (symbolp e)
166               (assoc e fuel-markup--printers))
167          (funcall (cdr (assoc e fuel-markup--printers)) e))
168         ((listp e) (mapc 'fuel-markup--print e))
169         ((symbolp e) (fuel-markup--print (list '$link e)))
170         (t (insert (format "\n%S\n" e)))))
171
172 (defun fuel-markup--print-str (e)
173   (with-temp-buffer
174     (fuel-markup--print e)
175     (buffer-string)))
176
177 (defun fuel-markup--maybe-nl ()
178   (setq fuel-markup--maybe-nl (point)))
179
180 (defun fuel-markup--insert-newline (&optional justification nosqueeze)
181   (fill-region (save-excursion (beginning-of-line) (point))
182                (point)
183                (or justification 'left)
184                nosqueeze)
185   (newline))
186
187 (defsubst fuel-markup--insert-nl-if-nb (&optional no-fill)
188   (unless (eq (save-excursion (beginning-of-line) (point)) (point))
189     (if no-fill (newline) (fuel-markup--insert-newline))))
190
191 (defsubst fuel-markup--put-face (txt face)
192   (put-text-property 0 (length txt) 'font-lock-face face txt)
193   txt)
194
195 (defun fuel-markup--insert-heading (txt &optional no-nl)
196   (fuel-markup--insert-nl-if-nb)
197   (delete-blank-lines)
198   (unless (bobp) (newline))
199   (fuel-markup--put-face txt 'fuel-font-lock-markup-heading)
200   (fuel-markup--insert-string txt)
201   (unless no-nl (newline)))
202
203 (defun fuel-markup--insert-string (str)
204   (when fuel-markup--maybe-nl
205     (newline 2)
206     (setq fuel-markup--maybe-nl nil))
207   (insert str))
208
209 (defun fuel-markup--article (e)
210   (setq fuel-markup--maybe-nl nil)
211   (insert (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-title))
212   (newline 2)
213   (fuel-markup--print (car (cddr e))))
214
215 (defun fuel-markup--heading (e)
216   (fuel-markup--insert-heading (cadr e)))
217
218 (defun fuel-markup--subheading (e)
219   (fuel-markup--insert-heading (cadr e)))
220
221 (defun fuel-markup--subsection (e)
222   (fuel-markup--insert-nl-if-nb)
223   (insert "  - ")
224   (fuel-markup--link (cons '$link (cdr e)))
225   (fuel-markup--maybe-nl))
226
227 (defun fuel-markup--vocab-subsection (e)
228   (fuel-markup--insert-nl-if-nb)
229   (insert "  - ")
230   (fuel-markup--vocab-link (cons '$vocab-link (cdr e)))
231   (fuel-markup--maybe-nl))
232
233 (defun fuel-markup--newline (e)
234   (fuel-markup--insert-newline)
235   (newline))
236
237 (defun fuel-markup--doc-path (e)
238   (fuel-markup--insert-heading "Related topics")
239   (insert "  ")
240   (dolist (art (cdr e))
241     (fuel-markup--insert-button (car art) (cadr art) 'article)
242     (insert ", "))
243   (delete-backward-char 2)
244   (fuel-markup--insert-newline 'left))
245
246 (defun fuel-markup--emphasis (e)
247   (when (stringp (cadr e))
248     (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-emphasis)
249     (insert (cadr e))))
250
251 (defun fuel-markup--strong (e)
252   (when (stringp (cadr e))
253     (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-strong)
254     (insert (cadr e))))
255
256 (defun fuel-markup--snippet (e)
257   (insert (mapconcat '(lambda (s)
258                         (if (stringp s)
259                             (fuel-font-lock--factor-str s)
260                           (fuel-markup--print-str s)))
261                      (cdr e)
262                      " ")))
263
264 (defun fuel-markup--code (e)
265   (fuel-markup--insert-nl-if-nb)
266   (newline)
267   (dolist (snip (cdr e))
268     (if (stringp snip)
269         (insert (fuel-font-lock--factor-str snip))
270       (fuel-markup--print snip))
271     (newline))
272   (newline))
273
274 (defun fuel-markup--command (e)
275   (fuel-markup--snippet (list '$snippet (nth 3 e))))
276
277 (defun fuel-markup--syntax (e)
278   (fuel-markup--insert-heading "Syntax")
279   (fuel-markup--print (cons '$code (cdr e)))
280   (newline))
281
282 (defun fuel-markup--example (e)
283   (fuel-markup--insert-newline)
284   (dolist (s (cdr e))
285     (fuel-markup--snippet (list '$snippet s))
286     (newline))
287   (newline))
288
289 (defun fuel-markup--markup-example (e)
290   (fuel-markup--insert-newline)
291   (fuel-markup--snippet (cons '$snippet (cdr e))))
292
293 (defun fuel-markup--link (e)
294   (let* ((link (or (nth 1 e) 'f))
295          (type (or (nth 3 e) (if (symbolp link) 'word 'article)))
296          (label (or (nth 2 e)
297                     (and (eq type 'article)
298                          (fuel-markup--article-title link))
299                     link)))
300     (fuel-markup--insert-button label link type)))
301
302 (defun fuel-markup--links (e)
303   (dolist (link (cdr e))
304     (fuel-markup--link (list '$link link))
305     (insert ", "))
306   (delete-backward-char 2))
307
308 (defun fuel-markup--index-quotation (q)
309   (cond ((null q) null)
310         ((listp q) (vconcat (mapcar 'fuel-markup--index-quotation q)))
311         (t q)))
312
313 (defun fuel-markup--index (e)
314   (let* ((q (fuel-markup--index-quotation (cadr e)))
315          (cmd `(:fuel* ((,q fuel-index)) "fuel"
316                        ("builtins" "help" "help.topics" "classes"
317                         "classes.builtin" "classes.tuple"
318                         "classes.singleton" "classes.union"
319                         "classes.intersection" "classes.predicate")))
320          (subs (fuel-eval--retort-result (fuel-eval--send/wait cmd 200))))
321     (when subs
322       (let ((start (point))
323             (sort-fold-case nil))
324         (fuel-markup--print subs)
325         (sort-lines nil start (point))))))
326
327 (defun fuel-markup--vocab-link (e)
328   (fuel-markup--insert-button (cadr e) (or (car (cddr e)) (cadr e)) 'vocab))
329
330 (defun fuel-markup--vocab-links (e)
331   (dolist (link (cdr e))
332     (insert " ")
333     (fuel-markup--vocab-link (list '$vocab-link link))
334     (insert " ")))
335
336 (defun fuel-markup--vocab-list (e)
337   (let ((rows (mapcar '(lambda (elem)
338                          (list (list '$vocab-link (car elem))
339                                (cadr elem)))
340                       (cdr e))))
341     (fuel-markup--table (cons '$table rows))))
342
343 (defun fuel-markup--describe-vocab (e)
344   (fuel-markup--insert-nl-if-nb)
345   (let* ((cmd `(:fuel* ((,(cadr e) fuel-vocab-help)) "fuel" t))
346          (res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
347     (when res (fuel-markup--print res))))
348
349 (defun fuel-markup--vocabulary (e)
350   (fuel-markup--insert-heading "Vocabulary: " t)
351   (fuel-markup--vocab-link (cons '$vocab-link (cdr e)))
352   (newline))
353
354 (defun fuel-markup--parse-classes ()
355   (let ((elems))
356     (while (looking-at ".+ classes$")
357       (let ((heading `($heading ,(match-string-no-properties 0)))
358             (rows))
359         (forward-line)
360         (when (looking-at "Class *.+$")
361           (push (split-string (match-string-no-properties 0) nil t) rows)
362           (forward-line))
363         (while (not (looking-at "$"))
364           (let* ((objs (split-string (thing-at-point 'line) nil t))
365                  (class (list '$link (car objs) (car objs) 'word))
366                  (super (and (cadr objs)
367                              (list (list '$link (cadr objs) (cadr objs) 'word))))
368                  (slots (when (cddr objs)
369                           (list (mapcar '(lambda (s) (list s " ")) (cddr objs))))))
370             (push `(,class ,@super ,@slots) rows))
371           (forward-line))
372         (push `(,heading ($table ,@(reverse rows))) elems))
373       (forward-line))
374     (reverse elems)))
375
376 (defun fuel-markup--parse-words ()
377   (let ((elems))
378     (while (looking-at ".+ words\\|Primitives$")
379       (let ((heading `($heading ,(match-string-no-properties 0)))
380             (rows))
381         (forward-line)
382         (when (looking-at "Word *\\(Stack effect\\|Syntax\\)$")
383           (push (list "Word" (match-string-no-properties 1)) rows)
384           (forward-line))
385         (while (looking-at "\\(.+?\\)\\( +\\(.+\\)\\)?$")
386           (let ((word `($link ,(match-string-no-properties 1)
387                               ,(match-string-no-properties 1)
388                               word))
389                 (se (and (match-string-no-properties 3)
390                          `(($snippet ,(match-string-no-properties 3))))))
391             (push `(,word ,@se) rows))
392           (forward-line))
393         (push `(,heading ($table ,@(reverse rows))) elems))
394       (forward-line))
395     (reverse elems)))
396
397 (defun fuel-markup--parse-words-desc (desc)
398   (with-temp-buffer
399     (insert desc)
400     (goto-char (point-min))
401     (when (re-search-forward "^Words$" nil t)
402       (forward-line 2)
403       (let ((elems '(($heading "Words"))))
404         (push (fuel-markup--parse-classes) elems)
405         (push (fuel-markup--parse-words) elems)
406         (reverse elems)))))
407
408 (defun fuel-markup--describe-words (e)
409   (when (cadr e)
410     (fuel-markup--print (fuel-markup--parse-words-desc (cadr e)))))
411
412 (defun fuel-markup--tag (e)
413   (fuel-markup--link (list '$link (cadr e) (cadr e) 'tag)))
414
415 (defun fuel-markup--tags (e)
416   (when (cdr e)
417     (fuel-markup--insert-heading "Tags: " t)
418     (dolist (tag (cdr e))
419       (fuel-markup--tag (list '$tag tag))
420       (insert ", "))
421     (delete-backward-char 2)
422     (fuel-markup--insert-newline)))
423
424 (defun fuel-markup--all-tags (e)
425   (let* ((cmd `(:fuel* (all-tags :get) "fuel" t))
426          (tags (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
427     (fuel-markup--list
428      (cons '$list (mapcar (lambda (tag) (list '$link tag tag 'tag)) tags)))))
429
430 (defun fuel-markup--author (e)
431   (fuel-markup--link (list '$link (cadr e) (cadr e) 'author)))
432
433 (defun fuel-markup--authors (e)
434   (when (cdr e)
435     (fuel-markup--insert-heading "Authors: " t)
436     (dolist (a (cdr e))
437       (fuel-markup--author (list '$author a))
438       (insert ", "))
439     (delete-backward-char 2)
440     (fuel-markup--insert-newline)))
441
442 (defun fuel-markup--all-authors (e)
443   (let* ((cmd `(:fuel* (all-authors :get) "fuel" t))
444          (authors (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
445     (fuel-markup--list
446      (cons '$list (mapcar (lambda (a) (list '$link a a 'author)) authors)))))
447
448 (defun fuel-markup--list (e)
449   (fuel-markup--insert-nl-if-nb)
450   (dolist (elt (cdr e))
451     (insert " - ")
452     (fuel-markup--print elt)
453     (fuel-markup--insert-newline)))
454
455 (defun fuel-markup--table (e)
456   (fuel-markup--insert-newline)
457   (delete-blank-lines)
458   (newline)
459   (fuel-table--insert
460    (mapcar '(lambda (row) (mapcar 'fuel-markup--print-str row)) (cdr e)))
461   (newline))
462
463 (defun fuel-markup--instance (e)
464   (insert " an instance of ")
465   (fuel-markup--print (cadr e)))
466
467 (defun fuel-markup--maybe (e)
468   (fuel-markup--instance (cons '$instance (cdr e)))
469   (insert " or f "))
470
471 (defun fuel-markup--or (e)
472   (let ((fst (car (cdr e)))
473         (mid (butlast (cddr e)))
474         (lst (car (last (cdr e)))))
475     (insert (format "%s" fst))
476     (dolist (m mid) (insert (format ", %s" m)))
477     (insert (format " or %s" lst))))
478
479 (defun fuel-markup--values (e)
480   (fuel-markup--insert-heading "Inputs and outputs")
481   (dolist (val (cdr e))
482     (insert " " (car val) " - ")
483     (fuel-markup--print (cdr val))
484     (newline)))
485
486 (defun fuel-markup--predicate (e)
487   (fuel-markup--values '($values ("object" object) ("?" "a boolean")))
488   (let ((word (make-symbol (substring (format "%s" (cadr e)) 0 -1))))
489   (fuel-markup--description
490    `($description "Tests if the object is an instance of the "
491                   ($link ,word) " class."))))
492
493 (defun fuel-markup--side-effects (e)
494   (fuel-markup--insert-heading "Side effects")
495   (insert "Modifies ")
496   (fuel-markup--print (cdr e))
497   (fuel-markup--insert-newline))
498
499 (defun fuel-markup--definition (e)
500   (fuel-markup--insert-heading "Definition")
501   (fuel-markup--code (cons '$code (cdr e))))
502
503 (defun fuel-markup--methods (e)
504   (fuel-markup--insert-heading "Methods")
505   (fuel-markup--code (cons '$code (cdr e))))
506
507 (defun fuel-markup--value (e)
508   (fuel-markup--insert-heading "Variable value")
509   (insert "Current value in global namespace: ")
510   (fuel-markup--snippet (cons '$snippet (cdr e)))
511   (newline))
512
513 (defun fuel-markup--values-x/y (e)
514   (fuel-markup--values '($values ("x" "number") ("y" "number"))))
515
516 (defun fuel-markup--curious (e)
517   (fuel-markup--insert-heading "For the curious...")
518   (fuel-markup--print (cdr e)))
519
520 (defun fuel-markup--references (e)
521   (fuel-markup--insert-heading "References")
522   (dolist (ref (cdr e))
523     (if (listp ref)
524         (fuel-markup--print ref)
525       (fuel-markup--subsection (list '$subsection ref)))))
526
527 (defun fuel-markup--see-also (e)
528   (fuel-markup--insert-heading "See also")
529   (fuel-markup--links (cons '$links (cdr e))))
530
531 (defun fuel-markup--related (e)
532   (fuel-markup--insert-heading "See also")
533   (fuel-markup--links (cons '$links (cadr e))))
534
535 (defun fuel-markup--shuffle (e)
536   (insert "\nShuffle word. Re-arranges the stack "
537           "according to the stack effect pattern.")
538   (fuel-markup--insert-newline))
539
540 (defun fuel-markup--low-level-note (e)
541   (fuel-markup--print '($notes "Calling this word directly is not necessary "
542                                "in most cases. "
543                                "Higher-level words call it automatically.")))
544
545 (defun fuel-markup--parsing-note (e)
546   (fuel-markup--insert-nl-if-nb)
547   (insert "This word should only be called from parsing words.")
548   (fuel-markup--insert-newline))
549
550 (defun fuel-markup--io-error (e)
551   (fuel-markup--errors '($errors "Throws an error if the I/O operation fails.")))
552
553 (defun fuel-markup--prettyprinting-note (e)
554   (fuel-markup--print '($notes ("This word should only be called within the "
555                                 ($link with-pprint) " combinator."))))
556
557 (defun fuel-markup--elem-with-heading (elem heading)
558   (fuel-markup--insert-heading heading)
559   (fuel-markup--print (cdr elem))
560   (fuel-markup--insert-newline))
561
562 (defun fuel-markup--quotation (e)
563   (insert "a ")
564   (fuel-markup--link (list '$link 'quotation 'quotation 'word))
565   (insert " with stack effect ")
566   (fuel-markup--snippet (list '$snippet (nth 1 e))))
567
568 (defun fuel-markup--warning (e)
569   (fuel-markup--elem-with-heading e "Warning"))
570
571 (defun fuel-markup--description (e)
572   (fuel-markup--elem-with-heading e "Word description"))
573
574 (defun fuel-markup--class-description (e)
575   (fuel-markup--elem-with-heading e "Class description"))
576
577 (defun fuel-markup--error-description (e)
578   (fuel-markup--elem-with-heading e "Error description"))
579
580 (defun fuel-markup--var-description (e)
581   (fuel-markup--elem-with-heading e "Variable description"))
582
583 (defun fuel-markup--contract (e)
584   (fuel-markup--elem-with-heading e "Generic word contract"))
585
586 (defun fuel-markup--errors (e)
587   (fuel-markup--elem-with-heading e "Errors"))
588
589 (defun fuel-markup--examples (e)
590   (fuel-markup--elem-with-heading e "Examples"))
591
592 (defun fuel-markup--notes (e)
593   (fuel-markup--elem-with-heading e "Notes"))
594
595 (defun fuel-markup--word-info (e s)
596   (let* ((word (nth 1 e))
597          (cmd (and word `(:fuel* ((:quote ,(format "%s" word)) ,s) "fuel")))
598          (ret (and cmd (fuel-eval--send/wait cmd)))
599          (res (and (not (fuel-eval--retort-error ret))
600                    (fuel-eval--retort-output ret))))
601     (if res
602         (fuel-markup--code (list '$code res))
603       (fuel-markup--snippet (list '$snippet " " word)))))
604
605 (defun fuel-markup--see (e)
606   (fuel-markup--word-info e 'see))
607
608 (defun fuel-markup--synopsis (e)
609   (fuel-markup--word-info e 'synopsis))
610
611 (defun fuel-markup--null (e))
612
613 \f
614 (provide 'fuel-markup)
615 ;;; fuel-markup.el ends here