;;;; posix-utils.scm
;;;; Kon Lovett, Nov '10
;;;; Kon Lovett, Feb '18

;; Issues
;;

(module posix-utils

(;export
  ;
  terminal-info
  get-terminal-name get-terminal-size
  output-port-width output-port-height
  ;
  string-trim-eol software-eol-string
  ;
  qs* qs-literal qs-string qs-argument
  ;
  get-commandline-result
  get-command-result
  get-echo-result
  ;
  environment-string environment-variables->environment-list
  ;
  get-shell-variable
  ;
  environment-variable-bound?
  environment-variable-true?
  register-environment-variable-feature!
  ;
  shell-variable-bound?
  shell-variable-true?
  register-shell-variable-feature! )

(import scheme
  (chicken type)
  (chicken base)
  (only (chicken string) string-intersperse ->string)
  (only (chicken platform) register-feature!)
  (only (chicken process-context) get-environment-variable)
  (only (srfi 1) member every first second)
  (only (chicken port) terminal-port? terminal-name terminal-size port-name)
  (only (chicken process) process process-wait qs)
  (only (chicken io) read-string)
  (only (srfi 13) string-trim-both string-index string-take string-null? string-downcase)
  (only (srfi 14) list->char-set)
  (only type-checks define-check+error-type check-string check-output-port) )

;;

(define-type alist (or null (list-of pair)))

(define-type terminal-length fixnum)

(define-type terminal-port output-port)

(define-type terminal-size (list terminal-length terminal-length))

;

(: natural-fixnum? (* -> boolean : fixnum))
;
(define (natural-fixnum? obj)
  (and (fixnum? obj) (<= 0 obj)) )

(: terminal-size? (* -> boolean : (list fixnum fixnum)))
;
(define (terminal-size? obj)
  (and
    (list? obj)
    (= 2 (length obj))
    (natural-fixnum? (first obj))
    (natural-fixnum? (second obj))) )

(define-check+error-type terminal-size)

(: check-terminal-port? (symbol * -> terminal-port))
;
(define (check-terminal-port? loc obj #!optional var)
  (and
    (terminal-port? (check-output-port loc obj var))
    obj) )

;

(define-constant TERMINAL-WIDTH 80)
(define-constant TERMINAL-HEIGHT 25)

;;

(: terminal-info (#!optional output-port --> alist))
;
(define (terminal-info #!optional (port (current-output-port)))
  (if (not (check-terminal-port? 'terminal-info port))
    '()
    (let (
      (size (receive rect (terminal-size port) rect)) )
      `((name . ,(*get-terminal-name port))
        (width . ,(second size))
        (height . ,(first size))) ) ) )

(: get-terminal-name (#!optional output-port --> (or boolean string)))
;
(define (get-terminal-name #!optional (port (current-output-port)))
  (and-let* ((port (check-terminal-port? 'get-terminal-name port)))
    (*get-terminal-name port) ) )

(: get-terminal-size (#!optional output-port --> (or boolean terminal-size)))
;
(define (get-terminal-size #!optional (port (current-output-port)))
  (and-let* ((port (check-terminal-port? 'get-terminal-size port)))
    (receive rect (terminal-size port) rect) ) )

(: output-port-width ((or boolean output-port) #!optional terminal-length --> terminal-length))
;
(define (output-port-width port #!optional (def TERMINAL-WIDTH))
  (if (check-terminal-port? 'output-port-width port)
    (*output-port-width port def)
    def ) )

(: output-port-height ((or boolean output-port) #!optional terminal-length --> terminal-length))
;
(define (output-port-height port #!optional (def TERMINAL-HEIGHT))
  (if (check-terminal-port? 'output-port-height port)
    (*output-port-height port def)
    def ) )

(: *output-port-width ((or boolean output-port) #!optional terminal-length --> terminal-length))
;
(define (*output-port-width port #!optional (def TERMINAL-WIDTH))
  (let-values (((w _) (terminal-size port)))
    (if (zero? w) def w) ) )

(: *output-port-height (output-port #!optional terminal-length --> terminal-length))
;
(define (*output-port-height port #!optional (def TERMINAL-HEIGHT))
  (let-values (((_ h) (terminal-size port)))
    (if (zero? h) def h) ) )

;;

(define (qs-delimiter obj)
  (if (string? obj) obj (string obj)) )

;;

(define-constant *SHELL-TRUE-VALUES* '("y" "yes" "1"))

(: shell-value-bound? ((or boolean string) -> (or boolean string)))
;
(define (shell-value-bound? varval)
  (and-let* (
    (str varval)
    ((not (string-null? str))) )
    str ) )

(: shell-value-true? ((or boolean string) (or boolean (list-of string)) -> boolean))
;
(define (shell-value-true? varval truedat)
  (and-let* ((str varval))
    (let* (
      (truedat (or truedat *SHELL-TRUE-VALUES*))
      (str (string-trim-both str))
      (str (string-downcase str)) )
      (member str truedat string=?) ) ) )

(: register-shell-value-feature! ((or boolean string) procedure -> (or boolean symbol)))
;
(define (register-shell-value-feature! varval filter)
  (and-let* (
    (str (shell-value-bound? varval))
    (str (filter str)) )
    (let (
      (varsym (string->symbol str)) )
      (register-feature! varsym)
      varsym ) ) )

;;

(define software-eol-sequence
  (cond-expand
    (windows
     '(#\return #\newline))
    (unix
     '(#\newline))
    (else
     '(#\return)) ) )

(define char-set:software-eol (list->char-set software-eol-sequence))

(: string-trim-string string)
;
(define software-eol-string (list->string software-eol-sequence))

(define software-eol-length (string-length software-eol-string))

(: string-trim-eol (string --> string))
;
(define (string-trim-eol str)
  (let* (
    (end (string-length str))
    (start (- end software-eol-length))
    (index
      (and
        (<= 0 start) (< start end)
        ;order of multi-char sequences is not imposed !
        (string-index str char-set:software-eol start end))) )
    (if (not index)
      str
      (string-take str index) ) ) )

;;

(define-constant DOUBLE-QUOTE "\"" #;"\"")  ;editor unbalanced
(define-constant SINGLE-QUOTE "\'")
(define-constant BACK-QUOTE "`")

(: qs* (string #!optional (or string char) -> string))
;
(define (qs* str #!optional (delim DOUBLE-QUOTE))
  (let ((delim (qs-delimiter delim)))
    (string-append delim str delim) ) )

(: qs-literal (* -> string))
;
(define (qs-literal item)
  (qs-argument item #t SINGLE-QUOTE) )

(: qs-string (* -> string))
;
(define (qs-string item)
  (qs-argument item #t DOUBLE-QUOTE) )

(: qs-argument (* #!optional boolean (or string char) -> string))
;
(define (qs-argument item #!optional literal? (delim DOUBLE-QUOTE))
  (cond
    ;
    ;' item '
    ((and (not literal?) (pair? item) (eq? 'quote (car item)))
      (qs-argument (cadr item) #t SINGLE-QUOTE) )
    ;
    ;` item ... ` : quasi-interpret qs-argument
    ;   , - " item "
    ;   ,@ - " ->string(item) ... "
    ((and (not literal?) (pair? item) (eq? 'quasiquote (car item)))
      (qs-argument (qs-quasiquote (cadr item)) #t BACK-QUOTE) )
    ;
    ;< item >
    ((string? item)
      (qs* item delim) )
    ;
    ;< string(item) >
    (else
      (qs* (->string item) delim)) ) )

(: qs-quasiquote (* --> string))
;
(define (qs-quasiquote item)
  (cond
    ;
    ;" item "
    ((and (pair? item) (eq? 'unquote (car item)))
      (qs-unquote (cadr item)) )
    ;
    ;" item ... "
    ((and (pair? item) (eq? 'unquote-splicing (car item)))
      (qs-unquote-splicing (cadr item)) )
    ;
    ;' item '
    (else
      (qs-argument item #t SINGLE-QUOTE) ) ) )

(: qs-unquote-splicing (* --> string))
;
(define (qs-unquote-splicing item)
  (qs-unquote item #t) )

(: qs-unquoted (string --> string))
;
(define qs-unquoted (o ->string eval))

(: qs-unquote (* #!optional boolean --> string))
;
(define (qs-unquote item #!optional splicing?)
  (let* (
    (evaled
      (if (and splicing? (list? item))
        (string-intersperse (map qs-unquoted item) " ")
        (qs-unquoted item) ) ) )
    (qs-argument evaled #t DOUBLE-QUOTE) ) )

;;

(: environment-string (pair -> string))
;
(define (environment-string pare)
  (string-append (car pare) "=" (->string (cdr pare))) )

(: environment-variables->environment-list (list -> list))
;
(define (environment-variables->environment-list al)
  (map environment-string al) )

;;

(: environment-variable-bound? (string -> (or boolean string)))
;
(define (environment-variable-bound? nam)
  (shell-value-bound? (get-environment-variable nam)) )

(: environment-variable-true? (string #!optional (or boolean (list-of string)) -> boolean))
;
(define (environment-variable-true? nam #!optional truedat)
  (shell-value-true? (get-environment-variable nam) truedat) )

(: register-environment-variable-feature! (string -> (or boolean symbol)))
;
(define (register-environment-variable-feature! nam #!optional (filter identity))
  (register-shell-value-feature! (get-environment-variable nam) filter) )

;;

(: get-commandline-result (string string -> string))
;
(define (get-commandline-result cmnd line)
  (let ((in (void)) (out (void)) (pid (void)))
    (dynamic-wind
      (lambda ()
        (let ((cmndline (string-append (qs cmnd) " " line)))
          (set!-values (in out pid) (process cmndline)) ) )
      (lambda ()
        (let ((s (read-string #f in)))
          (if (eof-object? s) "" s)) )
      (lambda ()
        (close-input-port in)
        (close-output-port out) ) ) ) )

(: get-command-result (string #!rest -> string))
;
(define (get-command-result cmnd . args)
  (let ((line (string-intersperse (map qs-argument args) " ")))
    (get-commandline-result cmnd line) ) )

(: get-echo-result (#!rest -> string))
;
(define (get-echo-result . exps)
  (let ((res (apply get-command-result "echo" exps)))
    ;remove echo eol
    (string-trim-eol res) ) )

;;

(: get-shell-variable (string -> string))
;
(define (get-shell-variable name)
  (get-echo-result (string-append "$" name)) )

(: shell-variable-bound? (string -> (or boolean string)))
;
(define (shell-variable-bound? name)
  (shell-value-bound? (get-shell-variable name)) )

(: shell-variable-true? (string #!optional (or boolean (list-of string)) -> boolean))
;
(define (shell-variable-true? name #!optional truedat)
  (shell-value-true? (get-shell-variable name) truedat) )

(: register-shell-variable-feature! (string -> (or boolean symbol)))
;
(define (register-shell-variable-feature! name #!optional (filter identity))
  (register-shell-value-feature! (get-shell-variable name) filter) )

(: *get-terminal-name (output-port --> string))
;
(define (*get-terminal-name port)
  (if (terminal-port? port)
    (terminal-name port)
    (port-name port) ) )

;;;

) ;module posix-utils