;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 (my-wrap)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-60)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 format)
  #:use-module (ice-9 threads)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (guix build utils)
  #:export ( wrap-script**))


;;;
;;; Guile 2.0 compatibility later.
;;;

;; The bootstrap Guile is Guile 2.0, so provide a compatibility layer.

(define wrap-script**
  (let ((interpreter-regex
         (make-regexp
          (string-append "^#! ?(/[^ ]+/bin/("
                         (string-join '("python[^ ]*"
                                        "Rscript"
                                        "perl"
                                        "ruby"
                                        "bash"
                                        "sh") "|")
                         "))( ?.*)")))
        (coding-line-regex
         (make-regexp
          ".*#.*coding[=:][[:space:]]*([-a-zA-Z_0-9.]+)")))
    (lambda* (prog #:key (guile (which "guile")) #:rest vars)
      "Wrap the script PROG such that VARS are set first.  The format of VARS
is the same as in the WRAP-PROGRAM procedure.  This procedure differs from
WRAP-PROGRAM in that it does not create a separate shell script.  Instead,
PROG is modified directly by prepending a Guile script, which is interpreted
as a comment in the script's language.

Special encoding comments as supported by Python are recreated on the second
line.

Note that this procedure can only be used once per file as Guile scripts are
not supported."
      (define update-env
        (match-lambda
          ((var sep '= rest)
           `(setenv ,var ,(string-join rest sep)))
          ((var sep 'prefix rest)
           `(let ((current (getenv ,var)))
              (setenv ,var (if current
                               (string-append ,(string-join rest sep)
                                              ,sep current)
                               ,(string-join rest sep)))))
          ((var sep 'suffix rest)
           `(let ((current (getenv ,var)))
              (setenv ,var (if current
                               (string-append current ,sep
                                              ,(string-join rest sep))
                               ,(string-join rest sep)))))
          ((var '= rest)
           `(setenv ,var ,(string-join rest ":")))
          ((var 'prefix rest)
           `(let ((current (getenv ,var)))
              (setenv ,var (if current
                               (string-append ,(string-join rest ":")
                                              ":" current)
                               ,(string-join rest ":")))))
          ((var 'suffix rest)
           `(let ((current (getenv ,var)))
              (setenv ,var (if current
                               (string-append current ":"
                                              ,(string-join rest ":"))
                               ,(string-join rest ":")))))))
      (let-values (((interpreter args coding-line)
                    (call-with-ascii-input-file prog
                      (lambda (p)
                        (let ((first-match
                               (false-if-exception
                                (regexp-exec interpreter-regex (read-line p)))))
                          (values (and first-match (match:substring first-match 1))
                                  (and first-match (match:substring first-match 3))
                                  (false-if-exception
                                   (and=> (regexp-exec coding-line-regex (read-line p))
                                          (lambda (m) (match:substring m 0))))))))))
        (if interpreter
            (let* ((header (format #f "\
#!~a --no-auto-compile
#!#; ~a
#\\-~s
#\\-~s
"
                                   guile
                                   (or coding-line "Guix wrapper")
                                   (cons 'begin (map update-env
                                                     (match vars
                                                       ((#:guile _ . vars) vars)
                                                       (_ vars))))
                                   `(let ((cl (command-line)))
                                      (apply execl ,interpreter
                                             (car cl)
                                             (cons (car cl)
                                                   (append
                                                    ',(string-tokenize args)
                                                    cl))))))
                   (template (string-append prog ".XXXXXX"))
                   (out      (mkstemp! template))
                   (st       (stat prog))
                   (mode     (stat:mode st)))
              (with-throw-handler #t
                (lambda ()
                  (call-with-ascii-input-file prog
                    (lambda (p)
                      (format out header)
                      (dump-port p out)
                      (close out)
                      (chmod template mode)
                      (rename-file template prog)
                      (set-file-time prog st))))
                (lambda (key . args)
                  (format (current-error-port)
                          "wrap-script: ~a: error: ~a ~s~%"
                          prog key args)
                  (false-if-exception (delete-file template))
                  (raise (condition
                          (&wrap-error (program prog)
                                       (type key))))
                  #f)))
            (raise (condition
                    (&wrap-error (program prog)
                                 (type 'no-interpreter-found)))))))))