guix-kreyren/guix/records.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix records)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:export (define-record-type*
            alist->record
            object->fields
            recutils->alist))

;;; Commentary:
;;;
;;; Utilities for dealing with Scheme records.
;;;
;;; Code:

(define-syntax record-error
  (syntax-rules ()
    "Report a syntactic error in use of CONSTRUCTOR."
    ((_ constructor form fmt args ...)
     (syntax-violation constructor
                       (format #f fmt args ...)
                       form))))

(define* (make-syntactic-constructor type name ctor fields
                                     #:key (thunked '()) (defaults '()))
  "Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects
all of FIELDS to be initialized.  DEFAULTS is the list of FIELD/DEFAULT-VALUE
tuples, and THUNKED is the list of identifiers of thunked fields."
  (with-syntax ((type     type)
                (name     name)
                (ctor     ctor)
                (expected fields)
                (defaults defaults))
    #`(define-syntax name
        (lambda (s)
          (define (record-inheritance orig-record field+value)
            ;; Produce code that returns a record identical to ORIG-RECORD,
            ;; except that values for the FIELD+VALUE alist prevail.
            (define (field-inherited-value f)
              (and=> (find (lambda (x)
                             (eq? f (car (syntax->datum x))))
                           field+value)
                     car))

            ;; Make sure there are no unknown field names.
            (let* ((fields     (map (compose car syntax->datum) field+value))
                   (unexpected (lset-difference eq? fields 'expected)))
              (when (pair? unexpected)
                (record-error 'name s "extraneous field initializers ~a"
                              unexpected)))

            #`(make-struct type 0
                           #,@(map (lambda (field index)
                                     (or (field-inherited-value field)
                                         #`(struct-ref #,orig-record
                                                       #,index)))
                                   'expected
                                   (iota (length 'expected)))))

          (define (thunked-field? f)
            (memq (syntax->datum f) '#,thunked))

          (define (wrap-field-value f value)
            (if (thunked-field? f)
                #`(lambda () #,value)
                value))

          (define (field-bindings field+value)
            ;; Return field to value bindings, for use in 'let*' below.
            (map (lambda (field+value)
                   (syntax-case field+value ()
                     ((field value)
                      #`(field
                         #,(wrap-field-value #'field #'value)))))
                 field+value))

          (syntax-case s (inherit #,@fields)
            ((_ (inherit orig-record) (field value) (... ...))
             #`(let* #,(field-bindings #'((field value) (... ...)))
                 #,(record-inheritance #'orig-record
                                       #'((field value) (... ...)))))
            ((_ (field value) (... ...))
             (let ((fields (map syntax->datum #'(field (... ...))))
                   (dflt   (map (match-lambda
                                 ((f v)
                                  (list (syntax->datum f) v)))
                                #'defaults)))

               (define (field-value f)
                 (or (and=> (find (lambda (x)
                                    (eq? f (car (syntax->datum x))))
                                  #'((field value) (... ...)))
                            car)
                     (let ((value
                            (car (assoc-ref dflt (syntax->datum f)))))
                       (wrap-field-value f value))))

               (let ((fields (append fields (map car dflt))))
                 (cond ((lset= eq? fields 'expected)
                        #`(let* #,(field-bindings
                                   #'((field value) (... ...)))
                            (ctor #,@(map field-value 'expected))))
                       ((pair? (lset-difference eq? fields 'expected))
                        (record-error 'name s
                                      "extraneous field initializers ~a"
                                      (lset-difference eq? fields
                                                       'expected)))
                       (else
                        (record-error 'name s
                                      "missing field initializers ~a"
                                      (lset-difference eq? 'expected
                                                       fields))))))))))))

(define-syntax define-record-type*
  (lambda (s)
    "Define the given record type such that an additional \"syntactic
constructor\" is defined, which allows instances to be constructed with named
field initializers, à la SRFI-35, as well as default values.  An example use
may look like this:

  (define-record-type* <thing> thing make-thing
    thing?
    (name  thing-name (default \"chbouib\"))
    (port  thing-port
           (default (current-output-port)) (thunked)))

This example defines a macro 'thing' that can be used to instantiate records
of this type:

  (thing
    (name \"foo\")
    (port (current-error-port)))

The value of 'name' or 'port' could as well be omitted, in which case the
default value specified in the 'define-record-type*' form is used:

  (thing)

The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
actually compute the field's value in the current dynamic extent, which is
useful when referring to fluids in a field's value.

It is possible to copy an object 'x' created with 'thing' like this:

  (thing (inherit x) (name \"bar\"))

This expression returns a new object equal to 'x' except for its 'name'
field."

    (define (field-default-value s)
      (syntax-case s (default)
        ((field (default val) _ ...)
         (list #'field #'val))
        ((field _ options ...)
         (field-default-value #'(field options ...)))
        (_ #f)))

    (define (thunked-field? s)
      ;; Return the field name if the field defined by S is thunked.
      (syntax-case s (thunked)
        ((field (thunked) _ ...)
         #'field)
        ((field _ options ...)
         (thunked-field? #'(field options ...)))
        (_ #f)))

    (define (thunked-field-accessor-name field)
      ;; Return the name (an unhygienic syntax object) of the "real"
      ;; getter for field, which is assumed to be a thunked field.
      (syntax-case field ()
        ((field get options ...)
         (let* ((getter      (syntax->datum #'get))
                (real-getter (symbol-append '% getter '-real)))
           (datum->syntax #'get real-getter)))))

    (define (field-spec->srfi-9 field)
      ;; Convert a field spec of our style to a SRFI-9 field spec of the
      ;; form (field get).
      (syntax-case field ()
        ((name get options ...)
         #`(name
            #,(if (thunked-field? field)
                  (thunked-field-accessor-name field)
                  #'get)))))

    (define (thunked-field-accessor-definition field)
      ;; Return the real accessor for FIELD, which is assumed to be a
      ;; thunked field.
      (syntax-case field ()
        ((name get _ ...)
         (with-syntax ((real-get (thunked-field-accessor-name field)))
           #'(define-inlinable (get x)
               ;; The real value of that field is a thunk, so call it.
               ((real-get x)))))))

    (syntax-case s ()
      ((_ type syntactic-ctor ctor pred
          (field get options ...) ...)
       (let* ((field-spec #'((field get options ...) ...))
              (thunked    (filter-map thunked-field? field-spec))
              (defaults   (filter-map field-default-value
                                      #'((field options ...) ...))))
         (with-syntax (((field-spec* ...)
                        (map field-spec->srfi-9 field-spec))
                       ((thunked-field-accessor ...)
                        (filter-map (lambda (field)
                                      (and (thunked-field? field)
                                           (thunked-field-accessor-definition
                                            field)))
                                    field-spec)))
           #`(begin
               (define-record-type type
                 (ctor field ...)
                 pred
                 field-spec* ...)
               (begin thunked-field-accessor ...)
               #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
                                             #'(field ...)
                                             #:thunked thunked
                                             #:defaults defaults))))))))

(define* (alist->record alist make keys
                        #:optional (multiple-value-keys '()))
  "Apply MAKE to the values associated with KEYS in ALIST.  Items in KEYS that
are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple
times in ALIST, and thus their value is a list."
  (let ((args (map (lambda (key)
                     (if (member key multiple-value-keys)
                         (filter-map (match-lambda
                                      ((k . v)
                                       (and (equal? k key) v)))
                                     alist)
                         (assoc-ref alist key)))
                   keys)))
    (apply make args)))

(define (object->fields object fields port)
  "Write OBJECT (typically a record) as a series of recutils-style fields to
PORT, according to FIELDS.  FIELDS must be a list of field name/getter pairs."
  (let loop ((fields fields))
    (match fields
      (()
       object)
      (((field . get) rest ...)
       (format port "~a: ~a~%" field (get object))
       (loop rest)))))

(define %recutils-field-charset
  ;; Valid characters starting a recutils field.
  ;; info "(recutils) Fields"
  (char-set-union char-set:upper-case
                  char-set:lower-case
                  (char-set #\%)))

(define (recutils->alist port)
  "Read a recutils-style record from PORT and return it as a list of key/value
pairs.  Stop upon an empty line (after consuming it) or EOF."
  (let loop ((line   (read-line port))
             (result '()))
    (cond ((eof-object? line)
           (reverse result))
          ((string-null? line)
           (if (null? result)
               (loop (read-line port) result)     ; leading space: ignore it
               (reverse result)))                 ; end-of-record marker
          (else
           ;; Now check the first character of LINE, since that's what the
           ;; recutils manual says is enough.
           (let ((first (string-ref line 0)))
             (cond
              ((char-set-contains? %recutils-field-charset first)
               (let* ((colon (string-index line #\:))
                      (field (string-take line colon))
                      (value (string-trim (string-drop line (+ 1 colon)))))
                 (loop (read-line port)
                       (alist-cons field value result))))
              ((eqv? first #\#)                   ;info "(recutils) Comments"
               (loop (read-line port) result))
              ((eqv? first #\+)                   ;info "(recutils) Fields"
               (let ((new-line (if (string-prefix? "+ " line)
                                   (string-drop line 2)
                                   (string-drop line 1))))
                (match result
                  (((field . value) rest ...)
                   (loop (read-line port)
                         `((,field . ,(string-append value "\n" new-line))
                           ,@rest))))))
              (else
               (error "unmatched line" line))))))))

;;; records.scm ends here