128 lines
3.7 KiB
Scheme
128 lines
3.7 KiB
Scheme
(define-module (uniseg internal)
|
|
#:use-module (ice-9 peg)
|
|
#:use-module (ice-9 textual-ports)
|
|
#:use-module (ice-9 exceptions)
|
|
#:use-module (ice-9 i18n)
|
|
#:use-module (ice-9 pretty-print)
|
|
#:use-module (web uri)
|
|
#:use-module (web client)
|
|
#:use-module (web request)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-71)
|
|
#:export (@hex
|
|
@codepoint
|
|
@codepoint-range
|
|
@comment
|
|
@ws
|
|
cpk-values
|
|
cpk
|
|
cons-hash-list!
|
|
hex-string->integer
|
|
format-exception-msg
|
|
in-surrogate-range
|
|
cmdline-wget-or-file
|
|
ranges->charset!))
|
|
|
|
;;
|
|
;; Common PEG patterns
|
|
;;
|
|
(define-peg-pattern @hex body (peg "[a-fA-F0-9]"))
|
|
|
|
(define-peg-pattern @codepoint all
|
|
(* @hex))
|
|
|
|
(define-peg-pattern @codepoint-range all
|
|
(or
|
|
(and @codepoint (ignore "..") @codepoint)
|
|
@codepoint))
|
|
|
|
(define-peg-pattern @comment all
|
|
(and (ignore "#") (* peg-any)))
|
|
|
|
(define-peg-pattern @ws none
|
|
(or " " "\t"))
|
|
|
|
;; Helper macro to add a list of character ranges
|
|
;; to a hash-set.
|
|
(define-syntax-rule (cons-hash-list! ht key low high)
|
|
(let* ((old (hashq-ref ht key))
|
|
(value (list low high))
|
|
(new-lst
|
|
(if old
|
|
(cons value old)
|
|
(list value))))
|
|
(hashq-set! ht key new-lst)))
|
|
|
|
;; Helper macro to take above character range hash table
|
|
;; and insert it into Guile's chasracter set system.
|
|
(define-syntax-rule (ranges->charset! ht name symbol)
|
|
(let* ((pairs (hashq-ref ht name)))
|
|
(for-each
|
|
(λ (pair)
|
|
(ucs-range->char-set!
|
|
(first pair)
|
|
;; Exclusive upper range, so add one
|
|
(+ (second pair) 1)
|
|
#t symbol))
|
|
pairs)))
|
|
|
|
(define (hex-string->integer str)
|
|
;; XXX: We would ideally do integer->char here and save it to file as such
|
|
;; However read-expr* does not actually work for all the characters!
|
|
;; So they can't be written out as such.
|
|
(locale-string->integer str 16))
|
|
|
|
;; This should be in the standard library...
|
|
(define (format-exception-msg port err)
|
|
(apply format port (exception-message err) (exception-irritants err))
|
|
(display "\n" port))
|
|
|
|
;; Little checker to see if we are in the danger zone
|
|
;; (surrogate range is invalid unicode and guile errors)
|
|
(define (in-surrogate-range num)
|
|
(and (>= num #xd800)
|
|
(<= num #xdfff)))
|
|
|
|
(define (cmdline-wget-or-file url log-port)
|
|
(let ((cmdline (command-line)))
|
|
(if (= 2 (length cmdline))
|
|
(file-to-lines (last cmdline) log-port)
|
|
(wget-to-lines url log-port))))
|
|
|
|
(define (wget-to-lines url log-port)
|
|
(format log-port "Downloading from ~a..." url)
|
|
|
|
(let* ((response body (http-get (string->uri url)))
|
|
(lines (string-split body #\newline)))
|
|
(format log-port " done.\n")
|
|
lines))
|
|
|
|
(define (file-to-lines path log-port)
|
|
(format log-port "Loading from local file ~a\n" path)
|
|
(string-split
|
|
(with-input-from-file path
|
|
(λ () (get-string-all (current-input-port)))) #\newline))
|
|
|
|
;; kludge: emacs mis-renders this as a string, so...
|
|
(define hash-semicolon-semicolon
|
|
(list->string '(#\# #\; #\;)))
|
|
|
|
;; for debugging
|
|
(define (cpk . vals)
|
|
"Peek at values for print debugging, but return 'em"
|
|
(display hash-semicolon-semicolon (current-error-port))
|
|
(display " cpk\n" (current-error-port))
|
|
(pretty-print vals (current-error-port))
|
|
;; return the last value
|
|
(last vals))
|
|
|
|
(define-syntax-rule (cpk-values print-these ... body)
|
|
;; Like pk, but supporting multiple value return
|
|
(call-with-values
|
|
(lambda () body)
|
|
(lambda vals
|
|
(display hash-semicolon-semicolon (current-error-port))
|
|
(display " cpk-values\n" (current-error-port))
|
|
(pretty-print (list print-these ... '*values:* vals)
|
|
(current-error-port))
|
|
(apply values vals))))
|