;;;; 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)
(import (chicken base))
(import (chicken type))
(import (chicken syntax))
(import (chicken platform))
(import (chicken pathname))
(import (chicken file))
(import (srfi 1))
(import utf8)
(import utf8-srfi-13)
(import (only type-errors error-argument-type warning-argument-type))

;;; 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-syntax define-warning-parameter
  (syntax-rules ()
    ((define-warning-parameter ?name ?init ?typnam ?body0 ...)
      (define-parameter ?name ?init (warning-guard ?name ?typnam ?body0 ...)) ) ) )

(define-syntax warning-guard
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'warning-guard frm '(_ symbol symbol . _))
      (let (
        (?getnam (cadr frm))
        (?typnam (caddr frm))
        (?body (cdddr frm))
        (_lambda (rnm 'lambda))
        (_if (rnm 'if))
        (_begin (rnm 'begin))
        (_warning-argument-type (rnm 'warning-argument-type)) )
        (let (
          (predname (make-identifier (symbol->string ?typnam) "?")) )
          `(,_lambda (obj)
            (,_if (,predname obj)
              (,_begin
                ,@?body
                obj)
              (,_begin
                (,_warning-argument-type ',?getnam obj ',?typnam)
                (,?getnam) ) ) ) ) ) ) ) )

;;; Utilities

(define (->symbol obj) (string->symbol (->string obj)))

(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

#|
#; ;UNUSED
;mod is a symbol, ex: 'a+r
(define (file-chmod pn mod)
  (cond-expand
    (windows
      (void) )
    (else
      (run (,(if (sudo-install) "sudo chmod" "chmod") ,mod ,(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 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-type pathname string)

(: pathname? (* -> boolean : string))
(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 (string-suffix? (directory-separator) dir)
    (string-drop-right dir (string-length (directory-separator)))
    dir ) )

(define (make-home-pathname bn)
  (make-pathname (chicken-home) bn) )

(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 (make-home-pathname 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)) ) )

;

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

;#; ;UNUSED
(define (ensure-srfi-29-bundle-chmod 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))))))
          #; ;No chmod "eager"
          (file-chmod dn mod)
          (loop dn (cdr nms)) ) ) ) ) )

(define (create-bundle-directory spec)
  (let (
    (dir (make-bundle-pathname spec)) )
    ;#; ;Permissions ?
    (create-directory dir #t)
    #; ;No chmod "eager"
    (ensure-srfi-29-bundle-chmod spec)
    ;
    dir ) )

;;;

;; Where

;(: system-bundle-directory (#!optional pathname -> (or void pathname)))
(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)) )
    (let (
      ;explicit curdir ('.') because problems in the past.
      (from (make-pathname (cons "." spec) nam))
      (to (make-pathname dir nam)) )
      (copy-file from to #t)
      #; ;No chmod "lazy"
      (file-chmod to 'a+r) ) ) )

) ;module srfi-29-install