mes/configure

#! /bin/sh
# -*- scheme -*-
unset LANG LC_ALL
guile=$(command -v ${GUILE-guile})
guix=$(command -v ${GUIX-guix})
if [ -n "$guix" ] ; then
    install="guix environment -l guix.scm"
else
    install="sudo apt-get install guile-2.2-dev"
fi
if [ -z "$guile" ]; then
    cat <<EOF

Missing dependencies: ${GUILE-guile}, please install Guile 2.2 or later; run
    $install
EOF
exit 1
fi
GUILE=$guile
export GUILE
exec ${guile} -L . --no-auto-compile -e '(configure)' -s "$0" ${1+"$@"}
!#

;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; configure: This file is part of Mes.
;;;
;;; Mes 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.
;;;
;;; Mes 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 Mes.  If not, see <http://www.gnu.org/licenses/>.

(define-module (configure)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 and-let-star)
  #:use-module (ice-9 curried-definitions)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 match)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:export (main))

(define* (PATH-search-path name #:key (default name) warn?)
  (or (search-path (string-split (getenv "PATH") #\:) name)
      (and (and warn? (format (current-error-port) "warning: not found: ~a\n" name))
           default)))

(define *shell* "sh")
(define PACKAGE "mes")
(define VERSION "0.16.1")

;;; Utility
(define (logf port string . rest)
  (apply format (cons* port string rest))
  (force-output port)
  #t)

(define (stderr string . rest)
  (apply logf (cons* (current-error-port) string rest)))

(define (stdout string . rest)
  (apply logf (cons* (current-output-port) string rest)))

(define %verbose? #f)

(define (verbose string . rest)
  (if %verbose? (apply stderr (cons string rest))))

(define (gulp-pipe command)
  (let* ((port (open-pipe* OPEN_READ *shell* "-c" command))
         (output (read-string port))
         (status (close-pipe port)))
    (verbose "command[~a]: ~s => ~a\n" status command output)
    (if (not (zero? status)) "" (string-trim-right output #\newline))))

(define* ((->string #:optional (infix "")) h . t)
  (let ((o (if (pair? t) (cons h t) h)))
    (match o
      ((? char?) (make-string 1 o))
      ((? number?) (number->string o))
      ((? string?) o)
      ((? symbol?) (symbol->string o))
      ((h ... t) (string-join (map (->string) o) ((->string) infix)))
      (_ ""))))

(define (tuple< a b)
  (cond
   ((and (null? a) (null? b)) #t)
   ((null? a) (not (null? b)))
   ((null? b) #f)
   ((and (not (< (car a) (car b)))
         (not (< (car b) (car a))))
    (tuple< (cdr a) (cdr b)))
   (else (< (car a) (car b)))))

(define (tuple<= a b)
  (or (equal? a b) (tuple< a b)))

(define (conjoin . predicates)
  (lambda (. arguments)
    (every (cut apply <> arguments) predicates)))

(define (char->char from to char)
  (if (eq? char from) to char))

(define (string-replace-char string from to)
  (string-map (cut char->char from to <>) string))

;;; Configure

(define-immutable-record-type <dependency>
  (make-depedency name version-expected optional? version-option commands file-name)
  dependency?
  (name dependency-name)
  (version-expected dependency-version-expected)
  (version-option dependency-version-option)
  (optional? dependency-optional?)
  (commands dependency-commands)
  (file-name dependency-file-name)
  (version-found dependency-version-found))

(define* (make-dep name #:optional (version '(0))
                   #:key optional? (version-option "--version") (commands (list name)) file-name)
  (let* ((env-var (getenv (name->shell-name name)))
         (commands (if env-var (cons env-var commands) commands)))
   (make-depedency name version optional? version-option commands file-name)))

(define (find-dep name deps)
  (find (compose (cut equal? <> name) dependency-name) deps))

(define (file-name name deps)
  (and=> (find-dep name deps) dependency-file-name))

(define (variable-name dependency)
  (and=>
   (dependency-name dependency)
   name->shell-name))

(define (name->shell-name name)
  (string-upcase (string-replace-char name #\- #\_)))

(define (version->string version)
  ((->string '.) version))

(define (string->version string)
  (and-let* ((version (string-tokenize string
                                       (char-set-adjoin char-set:digit #\.)))
             ((pair? version))
             (version (sort version (lambda (a b) (> (string-length a) (string-length b)))))
             (version (car version))
             (version (string-tokenize version
                                       (char-set-complement (char-set #\.)))))
            (map string->number version)))

(define (check-program-version dependency)
  (let ((name (dependency-name dependency))
        (expected (dependency-version-expected dependency))
        (version-option (dependency-version-option dependency))
        (commands (dependency-commands dependency)))
    (let loop ((commands commands))
      (if (null? commands) dependency
          (let ((command (car commands)))
            (stdout "checking for ~a~a... " command
                    (if (null? expected) ""
                        (format #f " [~a]" (version->string expected))))
            (let* ((output (gulp-pipe (format #f "~a ~a 2>&1" command version-option)))
                   (actual (string->version output))
                   (pass? (and actual (tuple< expected actual)))
                   (dependency (set-field dependency (dependency-version-found) actual)))
              (stdout "~a ~a\n" (if pass? (if (pair? actual) "" " yes")
                                    (if actual " no, found" "no")) (version->string actual))
              (if pass? (let ((file-name (or (PATH-search-path command)
                                             (dependency-file-name dependency))))
                          (set-field dependency (dependency-file-name) file-name))
                  (loop (cdr commands)))))))))

(define (check-file dependency)
  (stdout "checking for ~a... " (dependency-name dependency))
  (let ((file-name (and (file-exists? (dependency-file-name dependency))
                        (dependency-file-name dependency))))
    (stdout "~a\n" (or file-name ""))
    (set-field dependency (dependency-file-name) file-name)))

(define* (check-header-c dependency  #:optional (check check-compile-header-c))
  (let ((name (dependency-name dependency)))
    (stderr "checking for ~a..." name)
    (let ((result (check name)))
      (stderr " ~a\n" (if result "yes" "no"))
      (if result (set-field dependency (dependency-file-name) name)
          dependency-file-name))))

(define (check-compile-header-c header)
  (zero? (system (format #f "echo '#include ~s' | gcc -E - > /dev/null 2>&1" header))))

(define (parse-opts args)
  (let* ((option-spec
  	  '((build (value #t))
            (host (value #t))
            (help (single-char #\h))
            (prefix (value #t))
            (sysconfdir (value #t))
            (verbose (single-char #\v))
            (with-courage)
            (infodir (value #t))
            (mandir (value #t))
            (disable-silent-rules)

            (enable-fast-install)       ; Ignored for Guix
            (includedir (value #t))     ; Ignored for Debian
            (mandir (value #t))         ; Ignored for Debian
            (localstatedir (value #t))  ; Ignored for Debian
            (libdir (value #t))         ; Ignored for Debian
            (libexecdir (value #t))     ; Ignored for Debian
            (runstatedir (value #t))    ; Ignored for Debian
            (disable-maintainer-mode)   ; Ignored for Debian
            (disable-dependency-tracking) ; Ignored for Debian
            )))

    (getopt-long args option-spec)))

(define* (print-help #:optional (port (current-output-port)))
  (format port "\
`configure' configures ~a ~a to adapt to many kinds of systems.

Usage: ./configure [OPTION]... [VAR=VALUE]

To assign environment variables (e.g., CC, CFLAGS...), specify them as
VAR=VALUE.  See below for descriptions of some of the useful variables.

Defaults for the options are specified in brackets.

Options:
  -h, --help           display this help
      --build=BUILD    configure for building on BUILD [guessed]
      --disable-silent-rules
                       verbose build output [BUILD_DEBUG=1]
      --host=HOST      cross-compile to build programs to run on HOST [BUILD]
  -v, --verbose        be verbose
  --with-courage       assert being courageous to configure for unsupported platform

Installation directories:
  --prefix=DIR         install in prefix DIR [~a]
  --infodir=DIR        info documentation [PREFIX/share/info]
  --mandir=DIR         man pages [PREFIX/share/man]

Ignored for Guix:
  --enable-fast-install

Ignored for Debian:
  --disable-dependency-tracking
  --disable-maintainer-mode
  --includedir=DIR
  --libdir=DIR
  --libexecdir=DIR
  --localstatedir=DIR
  --mandir=DIR
  --runstatedir=DIR

Some influential environment variables:
  CC                C compiler command
  CFLAGS            C compiler flags
  CC32              x86 C compiler command
  CC32_CFLAGS       x86 C compiler flags
  GUILE             guile command
  GUILE_TOOLS       guile-tools command
  MES_CFLAGS        MesCC flags
  MES_SEED          location of mes-seed
  MESCC_TOOLS_SEED  location of mescc-tools-seed
  TCC               tcc C compiler command
  TINYCC_SEED       location of tinycc-seed
" PACKAGE VERSION (getenv "prefix")))

(define (main args)
  (let* ((prefix "/usr/local")
         (infodir "${prefix}/share/info")
         (mandir "${prefix}/share/man")
         (sysconfdir "${prefix}/etc")

         (srcdir (dirname (car (command-line))))
         (abs-top-srcdir (canonicalize-path srcdir))
         (abs-top-builddir (canonicalize-path (getcwd)))
         (top-builddir (if (equal? srcdir ".") "."
                           abs-top-builddir))
         (top-builddest (if (equal? srcdir ".") ""
                        (string-append abs-top-builddir "/")))

         (options (parse-opts args))

         (build-type (option-ref options 'build %host-type))
         (arch (car (string-split build-type #\-)))
         (host-type (option-ref options 'host %host-type))

         (prefix (option-ref options 'prefix prefix))
         (infodir (option-ref options 'infodir infodir))
         (sysconfdir (option-ref options 'sysconfdir sysconfdir))
         (datadir (string-append prefix "/share/mes"))
         (moduledir (string-append datadir "/module"))
         (guile-effective-version (effective-version))
         (guile-site-dir (if (equal? prefix ".") (canonicalize-path ".")
                             (string-append prefix "/share/guile/site/" guile-effective-version)))
         (guile-site-ccache-dir (if (equal? prefix ".") (canonicalize-path ".")
                                    (string-append prefix "/lib/guile/" guile-effective-version "/site-ccache")))
         (with-courage? (option-ref options 'with-courage #f))
         (disable-silent-rules? (option-ref options 'disable-silent-rules #f))
         (vars (filter (cut string-index <> #\=) (option-ref options '() '())))
         (help? (option-ref options 'help #f)))
    (define (srcdir-relative file-name)
      (if (equal? srcdir ".") file-name
          (string-append srcdir "/" file-name)))
    (when help?
      (print-help)
      (exit 0))
    (set! %verbose? (option-ref options 'verbose #f))
    (for-each (lambda (v) (apply setenv (string-split v #\=))) vars)
    (let* ((mes-seed (or (getenv "MES_SEED")
                         (srcdir-relative "../mes-seed")))
           (tinycc-seed (or (getenv "TINYCC_SEED")
                            (srcdir-relative "../tinycc-seed")))
           (mescc-tools-seed (or (getenv "MESCC_TOOLS_SEED")
                                 (srcdir-relative "../mescc-tools-seed")))
           (deps (fold (lambda (program results)
                         (cons (check-program-version program) results))
                       '()
                       (list (make-dep "guile" '(2 0) #:commands '("guile-2.2" "guile-2.0" "guile-2" "guile"))
                             (make-dep "bash" '(2 0) #:optional? #t)
                             (make-dep "guile-tools" '(2 0))
                             (make-dep "mes-seed" '(0 16 1) #:optional? #t
                                       #:commands (list (string-append mes-seed "/refresh.sh"))
                                       #:file-name mes-seed)
                             (make-dep "tinycc-seed" '(0 16) #:optional? #t
                                       #:commands (list (string-append tinycc-seed "/refresh.sh"))
                                       #:file-name tinycc-seed)
                             (make-dep "cc" '(2 95) #:commands '("gcc"))
                             (make-dep "make" '(4))
                             (make-dep "cc32" '(2 95)
                                       #:optional? #t
                                       #:commands '("i686-unknown-linux-gnu-gcc"))
                             (make-dep "M1" '(0 3))
                             (make-dep "blood-elf" '(0 1))
                             (make-dep "hex2" '(0 3))
                             (make-dep "tcc" '(0 9 26) #:optional? #t #:version-option "-v")
                             (make-dep "makeinfo" '(5) #:optional? #t)
                             (make-dep "help2man" '(1 47) #:optional? #t)
                             (make-dep "perl" '(5) #:optional? #t)
                             (make-dep "git" '(2) #:optional? #t))))
           (deps (cons (check-program-version (make-dep "nyacc" '(0 80 41) #:commands (list (string-append (file-name "guile" deps) " -c '(use-modules (nyacc lalr)) (display *nyacc-version*)'")) #:file-name #t))
                       deps))
           (deps (if (file-name "cc" deps)
                     (cons* (check-header-c (make-dep "stdio.h"))
                            (check-header-c (make-dep "limits.h"))
                            deps)
                     deps))
           (deps (cons (check-file (make-dep "mescc-tools-seed" '(0) #:optional? #t
                                             #:file-name mescc-tools-seed))
                       deps))
           (missing (filter (conjoin (negate dependency-file-name)
                                     (negate dependency-optional?)) deps)))

      (define* (substitute file-name pairs
                           #:key (target (if (string-suffix? ".in" file-name)
                                             (string-drop-right file-name 3) file-name)))
        (system* "mkdir" "-p" (dirname target))
        (with-output-to-file target
          (lambda _
            (display
             (fold (lambda (o result)
                     (regexp-substitute/global #f (car o) result 'pre (cdr o) 'post))
                   (with-input-from-file file-name read-string) pairs)))))

      (when (and (not (member arch '("i686" "x86_64"))) (not with-courage?))
        (stderr "platform not supported: ~a, try --with-courage\n" arch)
        (exit 1))
      (when (pair? missing)
        (stderr "\nMissing dependencies: ~a\n" (string-join (map dependency-name missing)))
        (exit 1))
      (let ((git (find-dep "git" deps)))
        (when (and git
                   (not (file-exists? ".git")))
          ;; Debian wants to run `make clean' from a tarball
          (and (zero? (system* "git" "init"))
               (zero? (system* "git" "add" "."))
               (zero? (system* "git" "commit" "--allow-empty" "-m" "Import mes")))))
      (with-output-to-file ".config.make"
        (lambda _
          (stdout "PACKAGE:=~a\n" PACKAGE)
          (stdout "VERSION:=~a\n" VERSION)

          (stdout "build:=~a\n" build-type)
          (stdout "host:=~a\n" host-type)
          (stdout "srcdir:=~a\n" srcdir)
          (stdout "top_builddest:=~a\n" top-builddest)
          (stdout "top_builddir:=~a\n" top-builddir)
          (stdout "abs_top_builddir:=~a\n" abs-top-builddir)
          (stdout "abs_top_srcdir:=~a\n" abs-top-srcdir)
          (stdout "srcdir:=~a\n" srcdir)
          (stdout "prefix:=~a\n" (gulp-pipe (string-append "echo " prefix)))
          (stdout "infodir:=~a\n" infodir)
          (stdout "mandir:=~a\n" mandir)
          (stdout "datadir:=~a\n" datadir)
          (stdout "moduledir:=~a\n" moduledir)
          (stdout "sysconfdir:=~a\n" sysconfdir)

          (stdout "build:=~a\n" build-type)
          (stdout "ARCH:=~a\n" arch)
          (stdout "host:=~a\n" %host-type)
          (stdout "build:=~a\n" build-type)

          (for-each (lambda (o)
                      (stdout "~a:=~a\n" (variable-name o) (or (dependency-file-name o) "")))
                    deps)
          (stdout "GUILE_EFFECTIVE_VERSION:=~a\n" (effective-version))

          (when disable-silent-rules?
            (stdout "BUILD_DEBUG:=1\n"))

          (for-each (lambda (o)
                      (stdout "~a:=~a\n" o (or (getenv o) "")))
                    '(
                      "CFLAGS"
                      "CC32_CFLAGS"
                      "HEX2FLAGS"
                      "M1FLAGS"
                      "CC32_CFLAGS"
                      "MES_CFLAGS"
                      ))))

      (let ((pairs `(("@srcdir@" . ,abs-top-srcdir)
                     ("@abs_top_srcdir@" . ,abs-top-srcdir)
                     ("@abs_top_builddir@" . ,abs-top-builddir)
                     ("@top_builddir@" . ,top-builddir)
                     ("@top_builddest@" . ,top-builddest)
                     ("@BASH@" . ,(file-name "bash" deps))
                     ("@GUILE@" . ,(file-name "guile" deps))
                     ("@guile_site_dir@" . ,guile-site-dir)
                     ("@guile_site_ccache_dir@" . ,guile-site-ccache-dir)
                     ("@VERSION@" . ,VERSION)
                     ("mes/module/" . ,(string-append moduledir "/")))))
        (for-each (lambda (o)
                    (let* ((src (srcdir-relative o))
                           (target (string-drop-right o 3))
                           (target (if (not (string-prefix? "build-aux/" target)) target
                                       (string-drop target (string-length "build-aux/")))))
                      (substitute src pairs #:target target)))
                  '(
                    "build-aux/pre-inst-env.in"
                    "mes/module/mes/boot-0.scm.in"
                    "scripts/mescc.in"
                    ))
        (when (not (equal? srcdir "."))
          (substitute (string-append srcdir "/build-aux/GNUmakefile.in")
                      pairs
                      #:target "GNUmakefile")
          (system (string-append "cd mes/module/mes && ln -sf " abs-top-srcdir "/mes/module/mes/*.mes ."))))
      (chmod "pre-inst-env" #o755)
      (chmod "scripts/mescc" #o755)
      (let ((make (and=> (file-name "make" deps) basename)))
        (format (current-output-port)
                "\nRun:
  ~a            to build mes
  ~a help       for help on other targets\n"
                (or make "./build.sh")
                (or make "./build.sh"))))))