1 files changed, 168 insertions, 0 deletions
diff --git a/module/util.scm b/module/util.scm
new file mode 100644
index 00000000..6f1b955a
--- /dev/null
+++ b/module/util.scm
@@ -0,0 +1,168 @@
+(define-module (util)
+  #:use-module (srfi srfi-1)
+  #:use-module ((sxml fold) #:select (fold-values))
+  #:export (destructure-lambda let-multi fold-lists catch-let
+                               for-each-in
+                               define-quick-record define-quick-record!
+                               mod! sort* sort*!
+                               find-min)
+  #:replace (let*)
+  )
+
+(define-public upstring->symbol (compose string->symbol string-upcase))
+
+(define-public symbol-upcase (compose string->symbol string-upcase symbol->string))
+
+(define-public symbol-downcase (compose string->symbol string-downcase symbol->string))
+
+(define-syntax destructure-lambda
+  (syntax-rules ()
+    ((_ expr-list body ...)
+     (lambda (expr)
+       (apply (lambda expr-list body ...) expr)))))
+
+(define-syntax catch-let
+  (syntax-rules ()
+    ((_ thunk ((type handler) ...))
+     (catch #t thunk
+       (lambda (err . args)
+         (case err
+           ((type) (apply handler err args)) ...
+           (else (format #t "Unhandled error type ~a, rethrowing ~%" err)
+                 (apply throw err args))))))))
+
+;;; For-each with arguments in reverse order.
+(define-syntax-rule (for-each-in lst proc)
+  (for-each proc lst))
+
+
+;;; Helper macros to make define-quick-record better
+
+(define (class-name symb) (symbol-append '< symb '>))
+(define (constructor symb) (symbol-append 'make- symb))
+(define (pred symb) (symbol-append symb '?))
+
+(define (getter name symb) (symbol-append 'get- name '- symb))
+(define* (setter name symb #:optional bang?)
+  (symbol-append 'set- name '- symb (if bang? '! (symbol))))
+
+(define (%define-quick-record internal-define bang? name fields)
+  (let ((symb (gensym)))
+    `((,internal-define ,(class-name name)
+             (,(constructor name) ,@fields)
+             ,(pred name)
+             ,@(map (lambda (f) `(,f ,(getter f symb) ,(setter f symb bang?)))
+                    fields))
+            ,@(map (lambda (f) `(define ,f (make-procedure-with-setter
+                                       ,(getter f symb) ,(setter f symb bang?))))
+                   fields))))
+
+;;; Creates srfi-9 define{-immutable,}-record-type declations.
+;;; Also creates srfi-17 accessor ((set! (access field) value))
+
+;; (define (define-quick-record-templated define-proc name field))
+
+(define-macro (define-quick-record name . fields)
+  (let ((public-fields  (or (assoc-ref fields #:public)  '()))
+        (private-fields (or (assoc-ref fields #:private) '())))
+    `(begin
+       ,@(%define-quick-record '(@ (srfi srfi-9 gnu) define-immutable-record-type)
+                               #f name
+                               (append public-fields private-fields))
+       ,@(map (lambda (field) `(export ,field))
+              public-fields))))
+  ;; (define-quick-record-templated 'define-immutable-record-type name fields))
+
+;; (define-macro (define-quick-record! name . fields)
+;;   (define-quick-record-templated 'define-record-type name fields))
+
+;; 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)}
+;;        [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)]
+
+    ;; "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 ...)))]
+
+    ))
+
+;; Like set!, but applies a transformer on the already present value.
+(define-syntax-rule (mod! field transform-proc)
+  (set! field (transform-proc field)))
+
+(define-public (concat lists)
+  (apply append lists))
+
+;; 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)))))
+
+;;; 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)))))
+
+;; Finds the smallest element in @var{items}, compared with @var{<} after
+;; applying @var{foo}. Returns 2 values. The smallest item in @var{items},
+;; and the other items in some order.
+(define (find-min < ac items)
+  (if (null? items)
+      ;; Vad fan retunerar man här?
+      (values #f '())
+      (fold-values
+       (lambda (c min other)
+         (if (< (ac c) (ac 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 (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)))