133 lines
4.9 KiB
Scheme
133 lines
4.9 KiB
Scheme
;;; Gash --- Guile As SHell
|
|
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; 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 geesh)
|
|
#:use-module (srfi srfi-1)
|
|
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 pretty-print)
|
|
|
|
#:use-module (gash builtins)
|
|
#:use-module (gash gash)
|
|
#:use-module (gash io)
|
|
#:export (
|
|
parse
|
|
parse-string
|
|
))
|
|
|
|
(catch #t
|
|
(lambda _ (use-modules (gash parser)))
|
|
(lambda (key . args)
|
|
#t))
|
|
|
|
(define (parse port)
|
|
(let ((parse-tree (read-sh-all port)))
|
|
(when (> %debug-level 1)
|
|
(format (current-error-port) "parse-tree:\n")
|
|
(pretty-print parse-tree (current-error-port)))
|
|
(let ((ast (parse-tree->script parse-tree)))
|
|
(when (> %debug-level 1)
|
|
(format (current-error-port) "transformed:\n")
|
|
(pretty-print ast (current-error-port)))
|
|
(let* ((script (match ast
|
|
(((or 'command 'pipeline) _ ...) `(script ,ast))
|
|
((_ ...) `(script ,@ast))
|
|
(_ `(script ,ast))))
|
|
(tracing-script (annotate-tracing script)))
|
|
(when (> %debug-level 0)
|
|
(format (current-error-port) "script:\n")
|
|
(pretty-print tracing-script (current-error-port)))
|
|
tracing-script))))
|
|
|
|
(define (parse-string string)
|
|
(call-with-input-string string parse))
|
|
|
|
(define (parse-tree->script tree)
|
|
(define (transform o)
|
|
(when (> %debug-level 2)
|
|
(format (current-error-port) "transform:\n")
|
|
(pretty-print o (current-error-port)))
|
|
(match o
|
|
(('<sh-begin> body ...) `(begin ,@(map transform body)))
|
|
(('<sh-pipeline> (('<sh-pipeline> (left ...))) right)
|
|
`(pipeline ,@(map transform left) ,(transform right)))
|
|
(('<sh-pipeline> ('<sh-pipeline> (left ...) right))
|
|
`(pipeline ,@(map transform left) ,(transform right)))
|
|
(('<sh-pipeline> (left right))
|
|
`(pipeline ,(transform left) ,(transform right)))
|
|
(('<sh-exec> command) `(command ,(transform command)))
|
|
(('<sh-exec> command ...) `(command ,@(map transform command)))
|
|
(((and ref ('<sh-ref> _)) words ...)
|
|
`(word ,(transform ref) ,@(map transform words)))
|
|
(('<sh-ref> var) `(variable ,var))
|
|
(('<sh-set!> (var (and value ((? symbol?) _ ...))))
|
|
`(assignment ,(transform var) ,(transform value)))
|
|
(('<sh-set!> (var (value ...)))
|
|
`(assignment ,(transform var) (word ,@(map transform value))))
|
|
(('<sh-set!> (var value)) `(assignment ,(transform var) ,(transform value)))
|
|
(((and kwote ('<sh-quote> _)) word)
|
|
`(word ,(transform kwote) ,(transform word)))
|
|
(('<sh-quote>)
|
|
`(doublequotes ""))
|
|
(('<sh-quote> words ...)
|
|
`(doublequotes (word ,@(map transform words))))
|
|
(((and quote ('<sh-quote> _)) tail ...)
|
|
`(word ,(transform quote) ,@(map transform tail)))
|
|
(('<sh-cmd-sub> cmd) `(substitution ,(transform cmd)))
|
|
(('<sh-cond> (expression then)) `(if-clause ,(transform expression) ,(transform then)))
|
|
(('<sh-with-redirects> (('<< 0 string)) pipeline)
|
|
(let ((pipeline (transform pipeline)))
|
|
`(pipeline (display ,(transform string))
|
|
,@(match pipeline
|
|
(('command command ...) `(,pipeline))
|
|
(('pipeline commands ...) commands)))))
|
|
|
|
(('<sh-for> (name (sequence)) body)
|
|
`(for ,(transform name)
|
|
(lambda _ (split ,(transform sequence)))
|
|
(lambda _ ,(transform body))))
|
|
|
|
(('<sh-for> (name sequence) body)
|
|
`(for ,(transform name)
|
|
(lambda _ (split ,(transform sequence)))
|
|
(lambda _ ,(transform body))))
|
|
|
|
((? string?) o)
|
|
(((? string?) _ ...) `(word ,@(map re-word o)))
|
|
((_ ...) (map transform o))
|
|
(_ o)))
|
|
(transform tree))
|
|
|
|
(define (re-word word)
|
|
(match word
|
|
((? string?) word)
|
|
(((and h (? string?)) t ...)
|
|
`(word ,h ,@(map (compose re-word parse-tree->script) t)))
|
|
(_ (parse-tree->script word))))
|
|
|
|
(define (annotate-tracing script)
|
|
(match script
|
|
(('pipeline command)
|
|
`(pipeline ,(trace (list command)) ,command))
|
|
(('pipeline commands ...)
|
|
`(pipeline ,(trace commands) ,@commands))
|
|
(('command command ...)
|
|
`(pipeline ,(trace (list script)) ,script))
|
|
((_ ...) (map annotate-tracing script))
|
|
(_ script)))
|