1
2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3;;
4;; MODULE      : document-part.scm
5;; DESCRIPTION : managing document parts
6;; COPYRIGHT   : (C) 2005  Joris van der Hoeven
7;;
8;; This software falls under the GNU general public license version 3 or later.
9;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
10;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
11;;
12;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13
14(texmacs-module (generic document-part)
15  (:use (generic document-edit) (text text-structure)))
16
17;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18;; Flatten old-style projects into one file
19;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
20
21(define (inclusion-children t)
22  (cond ((tree-is? t 'with) (inclusion-children (cAr (tree-children t))))
23	((tree-is? t 'document) (tree-children t))
24	(else (list t))))
25
26(define (expand-includes-one t r)
27  (if (tree-is? t 'include)
28      (with u (url-relative r (unix->url (tree->string (tree-ref t 0))))
29	(inclusion-children (tree-load-inclusion u)))
30      (list (expand-includes t r))))
31
32(define (expand-includes t r)
33  (cond ((tree-atomic? t) t)
34	((tree-is? t 'document)
35	 (with l (map (lambda (x) (expand-includes-one x r)) (tree-children t))
36	   (cons 'document (apply append l))))
37	(else
38	 (with l (map (lambda (x) (expand-includes x r)) (tree-children t))
39	   (cons (tree-label t) l)))))
40
41(tm-define (buffer-expand-includes)
42  (with t (buffer-tree)
43    (tree-assign! t (expand-includes (buffer-tree) (buffer-master)))))
44
45;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
46;; Main internal representations for document parts:
47;;   :preamble -> (document (show-preamble preamble) (ignore body))
48;;   :one, :several -> (document [optional (hide-preamble pre)] hide-show-list)
49;;   :all -> (document [optional (hide-preamble preamble)] body)
50;; In the case of :one and :several, the hide-show-list contains items
51;;   (show-part id body alt-body)
52;;   (hide-part id body alt-body)
53;; Here id is an identifier for referencing purposes
54;; The alt-body is evaluated in the background in the case of hidden parts
55;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
56
57(define part-mode :one)
58
59(define (buffer-body-paragraphs)
60  (with t (buffer-tree)
61    (if (tree-in? (tree-ref t 0) '(show-preamble hide-preamble))
62	(cdr (tree-children t))
63	(tree-children t))))
64
65(define (buffer-show-preamble)
66  (with t (buffer-tree)
67    (when (tree-is? (tree-ref t 0) 'hide-preamble)
68      (buffer-flatten-parts)
69      (let* ((t (buffer-tree))
70	     (preamble `(show-preamble ,(tree-ref t 0 0)))
71	     (body `(ignore (document ,@(cdr (tree-children t))))))
72	(tree-assign! t `(document ,preamble ,body))))))
73
74(define (buffer-hide-preamble)
75  (with t (buffer-tree)
76    (when (match? t '(document (show-preamble :%1) (ignore (document :*))))
77      (tree-assign! t `(document (hide-preamble ,(tree-ref t 0 0))
78				 ,@(tree-children (tree-ref t 1 0)))))))
79
80(tm-define (kbd-remove t forwards?)
81  (:require (and (tree-is? t 'show-preamble) (tree-empty? (tree-ref t 0))))
82  (buffer-set-part-mode :all)
83  (when (buffer-has-preamble?)
84    (tree-remove (buffer-tree) 0 1)))
85
86(define (buffer-flatten-subpart t)
87  (if (tree-in? t '(show-part hide-part))
88      (tree-children (tree-ref t 1))
89      (list t)))
90
91(define (buffer-flatten-part t)
92  (if (tree-in? t '(show-part hide-part))
93      (append-map buffer-flatten-subpart (tree-children (tree-ref t 1)))
94      (list t)))
95
96(define (buffer-flatten-parts)
97  (when (tree-in? (car (buffer-body-paragraphs)) '(hide-part show-part))
98    (let* ((t (buffer-tree))
99	   (l (buffer-body-paragraphs))
100	   (parts (apply append (map buffer-flatten-part l)))
101	   (preamble? (tree-in? (tree-ref t 0) '(show-preamble hide-preamble)))
102	   (r (if preamble? (cons (tree-ref t 0) parts) parts)))
103      (tree-assign! t `(document ,@r)))))
104
105(define (buffer-make-parts)
106  (when (not (tree-in? (car (buffer-body-paragraphs)) '(hide-part show-part)))
107    (let* ((t (buffer-tree))
108	   (l (buffer-body-paragraphs))
109	   (parts (principal-sections-to-document-parts l))
110	   (preamble? (tree-in? (tree-ref t 0) '(show-preamble hide-preamble)))
111	   (r (if preamble? (cons (tree-ref t 0) parts) parts)))
112      (tree-assign! t `(document ,@r)))))
113
114(tm-define (buffer-get-part-mode)
115  (:synopsis "Get the mode for document part selections")
116  (cond ((tree-is? (tree-ref (buffer-tree) 0) 'show-preamble) :preamble)
117	((tree-in? (car (buffer-body-paragraphs)) '(show-part hide-part))
118	 part-mode)
119	(else :all)))
120
121(define (buffer-test-part-mode? mode)
122  (== (buffer-get-part-mode) mode))
123
124(tm-define (buffer-set-part-mode mode)
125  (:synopsis "Set the mode for document part selections")
126  (:check-mark "v" buffer-test-part-mode?)
127  (with old-mode (buffer-get-part-mode)
128    (cond ((== mode old-mode) (noop))
129	  ((== mode :preamble)
130	   (when (tree-is? (tree-ref (buffer-tree) 0) 'hide-preamble)
131	     (buffer-show-preamble)
132	     (tree-go-to (buffer-tree) 0 0 :start)))
133	  ((== mode :all)
134	   (buffer-hide-preamble)
135	   (buffer-flatten-parts)
136	   (tree-go-to (car (buffer-body-paragraphs)) :start)
137	   (update-current-buffer))
138	  (else
139	   (buffer-hide-preamble)
140	   (buffer-make-parts)
141	   (set! part-mode mode)
142	   (with first (car (buffer-parts-list #f))
143	     (if (== mode :one)
144		 (buffer-show-part first)
145		 (buffer-go-to-part first)))
146	   (update-current-buffer)))))
147
148;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
149;; Listing the document parts
150;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
151
152(define (document-part-name t)
153  (if (== (tree-ref t 1) (string->tree ""))
154      (string->tree "no title")
155      (principal-section-title (tree-ref t 1))))
156
157(define (document-get-parts t all?)
158  (cond ((tree-atomic? t) '())
159	((or (tree-is? t 'show-part) (and all? (tree-is? t 'hide-part)))
160	 (list (document-part-name t)))
161	((principal-section? t)
162	 (list (tm/section-get-title-string t)))
163	((not (tree-in? t '(document ignore))) '())
164	(else (with ls (map (lambda (x) (document-get-parts x all?))
165			    (tree-children t))
166		(apply append ls)))))
167
168(tm-define (buffer-has-preamble?)
169  (:synopsis "Does the current buffer contain a preamble?")
170  (with t (buffer-tree)
171    (tree-in? (tree-ref t 0) '(show-preamble hide-preamble))))
172
173(tm-define (buffer-parts-list all?)
174  (:synopsis "Get the list of all document parts of the current buffer")
175  (with l (buffer-body-paragraphs)
176    (if (match? l '((ignore (document :*))))
177	(set! l (tree-children (tree-ref (car l) 0))))
178    (with parts (document-get-parts (tm->tree `(document ,@l)) all?)
179      (if (and (not (tree-in? (car l) '(show-part hide-part)))
180	       (not (principal-section? (car l)))
181	       (or all? (== (buffer-get-part-mode) :all)))
182	  (cons "front matter" parts)
183	  parts))))
184
185;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
186;; Selection of specific document parts
187;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
188
189(define (document-find-part t id)
190  (cond ((tree-atomic? t) #f)
191	((tree-in? t '(show-part hide-part))
192	 (and (== id (document-part-name t)) t))
193	((not (tree-in? t '(document ignore))) #f)
194	(else (list-find (tree-children t)
195			 (lambda (x) (document-find-part x id))))))
196
197(define (document-select-part t id)
198  (cond ((tree-atomic? t) (noop))
199	((tree-in? t '(show-part hide-part))
200	 (with show? (== id (document-part-name t))
201	   (if (and show? (tree-is? t 'hide-part))
202	       (tree-assign-node! t 'show-part))
203	   (if (and (not show?) (tree-is? t 'show-part))
204	       (tree-assign-node! t 'hide-part))))
205	((not (tree-is? t 'document)) (noop))
206	(else (for-each (lambda (x) (document-select-part x id))
207			(tree-children t)))))
208
209(tm-define (buffer-go-to-part id)
210  (:synopsis "Go to the part with name @id")
211  (with t (document-find-part (buffer-tree) id)
212    (and t (tree-go-to t 1 :start))))
213
214(tm-define (buffer-show-part id)
215  (:synopsis "Show the document part with name @id")
216  (when (== (buffer-get-part-mode) :one)
217    (document-select-part (buffer-tree) id)
218    (buffer-go-to-part id)))
219
220(tm-define (buffer-toggle-part id)
221  (:synopsis "Toggle the visibility of the document part with name @id")
222  (when (and (== (buffer-get-part-mode) :several)
223	     (list-find (buffer-parts-list #f) (lambda (x) (!= x id))))
224    (with t (document-find-part (buffer-tree) id)
225      (cond ((not t) (noop))
226	    ((tree-is? t 'show-part)
227	     (tree-assign-node! t 'hide-part)
228	     (buffer-go-to-part (car (buffer-parts-list #f))))
229	    ((tree-is? t 'hide-part)
230	     (tree-assign-node! t 'show-part)
231	     (buffer-go-to-part id))))))
232
233(tm-define (buffer-make-preamble)
234  (:synopsis "Create a preamble for the current document")
235  (when (not (buffer-has-preamble?))
236    (with t (buffer-tree)
237      (tree-insert! t 0 '((hide-preamble (document ""))))
238      (buffer-set-part-mode :preamble))))
239
240;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
241;; Making hidden parts visible
242;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
243
244(tm-define (tree-show-hidden t)
245  (:require (and (tree-is? t 'hide-part) (== (tree-up t) (buffer-tree))))
246  (if (== (buffer-get-part-mode) :one)
247      (with id (document-part-name t)
248	(document-select-part (tree-up t) id))
249      (tree-assign-node! t 'show-part)))
250
251(tm-define (show-hidden-part id)
252  (:synopsis "Make hidden part with identifier @id visible")
253  (with search? (lambda (t) (match? t `(hide-part ,id :%2)))
254    (and-with t (list-find (tree-children (buffer-tree)) search?)
255      (tree-show-hidden t)
256      #t)))
257
258;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
259;; Buffer with included files
260;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
261
262(define (tm-include? t)
263  (and (tm-func? t 'include 1)
264       (tm-atomic? (tm-ref t 0))
265       (not (string-starts? (tm->string (tm-ref t 0)) ".."))))
266
267(tm-define (tm-get-includes doc)
268  (cond ((tm-func? doc 'with)
269	 (tm-get-includes (tm-ref doc :last)))
270	((tm-func? doc 'document)
271	 (append-map tm-get-includes (tm-children doc)))
272	((tm-include? doc)
273	 (list (tm->string (tm-ref doc 0))))
274	(else (list))))
275
276(tm-define (buffer-get-includes)
277  (tm-get-includes (buffer-tree)))
278
279(tm-define (buffer-contains-includes?)
280  (and (nnull? (buffer-get-includes))
281       (url-rooted-protocol? (current-buffer) "default")))
282
283;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
284;; The dynamic document part menu
285;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
286
287(tm-menu (document-parts-menu)
288  (let* ((all (buffer-parts-list #t))
289	 (active (buffer-parts-list #f))
290	 (make (lambda (id) (document-parts-menu-entry id (in? id active)))))
291    (for (id all)
292      ((check (eval (upcase-first id)) "v" (in? id active))
293       (if (== (buffer-get-part-mode) :one)
294           (buffer-show-part id)
295           (buffer-toggle-part id))))))
296
297(menu-bind document-part-menu
298  (if (buffer-has-preamble?)
299      ("Show preamble" (buffer-set-part-mode :preamble)))
300  (if (not (buffer-has-preamble?))
301      ("Create preamble" (buffer-make-preamble)))
302  ("Show one part" (buffer-set-part-mode :one))
303  ("Show several parts" (buffer-set-part-mode :several))
304  ("Show all parts" (buffer-set-part-mode :all))
305  (if (or (in? (buffer-get-part-mode) '(:one :several))
306	  (!= (get-init-tree "sectional-short-style") (tree 'macro "false")))
307      ---
308      (when (in? (buffer-get-part-mode) '(:one :several))
309	(link document-parts-menu))))
310
311(menu-bind document-part-menu
312  (:require (buffer-contains-includes?))
313  (link document-master-menu))
314
315(menu-bind project-manage-menu
316  (group "Upgrade")
317  ("Expand inclusions" (buffer-expand-includes))
318  ---
319  (group "Old style")
320  (when (not (project-attached?))
321    ("Attach master" (interactive project-attach)))
322  (when (project-attached?)
323    ("Detach master" (project-detach))))
324