Modularized anguish.
This commit is contained in:
parent
de319e38eb
commit
340917ce4c
148
anguish
148
anguish
|
@ -1,146 +1,12 @@
|
||||||
#!/usr/bin/guile \
|
#!/usr/bin/guile \
|
||||||
-e main -s
|
-e main -s
|
||||||
!#
|
!#
|
||||||
|
;; workaround:
|
||||||
(load "sh.peg.scm")
|
;; -e (@ (sh anguish) main) -s
|
||||||
(load "pipe.scm")
|
;; leads to:
|
||||||
|
;; ERROR: In procedure read:
|
||||||
(use-modules (ice-9 getopt-long))
|
;; ERROR: In procedure scm_i_lreadparen: #<unknown port>:1:3: end of file
|
||||||
(use-modules (ice-9 match))
|
|
||||||
(use-modules (ice-9 pretty-print))
|
|
||||||
(use-modules (ice-9 rdelim))
|
|
||||||
(use-modules (ice-9 readline))
|
|
||||||
(use-modules (ice-9 ftw))
|
|
||||||
|
|
||||||
(define (remove-shell-comments s)
|
|
||||||
(string-join (map
|
|
||||||
(lambda (s)
|
|
||||||
(let* ((n (string-index s #\#)))
|
|
||||||
(if n (string-pad-right s (string-length s) #\space 0 n)
|
|
||||||
s)))
|
|
||||||
(string-split s #\newline)) "\n"))
|
|
||||||
|
|
||||||
(define (builtin cmd)
|
|
||||||
(if (and (pair? cmd) (string? (car cmd)) (string=? (car cmd) "cd"))
|
|
||||||
(lambda () (chdir (cadr cmd)))
|
|
||||||
#f))
|
|
||||||
|
|
||||||
(define (transform ast)
|
|
||||||
(match ast
|
|
||||||
(('pipeline command) (transform command))
|
|
||||||
(('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands))))
|
|
||||||
(('simple-command ('word s)) (list s))
|
|
||||||
(('simple-command ('word s1) ('word s2)) (list s1 s2))
|
|
||||||
(('simple-command ('word s1) (list ('word s2) ...)) (cons s1 s2))
|
|
||||||
((('pipe _) command ...) (map transform command))
|
|
||||||
(((('pipe _) command) ...) (map transform command))
|
|
||||||
((_ o) (transform o))
|
|
||||||
(_ ast)))
|
|
||||||
|
|
||||||
(define (sh-exec ast)
|
|
||||||
(let ((cmd (transform ast)))
|
|
||||||
(if (builtin cmd)
|
|
||||||
((builtin cmd))
|
|
||||||
(if (and (pair? cmd) (eq? 'pipeline (car cmd)))
|
|
||||||
(pipeline (cdr cmd))
|
|
||||||
(apply system* cmd)))))
|
|
||||||
|
|
||||||
(define (prompt)
|
|
||||||
(let* ((esc (string #\033))
|
|
||||||
(CWD (getcwd))
|
|
||||||
(HOME (getenv "HOME"))
|
|
||||||
(cwd (if (string-prefix? HOME CWD)
|
|
||||||
(string-replace CWD "~" 0 (string-length HOME))
|
|
||||||
CWD)))
|
|
||||||
(string-append esc "[01;34m" cwd esc "[00m$ ")))
|
|
||||||
|
|
||||||
(define (redraw-current-line)
|
|
||||||
(dynamic-call (dynamic-func "rl_refresh_line"
|
|
||||||
(dynamic-link "libreadline.so"))
|
|
||||||
#f))
|
|
||||||
|
|
||||||
(define (filename-completion text state)
|
|
||||||
(if (not state)
|
|
||||||
(let ((completions (map car
|
|
||||||
(filter (lambda (entry) (string-prefix? text (car entry)))
|
|
||||||
(cddr (file-system-tree (getcwd)))))))
|
|
||||||
(cond ((< 1 (length completions)) (begin (newline)
|
|
||||||
(display (string-join completions " ")) (newline)
|
|
||||||
(redraw-current-line)
|
|
||||||
#f))
|
|
||||||
((= 1 (length completions)) (car completions))
|
|
||||||
(#t #f)))
|
|
||||||
#f))
|
|
||||||
|
|
||||||
(define (search-binary-in-path-completion text state)
|
|
||||||
(if (not state)
|
|
||||||
(let ((completions (map car
|
|
||||||
(filter (lambda (entry) (string-prefix? text (car entry)))
|
|
||||||
(cddr (file-system-tree "/bin"))))))
|
|
||||||
(cond ((< 1 (length completions)) (begin (newline)
|
|
||||||
(display (string-join completions " ")) (newline)
|
|
||||||
(redraw-current-line)
|
|
||||||
#f))
|
|
||||||
((= 1 (length completions)) (car completions))
|
|
||||||
(#t #f)))
|
|
||||||
#f))
|
|
||||||
|
|
||||||
(define (completion text state)
|
|
||||||
(or (filename-completion text state)
|
|
||||||
;(search-binary-in-path-completion text state)
|
|
||||||
))
|
|
||||||
|
|
||||||
(define (main args)
|
(define (main args)
|
||||||
(let* ((option-spec '((help (single-char #\h) (value #f))
|
(set! %load-path (cons (dirname (car args)) %load-path))
|
||||||
(parse (single-char #\p) (value #f))
|
((@ (sh anguish) main) args))
|
||||||
(version (single-char #\v) (value #f))))
|
|
||||||
(options (getopt-long args option-spec
|
|
||||||
#:stop-at-first-non-option #t ))
|
|
||||||
(help? (option-ref options 'help #f))
|
|
||||||
(parse? (option-ref options 'parse (null? #f)))
|
|
||||||
(version? (option-ref options 'version #f))
|
|
||||||
(files (option-ref options '() '()))
|
|
||||||
(run (lambda (ast) (if parse?
|
|
||||||
(pretty-print (list ast (transform ast)))
|
|
||||||
(sh-exec ast)))))
|
|
||||||
(cond
|
|
||||||
(help?
|
|
||||||
(display "\
|
|
||||||
anguish [options]
|
|
||||||
-h, --help Display this help
|
|
||||||
-p, --parse Parse the shell script and print the parse tree
|
|
||||||
-v, --version Display the version
|
|
||||||
"))
|
|
||||||
(version?
|
|
||||||
(display "
|
|
||||||
Anguish 0.1
|
|
||||||
Copryright (C) 2016 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com.
|
|
||||||
|
|
||||||
This is anguish, ANother GUIle SHell, or the feeling you might have
|
|
||||||
when your shell lacks a real programming language. Anguish is free
|
|
||||||
software and is covered by the GNU Public License, see COPYING for the
|
|
||||||
copyleft.
|
|
||||||
"))
|
|
||||||
((pair? files)
|
|
||||||
(let ((ast (parse
|
|
||||||
(remove-shell-comments
|
|
||||||
(read-string
|
|
||||||
(open-input-file
|
|
||||||
(car files)))))))
|
|
||||||
(run ast)))
|
|
||||||
(#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory"))
|
|
||||||
(thunk (lambda ()
|
|
||||||
(let loop ((line (readline (prompt))))
|
|
||||||
(if (not (eof-object? line))
|
|
||||||
(begin
|
|
||||||
(let ((ast (parse (remove-shell-comments line))))
|
|
||||||
(add-history line)
|
|
||||||
(run ast))
|
|
||||||
(loop (readline (prompt)))))))))
|
|
||||||
(activate-readline)
|
|
||||||
(clear-history)
|
|
||||||
(read-history HOME)
|
|
||||||
(with-readline-completion-function completion thunk)
|
|
||||||
;;(thunk)
|
|
||||||
(write-history HOME))
|
|
||||||
(newline)))))
|
|
||||||
|
|
|
@ -0,0 +1,146 @@
|
||||||
|
(define-module (sh anguish)
|
||||||
|
:use-module (ice-9 getopt-long)
|
||||||
|
:use-module (ice-9 match)
|
||||||
|
:use-module (ice-9 pretty-print)
|
||||||
|
:use-module (ice-9 rdelim)
|
||||||
|
:use-module (ice-9 readline)
|
||||||
|
:use-module (ice-9 ftw)
|
||||||
|
|
||||||
|
:export (main))
|
||||||
|
|
||||||
|
(use-modules ((sh pipe) :renamer (symbol-prefix-proc 'sh:)))
|
||||||
|
(use-modules ((sh peg) :renamer (symbol-prefix-proc 'sh:)))
|
||||||
|
|
||||||
|
(define (main args)
|
||||||
|
(let* ((option-spec '((help (single-char #\h) (value #f))
|
||||||
|
(parse (single-char #\p) (value #f))
|
||||||
|
(version (single-char #\v) (value #f))))
|
||||||
|
(options (getopt-long args option-spec
|
||||||
|
#:stop-at-first-non-option #t ))
|
||||||
|
(help? (option-ref options 'help #f))
|
||||||
|
(parse? (option-ref options 'parse (null? #f)))
|
||||||
|
(version? (option-ref options 'version #f))
|
||||||
|
(files (option-ref options '() '()))
|
||||||
|
(run (lambda (ast) (if parse?
|
||||||
|
(pretty-print (list ast (transform ast)))
|
||||||
|
(sh-exec ast)))))
|
||||||
|
(cond
|
||||||
|
(help?
|
||||||
|
(display "\
|
||||||
|
anguish [options]
|
||||||
|
-h, --help Display this help
|
||||||
|
-p, --parse Parse the shell script and print the parse tree
|
||||||
|
-v, --version Display the version
|
||||||
|
"))
|
||||||
|
(version?
|
||||||
|
(display "
|
||||||
|
Anguish 0.1
|
||||||
|
Copryright (C) 2016 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com.
|
||||||
|
|
||||||
|
This is anguish, ANother GUIle SHell, or the feeling you might have
|
||||||
|
when your shell lacks a real programming language. Anguish is free
|
||||||
|
software and is covered by the GNU Public License, see COPYING for the
|
||||||
|
copyleft.
|
||||||
|
"))
|
||||||
|
((pair? files)
|
||||||
|
(let ((ast (sh:parse
|
||||||
|
(remove-shell-comments
|
||||||
|
(read-string
|
||||||
|
(open-input-file
|
||||||
|
(car files)))))))
|
||||||
|
(run ast)))
|
||||||
|
(#t (let* ((HOME (string-append (getenv "HOME") "/.anguishistory"))
|
||||||
|
(thunk (lambda ()
|
||||||
|
(let loop ((line (readline (prompt))))
|
||||||
|
(if (not (eof-object? line))
|
||||||
|
(begin
|
||||||
|
(let ((ast (sh:parse (remove-shell-comments line))))
|
||||||
|
(add-history line)
|
||||||
|
(run ast))
|
||||||
|
(loop (readline (prompt)))))))))
|
||||||
|
(activate-readline)
|
||||||
|
(clear-history)
|
||||||
|
(read-history HOME)
|
||||||
|
(with-readline-completion-function completion thunk)
|
||||||
|
;;(thunk)
|
||||||
|
(write-history HOME))
|
||||||
|
(newline)))))
|
||||||
|
|
||||||
|
|
||||||
|
(define (remove-shell-comments s)
|
||||||
|
(string-join (map
|
||||||
|
(lambda (s)
|
||||||
|
(let* ((n (string-index s #\#)))
|
||||||
|
(if n (string-pad-right s (string-length s) #\space 0 n)
|
||||||
|
s)))
|
||||||
|
(string-split s #\newline)) "\n"))
|
||||||
|
|
||||||
|
(define (builtin cmd)
|
||||||
|
(if (and (pair? cmd) (string? (car cmd)) (string=? (car cmd) "cd"))
|
||||||
|
(lambda () (chdir (cadr cmd)))
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(define (transform ast)
|
||||||
|
(match ast
|
||||||
|
(('pipeline command) (transform command))
|
||||||
|
(('pipeline command piped-commands) (cons 'pipeline (cons (transform command) (transform piped-commands))))
|
||||||
|
(('simple-command ('word s)) (list s))
|
||||||
|
(('simple-command ('word s1) ('word s2)) (list s1 s2))
|
||||||
|
(('simple-command ('word s1) (list ('word s2) ...)) (cons s1 s2))
|
||||||
|
((('pipe _) command ...) (map transform command))
|
||||||
|
(((('pipe _) command) ...) (map transform command))
|
||||||
|
((_ o) (transform o))
|
||||||
|
(_ ast)))
|
||||||
|
|
||||||
|
(define (sh-exec ast)
|
||||||
|
(let ((cmd (transform ast)))
|
||||||
|
(if (builtin cmd)
|
||||||
|
((builtin cmd))
|
||||||
|
(if (and (pair? cmd) (eq? 'pipeline (car cmd)))
|
||||||
|
(sh:pipeline (cdr cmd))
|
||||||
|
(apply system* cmd)))))
|
||||||
|
|
||||||
|
(define (prompt)
|
||||||
|
(let* ((esc (string #\033))
|
||||||
|
(CWD (getcwd))
|
||||||
|
(HOME (getenv "HOME"))
|
||||||
|
(cwd (if (string-prefix? HOME CWD)
|
||||||
|
(string-replace CWD "~" 0 (string-length HOME))
|
||||||
|
CWD)))
|
||||||
|
(string-append esc "[01;34m" cwd esc "[00m$ ")))
|
||||||
|
|
||||||
|
(define (redraw-current-line)
|
||||||
|
(dynamic-call (dynamic-func "rl_refresh_line"
|
||||||
|
(dynamic-link "libreadline.so"))
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(define (filename-completion text state)
|
||||||
|
(if (not state)
|
||||||
|
(let ((completions (map car
|
||||||
|
(filter (lambda (entry) (string-prefix? text (car entry)))
|
||||||
|
(cddr (file-system-tree (getcwd)))))))
|
||||||
|
(cond ((< 1 (length completions)) (begin (newline)
|
||||||
|
(display (string-join completions " ")) (newline)
|
||||||
|
(redraw-current-line)
|
||||||
|
#f))
|
||||||
|
((= 1 (length completions)) (car completions))
|
||||||
|
(#t #f)))
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(define (search-binary-in-path-completion text state)
|
||||||
|
(if (not state)
|
||||||
|
(let ((completions (map car
|
||||||
|
(filter (lambda (entry) (string-prefix? text (car entry)))
|
||||||
|
(cddr (file-system-tree "/bin"))))))
|
||||||
|
(cond ((< 1 (length completions)) (begin (newline)
|
||||||
|
(display (string-join completions " ")) (newline)
|
||||||
|
(redraw-current-line)
|
||||||
|
#f))
|
||||||
|
((= 1 (length completions)) (car completions))
|
||||||
|
(#t #f)))
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(define (completion text state)
|
||||||
|
(or (filename-completion text state)
|
||||||
|
;(search-binary-in-path-completion text state)
|
||||||
|
))
|
|
@ -1,6 +1,8 @@
|
||||||
(use-modules (ice-9 peg))
|
(define-module (sh peg)
|
||||||
(use-modules (ice-9 peg codegen))
|
:use-module (ice-9 peg)
|
||||||
(use-modules (ice-9 pretty-print))
|
:use-module (ice-9 peg codegen)
|
||||||
|
:use-module (ice-9 pretty-print)
|
||||||
|
:export (parse))
|
||||||
|
|
||||||
(define (parse input)
|
(define (parse input)
|
||||||
(define label "")
|
(define label "")
|
||||||
|
@ -50,7 +52,7 @@
|
||||||
io-suffix <- sp* here-label sp* linebreak
|
io-suffix <- sp* here-label sp* linebreak
|
||||||
filename <-- word
|
filename <-- word
|
||||||
name <-- identifier
|
name <-- identifier
|
||||||
identifier <-- [_a-zA-Z][_a-zA-Z0-9]*
|
identifier <- [_a-zA-Z][_a-zA-Z0-9]*
|
||||||
word <-- test / substitution / assignment / literal
|
word <-- test / substitution / assignment / literal
|
||||||
test <-- ltest (!' ]' .)* rtest
|
test <-- ltest (!' ]' .)* rtest
|
||||||
ltest < '[ '
|
ltest < '[ '
|
|
@ -1,5 +1,7 @@
|
||||||
(use-modules (ice-9 popen))
|
(define-module (sh pipe)
|
||||||
(use-modules (srfi srfi-8)) ;; receive
|
:use-module (ice-9 popen)
|
||||||
|
:use-module (srfi srfi-8)
|
||||||
|
:export (pipeline))
|
||||||
|
|
||||||
(define (pipe*)
|
(define (pipe*)
|
||||||
(let ((p (pipe)))
|
(let ((p (pipe)))
|
Loading…
Reference in New Issue