1 ;;; fuel-markup.el -- printing factor help markup -*- lexical-binding: t -*-
3 ;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
4 ;; See http://factorcode.org/license.txt for BSD license.
6 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
7 ;; Keywords: languages, fuel, factor
8 ;; Start date: Thu Jan 01, 2009 21:43
12 ;; Utilities for printing Factor's help markup.
25 (defface fuel-font-lock-markup-title '((t (:inherit bold)))
26 "article titles in help buffers"
31 (defface fuel-font-lock-markup-heading '((t (:inherit bold)))
32 "headlines in help buffers"
37 (defface fuel-font-lock-markup-link '((t (:inherit link)))
38 "links to topics in help buffers"
43 (defface fuel-font-lock-markup-emphasis '((t (:inherit italic)))
44 "emphasized words in help buffers"
49 (defface fuel-font-lock-markup-strong '((t (:inherit link)))
50 "bold words in help buffers"
58 (defvar-local fuel-markup--follow-link-function 'fuel-markup--echo-link)
60 (define-button-type 'fuel-markup--button
61 'action 'fuel-markup--follow-link
62 'face 'fuel-font-lock-markup-link
65 (defun fuel-markup--follow-link (button)
66 (when fuel-markup--follow-link-function
67 (funcall fuel-markup--follow-link-function
68 (button-get button 'markup-link)
69 (button-get button 'markup-label)
70 (button-get button 'markup-link-type))))
72 (defun fuel-markup--echo-link (link label type)
73 (message "Link %s pointing to %s named %s" label type link))
75 (defun fuel-markup--insert-button (label link type)
76 (let ((label (format "%s" label))
77 (link (if (listp link) link (format "%s" link))))
78 (insert-text-button label
79 :type 'fuel-markup--button
82 'markup-link-type type
83 'help-echo (format "%s (%s)" label type))))
85 (defun fuel-markup--article-title (name)
86 (let ((name (if (listp name) (cons :seq name) name)))
87 (fuel-eval--retort-result
88 (fuel-eval--send/wait `(:fuel* ((,name fuel-get-article-title)) "fuel")))))
90 (defun fuel-markup--link-at-point ()
91 (let ((button (condition-case nil (forward-button 0) (error nil))))
93 (list (button-get button 'markup-link)
94 (button-get button 'markup-label)
95 (button-get button 'markup-link-type)))))
97 (defun fuel-markup--nav-crumbs (e)
98 (fuel-markup--links e " > ")
103 (defconst fuel-markup--printers
104 '(($all-tags . fuel-markup--all-tags)
105 ($all-authors . fuel-markup--all-authors)
106 ($author . fuel-markup--author)
107 ($authors . fuel-markup--authors)
108 ($class-description . fuel-markup--class-description)
109 ($code . (lambda (e) (fuel-markup--code e t)))
110 ($command . fuel-markup--command)
111 ($command-map . fuel-markup--null)
112 ($complex-shuffle . fuel-markup--complex-shuffle)
113 ($contract . fuel-markup--contract)
114 ($curious . fuel-markup--curious)
115 ($definition . fuel-markup--definition)
116 ($description . fuel-markup--description)
117 ($doc-path . fuel-markup--doc-path)
118 ($emphasis . fuel-markup--emphasis)
119 ($error-description . fuel-markup--error-description)
120 ($errors . fuel-markup--errors)
121 ($example . (lambda (e) (fuel-markup--code e t)))
122 ($examples . fuel-markup--examples)
123 ($fuel-nav-crumbs . fuel-markup--nav-crumbs)
124 ($heading . fuel-markup--heading)
125 ($index . fuel-markup--index)
126 ($instance . fuel-markup--instance)
127 ($io-error . fuel-markup--io-error)
128 ($link . fuel-markup--link)
129 ($links . (lambda (e) (fuel-markup--links e ", ")))
130 ($list . fuel-markup--list)
131 ($low-level-note . fuel-markup--low-level-note)
132 ($markup-example . fuel-markup--markup-example)
133 ($maybe . fuel-markup--maybe)
134 ($sequence . fuel-markup--sequence)
135 ($methods . fuel-markup--methods)
136 ($next-link . (lambda (e) (fuel-markup--prefixed-link "Next:" e)))
137 ($nl . fuel-markup--newline)
138 ($notes . fuel-markup--notes)
139 ($operation . fuel-markup--link)
140 ($or . fuel-markup--or)
141 ($parsing-note . fuel-markup--parsing-note)
142 ($predicate . fuel-markup--predicate)
143 ($prettyprinting-note . fuel-markup--prettyprinting-note)
144 ($prev-link . (lambda (e) (fuel-markup--prefixed-link "Prev:" e)))
145 ($quotation . fuel-markup--quotation)
146 ($references . fuel-markup--references)
147 ($related . fuel-markup--related)
148 ($see . fuel-markup--word-info)
149 ($see-also . fuel-markup--see-also)
150 ($shuffle . fuel-markup--shuffle)
151 ($side-effects . fuel-markup--side-effects)
152 ($slot . fuel-markup--snippet)
153 ($snippet . fuel-markup--snippet)
154 ($strong . fuel-markup--strong)
155 ($subheading . fuel-markup--subheading)
156 ($subsection . fuel-markup--subsection)
157 ($subsections . fuel-markup--subsections)
158 ($synopsis . fuel-markup--word-info)
159 ($syntax . fuel-markup--syntax)
160 ($table . fuel-markup--table)
161 ($tag . fuel-markup--tag)
162 ($tags . fuel-markup--tags)
163 ($unchecked-example . (lambda (e) (fuel-markup--code e t)))
164 ($url . fuel-markup--url)
165 ($value . fuel-markup--value)
166 ($values . fuel-markup--values)
167 ($values-x/y . fuel-markup--values-x/y)
168 ($var-description . fuel-markup--var-description)
169 ($vocab . fuel-markup--vocab)
170 ($vocab-link . fuel-markup--vocab-link)
171 ($vocab-links . fuel-markup--vocab-links)
172 ($vocab-subsection . fuel-markup--vocab-subsection)
173 ($warning . fuel-markup--warning)
174 (article . fuel-markup--article)
175 (describe-words . fuel-markup--describe-words)
176 (vocab-list . fuel-markup--vocab-list)))
178 (defvar-local fuel-markup--maybe-nl nil)
180 (defun fuel-markup--print (e)
181 (cond ((null e) (insert "f"))
182 ((stringp e) (fuel-markup--insert-string e))
183 ((and (listp e) (symbolp (car e))
184 (assoc (car e) fuel-markup--printers))
185 (funcall (alist-get (car e) fuel-markup--printers) e))
187 (assoc e fuel-markup--printers))
188 (funcall (alist-get e fuel-markup--printers) e))
189 ((listp e) (mapc 'fuel-markup--print e))
190 ((symbolp e) (fuel-markup--print (list '$link e)))
191 (t (insert (format "\n%S\n" e)))))
193 (defun fuel-markup--print-str (e)
195 (fuel-markup--print e)
198 (defun fuel-markup--maybe-nl ()
199 (setq fuel-markup--maybe-nl (point)))
201 (defun fuel-markup--insert-newline (&optional justification nosqueeze)
202 (fill-region (save-excursion (beginning-of-line) (point))
204 (or justification 'left)
208 (defsubst fuel-markup--insert-nl-if-nb (&optional no-fill)
209 (unless (eq (save-excursion (beginning-of-line) (point)) (point))
210 (if no-fill (newline) (fuel-markup--insert-newline))))
212 (defsubst fuel-markup--put-face (txt face)
213 (put-text-property 0 (length txt) 'font-lock-face face txt)
216 (defun fuel-markup--insert-heading (txt &optional no-nl)
217 (fuel-markup--insert-nl-if-nb)
219 (unless (bobp) (newline))
220 (fuel-markup--put-face txt 'fuel-font-lock-markup-heading)
221 (fuel-markup--insert-string txt)
222 (unless no-nl (newline)))
224 (defun fuel-markup--insert-string (str)
225 (when fuel-markup--maybe-nl
227 (setq fuel-markup--maybe-nl nil))
230 (defun fuel-markup--article (e)
231 (setq fuel-markup--maybe-nl nil)
232 (insert (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-title))
234 (fuel-markup--print (car (cddr e))))
236 (defun fuel-markup--heading (e)
237 (fuel-markup--insert-heading (cadr e)))
239 (defun fuel-markup--subheading (e)
240 (fuel-markup--insert-heading (cadr e)))
242 (defun fuel-markup--subsection (e)
243 (fuel-markup--insert-nl-if-nb)
245 (fuel-markup--link (cons '$link (cdr e)))
246 (fuel-markup--maybe-nl))
248 (defun fuel-markup--subsections (e)
249 (dolist (link (cdr e))
250 (fuel-markup--insert-nl-if-nb)
252 (fuel-markup--link (list '$link link))
253 (fuel-markup--maybe-nl)))
255 (defun fuel-markup--vocab-subsection (e)
256 (fuel-markup--insert-nl-if-nb)
258 (fuel-markup--vocab-link (cons '$vocab-link (cdr e)))
259 (fuel-markup--maybe-nl))
261 (defun fuel-markup--newline (e)
262 (fuel-markup--insert-newline)
265 (defun fuel-markup--doc-path (e)
266 (fuel-markup--insert-heading "Related topics")
268 (dolist (art (cdr e))
269 (fuel-markup--insert-button (car art) (cadr art) 'article)
272 (fuel-markup--insert-newline 'left))
274 (defun fuel-markup--emphasis (e)
275 (when (stringp (cadr e))
276 (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-emphasis)
279 (defun fuel-markup--strong (e)
280 (when (stringp (cadr e))
281 (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-strong)
284 (define-button-type 'fuel-markup--url
285 'action 'fuel-markup--follow-url
286 'face 'fuel-font-lock-markup-link
289 (defun fuel-markup--follow-url (button)
290 (browse-url (button-get button 'markup-link)))
292 (defun fuel-markup--url (e)
293 (let ((url (cadr e)))
294 (insert-text-button url
295 :type 'fuel-markup--url
298 (defun fuel-markup--snippet (e)
299 (insert (mapconcat #'(lambda (s)
301 (factor-font-lock-string s)
302 (fuel-markup--print-str s)))
306 (defun fuel-markup--code (e indent)
307 (fuel-markup--insert-nl-if-nb)
309 (dolist (snip (cdr e))
310 (unless (stringp snip)
311 (error "snip is not a string"))
312 (dolist (line (split-string (factor-font-lock-string snip) "\n"))
313 (when indent (insert " "))
318 (defun fuel-markup--command (e)
319 (fuel-markup--snippet (list '$snippet (nth 3 e))))
321 (defun fuel-markup--syntax (e)
322 (fuel-markup--insert-heading "Syntax")
323 (fuel-markup--print (cons '$code (cdr e)))
326 (defun fuel-markup--markup-example (e)
327 (fuel-markup--insert-newline)
328 (fuel-markup--snippet (cons '$snippet (cdr e))))
330 (defun fuel-markup--link (e)
331 (let* ((link (or (nth 1 e) 'f))
332 (type (or (nth 3 e) (if (symbolp link) 'word 'article)))
334 (and (eq type 'article)
335 (fuel-markup--article-title link))
337 (fuel-markup--insert-button label link type)))
339 (defun fuel-markup--links (e sep)
340 "Inserts a sequence of links. Used for rendering see also lists
341 and breadcrumb navigation. The items in e can either be strings
343 (let ((links (cdr e)))
346 (message (format "link %s" link))
352 (delete-char (- (length sep))))))
354 (defun fuel-markup--index-quotation (q)
356 ((listp q) (vconcat (mapcar 'fuel-markup--index-quotation q)))
359 (defun fuel-markup--index (e)
360 (let* ((q (fuel-markup--index-quotation (cadr e)))
361 (cmd `(:fuel* ((,q fuel-index)) "fuel"
362 ("assocs" "builtins" "classes" "classes.builtin"
363 "classes.intersection" "classes.predicate"
364 "classes.singleton" "classes.tuple" "classes.union"
365 "help" "help.topics" "namespaces" "sequences"
367 (subs (fuel-eval--retort-result (fuel-eval--send/wait cmd 200))))
369 (let ((start (point))
370 (sort-fold-case nil))
371 (fuel-markup--print subs)
372 (sort-lines nil start (point))))))
374 (defun fuel-markup--vocab-link (e)
375 (fuel-markup--insert-button (cadr e) (or (car (cddr e)) (cadr e)) 'vocab))
377 (defun fuel-markup--vocab-links (e)
378 (dolist (link (cdr e))
380 (fuel-markup--vocab-link (list '$vocab-link link))
383 (defun fuel-markup--vocab-list (e)
384 (let ((rows (mapcar #'(lambda (elem)
385 (list (list '$vocab-link (car elem))
388 (fuel-markup--table (cons '$table rows))))
390 (defun fuel-markup--vocab (e)
391 (fuel-markup--insert-nl-if-nb)
392 (let* ((cmd `(:fuel* ((,(cadr e) fuel-vocab-help)) "fuel" t))
393 (res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
394 (when res (fuel-markup--print res))))
396 (defun fuel-markup--parse-classes ()
398 (while (looking-at ".+ classes$")
399 (let ((heading `($heading ,(match-string-no-properties 0)))
402 (when (looking-at "Class *.+$")
403 (push (split-string (match-string-no-properties 0) nil t) rows)
405 (while (not (looking-at "$"))
406 (let* ((objs (split-string (thing-at-point 'line) nil t))
407 (class (list '$link (car objs) (car objs) 'word))
408 (super (and (cadr objs)
409 (list (list '$link (cadr objs) (cadr objs) 'word))))
410 (slots (when (cddr objs)
411 (list (mapcar #'(lambda (s) (list s " ")) (cddr objs))))))
412 (push `(,class ,@super ,@slots) rows))
414 (push `(,heading ($table ,@(reverse rows))) elems))
418 (defun fuel-markup--parse-words ()
420 (while (looking-at ".+ words\\|Primitives$")
421 (let ((heading `($heading ,(match-string-no-properties 0)))
424 (when (looking-at "Word *\\(Stack effect\\|Syntax\\)$")
425 (push (list "Word" (match-string-no-properties 1)) rows)
427 (while (looking-at " ?\\(.+?\\)\\( +\\(.+\\)\\)?$")
428 (let ((word `($link ,(match-string-no-properties 1)
429 ,(match-string-no-properties 1)
431 (se (and (match-string-no-properties 3)
432 `(($snippet ,(match-string-no-properties 3))))))
433 (push `(,word ,@se) rows))
435 (push `(,heading ($table ,@(reverse rows))) elems))
439 (defun fuel-markup--parse-words-desc (desc)
440 "This function parses the text description of the vocab that
441 the 'words.' word emits."
444 (goto-char (point-min))
445 (when (re-search-forward "^Words$" nil t)
447 (let ((elems '(($heading "Words"))))
448 (push (fuel-markup--parse-classes) elems)
449 (push (fuel-markup--parse-words) elems)
450 (reverse (remove nil elems))))))
452 (defun fuel-markup--describe-words (e)
454 (fuel-markup--print (fuel-markup--parse-words-desc (cadr e)))))
456 (defun fuel-markup--tag (e)
457 (fuel-markup--link (list '$link (cadr e) (cadr e) 'tag)))
459 (defun fuel-markup--tags (e)
461 (fuel-markup--insert-heading "Tags: " t)
462 (dolist (tag (cdr e))
463 (fuel-markup--tag (list '$tag tag))
466 (fuel-markup--insert-newline)))
468 (defun fuel-markup--all-tags (e)
469 (let* ((cmd `(:fuel* (all-tags) "fuel" t))
470 (tags (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
472 (cons '$list (mapcar (lambda (tag) (list '$link tag tag 'tag)) tags)))))
474 (defun fuel-markup--author (e)
475 (fuel-markup--link (list '$link (cadr e) (cadr e) 'author)))
477 (defun fuel-markup--authors (e)
479 (fuel-markup--insert-heading "Authors: " t)
481 (fuel-markup--author (list '$author a))
484 (fuel-markup--insert-newline)))
486 (defun fuel-markup--all-authors (e)
487 (let* ((cmd `(:fuel* (all-authors) "fuel" t))
488 (authors (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
490 (cons '$list (mapcar (lambda (a) (list '$link a a 'author)) authors)))))
492 (defun fuel-markup--complex-shuffle (e)
493 (fuel-markup--description
494 `($description "Shuffle word. Rearranges the top of the datastack as "
495 "indicated in the stack effect pattern."))
496 (fuel-markup--elem-with-heading
497 `(nil "The data flow represented by this shuffle word can be more clearly "
498 "expressed using " ($vocab-link "Lexical variables" "locals") ".")
499 "This word is deprecated"))
501 (defun fuel-markup--list (e)
502 (fuel-markup--insert-nl-if-nb)
503 (dolist (elt (cdr e))
505 (fuel-markup--print elt)
506 (fuel-markup--insert-newline)))
508 (defun fuel-markup--table (e)
509 (fuel-markup--insert-newline)
513 (mapcar #'(lambda (row) (mapcar 'fuel-markup--print-str row)) (cdr e)))
516 (defun fuel-markup--instance (e)
517 (insert " an instance of ")
518 (fuel-markup--print (cadr e)))
520 (defun fuel-markup--maybe (e)
521 (fuel-markup--instance (cons '$instance (cdr e)))
524 (defun fuel-markup--sequence (e)
526 (fuel-markup--link (list '$link 'sequence 'sequence 'word))
528 (fuel-markup--print (cadr e))
531 (defun fuel-markup--or (e)
532 (let ((fst (car (cdr e)))
533 (mid (butlast (cddr e)))
534 (lst (car (last (cdr e)))))
535 (insert (format "%s" fst))
536 (dolist (m mid) (insert (format ", %s" m)))
537 (insert (format " or %s" lst))))
539 (defun fuel-markup--values (e)
540 (fuel-markup--insert-heading "Inputs and outputs")
541 (dolist (val (cdr e))
542 (insert " " (car val) " - ")
543 (fuel-markup--print (cdr val))
546 (defun fuel-markup--predicate (e)
547 (fuel-markup--values '($values ("object" object) ("?" "a boolean")))
548 (let ((word (make-symbol (substring (format "%s" (cadr e)) 0 -1))))
549 (fuel-markup--description
550 `($description "Tests if the object is an instance of the "
551 ($link ,word) " class."))))
553 (defun fuel-markup--side-effects (e)
554 (fuel-markup--insert-heading "Side effects")
556 (fuel-markup--print (cdr e))
557 (fuel-markup--insert-newline))
559 (defun fuel-markup--definition (e)
560 (fuel-markup--insert-heading "Definition")
561 (fuel-markup--code (cons '$code (cdr e)) nil))
563 (defun fuel-markup--methods (e)
564 (fuel-markup--insert-heading "Methods")
565 (fuel-markup--code (cons '$code (cdr e)) nil))
567 (defun fuel-markup--value (e)
568 (fuel-markup--insert-heading "Variable value")
569 (insert "Current value in global namespace: ")
570 (fuel-markup--snippet (cons '$snippet (cdr e)))
573 (defun fuel-markup--values-x/y (e)
574 (fuel-markup--values '($values ("x" "number") ("y" "number"))))
576 (defun fuel-markup--curious (e)
577 (fuel-markup--insert-heading "For the curious...")
578 (fuel-markup--print (cdr e)))
580 (defun fuel-markup--references (e)
581 (fuel-markup--insert-heading "References")
582 (dolist (ref (cdr e))
584 (fuel-markup--print ref)
585 (fuel-markup--subsection (list '$subsection ref)))))
587 (defun fuel-markup--see-also (e)
588 (fuel-markup--insert-heading "See also")
589 (fuel-markup--links (cons '$links (cdr e)) ", "))
591 (defun fuel-markup--related (e)
592 (fuel-markup--insert-heading "See also")
593 (fuel-markup--links (cons '$links (cadr e)) ", "))
595 (defun fuel-markup--shuffle (e)
596 (insert "\nShuffle word. Re-arranges the stack "
597 "according to the stack effect pattern.")
598 (fuel-markup--insert-newline))
600 (defun fuel-markup--low-level-note (e)
601 (fuel-markup--print '($notes "Calling this word directly is not necessary "
603 "Higher-level words call it automatically.")))
605 (defun fuel-markup--parsing-note (e)
606 (fuel-markup--insert-nl-if-nb)
607 (insert "This word should only be called from parsing words.")
608 (fuel-markup--insert-newline))
610 (defun fuel-markup--io-error (e)
611 (fuel-markup--errors '($errors "Throws an error if the I/O operation fails.")))
613 (defun fuel-markup--prettyprinting-note (e)
614 (fuel-markup--print '($notes ("This word should only be called within the "
615 ($link with-pprint) " combinator."))))
617 (defun fuel-markup--prefixed-link (prefix e)
618 (insert (format " %s " prefix))
619 (fuel-markup--link e)
622 (defun fuel-markup--elem-with-heading (elem heading)
623 (fuel-markup--insert-heading heading)
624 (fuel-markup--print (cdr elem))
625 (fuel-markup--insert-newline))
627 (defun fuel-markup--stack-effect (e)
628 (let* ((in (mapconcat 'identity (nth 1 e) " "))
629 (out (mapconcat 'identity (nth 2 e) " "))
630 (str (format "( %s -- %s )" in out)))
631 (fuel-markup--snippet (list '$snippet str))))
633 (defun fuel-markup--quotation (e)
635 (fuel-markup--link (list '$link 'quotation 'quotation 'word))
636 (insert " with stack effect ")
637 (fuel-markup--stack-effect (nth 1 e)))
639 (defun fuel-markup--warning (e)
640 (fuel-markup--elem-with-heading e "Warning"))
642 (defun fuel-markup--description (e)
643 (fuel-markup--elem-with-heading e "Word description"))
645 (defun fuel-markup--class-description (e)
646 (fuel-markup--elem-with-heading e "Class description"))
648 (defun fuel-markup--error-description (e)
649 (fuel-markup--elem-with-heading e "Error description"))
651 (defun fuel-markup--var-description (e)
652 (fuel-markup--elem-with-heading e "Variable description"))
654 (defun fuel-markup--contract (e)
655 (fuel-markup--elem-with-heading e "Generic word contract"))
657 (defun fuel-markup--errors (e)
658 (fuel-markup--elem-with-heading e "Errors"))
660 (defun fuel-markup--examples (e)
661 (fuel-markup--elem-with-heading e "Examples"))
663 (defun fuel-markup--notes (e)
664 (fuel-markup--elem-with-heading e "Notes"))
666 (defun fuel-markup--word-info (e)
667 "Uses the 'see' word to lookup info about a given word. Note
668 that this function is called in contexts where it is impossible
669 to guess the correct usings, so a static using list is used."
670 (let* ((word (nth 1 e))
671 (cmd `(:fuel* ((:quote ,(symbol-name word)) see)
672 "fuel" ("kernel" "lexer" "see" "sequences")))
673 (ret (and cmd (fuel-eval--send/wait cmd)))
674 (res (and (not (fuel-eval--retort-error ret))
675 (fuel-eval--retort-output ret))))
677 (fuel-markup--code (list '$code res) nil)
678 (fuel-markup--snippet (list '$snippet " " word)))))
680 (defun fuel-markup--null (e))
683 (provide 'fuel-markup)
685 ;;; fuel-markup.el ends here