;;;; 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 utf8)
(import (chicken base))
(import (chicken type))
(import (only (chicken string) string-intersperse ->string))
(import (only (chicken platform) register-feature!))
(import (only (chicken process-context) get-environment-variable))
(import (only (chicken port) terminal-port? terminal-name terminal-size port-name))
(import (only (chicken process) process process-wait qs))
(import (only (chicken io) read-string))
(import (only (srfi 1) member every first second))
(import (only utf8-srfi-13 string-trim-both string-index string-take string-null? string-downcase))
(import (only utf8-srfi-14 list->char-set))
(import (only type-checks-basic define-check+error-type))
(import (only (check-errors sys) 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))

(: terminal-size? (* -> boolean : (list fixnum fixnum)))
(: check-terminal-port? (symbol * -> terminal-port))
(: terminal-info (#!optional output-port --> alist))
(: get-terminal-name (#!optional output-port --> (or false string)))
(: get-terminal-size (#!optional output-port --> (or false terminal-size)))
(: output-port-width ((or false output-port) #!optional terminal-length --> terminal-length))
(: output-port-height ((or false output-port) #!optional terminal-length --> terminal-length))
(: *output-port-width ((or false output-port) #!optional terminal-length --> terminal-length))
(: *output-port-height (output-port #!optional terminal-length --> terminal-length))
(: *get-terminal-name (output-port --> string))

(: shell-value-bound? ((or false string) -> (or false string)))
(: shell-value-true? ((or false string) (or false (list-of string)) -> boolean))
(: register-shell-value-feature! ((or false string) procedure -> (or false symbol)))
(: string-trim-string string)
(: string-trim-eol (string --> string))

(: qs* (string #!optional (or string char) -> string))
(: qs-literal (* -> string))
(: qs-string (* -> string))
(: qs-argument (* #!optional boolean (or string char) -> string))
(: qs-quasiquote (* --> string))
(: qs-unquote-splicing (* --> string))
(: qs-unquoted (string --> string))
(: qs-unquote (* #!optional boolean --> string))

(: environment-string (pair -> string))
(: environment-variables->environment-list (list -> list))
(: environment-variable-bound? (string -> (or false string)))
(: environment-variable-true? (string #!optional (or false (list-of string)) -> boolean))
(: register-environment-variable-feature! (string -> (or false symbol)))

(: get-commandline-result (string string -> string))
(: get-command-result (string #!rest -> string))
(: get-echo-result (#!rest -> string))
(: get-shell-variable (string -> string))
(: shell-variable-bound? (string -> (or false string)))
(: shell-variable-true? (string #!optional (or false (list-of string)) -> boolean))
(: register-shell-variable-feature! (string -> (or false symbol)))

;

(define (natural-fixnum? obj) (and (fixnum? obj) (not (negative? obj))))

(define (terminal-size? obj)
  (and (list? obj)
       (= 2 (length obj))
       (natural-fixnum? (first obj))
       (natural-fixnum? (second obj))) )

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

(define (check-terminal-port? loc obj)
  (and (terminal-port? (check-output-port loc obj))
       obj) )

;

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

;;

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

(define (get-terminal-name #!optional (port (current-output-port)))
  (and-let* ((port (check-terminal-port? 'get-terminal-name port)))
    (*get-terminal-name port) ) )

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

(define (output-port-width port #!optional (def TERMINAL-WIDTH))
  (if (check-terminal-port? 'output-port-width port)
      (*output-port-width port def)
      def ) )

(define (output-port-height port #!optional (def TERMINAL-HEIGHT))
  (if (check-terminal-port? 'output-port-height port)
      (*output-port-height port def)
      def ) )

(define (*output-port-width port #!optional (def TERMINAL-WIDTH))
  (let-values (((w _) (terminal-size port)))
    (if (zero? w) def w) ) )

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

(define (*get-terminal-name port)
  (if (terminal-port? port)
      (terminal-name port)
      (port-name port) ) )

;;

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

;;

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

(define (shell-value-bound? varval)
  (and-let* ((str varval)
             ((not (string-null? str))) )
    str ) )

(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=?) ) ) )

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

(define software-eol-string (list->string software-eol-sequence))

(define software-eol-length (string-length software-eol-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 "`")

(define (qs* str #!optional (delim DOUBLE-QUOTE))
  (let ((delim (qs-delimiter delim)))
    (string-append delim str delim) ) )

(define (qs-literal item)
  (qs-argument item #t SINGLE-QUOTE) )

(define (qs-string item)
  (qs-argument item #t DOUBLE-QUOTE) )

(define (qs-argument item #!optional literal? (delim DOUBLE-QUOTE))
        ;
        ;' item '
  (cond ((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)) ) )

(define (qs-quasiquote item)
        ;
        ;" item "
  (cond ((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) ) ) )

(define (qs-unquote-splicing item)
  (qs-unquote item #t) )

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

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

;;

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

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

;;

(define (environment-variable-bound? nam)
  (shell-value-bound? (get-environment-variable nam)) )

(define (environment-variable-true? nam #!optional truedat)
  (shell-value-true? (get-environment-variable nam) truedat) )

(define (register-environment-variable-feature! nam #!optional (filter identity))
  (register-shell-value-feature! (get-environment-variable nam) filter) )

;;

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

(define (get-command-result cmnd . args)
  (let ((line (string-intersperse (map qs-argument args) " ")))
    (get-commandline-result cmnd line) ) )

(define (get-echo-result . exps)
  (let ((res (apply get-command-result "echo" exps)))
    ;remove echo eol
    (string-trim-eol res) ) )

;;

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

(define (shell-variable-bound? name)
  (shell-value-bound? (get-shell-variable name)) )

(define (shell-variable-true? name #!optional truedat)
  (shell-value-true? (get-shell-variable name) truedat) )

(define (register-shell-variable-feature! name #!optional (filter identity))
  (register-shell-value-feature! (get-shell-variable name) filter) )

;;;

) ;module posix-utils