;;; Gash --- Guile As SHell
;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
;;; Copyright © 2018, 2019, 2024 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; The careful invocation of 'seclocale' was taken from the
;;; 'module/ice-9/top-repl.scm' file in GNU Guile, which has the
;;; following copyright notice:
;;;
;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
;;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2013 Free
;;; Software Foundation, Inc.
;;;
;;; This file is part of Gash.
;;;
;;; Gash 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.
;;;
;;; Gash 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 Gash.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gash gash)
  #:use-module (gash compat)
  #:use-module (gash config)
  #:use-module (gash environment)
  #:use-module (gash eval)
  #:use-module (gash parser)
  #:use-module (gash repl)
  #:use-module (ice-9 buffered-input)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 local-eval)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-26)
  #:export (main))

(eval-when (expand load eval)
  (catch #t
    (lambda _ (use-modules (ice-9 readline)))
    (lambda (key . args)
      (use-modules (gash readline)))))

;; This is done automatically since Guile 2.2.
(if-guile-version-below (2 2 0)
  (and (defined? 'setlocale)
       (catch 'system-error
         (lambda ()
           (setlocale LC_ALL ""))
         (lambda (key subr fmt args errno)
           (format (current-error-port)
                   "warning: failed to install locale: ~a~%"
                   (strerror (car errno)))))))

(define (display-help)
  (display (string-append "\
Usage: gash [OPTION]... [FILE]...
  or gash [OPTION]...

Options:
  -c, --command=STRING  Evaluate STRING and exit
  -e, --errexit         Exit upon error
  -h, --help            Display this help
  -p, --parse           Parse the shell script and print the parse tree
  -v, --version         Display the version
  -x, --xtrace          Print simple command trace
")))

(define (display-version)
  (display (string-append "
Gash " %version "
Copyright (C) 2016-2019 the Gash authors
License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.
")))

(define (get-history-file)
  "Lookup the location of the history file from the system environment.
If the location cannot be determined, return @code{#f}."
  (and-let* ((config-home (or (getenv "XDG_CONFIG_HOME")
                              (and-let* ((home (getenv "HOME")))
                                (string-append home "/.config")))))
    (string-append config-home "/gash-history")))

(define (main args)
  (let ((thunk
         (lambda ()
           (let* ((option-spec '((command (single-char #\c) (value #t))
                                 (errexit (single-char #\e))
                                 (help (single-char #\h))
                                 (parse (single-char #\p))
                                 (version (single-char #\v))
                                 (xtrace (single-char #\x))))
                  (args (take-while (negate (cut equal? <> "--")) args))
                  (options (getopt-long args option-spec #:stop-at-first-non-option #t))
                  (command (option-ref options 'command #f))
                  (opt? (lambda (name) (lambda (o) (and (eq? (car o) name) (cdr o)))))
                  (help? (option-ref options 'help #f))
                  (parse? (option-ref options 'parse #f))
                  (version? (option-ref options 'version #f))
                  (files (option-ref options '() '())))
             (setopt! 'errexit (option-ref options 'errexit #f))
             (setopt! 'xtrace (option-ref options 'xtrace #f))
             (cond
              (help? (display-help))
              (version? (display-version))
              (command (if (null? files)
                           (set-program-arguments (list (car (program-arguments))))
                           (set-program-arguments files))
                       (call-with-input-string command
                         (lambda (port)
                           (exit (run-repl port parse?)))))
              ((pair? files)
               (let ((script (car files)))
                 (set-program-arguments files)
                 (call-with-input-file script
                   (lambda (port)
                     (exit (run-repl port parse?))))))
              ((isatty? (current-input-port))
               (let* ((history-file (get-history-file))
                      (thunk (lambda ()
                               (let loop ((line (readline (prompt))))
                                 (when (not (eof-object? line))
                                   (let ((ast (call-with-input-string line
                                                (lambda (port) (read-sh port)))))
                                     (when (and ast
                                                (not (string-null? line)))
                                       (unless parse?
                                         (eval-sh ast))
                                       (add-history line)
                                       (reap-child-processes!))
                                     (loop (let ((previous (if ast "" (string-append line "\n")))
                                                 (next (readline (if ast (prompt) "> "))))
                                             (if (eof-object? next) next
                                                 (string-append previous next))))))))))
                 (clear-history)
                 (when history-file
                   (read-history history-file))
                 (with-readline-completion-function completion thunk)
                 (when history-file
                   (write-history history-file))
                 (newline)))
              (else (exit (run-repl (current-input-port) parse?))))))))
    (thunk)))

(define prompt
  (let* ((l (string #\001))
         (r (string #\002))
         (e (string #\033))
         (user (or (getenv "USER") ""))
         (host (gethostname))
         (home (getenv "HOME")))
    (lambda ()
      (let* ((cwd (getcwd))
             (cwd (if (and home (string-prefix? home cwd))
                      (string-replace cwd "~" 0 (string-length home))
                      cwd)))
        (string-append
         l e "[01;32m" r user "@" host l e "[00m" r ":"
         l e "[01;34m" r cwd l e "[00m" r (if (zero? (getuid)) "# " "$ "))))))

(define (string-prefix s1 s2)
  (substring/read-only s1 0 (string-prefix-length s1 s2)))

(define next->file-completion (lambda () #f))
(define next->binary-completion (lambda () #f))

(define (isdir? path)
  (and (access? path F_OK) (eq? 'directory (stat:type (stat path)))))

(define (ls dir)
  (map (lambda (path)
         (if (isdir? (string-append dir path))
             (string-append path "/")
             path))
       (sort (filter (negate (cut string-every #\. <>))
                     (scandir (if (string-null? dir) (getcwd) dir))) string<?)))

(define (complete prefix list)
  (if (string-null? prefix) list
      (filter (cut string-prefix? prefix <>) list)))

(define (slash dir)
  (if (string-suffix? "/" dir) dir
      (string-append dir "/")))

(define (after-slash path)
  (let ((at (string-index-right path #\/)))
    (if at (string-drop path (+ 1 at))
        path)))


(define (file-name-completion text continue?)
  (if continue?
      (next->file-completion)
      (let* ((dir (slash (if (isdir? text) text (dirname text))))
             (listing (ls dir))
             (dir (if (string=? "./" dir) "" dir))
             (completions (complete (after-slash text) listing)))
        (set! next->file-completion
          (lambda ()
            (if (null? completions)
                #f
                (let ((completion (car completions)))
                  (set! completions (cdr completions))
                  (string-append dir completion)))))
        (next->file-completion))))

(define (search-binary-in-path-completion text continue?)
  (if (not continue?)
      (let* ((paths (string-split (getenv "PATH") #\:))
             (binaries (apply append (filter identity (map scandir paths))))
             (completions (sort (filter (cut string-prefix? text <>) binaries) string<?)))
        (set! next->binary-completion (lambda ()
                                        (if (null? completions)
                                            #f
                                            (let ((completion (car completions)))
                                              (set! completions (cdr completions))
                                              completion))))
        (next->binary-completion))
      (next->binary-completion)))

(define (completion text continue?)
  (or (file-name-completion text continue?) (search-binary-in-path-completion text continue?)))
