#!/usr/bin/gosh
;;;
;;; gauche-package - Gauche package builder/manager
;;;  
;;;   Copyright (c) 2004-2005 Shiro Kawai, All rights reserved.
;;;   
;;;   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.
;;;  
;;;  $Id: gauche-package.in,v 1.13 2005/09/04 09:22:43 shirok Exp $
;;;

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

(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 . maybe-command)
  (let ((cmd (get-optional maybe-command #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 (app-error fmt . args)
  (apply format #t fmt args)
  (newline)
  (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 all?
            (format #t "(~19a ~8a for Gauche ~a)~%"
                    (ref gpd 'name) (ref gpd 'version)
                    (ref gpd 'gauche-version))))
        ))))

;;------------------------------------------------------
;; 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))
           (app-error "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.  

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'.
  --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")
                  (cc           "cc=s")
                  (cppflags     "cppflags=s")
                  (cflags       "cflags=s")
                  (ldflags      "ldflags=s")
                  (libs         "libs=s")
                  . args)
    (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
                              :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
                                       :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)
      (app-error "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))
      (app-error "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:
