66 lines
2.5 KiB
Text
66 lines
2.5 KiB
Text
|
;; Helper utilities to replace a list of bytevectors in a string.
|
||
|
|
;; Used for e.g. resolving placeholders, or swapping out store paths.
|
||
|
|
(define-library (zilch lib rewrite)
|
||
|
|
(import (scheme base) (srfi 207))
|
||
|
|
|
||
|
|
(export rewrite-bytevector-or-string)
|
||
|
|
|
||
|
|
(begin
|
||
|
|
;; Rewrites a bytevector.
|
||
|
|
;; `with-rewrites` is a list of `(from . to)` bytevector pairs.
|
||
|
|
;; All `from` values are assumed to start with a forward slash.
|
||
|
|
(define (rewrite-bytevector str with-rewrites)
|
||
|
|
(define parts '())
|
||
|
|
(define shortest-rewrite #f)
|
||
|
|
(define longest-rewrite #f)
|
||
|
|
(for-each
|
||
|
|
(lambda (kv)
|
||
|
|
(define len (bytevector-length (car kv)))
|
||
|
|
(unless (and shortest-rewrite (> shortest-rewrite len)) (set! shortest-rewrite len))
|
||
|
|
(unless (and longest-rewrite (< longest-rewrite len)) (set! longest-rewrite len)))
|
||
|
|
with-rewrites)
|
||
|
|
(define (matches i key)
|
||
|
|
(define key-len (bytevector-length key))
|
||
|
|
(if (> i (- (bytevector-length str) key-len))
|
||
|
|
#f
|
||
|
|
(let loop ((j 0))
|
||
|
|
(cond
|
||
|
|
((>= j key-len) #t)
|
||
|
|
((= (bytevector-u8-ref key j) (bytevector-u8-ref str (+ i j))) (loop (+ 1 j)))
|
||
|
|
(else #f)))))
|
||
|
|
(define (find-match-at i)
|
||
|
|
(let loop ((l with-rewrites))
|
||
|
|
(cond
|
||
|
|
((null? l) #f)
|
||
|
|
((matches i (caar l)) (car l))
|
||
|
|
(else (loop (cdr l))))))
|
||
|
|
(when shortest-rewrite
|
||
|
|
(let find-part ((i 0) (last-i 0))
|
||
|
|
(let ((next-slash (bytestring-index str (lambda (c) (= c #x2F)) i)))
|
||
|
|
(if (or (not next-slash) (> next-slash (- (bytevector-length str) shortest-rewrite)))
|
||
|
|
(if (= last-i 0)
|
||
|
|
(set! parts #f)
|
||
|
|
(set! parts (cons (bytevector-copy str last-i) parts)))
|
||
|
|
(let ((mapping-pair (find-match-at next-slash)))
|
||
|
|
(if mapping-pair
|
||
|
|
(let* ((len (bytevector-length (car mapping-pair)))
|
||
|
|
(next-start (+ next-slash len)))
|
||
|
|
(set! parts (cons (cdr mapping-pair) (cons (bytevector-copy str last-i next-slash) parts)))
|
||
|
|
(find-part next-start next-start))
|
||
|
|
(find-part (+ next-slash 1) last-i)))))))
|
||
|
|
(if (pair? parts)
|
||
|
|
(apply bytevector-append (reverse parts))
|
||
|
|
#f))
|
||
|
|
|
||
|
|
;; Rewrites a bytevector or string.
|
||
|
|
;; `with-rewrites` is a list of `(from . to)` bytevector pairs.
|
||
|
|
;; All `from` values are assumed to start with a forward slash.
|
||
|
|
(define (rewrite-bytevector-or-string str with-rewrites)
|
||
|
|
(define result
|
||
|
|
(if (string? str)
|
||
|
|
(rewrite-bytevector (string->utf8 str) with-rewrites)
|
||
|
|
(rewrite-bytevector str with-rewrites)))
|
||
|
|
(if (and (string? str) result)
|
||
|
|
(utf8->string result)
|
||
|
|
(or result str)))))
|