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