guix/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix utils)
  20   #:use-module (guix config)
  21   #:use-module (srfi srfi-1)
  22   #:use-module (srfi srfi-9)
  23   #:use-module (srfi srfi-26)
  24   #:use-module (srfi srfi-39)
  25   #:use-module (srfi srfi-60)
  26   #:use-module (rnrs bytevectors)
  27   #:use-module ((rnrs io ports) #:select (put-bytevector))
  28   #:use-module (ice-9 vlist)
  29   #:use-module (ice-9 format)
  30   #:autoload   (ice-9 popen)  (open-pipe*)
  31   #:autoload   (ice-9 rdelim) (read-line)
  32   #:use-module (ice-9 regex)
  33   #:use-module (ice-9 match)
  34   #:use-module (ice-9 format)
  35   #:autoload   (system foreign) (pointer->procedure)
  36   #:export (bytevector->base16-string
  37             base16-string->bytevector
  38             sha256
  39
  40             %nixpkgs-directory
  41             nixpkgs-derivation
  42             nixpkgs-derivation*
  43
  44             define-record-type*
  45             compile-time-value
  46             memoize
  47             default-keyword-arguments
  48             substitute-keyword-arguments
  49
  50             <location>
  51             location
  52             location?
  53             location-file
  54             location-line
  55             location-column
  56             source-properties->location
  57
  58             gnu-triplet->nix-system
  59             %current-system
  60             package-name->name+version))
  61
  62 \f
  63 ;;;
  64 ;;; Compile-time computations.
  65 ;;;
  66
  67 (define-syntax compile-time-value
  68   (syntax-rules ()
  69     "Evaluate the given expression at compile time.  The expression must
  70 evaluate to a simple datum."
  71     ((_ exp)
  72      (let-syntax ((v (lambda (s)
  73                        (let ((val exp))
  74                          (syntax-case s ()
  75                            (_ #`'#,(datum->syntax s val)))))))
  76        v))))
  77
  78 \f
  79 ;;;
  80 ;;; Base 16.
  81 ;;;
  82
  83 (define (bytevector->base16-string bv)
  84   "Return the hexadecimal representation of BV's contents."
  85   (define len
  86     (bytevector-length bv))
  87
  88   (let-syntax ((base16-chars (lambda (s)
  89                                (syntax-case s ()
  90                                  (_
  91                                   (let ((v (list->vector
  92                                             (unfold (cut > <> 255)
  93                                                     (lambda (n)
  94                                                       (format #f "~2,'0x" n))
  95                                                     1+
  96                                                     0))))
  97                                     v))))))
  98     (define chars base16-chars)
  99     (let loop ((i 0)
 100                (r '()))
 101       (if (= i len)
 102           (string-concatenate-reverse r)
 103           (loop (+ 1 i)
 104                 (cons (vector-ref chars (bytevector-u8-ref bv i)) r))))))
 105
 106 (define base16-string->bytevector
 107   (let ((chars->value (fold (lambda (i r)
 108                               (vhash-consv (string-ref (number->string i 16)
 109                                                        0)
 110                                            i r))
 111                             vlist-null
 112                             (iota 16))))
 113     (lambda (s)
 114       "Return the bytevector whose hexadecimal representation is string S."
 115       (define bv
 116         (make-bytevector (quotient (string-length s) 2) 0))
 117
 118       (string-fold (lambda (chr i)
 119                      (let ((j (quotient i 2))
 120                            (v (and=> (vhash-assv chr chars->value) cdr)))
 121                        (if v
 122                            (if (zero? (logand i 1))
 123                                (bytevector-u8-set! bv j
 124                                                    (arithmetic-shift v 4))
 125                                (let ((w (bytevector-u8-ref bv j)))
 126                                  (bytevector-u8-set! bv j (logior v w))))
 127                            (error "invalid hexadecimal character" chr)))
 128                      (+ i 1))
 129                    0
 130                    s)
 131       bv)))
 132
 133 \f
 134 ;;;
 135 ;;; Hash.
 136 ;;;
 137
 138 (define sha256
 139   (let ((hash   (pointer->procedure void
 140                                     (dynamic-func "gcry_md_hash_buffer"
 141                                                   (dynamic-link %libgcrypt))
 142                                     `(,int * * ,size_t)))
 143         (sha256 8))                        ; GCRY_MD_SHA256, as of 1.5.0
 144     (lambda (bv)
 145       "Return the SHA256 of BV as a bytevector."
 146       (let ((digest (make-bytevector (/ 256 8))))
 147         (hash sha256 (bytevector->pointer digest)
 148               (bytevector->pointer bv) (bytevector-length bv))
 149         digest))))
 150
 151 \f
 152 ;;;
 153 ;;; Nixpkgs.
 154 ;;;
 155
 156 (define %nixpkgs-directory
 157   (make-parameter
 158    ;; Capture the build-time value of $NIXPKGS.
 159    (or %nixpkgs
 160        (and=> (getenv "NIXPKGS")
 161               (lambda (val)
 162                 ;; Bail out when passed an empty string, otherwise
 163                 ;; `nix-instantiate' will sit there and attempt to read
 164                 ;; from its standard input.
 165                 (if (string=? val "")
 166                     #f
 167                     val))))))
 168
 169 (define* (nixpkgs-derivation attribute #:optional (system (%current-system)))
 170   "Return the derivation path of ATTRIBUTE in Nixpkgs."
 171   (let* ((p (open-pipe* OPEN_READ (or (getenv "NIX_INSTANTIATE")
 172                                       %nix-instantiate)
 173                         "-A" attribute (%nixpkgs-directory)
 174                         "--argstr" "system" system))
 175          (l (read-line p))
 176          (s (close-pipe p)))
 177     (and (zero? (status:exit-val s))
 178          (not (eof-object? l))
 179          l)))
 180
 181 (define-syntax-rule (nixpkgs-derivation* attribute)
 182   "Evaluate the given Nixpkgs derivation at compile-time."
 183   (compile-time-value (nixpkgs-derivation attribute)))
 184
 185 \f
 186 ;;;
 187 ;;; Miscellaneous.
 188 ;;;
 189
 190 (define-syntax define-record-type*
 191   (lambda (s)
 192     "Define the given record type such that an additional \"syntactic
 193 constructor\" is defined, which allows instances to be constructed with named
 194 field initializers, à la SRFI-35, as well as default values."
 195     (define (make-syntactic-constructor type name ctor fields defaults)
 196       "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
 197 expects all of FIELDS to be initialized.  DEFAULTS is the list of
 198 FIELD/DEFAULT-VALUE tuples."
 199       (with-syntax ((type     type)
 200                     (name     name)
 201                     (ctor     ctor)
 202                     (expected fields)
 203                     (defaults defaults))
 204         #`(define-syntax name
 205             (lambda (s)
 206               (define (record-inheritance orig-record field+value)
 207                 ;; Produce code that returns a record identical to
 208                 ;; ORIG-RECORD, except that values for the FIELD+VALUE alist
 209                 ;; prevail.
 210                 (define (field-inherited-value f)
 211                   (and=> (find (lambda (x)
 212                                  (eq? f (car (syntax->datum x))))
 213                                field+value)
 214                          car))
 215
 216                 #`(make-struct type 0
 217                                #,@(map (lambda (field index)
 218                                          (or (field-inherited-value field)
 219                                              #`(struct-ref #,orig-record
 220                                                            #,index)))
 221                                        'expected
 222                                        (iota (length 'expected)))))
 223
 224
 225               (syntax-case s (inherit #,@fields)
 226                 ((_ (inherit orig-record) (field value) (... ...))
 227                  #`(letrec* ((field value) (... ...))
 228                      #,(record-inheritance #'orig-record
 229                                            #'((field value) (... ...)))))
 230                 ((_ (field value) (... ...))
 231                  (let ((fields (map syntax->datum #'(field (... ...))))
 232                        (dflt   (map (match-lambda
 233                                      ((f v)
 234                                       (list (syntax->datum f) v)))
 235                                     #'defaults)))
 236
 237                    (define (field-value f)
 238                      (or (and=> (find (lambda (x)
 239                                         (eq? f (car (syntax->datum x))))
 240                                       #'((field value) (... ...)))
 241                                 car)
 242                          (car (assoc-ref dflt (syntax->datum f)))))
 243
 244                    (let-syntax ((error*
 245                                  (syntax-rules ()
 246                                    ((_ fmt args (... ...))
 247                                     (syntax-violation 'name
 248                                                       (format #f fmt args
 249                                                               (... ...))
 250                                                       s)))))
 251                      (let ((fields (append fields (map car dflt))))
 252                        (cond ((lset= eq? fields 'expected)
 253                               #`(letrec* ((field value) (... ...))
 254                                   (ctor #,@(map field-value 'expected))))
 255                              ((pair? (lset-difference eq? fields 'expected))
 256                               (error* "extraneous field initializers ~a"
 257                                       (lset-difference eq? fields 'expected)))
 258                              (else
 259                               (error* "missing field initializers ~a"
 260                                       (lset-difference eq? 'expected
 261                                                        fields)))))))))))))
 262
 263     (define (field-default-value s)
 264       (syntax-case s (default)
 265         ((field (default val) _ ...)
 266          (list #'field #'val))
 267         ((field _ options ...)
 268          (field-default-value #'(field options ...)))
 269         (_ #f)))
 270
 271     (syntax-case s ()
 272       ((_ type syntactic-ctor ctor pred
 273           (field get options ...) ...)
 274        #`(begin
 275            (define-record-type type
 276              (ctor field ...)
 277              pred
 278              (field get) ...)
 279            #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
 280                                          #'(field ...)
 281                                          (filter-map field-default-value
 282                                                      #'((field options ...)
 283                                                         ...))))))))
 284
 285 (define (memoize proc)
 286   "Return a memoizing version of PROC."
 287   (let ((cache (make-hash-table)))
 288     (lambda args
 289       (let ((results (hash-ref cache args)))
 290         (if results
 291             (apply values results)
 292             (let ((results (call-with-values (lambda ()
 293                                                (apply proc args))
 294                              list)))
 295               (hash-set! cache args results)
 296               (apply values results)))))))
 297
 298 (define (default-keyword-arguments args defaults)
 299   "Return ARGS augmented with any keyword/value from DEFAULTS for
 300 keywords not already present in ARGS."
 301   (let loop ((defaults defaults)
 302              (args     args))
 303     (match defaults
 304       ((kw value rest ...)
 305        (loop rest
 306              (if (assoc-ref kw args)
 307                  args
 308                  (cons* kw value args))))
 309       (()
 310        args))))
 311
 312 (define-syntax substitute-keyword-arguments
 313   (syntax-rules ()
 314     "Return a new list of arguments where the value for keyword arg KW is
 315 replaced by EXP.  EXP is evaluated in a context where VAR is boud to the
 316 previous value of the keyword argument."
 317     ((_ original-args ((kw var) exp) ...)
 318      (let loop ((args    original-args)
 319                 (before '()))
 320        (match args
 321          ((kw var rest (... ...))
 322           (loop rest (cons* exp kw before)))
 323          ...
 324          ((x rest (... ...))
 325           (loop rest (cons x before)))
 326          (()
 327           (reverse before)))))))
 328
 329 (define (gnu-triplet->nix-system triplet)
 330   "Return the Nix system type corresponding to TRIPLET, a GNU triplet as
 331 returned by `config.guess'."
 332   (let ((triplet (cond ((string-match "^i[345]86-(.*)$" triplet)
 333                         =>
 334                         (lambda (m)
 335                           (string-append "i686-" (match:substring m 1))))
 336                        (else triplet))))
 337     (cond ((string-match "^([^-]+)-([^-]+-)?linux-gnu.*" triplet)
 338            =>
 339            (lambda (m)
 340              ;; Nix omits `-gnu' for GNU/Linux.
 341              (string-append (match:substring m 1) "-linux")))
 342           ((string-match "^([^-]+)-([^-]+-)?([[:alpha:]]+)([0-9]+\\.?)*$" triplet)
 343            =>
 344            (lambda (m)
 345              ;; Nix strip the version number from names such as `gnu0.3',
 346              ;; `darwin10.2.0', etc., and always strips the vendor part.
 347              (string-append (match:substring m 1) "-"
 348                             (match:substring m 3))))
 349           (else triplet))))
 350
 351 (define %current-system
 352   ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
 353   ;; By default, this is equal to (gnu-triplet->nix-system %host-type).
 354   (make-parameter %system))
 355
 356 (define (package-name->name+version name)
 357   "Given NAME, a package name like \"foo-0.9.1b\", return two values:
 358 \"foo\" and \"0.9.1b\".  When the version part is unavailable, NAME and
 359 #f are returned.  The first hyphen followed by a digit is considered to
 360 introduce the version part."
 361   ;; See also `DrvName' in Nix.
 362
 363   (define number?
 364     (cut char-set-contains? char-set:digit <>))
 365
 366   (let loop ((chars   (string->list name))
 367              (prefix '()))
 368     (match chars
 369       (()
 370        (values name #f))
 371       ((#\- (? number? n) rest ...)
 372        (values (list->string (reverse prefix))
 373                (list->string (cons n rest))))
 374       ((head tail ...)
 375        (loop tail (cons head prefix))))))
 376
 377 \f
 378 ;;;
 379 ;;; Source location.
 380 ;;;
 381
 382 ;; A source location.
 383 (define-record-type <location>
 384   (make-location file line column)
 385   location?
 386   (file          location-file)                   ; file name
 387   (line          location-line)                   ; 1-indexed line
 388   (column        location-column))                ; 0-indexed column
 389
 390 (define location
 391   (memoize
 392    (lambda (file line column)
 393      "Return the <location> object for the given FILE, LINE, and COLUMN."
 394      (and line column file
 395           (make-location file line column)))))
 396
 397 (define (source-properties->location loc)
 398   "Return a location object based on the info in LOC, an alist as returned
 399 by Guile's `source-properties', `frame-source', `current-source-location',
 400 etc."
 401   (let ((file (assq-ref loc 'filename))
 402         (line (assq-ref loc 'line))
 403         (col  (assq-ref loc 'column)))
 404     ;; In accordance with the GCS, start line and column numbers at 1.
 405     (location file (and line (+ line 1)) (and col (+ col 1)))))