From 79975a5dc78daa03b43d37b3fe636265c148abc0 Mon Sep 17 00:00:00 2001 From: Munyoki Kilyungi Date: Mon, 15 May 2023 15:21:34 +0300 Subject: Re-organize dumping macros and associated functions Signed-off-by: Munyoki Kilyungi --- dump/utils.scm | 208 --------------------------------------------------------- 1 file changed, 208 deletions(-) delete mode 100644 dump/utils.scm (limited to 'dump/utils.scm') diff --git a/dump/utils.scm b/dump/utils.scm deleted file mode 100644 index 8544eec..0000000 --- a/dump/utils.scm +++ /dev/null @@ -1,208 +0,0 @@ -(define-module (dump utils) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-26) - #:use-module (ice-9 match) - #:export (string-blank? - translate-forms - collect-forms - map-alist - time-unix->string)) - - -(define (time-unix->string seconds . maybe-format) - "Given an integer saying the number of seconds since the Unix -epoch (1970-01-01 00:00:00), SECONDS, format it as a human readable -date and time-string, possible using the MAYBE-FORMAT." - (letrec ([time-unix->time-utc - (lambda (seconds) - (add-duration - (date->time-utc (make-date 0 0 0 0 1 1 1970 0)) - (make-time time-duration 0 seconds)))]) - (apply date->string - (time-utc->date (time-unix->time-utc seconds)) - maybe-format))) - -(define (string-blank? str) - "Return non-#f if STR consists only of whitespace characters." - (string-every char-set:whitespace str)) - -(define (translate-forms from translator x) - "Recursively pass (FROM ...) forms in source X to TRANSLATOR, and -replace them with the return value." - (syntax-case x () - ;; Handle translation base case. - ((head tail ...) (eq? (syntax->datum #'head) - from) - (translator x)) - ;; Recurse. - ((head tail ...) - (cons (translate-forms from translator #'head) - (map (cut translate-forms from translator <>) - #'(tail ...)))) - ;; Handle leaf base case. - (leaf #'leaf))) - -(define (key->assoc-ref alist x) - "Recursively translate (key k) forms in source X to (assoc-ref ALIST -k) forms." - (translate-forms 'key - ;; (syntax-rules (key) - ;; ((key k) (assoc-ref alist k))) - (lambda (x) - (syntax-case x (key) - ((key k) #`(assoc-ref #,alist 'k)))) - x)) - -(define (collect-forms target x) - "Recursively collect (TARGET ...) forms in source X and return them -as a list." - (syntax-case x () - ;; Handle collection base case. - ((head tail ...) (eq? (syntax->datum #'head) - target) - (list x)) - ;; Recurse. - ((head tail ...) - (append (collect-forms target #'head) - (append-map (cut collect-forms target <>) #'(tail ...)))) - ;; Handle leaf base case. - (leaf (list)))) - -(define (collect-keys x) - "Recursively collect (key k) forms from source X and return as a -list of all K." - (map (syntax-rules (key) - ((key k) 'k)) - (collect-forms 'key x))) - -(define (alist-delete* alist keys) - "Delete entries from ALIST whose key is equal (in the sense of -equal?) to any in KEYS, a list." - (remove (match-lambda - ((key . value) - (member key keys)) - (x (error "malformed alist element" x))) - alist)) - -(define-syntax map-alist - (lambda (x) - "Transform (aka map) ALIST, an association list, into another -association list. The returned association list may contain multiple -associations for the same key. equal? is used in all association list -key comparisons. - -Syntax: - -(map-alist alist - (verb key expression) ... - (else=> proc)) - -VERB must be one of set, filter-set, multiset and remove. - -For the set VERB, KEY is set to the result of evaluating -EXPRESSION. Multiple set verbs on the same key will result in multiple -associations for that key. - -For the filter-set VERB, KEY is set to the result of evaluating -EXPRESSION only if that result is not #f. - -For the multiset VERB, EXPRESSION must return a list and KEY is -associated multiple times once with each element of the returned list. - -For the remove VERB, KEY is discarded. - -EXPRESSIONs must reference elements of ALIST using (key k) forms where -K is the key to be referenced from ALIST. K must not be quoted. That -is, if K is the symbol 'bar, it must be referenced as (key bar), not -as (key 'bar). - -The else=> clause is optional. - -If the else=> clause is present, PROC is passed all pairs of ALIST -that are not set by an earlier (verb key expression) action. PROC must -return #f or a pair to replace its input pair. If PROC returns #f, -that pair is discarded. - -If the else=> clause is absent, all unset pairs are discarded. - -Example: - -(map-alist '((\"foo\" . 1) - (bar . 2) - (foobar . 5) - (fubar . 3)) - (set spam (1+ (key \"foo\"))) - (set ham (* 2 (key bar))) - (set eggs (* 3 (key bar))) - (set aal (+ (key \"foo\") - (key bar))) - (multiset vel (iota (* 2 (key bar)))) - (remove foobar) - (else=> (match-lambda - ((key . value) - (cons key (expt 2 value)))))) -=> ((spam . 2) (ham . 4) (eggs . 6) (aal . 3) - (vel . 0) (vel . 1) (vel . 2) (vel . 3) (fubar . 8))" - (syntax-case x () - ((_ alist actions ...) - ;; TODO: Check that all actions are valid. - #`(let ((evaluated-alist alist)) - (append (remove (match-lambda - ;; Filter out results of filter-set actions. - ((key . #f) - (member key '#,(filter-map (lambda (action) - (syntax-case action (filter-set) - ((filter-set key expression) #'key) - (_ #f))) - #'(actions ...)))) - (_ #f)) - ;; Do set and filter-set. - `#,(filter-map (lambda (action) - (syntax-case action (set filter-set) - ((set key expression) - #`(key . ,#,(key->assoc-ref #'evaluated-alist #'expression))) - ((filter-set key expression) - #`(key . ,#,(key->assoc-ref #'evaluated-alist #'expression))) - (_ #f))) - #'(actions ...))) - ;; Do multiset. - #,@(filter-map (lambda (action) - (syntax-case action (multiset) - ((multiset key expression) - #`(map (cut cons 'key <>) - #,(key->assoc-ref #'evaluated-alist #'expression))) - (_ #f))) - #'(actions ...)) - ;; Apply else=> procedure on unspecified keys. If - ;; no else=> procedure is specified, delete - ;; unspecified keys. - (filter-map #,(or (any (lambda (action) - (syntax-case action (else=>) - ((else=> proc) #'proc) - (_ #f))) - #'(actions ...)) - #'(const #f)) - ;; The unspecified part of the input - ;; alist - (alist-delete* evaluated-alist - (list - ;; Keys that were referenced - #,@(append-map (lambda (action) - (syntax-case action () - ((_ key expression) - (collect-keys #'expression)) - (_ '()))) - #'(actions ...)) - ;; Keys that were deleted - #,@(filter-map (lambda (action) - (syntax-case action (remove) - ((remove key) #''key) - (_ #f))) - #'(actions ...)) - ;; Keys that were set - #,@(filter-map (lambda (action) - (syntax-case action () - ((_ key expression) #''key) - (_ #f))) - #'(actions ...))))))))))) -- cgit v1.2.3