diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-01-31 20:24:18 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-01-31 20:24:18 +0100 |
commit | 807409d41f8b1a4435ee1cf7ddc3d1a1b9116799 (patch) | |
tree | 41ce7d861f9048863f930b8a9227ca580da17911 /module/hnh/util.scm | |
parent | Move use2dot into scripts subdir. (diff) | |
download | calp-807409d41f8b1a4435ee1cf7ddc3d1a1b9116799.tar.gz calp-807409d41f8b1a4435ee1cf7ddc3d1a1b9116799.tar.xz |
Move stuff from calp/util to hnh/util.
This is the first (major) step in splitting the generally useful items
into its own library.
Diffstat (limited to 'module/hnh/util.scm')
-rw-r--r-- | module/hnh/util.scm | 616 |
1 files changed, 616 insertions, 0 deletions
diff --git a/module/hnh/util.scm b/module/hnh/util.scm new file mode 100644 index 00000000..0b22555b --- /dev/null +++ b/module/hnh/util.scm @@ -0,0 +1,616 @@ +(define-module (hnh util) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-88) ; postfix keywords + #:use-module ((ice-9 optargs) #:select (define*-public)) + #:use-module ((sxml fold) #:select (fold-values)) + #:use-module ((srfi srfi-9 gnu) #:select (set-fields)) + #:re-export (define*-public fold-values) + #:export (for sort* sort*! + set/r! + catch-multiple + quote? + -> ->> set set-> aif awhen + let-lazy let-env + case* define-many + and=>> label + print-and-return + begin1 + ) + #:replace (let* set! define-syntax + when unless)) + +((@ (guile) define-syntax) define-syntax + (syntax-rules () + ((_ (name args ...) body ...) + ((@ (guile) define-syntax) name + (lambda (args ...) + body ...))) + ((_ otherwise ...) + ((@ (guile) define-syntax) otherwise ...)))) + + + +;; NOTE +;; Instead of returning the empty list a better default value +;; for when and unless would be the identity element for the +;; current context. +;; So (string-append (when #f ...)) would expand into +;; (string-append (if #f ... "")). +;; This however requires type interferance, which i don't +;; *currently* have. + +(define-syntax-rule (when pred body ...) + (if pred (begin body ...) '())) + +(define-syntax-rule (unless pred body ...) + (if pred '() (begin body ...))) + + +(define-syntax (aif stx) + (syntax-case stx () + [(_ condition true-clause false-clause) + (with-syntax ((it (datum->syntax stx 'it))) + #'(let ((it condition)) + (if it true-clause false-clause)))])) + +(define-syntax (awhen stx) + (syntax-case stx () + [(_ condition body ...) + (with-syntax ((it (datum->syntax stx 'it))) + #'(let ((it condition)) + (when it body ...)))])) + +#; +(define-macro (awhen pred . body) + `(let ((it ,pred)) + (when it + ,@body))) + + + +(define-syntax for + (syntax-rules (in) + ((for (<var> <vars> ...) in <collection> b1 body ...) + (map ((@ (ice-9 match) match-lambda) [(<var> <vars> ...) b1 body ...]) + <collection>)) + ((for <var> in <collection> b1 body ...) + (map (lambda (<var>) b1 body ...) + <collection>)))) + + + +;; Replace let* with a version that can bind from lists. +;; Also supports SRFI-71 (extended let-syntax for multiple values) +;; @lisp +;; (let* ([a b (values 1 2)] ; @r{SRFI-71} +;; [(c d) '(3 4)] ; @r{Let-list (mine)} +;; [(a b . c) (cons* 1 2 3)] ; @r{Improper list matching (mine)} +;; [e 5]) ; @r{Regular} +;; (list e d c b a)) +;; ;; => (5 4 3 2 1) +;; @end lisp +(define-syntax let* + (syntax-rules () + + ;; Base case + [(_ () body ...) + (begin body ...)] + + ;; (let (((a b) '(1 2))) (list b a)) => (2 1) + [(_ (((k ... . (k*)) list-value) rest ...) + body ...) + (apply (lambda (k ... k*) + (let* (rest ...) + body ...)) + list-value)] + + ;; Improper list matching + ;; (let* (((a b . c) (cons* 1 2 3))) (list a c)) ; => (1 3) + [(_ (((k1 k ... . k*) imp-list) rest ...) + body ...) + (apply (lambda (k1 k ... k*) + (let* (rest ...) + body ...)) + (improper->proper-list + imp-list (length (quote (k1 k ...)))))] + + ;; "Regular" case + [(_ ((k value) rest ...) body ...) + (let ((k value)) + (let* (rest ...) + body ...))] + + ;; SRFI-71 let-values + [(_ ((k k* ... values) rest ...) body ...) + (call-with-values (lambda () values) + (lambda (k k* ...) + (let* (rest ...) + body ...)))] + + ;; Declare variable without a value (actuall #f). + ;; Useful for inner mutation. + [(_ (v rest ...) body ...) + (let* ((v #f) rest ...) body ...)] + )) + +(define (improper->proper-list lst len) + (let* ((head tail (split-at lst len))) + (append head (list tail)))) + + +(define-syntax-rule (begin1 first rest ...) + (let ((return first)) + rest ... + return)) + + + + + +(define-macro (print-and-return expr) + (let ((str (gensym "str")) + (result (gensym "result"))) + `(let* ((,result ,expr) + (,str (format #f "~a [~a]~%" ,result (quote ,expr)))) + (display ,str (current-error-port)) + ,result))) + + + +(define-public (swap f) + (lambda args (apply f (reverse args)))) + + +(define-syntax case*% + (syntax-rules (else) + [(_ _ else) + #t] + [(_ invalue (value ...)) + (memv invalue (list value ...))] + #; + [(_ invalue target) + (eq? invalue target)])) + +;; Like `case', but evals the case parameters +(define-syntax case* + (syntax-rules (else) + [(_ invalue (cases body ...) ...) + (cond ((case*% invalue cases) + body ...) + ...)])) + +;; Allow set to work on multiple values at once, +;; similar to Common Lisp's @var{setf} +;; @example +;; (set! x 10 +;; y 20) +;; @end example +;; Still requires all variables to be defined beforehand. +(define-syntax set! + (syntax-rules (=) + ((_ field = (op args ...) rest ...) + (set! field (op field args ...) + rest ...)) + ((_ field = proc rest ...) + (set! field (proc field) + rest ...)) + ((_ field val) + ((@ (guile) set!) field val)) + ((_ field val rest ...) + (begin ((@ (guile) set!) field val) + (set! rest ...))))) + +;; only evaluates the final form once +(define-syntax set/r! + (syntax-rules (=) + ((_ args ... v = something) + (begin + (set! args ... v = something) + v)) + ((_ args ... final) + (let ((val final)) + (set! args ... val) + val)))) + + +(define-syntax define-many + (syntax-rules () + [(_) (begin)] + [(_ def) (begin)] + [(_ (symbols ...) value rest ...) + (begin (define symbols value) ... + (define-many rest ...))] + [(_ def (symbols ...) value rest ...) + (begin (def symbols value) ... + (define-many def rest ...))])) + +;; Attach a label to a function, allowing it to call itself +;; without actually giving it a name (can also be thought +;; of as letrec-1). +;; @example +;; ((label fact +;; (match-lambda +;; [0 1] +;; [x (* x (fact (1- x)))])) +;; 5) +;; @end example +(define-syntax label + (syntax-rules () + [(_ self proc) + (letrec ((self proc)) + proc)])) + + +;; This function borrowed from web-ics (calendar util) +(define* (sort* items comperator #:optional (get identity)) + "A sort function more in line with how python's sorted works" + (sort items (lambda (a b) + (comperator (get a) + (get b))))) + +;; Sorts the list @var{items}. @emph{May} destroy the input list in the process +(define* (sort*! items comperator #:optional (get identity)) + "A sort function more in line with how python's sorted works" + (sort! items (lambda (a b) + (comperator (get a) + (get b))))) + +;; Given {items, <} finds the most extreme value. +;; Returns 2 values. The extremest item in @var{items}, +;; and the other items in some order. +;; Ord b => (list a) [, (b, b -> bool), (a -> b)] -> a, (list a) +(define*-public (find-extreme items optional: (< <) (access identity)) + (if (null? items) + (error "Can't find extreme in an empty list") + (fold-values + (lambda (c min other) + (if (< (access c) (access min)) + ;; Current stream head is smaller that previous min + (values c (cons min other)) + ;; Previous min is still smallest + (values min (cons c other)))) + (cdr items) + ;; seeds: + (car items) '()))) + +(define*-public (find-min list optional: (access identity)) + (find-extreme list < access)) + +(define*-public (find-max list optional: (access identity)) + (find-extreme list > access)) + +(define-public (filter-sorted proc list) + (take-while + proc (drop-while + (negate proc) list))) + +;; (define (!= a b) (not (= a b))) +(define-public != (negate =)) + +(define-public (take-to lst i) + "Like @var{take}, but might lists shorter than length." + (if (> i (length lst)) + lst (take lst i))) + +(define-public (string-take-to str i) + (if (> i (string-length str)) + str (string-take str i))) + +(define-public (string-first str) + (string-ref str 0)) + +(define-public (string-last str) + (string-ref str (1- (string-length str)))) + +(define-public (as-symb s) + (if (string? s) (string->symbol s) s)) + +(define-public (enumerate lst) + (zip (iota (length lst)) + lst)) + +;; Takes a procedure returning multiple values, and returns a function which +;; takes the same arguments as the original procedure, but only returns one of +;; the procedures. Which procedure can be sent as an additional parameter. +(define*-public (unval proc #:optional (n 0)) + (lambda args + (call-with-values (lambda () (apply proc args)) + (lambda args (list-ref args n))))) + +(define-public (flatten lst) + (fold (lambda (subl done) + (append done ((if (list? subl) flatten list) subl))) + '() lst)) + +(define-syntax let-lazy + (syntax-rules () + [(_ ((field value) ...) + body ...) + (let ((field (delay value)) ...) + (let-syntax ((field (identifier-syntax (force field))) ...) + body ...))])) + +(define-public (map/dotted proc dotted-list) + (cond ((null? dotted-list) '()) + ((not-pair? dotted-list) (proc dotted-list)) + (else + (cons (proc (car dotted-list)) + (map/dotted proc (cdr dotted-list)))))) + +;; Merges two association lists, comparing with eq. +;; The cdrs in all pairs in both lists should be lists, +;; If a key is present in both then the contents of b is +;; put @emph{before} the contents in a. +;; @example +;; (assq-merge '((k 1)) '((k 2))) +;; => ((k 2 1)) +;; @end example +(define-public (assq-merge a b) + (fold (lambda (entry alist) + (let* (((k . v) entry) + (o (assq-ref alist k))) + (assq-set! alist k (append v (or o '()))))) + (copy-tree a) b)) + +(define-public (kvlist->assq kvlist) + (map (lambda (pair) + (cons (keyword->symbol (car pair)) (cdr pair))) + (group kvlist 2))) + +(define*-public (assq-limit alist optional: (number 1)) + (map (lambda (pair) + (take-to pair (1+ number))) + alist)) + +(define-public (group-by proc lst) + (let ((h (make-hash-table))) + (for value in lst + (let ((key (proc value))) + (hash-set! h key (cons value (hash-ref h key '()))))) + ;; NOTE changing this list to cons allows the output to work with assq-merge. + (hash-map->list list h))) + +;; (split-by '(0 1 2 3 4 2 5 6) 2) +;; ⇒ ((0 1) (3 4) (5 6)) +(define-public (split-by list item) + (let loop ((done '()) + (current '()) + (rem list)) + (cond [(null? rem) + (reverse (cons (reverse current) done))] + [(eqv? item (car rem)) + (loop (cons (reverse current) done) + '() + (cdr rem))] + [else + (loop done + (cons (car rem) current) + (cdr rem))]))) + + + +;; Simar to span from srfi-1, but never takes more than +;; @var{count} items. Can however still take less. +;; @example +;; (span-upto 2 char-numeric? (string->list "123456")) +;; ⇒ (#\1 #\2) +;; ⇒ (#\3 #\4 #\5 #\6) +;; (span-upto 2 char-numeric? (string->list "H123456")) +;; ⇒ () +;; ⇒ (#\H #\1 #\2 #\3 #\4 #\5 #\6) +;; @end example +(define-public (span-upto count predicate list) + (let loop ((remaining count) + (taken '()) + (list list)) + (if (or (zero? remaining) (null? list)) + (values (reverse! taken) list) + (if (predicate (car list)) + (loop (1- remaining) + (cons (car list) taken) + (cdr list)) + (loop (1- remaining) + taken list))))) + + +;; Returns the cross product between l1 and l2. +;; each element is a cons cell. +(define (cross-product% l1 l2) + (concatenate + (map (lambda (a) + (map (lambda (b) (cons a b)) + l2)) + l1))) + +(define-public (cross-product . args) + (if (null? args) + '() + (let* ((last rest (car+cdr (reverse args)))) + (reduce-right cross-product% '() + (reverse (cons (map list last) rest )))))) + +;; Given an arbitary tree, do a pre-order traversal, appending all strings. +;; non-strings allso allowed, converted to strings and also appended. +(define-public (string-flatten tree) + (cond [(string? tree) tree] + [(list? tree) (string-concatenate (map string-flatten tree))] + [else (format #f "~a" tree)])) + +(define-public (intersperse item list) + (let loop ((flipflop #f) + (rem list)) + (if (null? rem) + '() + (if flipflop + (cons item (loop (not flipflop) rem)) + (cons (car rem) (loop (not flipflop) (cdr rem))) + )))) + +;; @example +;; (insert-ordered 5 (iota 10)) +;; ⇒ (0 1 2 3 4 5 5 6 7 8 9) +;; @end example +(define*-public (insert-ordered item collection optional: (< <)) + (cond [(null? collection) + (list item)] + [(< item (car collection)) + (cons item collection)] + [else + (cons (car collection) + (insert-ordered item (cdr collection) <))])) + + + +(define-syntax -> + (syntax-rules () + [(-> obj) obj] + [(-> obj (func args ...) rest ...) + (-> (func obj args ...) rest ...)] + [(-> obj func rest ...) + (-> (func obj) rest ...)])) + +(define-syntax ->> + (syntax-rules () + ((->> obj) + obj) + ((->> obj (func args ...) rest ...) + (->> (func args ... obj) rest ...)) + ((->> obj func rest ...) + (->> (func obj) rest ...)))) + +;; Non-destructive set, syntax extension from set-fields from (srfi +;; srfi-9 gnu). +(define-syntax set + (syntax-rules (=) + [(set (acc obj) value) + (set-fields + obj ((acc) value))] + [(set (acc obj) = (op rest ...)) + (set-fields + obj ((acc) (op (acc obj) rest ...)))])) + +(define-syntax set-> + (syntax-rules (=) + [(_ obj) obj] + [(_ obj (func = (op args ...)) rest ...) + (set-> (set (func obj) (op (func obj) args ...)) rest ...)] + [(_ obj (func args ...) rest ...) + (set-> (set (func obj) args ...) rest ...)])) + +(define-syntax and=>> + (syntax-rules () + [(_ value) value] + [(_ value proc rest ...) + (and=>> (and=> value proc) + rest ...)])) + +(define-public (downcase-symbol symb) + (-> symb + symbol->string + string-downcase + string->symbol)) + + +;; @example +;; (group (iota 10) 2) +;; ⇒ ((0 1) (2 3) (4 5) (6 7) (8 9)) +;; @end example +;; Requires that width|(length list) +(define-public (group list width) + (unless (null? list) + (let* ((row rest (split-at list width))) + (cons row (group rest width))))) + +;; repeatedly apply @var{proc} to @var{base} +;; unitl @var{until} is satisfied. +;; (a → a), (a → bool), a → a +(define-public (iterate proc until base) + (let loop ((o base)) + (if (until o) + o + (loop (proc o))))) + +;; (a → values a), list ... → values a +(define-public (valued-map proc . lists) + (apply values + (apply append-map + (lambda args + (call-with-values (lambda () (apply proc args)) list)) + lists))) + +(define (ass%-ref-all alist key =) + (map cdr (filter (lambda (pair) (= key (car pair))) + alist))) + +;; Equivalent to assoc-ref (and family), but works on association lists with +;; non-unique keys, returning all mathing records (instead of just the first). +;; @begin lisp +;; (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a) +;; ⇒ (1 3) +;; @end +(define-public (assoc-ref-all alist key) (ass%-ref-all alist key equal?)) +(define-public (assq-ref-all alist key) (ass%-ref-all alist key eq?)) +(define-public (assv-ref-all alist key) (ass%-ref-all alist key eqv?)) + + + + +(define-public (vector-last v) + (vector-ref v (1- (vector-length v)))) + +(define-public (->str any) + (with-output-to-string (lambda () (display any)))) + +(define-public ->string ->str) + +(define-public (->quoted-string any) + (with-output-to-string (lambda () (write any)))) + + + + +;; TODO shouldn't this use `file-name-separator-string'? +(define-public (path-append . strings) + (fold (lambda (s done) + (string-append + done + (if (string-null? s) + (string-append s "/") + (if (char=? #\/ (string-last done)) + (if (char=? #\/ (string-first s)) + (string-drop s 1) s) + (if (char=? #\/ (string-first s)) + s (string-append "/" s)))))) + (let ((s (car strings))) + (if (string-null? s) + "/" s)) + (cdr strings))) + + + + +(define-syntax let-env + (syntax-rules () + [(_ ((name value) ...) + body ...) + + (let ((env-pairs #f)) + (dynamic-wind + (lambda () + (set! env-pairs + (map (lambda (n new-value) + (list n new-value (getenv n))) + (list (symbol->string (quote name)) ...) + (list value ...))) + (for-each (lambda (pair) (setenv (car pair) (cadr pair))) + env-pairs)) + (lambda () body ...) + (lambda () + (for-each (lambda (pair) (setenv (car pair) (caddr pair))) + env-pairs))))])) + + +(define-public (uuidgen) + ((@ (rnrs io ports) call-with-port) + ((@ (ice-9 popen) open-input-pipe) "uuidgen") + (@ (ice-9 rdelim) read-line))) |