;;;; srfi-29-install.scm
;;;; Kon Lovett, Oct '19

;; Issues
;;

(declare
  (bound-to-procedure ##sys#check-syntax ##sys#signal-hook))

(module srfi-29-install

(;export
  system-bundle-directory
  install-bundle)

(import scheme utf8
  (chicken base)
  (chicken type)
  (chicken syntax)
  (chicken platform)
  (chicken pathname)
  (chicken file)
  (chicken process-context)
  (srfi 1)
  utf8-srfi-13
  (only type-errors-basic error-argument-type warning-argument-type))

(define-type pathname string)

(define-type locale-item (or false symbol))

;NOTE more restrictive than code (accepts *)
(define-type locale-item* (or locale-item string integer))

(: system-bundle-directory (#!optional pathname -> pathname))
(: install-bundle (locale-item* #!rest (list-of locale-item*) -> void))

;;; Dependency Neurosis

;;(only miscmacros define-parameter

(define-syntax define-parameter
  (syntax-rules ()
    ((define-parameter name value guard)
     (define name (make-parameter value guard)))
    ((define-parameter name value)
     (define name (make-parameter value)))
    ((define-parameter name)
     (define name (make-parameter (void))))))

;;(only numeric-macros one?)

(define-syntax one? (syntax-rules () ((one? ?n) (= 1 ?n))))

;;(only moremacros ->boolean define-warning-parameter)

(define-syntax ->boolean (syntax-rules () ((->boolean ?obj) (and ?obj #t))))

(import-for-syntax (only (chicken string) conc))

(define-for-syntax (make-identifier . elts)
  (string->symbol (apply conc (map strip-syntax elts))) )

(define (*warning-argument-type loc obj nam) (warning-argument-type loc obj nam))

(define-syntax warning-guard
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'warning-guard frm '(_ symbol symbol . _))
      (let ((_lambda (rnm 'lambda))
            (_if (rnm 'if))
            (_let (rnm 'let))
            (_begin (rnm 'begin))
            (_*warning-argument-type (rnm '*warning-argument-type))
            (_arg (rnm 'arg))
            (?getnam (cadr frm))
            (?typnam (caddr frm))
            (?body (cdddr frm)) )
        (let ((predname (symbol-append (strip-syntax ?typnam) '?))) ;inject
          `(,_lambda (,_arg)
            (,_if (,predname ,_arg)
                  ;`obj' is visible
                  (,_let ((obj ,_arg))
                    ,@?body
                    obj )
                  (,_begin
                    (,_*warning-argument-type ',?getnam ,_arg ',?typnam)
                    (,?getnam) ) ) ) ) ) ) ) )

(define-syntax define-warning-parameter
  (syntax-rules ()
    ((define-warning-parameter ?name ?init ?typnam ?body0 ...)
      (define-parameter ?name ?init (warning-guard ?name ?typnam ?body0 ...)) ) ) )

;;; Utilities

(cond-expand
  #; ;4 testing
  (chicken-5.4
    (define egg-data-path include-path) )
  ((or chicken-5.3 chicken-5.2 chicken-5.1 chicken-5.0)
    (define egg-data-path (lambda () (list (chicken-home)))) )
  (else
    (define egg-data-path include-path) ) )

;
(include-relative "locale-item")

#; ;UNUSED
(define-check+error-type locale-item)

;; Simple type error report

(define (sh:error-type loc obj #!optional typmsg)
  (let* ((msg "bad argument type")
         (msg (if typmsg (string-append msg "; not a " typmsg) msg)) )
    (##sys#signal-hook #:type-error loc msg obj) ) )

(cond-expand
  (windows
    ;(define-constant EXECUTABLE-EXTN "exe")
    (define-constant DIRECTORY-SEP "\\") )
  (else
    ;(define-constant EXECUTABLE-EXTN #f)
    (define-constant DIRECTORY-SEP "/") ) )

;; File Mode Support

(cond-expand
  (can-set-file-permissions
    ;FIXME
    (define (sudo-required?) #f)

    ;perm is a symbol, ex: 'a+r
    (define (file-chmod/sudo pn perm)
      (cond-expand
        (windows
          (void) )
        (else
          (run (,(if (sudo-install) "sudo chmod" "chmod") ,perm ,(shellpath pn))) ) ) )

    (define perm:a+r (bitwise-ior perm/irusr perm/irgrp perm/iroth))
    (define perm:a+x (bitwise-ior perm/ixusr perm/ixgrp perm/ixoth))
    (define perm:a+rx (bitwise-ior perm:a+r perm:a+x))

    (define (file-chmod/internal pn perm)
      (cond-expand
        (windows
          (void) )
        (else
          ;(import synch-dynexn)
          (let* ((perm (symbolic->unix-permissions perm))
                 (fn (file-open pn open/rdonly perm)) )
            (set! (file-permissions fn) perm)
            (file-close fn) ) ) ) )

    (define (file-chmod pn perm)
      ((if (sudo-required?) file-chmod/sudo file-chmod/internal) pn perm)) )
  (else
    (define (file-chmod pn perm) (void)) ) )

;;

;required by warning-parameter system-bundle-directory

(: pathname? (* -> boolean : pathname))

(define (pathname? obj)
  (and (string? obj)
       (let-values (((dir fil ext) (decompose-pathname obj)))
         ;ext w/o dir/fil indicates a *nix "hidden" file (too broad for Windows?)
         (->boolean (or dir fil ext)) ) ) )

(define (directory-separator) DIRECTORY-SEP)

(define (directory-separator? obj)
  (string=? (directory-separator) (->string obj)) )

(define (trim-directory-separator dir)
  (if (not (string-suffix? (directory-separator) dir)) dir
      (string-drop-right dir (string-length (directory-separator))) ) )

;FIXME caller must re-check directory, either predicate or open failure
(define (find-home-directory bn #!optional (dirs (egg-data-path)) (defdir "."))
  (let loop ((dirs dirs))
    (if (null? dirs)
        ;then not found in the known install locations, punt
        (make-pathname defdir bn)
        ;else try this dir then any remaining
        (let ((pn (make-pathname (car dirs) bn)))
          (if (directory-exists? pn) pn
              (loop (cdr dirs))) ) ) ) )

(define (make-directory-name dir)
  (let ((dir (if (atom? dir) (->string dir) (map ->string dir))))
    ;Ensures no trailing directory separator.
    (cond ((string? dir)
            (trim-directory-separator dir) )
          ((pair? dir)
            (trim-directory-separator
              (make-pathname (take dir (sub1 (length dir))) (last dir))) )
          (else
            (sh:error-type 'make-directory-name dir) ) ) ) )

;; System bundles are here:

(define-constant DEFAULT-BUNDLE-DIR "srfi-29-bundles")

;Within the bundle directory the structure
;is [<language> [<country> [<details>...]]] (package-name).

(define DEFAULT-SYSTEM-BUNDLES (find-home-directory DEFAULT-BUNDLE-DIR))

;; Filename Support

(define (make-bundle-pathname #!optional spec)
  (if (or (not spec) (null? spec))
      (system-bundle-directory)
      (make-directory-name (cons (system-bundle-directory) spec)) ) )

;

(define (check-system-bundle-directory)
  (unless (directory-exists? (system-bundle-directory))
    (error "missing bundles directory; please re-install SRFI-29") ) )

(define (ensure-srfi-29-bundle-perms spec #!optional (mod 'a+rx))
  (when spec
    (let loop ((dn (make-bundle-pathname)) (nms spec))
      (unless (null? nms)
        (let ((dn (make-directory-name (cons dn `(,(car nms))))))
          (file-chmod dn mod)
          (loop dn (cdr nms)) ) ) ) ) )

(define (create-bundle-directory spec)
  (let ((dir (make-bundle-pathname spec)))
    ;directory perms are system
    (create-directory dir #t)
    (ensure-srfi-29-bundle-perms spec)
    ;result directory pathname
    dir ) )

;;; Public

;; Where

(define-warning-parameter system-bundle-directory DEFAULT-SYSTEM-BUNDLES pathname)

;; SRFI-29 Bundle Support

(define (install-bundle nam . spec)
  (check-system-bundle-directory)
  (let* ((nam (->locale-item nam))
         (spec (map ->locale-item spec))
         (dir (create-bundle-directory spec))
         ;explicit curdir ('.') because problems in the past.
         (from (make-pathname (cons "." spec) nam))
         (to (make-pathname dir nam)) )
    (copy-file from to #t) )
  ;no result
  (void) )

) ;module srfi-29-install