#!/usr/bin/guile \
-e "(scripts edit-script-header)" -s
!#
;;; edit-script-header --- Munge the first few lines of a Scheme script

;;	Copyright (C) 2003,2004 Free Software Foundation, Inc.
;;
;; This program 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 2, or
;; (at your option) any later version.
;;
;; This program 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 this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: edit-script-header [OPTIONS] FILE ...
;;
;; Grok and modify each FILE's header (hash-bang invocation sequence)
;; according to OPTIONS:
;;
;;  -o, --output OTHER  -- write to file OTHER instead of modifying FILE
;;  -g, --guile [GUILE] -- use GUILE as the interpreter
;;  -G, --GUILE-guile   -- use ${GUILE-guile} construct, implies -e
;;  -n, --no-act        -- do not do the edit, display parse results only
;;  -v, --verbose       -- display progress reports
;;  -b, --backup EXT    -- rename output file to fooEXT before writing
;;  -s, --style STYLE   -- convert output to use header STYLE (see below)
;;  -i, --installed     -- use installed guile as the interpreter
;;
;; By default, the name of the interpreter is constructed by combining
;; bindir (use "guile-tools guile-config info bindir" to see this value)
;; with the name "guile", for example: "/usr/local/bin/guile".  This name
;; is placed directly after the hash-bang "#!" on the first line followed
;; by a space and then the meta switch "\".  The second line has the rest
;; of the args, terminating with "-s" and a newline.  The third line has
;; a bang-hash "!#" only.
;;
;; Simple edits (like changing the guile interpreter from /usr/bin/guile
;; to /usr/local/bin/guile, for example) are no problem.  Converting
;; between styles is somewhat more tricky.  Here is a list of the styles
;; that are recognized and supported (for -s option):
;;
;; * old-style-sh-wrapper
;;
;;   This is primarily for executable modules, and looks something like:
;;
;;   #!/bin/sh
;;   main='(module-ref (resolve-module '\''MODULE-NAME) '\'main')'
;;   exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
;;   !#
;;
;;   We call it "old" because there are now better ways to invoke `main'
;;   (see `modern-sh-wrapper').  Converting to from and to this style
;;   requires accompanying changes to the script's invocation convention
;;   that `edit-script-header' does not handle.
;;
;; * modern-sh-wrapper
;;
;;   This style looks something like:
;;
;;   #!/bin/sh
;;   exec ${GUILE-guile} -e ENTRY-POINT -s $0 "$@"
;;   !#
;;
;;   The distinguishing characteristic is `exec' and `-s $0 "$@"'.  The
;;   `-e ENTRY-POINT' is optional.  This style is fully convertable to
;;   and from the `direct-with-meta-switch' style.
;;
;; * direct-with-meta-switch
;;
;;   This style looks something like:
;;
;;   #!/usr/local/bin/guile \
;;   -e ENTRY-POINT -s
;;   !#
;;
;;   The distinguishing characteristic is the guile interpreter named in
;;   the first line as well as the meta switch.  The `-e ENTRY-POINT' is
;;   optional.  This style is fully convertable to and from the
;;   `modern-sh-wrapper' style.
;;
;; * direct-with-minus-s
;;
;;   This style looks something like:
;;
;;   #!/usr/local/bin/guile -s
;;   !#
;;
;;   The distinguishing characteristic is the guile interpreter named
;;   in the first line as well as the `-s' switch.  This style can be
;;   converted to and from the other ones with some restrictions.

;;; Code:

(define-module (scripts edit-script-header)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:autoload (ice-9 rdelim) (read-line)
  #:autoload (scripts split-string-no-nulls) (split-string-no-nulls)
  #:autoload (srfi srfi-13) (string-join)
  #:autoload (scripts slurp) (slurp-file!)
  ;; not yet
  ;; #:export ()
  )

;; Implementation Note: This exercise clearly highlights the need for
;;                      lexing/parsing support in Guile, proper.
;;                      Connoisseurs of clean code, you have been warned!

;; support (todo: reimpl w/ proper lexer/parser)

(define bol-bang-hash-rx "^!#")

(define (init-regexps!)
  (set! bol-bang-hash-rx (make-regexp bol-bang-hash-rx)))

(define (coalesce-matching-quotes q tokens)
  (let loop ((head tokens))
    (or (null? head)
        (cond ((let ((hit (string-index (car head) q)))
                 (and hit (= 0 hit)))
               (let search ((h2 head) (acc '()))
                 (if (null? h2)
                     (error "unterminated quote")
                     (let* ((maybe (car h2))
                            (len (string-length maybe))
                            (hit (string-index maybe q 1)))
                       (if (and hit (= (1- len) hit))
                           (let ((new (string-join
                                       (reverse (cons maybe acc))
                                       " ")))
                             (set-car! head
                                       (substring new 1 (1- (string-length
                                                             new))))
                             (set-cdr! head (cdr h2)))
                           (search (cdr h2) (cons maybe acc)))))))
              (else (loop (cdr head)))))))

(define (tokenize-header file)          ; bletcherous beyond belief
  (and (string? bol-bang-hash-rx)
       (init-regexps!))
  (let* ((header-size 0)
         (t9 (let* ((p (open-input-file file))
                    (next (lambda () (read-line p 'concat))))
               (let loop ((line (next)) (acc '()) (count 9))
                 (set! header-size (+ header-size (string-length line)))
                 (if (or (= 0 count) (regexp-exec bol-bang-hash-rx line))
                     (reverse (cons line acc))
                     (loop (next)
                           (cons line acc)
                           (1- count))))))
         (tokens (split-string-no-nulls (apply string-append t9) " \t"))
         (parse-info (acons 'header-size header-size '()))
         (note! (lambda (key value)
                  ;;(pk 'note! key value)
                  (cond ((assq key parse-info)
                         => (lambda (pair)
                              (set-cdr! pair value)))
                        (else
                         (set! parse-info (acons key value parse-info)))))))
    ;; separate newlines
    (let loop ((head tokens))
      (or (null? head)
          (let ((cur (car head)))
            (cond ((string-index cur #\newline)
                   => (lambda (hit)
                        (set-car! head (substring cur 0 hit))
                        (set-cdr! head (append `("\n" ,(substring cur (1+ hit)))
                                               (cdr head)))
                        (loop (cddr head))))
                  (else (loop (cdr head)))))))
    ;; reduce "main=...^J" to just the module name
    (let loop ((head tokens))
      (or (null? head)
          (if (string=? "main='(module-ref" (car head))
              (let* ((new-head (cddr head))
                     (guess (car new-head))
                     ;; if we assume guess looks like:
                     ;;    '\''(SOME MODULE NAME))
                     ;; then `name' will be:
                     ;;    (SOME MODULE NAME)
                     (name (substring guess 4 (1- (string-length guess)))))
                (set-car! head name)
                (set-cdr! head (cddr new-head))
                (loop (cdr head)))
              (loop (cdr head)))))
    ;; coalesce quote pairs spread out over multiple tokens (discard quote)
    (coalesce-matching-quotes #\" tokens)
    (coalesce-matching-quotes #\' tokens)
    ;; replace various things
    (let loop ((head tokens))
      (or (null? head)
          (let ((cur (car head)))
            (cond ((string=? "\n" cur)
                   (set-car! head 'newline))
                  ((string=? "${GUILE-guile}" cur)
                   (set-car! head 'G-g))
                  ((string=? "#!" cur)
                   (set-car! head 'hash-bang))
                  ((string=? "!#" cur)
                   (set-car! head 'bang-hash))
                  ((and (< 3 (string-length cur))
                        (string=? "#!/" (substring cur 0 3)))
                   (set-car! head 'hash-bang)
                   (set-cdr! head (cons (substring cur 2) (cdr head))))
                  ((string=? "$0" cur)
                   (set-car! head 'dollar-zero))
                  ((string=? "\"$@\"" cur)
                   (set-car! head 'quoted-dollar-at))
                  ((string=? "$@" cur)
                   (set-car! head 'dollar-at))
                  ((string=? "-e" cur)
                   (set-car! head 'minus-e))
                  ((string=? "-s" cur)
                   (set-car! head 'minus-s))
                  ((string=? "exec" cur)
                   (set-car! head 'exec))
                  ((string=? "guile" cur)
                   (set-car! head 'guile)))
            (loop (cdr head)))))
    ;; zonk comments (ignoring the hash-bang)
    (let loop ((head tokens))
      (or (null? (cdr head))
          (let ((look-ahead (cdr head)))
            (if (let ((n1 (string-index (car look-ahead) #\#))
                      (n2 (string-index (car look-ahead) #\!)))
                  (and n1 (or (not n2) (not (= (1+ n2) n1)))))
                (let search ((h2 (cdr look-ahead)))
                  (cond ((eq? 'newline (car h2))
                         (set-cdr! head h2)
                         (loop (cdr head)))
                        (else (search (cdr h2)))))
                (loop (cdr head))))))
    ;; minimize line count
    (let loop ((head (let find-newline ((all (reverse tokens)))
                       (if (eq? (car all) 'newline)
                           all
                           (find-newline (cdr all)))))
               (acc '())
               (count 0))
      (cond ((null? head)
             (note! 'line-count count)
             (set! tokens acc))
            ((eq? 'newline (car head))
             (if (and (not (null? acc)) (eq? 'newline (car acc)))
                 (loop (cdr head) acc count)
                 (loop (cdr head) (cons (car head) acc) (1+ count))))
            (else (loop (cdr head) (cons (car head) acc) count))))
    ;; note lines in order (discard newline)
    (let loop ((head tokens) (acc '()) (lines '()))
      (if (null? head)
          (note! 'lines (reverse lines))
          (let ((cur (car head)))
            (if (eq? 'newline cur)
                (loop (cdr head) '() (cons (reverse acc) lines))
                (loop (cdr head) (cons cur acc) lines)))))


    ;; retval
    (note! 'tokens tokens)
    parse-info))

(define (attributes&idiom raw)          ; bombastic begotten bilge
  (let* ((attributes '())
         (attr! (lambda (a)
                  (set! attributes (cons a attributes))))
         (attr? (lambda (a)
                  (memq a attributes)))
         (lines (assq-ref raw 'lines))
         (tokens (assq-ref raw 'tokens))
         (idiom! (lambda (name . extra)
                   (acons 'idiom name
                          (acons 'attributes attributes
                                 (append extra raw)))))
         (first-line (car lines))
         (second-line (if (< 1 (length lines)) (cadr lines) '()))
         (third-line (if (< 2 (length lines)) (caddr lines) '()))
         (guile #f) (module #f) (proc #f))
    ;; set some attributes
    (or (equal? '(bang-hash) (car (reverse lines)))
        (attr! 'missing-bang-hash))
    (or (equal? 'hash-bang (car first-line))
        (attr! 'missing-hash-bang))
    (and (< 1 (length first-line))
         (let ((shell (cadr first-line)))
           (and (or (string=? "/bin/sh" shell)
                    (string=? "/bin/bash" shell))
                (attr! 'sh-wrapper))
           (and (let ((s (cadr first-line)))
                  (string=? "guile" (substring s (- (string-length s) 5))))
                (attr! 'some-guile))
           (and (= 3 (length first-line))
                (attr! 'first-line-arg))))
    (and (= 1 (length second-line))
         (let ((s (car second-line)))
           (and (string? s)
                (not (= 0 (string-length s)))
                (char=? #\( (string-ref s 0))
                (char=? #\) (string-ref s (1- (string-length s))))
                (attr! 'second-line-module-name)
                (set! module (car second-line)))))
    (and (< 1 (length second-line))
         (eq? 'exec (car second-line))
         (attr! 'second-line-exec)
         (set! guile (cadr second-line)))
    (and (< 1 (length third-line))
         (eq? 'exec (car third-line))
         (attr! 'third-line-exec)
         (set! guile (cadr third-line)))
    (cond ((memq 'minus-e tokens)
           => (lambda (ls)
                (attr! 'entry-point)
                (and (string? (cadr ls))
                     (let* ((ep (cadr ls))
                            (split (1+ (or (string-index ep #\)) -1))))
                       (and (char=? #\( (string-ref ep 0))
                            (attr! 'entry-point-is-module)
                            (set! module (substring ep 0 split)))
                       (if (char=? #\) (string-ref ep (1- (string-length ep))))
                           (attr! 'entry-point-proc-omitted)
                           (let loop ((s (substring ep split)))
                             (if (char=? #\space (string-ref s 0))
                                 (loop (substring s 1))
                                 (set! proc s)))))))))
    ;; determine idiom (and set more attributes)
    (cond ((or (attr? 'missing-bang-hash)                       ;;; rv
               (attr? 'missing-hash-bang))
           (idiom! 'broken))
          ((and (attr? 'sh-wrapper)
                (attr? 'second-line-module-name)
                (attr? 'third-line-exec)
                (equal? '("-l" dollar-zero
                          "-c" "(apply $main (cdr (command-line)))"
                          quoted-dollar-at)
                        (cddr third-line)))
           (attr! 'simple)
           (idiom! 'old-style-sh-wrapper
                   `(guile . ,guile)
                   `(module . ,module)))
          ((and (attr? 'sh-wrapper)
                (attr? 'second-line-exec))
           (let* ((rest (cddr second-line))
                  (len (length rest))
                  (ep? (attr? 'entry-point)))
             (and (= (if ep? 5 3) len)
                  (let ((r2 ((if ep? cddr identity) rest)))
                    (or (equal? '(minus-s dollar-zero dollar-at) r2)
                        (equal? '(minus-s dollar-zero quoted-dollar-at) r2)))
                  (attr! 'simple)))
           (idiom! 'modern-sh-wrapper
                   `(guile . ,guile)
                   `(module . ,module)
                   `(proc . ,proc)))
          ((and (attr? 'some-guile)
                (attr? 'first-line-arg)
                (string=? "\\" (caddr first-line)))
           (and (if (attr? 'entry-point)
                    (and (= 3 (length second-line))
                         (eq? 'minus-s (caddr second-line)))
                    (eq? '(minus-s) second-line))
                (attr! 'simple))
           (idiom! 'direct-with-meta-switch
                   `(guile . ,(cadr first-line))
                   `(module . ,module)
                   `(proc . ,proc)))
          ((and (attr? 'some-guile)
                (attr? 'first-line-arg)
                (eq? 'minus-s (caddr first-line)))
           (attr! 'simple)
           (idiom! 'direct-with-minus-s
                   `(guile . ,(cadr first-line))))
          (else
           (idiom! 'unrecognized)))))

;; dispatch

(define (parse-script-header file)
  (attributes&idiom (tokenize-header file)))

(define (edit-script-header options file)
  (let* ((info (parse-script-header file))
         (opt  (lambda (o) (assq-ref options o)))
         (look (lambda (key) (assq-ref info key)))
         (attr (lambda (a) (memq a (look 'attributes))))
         (set-guile! (lambda (guile)
                       (let ((cell (assq 'guile info)))
                         (set-cdr! cell guile)))))

    (define (commit! fmt . args)
      (let* ((new (apply simple-format #f fmt args))
             (ofile (or (opt 'output) file))
             (ext (opt 'backup))
             (new-len (string-length new))
             (orig-size (stat:size (stat file)))
             (bye (look 'header-size))
             (buf (make-string (+ new-len (- orig-size bye)))))
        (substring-move! new 0 new-len buf 0)
        (slurp-file! buf file bye (- orig-size bye) new-len)
        (and ext
             (file-exists? ofile)
             (rename-file ofile (simple-format #f "~A~A" ofile ext))
             (opt 'verbose)
             (simple-format #t "wrote backup file: ~A~A\n" ofile ext))
        (let ((p (open-output-file ofile)))
          (display buf p)
          (close-port p))
        (and (opt 'verbose)
             (simple-format #t "wrote ~A output file: ~A\n"
                            (or (opt 'style) (look 'idiom)) ofile))))

    (define (check-guile-for-sh-wrapper-variants!)
      (cond ((and (opt 'GUILE-guile) (opt 'installed))
             (set-guile! (simple-format #f "${GUILE-~A/guile}"
                                        (assq-ref %guile-build-info 'bindir))))
            ((and (opt 'GUILE-guile) (opt 'guile))
             => (lambda (guile)
                  (set-guile! (simple-format #f "${GUILE-~A}" guile))))
            ((opt 'guile)
             => set-guile!)
            ((or (opt 'GUILE-guile) (eq? 'G-g (look 'guile)))
             (set-guile! "${GUILE-guile}"))
            ((not (look 'guile))
             (set-guile! (string-append
                          (assq-ref %guile-build-info 'bindir)
                          "/guile")))))

    (define (check-guile-for-direct-variants!)
      (cond
       ((opt 'guile)
        => set-guile!)
       ((opt 'installed)
        (set-guile! (string-append
                     (assq-ref %guile-build-info 'bindir)
                     "/guile")))
       ((or (eq? 'G-g (look 'guile))
            (not (let ((s (look 'guile)))
                   (and s (string? s)
                        (let ((len (string-length s)))
                          (and (< 9 len)
                               (string=? "${GUILE-" (substring s 0 8))
                               (char=? #\} (string-ref s (1- len)))
                               (set-cdr! (assq 'guile info)
                                         (substring s 8 (1- len)))))))))
        (error "cannot infer interpreter, use -i or -g to specify"))))

    (define (formatted-entry-point-maybe)
      (cond ((and (look 'module) (look 'proc))
             (simple-format #f "-e \"~A ~A\" " (look 'module) (look 'proc)))
            ((look 'module)
             => (lambda (module)
                  (simple-format #f "-e ~S " module)))
            ((look 'proc)
             => (lambda (proc)
                  (simple-format #f "-e ~S " proc)))
            ((attr 'entry-point)
             (simple-format #f "-e ~S " (cadr (memq 'minus-e (look 'tokens)))))
            (else
             "")))

    (or (attr 'simple)
        (error "lame parser cannot handle complexity (sorry)"))
    (let* ((idiom (look 'idiom))
           (style (or (opt 'style) idiom)))
      (and (memq idiom '(broken unrecognized))
           (error (simple-format #f "cannot handle ~A (it is unfortunately ~A somehow)"
                                 file idiom)))
      (case style

        ((old-style-sh-wrapper)
         (check-guile-for-sh-wrapper-variants!)
         (or (look 'module)
             (error "missing module specification"))
         (let ((proc (look 'proc)))
           (and proc (string? proc)
                (not (string=? "main" proc))
                (error "old-style-sh-wrapper can only handle proc `main'")))
         (commit! "#!/bin/sh\n~A~A~A\nexec ~A -l $0 -c ~S \"$@\"\n!#\n"
                  "main='(module-ref (resolve-module '\\''"
                  (look 'module)
                  ") '\\'main')' # -*-scheme-*-"
                  (look 'guile)
                  "(apply $main (cdr (command-line)))"))

        ((modern-sh-wrapper)
         (check-guile-for-sh-wrapper-variants!)
         (commit! "#!/bin/sh\nexec ~A ~A-s $0 \"$@\" # -*-scheme-*-\n!#\n"
                  (look 'guile)
                  (formatted-entry-point-maybe)))

        ((direct-with-meta-switch)
         (and (opt 'G-g) (error "incompatible option: --GUILE-guile"))
         (check-guile-for-direct-variants!)
         (commit! "#!~A \\\n~A-s\n!#\n"
                  (or (look 'guile)
                      (string-append
                       (assq-ref %guile-build-info 'bindir)
                       "/guile"))
                  (formatted-entry-point-maybe)))

        ((direct-with-minus-s)
         (cond
          ((opt 'G-g)
           (error "incompatible option: --GUILE-guile"))
          ((attr 'entry-point)
           (error "direct-with-minus-s loses entry point information")))
         (check-guile-for-direct-variants!)
         (commit! "#!~A -s\n!#\n"
                  (or (look 'guile)
                      (string-append
                       (assq-ref %guile-build-info 'bindir)
                       "/guile"))))

        (else
         (error (simple-format #f "unsupported style: ~A" style)))))))

(define (edit-script-header/qop qop)
  (let* ((options '())
         (chk! (lambda (key)
                 (qop key (lambda (val)
                            (set! options (acons key val options)))))))
    (for-each chk! '(GUILE-guile guile output verbose style backup installed))
    (cond ((assq 'style options)
           => (lambda (cell)
                (let ((sym (string->symbol (cdr cell))))
                  (or (memq sym '(old-style-sh-wrapper
                                  modern-sh-wrapper
                                  direct-with-meta-switch
                                  direct-with-minus-s))
                      (error "invalid style:" sym))
                  (set-cdr! cell sym)))))
    (and (assq 'installed options)
         (assq 'guile options)
         (error "-g is incompatible with -i"))
    (for-each (if (qop 'no-act)
                  (lambda (file)
                    (simple-format #t "file: ~A\n" file)
                    (for-each (lambda (x)
                                (if (list? (cdr x))
                                    (for-each (lambda (elem)
                                                (simple-format #t "~A: ~S\n"
                                                               (car x)
                                                               elem))
                                              (cdr x))
                                    (simple-format #t "~A: ~S\n"
                                                   (car x) (cdr x))))
                              (parse-script-header file)))
                  (lambda (file)
                    (edit-script-header options file)))
              (qop '())))
  #t)

(define (main args)
  (HVQC-MAIN args edit-script-header/qop
             '(usage . commentary)
             '(package . "Guile")
             '(option-spec (guile       (single-char #\g)
                                        (value optional))
                           (GUILE-guile (single-char #\G))
                           (no-act      (single-char #\n))
                           (output      (single-char #\o)
                                        (value #t))
                           (style       (single-char #\s)
                                        (value #t))
                           (verbose     (single-char #\v))
                           (backup      (single-char #\b)
                                        (value #t))
                           (installed   (single-char #\i)))))

;;; edit-script-header ends here
