guix/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
   5 ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
   6 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
   7 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
   8 ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
   9 ;;;
  10 ;;; This file is part of GNU Guix.
  11 ;;;
  12 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  13 ;;; under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 3 of the License, or (at
  15 ;;; your option) any later version.
  16 ;;;
  17 ;;; GNU Guix is distributed in the hope that it will be useful, but
  18 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 (define-module (guix utils)
  26   #:use-module (guix config)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-9)
  29   #:use-module (srfi srfi-11)
  30   #:use-module (srfi srfi-26)
  31   #:use-module (srfi srfi-39)
  32   #:use-module (ice-9 binary-ports)
  33   #:autoload   (rnrs io ports) (make-custom-binary-input-port)
  34   #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
  35   #:use-module (guix memoization)
  36   #:use-module (guix records)
  37   #:use-module ((guix build utils) #:select (dump-port mkdir-p))
  38   #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
  39   #:use-module (ice-9 format)
  40   #:autoload   (ice-9 popen)  (open-pipe*)
  41   #:autoload   (ice-9 rdelim) (read-line)
  42   #:use-module (ice-9 regex)
  43   #:use-module (ice-9 match)
  44   #:use-module (ice-9 format)
  45   #:use-module ((ice-9 iconv) #:prefix iconv:)
  46   #:use-module (system foreign)
  47   #:re-export (memoize)         ; for backwards compatibility
  48   #:export (strip-keyword-arguments
  49             default-keyword-arguments
  50             substitute-keyword-arguments
  51             ensure-keyword-arguments
  52
  53             current-source-directory
  54
  55             <location>
  56             location
  57             location?
  58             location-file
  59             location-line
  60             location-column
  61             source-properties->location
  62             location->source-properties
  63
  64             nix-system->gnu-triplet
  65             gnu-triplet->nix-system
  66             %current-system
  67             %current-target-system
  68             package-name->name+version
  69             target-mingw?
  70             version-compare
  71             version>?
  72             version>=?
  73             version-prefix
  74             version-major+minor
  75             guile-version>?
  76             string-replace-substring
  77             arguments-from-environment-variable
  78             file-extension
  79             file-sans-extension
  80             compressed-file?
  81             switch-symlinks
  82             call-with-temporary-output-file
  83             call-with-temporary-directory
  84             with-atomic-file-output
  85
  86             config-directory
  87             cache-directory
  88
  89             readlink*
  90             edit-expression
  91
  92             filtered-port
  93             compressed-port
  94             decompressed-port
  95             call-with-decompressed-port
  96             compressed-output-port
  97             call-with-compressed-output-port
  98             canonical-newline-port
  99
 100             <progress-reporter>
 101             progress-reporter
 102             make-progress-reporter
 103             progress-reporter?
 104             call-with-progress-reporter))
 105
 106 \f
 107 ;;;
 108 ;;; Filtering & pipes.
 109 ;;;
 110
 111 (define (filtered-port command input)
 112   "Return an input port where data drained from INPUT is filtered through
 113 COMMAND (a list).  In addition, return a list of PIDs that the caller must
 114 wait.  When INPUT is a file port, it must be unbuffered; otherwise, any
 115 buffered data is lost."
 116   (let loop ((input input)
 117              (pids  '()))
 118     (if (file-port? input)
 119         (match (pipe)
 120           ((in . out)
 121            (match (primitive-fork)
 122              (0
 123               (dynamic-wind
 124                 (const #f)
 125                 (lambda ()
 126                   (close-port in)
 127                   (close-port (current-input-port))
 128                   (dup2 (fileno input) 0)
 129                   (close-port (current-output-port))
 130                   (dup2 (fileno out) 1)
 131                   (catch 'system-error
 132                     (lambda ()
 133                       (apply execl (car command) command))
 134                     (lambda args
 135                       (format (current-error-port)
 136                               "filtered-port: failed to execute '~{~a ~}': ~a~%"
 137                               command (strerror (system-error-errno args))))))
 138                 (lambda ()
 139                   (primitive-_exit 1))))
 140              (child
 141               (close-port out)
 142               (values in (cons child pids))))))
 143
 144         ;; INPUT is not a file port, so fork just for the sake of tunneling it
 145         ;; through a file port.
 146         (match (pipe)
 147           ((in . out)
 148            (match (primitive-fork)
 149              (0
 150               (dynamic-wind
 151                 (const #t)
 152                 (lambda ()
 153                   (close-port in)
 154                   (dump-port input out))
 155                 (lambda ()
 156                   (false-if-exception (close out))
 157                   (primitive-_exit 0))))
 158              (child
 159               (close-port out)
 160               (loop in (cons child pids)))))))))
 161
 162 (define (decompressed-port compression input)
 163   "Return an input port where INPUT is decompressed according to COMPRESSION,
 164 a symbol such as 'xz."
 165   (match compression
 166     ((or #f 'none) (values input '()))
 167     ('bzip2        (filtered-port `(,%bzip2 "-dc") input))
 168     ('xz           (filtered-port `(,%xz "-dc" "-T0") input))
 169     ('gzip         (filtered-port `(,%gzip "-dc") input))
 170     (else          (error "unsupported compression scheme" compression))))
 171
 172 (define (compressed-port compression input)
 173   "Return an input port where INPUT is decompressed according to COMPRESSION,
 174 a symbol such as 'xz."
 175   (match compression
 176     ((or #f 'none) (values input '()))
 177     ('bzip2        (filtered-port `(,%bzip2 "-c") input))
 178     ('xz           (filtered-port `(,%xz "-c" "-T0") input))
 179     ('gzip         (filtered-port `(,%gzip "-c") input))
 180     (else          (error "unsupported compression scheme" compression))))
 181
 182 (define (call-with-decompressed-port compression port proc)
 183   "Call PROC with a wrapper around PORT, a file port, that decompresses data
 184 read from PORT according to COMPRESSION, a symbol such as 'xz."
 185   (let-values (((decompressed pids)
 186                 (decompressed-port compression port)))
 187     (dynamic-wind
 188       (const #f)
 189       (lambda ()
 190         (proc decompressed))
 191       (lambda ()
 192         (close-port decompressed)
 193         (unless (every (compose zero? cdr waitpid) pids)
 194           (error "decompressed-port failure" pids))))))
 195
 196 (define (filtered-output-port command output)
 197   "Return an output port.  Data written to that port is filtered through
 198 COMMAND and written to OUTPUT, an output file port.  In addition, return a
 199 list of PIDs to wait for.  OUTPUT must be unbuffered; otherwise, any buffered
 200 data is lost."
 201   (match (pipe)
 202     ((in . out)
 203      (match (primitive-fork)
 204        (0
 205         (dynamic-wind
 206           (const #f)
 207           (lambda ()
 208             (close-port out)
 209             (close-port (current-input-port))
 210             (dup2 (fileno in) 0)
 211             (close-port (current-output-port))
 212             (dup2 (fileno output) 1)
 213             (catch 'system-error
 214               (lambda ()
 215                 (apply execl (car command) command))
 216               (lambda args
 217                 (format (current-error-port)
 218                         "filtered-output-port: failed to execute '~{~a ~}': ~a~%"
 219                         command (strerror (system-error-errno args))))))
 220           (lambda ()
 221             (primitive-_exit 1))))
 222        (child
 223         (close-port in)
 224         (values out (list child)))))))
 225
 226 (define* (compressed-output-port compression output
 227                                  #:key (options '()))
 228   "Return an output port whose input is compressed according to COMPRESSION,
 229 a symbol such as 'xz, and then written to OUTPUT.  In addition return a list
 230 of PIDs to wait for.  OPTIONS is a list of strings passed to the compression
 231 program--e.g., '(\"--fast\")."
 232   (match compression
 233     ((or #f 'none) (values output '()))
 234     ('bzip2        (filtered-output-port `(,%bzip2 "-c" ,@options) output))
 235     ('xz           (filtered-output-port `(,%xz "-c" "-T0" ,@options) output))
 236     ('gzip         (filtered-output-port `(,%gzip "-c" ,@options) output))
 237     (else          (error "unsupported compression scheme" compression))))
 238
 239 (define* (call-with-compressed-output-port compression port proc
 240                                            #:key (options '()))
 241   "Call PROC with a wrapper around PORT, a file port, that compresses data
 242 that goes to PORT according to COMPRESSION, a symbol such as 'xz.  OPTIONS is
 243 a list of command-line arguments passed to the compression program."
 244   (let-values (((compressed pids)
 245                 (compressed-output-port compression port
 246                                         #:options options)))
 247     (dynamic-wind
 248       (const #f)
 249       (lambda ()
 250         (proc compressed))
 251       (lambda ()
 252         (close-port compressed)
 253         (unless (every (compose zero? cdr waitpid) pids)
 254           (error "compressed-output-port failure" pids))))))
 255
 256 (define* (edit-expression source-properties proc #:key (encoding "UTF-8"))
 257   "Edit the expression specified by SOURCE-PROPERTIES using PROC, which should
 258 be a procedure that takes the original expression in string and returns a new
 259 one.  ENCODING will be used to interpret all port I/O, it default to UTF-8.
 260 This procedure returns #t on success."
 261   (with-fluids ((%default-port-encoding encoding))
 262     (let* ((file   (assq-ref source-properties 'filename))
 263            (line   (assq-ref source-properties 'line))
 264            (column (assq-ref source-properties 'column))
 265            (in     (open-input-file file))
 266            ;; The start byte position of the expression.
 267            (start  (begin (while (not (and (= line (port-line in))
 268                                            (= column (port-column in))))
 269                             (when (eof-object? (read-char in))
 270                               (error (format #f "~a: end of file~%" in))))
 271                           (ftell in)))
 272            ;; The end byte position of the expression.
 273            (end    (begin (read in) (ftell in))))
 274       (seek in 0 SEEK_SET) ; read from the beginning of the file.
 275       (let* ((pre-bv  (get-bytevector-n in start))
 276              ;; The expression in string form.
 277              (str     (iconv:bytevector->string
 278                        (get-bytevector-n in (- end start))
 279                        (port-encoding in)))
 280              (post-bv (get-bytevector-all in))
 281              (str*    (proc str)))
 282         ;; Verify the edited expression is still a scheme expression.
 283         (call-with-input-string str* read)
 284         ;; Update the file with edited expression.
 285         (with-atomic-file-output file
 286           (lambda (out)
 287             (put-bytevector out pre-bv)
 288             (display str* out)
 289             ;; post-bv maybe the end-of-file object.
 290             (when (not (eof-object? post-bv))
 291               (put-bytevector out post-bv))
 292             #t))))))
 293
 294 \f
 295 ;;;
 296 ;;; Keyword arguments.
 297 ;;;
 298
 299 (define (strip-keyword-arguments keywords args)
 300   "Remove all of the keyword arguments listed in KEYWORDS from ARGS."
 301   (let loop ((args   args)
 302              (result '()))
 303     (match args
 304       (()
 305        (reverse result))
 306       (((? keyword? kw) arg . rest)
 307        (loop rest
 308              (if (memq kw keywords)
 309                  result
 310                  (cons* arg kw result))))
 311       ((head . tail)
 312        (loop tail (cons head result))))))
 313
 314 (define (default-keyword-arguments args defaults)
 315   "Return ARGS augmented with any keyword/value from DEFAULTS for
 316 keywords not already present in ARGS."
 317   (let loop ((defaults defaults)
 318              (args     args))
 319     (match defaults
 320       ((kw value rest ...)
 321        (loop rest
 322              (if (memq kw args)
 323                  args
 324                  (cons* kw value args))))
 325       (()
 326        args))))
 327
 328 (define-syntax collect-default-args
 329   (syntax-rules ()
 330     ((_)
 331      '())
 332     ((_ (_ _) rest ...)
 333      (collect-default-args rest ...))
 334     ((_ (kw _ dflt) rest ...)
 335      (cons* kw dflt (collect-default-args rest ...)))))
 336
 337 (define-syntax substitute-keyword-arguments
 338   (syntax-rules ()
 339     "Return a new list of arguments where the value for keyword arg KW is
 340 replaced by EXP.  EXP is evaluated in a context where VAR is bound to the
 341 previous value of the keyword argument, or DFLT if given."
 342     ((_ original-args ((kw var dflt ...) exp) ...)
 343      (let loop ((args (default-keyword-arguments
 344                         original-args
 345                         (collect-default-args (kw var dflt ...) ...)))
 346                 (before '()))
 347        (match args
 348          ((kw var rest (... ...))
 349           (loop rest (cons* exp kw before)))
 350          ...
 351          ((x rest (... ...))
 352           (loop rest (cons x before)))
 353          (()
 354           (reverse before)))))))
 355
 356 (define (delkw kw lst)
 357   "Remove KW and its associated value from LST, a keyword/value list such
 358 as '(#:foo 1 #:bar 2)."
 359   (let loop ((lst    lst)
 360              (result '()))
 361     (match lst
 362       (()
 363        (reverse result))
 364       ((kw? value rest ...)
 365        (if (eq? kw? kw)
 366            (append (reverse result) rest)
 367            (loop rest (cons* value kw? result)))))))
 368
 369 (define (ensure-keyword-arguments args kw/values)
 370   "Force the keywords arguments KW/VALUES in the keyword argument list ARGS.
 371 For instance:
 372
 373   (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
 374   => (#:foo 2)
 375
 376   (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
 377   => (#:foo 2 #:bar 3)
 378
 379   (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))
 380   => (#:foo 42 #:bar 3)
 381 "
 382   (let loop ((args      args)
 383              (kw/values kw/values)
 384              (result    '()))
 385     (match args
 386       (()
 387        (append (reverse result) kw/values))
 388       ((kw value rest ...)
 389        (match (memq kw kw/values)
 390          ((_ value . _)
 391           (loop rest (delkw kw kw/values) (cons* value kw result)))
 392          (#f
 393           (loop rest kw/values (cons* value kw result))))))))
 394
 395 \f
 396 ;;;
 397 ;;; System strings.
 398 ;;;
 399
 400 (define* (nix-system->gnu-triplet
 401           #:optional (system (%current-system)) (vendor "unknown"))
 402   "Return a guess of the GNU triplet corresponding to Nix system
 403 identifier SYSTEM."
 404   (match system
 405     ("armhf-linux"
 406      (string-append "arm-" vendor "-linux-gnueabihf"))
 407     (_
 408      (let* ((dash (string-index system #\-))
 409             (arch (substring system 0 dash))
 410             (os   (substring system (+ 1 dash))))
 411        (string-append arch
 412                       "-" vendor "-"
 413                       (if (string=? os "linux")
 414                           "linux-gnu"
 415                           os))))))
 416
 417 (define (gnu-triplet->nix-system triplet)
 418   "Return the Nix system type corresponding to TRIPLET, a GNU triplet as
 419 returned by `config.guess'."
 420   (let ((triplet (cond ((string-match "^i[345]86-(.*)$" triplet)
 421                         =>
 422                         (lambda (m)
 423                           (string-append "i686-" (match:substring m 1))))
 424                        (else triplet))))
 425     (cond ((string-match "^arm[^-]*-([^-]+-)?linux-gnueabihf" triplet)
 426            "armhf-linux")
 427           ((string-match "^([^-]+)-([^-]+-)?linux-gnu.*" triplet)
 428            =>
 429            (lambda (m)
 430              ;; Nix omits `-gnu' for GNU/Linux.
 431              (string-append (match:substring m 1) "-linux")))
 432           ((string-match "^([^-]+)-([^-]+-)?([[:alpha:]]+)([0-9]+\\.?)*$" triplet)
 433            =>
 434            (lambda (m)
 435              ;; Nix strip the version number from names such as `gnu0.3',
 436              ;; `darwin10.2.0', etc., and always strips the vendor part.
 437              (string-append (match:substring m 1) "-"
 438                             (match:substring m 3))))
 439           (else triplet))))
 440
 441 (define %current-system
 442   ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
 443   ;; By default, this is equal to (gnu-triplet->nix-system %host-type).
 444   (make-parameter %system))
 445
 446 (define %current-target-system
 447   ;; Either #f or a GNU triplet representing the target system we are
 448   ;; cross-building to.
 449   (make-parameter #f))
 450
 451 (define* (package-name->name+version spec
 452                                      #:optional (delimiter #\@))
 453   "Given SPEC, a package name like \"foo@0.9.1b\", return two values: \"foo\"
 454 and \"0.9.1b\".  When the version part is unavailable, SPEC and #f are
 455 returned.  Both parts must not contain any '@'.  Optionally, DELIMITER can be
 456 a character other than '@'."
 457   (match (string-rindex spec delimiter)
 458     (#f  (values spec #f))
 459     (idx (values (substring spec 0 idx)
 460                  (substring spec (1+ idx))))))
 461
 462 (define* (target-mingw? #:optional (target (%current-target-system)))
 463   (and target
 464        (string-suffix? "-mingw32" target)))
 465
 466 (define version-compare
 467   (let ((strverscmp
 468          (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
 469                         (error "could not find `strverscmp' (from GNU libc)"))))
 470            (pointer->procedure int sym (list '* '*)))))
 471     (lambda (a b)
 472       "Return '> when A denotes a newer version than B,
 473 '< when A denotes a older version than B,
 474 or '= when they denote equal versions."
 475       (let ((result (strverscmp (string->pointer a) (string->pointer b))))
 476         (cond ((positive? result) '>)
 477               ((negative? result) '<)
 478               (else '=))))))
 479
 480 (define (version-prefix version-string num-parts)
 481   "Truncate version-string to the first num-parts components of the version.
 482 For example, (version-prefix \"2.1.47.4.23\" 3) returns \"2.1.47\""
 483   (string-join (take (string-split version-string #\.) num-parts) "."))
 484
 485
 486 (define (version-major+minor version-string)
 487   "Return \"<major>.<minor>\", where major and minor are the major and
 488 minor version numbers from version-string."
 489   (version-prefix version-string 2))
 490
 491 (define (version>? a b)
 492   "Return #t when A denotes a version strictly newer than B."
 493   (eq? '> (version-compare a b)))
 494
 495 (define (version>=? a b)
 496   "Return #t when A denotes a version newer or equal to B."
 497   (case (version-compare a b)
 498     ((> =) #t)
 499     (else #f)))
 500
 501 (define (guile-version>? str)
 502   "Return #t if the running Guile version is greater than STR."
 503   ;; Note: Using (version>? (version) "2.0.5") or similar doesn't work,
 504   ;; because the result of (version) can have a prefix, like "2.0.5-deb1".
 505   (version>? (string-append (major-version) "."
 506                             (minor-version) "."
 507                             (micro-version))
 508              str))
 509
 510 (define (file-extension file)
 511   "Return the extension of FILE or #f if there is none."
 512   (let ((dot (string-rindex file #\.)))
 513     (and dot (substring file (+ 1 dot) (string-length file)))))
 514
 515 (define (file-sans-extension file)
 516   "Return the substring of FILE without its extension, if any."
 517   (let ((dot (string-rindex file #\.)))
 518     (if dot
 519         (substring file 0 dot)
 520         file)))
 521
 522 (define (compressed-file? file)
 523   "Return true if FILE denotes a compressed file."
 524   (->bool (member (file-extension file)
 525                   '("gz" "bz2" "xz" "lz" "lzma" "tgz" "tbz2" "zip"))))
 526
 527 (define (switch-symlinks link target)
 528   "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
 529 both when LINK already exists and when it does not."
 530   (let ((pivot (string-append link ".new")))
 531     (symlink target pivot)
 532     (rename-file pivot link)))
 533
 534 (define* (string-replace-substring str substr replacement
 535                                    #:optional
 536                                    (start 0)
 537                                    (end (string-length str)))
 538   "Replace all occurrences of SUBSTR in the START--END range of STR by
 539 REPLACEMENT."
 540   (match (string-length substr)
 541     (0
 542      (error "string-replace-substring: empty substring"))
 543     (substr-length
 544      (let loop ((start  start)
 545                 (pieces (list (substring str 0 start))))
 546        (match (string-contains str substr start end)
 547          (#f
 548           (string-concatenate-reverse
 549            (cons (substring str start) pieces)))
 550          (index
 551           (loop (+ index substr-length)
 552                 (cons* replacement
 553                        (substring str start index)
 554                        pieces))))))))
 555
 556 (define (arguments-from-environment-variable variable)
 557   "Retrieve value of environment variable denoted by string VARIABLE in the
 558 form of a list of strings (`char-set:graphic' tokens) suitable for consumption
 559 by `args-fold', if VARIABLE is defined, otherwise return an empty list."
 560   (let ((env (getenv variable)))
 561     (if env
 562         (string-tokenize env char-set:graphic)
 563         '())))
 564
 565 (define (call-with-temporary-output-file proc)
 566   "Call PROC with a name of a temporary file and open output port to that
 567 file; close the file and delete it when leaving the dynamic extent of this
 568 call."
 569   (let* ((directory (or (getenv "TMPDIR") "/tmp"))
 570          (template  (string-append directory "/guix-file.XXXXXX"))
 571          (out       (mkstemp! template)))
 572     (dynamic-wind
 573       (lambda ()
 574         #t)
 575       (lambda ()
 576         (proc template out))
 577       (lambda ()
 578         (false-if-exception (close out))
 579         (false-if-exception (delete-file template))))))
 580
 581 (define (call-with-temporary-directory proc)
 582   "Call PROC with a name of a temporary directory; close the directory and
 583 delete it when leaving the dynamic extent of this call."
 584   (let* ((directory (or (getenv "TMPDIR") "/tmp"))
 585          (template  (string-append directory "/guix-directory.XXXXXX"))
 586          (tmp-dir   (mkdtemp! template)))
 587     (dynamic-wind
 588       (const #t)
 589       (lambda ()
 590         (proc tmp-dir))
 591       (lambda ()
 592         (false-if-exception (rmdir tmp-dir))))))
 593
 594 (define (with-atomic-file-output file proc)
 595   "Call PROC with an output port for the file that is going to replace FILE.
 596 Upon success, FILE is atomically replaced by what has been written to the
 597 output port, and PROC's result is returned."
 598   (let* ((template (string-append file ".XXXXXX"))
 599          (out      (mkstemp! template)))
 600     (with-throw-handler #t
 601       (lambda ()
 602         (let ((result (proc out)))
 603           (fdatasync out)
 604           (close-port out)
 605           (rename-file template file)
 606           result))
 607       (lambda (key . args)
 608         (false-if-exception (delete-file template))
 609         (close-port out)))))
 610
 611 (define* (xdg-directory variable suffix #:key (ensure? #t))
 612   "Return the name of the XDG directory that matches VARIABLE and SUFFIX,
 613 after making sure that it exists if ENSURE? is true.  VARIABLE is an
 614 environment variable name like \"XDG_CONFIG_HOME\"; SUFFIX is a suffix like
 615 \"/.config\".  Honor the XDG specs,
 616 <http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>."
 617   (let ((dir (and=> (or (getenv variable)
 618                         (and=> (or (getenv "HOME")
 619                                    (passwd:dir (getpwuid (getuid))))
 620                                (cut string-append <> suffix)))
 621                     (cut string-append <> "/guix"))))
 622     (when ensure?
 623       (mkdir-p dir))
 624     dir))
 625
 626 (define config-directory
 627   (cut xdg-directory "XDG_CONFIG_HOME" "/.config" <...>))
 628
 629 (define cache-directory
 630   (cut xdg-directory "XDG_CACHE_HOME" "/.cache" <...>))
 631
 632 (define (readlink* file)
 633   "Call 'readlink' until the result is not a symlink."
 634   (define %max-symlink-depth 50)
 635
 636   (let loop ((file  file)
 637              (depth 0))
 638     (define (absolute target)
 639       (if (absolute-file-name? target)
 640           target
 641           (string-append (dirname file) "/" target)))
 642
 643     (if (>= depth %max-symlink-depth)
 644         file
 645         (call-with-values
 646             (lambda ()
 647               (catch 'system-error
 648                 (lambda ()
 649                   (values #t (readlink file)))
 650                 (lambda args
 651                   (let ((errno (system-error-errno args)))
 652                     (if (or (= errno EINVAL))
 653                         (values #f file)
 654                         (apply throw args))))))
 655           (lambda (success? target)
 656             (if success?
 657                 (loop (absolute target) (+ depth 1))
 658                 file))))))
 659
 660 (define (canonical-newline-port port)
 661   "Return an input port that wraps PORT such that all newlines consist
 662   of a single carriage return."
 663   (define (get-position)
 664     (if (port-has-port-position? port) (port-position port) #f))
 665   (define (set-position! position)
 666     (if (port-has-set-port-position!? port)
 667         (set-port-position! position port)
 668         #f))
 669   (define (close) (close-port port))
 670   (define (read! bv start n)
 671     (let loop ((count 0)
 672                (byte (get-u8 port)))
 673       (cond ((eof-object? byte) count)
 674             ((= count (- n 1))
 675              (bytevector-u8-set! bv (+ start count) byte)
 676              n)
 677             ;; XXX: consume all LFs even if not followed by CR.
 678             ((eqv? byte (char->integer #\return)) (loop count (get-u8 port)))
 679             (else
 680              (bytevector-u8-set! bv (+ start count) byte)
 681              (loop (+ count 1) (get-u8 port))))))
 682   (make-custom-binary-input-port "canonical-newline-port"
 683                                  read!
 684                                  get-position
 685                                  set-position!
 686                                  close))
 687 \f
 688 ;;;
 689 ;;; Source location.
 690 ;;;
 691
 692 (define (absolute-dirname file)
 693   "Return the absolute name of the directory containing FILE, or #f upon
 694 failure."
 695   (match (search-path %load-path file)
 696     (#f #f)
 697     ((? string? file)
 698      ;; If there are relative names in %LOAD-PATH, FILE can be relative and
 699      ;; needs to be canonicalized.
 700      (if (string-prefix? "/" file)
 701          (dirname file)
 702          (canonicalize-path (dirname file))))))
 703
 704 (define-syntax current-source-directory
 705   (lambda (s)
 706     "Return the absolute name of the current directory, or #f if it could not
 707 be determined."
 708     (syntax-case s ()
 709       ((_)
 710        (match (assq 'filename (or (syntax-source s) '()))
 711          (('filename . (? string? file-name))
 712           ;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME
 713           ;; can be relative.  In that case, we try to find out at run time
 714           ;; the absolute file name by looking at %LOAD-PATH; doing this at
 715           ;; run time rather than expansion time is necessary to allow files
 716           ;; to be moved on the file system.
 717           (cond ((not file-name)
 718                  #f)                ;raising an error would upset Geiser users
 719                 ((string-prefix? "/" file-name)
 720                  (dirname file-name))
 721                 (else
 722                  #`(absolute-dirname #,file-name))))
 723          (#f
 724           #f))))))
 725
 726 ;; A source location.
 727 (define-record-type <location>
 728   (make-location file line column)
 729   location?
 730   (file          location-file)                   ; file name
 731   (line          location-line)                   ; 1-indexed line
 732   (column        location-column))                ; 0-indexed column
 733
 734 (define location
 735   (mlambda (file line column)
 736     "Return the <location> object for the given FILE, LINE, and COLUMN."
 737     (and line column file
 738          (make-location file line column))))
 739
 740 (define (source-properties->location loc)
 741   "Return a location object based on the info in LOC, an alist as returned
 742 by Guile's `source-properties', `frame-source', `current-source-location',
 743 etc."
 744   (let ((file (assq-ref loc 'filename))
 745         (line (assq-ref loc 'line))
 746         (col  (assq-ref loc 'column)))
 747     ;; In accordance with the GCS, start line and column numbers at 1.  Note
 748     ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
 749     (location file (and line (+ line 1)) col)))
 750
 751 (define (location->source-properties loc)
 752   "Return the source property association list based on the info in LOC,
 753 a location object."
 754   `((line     . ,(and=> (location-line loc) 1-))
 755     (column   . ,(location-column loc))
 756     (filename . ,(location-file loc))))
 757
 758 \f
 759 ;;;
 760 ;;; Progress reporter.
 761 ;;;
 762
 763 (define-record-type* <progress-reporter>
 764   progress-reporter make-progress-reporter progress-reporter?
 765   (start   progress-reporter-start)     ; thunk
 766   (report  progress-reporter-report)    ; procedure
 767   (stop    progress-reporter-stop))     ; thunk
 768
 769 (define (call-with-progress-reporter reporter proc)
 770   "Start REPORTER for progress reporting, and call @code{(@var{proc} report)}
 771 with the resulting report procedure.  When @var{proc} returns, the REPORTER is
 772 stopped."
 773   (match reporter
 774     (($ <progress-reporter> start report stop)
 775      (dynamic-wind start (lambda () (proc report)) stop))))
 776
 777 ;;; Local Variables:
 778 ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
 779 ;;; End: