#! /bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts bootstrap)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cons \"$0\" (cdr (command-line))))" "$@"
!#
;;;; This file is part of Gamma.
;;;; Copyright (C) 2010-2018 Sergey Poznyakoff
;;;;
;;;; Gamma 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, or (at your option)
;;;; any later version.
;;;;
;;;; Gamma 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 Gamma.  If not, see <http://www.gnu.org/licenses/>.

(define-module (scripts bootstrap)
  :use-module (ice-9 getopt-long)
  :use-module (ice-9 rdelim)
  :use-module (ice-9 regex)
  :use-module (ice-9 popen)
  :use-module (srfi srfi-1))

(if (= (string->number (major-version)) 1)
    (debug-enable 'debug))
(debug-enable 'backtrace)

(define module-dir #f)
(define srcdir "gamma")
(define makefile "gamma/modules.mk")
(define modconfig-file "m4/modules.m4")
(define modconfig-defun "gamma_MODCONFIG")
(define autogenerated-file-header
  (list "-*- buffer-read-only: t -*- vi: set ro:"
	"DO NOT EDIT! GENERATED AUTOMATICALLY!"))
(define reconfig-command
  "git submodule init && git submodule update && autoreconf -f -i -s")
(define files-from #f)
(define create-parents #f)
  
(define grammar
  `((topdir (single-char #\C) (value #t))
    (moddir (value #t))
    (srcdir (value #t))
    (makefile (value #t))
    (modconfig-file (value #t))
    (modconfig-defun (value #t))
    (reconfigure (value #t))
    (files-from (single-char #\T) (value #t))
    (parents (single-char #\p) (value #f))
    (help)))

(define (usage)
  (display   "usage: bootstrap [OPTIONS] [FILES...]\n")
  (display   "Bootstraps the Gamma module system\n")
  (display   "OPTIONS are (defaults shown in brackets):\n")
  (display   "  -C, --topdir DIR    top source directory [.]\n")
  (display   "  --moddir DIR        module directory [.]\n")
  (format #t "  --srcdir DIR        source directory [~A]~%" srcdir)
  (format #t "  --makefile FILE     output makefile [~A]~%" makefile)
  (format #t "  --modconfig-file FILE  module configuration file [~A]~%" modconfig-file)
  (format #t "  --modconfig-defun FUNC name of the module configuration defun [~A]~%" modconfig-defun)
  (format #t "  --reconfigure CMD      reconfigure command [~A]~%" reconfig-command)
  (display   "  -T, --files-from FILE  read files from FILE\n")
  (display   "  -p, --parents          create parent directories as needed\n"))

(define progname #f)

(define (error fmt . args)
  (with-output-to-port
      (current-error-port)
    (lambda ()
      (display progname)
      (display ": ")
      (apply format (cons #t (cons fmt args)))
      (newline))))

(define (mkdir-p dir . rest)
  (let ((mode (if (null? rest) #o777 (car rest)))
	(path #f))
    (for-each
     (lambda (subdir)
       (let ((full-name
	      (if path
		  (string-append path (if (string-suffix? "/" path)
					  "" "/")
				 subdir)
		  subdir)))
	 (if (not (file-exists? full-name))
	     (catch 'system-error
		    (lambda ()
		      (mkdir full-name mode))
		    (lambda args
		      (format #t "ARGS: ~A~%" args)
		      (apply throw (append (list-head args 2)
					   (list
					    (string-append
					     "~A: "
					     (list-ref args 2)))
					   (list
					    (cons
					     full-name
					     (list-ref args 3)))
					   (list-tail args 4))))))
	 (set! path full-name)))
     (string-split dir #\/))))

(define (with-output-to-file-p file thunk)
  (if create-parents
      (mkdir-p (dirname file)))
  (catch 'system-error
	 (lambda ()
	   (with-output-to-file file thunk))
	 (lambda args
	   (let ((errno (car (list-ref args 4))))
	     (cond
	      ((and (not create-parents) (= errno 2))
	       (with-output-to-port
		   (current-error-port)
		 (lambda ()
		   (apply format (append (list #t (list-ref args 2))
					 (list-ref args 3)))
		   (format #t ": try using --parents~%")
		   (exit 1))))
	      (else
	       (apply throw args)))))))

(define section-header-rx (make-regexp "^(.*):[ \t]*$"))

(define (read-module-file file)
  (let ((ret (list (cons 'module (basename file))))
	(section-name #f)
	(section-body '()))
    (with-input-from-file
	(cond
	 ((or (string-prefix? "./" file)
	      (string-prefix? "/" file))
	  file)
	 (module-dir
	  (string-append module-dir "/" file))
	 (else
	  file))
      (lambda ()
	(do ((input (read-line) (read-line)))
	    ((eof-object? input)
	     (reverse (if section-name
			  (cons (cons (string->symbol section-name)
				      (reverse section-body))
				ret)
			  ret)))
	  (cond
	   ((regexp-exec section-header-rx input) =>
	    (lambda (match)
	      (cond
	       (section-name
		(set! ret (cons (cons (string->symbol section-name)
				      (reverse section-body))
				ret))))
	      (set! section-name (match:substring match 1))
	      (set! section-body '())))
	   (else
	    (set! section-body (cons input section-body)))))))))

(define (reduce-string-list inlist)
  (if (or (not (list? inlist)) (null? inlist))
      inlist
      (let ((x (car inlist)))
	(if (string-null? x)
	    (reduce-string-list (cdr inlist))
	    (cons x (reduce-string-list (cdr inlist)))))))

(define (read-strings . rest)
  (let reader ((pred (if (null? rest) #f (car rest))))
    (let ((input (read-line)))
      (cond
       ((eof-object? input)
	'())
       ((and pred (not (pred input)))
	(reader pred))
       (else
	(cons input (reader pred)))))))

(define (read-strings-from-file file . rest)
  (with-input-from-file
      file
    (lambda ()
      (apply read-strings rest))))
      
(define (get-x-file-list source-list)
  (let ((p (open-input-pipe
	    (apply string-append
		   (cons
		    "sed -r -n '/^#[[:blank:]]*include[[:blank:]]*</s/.*<(.*\\.x)>.*/\\1/p;/^#[[:blank:]]*include[[:blank:]]*\"/s/.*\"(.*\\.x)\".*/\\1/p'"
		    (map
		     (lambda (file-name)
		       (string-append " " srcdir "/" file-name))
		     source-list))))))
    (let ((out-list (with-input-from-port p read-strings)))
      (close-pipe p)
      out-list)))

(define (uniq-list lst)
  (if (null? (cdr lst))
      lst
      (reduce-right
       (lambda (elem prev)
	 (let ((x (if (pair? prev) prev (list prev))))
	   (if (string=? elem (car x))
	       x
	       (cons elem x))))
       '()
       lst)))

(define (get-module-defn file)
  (let* ((xdata '())
	 (moddef (map
		  (lambda (sec)
		    (let ((id (car sec))
			  (data (cdr sec)))
		      (case id
			((libraries scm)
			 (cons id (reduce-string-list data)))
			((sources)
			 (let ((file-list
				(map
				 (lambda (file-name)
				   (cond
				    ((string-suffix? ".x" file-name)
				     (set! xdata (cons file-name xdata))
				     (string-append
				      (string-drop-right file-name 1) "c"))
				    (else
				     file-name)))
				 (reduce-string-list data))))
			   (set! xdata (append xdata
					       (get-x-file-list file-list)))
			   (cons id file-list)))
			(else
			 sec))))
		  (read-module-file file))))
    (if (not (null? xdata))
	(append moddef
		(list (cons 'xdata
			    (uniq-list (sort xdata string<?)))))
	moddef)))

(define (write-autogenerated-header ocomm ccomm)
  (for-each
   (lambda (line)
     (display ocomm)
     (display line)
     (if ccomm
	 (display ccomm))
     (newline))
   autogenerated-file-header))

(define (write-string-list arg . rest)
  (let ((indent (make-string (if (null? rest) 0 (car rest)) #\space)))
    (for-each
     (lambda (line)
       (display indent)
       (display line)
       (newline))
     arg)))

(define (write-module-header fmt moddef)
  (display "#\n")
  (let ((mname (assoc-ref moddef 'module)))
    (if mname
	(begin
	  (display "# ")
	  (format #t fmt mname)
	  (newline))))
  (display "#\n"))

(define np-rx (make-regexp "[^[:alnum:]]" regexp/extended))

(define (write-arg-framework moddef thunk)
  (let* ((mod-name (assoc-ref moddef 'module))
	 (var-name (string-append
		    "gamma_"
		    (regexp-substitute/global
		     #f np-rx (string-downcase mod-name)
		     'pre "_" 'post))))
    (format #t "AC_ARG_ENABLE([~A],~%" mod-name)
    (format #t "  AC_HELP_STRING([--disable-~A],~%" mod-name)
    (format #t "                 [disable ~A]),~%" mod-name)
    (format #t "  [~A=$enableval],[~A=yes])~%" var-name var-name)
    (cond
     (thunk
      (format #t "if test $~A = yes; then~%" var-name)
      (thunk)
      (display "fi\n")))
    (let ((libraries (assoc-ref moddef 'libraries)))
      (cond
       ((and libraries (not (null? libraries)))
	(format #t "if test $~A = yes; then~%" var-name)
	(display   "  GAMMA_LIB_LIST=\"$GAMMA_LIB_LIST")
	(for-each
	 (lambda (root)
	   (format #t " libgamma-~A.la" root))
	 libraries)
	(display #\")
	(newline)

	(display   "  GAMMA_INSTALL_HOOKS=\"$GAMMA_INSTALL_HOOKS")
	(for-each
	 (lambda (root)
	   (format #t " install-~A-hook" root))
	 libraries)
	(display #\")
	(newline)
	(display "fi\n"))))))
	      
(define (empty-string-list? lst)
  (cond
   ((null? lst)
    #t)
   ((not (string-null? (car lst)))
    #f)
   (else
    (empty-string-list? (cdr lst)))))

(define (write-modconfig modules)
  (format #t "~A: writing module configuration file ~A~%"
	  progname modconfig-file)
  (with-output-to-file-p
      modconfig-file
    (lambda ()
      (write-autogenerated-header "# " #f)
      (newline)
      (format #t "AC_DEFUN([~A],[~%" modconfig-defun)
      (display   "AC_SUBST([GAMMA_LIB_LIST])\n")
      (display   "AC_SUBST([GAMMA_INSTALL_HOOKS])\n")
      (for-each
       (lambda (moddef)
	 (let ((conf (assoc-ref moddef 'configure)))
	   (if conf
	       (begin
		 (write-module-header "Configuration for ~A" moddef)
		 (write-arg-framework moddef
				      (if (empty-string-list? conf)
					  #f
					  (lambda ()
					    (write-string-list conf 2))))))))
       modules)
      (display "])")
      (newline))))

(define (write-backslashed-list lst prev)
  (cond
   ((not lst)
    (newline))
   ((null? lst)
    (newline))
   (else
    (let* ((x (car lst))
	   (p (not (string-null? x))))
      (cond (p
	     (cond (prev
		    (display #\\)
		    (newline)
		    (display " ")))
	     (display x)))
      (write-backslashed-list (cdr lst) (or p prev))))))

(define (write-install-hook root)
  (display (string-append "install-" root "-hook:\n"))
  (format #t "\
\t@here=`pwd`; \\\n\
\tcd $(DESTDIR)$(libdir);\\\n\
\tif test -f libgamma-~A.so; then \\\n\
\t\t$(LN_S) -f libgamma-~A.so libgamma-~A-v-$(VERSION).so; \\\n\
\tfi; \\\n\
\tcd $$here" root root root)
  (newline))


(define (write-makefile modules)
  (format #t "~A: writing makefile ~A~%"
	  progname makefile)
  (with-output-to-file-p
      makefile
    (lambda ()
      (write-autogenerated-header "# " #f)
      (newline)
      (display   "GAMMA_DATA_FILES=\n")
      (display   "GAMMA_BUILT_DATA_FILES=\n")
      (display   "GAMMA_X_FILES=\n")
      (for-each
       (lambda (moddef)
	 (write-module-header "Module ~A" moddef)

	 (let ((libraries (assoc-ref moddef 'libraries)))
	   (cond
	    ((and libraries (not (null? libraries)))
	     (display "EXTRA_LTLIBRARIES +=")
	     (for-each
	      (lambda (root)
		(if (not (string-null? root))
		    (format #t " libgamma-~A.la" root)))
	      libraries)
	     (newline)

	     (if (null? (cdr libraries))
		 (let ((root (car libraries)))
		   (format #t "libgamma_~A_la_SOURCES = " root)
		   (write-backslashed-list
		    (or (assoc-ref moddef
				   (string->symbol
				    (string-append root "-sources")))
			(assoc-ref moddef 'sources)) #f)
		   (newline)
		   (format #t "libgamma_~A_la_LDFLAGS = -rpath $(libdir) -version-info 0:0:0~%" root)
		   (newline)
		   (write-install-hook root))
		 
		 (for-each
		  (lambda (root)
		    (format #t "libgamma_~A_la_SOURCES = " root)
		    (write-backslashed-list
		     (assoc-ref moddef (string->symbol
					(string-append root "-sources"))) #f)
		    (newline)
		    (format #t "libgamma_~A_la_LDFLAGS = -rpath $(libdir) -version-info 0:0:0~%" root)
		    (newline)
		    (write-install-hook root))
		  libraries))

	     (newline))))

	 (cond
	  ((assoc-ref moddef 'scm) =>
	   (lambda (scm-list)
	     (let ((built-data '())
		   (scm-data '()))
	       (format #t "EXTRA_DIST +=")
	       (for-each
		(lambda (file)
		  (if (string-suffix? ".sci" file)
		      (set! built-data (cons (string-append
					      (string-drop-right file 1)
					      "m")
					     built-data))
		      (set! scm-data (cons file scm-data)))
		  (display " ")
		  (display file))
		scm-list)
	       (newline)
	       (format #t "GAMMA_DATA_FILES += ~a~%" (string-join scm-data " "))

	       (cond
		((not (null? built-data))
		 (format #t "GAMMA_BUILT_DATA_FILES +=")
		 (for-each
		  (lambda (file)
		    (display " ")
		    (display file))
		  built-data)
		 (newline)))))))
	 
	 (cond
	  ((assoc-ref moddef 'xdata) =>
	   (lambda (xdata)
	     (format #t "GAMMA_X_FILES +=")
	     (for-each
	      (lambda (file)
		(display " ")
		(display file))
	      xdata)
	     (newline))))

	 (cond
	  ((assoc-ref moddef 'makefile) =>
	   (lambda (x)
	     (write-string-list x)))))
       modules))))

(define (main . args)
  (set! progname (car args))
  (let ((input-files '()))
    (for-each
     (lambda (x)
       (case (car x)
	 ((())
	  (set! input-files (cdr x)))
	 ((help)
	  (usage)
	  (exit 0))
	 ((moddir)
	  (set! module-dir (cdr x)))
	 ((srcdir)
	  (set! srcdir (cdr x)))
	 ((modconfig-file)
	  (set! modconfig-file (cdr x)))
	 ((modconfig-defun)
	  (set! modconfig-defun (cdr x)))
	 ((topdir)
	  (chdir (cdr x)))
	 ((makefile)
	  (set! makefile (cdr x)))
	 ((reconfigure)
	  (set! reconfig-command (cdr x)))
	 ((files-from)
	  (set! files-from (cdr x)))
	 ((parents)
	  (set! create-parents (cdr x)))
	 (else
	  (error "unhandled option: ~A" x))))
     (getopt-long args grammar))

    (letrec ((pred (lambda (x)
		     (not (or
			   (string-null? x)
			   (string-prefix? "#" x))))))
      (if files-from
	  (set! input-files
		(append input-files
			(read-strings-from-file files-from pred))))

      (cond
       ((null? input-files)
	(if module-dir
	    (let ((fname (string-append module-dir "/MODLIST")))
	      (cond
	       ((file-exists? fname)
		(format #t "~A: reading modules from ~A~%" progname fname)
		(set! input-files (read-strings-from-file fname pred)))))))))

    (if (null? input-files)
	(begin
	  (error "no input files")
	  (exit 1)))
    
    (let ((modules (map
		    (lambda (file)
		      (get-module-defn file))
		    input-files)))
;      (write modules)
      (write-modconfig modules)
      (write-makefile modules)
      (cond
       ((not (string-null? reconfig-command))
	(format #t "~A: running ~A~%" progname reconfig-command)
	(system reconfig-command))))))