;;; bash.scm ---

;; Copyright (C) 2014 Dmitry Bogatov <Dmitry Bogatov <KAction@gnu.org>>

;; Author: Dmitry Bogatov <Dmitry Bogatov <KAction@gnu.org>>

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License
;; as published by the Free Software Foundation; either version 3
;; of the License, or (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(define-module (gnu bash)
  #:export ((bash-eval . eval))
  #:replace ((e-if . if))
  #:replace ((e-when . when))
  #:replace ((e-unless . unless)))
(use-modules (system foreign))
(use-modules (system ffi))
(use-modules (ice-9 match))
(use-modules (ice-9 format))
(use-modules (ice-9 curried-definitions))

(define-syntax-rule (define-public-from-c-code name)
  (begin
    (define name (false-if-exception (@ (gnu bash internal) name)))
    (export name)))

(define-public-from-c-code array->alist)
(define-public-from-c-code bind-dynamic-variable)

;; Since interface, provided by (system ffi) contains too much details
;; of Bash internals, we use this macro to provide more clean
;; interface.
;;
;; `define-override` works absolutely same as define*, but defines in body
;; `this-proc` symbol, referring to previous value of procedure variable.
(define-syntax define-override
  (lambda (x)
    (syntax-case x ()
      ((_ (name arg ...) stmt stmt* ...)
       (with-syntax ((this-proc (datum->syntax x 'this-proc)))
	 #'(define name
	     (let ((this-proc name))
	       (export name)
	       (lambda* (arg ...) stmt stmt* ...))))))))

(define* (pointer-increment ptr #:optional (offset (sizeof '*)))
  (make-pointer (+ (pointer-address ptr) offset)))

;; Flags is implementation detail, it is not actually useful for end-user,
;; so I save code and maintenance not decoding them.
(define-ffi-struct alias: ((string: name) (string: value) (int: flags)))

;; This is a bit tricky because of terminology fuss.
;; Address is, well, pointer to pointer to struct alias.
;; Pointer is, pointer to struct alias. See diagram, where
;; arrow means pointer dereferencing.
;;
;;  +-----------------+     	+---------+	   +----------------------+
;;  | address := argv |  --*>   | pointer |  --*>  + name | value | flags + (struct alias)
;;  +-----------------+         +---------+ 	   +----------------------+
;;
;;  +-----------------+     	+---------+	   +----------------------+
;;  |     address     |  --*>   | pointer |  --*>  + name | value | flags + (struct alias)
;;  +-----------------+         +---------+ 	   +----------------------+
;;
;;  ...
;;
;;  +-----------------+     	+---------+
;;  |     address     |  --*>   |   NULL  |
;;  +-----------------+         +---------+
(define (pointer->argv<alias> argv)
  (if (null-pointer? argv)
      '()
    (let loop ((address argv) (acc '()))
      (let ((pointer (dereference-pointer address)))
	(if (null-pointer? pointer)
	    acc
	  (loop (pointer-increment address)
		(cons (pointer->alias pointer) acc)))))))

(define-ffi-object argv<alias>:
  #:decoder pointer->argv<alias>
  #:free c-free)

(define-ffi all-aliases (-> #:alloc argv<alias>:))
(define-override (all-aliases)
  (define (alias->pair a)
    (match a
      (($ <struct-alias> name value) (cons name value))))
  (map alias->pair (this-proc)))


(define-ffi add-alias ((#:const string-like: name) (#:const string-like: value) -> void:))
(define-ffi get-alias-value ((#:const string-like: name) -> ?string:))
(export add-alias get-alias-value)

(define-ffi remove-alias ((#:const string-like: name) -> int:))
(define-override (remove-alias name)
  (let ((successfully-removed? (not {(this-proc name) = -1})))
    successfully-removed?))

(define-ffi delete-all-aliases (-> void:))
(define-ffi alias-expand ((#:const string-like: name) -> #:alloc string:))
(export alias-expand delete-all-aliases)

(define-extern (int: last-command-exit-value))
(define-syntax $? (identifier-syntax (last-command-exit-value)))
(export $?)

(define-ffi-mask eval-flags:
  ((nonint    #x001)
   (interact  #x002)
   (nohist    #x004)
   (nofree    #x008)
   (resetline #x010)
   (parseonly #x020)
   (nolongjmp #x040)))

;; It is unsafe, since at least following is true:
;;
;;  * If errexit is set, it segfaults
;;
;; For safe version see bash-eval.
(define-ffi unsafe-evalstring ((#:const string: string) (#:const string: from) eval-flags: -> int:)
  #:symbol "evalstring")

;; Force `nofree` flag, or Bash will attempt to free what it should not.
(define-override (unsafe-evalstring string from flags)
  (this-proc string from (cons 'nofree flags)))

(define (unsafe-format/eval . args)
  (unsafe-evalstring (apply format #f args) "(gnu bash)" '(nohist)))

(define (enable-option-argument opt)
  (format #f "-o ~a" opt))
(define (disable-option-argument opt)
  (format #f "+o ~a" opt))

(define (make-restore-shellopts-thunk options)
  (let* ((shellopts-string (get-string-value "SHELLOPTS"))
	 (shellopts (string-split shellopts-string #\:))
	 (shellopts-symbols (map string->symbol shellopts)))
    (define (option->set-argument opt)
      (if (member opt shellopts-symbols)
	  (enable-option-argument opt)
	(disable-option-argument opt)))
    (lambda ()
      (define saved-$? (last-command-exit-value))
      (unsafe-format/eval "set ~{~a ~}" (map option->set-argument options))
      (set! (last-command-exit-value) saved-$?))))

(define ((make-enable-shellopts-thunk options))
  (unsafe-format/eval "set ~{-o ~a ~}" options))

(define ((make-disable-shellopts-thunk options))
  (unsafe-format/eval "set ~{+o ~a ~}" options))

(define (call-with-shellopts options thunk)
  (dynamic-wind
    (make-enable-shellopts-thunk options)
    thunk
    (make-restore-shellopts-thunk options)))

(define (call-without-shellopts options thunk)
  (dynamic-wind
    (make-disable-shellopts-thunk options)
    thunk
    (make-restore-shellopts-thunk options)))

(define-syntax-rule (with-shellopts (opt opt* ...) stmt stmt* ...)
  (call-with-shellopts '(opt opt* ...) (lambda () stmt stmt* ...)))

(define-syntax-rule (without-shellopts (opt opt* ...) stmt stmt* ...)
  (call-without-shellopts '(opt opt* ...) (lambda () stmt stmt* ...)))

(export call-with-shellopts call-without-shellopts)
(export with-shellopts without-shellopts)

;; Safe version of `unsafe-evalstring`.
(define (bash-eval str)
  (without-shellopts (errexit)
    (unsafe-evalstring str "(gnu bash)" '(nohist))))

(define-ffi-mask variable-flags:
  ((exported	#x0000001)	; export to environment
   (readonly	#x0000002)	; cannot change
   (array	#x0000004)	; value is an array
   (function	#x0000008)	; value is a function
   (integer	#x0000010)	; internal representation is int
   (local	#x0000020)	; variable is local to a function
   (assoc	#x0000040)	; variable is an associative array
   (trace	#x0000080)	; function is traced with DEBUG trap
   (uppercase	#x0000100)	; word converted to uppercase on assignment
   (lowercase	#x0000200)	; word converted to lowercase on assignment
   (capcase	#x0000400)	; word capitalized on assignment
   (nameref	#x0000800)	; word is a name reference
   (invisible	#x0001000)	; cannot see
   (nounset	#x0002000)	; cannot unset
   (noassign	#x0004000)	; assignment not allowed
   (imported	#x0008000)	; came from environment
   (special	#x0010000)	; requires special handling
   (nofree	#x0020000)	; do not free value on unset
   (tempvar	#x0100000)	; variable came from the temp environment
   (propagate	#x0200000)))	; propagate to previous scope

(define-ffi-struct variable:
  ((string: name)
   (?string: value)
   ;; This field isn't used, so why waste effort on decoding it?
   (*: exportstr)
   ;; These two fields are very delicate and worth several days of
   ;; segfault debugging with no output, so they are handled in C.
   (*: dynamic-value)
   (*: assign-func)
   (variable-flags: attributes)
   (int: context)))

(define-ffi get-string-value ((#:const string: var-name) -> ?string:))
(define-ffi find-variable ((#:const string: name) -> ?variable:))
(define-ffi bind-variable
  ((#:const string: name) (#:const string: value) (variable-flags: flags)
    -> variable:))
(define-ffi bind-global-variable
  ((#:const string: name) (#:const string: value) (variable-flags: flags)
   -> variable:))
(define-ffi quote-escapes ((#:const string: str) -> #:alloc string:))
(define (show x)
  (format #f "~a" x))
(define quote-show (compose quote-escapes show))

(define (args->eval-string args)
  (string-join (map quote-show args) " "))

(define-public exception-on-error (make-parameter #f))

(define (eval-args args)
  (define eval-str (args->eval-string args))
  (define result (zero? (bash-eval eval-str)))
  (when (and (not result) (exception-on-error))
    (error 'bash-command-error eval-str (last-command-exit-value)))
  result)

(define-syntax-rule (e-if test then else)
  (if (parameterize ((exception-on-error #f)) test) then else))
(define-syntax-rule (e-when test stmt stmt* ...)
  (when (parameterize ((exception-on-error #f)) test) stmt stmt* ...))

(define-syntax-rule (e-unless test stmt stmt* ...)
  (unless (parameterize ((exception-on-error #f)) test) stmt stmt* ...))

(define (capture-output args)
  (define eval-str (args->eval-string args))
  (bash-eval (format #f "SCM_OUTPUT=$(~a)" eval-str))
  (unless (zero? (last-command-exit-value))
    (error 'bash-command-error eval-str (last-command-exit-value)))
  (get-string-value "SCM_OUTPUT"))

(define ($-hash-reader _unused port)
  (define (skip-chars pred port)
    (define current-char (read-char port))
    (when (eof-object? current-char)
      (error 'read-error 'premature-EOF))
    (if (pred current-char)
	(skip-chars pred port)
      current-char))
  (define char-after (skip-chars char-whitespace? port))
  (case char-after
    ((#\?) '((@@ (gnu bash) last-command-exit-value)))
    (else
     (unread-char char-after port)
     (let ((sexp (read port)))
       (case char-after
	 ((#\") `((@@ (gnu bash) bash-eval) ,sexp))
	 ((#\[)  (list '(@@ (gnu bash) eval-args)
		       (list 'quasiquote sexp)))
	 ((#\()  (list '(@@ (gnu bash) capture-output)
		       (list 'quasiquote sexp)))
	 (else (list '(@@ (gnu bash) $) (list 'quote sexp))))))))

(read-hash-extend #\$ $-hash-reader)

(define ($-ref name)
  (get-string-value (show name)))

(define ($-set name value)
  (bind-variable (show name) (show value) '()))

(define-public $ (make-procedure-with-setter $-ref $-set))

(define-public bind-scm-function
  (let ()
    (define *funcs* (make-hash-table))
    (define special-varname 'SCM_FUNCTIONS_MAGIC_VARIABLE)
    (define (special-var-thunk)
      (define cur-func-symbol (string->symbol ($ 'FUNCNAME)))
      (define thunk (hashq-ref *funcs* cur-func-symbol))
      (catch #t
	(lambda ()
	  (define retval (thunk))
	  (if (integer? retval)
	      (format #f "~a" retval)
	    "0"))
	(lambda (key . args)
	  (print-exception (current-error-port) #f key args)
	  "41")))

    (bind-dynamic-variable special-varname special-var-thunk)
    ;; Problem is that in dynamic variable handler I have no access to
    ;; dollar variables. Quick and dirty solution is just save $@ into
    ;; some other array. Yeah, global variables are evil, but it saves
    ;; load of code to maintain and debug.
    (lambda (symbol thunk)
      (hashq-set! *funcs* symbol thunk)
      (unsafe-format/eval
       "function ~a {
            SCM_ARGS=($@)    ;
            local retval=$~a ;
            unset SCM_ARGS   ;
            return $retval   ;
       }"
       symbol special-varname))))

(export define-bash-function)
(define-syntax-rule (define-bash-function (fn-name arg ...) stmt stmt* ...)
  (begin
    (define (fn-name arg ...)
      stmt stmt* ...)
    (bind-scm-function
     'fn-name
     (lambda ()
       (define bash-args (map cdr (array->alist 'SCM_ARGS)))
       (match bash-args
	 ((arg ...) (fn-name arg ...))
	 (_ (scm-error
	     'wrong-number-of-args
	     (symbol->string 'fn-name)
	     "scm-function called from Bash with args ~A failed to match signature ~A"
	     (list bash-args '(arg ...))
	     #f)))))))