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


;;; Release 4 Only!

(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 . en)
  (make-pathname #f (->string bn) (and (not (null? en)) (->string (car en)))) )

(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*
        (let ((dir (append (list *srfi-29-bundles-directory*) (take spec (sub1 (length spec)))))
              (nam (last spec)))
          (make-pathname dir nam) ) ) )
  (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 ((bundle-dir (srfi-29-bundle-directory spec)))
        (unless (directory? bundle-dir) (create-directory/parents bundle-dir)) )
      (let* ((namstr (->string nam))
             (bundle-src (make-pathname (append '(".") spec) namstr))
             (bundle-dst (make-pathname (append (list *srfi-29-bundles-directory*) spec) namstr)))
        (copy-file bundle-src bundle-dst) ) ) ) )

;; 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) )

;;

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