;;;; setup-helper.scm -*- Hen -*-
;;;; Kon Lovett, Mar '09


;;; Release 4 Only!
(use setup-api) ;; needed for required-chicken-version
(required-chicken-version 4)


;;; Extension Information

(define (verify-extension-name nam)
  (let ((extnam (->string nam)))
    (unless (string=? extnam (extension-name))
      (error "unexpected extension-name" extnam (extension-name)) ) ) )


;;; Support

;; Filename Support

(define (filename bn #!optional en) (make-pathname #f (->string bn) (and en (->string en))))

(define (make-directory dir)
  (cond ((string? dir)  dir)
        ((symbol? dir)  (symbol->string dir))
        ((pair? dir)
          (let ((len (length dir)))
            (if (= 1 len) (->string (car dir))
                (make-pathname (map ->string (take dir (sub1 len))) (->string (last dir))) ) ) )
        (else
          (warning 'make-directory "unknown argument" dir) ) ) )

(define (document-filename bn) (filename bn "html"))

(define (source-filename bn) (filename bn "scm"))

(define (shared-library-filename bn) (filename bn ##sys#load-library-extension))

(define (shared-filename bn) (filename bn ##sys#load-dynamic-extension))

(define (static-library-filename bn) (filename bn "a"))

(define (static-filename bn) (filename bn "o"))

(define (import-filename bn) (filename bn "import"))

(define (source-import-filename bn) (source-filename (import-filename bn)))

(define (shared-import-filename bn) (shared-filename (import-filename bn)))

(define (inline-filename bn) (filename bn "inline"))

(define (program-filename bn) (filename bn (and (eq? 'windows (software-type)) "exe")))

(define (make-repository-pathname bn) (make-pathname (repository-path) bn))

;; File Support

(define (copy-file-to-directory fn dn) (copy-file fn (make-pathname dn fn)))

(define (copy-to-repository fn) (copy-file-to-directory fn (repository-path)))

(define (copy-to-home fn) (copy-file-to-directory fn (chicken-home)))

;; SRFI-29 Bundle Support

(define install-srfi-29-bundle)
(let ((*srfi-29-bundles-directory* (make-repository-pathname "srfi-29-bundles")))
  (define (srfi-29-bundle-directory spec)
    (if (null? spec) *srfi-29-bundles-directory*
        (make-directory (append (list *srfi-29-bundles-directory*) spec)) ) )
  (set! install-srfi-29-bundle
    (lambda (nam . spec)
      (unless (directory? *srfi-29-bundles-directory*)
        (error "missing SRFI-29 bundles directory; please install SRFI-29") )
      (let* ((spec (map ->string spec))
             (nam (->string nam))
             (dir (srfi-29-bundle-directory spec)) )
        (copy-file (make-pathname (append '(".") spec) nam)
                   (make-pathname dir nam)
                   #t) ) ) ) )

;; Compile Support

(define default-static-compile-options (make-parameter '(-c -optimize-level 2 -debug-level 1)))
(define default-shared-compile-options (make-parameter '(-shared -optimize-level 2 -debug-level 1)))
(define default-import-compile-options (make-parameter '(-shared -optimize-level 3 -debug-level 0)))

(define (compile-static nam #!key (options '()) inline?)
  (compile
    ,(source-filename nam)
    ,@(default-static-compile-options)
    -unit ,nam
    ,@(if (memq '-output-file options) '() `(-output-file ,(static-filename nam)))
    ,@(if inline? `(-emit-inline-file ,(inline-filename nam)) '())
    ,@options) )

(define (compile-shared nam #!key (options '()) inline?)
  (compile
    ,(source-filename nam)
    ,@(default-shared-compile-options)
    ,@(if (memq '-output-file options) '() `(-output-file ,(shared-filename nam)))
    ,@(if inline? `(-emit-inline-file ,(inline-filename nam)) '())
    ,@options) )

(define (compile-shared-module nam #!key (options '()) inline?)
  (compile
    ,(source-filename nam)
    ,@(default-shared-compile-options)
    ,@(if (memq '-output-file options) '() `(-output-file ,(shared-filename nam)))
    -emit-import-library ,nam
    ,@(if inline? `(-emit-inline-file ,(inline-filename nam)) '())
    ,@options)
  (compile
    ,(source-import-filename nam)
    ,@(default-import-compile-options)
    -output-file ,(shared-import-filename nam)) )

;; Install Support

(define default-static-install-options (make-parameter '()))
(define default-shared-install-options (make-parameter '()))
(define default-shared-module-install-options (make-parameter '()))
(define default-shared+static-module-install-options (make-parameter '()))

(define (install-static-extension nam ver #!key (options '()) (files '()) output-file?)
  (install-extension nam
   `(,@(if output-file? '() `(,(static-filename nam))) ,@files)
   `(,@(default-static-install-options)
     (version ,ver)
     (static ,(static-filename nam))
     (documentation ,(document-filename nam))
     ,@options)) )

(define (install-shared-extension nam ver #!key (options '()) (files '()) output-file?)
  (install-extension nam
   `(,@(if output-file? '() `(,(shared-filename nam))) ,@files)
   `(,@(default-shared-install-options)
     (version ,ver)
     (documentation ,(document-filename nam))
     ,@options)) )

(define (install-shared-extension-module nam ver #!key (options '()) (files '()) output-file?)
  (install-extension nam
   `(,@(if output-file? '() `(,(shared-filename nam)))
     ,(shared-import-filename nam)
     ,@files)
   `(,@(default-shared-module-install-options)
     (version ,ver)
     (documentation ,(document-filename nam))
     ,@options)) )

(define (install-shared+static-extension-module nam ver
          #!key (options '()) (files '()) shared-output-file? static-output-file?)
  (install-extension nam
   `(,@(if shared-output-file? '() `(,(shared-filename nam)))
     ,(shared-import-filename nam)
     ,@(if static-output-file? '() `((static-filename nam)))
     ,@files)
   `(,@(default-shared+static-module-install-options)
     (version ,ver)
     (static ,(static-filename nam))
     (documentation ,(document-filename nam))
     ,@options)) )

;; Setup Support

(define (setup-static-extension nam ver
          #!key (compile-options '()) inline? (install-options '()) (files '()))
  (and-let* ((of (memq '-output-file compile-options)))
    (set! files (append files (list (cadr of)))) )
  (compile-static nam options: compile-options inline?: inline?)
  (install-static-extension nam ver options: install-options files: files) )

(define (setup-shared-extension nam ver
          #!key (compile-options '()) inline? (install-options '()) (files '()))
  (and-let* ((of (memq '-output-file compile-options)))
    (set! files (append files (list (cadr of)))) )
  (compile-shared nam options: compile-options inline?: inline?)
  (install-shared-extension nam ver options: install-options files: files) )

(define (setup-shared-extension-module nam ver
          #!key (compile-options '()) inline? (install-options '()) (files '()))
  (and-let* ((of (memq '-output-file compile-options)))
    (set! files (append files (list (cadr of)))) )
  (compile-shared-module nam options: compile-options inline?: inline?)
  (install-shared-extension-module nam ver options: install-options files: files) )

(define (setup-shared+static-extension-module nam ver
          #!key (shared-compile-options '()) shared-inline?
                (static-compile-options '()) static-inline?
                (install-options '()) (files '()))
  (compile-static nam options: static-compile-options inline?: static-inline?)
  (compile-shared-module nam options: shared-compile-options inline?: shared-inline?)
  (install-shared+static-extension-module nam ver options: install-options files: files) )

;; Empty "Conglomerate" Extension Support

(define (install-extension-tag nam ver) (install-extension nam '() `((version ,ver))))