-
-
Notifications
You must be signed in to change notification settings - Fork 0
/
text-formatting.lisp
164 lines (145 loc) · 6.68 KB
/
text-formatting.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
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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :clim-internals)
(defun format-textual-list (sequence printer
&key stream separator conjunction
suppress-separator-before-conjunction
suppress-space-after-conjunction)
"Outputs the SEQUENCE of items as a \"textual list\" into
STREAM. PRINTER is a function of an item and a stream. Between each
two items the string SEPARATOR is placed. If the string CONJUCTION is
supplied, it is placed before the last item.
SUPPRESS-SEPARATOR-BEFORE-CONJUNCTION and
SUPPRESS-SPACE-AFTER-CONJUNCTION are non-standard."
(orf stream *standard-output*)
(orf separator ", ")
(let* ((length (length sequence))
(n-rest length))
(map-repeated-sequence nil 1
(lambda (item)
(funcall printer item stream)
(decf n-rest)
(cond ((> n-rest 1)
(princ separator stream))
((= n-rest 1)
(if conjunction
(progn
(unless suppress-separator-before-conjunction
(princ separator stream))
(princ conjunction stream)
(unless suppress-space-after-conjunction
(princ #\space stream)))
(princ separator stream)))))
sequence)))
;;; filling-output support
(defclass filling-stream (standard-encapsulating-stream
extended-output-stream
output-recording-stream)
((fill-width :accessor fill-width :initarg :fill-width)
(break-characters :accessor break-characters :initarg :break-characters
:initform '(#\Space))
(after-line-break :accessor after-line-break :initarg :after-line-break)))
;;; parse-space is from table-formatting.lisp
(defmethod initialize-instance :after ((obj filling-stream)
&key (fill-width '(80 :character)))
(setf (fill-width obj) (parse-space (encapsulating-stream-stream obj)
fill-width
:horizontal)))
(defmethod stream-write-char :around ((stream filling-stream) char)
(let ((under-stream (encapsulating-stream-stream stream)))
(if (and (member char (break-characters stream) :test #'char=)
(> (stream-cursor-position under-stream) (fill-width stream)))
(progn
(stream-write-char under-stream #\newline)
(when (slot-boundp stream 'after-line-break)
(write-string (after-line-break stream)
(encapsulating-stream-stream stream))))
(call-next-method))))
(defmethod stream-write-string :around ((stream filling-stream) string
&optional (start 0) end)
(dotimes (i (- (or end (length string)) start))
(stream-write-char stream (aref string (+ i start)))))
;;; All the monkey business with the lambda form has to do with capturing the
;;; keyword arguments of the macro while preserving the user's evaluation order.
(defmacro filling-output ((stream &rest args &key fill-width break-characters
after-line-break after-line-break-initially)
&body body)
(when (eq stream t)
(setq stream '*standard-output*))
(with-gensyms (fill-var break-var after-var initially-var)
`((lambda (&key ((:fill-width ,fill-var))
((:break-characters ,break-var))
((:after-line-break ,after-var))
((:after-line-break-initially ,initially-var)))
(declare (ignorable ,fill-var ,break-var ,after-var ,initially-var))
(let ((,stream (make-instance
'filling-stream
:stream ,stream
,@(and fill-width `(:fill-width ,fill-var))
,@(and break-characters
`(:break-characters ,break-var))
,@(and after-line-break
`(:after-line-break ,after-var)))))
,(unless (null after-line-break-initially)
`(when ,initially-var
(write-string ,after-var ,stream)))
,@body))
,@args)))
;;; indenting-output
(defclass indenting-output-stream (standard-encapsulating-stream
extended-output-stream
output-recording-stream)
((indentation :accessor indentation)))
(defmethod initialize-instance :after ((obj indenting-output-stream)
&key (indent-spec 0) &allow-other-keys)
(setf (indentation obj) (parse-space (encapsulating-stream-stream obj)
indent-spec
:horizontal)))
(defmethod stream-write-char :around ((stream indenting-output-stream) char)
(let ((under-stream (encapsulating-stream-stream stream)))
(when (stream-start-line-p under-stream)
(stream-increment-cursor-position under-stream (indentation stream) nil))
(call-next-method)))
(defmethod stream-write-string :around ((stream indenting-output-stream)
string &optional (start 0) end)
(let ((under-stream (encapsulating-stream-stream stream))
(end (or end (length string))))
(flet ((foo (start end)
(when (stream-start-line-p under-stream)
(stream-increment-cursor-position under-stream (indentation stream) nil))
(stream-write-string under-stream string start end)))
(let ((seg-start start))
(loop for i from start below end do
(when (char= #\Newline
(char string i))
(foo seg-start (1+ i))
(setq seg-start (1+ i))))
(foo seg-start end)))))
(defmacro indenting-output ((stream indent &key (move-cursor t)) &body body)
(when (eq stream t)
(setq stream '*standard-output*))
(with-gensyms (old-x old-y)
`(multiple-value-bind (,old-x ,old-y)
(stream-cursor-position ,stream)
(let ((,stream (make-instance
'indenting-output-stream
:stream ,stream
:indent-spec ,indent)))
,@body)
(unless ,move-cursor
(setf (stream-cursor-position ,stream)
(values ,old-x ,old-y))))))