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

WIP FOO => rewrite me harder

This commit is contained in:
Rutger van Beusekom 2018-07-07 19:32:46 +02:00 committed by Jan Nieuwenhuizen
parent 859a95efe2
commit 745757cfd0
3 changed files with 95 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
gash/gash.scm
View File

@ -92,7 +92,6 @@ copyleft.
(debug (single-char #\d))
(errexit (single-char #\e))
(help (single-char #\h))
(parse (single-char #\p))
(prefer-builtins)
(version (single-char #\v))
(xtrace (single-char #\x))))
@ -100,19 +99,13 @@ copyleft.
(command? (option-ref options 'command #f))
(opt? (lambda (name) (lambda (o) (and (eq? (car o) name) (cdr o)))))
(debug (length (filter-map (opt? 'debug) options)))
(debug? (option-ref options 'debug #f))
(help? (option-ref options 'help #f))
(parse? (option-ref options 'parse #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(run
(lambda (ast)
(cond (parse?
(let ((ast- (transform ast)))
(stdout "parsed: " ast)
(stdout "prepared: " ast-)
#t))
(#t
(sh-exec ast))))))
(run (compose sh-exec
(if #t (cut stdout "transformed: " <>) identity) (cut transform <>)
(if #t (cut stdout "parsed: " <>) identity))))
(set! %prefer-builtins? (option-ref options 'prefer-builtins #f))
(set-shell-opt! "errexit" (option-ref options 'errexit #f))
(set-shell-opt! "xtrace" (option-ref options 'xtrace #f))
@ -185,7 +178,7 @@ copyleft.
paths)))
(cond
((not pattern) '(""))
((string=? "$?" pattern) (list (assoc-ref global-variables "?")))
((string-prefix? "$" pattern) (list (pk "get " pattern " => " (assoc-ref global-variables (string-drop pattern 1))))) ;; TODO: REMOVE ME
((glob? pattern) (let ((absolute? (string-prefix? "/" pattern)))
(let loop ((patterns (filter (negate string-null?) (string-split pattern #\/)))
(paths (if absolute? '("/") '("."))))
@ -320,52 +313,57 @@ mostly works, pipes work, some redirections work.
(#t #t)
(_ #f)))))))
(define (tostring . args)
(with-output-to-string (cut map display args)))
;; transform ast -> list of expr
;; such that (map eval expr)
(define (transform ast)
(match ast
(('script term "&") (list (background (transform term))))
(('script term) `(,(transform term)))
(('script terms ...) (transform terms))
(('substitution "$(" script ")") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment)))
(('substitution "`" script "`") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment)))
((('term command)) `(,(transform command)))
((('term command) ...) (map transform command))
((('term command) (('term commands) ...)) (map transform (cons command commands)))
(('compound-list terms ...) (transform terms))
(('if-clause "if" (expression "then" consequent "fi"))
`(if (equal? 0 (status:exit-val ,@(transform expression)))
(begin ,@(transform consequent))))
(('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi"))
`(if (equal? 0 (status:exit-val ,@(transform expression)))
(begin ,@(transform consequent))
(begin ,@(transform alternative))))
(('for-clause ("for" identifier sep do-group)) #t)
(('for-clause "for" ((identifier "in" lst sep) do-group))
`(for-each (lambda (,(string->symbol identifier))
(begin ,@(expand identifier (transform do-group))))
(glob ,(transform lst))))
(('do-group "do" (command "done")) (transform command))
(('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,@command))))
(('pipeline command piped-commands) `(pipeline #t ,@(transform command) ,@(transform piped-commands)))
(('simple-command ('word (assignment name value))) (set! global-variables (assoc-set! global-variables (transform name) (transform value))) #t)
(('simple-command ('word s)) `((glob ,(transform s))))
(('simple-command ('word s1) ('io-redirect "<<" ('here-document s2))) `((append (glob "echo") (cons "-n" (glob ,s2))) (glob ,(transform s1))))
(('simple-command ('word s1) ('word s2)) `((append (glob ,(transform s1)) (glob ,(transform s2)))))
(('simple-command ('word s1) (('word s2) ...)) `((append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2))))))
(('variable s) (assoc-ref global-variables (string-drop s 1)))
(('literal s) (transform s))
(('singlequotes s) (string-concatenate `("'" ,s "'")))
(('doublequotes s) (string-concatenate `("\"" ,s "\"")))
(('backticks s) (string-concatenate `("`" ,s "`")))
(('delim ('singlequotes s ...)) (string-concatenate (map transform s)))
(('delim ('doublequotes s ...)) (string-concatenate (map transform s)))
(('delim ('backticks s ...)) (string-concatenate (map transform s)))
((('pipe _) command) (transform command))
(((('pipe _) command) ...) (map (compose car transform) command))
((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...)
(_ ast))) ;; done
(('script term "&") (list (background (transform term))))
(('script term) `(,(transform term)))
(('script terms ...) (transform terms))
(('substitution "$(" script ")") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment)))
(('substitution "`" script "`") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment)))
((('term command)) `(,(transform command)))
((('term command) ...) (map transform command))
((('term command) (('term commands) ...)) (map transform (cons command commands)))
(('compound-list terms ...) (transform terms))
(('if-clause "if" (expression "then" consequent "fi"))
`(if (equal? 0 (status:exit-val ,@(transform expression)))
(begin ,@(transform consequent))))
(('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi"))
`(if (equal? 0 (status:exit-val ,@(transform expression)))
(begin ,@(transform consequent))
(begin ,@(transform alternative))))
(('for-clause ("for" identifier sep do-group)) #t)
(('for-clause "for" ((identifier "in" lst sep) do-group))
`(for-each (lambda (,(string->symbol identifier))
(begin ,@(expand identifier (transform do-group))))
(glob ,(transform lst))))
(('do-group "do" (command "done")) (transform command))
(('pipeline command) (pk 1) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,@command))))
(('pipeline command piped-commands) (pk 2) `(pipeline #t ,@(transform command) ,@(transform piped-commands)))
(('simple-command ('word (assignment name value))) `((lambda _ (let ((name ,(tostring (transform name)))
(value ,(tostring (transform value))))
(stderr "assignment: " name "=" value)
(set! global-variables (assoc-set! global-variables name (glob value)))))))
(('simple-command ('word s)) `((glob ,(transform s))))
(('simple-command ('word s1) ('io-redirect "<<" ('here-document s2))) `((append (glob "echo") (cons "-n" (glob ,s2))) (glob ,(transform s1))))
(('simple-command ('word s1) ('word s2)) `((append (glob ,(transform s1)) (glob ,(transform s2)))))
(('simple-command ('word s1) (('word s2) ...)) `((append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2))))))
(('variable s) s)
(('literal s) (transform s))
(('singlequotes s) (string-concatenate `("'" ,s "'")))
(('doublequotes s) (string-concatenate `("\"" ,s "\"")))
(('backticks s) (string-concatenate `("`" ,s "`")))
(('delim ('singlequotes s ...)) (string-concatenate (map transform s)))
(('delim ('doublequotes s ...)) (string-concatenate (map transform s)))
(('delim ('backticks s ...)) (string-concatenate (map transform s)))
((('pipe _) command) (transform command))
(((('pipe _) command) ...) (map (compose car transform) command))
((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...)
(_ ast))) ;; done
(define (sh-exec ast)
(define (exec cmd)

6
gash/io.scm
View File

@ -1,5 +1,7 @@
(define-module (gash io)
#:use-module (srfi srfi-1)
#:export (stdout stderr))
(define (output port o)
@ -9,8 +11,8 @@
(define (stdout . o)
(output (current-output-port) o)
o)
(last o))
(define (stderr . o)
(output (current-error-port) o)
o)
(last o))

42
gash/peg.scm
View File

@ -5,6 +5,42 @@
#:export (parse peg-trace?))
(define (wrap-parser-for-users for-syntax parser accumsym s-syn)
#`(lambda (str strlen pos)
(when (> (@ (gash gash) %debug-level) 0)
(format (current-error-port) "~a ~a : ~s\n"
(make-string (- pos (or (string-rindex str #\newline 0 pos) 0)) #\space)
'#,s-syn
(substring str pos (min (+ pos 40) strlen))))
(let* ((res (#,parser str strlen pos)))
;; Try to match the nonterminal.
(if res
;; If we matched, do some post-processing to figure out
;; what data to propagate upward.
(let ((at (car res))
(body (cadr res)))
#,(cond
((eq? accumsym 'name)
#`(list at '#,s-syn))
((eq? accumsym 'all)
#`(list (car res)
(cond
((not (list? body))
(list '#,s-syn body))
((null? body) '#,s-syn)
((symbol? (car body))
(list '#,s-syn body))
(else (cons '#,s-syn body)))))
((eq? accumsym 'none) #`(list (car res) '()))
(else #`(begin res))))
;; If we didn't match, just return false.
#f))))
(module-define! (resolve-module '(ice-9 peg codegen))
'wrap-parser-for-users
wrap-parser-for-users)
(define (error? x)
(let loop ((x x))
(if (null? x) #f
@ -83,13 +119,13 @@
assignment <-- name assign (substitution / word)?
assign < '='
literal <-- (variable / delim / (![0-9] (![()] !io-op !sp !nl !break !pipe !assign !bt !sq !dq .)+) / ([0-9]+ &separator)) literal*
variable <-- '$' ('$' / '*' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}]))
variable <-- '$' ('$' / '*' / '?' / '@' / [0-9] / identifier / ([{] (![}] .)+ [}]))
delim <-- singlequotes / doublequotes / substitution
sq < [']
dq < [\"]
bt < [`]
singlequotes <-- sq (doublequotes / substitution / (!sq .))* sq
doublequotes <-- dq (singlequotes / substitution / (!dq .))* dq
singlequotes <-- sq (doublequotes / (!sq .))* sq
doublequotes <-- dq (singlequotes / substitution / variable / (!dq .))* dq
separator <- (sp* break ws*) / ws+
break <- amp / semi !semi
sequential-sep <-- (semi !semi ws*) / ws+