path: root/ccwl/utils.scm

;;; ccwl --- Concise Common Workflow Language
;;; Copyright © 2021, 2022, 2023 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of ccwl.
;;;
;;; ccwl is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; ccwl is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with ccwl.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; A few useful utilities

;;; Code:

(define-module (ccwl utils)
  #:use-module ((rnrs conditions) #:select (condition
                                            condition-irritants
                                            (make-irritants-condition . irritants-condition)))
  #:use-module ((rnrs exceptions) #:select (guard
                                            (raise . raise-exception)))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module (ccwl conditions)
  #:export (indent-level
            pairify
            plist->alist
            lambda**
            syntax-lambda**
            mapn
            foldn
            filter-mapi))

(define (indent-level port level)
  "Emit whitespaces to PORT corresponding to nesting LEVEL."
  (display (make-string (* 2 level) #\space) port))

(define (pairify lst)
  "Return a list of pairs of successive elements of LST. Ignore extra
elements when LST has an odd number of elements. For example,

(pairify (list 1 2 3 4 5 6))
=> ((1 . 2) (3 . 4) (5 . 6))

(pairify (list 1 2 3 4 5 6 7))
=> ((1 . 2) (3 . 4) (5 . 6))"
  (match lst
    (() '())
    ((single-element) '())
    ((first second tail ...)
     (cons (cons first second)
           (pairify tail)))))

(define* (group-keyword-arguments args #:optional (unary-keywords (list)))
  "Group ARGS, a list of keyword arguments of arbitrary arity. Return
a list of unary keyword arguments. n-ary arguments are grouped
together into lists. Keywords that are to be treated as having unit
arity are listed in UNARY-KEYWORDS. For example,

(group-keyword-arguments (list #:spam 1 #:ham 1 2 3 #:eggs 0)
                         (list #:spam))
=> (#:spam 1 #:ham (1 2 3) #:eggs (0))

If a unary keyword is passed multiple arguments, a
&invalid-keyword-arity-assertion is raised."
  (match args
    (((? keyword? this-keyword) tail ...)
     (let ((this-keyword-args tail (break keyword? tail)))
       (cons* this-keyword
              (if (member this-keyword unary-keywords)
                  ;; unary keyword argument
                  (match this-keyword-args
                    ((this-keyword-arg) this-keyword-arg)
                    (_ (raise-exception
                        (condition (invalid-keyword-arity-assertion)
                                   (irritants-condition
                                    (cons this-keyword this-keyword-args))))))
                  ;; n-ary keyword argument
                  (apply list this-keyword-args))
              (group-keyword-arguments tail unary-keywords))))
    ((non-keyword _ ...)
     (error "Invalid sequence of keywords arguments" args))
    (() '())))

(define (plist-ref plist key)
  "Return the value from the first entry in PLIST with the given KEY,
or #f if there is no such entry. For example,

(plist-ref (list #:spam 1 #:ham 2 #:eggs 3)
           #:ham)
=> 2

(plist-ref (list #:spam 1 #:ham 2 #:eggs 3)
           #:foo)
=> #f"
  (match (find-tail (cut eq? key <>) plist)
    ((_ value . _) value)
    (#f #f)))

(define (unsyntax-keywords lst)
  "Unsyntax keywords in LST, a list of syntax objects. For example:

(unsyntax-keywords (list #'#:ham #'1 #'#:eggs #'2))
=> (#:ham #'1 #:eggs #'2)"
  (map (lambda (element)
         (if (keyword? (syntax->datum element))
             (syntax->datum element)
             element))
       lst))

;; TODO: Implement a define** for lambda** in the spirit of define*
;; for lambda*.
(define-syntax lambda**
  (lambda (x)
    "Define a lambda function that can have positional arguments
followed by unary and n-ary keyword arguments. Unary keyword arguments
are prefixed by #:key. n-ary keyword arguments are prefixed by
#:key*. For example:

(lambda** (a b #:key foo #:key* bar)
  (list a b foo bar))

Here, a and b are positional arguments. foo is a unary keyword
argument. bar is an n-ary keyword argument. The above function could,
for example, be invoked as:

((lambda** (a b #:key foo #:key* bar)
   (list a b foo bar))
 1 2 #:foo 123 #:bar 1 2 3)

=> (1 2 123 (1 2 3))

lambda** also supports default values for both unary and n-ary keyword
arguments. Note that the default default value for unary arguments is
#f, while that for n-ary arguments is the empty list. For example,

((lambda** (foo bar #:key aal vale (pal 9) #:key* naal (irandu 7) (sol 3 2 1) uruthi)
   (list foo bar aal vale pal naal irandu sol uruthi))
 1 2 #:vale 123 #:naal 321 456)
=> (1 2 #f 123 9 (321 456) (7) (3 2 1) ())

Like lambda*, lambda** supports #:allow-other-keys. For example,

((lambda** (#:key foo #:allow-other-keys)
   foo)
 #:foo 1 #:bar 2)
=> 1

However, #:optional and #:rest are not supported.

If an unrecognized keyword is passed to the lambda function, a
&unrecognized-keyword-assertion condition is raised. If a unary
keyword argument is passed more than one argument, a
&invalid-keyword-arity-assertion condition is raised. If a wrong
number of positional arguments is passed, a
&invalid-positional-arguments-arity-assertion condition is raised."
    (syntax-case x ()
      ((_ (args-spec ...) body ...)
       #`(lambda args
           #,(let* ((positionals rest (break keyword?
                                             (unsyntax-keywords #'(args-spec ...))))
                    (grouped-rest (group-keyword-arguments rest))
                    (unary-arguments (or (plist-ref grouped-rest #:key)
                                         (list)))
                    (nary-arguments (or (plist-ref grouped-rest #:key*)
                                        (list)))
                    (allow-other-keys? (if (plist-ref grouped-rest #:allow-other-keys)
                                           #t #f)))
               (let ((unrecognized-keywords
                      (lset-difference (lambda (x y)
                                         (let ((x (if (keyword? x) x (syntax->datum x)))
                                               (y (if (keyword? y) y (syntax->datum x))))
                                           (eq? x y)))
                                       (filter (compose keyword? syntax->datum)
                                               #'(args-spec ...))
                                       (list #:key #:key* #:allow-other-keys))))
                 (unless (null? unrecognized-keywords)
                   (raise-exception
                    (condition (unrecognized-keyword-assertion)
                               (irritants-condition unrecognized-keywords)))))
               #`(apply (lambda* #,(append positionals
                                           (cons #:key unary-arguments)
                                           (map (lambda (x)
                                                  (syntax-case x ()
                                                    ((arg defaults ...)
                                                     #'(arg (list defaults ...)))
                                                    (arg #'(arg '()))))
                                                nary-arguments)
                                           (if allow-other-keys?
                                               (list #:allow-other-keys)
                                               (list)))
                          body ...)
                        (let ((positionals rest (break keyword? args)))
                          ;; Test for correct number of positional
                          ;; arguments.
                          (unless (= (length positionals)
                                     #,(length positionals))
                            (raise-exception
                             (condition (invalid-positional-arguments-arity-assertion)
                                        (irritants-condition positionals))))
                          ;; Test if all keywords are recognized.
                          (let ((unrecognized-keywords
                                 (lset-difference eq?
                                                  (filter keyword? rest)
                                                  '#,(map (lambda (x)
                                                            (symbol->keyword
                                                             (syntax->datum (syntax-case x ()
                                                                              ((arg _ ...) #'arg)
                                                                              (arg #'arg)))))
                                                          (append unary-arguments
                                                                  nary-arguments)))))
                            (unless (or #,allow-other-keys?
                                        (null? unrecognized-keywords))
                              (raise-exception
                               (condition (unrecognized-keyword-assertion)
                                          (irritants-condition unrecognized-keywords)))))
                          (append positionals
                                  (group-keyword-arguments
                                   rest (list #,@(map (lambda (x)
                                                        (symbol->keyword
                                                         (syntax->datum
                                                          (syntax-case x ()
                                                            ((arg default) #'arg)
                                                            (arg #'arg)))))
                                                      unary-arguments))))))))))))

(define-syntax-rule (syntax-lambda** formal-args body ...)
  "Like lambda**, but for syntax objects. For example,

((syntax-lambda** (a b #:key foo #:key* bar)
   (list a b foo bar))
 #'1 #'2 #'#:foo #'123 #'#:bar #'1 #'2 #'3)
=> (#'1 #'2 #'123 (#'1 #'2 #'3))

Like lambda**, syntax-lambda** supports default values for
arguments. The default default value for unary arguments is #f, while
that for n-ary arguments is the empty list. For example,

((syntax-lambda** (foo aal #:key vale (pal 9) #:key* naal (irandu 7) (sol 3 2 1))
   (list foo aal vale pal naal irandu sol))
 #'1 #'2 #'#:vale #'123 #'#:naal #'321 #'456)
=> (#'1 #'2 #'123 9 (#'321 #'456) (7) (3 2 1))

Like lambda**, syntax-lambda** supports #:allow-other-keys.

((syntax-lambda** (#:key foo #:allow-other-keys)
     foo)
   #'#:foo #'1 #'#:bar #'2)
=> #'1

#:optional and #:rest are not supported.

If an unrecognized keyword is passed to the lambda function, a
&unrecognized-keyword-assertion condition is raised. If a unary
keyword argument is passed more than one argument, a
&invalid-keyword-arity-assertion condition is raised. If a wrong
number of positional arguments is passed, a
&invalid-positional-arguments-arity-assertion condition is raised."
  (lambda args
    (guard (exception
            ((unrecognized-keyword-assertion? exception)
             (raise-exception
              (condition (unrecognized-keyword-assertion)
                         (irritants-condition
                          ;; Resyntax irritant keywords.
                          (map (lambda (irritant-keyword)
                                 (find (lambda (arg)
                                         (eq? (syntax->datum arg)
                                              irritant-keyword))
                                       args))
                               (condition-irritants exception))))))
            ((invalid-keyword-arity-assertion? exception)
             (raise-exception
              (condition (invalid-keyword-arity-assertion)
                         (irritants-condition
                          ;; Resyntax irritant keyword.
                          (match (condition-irritants exception)
                            ((irritant-keyword . irritant-args)
                             (cons (find (lambda (arg)
                                           (eq? (syntax->datum arg)
                                                irritant-keyword))
                                         args)
                                   irritant-args))))))))
      (apply
       (lambda** formal-args body ...)
       (unsyntax-keywords args)))))

(define (filter-mapi proc lst)
  "Indexed filter-map. Like filter-map, but PROC calls are (proc item
index) where ITEM is an element of list and INDEX is the index of that
element. For example,

(filter-mapi (lambda (item index)
               (and (even? index)
                    (1+ item)))
             (iota 10))
=> (1 3 5 7 9)"
  (filter-map (lambda (item index)
                (proc item index))
              lst
              (iota (length lst))))

(define (mapn proc lst)
  "Map the procedure PROC over list LST and return a list containing
the results. PROC can return multiple values, in which case, an equal
number of lists are returned. For example,

(mapn (lambda (n)
        (values (expt n 2)
                (expt n 3)))
      (iota 5))
=> (0 1 4 9 16)
=> (0 1 8 27 64)"
  (apply values
         (apply zip
                (map (lambda (x)
                       (call-with-values (cut proc x) list))
                     lst))))

(define (foldn proc lst . inits)
  "Apply PROC to the elements of LST to build a result, and return
that result. PROC can return multiple values, in which case, an equal
number of values are returned. Each PROC call is (PROC ELEMENT
PREVIOUS ...) where ELEMENT is an element of LST, and (PREVIOUS ...)
is the return from the previous call to PROC or the given INITS for
the first call. For example,

(foldn (lambda (n sum sum-of-squares)
         (values (+ sum n)
                 (+ sum-of-squares (expt n 2))))
       (iota 10)
       0 0)
=> 45
=> 285"
  (apply values
         (fold (lambda (element results)
                 (call-with-values (cut apply proc element results) list))
               inits
               lst)))