-
-
Notifications
You must be signed in to change notification settings - Fork 2
/
printer.lisp
102 lines (95 loc) · 3.75 KB
/
printer.lisp
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
(in-package #:org.shirakumo.fraf.speechless)
(defun maybe-unwrap (thing)
(if (and (listp thing) (eql 'progn (first thing)) (null (cddr thing)))
(second thing)
thing))
(defmacro %op (s thing &rest args)
`(markless::output-operator (format NIL ,thing ,@args) ,s markless::_))
(defmacro %form (s thing)
`(output-form ,thing ,s markless::_))
(markless:define-output (speechless (markless:markless)) (c s)
(mcomponents:label ()
(%op s "> ")
(format s "~a" (mcomponents:target c)))
(components:jump ()
(%op s "< ")
(format s "~a" (mcomponents:target c)))
(components:source ()
(%op s "~~ ")
(output-form (components:name c) s markless::_))
(components:placeholder ()
(%op s "{")
(output-form (components:form c) s markless::_)
(%op s "}"))
(components:emote ()
(%op s "(:")
(output-form (components:emote c) s markless::_)
(%op s ")"))
(components:go () (format s "go ~s" (mcomponents:target c)))
(components:speed () (format s "speed ~s" (components:speed c)))
(components:setf ()
(format s "setf " )
(%form s (components:place c))
(format s " ")
(%form s (components:form c)))
(components:eval () (format s "eval ")
(%form s (maybe-unwrap (components:form c))))
(components:conditional ()
(destructuring-bind (condition . children) (aref (components:clauses c) 0)
(%op s "? ")
(%form s condition)
(let ((markless::*prefixes* (list* "| " markless::*prefixes*)))
(when (< 0 (length children))
(fresh-line s)
(loop for prefix in (reverse markless::*prefixes*)
do (%op s "~a" prefix)))
(markless:output children)))
(loop for i from 1 below (length (components:clauses c))
do (destructuring-bind (condition . children) (aref (components:clauses c) i)
(fresh-line s)
(loop for prefix in (reverse markless::*prefixes*)
do (%op s "~a" prefix))
(%op s "|? ")
(unless (eql condition T)
(%form s condition))
(let ((markless::*prefixes* (list* "| " markless::*prefixes*)))
(markless:output children)))))
(components:conditional-part ()
(%op s "[")
(%form s (components:form c))
(loop for i from 0 below (length (components:choices c))
do (loop for content across (aref (components:choices c) i)
do (format s "~a" content))
(when (< i (1- (length (components:choices c))))
(%op s "|")))
(%op s "]")))
(defmethod output-form (form target (format speechless))
(let ((*print-case* :downcase)
(*print-right-margin* 1000000000))
(format target "~s" form)))
(markless:define-output (highlighted (speechless markless:highlighted)) (c s))
(defmethod output-form (form target (format highlighted))
(let ((*print-case* :downcase)
(*print-right-margin* 1000000000))
(format target "<span class=\"lisp-expression\">~s</span>" form)))
(defun highlight (source &key (target T))
(etypecase target
((eql T)
(highlight source :target *standard-output*))
(null
(with-output-to-string (out)
(highlight source :target out)))
(pathname
(with-open-file (out target :direction :output :if-exists :supersede)
(highlight source :target out)))
(stream
(format target "<html><head><style>
.operator{color:#888;}
.lisp-expression{color:#A00;}
.header{font-weight:bold; font-size: 1.2em;}
.eval,.eval *,.setf,.setf *{color:#A00;}
.emote *{color:#080;}
.source *{color:#cc6e16;}
</style></head><body>")
(markless:output (ensure-parsed source) :target target :format 'highlighted)
(format target "</body></html>"))))