guile-examples/shell/guile-shell/alist-helpers.scm

(library (alist-helpers)
  (export alist-refs
          alist-set
          alist-item-key
          alist-item-value
          alist-find-item-by-value
          alist-find-item-by-key)
  (import (rnrs base)
          (only (guile)
                lambda* λ
                ;; command line args
                simple-format
                current-output-port)
          ;; GNU Guile batteries
          (ice-9 exceptions)
          ;; SRFIs
          ;; SRFI 1 - list procs
          (srfi srfi-1)
          ;; SRFI 43 - vector procs
          (srfi srfi-43)
          ;; SRFI 69 - hash tables
          (srfi srfi-69))


  (define rest cdr)


  (define alist-item-key
    (λ (item)
      "Get the key of the given ITEM of an alist."
      (first item)))


  (define alist-item-value
    (λ (item)
      "Get the value of the given ITEM of an alist."
      (cdr item)))


  (define alist-find-item-by-value
    (lambda* (val alst #:key (equal-test equal?))
      "Find an item of the given alist ALST by given value VAL
and return it."
      (find (λ (entry)
              (equal-test (alist-item-value entry) val))
            alst)))


  (define alist-find-item-by-key
    (lambda* (key alst #:key (equal-test equal?))
      "Find an item of the given alist ALST by given key KEY
and return it."
      (find (λ (entry)
              (equal-test (first entry) key))
            alst)))


  (define alist-refs
    (lambda* (alist refs #:key (default-thunk #f) (equal-test equal?))
      ;; (simple-format (current-output-port) "remaining refs for alist: ~a\n" refs)
      (cond
       ;; If no more refs are given, we must have found what
       ;; we are looking for.
       [(null? refs) alist]
       [(pair? alist)
        (cond
         ;; If there are no more entries in the current alist,
         ;; then we could not find the searched key.
         [(null? alist)
          ;; If a default thunk was given, call it, otherwise
          ;; raise an exception.
          (if default-thunk
              (default-thunk)
              (raise-exception
               (make-exception (make-non-continuable-error)
                               (make-exception-with-message "key not found")
                               (make-exception-with-irritants (list refs alist))
                               (make-exception-with-origin 'alist-refs))))]
         [else
          (let ([ref (first refs)]
                [item (first alist)])
            (cond
             [(equal-test (alist-item-key item) ref)
              (alist-refs (alist-item-value item)
                          (drop refs 1)
                          #:default-thunk default-thunk
                          #:equal-test equal-test)]
             [else
              (alist-refs (drop alist 1)
                          refs
                          #:default-thunk default-thunk
                          #:equal-test equal-test)]))])]
       [else
        ;; (simple-format (current-output-port) "not a pair: ~a\n" alist)
        (if default-thunk
            (default-thunk)
            (raise-exception
             (make-exception (make-non-continuable-error)
                             (make-exception-with-message "key not found")
                             (make-exception-with-irritants (list refs alist))
                             (make-exception-with-origin 'alist-refs))))])))


  (define alist-set
    (lambda* (alst key val #:key (equal-test equal?))
      "Set a given value VAL for a given KEY in the given
association list ALST."
      (cond
       [(null? alst) (cons (cons key val) '())]
       [else
        (let ([current-assoc (first alst)])
          (cond
           [(equal-test (alist-item-key current-assoc) key)
            (cons (cons key val)
                  (drop alst 1))]
           [else
            (cons current-assoc
                  (alist-set (drop alst 1)
                             key
                             val
                             #:equal-test equal-test))]))])))


  (define alist?-shallow
    (λ (lst)
      "Check, whether LST is an association list, by only looking
at the first item."
      (cond
       [(null? lst) #t]
       [(pair? lst)
        (pair? (first lst))]
       [else #f])))

  (define alist-any-key
    (lambda* (alst pred)
      "Check, whether any key in the alist ALST satisfies the
given predicate PRED."
      (cond
       [(null? alst) #f]
       [else
        (let ([first-key (alist-item-key (first alst))]
              [first-val (alist-item-value (first alst))])
          (cond
           ;; Check the predicate for the first key.
           [(pred first-key) #t]
           ;; If the first value seems to be an association
           ;; list itself, then check it and the rest of the
           ;; alist keys at the current level.
           [(alist?-shallow first-val)
            (or (alist-any-key first-val pred)
                (alist-any-key (drop alst 1) pred))]
           [else
            ;; Check the rest of the keys of the association
            ;; list.
            (alist-any-key (drop alst 1) pred)]))])))

  (define alist-any-value
    (λ (alst pred)
      "Check, whether any value in the alist ALST satisfies the
given predicate PRED."
      (cond
       [(null? alst) #f]
       [else
        (let ([first-val (alist-item-value (first alst))])
          (cond
           [(pred first-val) #t]
           [(alist?-shallow first-val)
            (or (alist-any-value first-val pred)
                (alist-any-value (drop alst 1) pred))]
           [else
            (alist-any-value (drop alst 1) pred)]))])))


  (define alist-set*
    (lambda* (alst keys val #:key (equal-test equal?))
      "Set value VAL inside the alist ALST navigating through its
keys using KEYS to get to the place where VAL shall be the
new value."
      (define traverse
        (λ (alst keys)
          (cond
           [(null? keys) val]
           [(not (alist?-shallow alst))
            (raise-exception
             (make-exception (make-non-continuable-error)
                             (make-exception-with-message "key not found")
                             (make-exception-with-irritants keys)
                             (make-exception-with-origin 'alist-set*)))]
           [(null? alst) (cons (cons (first keys)
                                     val)
                               '())]
           [else
            (let ([current-assoc (first alst)]
                  [item-key (alist-item-key (first alst))])
              (cond
               [(equal-test item-key (first keys))
                ;; Change the value and cons the rest of the list.
                (cons (cons item-key
                            (traverse (alist-item-value current-assoc)
                                      (drop keys 1)))
                      (drop alst 1))]
               [else
                (cons current-assoc
                      (traverse (drop alst 1) keys))]))])))
      (traverse alst keys))))