guile-charting/charting/util.scm

;; guile-charting
;; Copyright (C) 2007, 2014 Andy Wingo <wingo at pobox dot com>

;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, see
;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; 
;;
;;; Code:

(define-module (charting util)
  #:use-module (ice-9 optargs)
  #:use-module (cairo)
  #:export (lambda-with-kwargs
            define-with-kwargs
            cairo-text-width))

;; these taken from guile-lib and soundscrape

(define (until pred? list)
  "Returns the first elements of @var{list} for which @var{pred?} is false."
  (if (or (eq? list '()) (pred? (car list)))
      '()
      (cons (car list) (until pred? (cdr list)))))

(define (cairo-text-width cr text)
  (cairo-text-extents:width (cairo-text-extents cr text)))

(define-macro (define-macro-with-docs name-and-args docs . body)
  "Define a macro with documentation."
  `(define-macro ,name-and-args ,docs ,@body))

(define-macro-with-docs (lambda-with-kwargs BINDINGS . BODY)
  "Defines a function that takes keyword arguments.

@var{bindings} is a list of bindings, each of which may either be a
symbol or a two-element symbol-and-default-value list. Symbols without
specified default values will default to @code{#f}.

For example:
@example
 (define frobulate (lambda/kwargs (foo (bar 13) (baz 42))
                     (list foo bar baz)))
 (frobulate) @result{} (#f 13 42)
 (frobulate #:baz 3) @result{} (#f 13 3)
 (frobulate #:foo 3) @result{} (3 13 42)
 (frobulate 3 4) @result{} (3 4 42)
 (frobulate 1 2 3) @result{} (1 2 3)
 (frobulate #:baz 2 #:bar 1) @result{} (#f 1 2)
 (frobulate 10 20 #:foo 3) @result{} (3 20 42)
@end example

This function differs from the standard @code{lambda*} provided by Guile
in that invoking the function will accept positional arguments.
As an example, the @code{lambda/kwargs} behaves more intuitively in the
following case:

@example
 ((lambda* (#:optional (bar 42) #:key (baz 73))
    (list bar baz))
  1 2) @result{} (1 73)
 ((lambda/kwargs ((bar 42) (baz 73))
    (list bar baz))
  1 2) @result{} (1 2)
@end example

The fact that @code{lambda*} accepts the extra @samp{2} argument is
probably just a bug. In any case, @code{lambda/kwargs} does the right
thing.
"
  (or (list? BINDINGS)
      (error "lambda/kwargs bindings must be a list"))
  (let ((lambda-gensym (gensym))
        (args-gensym (gensym))
        (positional (gensym))
        (keyword (gensym))
        (nbindings (length BINDINGS))
        (CANONICAL-BINDINGS (map (lambda (x)
                                   (if (list? x) x (list x #f)))
                                 BINDINGS))
        (VARIABLES (map (lambda (x) (if (list? x) (car x) x))
                        BINDINGS)))
    `(let ((,lambda-gensym
            (lambda ,args-gensym
              ,@(if (string? (car BODY)) (list (car BODY)) '())
              (let* ((,positional ((@@ (charting util) until)
                                   keyword? ,args-gensym))
                     (,keyword (list-tail ,args-gensym (length ,positional))))
                (if (> (length ,positional) ,nbindings)
                    (error "Too many positional arguments."))
                ((@ (ice-9 optargs) let-optional) ,positional
                  ,CANONICAL-BINDINGS
                  ;; ,@(map car CANONICAL-BINDINGS)
                  ((@ (ice-9 optargs) let-keywords) ,keyword
                    #f
                    ,(map list VARIABLES VARIABLES)
                    ,@(if (string? (car BODY)) (cdr BODY) BODY)))))))
       (set-procedure-property! ,lambda-gensym
                                'arglist
                                '(() () ,CANONICAL-BINDINGS #f #f))
       ,lambda-gensym)))

(define-macro-with-docs (define-with-kwargs what . body)
  "Defines a function that takes kwargs. @xref{charting util
lambda/kwargs}, for more information.
"
  `(define ,(car what) ((@ (charting util) lambda-with-kwargs) ,(cdr what) ,@body)))