Skip to content

More SRFI tool patches #32

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 2 commits into from
Oct 21, 2022
Merged

More SRFI tool patches #32

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
6e9aadb
Fix bug in url-hexify-string
lassik Oct 21, 2022
6559201
Update string utilities and toc slug generation
lassik Oct 21, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
99 changes: 68 additions & 31 deletions srfi-tools/private/string.sld
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,8 @@
(define-library (srfi-tools private string)
(export ascii-alphabetic?
ascii-numeric?
ascii-alphanumeric?
with-output-to-string
string-fold
string-index
string-contains
Expand All @@ -9,6 +11,8 @@
string-split
string-join
string-join-english
string->slug
unique-string-accumulator
url-hexify-string)
(import (only (scheme char) string-downcase))
(import (scheme base)
Expand All @@ -29,6 +33,10 @@
(define (ascii-numeric? char)
(char<=? #\0 char #\9))

(define (ascii-alphanumeric? char)
(or (ascii-alphabetic? char)
(ascii-numeric? char)))

;; Subset of SRFI 140.
(define (string-split char str)
(define (maybe-add a b parts)
Expand All @@ -41,52 +49,81 @@
(loop (+ b 1) (+ b 1) (maybe-add a b parts)))
(reverse (maybe-add a b parts))))))

(define (with-output-to-string thunk)
(call-with-port (open-output-string)
(lambda (port)
(parameterize ((current-output-port port))
(thunk))
(get-output-string port))))

(define (string-join-english string-list)
"Return a string constructed by appending the elements of
`string-list', separating them with \", \" except for the last pair,
which should be separated by \" and\" if there are only two elements
and \", and\" otherwise."
(cond ((null? string-list) "")
((null? (cdr string-list)) (car string-list))
((null? (cddr string-list))
(string-append (car string-list)
" and "
(cadr string-list)))
(else
(let ((output (open-output-string)))
(let next ((remaining string-list))
(write-string (car remaining) output)
(cond ((null? (cddr remaining))
(write-string ", and " output)
(write-string (cadr remaining) output))
(else (write-string ", " output)
(next (cdr remaining)))))
(get-output-string output)))))
(case (length string-list)
((0) "")
((1) (first string-list))
((2) (string-append (first string-list) " and " (second string-list)))
(else (with-output-to-string
(lambda ()
(let next ((remaining string-list))
(write-string (first remaining))
(cond ((not (null? (cddr remaining)))
(write-string ", ")
(next (cdr remaining)))
(else
(write-string ", and ")
(write-string (second remaining))))))))))

;; "Foo bar/baz!" -> "foo-bar-baz"
(define (string->slug str)
(let ((str (string-downcase str)))
(with-output-to-string
(lambda ()
(let loop ((empty? #t) (want-dash? #f) (i 0))
(when (< i (string-length str))
(let ((char (string-ref str i)))
(cond ((ascii-alphanumeric? char)
(when (and want-dash? (not empty?))
(write-string "-"))
(write-char char)
(loop #f #f (+ i 1)))
(else
(loop empty? #t (+ i 1)))))))))))

(define (unique-string-accumulator)
(let ((used '()))
(lambda (str)
(if (eof-object? str)
(reverse used)
(let loop ((candidate str) (next 2))
(cond ((member candidate used)
(loop (string-append str "-" (number->string next))
(+ next 1)))
(else
(set! used (cons candidate used))
candidate)))))))

;; From Emacs Lisp.
(define (url-hexify-string str)
(define safe (map char->integer (string->list "-./_")))
(define (safe-byte? byte)
(and (< byte #x80)
(let ((char (integer->char byte)))
(or (ascii-alphabetic? char)
(ascii-numeric? char)
(or (ascii-alphanumeric? char)
(member char safe)))))
(define (write-byte-safely byte)
(cond ((safe-byte? byte)
(write-char (integer->char byte)))
(else
(write-string "%")
(write-string
(string-downcase
(number->string byte 16))))))
(write-string (if (< byte 16) "%0" "%"))
(write-string (string-downcase (number->string byte 16))))))
(let ((bytes (string->utf8 str)))
(call-with-port (open-output-string)
(lambda (out)
(parameterize ((current-output-port out))
(let loop ((i 0))
(if (= i (bytevector-length bytes))
(get-output-string out)
(let ((byte (bytevector-u8-ref bytes i)))
(write-byte-safely byte)
(loop (+ i 1))))))))))))
(with-output-to-string
(lambda ()
(let loop ((i 0))
(when (< i (bytevector-length bytes))
(let ((byte (bytevector-u8-ref bytes i)))
(write-byte-safely byte)
(loop (+ i 1)))))))))))
74 changes: 24 additions & 50 deletions srfi-tools/toc.sld
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -53,57 +53,31 @@
(let-values (((subtree hs) (headings->tree/values hs)))
subtree))

(define (string->slug string)
(let ((chars
(string-fold
(lambda (char chars)
(cond ((or (ascii-alphabetic? char)
(ascii-numeric? char))
(cons char chars))
((or (null? chars)
(char=? #\_ (car chars)))
chars)
(else
(cons #\_ chars))))
'()
(string-downcase string))))
(list->string
(reverse
(if (or (null? chars) (not (char=? #\_ (car chars))))
chars (cdr chars))))))

(define (write-html-toc indent items)
(define slugs '())
(define (gen-id title)
(let loop ((i 1))
(let ((slug (string-append "_" (string->slug title)
(if (< i 2) "" (number->string i)))))
(if (member slug slugs)
(loop (+ i 1))
(begin (set! slugs (append slugs (list slug)))
slug)))))
(let display-list ((indent indent) (items items))
(disp indent "<ul>")
(let ((indent (string-append indent " ")))
(for-each (lambda (item)
(let* ((title (car item))
(link (string-append
"<a href=\"#" (gen-id title) "\">"
title "</a>")))
(cond ((null? (cdr item))
(disp indent "<li>" link "</li>"))
(else
(disp indent "<li>")
(let ((indent (string-append indent " ")))
(disp indent link)
(display-list indent (cdr item)))
(disp indent "</li>")))))
items))
(disp indent "</ul>"))
(newline)
(for-each (lambda (slug)
(display " id=\"") (display slug) (disp "\""))
slugs))
(let ((uniq (unique-string-accumulator)))
(define (link-html title)
(string-append "<a href=\"#" (uniq (string->slug title)) "\">"
title
"</a>"))
(let display-list ((indent indent) (items items))
(disp indent "<ul>")
(let ((indent (string-append indent " ")))
(for-each (lambda (item)
(let* ((title (car item))
(link (link-html title)))
(cond ((null? (cdr item))
(disp indent "<li>" link "</li>"))
(else
(disp indent "<li>")
(let ((indent (string-append indent " ")))
(disp indent link)
(display-list indent (cdr item)))
(disp indent "</li>")))))
items))
(disp indent "</ul>"))
(newline)
(for-each (lambda (slug) (disp " id=\"" slug "\""))
(uniq (eof-object)))))

(define (wanted-heading? h)
(and (<= 2 (car h) 4)
Expand Down