gush -> plush

[Paul Graunke <ptg@cs.rice.edu>]

The gush project, which provided a simple unix shell running under guile, is
in limbo now.  The only thing interesting about it is that scheme "shell
scripts" are loaded into the same guile interpeter.  Their OS like
protections appear to be, "Please don't poke me too hard."  Here's a first
cut a replacing gush with a plt-scheme version, that hopefully does better
on the protections.  It's just something I hacked together in a few hours
this afternoon, so don't expect scsh.  It's more for interactive use with
plain old scheme programs for more complex tasks.

To try it out, save "fork" to ~/.plush/apps/fork and run
mzscheme -r plush.ss

Paul
(define-signature plush^ (plush help))

;(require-library "string.ss")
(require-library "function.ss")
(require-library "macro.ss")
;(require-library "pretty.ss")

; more here
; \ style line continuations
; quoting convetions
; redirection to or from files
; pipes
; background processes

; to exit run (exit)

; skip-whitespace : -> Void
(define (skip-whitespace)
  (let ([c (peek-char)])
    (unless (or (eof-object? c) (not (char-whitespace? c)))
      (read-char)
      (skip-whitespace))))

; chop-string : Char String -> (listof String)
(define (chop-string separator s)
  (let ([p (open-input-string s)])
    (let extract-parts ()
      (cons (list->string
             (let part ()
               (let ([char (peek-char p)])
                 (cond
                   [(eof-object? char) null]
                   [else (cond
                           [(eq? separator char) null]
                           [else (read-char p) (cons char (part))])]))))
            (cond
              [(eof-object? (read-char p)) null]
              [else (extract-parts)])))))

; bin-search : (listof String) String -> (union String #f)
(define (bin-search path file)
  (or (and (absolute-path? file) (file-exists? file) file)
      (path-search path file)))

; path-search : (listof String) String -> (union String #f)
; more here - cacheing
(define (path-search path file)
  (ormap (lambda (dir)
           (let ([p (build-path dir file)])
             (and (file-exists? p) p)))
         path))

; Cache-line = (make-cache-line ((listof String) -> Void) Nat (-> Nat))
(define-struct cache-line (value time get-time))

(define app-cache (make-hash-table))

; app-search : (listof String) String ((listof String) -> Void) -> (union ((listof String) -> Void) #f)
(define (app-search path name plush-cmd)
  (and (relative-path? name)
       (let* ([app-name (string->symbol name)]
              [cached (hash-table-get app-cache app-name (lambda () #f))])
         (if (and cached (= (cache-line-time cached) ((cache-line-get-time cached))))
             (cache-line-value cached)
             (let ([app-file (path-search path name)])
               (and app-file
                    (let* ([update-time (lambda () (file-or-directory-modify-seconds app-file))]
                           [time (update-time)]
                           ; warning: race condition with load/cd vs modifying file
                           [app (safe-eval
                                 (lambda ()
                                   (parameterize ([current-namespace
                                                   (make-namespace 'keywords 'all-syntax 'all-globals)])
                                     (eval `(define plush-cmd ,plush-cmd))
                                     (load/cd app-file))))])
                      (hash-table-put! app-cache app-name (make-cache-line app time update-time))
                      app)))))))

; safe-eval : (-> a) -> a
; more here - have a way to shut the custodian down
; we need a way to tell if any of the custodian's threads are still alive
(define (safe-eval thunk)
  (with-handlers ([void (lambda (exn)
                          (printf "child died: ~s" (if (exn? exn) (exn-message exn) exn)))])
    (parameterize ([exit-handler (lambda _ (error (format "~s" _)))]
                   [current-custodian (make-custodian)])
      (thunk))))

(define HOME (find-system-path 'home-dir))

(define (plush)
  (let ([app-path (list (build-path HOME ".plush" "apps"))]
        [path (path-list-string->path-list (getenv "PATH") null)])
    (let repl ()
      (printf "plush> ")
      (let ([line (read-line)])
        (cond
          [(eof-object? line) (void)]
          [else
           (let plush-cmd ([command (filter (lambda (s) (< 0 (string-length s)))
                                            (chop-string #\space line))])
             (cond
               [(null? command) (void)]
               [(string=? (car command) "cd")
                (cond
                  [(null? (cdr command)) (current-directory HOME)]
                  [(null? (cddr command)) (current-directory (cadr command))]
                  [else (printf "usage: cd [path]~n")])]
               [(app-search app-path (car command) plush-cmd)
                => (lambda (app)
                     (safe-eval (lambda () (app (cdr command)))))]
               [(bin-search path (car command))
                => (lambda (exec)
                     ; more here - check for #! interpreter
                     (apply system* exec (cdr command)))]
               [else (printf "command not found~n")]))
           (repl)])))))

(plush)
(lambda (args) (thread (lambda () (plush-cmd args))))