edward

  1;;>| String Procedures
  2;;>
  3;;> Utility procedures which operate on strings.
  4
  5;;> Return true if the given string `str` is the empty string.
  6
  7(define (empty-string? str)
  8  (zero? (string-length str)))
  9
 10;;> Pad given string `str` with given padding string `pad` to `length`.
 11
 12(define (pad-string str pad length)
 13  (if (>= (string-length str) length)
 14    str
 15    (pad-string (string-append pad str) pad length)))
 16
 17;;> Convert string to a human readable representation as mandated
 18;;> by the ed [list command][ed list].
 19;;>
 20;;> [ed list]: https://pubs.opengroup.org/onlinepubs/9799919799/utilities/ed.html#tag_20_38_13_17
 21
 22(define (string->human-readable str)
 23  ;; Length at which lines are folded.
 24  (define fold-length
 25    (let*-values (((padding) 8)
 26                  ((port) (current-output-port))
 27                  ((_ cols) (if (terminal-port? port)
 28                              (terminal-size port)
 29                              (values 0 0))))
 30      (if (> cols padding)
 31        (- cols padding)
 32        72)))
 33
 34  (define (byte->human-readable byte)
 35    (case byte
 36      ;; Mapping according to Table 5-1 in POSIX-1.2008.
 37      ((#x5C) "\\\\")
 38      ((#x07) "\\a")
 39      ((#x08) "\\b")
 40      ((#x0C) "\\f")
 41      ((#x0D) "\\r")
 42      ((#x09) "\\t")
 43      ((#x0B) "\\v")
 44
 45      ;; End of each line shall be marked with a `$` character.
 46      ((#x0A) "$\n")
 47      ;; `$` character within the line should be escaped.
 48      ((#x24) "\\$")
 49
 50      ;; Non-printable characters are represented in octal.
 51      (else
 52        (if (ascii-printable? byte)
 53          (string (integer->char byte))
 54          (string-append "\\" (pad-string (number->string byte 8) "0" 3))))))
 55
 56  ;; Fold lines at fold-length and convert bytes according to procedure above.
 57  (let ((bv (string->utf8 str)))
 58    (fold (lambda (idx out)
 59            (let* ((byte (bytevector-u8-ref bv idx))
 60                   (ret (string-append out (byte->human-readable byte))))
 61              (if (and (not (zero? idx))
 62                       (zero? (modulo idx fold-length)))
 63                (string-append ret "\\\n")
 64                ret)))
 65          "" (iota (bytevector-length bv)))))
 66
 67;;> Join a list of path elements (i.e. strings) using `/` as a path separator.
 68
 69(define (path-join . elems)
 70  (fold-right
 71    (lambda (elem path)
 72      (if (empty-string? path)
 73        elem
 74        (string-append elem "/" path)))
 75    "" elems))
 76
 77;;> Return amount of bytes in a string.
 78
 79;; XXX: Could consider renaming this to string-size.
 80;; This is what chibi-scheme and Gauche use.
 81(define (count-bytes str)
 82  (number-of-bytes str))
 83
 84;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 85
 86;;>| IO Procedures
 87;;>
 88;;> Procedures which deal with input/output.
 89
 90;;> Write `lines`, i.e. a list of non-newline terminated strings to a
 91;;> given `port`. Returns the amount of bytes written to the port
 92;;> (including any newline characters).
 93
 94(define (lines->port lines port)
 95  (fold (lambda (line num)
 96          (let ((line (string-append line "\n")))
 97            ;; TODO: Make write-string return the amount of bytes written.
 98            (write-string line port)
 99            (+ num (count-bytes line))))
100        0 lines))
101
102;;> Read from given `port` as a list of lines. Returns pair of retrieved
103;;> lines and total amount of bytes read from the port (including
104;;> newlines).
105
106(define (port->lines port)
107  ;; TODO: make read-lines return the amount of bytes read.
108  (let ((lines (read-lines port)))
109    (cons
110      lines
111      (fold (lambda (l n)
112              ;; +1 for newline stripped by read-lines.
113              ;; XXX: Buggy if last line is not not terminated with \n.
114              (+ 1 n (count-bytes l))) 0 lines))))
115
116;;> Expects the `mode` field of [`file-stat`][file-stat] and returns
117;;> if the mode indicates a regular file.
118;;>
119;;> [file-stat]: https://api.call-cc.org/6/doc/chicken/file/posix/file-stat
120
121;; TODO: This should be provided directly by (chicken file posix).
122(define (is-regular? mode)
123  (define %is-regular?
124    ;; XXX: Technically, we expect a `mode_t` and not an `unsigned-int`
125    ;; here. However, this is just a type annotation for CHICKEN itself.
126    (foreign-lambda* bool ((unsigned-int mode))
127      "C_return(S_ISREG(mode));"))
128
129  (%is-regular? mode))
130
131;;> Read a single UTF-8 character from a `fileno`. Return a false value if
132;;> end-of-file is reached. If EOF is reached within a multibyte sequence,
133;;> an exception is raised. This procedure uses `file-read` internally and
134;;> can thus—contrary to `read-char`—read beyond EOF.
135
136;; TODO: Use buffering here instead of emitting ~1 syscall per character.
137;; However, we only use this when reading from stdin, not on regular files.
138(define (file-read-char fileno)
139  ;; Use an internal CHICKEN function to check for multibyte sequences.
140  (define (bytes-needed byte)
141    (##core#inline "C_utf_bytes_needed" byte))
142
143  ;; UTF-8 multibyte sequences consists of a maximum of 4 bytes. Hence,
144  ;; a bytevector of size four will suffice. We first read a single byte.
145  ;; If it is a multibyte sequence, we read the remaining bytes afterward.
146  (let* ((buf (make-bytevector 4))
147         (ret (file-read fileno 1 buf))
148         (num (cadr ret)))
149    (if (zero? num)
150      #f
151      (let* ((last-byte (bytevector-u8-ref (car ret) (dec num)))
152             (num-needed (bytes-needed last-byte)))
153        (assert (and (> num-needed 0)
154                     (< num-needed (bytevector-length buf))))
155        (if (> num-needed 1)
156          (let* ((to-read (dec num-needed))
157                 (ret (file-read fileno to-read)))
158            (if (eqv? (cadr ret) to-read)
159              (begin
160                (bytevector-copy! buf 1 (car ret))
161                (string-ref (utf8->string buf) 0))
162              (error "unexpected short read in multibyte sequence")))
163          (integer->char last-byte))))))
164
165;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
166
167;;>| Miscellaneous
168;;>
169;;> Miscellaneous utility procedures.
170
171;;> Syntactic sugar to increment a number by one.
172(define (inc n) (+ n 1))
173;;> Syntactic sugar to decrement a number by one.
174(define (dec n) (- n 1))
175
176;;> Identity function, always returns the given value.
177
178(define (id x) x)
179
180;;> Returns all values of an `alist`, discarding the keys.
181
182(define (alist-values alist)
183  (map cdr alist))
184
185;;> Like `display` but prints multiple objects and adds a trailing newline.
186
187(define (println . objs)
188  (apply fprintln (current-output-port) objs))
189
190;;> Like [println](#println) but allows specification of a custom output `port`.
191
192(define (fprintln port . objs)
193  (for-each (lambda (obj) (display obj port)) objs)
194  (newline port))
195
196;;> Whether the given `integer` does not represent an ASCII control character.
197
198(define (ascii-printable? integer)
199  (and (>= integer #x20) (<= integer #x7e)))
200
201;;> Return path to home directory of current user.
202;;> This procedure emits an error if the environment variable `HOME` is unset.
203
204(define (user-home)
205  (let ((home (get-environment-variable "HOME")))
206    (if home
207      home
208      (error "environment variable 'HOME' not set"))))