src/TeXmacs/progs/kernel/library/base.scm

   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-recompose l sep)
 161   "Turn list @l of strings into one string using @sep as separator."
 162   (if (char? sep) (set! sep (list->string (list sep))))
 163   (cond ((null? l) "")
 164         ((null? (cdr l)) (car l))
 165         (else (string-append (car l) sep (string-recompose (cdr l) sep)))))
 166
 167 (define-public (string-tokenize-comma s)
 168   "Cut string @s into pieces using comma as a separator and remove whitespace."
 169   (map string-trim-both (string-tokenize-by-char s #\,)))
 170
 171 (define-public (string-recompose-comma l)
 172   "Turn list @l of strings into comma separated string."
 173   (string-recompose l ", "))
 174
 175 (define (property-pair->string p)
 176   (string-append (car p) "=" (cdr p)))
 177
 178 (define (string->property-pair s)
 179   (with pos (string-index s #\=)
 180     (if pos
 181         (cons (string-take s pos) (string-drop s (+ pos 1)))
 182         (cons s "true"))))
 183
 184 (define-public (string->alist s)
 185   "Parse @s of the form \"var1=val1/.../varn=valn\" as an association list."
 186   (map string->property-pair (string-tokenize-by-char s #\/)))
 187
 188 (define-public (alist->string l)
 189   "Pretty print the association list @l as a string."
 190   (string-recompose (map property-pair->string l) "/"))
 191
 192 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 193 ;; Some string-like functions on symbols
 194 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 195
 196 (define-public (symbol<=? x y)
 197   (string<=? (symbol->string x) (symbol->string y)))
 198
 199 (define-public (symbol-starts? s1 s2)
 200   (string-starts? (symbol->string s1) (symbol->string s2)))
 201
 202 (define-public (symbol-ends? s1 s2)
 203   (string-ends? (symbol->string s1) (symbol->string s2)))
 204
 205 (define-public (symbol-drop-right s n)
 206   (string->symbol (string-drop-right (symbol->string s) n)))
 207
 208 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 209 ;; Functions
 210 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 211
 212 (define-public (compose g f)
 213   "Compose the functions @f and @g"
 214   (lambda x (g (apply f x))))
 215
 216 (define-public (non pred?)
 217   "Return the negation of @pred?."
 218   (lambda args (not (apply pred? args))))
 219
 220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 221 ;; Objects
 222 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 223
 224 (define-public (string->object s)
 225   "Parse @s and build scheme object"
 226   (call-with-input-string s read))
 227
 228 (define-public (object->string* obj)
 229   (cond ((null? obj) (object->string obj))
 230         ((pair? obj) (object->string obj))
 231         ((number? obj) (object->string obj))
 232         ((string? obj) (object->string obj))
 233         ((symbol? obj) (object->string obj))
 234         ((tree? obj) (object->string (tree->stree obj)))
 235         (else (object->string #f))))
 236
 237 (define-public (func? x f . opts)
 238   "Is @x a list with first stree @f? Optionally test the length of @x."
 239   (let ((n (length opts)))
 240     (cond ((= n 0) (and (list? x) (nnull? x) (== (car x) f)))
 241           ((= n 1)
 242            (let ((nn (car opts)))
 243              (and (list? x) (nnull? x)
 244                   (== (car x) f) (= (length x) (+ nn 1)))))
 245           (else (error "Too many arguments.")))))
 246
 247 (define-public (tuple? x . opts)
 248   "Equivalent to @list? without options or to @func? otherwise"
 249   (if (null? opts)
 250       (list? x)
 251       (apply func? (cons x opts))))
 252
 253 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 254 ;; Positions
 255 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 256
 257 (define-public (position-new . opts)
 258   (position-new-path (if (null? opts) (cursor-path) (car opts))))
 259
 260 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 261 ;; Urls and buffers
 262 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 263
 264 (define-public (url->list u)
 265   (cond ((url-none? u) '())
 266         ((url-or? u) (append (url->list (url-ref u 1))
 267                              (url->list (url-ref u 2))))
 268         (else (list u))))
 269
 270 (define-public (list->url l)
 271   (cond ((null? l) (url-none))
 272         ((null? (cdr l)) (car l))
 273         (else (url-or (car l) (list->url (cdr l))))))
 274
 275 (define-public (buffer->tree u)
 276   (with t (get-buffer-tree u)
 277     (and (tree-active? t) t)))
 278
 279 (define-public (tree->buffer t)
 280   (and-with p (tree->path t)
 281     (get-name-buffer-path p)))
 282
 283 (define-public (buffer-list)
 284   (url->list (get-all-buffers)))
 285
 286 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 287 ;; Redirections
 288 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 289
 290 (define-public (tm-with-output-to-string p)
 291   (cout-buffer)
 292   (p)
 293   (cout-unbuffer))
 294