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