1 2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 3;; 4;; MODULE : base.scm 5;; DESCRIPTION : frequently used Scheme subroutines 6;; COPYRIGHT : (C) 2002 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 (kernel library base)) 15 16;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 17;; Booleans 18;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 20(define (xor-sub l) 21 (cond ((null? l) #f) 22 ((car l) (not (xor-sub (cdr l)))) 23 (else (xor-sub (cdr l))))) 24 25(define-public (xor . l) 26 "Exclusive or of all elements in @l." 27 (xor-sub l)) 28 29;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30;; Numbers 31;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 33(define-public (float->string s) 34 (number->string s)) 35 36(define-public (string->float s) 37 (exact->inexact (string->number s))) 38 39;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40;; Strings 41;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 43;; NOTE: guile-1.6.0 implements SRFI-13 (string library) in C. 44 45(define-public (char->string c) 46 "Convert @c to a string" 47 (list->string (list c))) 48 49(define-public (string-tail s n) 50 "Return all but the first @n chars of @s." 51 (substring s n (string-length s))) 52 53(define-public (char-in-string? c s) 54 "Test whether @c occurs in @s" 55 (!= (string-index s c) #f)) 56 57(define-public (string-starts? s what) 58 "Test whether @s starts with @what." 59 (let ((n (string-length s)) 60 (k (string-length what))) 61 (and (>= n k) (== (substring s 0 k) what)))) 62 63(define-public (string-ends? s what) 64 "Test whether @s ends with @what." 65 (let ((n (string-length s)) 66 (k (string-length what))) 67 (and (>= n k) (== (substring s (- n k) n) what)))) 68 69(define-public (string-contains? s what) 70 "Test whether @s contains @what as a substring." 71 (>= (string-search-forwards what 0 s) 0)) 72 73(define-public (force-string s) 74 "Return @s if @s is a string and the empty string otherwise" 75 (if (string? s) s "")) 76 77(provide-public (reverse-list->string cs) ; srfi-13 78 "Efficient implementation of (compose list->string reverse)." 79 ;; Not yet any more efficient, but this may be fixed in the future. 80 (list->string (reverse cs))) 81 82(provide-public (string-join ss . opt) ; srfi-13 (subset) 83 "Concatenate elements of @ss inserting separators." 84 (if (null? opt) (string-join ss " ") 85 (string-concatenate (list-intersperse ss (car opt))))) 86 87(provide-public (string-drop-right s n) ; srfi-13 88 "Return all but the last @n chars of @s." 89 (substring s 0 (- (string-length s) n))) 90 91(provide-public string-drop string-tail) ; srfi-13 92 93(provide-public (string-take s n) ; srfi-13 94 "Return the first @n chars of @s." 95 (substring s 0 n)) 96 97(provide-public (string-trim s) ; srfi-13 (subset) 98 "Remove whitespace at start of @s." 99 (list->string (list-drop-while (string->list s) char-whitespace?))) 100 101(define-public (list-drop-right-while l pred) 102 (reverse! (list-drop-while (reverse l) pred))) 103 104(provide-public (string-trim-right s) ; srfi-13 (subset) 105 "Remove whitespace at end of @s." 106 (list->string (list-drop-right-while (string->list s) char-whitespace?))) 107 108(provide-public (string-trim-both s) ; srfi-13 (subset) 109 "Remove whitespace at start and end of @s." 110 (list->string 111 (list-drop-right-while 112 (list-drop-while (string->list s) char-whitespace?) 113 char-whitespace?))) 114 115(provide-public (string-concatenate ss) ; srfi-13 116 "Append the elements of @ss toghether." 117 ;; WARNING: not portable for long lists 118 (apply string-append ss)) 119 120(provide-public (string-map proc s) ; srfi-13 (subset) 121 "Map @proc on every char of @s." 122 (list->string (map proc (string->list s)))) 123 124(provide-public (string-fold kons knil s) ; srfi-13 (subset)) 125 "Fundamental string iterator." 126 (list-fold kons knil (string->list s))) 127 128(provide-public (string-fold-right kons knil s) ; srfi-13 (subset) 129 "Right to left fundamental string iterator." 130 (list-fold-right kons knil (string->list s))) 131 132(define (string-split-lines/kons c cs+lines) 133 (if (== c #\newline) 134 (cons '() cs+lines) 135 (cons (cons c (car cs+lines)) (cdr cs+lines)))) 136 137(define-public (string-split-lines s) 138 "List of substrings of @s separated by newlines." 139 (map list->string 140 (list-fold-right string-split-lines/kons '(()) (string->list s)))) 141 142(provide-public (string-tokenize-by-char s sep) 143 "Cut string @s into pieces using @sep as a separator." 144 (with d (string-index s sep) 145 (if d 146 (cons (substring s 0 d) 147 (string-tokenize-by-char (substring s (+ 1 d) (string-length s)) sep)) 148 (list s)))) 149 150(define-public (string-tokenize-by-char-n s sep n) 151 "As @string-tokenize-by-char, but only cut first @n pieces" 152 (with d (string-index s sep) 153 (if (or (= n 0) (not d)) 154 (list s) 155 (cons (substring s 0 d) 156 (string-tokenize-by-char-n (substring s (+ 1 d) (string-length s)) 157 sep 158 (- n 1)))))) 159 160(define-public (string-decompose s sep) 161 (with d (string-search-forwards sep 0 s) 162 (if (< d 0) 163 (list s) 164 (cons (substring s 0 d) 165 (string-decompose (substring s (+ d (string-length sep)) 166 (string-length s)) sep))))) 167 168(define-public (string-recompose l sep) 169 "Turn list @l of strings into one string using @sep as separator." 170 (if (char? sep) (set! sep (list->string (list sep)))) 171 (cond ((null? l) "") 172 ((null? (cdr l)) (car l)) 173 (else (string-append (car l) sep (string-recompose (cdr l) sep))))) 174 175(define-public (string-tokenize-comma s) 176 "Cut string @s into pieces using comma as a separator and remove whitespace." 177 (map string-trim-both (string-tokenize-by-char s #\,))) 178 179(define-public (string-recompose-comma l) 180 "Turn list @l of strings into comma separated string." 181 (string-recompose l ", ")) 182 183(define (property-pair->string p) 184 (string-append (car p) "=" (cdr p))) 185 186(define (string->property-pair s) 187 (with pos (string-index s #\=) 188 (if pos 189 (cons (string-take s pos) (string-drop s (+ pos 1))) 190 (cons s "true")))) 191 192(define-public (string->alist s) 193 "Parse @s of the form \"var1=val1/.../varn=valn\" as an association list." 194 (map string->property-pair (string-tokenize-by-char s #\/))) 195 196(define-public (alist->string l) 197 "Pretty print the association list @l as a string." 198 (string-recompose (map property-pair->string l) "/")) 199 200;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 201;; Some string-like functions on symbols 202;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 203 204(define-public (symbol<=? x y) 205 (string<=? (symbol->string x) (symbol->string y))) 206 207(define-public (symbol-starts? s1 s2) 208 (string-starts? (symbol->string s1) (symbol->string s2))) 209 210(define-public (symbol-ends? s1 s2) 211 (string-ends? (symbol->string s1) (symbol->string s2))) 212 213(define-public (symbol-drop s n) 214 (string->symbol (string-drop (symbol->string s) n))) 215 216(define-public (symbol-drop-right s n) 217 (string->symbol (string-drop-right (symbol->string s) n))) 218 219;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 220;; Functions 221;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 222 223(define-public (compose g f) 224 "Compose the functions @f and @g" 225 (lambda x (g (apply f x)))) 226 227(define-public (non pred?) 228 "Return the negation of @pred?." 229 (lambda args (not (apply pred? args)))) 230 231;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 232;; Objects 233;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 234 235(define-public (string->object s) 236 "Parse @s and build scheme object" 237 (call-with-input-string s read)) 238 239(define-public (object->string* obj) 240 (cond ((null? obj) (object->string obj)) 241 ((pair? obj) (object->string obj)) 242 ((number? obj) (object->string obj)) 243 ((string? obj) (object->string obj)) 244 ((symbol? obj) (object->string obj)) 245 ((tree? obj) (object->string (tree->stree obj))) 246 (else (object->string #f)))) 247 248(define-public (func? x f . opts) 249 "Is @x a list with first stree @f? Optionally test the length of @x." 250 (let ((n (length opts))) 251 (cond ((= n 0) (and (list? x) (nnull? x) (== (car x) f))) 252 ((= n 1) 253 (let ((nn (car opts))) 254 (and (list? x) (nnull? x) 255 (== (car x) f) (= (length x) (+ nn 1))))) 256 (else (error "Too many arguments."))))) 257 258(define-public (tuple? x . opts) 259 "Equivalent to @list? without options or to @func? otherwise" 260 (if (null? opts) 261 (list? x) 262 (apply func? (cons x opts)))) 263 264;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 265;; Positions 266;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 267 268(define-public (position-new . opts) 269 (position-new-path (if (null? opts) (cursor-path) (car opts)))) 270 271;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 272;; Urls 273;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 274 275(define-public (url->list u) 276 (cond ((url-none? u) '()) 277 ((url-or? u) (append (url->list (url-ref u 1)) 278 (url->list (url-ref u 2)))) 279 (else (list u)))) 280 281(define-public (list->url l) 282 (cond ((null? l) (url-none)) 283 ((null? (cdr l)) (car l)) 284 (else (url-or (car l) (list->url (cdr l)))))) 285 286(define-public (url-read-directory u wc) 287 (with d (url-expand (url-complete (url-append u (url-wildcard wc)) "r")) 288 (url->list d))) 289 290;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 291;; Buffers 292;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 293 294(define-public (current-buffer) 295 (with u (current-buffer-url) 296 (and (not (url-none? u)) u))) 297 298(define-public (path->buffer p) 299 (with u (path-to-buffer p) 300 (and (not (url-none? u)) u))) 301 302(define-public (buffer->tree u) 303 (with t (buffer-get-body u) 304 (and (tree-active? t) t))) 305 306(define-public (tree->buffer t) 307 (and-with p (tree->path t) 308 (path->buffer p))) 309 310(define-public (buffer->path u) 311 (with t (buffer->tree u) 312 (and t (tree->path t)))) 313 314(define-public (buffer-exists? name) 315 (in? (url->url name) (buffer-list))) 316 317(define-public (buffer-master) 318 (buffer-get-master (current-buffer))) 319 320(define-public (buffer-in-recent-menu? u) 321 (or (not (url-rooted-tmfs? u)) 322 (string-starts? (url->unix u) "tmfs://part/"))) 323 324(define-public (buffer-in-menu? u) 325 (or (buffer-in-recent-menu? u) 326 (string-starts? (url->unix u) "tmfs://help/") 327 (string-starts? (url->unix u) "tmfs://remote-file/") 328 (string-starts? (url->unix u) "tmfs://apidoc/"))) 329 330(define-public (window->buffer win) 331 (with u (window-to-buffer win) 332 (and (not (url-none? u)) u))) 333 334(define-public (current-view) 335 (with u (current-view-url) 336 (and (not (url-none? u)) u))) 337 338(define-public (view->window vw) 339 (with win (view->window-url vw) 340 (and (not (url-none? win)) win))) 341 342;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 343;; Redirections 344;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 345 346(define-public (tm-with-output-to-string p) 347 (cout-buffer) 348 (p) 349 (cout-unbuffer)) 350