andrius
/
gash
mirror of https://git.savannah.gnu.org/git/gash.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

parser: refactor, use `pipeline' instead of `expression'.

This commit is contained in:
Jan Nieuwenhuizen 2018-07-15 10:58:02 +02:00
parent 9623e014f0
commit d065723221
5 changed files with 78 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
gash/bournish-commands.scm
View File

@ -111,7 +111,6 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns."
(()
(display-tabulated (scandir ".")))
(args
(format (current-error-port) "hiero:args=~s\n" args)
(let* ((option-spec
'((all (single-char #\a))
(help)

98
gash/builtins.scm
View File

@ -34,7 +34,7 @@
#:use-module (gash guix-build-utils)
#:use-module (gash io)
#:use-module (gash job)
#:use-module (gash peg) ; pipeline
#:use-module (gash pipe)
#:export (
%builtin-commands
@ -48,6 +48,7 @@
for
substitution
sh-exec
if-clause
bg-command
cd-command
@ -131,7 +132,7 @@ mostly works, pipes work, some redirections work.
(let* ((option-spec
'((help)
(version)))
(options (getopt-long (cons "ls" args) option-spec))
(options (getopt-long (cons "find" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
@ -164,7 +165,7 @@ Options:
(help)
(show (single-char #\v))
(version)))
(options (getopt-long (cons "ls" args) option-spec))
(options (getopt-long (cons "command" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
@ -206,7 +207,7 @@ Options:
'((help)
(canonical-file-name (single-char #\p))
(version)))
(options (getopt-long (cons "ls" args) option-spec))
(options (getopt-long (cons "type" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
@ -253,12 +254,10 @@ Options:
(is-writable (single-char #\w))
(is-exeutable (single-char #\x))
(version)))
(options (getopt-long (cons "ls" args) option-spec))
(options (getopt-long (cons "test" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(files (if (equal? (last files) "]") (drop-right files 1)
files))
(file (and (pair? files) (car files))))
(cond (help? (display "Usage: test [EXPRESSION]
@ -284,11 +283,12 @@ Options:
(left "==" right))
(equal? left right))
(expression
(let ((status (sh-exec `(pipeline (command ',expression)))))
(zero? status)))))
(pipeline (command expression)))))
((not (= (length files) 1))
(format (current-error-port) "test: too many files: ~a\n" files)
1)
((option-ref options 'is-file #f)
(regular-file? file))
((option-ref options 'is-directory #f)
(directory-exists? file))
((option-ref options 'exists #f)
@ -304,7 +304,22 @@ Options:
(access? file W_OK))
((option-ref options 'is-exeutable #f)
(access? file X_OK))
(else #f))))))
(else
(error "gash: test: not supported" args)))))))
(define bracket-command
(case-lambda
(() #f)
(args
(cond ((and (pair? args) (equal? (car args) "--help"))
(test-command "--help"))
((and (pair? args) (equal? (car args) "--version"))
(test-command "--version"))
(else
(if (not (equal? (last args) "]")) (begin
(format (current-error-port) "gash: [: missing `]'\n")
#f)
(apply test-command (drop-right args 1))))))))
(define grep-command
(case-lambda
@ -338,8 +353,8 @@ Options:
(version? (format #t "grep (GASH) ~a\n" %version))
((null? files) #t)
(else
(let* ((pattern (warn 'pattern (car files)))
(files (warn 'files (cdr files)))
(let* ((pattern (car files))
(files (cdr files))
(matches (append-map (cut grep pattern <>) files)))
(define (display-match o)
(let* ((s (grep-match-string o))
@ -472,17 +487,26 @@ Options:
(define (substitution . commands)
(apply (@ (gash pipe) pipeline->string) (map cdr commands))) ;;HACK
(define (sh-exec ast)
(define (exec cmd)
(when (> %debug-level 0)
(format (current-error-port) "sh-exec:exec cmd=~s\n" cmd))
(let* ((job (local-eval cmd (the-environment)))
(stati (cond ((job? job) (map status:exit-val (job-status job)))
(define-syntax if-clause
(lambda (x)
(syntax-case x ()
((_ expr then)
(with-syntax ((it (datum->syntax x 'it)))
#'(let ((it expr))
(if (zero? it) then))))
((_ expr then else)
(with-syntax ((it (datum->syntax x 'it)))
#'(let ((it expr))
(if (zero? it) then else)))))))
(define (pipeline . commands)
(define (handle job)
(let* ((stati (cond ((job? job) (map status:exit-val (job-status job)))
((boolean? job) (list (if job 0 1)))
((number? job) (list job))
(else (list 0))))
(status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0)
(car stati)))
(status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0)
(car stati)))
(pipestatus (string-append
"("
(string-join
@ -497,36 +521,18 @@ Options:
(shell-opt? "errexit"))
(exit status))
status))
(when (> %debug-level 1)
(format (current-error-port) "sh-exec:exec ast=~s\n" ast))
(match ast
('script #t) ;; skip
(('pipeline commands ...)
(when (shell-opt? "xtrace")
(for-each
(lambda (o)
(match o
(('command command ...)
;;(format (current-error-port) "+ ~a\n" (string-join command))
;; FIXME: side-effects done twice?!
;; '(variable "$?"): not a string...hmm
(format (current-error-port) "+ ~a\n" (string-join (map (cut local-eval <> (the-environment)) command)))
)
(_ (format (current-error-port) "FIXME trace:~s" o))))
(reverse commands)))
(exec ast))
(_ (for-each exec ast))))
(define (pipeline . commands)
(when (> %debug-level 1)
(format (current-error-port) "pijp: commands=~s\n" commands))
;; FIXME: after running a builtin, we still end up here with the builtin's result
;; that should probably not happen, however, cater for it here for now
(match commands
(((and (? boolean?) boolean)) (if boolean 0 1))
(((and (? number?) number)) number)
(((? unspecified?)) 0)
(_ (apply (@ (gash pipe) pipeline) #t commands))))
(((and (? boolean?) boolean))
(handle boolean))
(((and (? number?) number))
(handle number))
(((? unspecified?))
(handle #t))
(_ (handle (apply pipeline+ #t commands)))))
(define %builtin-commands
`(
@ -551,5 +557,5 @@ Options:
("type" . ,type-command)
("wc" . ,wc-command)
("which" . ,which-command)
("[" . ,test-command)
("[" . ,bracket-command)
))

11
gash/guix-build-utils.scm
View File

@ -44,6 +44,7 @@
directory-exists?
executable-file?
regular-file?
symbolic-link?
))
@ -67,9 +68,17 @@
(and s
(not (zero? (logand (stat:mode s) #o100))))))
(define (regular-file? file)
"Return #t if FILE is a regular file."
(let ((s (stat file #f)))
(and s
(eq? (stat:type s) 'regular))))
(define (symbolic-link? file)
"Return #t if FILE is a symbolic link (aka. \"symlink\".)"
(eq? (stat:type (lstat file)) 'symlink))
(let ((s (lstat file)))
(and s
(eq? (stat:type s) 'symlink))))
(define (file-name-predicate regexp)
"Return a predicate that returns true when passed a file name whose base

21
gash/peg.scm
View File

@ -119,15 +119,14 @@
for-keyword < 'for'
in-keyword < 'in'
for-clause <-- for-keyword sp+ name (ws+ in-keyword expression)? sp* sequential-sep do-group
expression <-- (sp+ word)+
for-clause <-- for-keyword sp+ name (ws+ in-keyword pipeline)? sp* sequential-sep do-group
do-keyword < 'do'
done-keyword < 'done'
do-group <- do-keyword ws* compound-list separator done-keyword
if-keyword < 'if'
fi-keyword < 'fi'
if-clause <-- if-keyword expression separator then-part elif-part* else-part? fi-keyword
if-clause <-- if-keyword pipeline separator then-part elif-part* else-part? fi-keyword
then-keyword < 'then'
then-part <-- then-keyword ws* compound-list separator
elif-keyword < 'elif'
@ -144,11 +143,8 @@
filename <-- word
name <-- identifier
identifier <- [_a-zA-Z][_a-zA-Z0-9]*
word <- test / substitution / assignment / number / variable / delim / literal
word <- substitution / assignment / number / variable / delim / literal
number <-- [0-9]+
test <-- ltest expression rtest
ltest < '[ '
rtest < ' ]'
lsubst < '$('
rsubst < ')'
tick < '`'
@ -156,7 +152,7 @@
assignment <-- name assign (substitution / word)*
assign < '='
dollar <- '$'
literal <-- (!ltest !tick !dollar !pipe !semi !par !nl !sp .)+
literal <-- (!tick !dollar !pipe !semi !par !nl !sp .)+
variable <-- dollar (dollar / '*' / '?' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}]))
delim <- singlequotes / doublequotes / substitution
sq < [']
@ -201,7 +197,7 @@
((eq? ast 'script)
#t)
(else
(map sh-exec ast)
(map (cut local-eval <> (the-environment)) ast)
ast))))
(define (unspecified? o)
@ -217,8 +213,6 @@
(('pipeline h t) (pk `(pipeline ,(transform h) ,@(map transform t))))
(('command o ...) (let* ((command (map transform o))
(program (car command))
;; if [ 0 = 1 ] ... program = '(if ...) not a string
;; this escape-builtin? is probably not deep enough?
(escape-builtin? (and (string? program) (string-prefix? "\\" program)))
(program (if escape-builtin? (string-drop program 1) program))
(command (cons program (cdr command))))
@ -230,11 +224,10 @@
(('literal o) (transform o))
(('name o) o)
(('number o) o)
(('expression o ...) `(expression ,@(map transform o)))
(('assignment a b) `(lambda _ (assignment ,(transform a) ,(transform b))))
(('for-clause name expr do) `(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,(transform do))))
(('if-clause expr then) `(if ,(transform expr) ,(transform then)))
(('if-clause expr then else) `(if ,(transform expr) ,(transform then) ,(transform else)))
(('if-clause expr then) `(if-clause ,(transform expr) ,(transform then)))
(('if-clause expr then else) `(if-clause ,(transform expr) ,(transform then) ,(transform else)))
(('then-part o ...) `(begin ,@(map transform o)))
(('else-part o ...) `(begin ,@(map transform o)))
(_ ast)))

23
gash/pipe.scm
View File

@ -13,7 +13,7 @@
#:use-module (gash job)
#:use-module (gash io)
#:export (handle-error pipeline pipeline->string substitute))
#:export (handle-error pipeline+ pipeline->string substitute))
(define (handle-error job error)
(let ((status (wait job)))
@ -87,14 +87,9 @@
(map close w)
r))))
(define (pipeline fg? . commands)
(define (pipeline+ fg? . commands)
(when (> %debug-level 0)
(format (current-error-port) "pipeline[~a]: COMMANDS: ~s\n" fg? commands))
;; (when (shell-opt? "xtrace")
;; (for-each
;; (lambda (o)
;; (format (current-error-port) "+ ~a\n" (string-join o)))
;; (reverse commands)))
(format (current-error-port) "pipeline+[~a]: COMMANDS: ~s\n" fg? commands))
(receive (r w)
(pipe*)
(move->fdes w 2)
@ -136,16 +131,16 @@
(define (pipeline->string . commands)
(receive (job ports)
(apply pipeline #f commands)
(apply pipeline+ #f commands)
(let ((output (read-string (car ports))))
(wait job)
output)))
;;(pipeline #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") (lambda () (display (read-string))))
;;(pipeline #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") '("cat"))
;;(pipeline #f (lambda () (display 'foo)) '("grep" "o") '("tr" "o" "e"))
;;(pipeline+ #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") (lambda () (display (read-string))))
;;(pipeline+ #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") '("cat"))
;;(pipeline+ #f (lambda () (display 'foo)) '("grep" "o") '("tr" "o" "e"))
;; (pipeline #f
;; (pipeline+ #f
;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar"))
;; '("tr" "u" "a")
;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string))))
@ -153,7 +148,7 @@
;; (lambda () (display (read-string))))
;; (receive (job ports)
;; (pipeline #f
;; (pipeline+ #f
;; (lambda ()
;; (display "foo")
;; (display "bar" (current-error-port)))