#!/usr/bin/env gsi-script
;; -*- Scheme -*-

(define features
  '((libxml  . #f)
    (libyaml . #f)
    (zlib    . #t)
    (sqlite  . #t)
    (mysql   . #f)
    (lmdb    . #f)
    (leveldb . #f)))

(define (display-help)
  (display "Options:\n")
  (display "  --prefix=HOME      Set default GERBIL_HOME (environment variable still overrides)\n")
  (display "  --with-gambit=DIR  Set default location of Gambit\n")
  (newline)
  (display "Feature options:\n")
  (for-each (lambda (feature)
              (display "  --")
              (if (not (cdr feature))
                (display "enable-")
                (display "disable-"))
              (display (car feature))
              (display " ")
              (newline))
            features))

(define install-prefix #f)
(define gambit-prefix #f)

(define files-to-patch
  '("gerbil/compiler/driver.ss"
    "gerbil/boot/gx-init.scm"
    "gerbil/boot/gx-init-exe.scm"
    "gerbil/boot/gxi-init.scm"
    "gerbil/gxi"
    "gerbil/gxi-build-script"
    "gerbil/runtime/build-lib.scm"
    "gerbil/runtime/gx-gambc.scm"
    "install"
    "std/build-features.ss"
    "std/make.ss"))

(define (string-starts-with? s prefix)
  (let* ((prefix-len (string-length prefix)))
    (and (<= prefix-len (string-length s))
         (string=? prefix (substring s 0 prefix-len)))))

(define (string-contains? s find)
  (let ((find-len (string-length find)))
    (let loop ((i 0))
      (cond
       ((< (string-length s) (+ i find-len))
        #f)
       ((string=? find (substring s i (+ i find-len))))
       (else
        (loop (+ 1 i)))))))

(define (feedback-mid . message-bits)
  (display ">>> ")
  (for-each display message-bits)
  (newline))

(define (feedback-low . message-bits)
  (display "[*] ")
  (for-each display message-bits)
  (newline))

(define-record-type :patch
  (make-patch replacement prefix substrings)
  patch?
  (replacement patch-replacement)
  (prefix      patch-prefix)
  (substrings  patch-substrings))

(define (patch-prefix-matches-line? patch line)
  (string-starts-with? line (patch-prefix patch)))

(define (patch-substrings-match-line? patch line)
  (fold (lambda (substring answer)
          (and answer (string-contains? line substring)))
        #t
        (patch-substrings patch)))

(define (patch-matches-line? patch line)
  (and (patch-prefix-matches-line? patch line)
       (patch-substrings-match-line? patch line)))

(define (patch-apply patch line)
  (if (patch-matches-line? patch line)
    (patch-replacement patch)
    line))

(define (die . message-bits)
  (parameterize ((current-output-port (current-error-port)))
    (display "*** ERROR; ")
    (for-each display message-bits)
    (newline))
  (exit 1))

(define (enable-feature! feature value)
  (let ((cell (assq (string->symbol feature) features)))
    (if (not cell)
      (die "Unknown feature: " feature))
    (set-cdr! cell value)))

(define (feature-patches)
  (map (lambda (feature)
         (define prefix
           (string-append "(enable " (symbol->string (car feature)) " "))
         (define replacement
           (string-append prefix (object->string (cdr feature)) ")\n"))
         (make-patch replacement prefix '()))
       features))

(define (shell-patches)
  (define (bin-path prefix prog)
    (if prefix
      (string-append prefix "/bin/" prog)
      prog))
  `(,(make-patch (string-append "GERBIL_GSI=\"" (bin-path gambit-prefix "gsi") "\"\n")
                 "GERBIL_GSI="
                 '())
    ,@(if install-prefix
        (list (make-patch (string-append "    GERBIL_HOME=\"" install-prefix "\"\n")
                          "    GERBIL_HOME="
                          '()))
        '())))

(define (gambit-gsc-path)
  (if gambit-prefix
    (string-append gambit-prefix "/bin/gsc")
    "gsc"))

(define (gerbil-gxc-path)
  (if install-prefix
    (string-append install-prefix "/bin/gxc")
    "gxc"))

(define (patches)
  (define (patch-define name value)
    (list
     (make-patch (string-append "(define " name " " (object->string value) ")\n")
                 (string-append "(define " name " ")
                 '())
     (make-patch (string-append "(def " name " " (object->string value) ")\n")
                 (string-append "(def " name " ")
                 '())))
  (append
    (feature-patches)
    (shell-patches)
    (patch-define "__gx#default-gerbil-home" install-prefix)
    (patch-define "default-gerbil-home" install-prefix)
    (patch-define "default-gambit-gsc" (gambit-gsc-path))
    (patch-define "default-gerbil-gxc" (gerbil-gxc-path))))

(define (parse-args args)
  (define (match-prefix s prefix)
    (if (string-starts-with? s prefix)
        (substring s (string-length prefix) (string-length s))
        #f))
  (let loop ((args args))
    (cond
     ((null? args)
      #f)
     ((match-prefix (car args) "--enable-") =>
      (lambda (feature)
        (enable-feature! feature #t)
        (loop (cdr args))))
     ((match-prefix (car args) "--disable-") =>
      (lambda (feature)
        (enable-feature! feature #f)
        (loop (cdr args))))
     ((string=? (car args) "--help")
      (display-help)
      (exit 0))
     ((match-prefix (car args) "--prefix=") =>
      (lambda (new-value)
        (set! install-prefix new-value)
        (loop (cdr args))))
     ((string=? (car args) "--prefix")
      (set! install-prefix (cadr args))
      (loop (cddr args)))
     ((match-prefix (car args) "--with-gambit=") =>
      (lambda (new-value)
        (set! gambit-prefix new-value)
        (loop (cdr args))))
     ((string=? (car args) "--with-gambit")
      (set! gambit-prefix (cadr args))
      (loop (cddr args)))
     (else
      (die "Unknown option: " (car args))))))

(define (for-each-line proc)
  (let loop ()
    (let ((line (read-line (current-input-port) #\newline #t)))
      (if (not (eof-object? line))
        (begin
         (proc line)
         (loop))))))


(define (patch-file filename patches)
  (define (apply-patches line)
    (fold patch-apply line patches))
  (feedback-low "Patching " filename)
  (let ((new-content (with-input-from-file filename
                       (lambda ()
                         (with-output-to-string
                           (lambda ()
                             (for-each-line
                               (lambda (line)
                                 (display (apply-patches line))))))))))
    (with-output-to-file filename
      (lambda ()
        (display new-content)))))

(define (display-config)
  (define (display-features enabled)
    (for-each (lambda (feature)
                (if (eq? (cdr feature) enabled)
                  (feedback-mid (string-append "  " (symbol->string (car feature))))))
              features))
  (newline)
  (feedback-mid "Install location: " (or install-prefix "(none)"))
  (feedback-mid "Gambit location:  " (or gambit-prefix "(in path)"))
  (feedback-mid "Enabled features:")
  (display-features #t)
  (feedback-mid "Disabled features:")
  (display-features #f))

(define (main . args)
  (parse-args args)
  (display-config)
  (let ((patches (patches)))
    (for-each (lambda (filename)
                (patch-file filename patches))
              files-to-patch)))
