#!/usr/local/bin/gosh
;;;
;;; gauche-package - Gauche package builder/manager
;;;
;;;   Copyright (c) 2004-2012  Shiro Kawai  <shiro@acm.org>
;;;
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

(use gauche.collection)
(use gauche.config)
(use gauche.package)
(use gauche.parseopt)
(use gauche.process)
(use gauche.version)
(use srfi-1)
(use srfi-13)
(use file.filter)
(use file.util)
(use text.tr)
(use util.list)

(autoload gauche.package.build
          gauche-package-build)
(autoload gauche.package.compile
          gauche-package-compile-and-link
          gauche-package-compile
          gauche-package-link
          gauche-package-clean)

(define *commands* '())
(define *helps* '())

(define (usage :optional (cmd #f))
  (if cmd
    (cond [(assoc-ref *helps* cmd)
           => (lambda (doc)
                (print "Usage: gauche-package " (car doc)) ;; synopsys
                (print "  " (cadr doc)) ;; summary
                (unless (null? (cddr doc)) (print (caddr doc))))]
          [else
           (print "Unknown command name: " cmd)
           (print "Valid commands are: " (map car (reverse *helps*)))])
    (begin
      (print "Usage: gauche-package <command> [options] <args> ...")
      (print "Commands:")
      (dolist (help (reverse *helps*))
        (format #t "  ~15a - ~a\n" (car help) (caddr help)))
      (print "Type 'gauche-package help <command>' for detailed help of each command.")))
  (exit 0))

(define *config* '())

(define (read-config)
  (let ((config-file (build-path (home-directory) ".gauche-package")))
    (when (file-is-readable? config-file)
      (set! *config* (with-input-from-file config-file read)))
    (dolist (p *config*)
      (when (eq? (car p) 'build-dir)
        (set! (cdr p) (expand-path (cdr p))))))
  )

(define (main args)
  (read-config)
  (cond ((null? (cdr args)) (usage))
        ((assoc-ref *commands* (cadr args)) => (cut <> (cddr args)))
        (else (print "Unknown command: " (cadr args))
              (usage)))
  0)

;;======================================================
;; Command definitions
;;

(define-macro (define-cmd name doc . body)
  `(begin
     (push! *helps* (cons ,name ',doc)) ; doc : (<synopsys> <summary> <detail>)
     (push! *commands* (cons ,name
                             (lambda (args)
                               (let ((usage-self (lambda () (usage ,name))))
                                 ,@body))))))

;;------------------------------------------------------
;; install
;;
(define-cmd "install"
  ("install [options] <tarball-path/url>"
   "Fetch, extract, configure, make & install"
   "Argument:
  a path to a tarball (uncompressed, gzipped or bzipped), or URL (http or ftp)
  of a tarball.
Options:
  -n, --dry-run   : shows commands to be executed, without running them.
  -C, --configure-options=<options>
                  : pass <options> to ./configure.  overrides -r.
  -r, --reconfigure
                  : uses the same configure options as before
      --clean     : clean up the build directory after installation
  -S, --install-as=<user> : sudo to <user> when installing")
  (let-args args ((dry-run "n|dry-run")
                  (copts   "C|configure-options=s" #f)
                  (reconf  "r|reconfigure")
                  (clean   "clean")
                  (sudo    "S|install-as=s" #f)
                  . args)
    (unless (= (length args) 1) (usage-self))
    (gauche-package-build (car args)
                          :config *config*
                          :dry-run dry-run :install #t :clean clean
                          :sudo-install sudo
                          :reconfigure reconf
                          :configure-options copts)))

;;------------------------------------------------------
;; build
;;
(define-cmd "build"
  ("build [options] <tarball-path/url>"
   "Fetch, extract, configure & make"
   "Argument:
  a path to a tarball (uncompressed, gzipped or bzipped), or URL (http or ftp)
  of a tarball.
Options:
  -n, --dry-run   : shows commands to be executed, without running them.
  -C, --configure-options=<options>
                  : pass <options> to ./configure.  overrides -r.
  -r, --reconfigure
                  : uses the same configure options as before")
  (let-args args ((dry-run "n|dry-run")
                  (copts   "C|configure-options=s" #f)
                  (reconf  "r|reconfigure")
                  . args)
    (unless (= (length args) 1) (usage-self))
    (gauche-package-build (car args)
                          :config *config*
                          :dry-run dry-run
                          :reconfigure reconf
                          :configure-options copts)))

;;------------------------------------------------------
;; reconfigure
;;
(define-cmd "reconfigure"
  ("configure-options <package>"
   "Show configure options of <package>"
   "Argument: a package name.
  If the package has installed .gpd (Gauche package description) file, show
  the options to the configure script when the package is built.")
  (unless (= (length args) 1) (usage-self))
  (let1 gpd (find-gauche-package-description (car args) :all-versions #t)
    (if gpd
      (print (ref gpd 'configure))
      (print ";; I don't know about package " (car args)))))

;;------------------------------------------------------
;; list
;;
(define-cmd "list"
  ("list"
   "List known installed packages"
   "  Only packages that have .gpd file are listed.
Options:
  -a, --all    : shows all packages, even the ones that are installed for
                 other versions of Gauche.")
  (let-args args ((all?  "a|all"))
    (let1 gpds (map path->gauche-package-description
                    (gauche-package-description-paths :all-versions all?))
      (dolist (gpd (sort gpds
                         (lambda (a b)
                           (string<= (ref a 'name) (ref b 'name)))))
        (if (version=? (gauche-version) (ref gpd 'gauche-version))
          (format #t " ~19a ~8a~%" (ref gpd 'name) (ref gpd 'version))
          (when (or all?
                    (abi-version=? (gauche-version) (ref gpd 'gauche-version)))
            (format #t " ~19a ~8a (@ Gauche ~a)~%"
                    (ref gpd 'name) (ref gpd 'version)
                    (ref gpd 'gauche-version))))
        ))))

;; Since 0.9, we keep ABI compatibility across all micro versions in
;; principle, so we only need to compare major and minor versions.
;; Eventually it would be better to have an interface to obatin abi-version
;; of running Gauche, and also to record abi version in .gpd file.
(define (abi-version=? v0 v1)
  (equal? (take* (string-split v0 #[.]) 2 #f)
          (take* (string-split v1 #[.]) 2 #f)))

;;------------------------------------------------------
;; make-gpd
;;
(define-cmd "make-gpd"
  ("make-gpd <name> <param> ..."
   "Make gpd file (called from the configure script)"
   "
  This command is to create a gpd (Gauche package description) file.
  Usually the user doens't invoke this command.  It is intended to be
  called within the configure script, like the following:

    gauche-package make-gpd Foo \\
       -version $PACKAGE_VERSION \\
       -configure \"./configure $GAUCHE_PACKAGE_CONFIGURE_ARGS\"

  If you generate template configure.ac by 'gauche-package generate',
  the make-gpd stuff is included in it.")
  (when (null? args) (usage-self))
  (let loop ((p (cdr args))
             (r '()))
    (cond [(null? p)
           (let ((gpd (apply make <gauche-package-description>
                             :name (car args)
                             (reverse! r))))
             (with-output-to-file #`",(car args).gpd"
               (cut write-gauche-package-description gpd)))]
          [(null? (cdr p))
           (exit 1 "gauche-package: make-gpd: parameter list not even")]
          [else
           (loop (cddr p)
                 (list* (cadr p)
                        (make-keyword (string-trim (car p) #[-:]))
                        r))])))

;;------------------------------------------------------
;; compile
;;
(define-cmd "compile"
  ("compile [options] [<extension-name>] <file> ..."
   "Compile and link an extension module from sources"
   "
  <file> can be any types the system's C compiler accepts, plus a stub
  file (with extension '.stub') which is a genstub source.

  By default, this command compiles given files with the options appropriate
  to compile Gauche extensions, then links a dynamically loadable object
  <extension-name>.so (the suffix may differ among systems).
  If '-c' option is given, only compilation of a single file is done.
  You can give extra flags for the compiler/linker via options.

  <extension-name> must match the name passed to SCM_INIT_EXTENSION,
  and must be a valid C identifier.  (NB: <extension-name> is used only
  as the filename and the argument of SCM_INIT_EXTENSION, and has nothing
  to do with the package name or the module name.

  Note: This command looks at the environment variables CC, CPPFLAGS, CFLAGS,
  LDFLAGS and LIBS as the default value of the --cc, --cppflags, --cflags,
  --ldflags and --libs, respectively.

Options:
  -c, --compile       : compile only.  with this option, <module> shouldn't
                        be given and only one <file> is allowed.
  -n, --dry-run       : just display commands to be executed.
  -v, --verbose       : reports commands being executed.
  -o, --output=name   : alternative output file name
      --clean         : instead of compile and link, removes the intermediate
                        and output file(s) that would be generated otherwise.
                        useful for 'make clean'.
  --gauche-buiddir=DIR : specify the top builddir of the Gauche when the
                        extensions should be compiled for /uninstalled/ Gauche.
  --local=PATH:PATH... : adds PATH/include to inlcude paths and PATH/lib to
                        library search paths for compiling.
  --cc=CC             : alternative C compiler.  Note that the compile should
                        have compatible ABI with the one that compiled Gauche.
  --cppflags=CPPFLAGS : extra cpp flags for compile, such as -I/usr/local
  --cflags=CFLAGS     : extra cc flags for compile
  --ldflags=LDFLAGS   : extra ld flags
  --libs=LIBS         : extra libraries")
  (let-args args ((dry-run      "n|dry-run")
                  (verbose      "v|verbose")
                  (compile-only "c|compile")
                  (output       "o|output=s")
                  (clean        "clean")
                  (gauche-builddir "gauche-builddir=s")
                  (local        "l|local=s")
                  (cc           "cc=s")
                  (cppflags     "cppflags=s")
                  (cflags       "cflags=s")
                  (ldflags      "ldflags=s")
                  (libs         "libs=s")
                  . args)
    ;; process 'local' option
    ;; e.g. "/usr/local:/pkg:/Program Files"
    ;;   => "-I /usr/local/include -I /pkg/include -I '/Program Files/include'"
    ;; etc.
    (define (local-paths prefix subdir)
      (and local
           (not (string-null? local))
           (not (string-null? prefix))
           (string-join (map (lambda (path)
                               (shell-escape-string (build-path path subdir)))
                             (string-split local #\:))
                        #`" ,prefix" 'prefix)))
    ;; preprocess parameters.
    ;; if parameter is not given, look at the named environment variable.
    (define (param given envname . additionals)
      (let1 v
          (filter values (cons (or given (sys-getenv envname)) additionals))
        (and (not (null? v)) (string-join v))))

    (let ([cc       (param cc "CC")]
          [cppflags (param cppflags "CPPFLAGS" (local-paths "-I" "include"))]
          [cflags   (param cflags   "CFLAGS")]
          [ldflags  (param ldflags  "LDFLAGS"
                           (local-paths "-L" "lib")
                           (local-paths (gauche-config "--rpath-flag") "lib"))]
          [libs     (param libs     "LIBS")])
      (cond
       [clean
        (unless (null? args)
          (gauche-package-clean (if compile-only #f (car args))
                                (if compile-only args (cdr args))
                                :output output))]
       [compile-only
        (unless (= (length args) 1) (usage-self))
        (gauche-package-compile (car args)
                                :dry-run dry-run :verbose verbose
                                :gauche-builddir gauche-builddir
                                :output output :cc cc
                                :cppflags cppflags :cflags cflags)]
       [else
        (when (<= (length args) 1) (usage-self))
        (gauche-package-compile-and-link (car args) (cdr args)
                                         :dry-run dry-run :verbose verbose
                                         :gauche-builddir gauche-builddir
                                         :output output :cc cc :ld cc
                                         :cppflags cppflags :cflags cflags
                                         :ldflags ldflags :libs libs)]))
    ))

;;------------------------------------------------------
;; generate
;;
(define-cmd "generate"
  ("generate package-name [module-name]"
   "Generate template source tree for a new Gauche extension"
   "
  This command creates a directory <package-name> under the current
  directory, and populates it with the template files.  It is an easy
  way to start writing Gauche extension.

  <package-name> is the one you'll see as a part of the name of tarball,
  for example, \"Gauche-gl\".  It is the name of the unit of distribution
  and installation of your package.

  <module-name>, if given, is used as the name of the module
  instead of <package-name>.  It may affect the generated directory
  structure.")
  (let-optionals* args ((package-name #f)
                        (module-name #f)
                        . more)
    (unless (and package-name (null? more)) (usage-self))
    (unless (#/^[\w-]+$/ package-name)
      (exit 1 "Invalid character in package-name ~s: You can only use alphanumeric chars, underscore, and minus sign." package-name))
    (unless (or (not module-name) (#/^[\w.-]+$/ module-name))
      (exit 1 "Invalid character in module-name ~s" module-name))
    (let* ([package-name*  (rxmatch-case package-name
                             (#/^Gauche-(.*)/ (#f rest) rest)
                             (else package-name))]
           [extension-name (string-tr package-name* "A-Za-z_-" "a-za-z__")]
           [module-name (string->symbol (or module-name extension-name))]
           [tmpl-dir (sys-dirname (gauche-library-directory))]
           [scm-subdir (sys-dirname (module-name->path module-name))])
      (make-directory* (simplify-path (build-path package-name scm-subdir)))
      (for-each
       (lambda (file)
         (let* ([src-path (build-path tmpl-dir #`"template.,file")]
                [dst-name (regexp-replace*
                           file
                           #/extension/ extension-name
                           #/module/ (sys-basename
                                      (module-name->path module-name)))]
                [dst-path (if (equal? file "module.scm")
                            (build-path package-name scm-subdir dst-name)
                            (build-path package-name dst-name))])
           (filter-copy src-path dst-path
                        package-name extension-name module-name '("DIST"))))
       '("Makefile.in" "configure.ac" "extension.c" "extension.h"
         "extensionlib.stub" "module.scm" "test.scm" "DIST")))
    ))

(define (filter-copy src dst
                     package-name extension-name module-name executables)
  (let1 EXTENSION-NAME (string-upcase extension-name)
    (file-filter (lambda (in out)
                   (port-for-each
                    (lambda (line)
                      (display
                       (regexp-replace-all*
                        line
                        #/@@package@@/ package-name
                        #/@@modname@@/ (x->string module-name)
                        #/@@modpath@@/ (module-name->path module-name)
                        #/@@extname@@/ extension-name
                        #/@@EXTNAME@@/ EXTENSION-NAME)
                       out)
                      (newline out))
                    (cut read-line in)))
                 :input src
                 :output dst)
    (when (member (sys-basename dst) executables)
      (sys-chmod dst #o755))
    ))

;;------------------------------------------------------
;; help
;;

(define-cmd "help"
  ("help <command>"
   "Show detailed help of <command>")
  (apply usage args))

;; Local variables:
;; mode: scheme
;; end:
