From 69c3f9e6adacccc8147d8db5464e0c652b9d7e66 Mon Sep 17 00:00:00 2001
From: Timothy Sample <samplet@ngyro.com>
Date: Sat, 16 Dec 2017 00:53:20 -0500
Subject: [PATCH] Add parser

* geesh/parser.scm: New file.
* tests/parser.scm: New file.
* Makefile.am: Add them.
* .dir-locals.el: New file. Include indenting rules for Shell AST
forms and 'call-with-backquoted-input-port'.
---
 .dir-locals.el   |  10 +
 Makefile.am      |   2 +
 geesh/parser.scm | 660 +++++++++++++++++++++++++++++++++++++++++++++++
 tests/parser.scm | 276 ++++++++++++++++++++
 4 files changed, 948 insertions(+)
 create mode 100644 .dir-locals.el
 create mode 100644 geesh/parser.scm
 create mode 100644 tests/parser.scm

diff --git a/.dir-locals.el b/.dir-locals.el
new file mode 100644
index 0000000..f96ab13
--- /dev/null
+++ b/.dir-locals.el
@@ -0,0 +1,10 @@
+((scheme-mode
+  .
+  ((eval . (put '<sh-case> 'scheme-indent-function 1))
+   (eval . (put '<sh-define> 'scheme-indent-function 1))
+   (eval . (put '<sh-exec-let> 'scheme-indent-function 1))
+   (eval . (put '<sh-for> 'scheme-indent-function 1))
+   (eval . (put '<sh-until> 'scheme-indent-function 1))
+   (eval . (put '<sh-while> 'scheme-indent-function 1))
+   (eval . (put '<sh-with-redirects> 'scheme-indent-function 1))
+   (eval . (put 'call-with-backquoted-input-port 'scheme-indent-function 1)))))
diff --git a/Makefile.am b/Makefile.am
index 790ba0e..17eac4f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -38,6 +38,7 @@ test-list: ; @echo $(TESTS)
 
 MODULES =                                       \
   geesh/lexer.scm                               \
+  geesh/parser.scm                              \
   geesh/repl.scm
 
 bin_SCRIPTS =                                   \
@@ -45,6 +46,7 @@ bin_SCRIPTS =                                   \
 
 TESTS =                                         \
   tests/lexer.scm                               \
+  tests/parser.scm                              \
   tests/repl.scm
 
 CLEANFILES =                                    \
diff --git a/geesh/parser.scm b/geesh/parser.scm
new file mode 100644
index 0000000..12249f5
--- /dev/null
+++ b/geesh/parser.scm
@@ -0,0 +1,660 @@
+;;; The Geesh Shell Interpreter
+;;; Copyright 2018 Timothy Sample <samplet@ngyro.com>
+;;;
+;;; This file is part of Geesh.
+;;;
+;;; Geesh 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.
+;;;
+;;; Geesh 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 Geesh.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (geesh parser)
+  #:use-module (geesh lexer)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-41)
+  #:use-module (system base lalr)
+  #:export (read-sh))
+
+;;; Commentary:
+;;;
+;;; This module contains the parser for the Shell language.
+;;;
+;;; Code:
+
+(define io-redirect-defaults
+  '((< . 0) (<& . 0) (> . 1)
+    (>& . 1) (>> . 1) (<> . 0)
+    (>! . 1) (<< . 0) (<<- . 0)))
+
+(define (io-redirect? sexp)
+  "Determine if @var{sexp} is an I/O redirect form."
+  (match sexp
+    ((or ('< x y) ('<& x y) ('> x y)
+         ('>& x y) ('>> x y) ('<> x y)
+         ('>! x y) ('<< x y) ('<<- x y)) #t)
+    (_ #f)))
+
+(define (process-dup-or-close-word word)
+  "Process the right-hand-side of a \"<&\" or \"&>\" redirect."
+  (let ((n (string->number word)))
+    (cond
+     ((and n (exact-integer? n)) n)
+     ((string=? word "-") '-)
+     (else word))))
+
+(define (split-assignment word)
+  "Split assignment @var{word} into a list where the first element is
+the variable name and the second element is the value expression."
+
+  (define (assignment-name-and-value str)
+    (let* ((index (string-index str #\=))
+           (name (substring str 0 index))
+           (value (substring str (1+ index))))
+      `(,name . ,value)))
+
+  (match word
+    (((? string?) . tail)
+     (match (assignment-name-and-value (car word))
+       ((name . value)
+        (cond
+         ((null? tail) `(,name ,value))
+         ((string-null? value) (if (null? (cdr tail))
+                                   `(,name ,(car tail))
+                                   `(,name ,tail)))
+         (else `(,name ,(cons value tail)))))))
+    ((? string?)
+     (match (assignment-name-and-value word)
+       ((name . value) `(,name ,value))))))
+
+;; The (ice-9 textual-ports) module does not allow instantiating
+;; end-of-file objects, but (rnrs io ports) does.
+(define eof-object (@ (rnrs io ports) eof-object))
+
+(define (make-lexer port read-sh/bracketed read-sh/backquoted)
+  "Make a lexer thunk that reads tokens from @var{port}. When the lexer
+needs to read subcommands, it uses @var{read-sh/bracketed} to read
+bracketed subcommands and @var{read-sh/backquoted} to read backquoted
+subcommands."
+  (lambda ()
+    (parameterize ((read-bracketed-command read-sh/bracketed)
+                   (read-backquoted-command read-sh/backquoted))
+      (get-token port))))
+
+(define* (make-parser #:key (command-hook noop)
+                      (open-bracket-hook noop)
+                      (close-bracket-hook noop))
+  "Make an LALR parser for the Shell language. The optional hooks are
+all thunks. The @var{command-hook} thunk is called after reducing a
+complete command. The @var{open-bracket-hook} thunk is called after
+reducing an opening bracket. The @var{close-bracket-hook} is called
+after reducing a closing bracket. (Note that a @var{open-bracket-hook}
+is also called when reducing case patterns that end with an unbalanced
+closing bracket. This ensures that when parsing valid Shell code,
+@var{open-bracket-hook} and @var{close-bracket-hook} should be called
+the same number of times.)"
+  (lalr-parser
+
+   (AND                                 ; '&'
+    SEMI                                ; ';'
+    LESS                                ; '<'
+    GREAT                               ; '>'
+    PIPE                                ; '|'
+    LPAREN                              ; '('
+    RPAREN                              ; ')'
+
+    AND-IF                              ; '&&'
+    OR-IF                               ; '||'
+    DSEMI                               ; ';;'
+    DLESS                               ; '<<'
+    DGREAT                              ; '>>'
+    LESSAND                             ; '<&'
+    GREATAND                            ; '>&'
+    LESSGREAT                           ; '<>'
+    DLESSDASH                           ; '<<-'
+    CLOBBER                             ; '>|'
+
+    If                                  ; 'if'
+    Then                                ; 'then'
+    Else                                ; 'else'
+    Elif                                ; 'elif'
+    Fi                                  ; 'fi'
+    Do                                  ; 'do'
+    Done                                ; 'done'
+    Case                                ; 'case'
+    Esac                                ; 'esac'
+    While                               ; 'while'
+    Until                               ; 'until'
+    For                                 ; 'for'
+    Lbrace                              ; '{'
+    Rbrace                              ; '}'
+    Bang                                ; '!'
+    In                                  ; 'in'
+
+    WORD
+    ASSIGNMENT-WORD
+    NAME
+    NEWLINE
+    IO-NUMBER)
+
+   (program
+    (linebreak complete-commands linebreak)
+    : (if (null? (cdr $2)) (car $2) (reverse! $2))
+    (linebreak)
+    : (eof-object))
+
+   (complete-commands
+    (complete-commands newline-list complete-command)
+    : (begin
+        (command-hook)
+        (cons (if (null? (cdr $3)) (car $3) $3) $1))
+    (complete-command)
+    : (begin
+        (command-hook)
+        (if (null? (cdr $1)) `(,(car $1)) `(,$1))))
+
+   (complete-command
+    (list separator-op)
+    : (match $2
+        ('AND (reverse! (cons `(<sh-async> ,(car $1)) (cdr $1))))
+        ('SEMI (reverse! $1)))
+    (list)
+    : (reverse! $1))
+
+   (list
+    (list separator-op and-or)
+    : (match $2
+        ('AND (cons* $3 `(<sh-async> ,(car $1)) (cdr $1)))
+        ('SEMI (cons $3 $1)))
+    (and-or)
+    : `(,$1))
+
+   (and-or
+    (pipeline)
+    : $1
+    (and-or AND-IF linebreak pipeline)
+    : `(<sh-and> ,$1 ,$4)
+    (and-or OR-IF linebreak pipeline)
+    : `(<sh-or> ,$1 ,$4))
+
+   (pipeline
+    (pipe-sequence)
+    : (if (null? (cdr $1)) (car $1) $1)
+    (Bang pipe-sequence)
+    : `(<sh-bang> ,$2))
+
+   (pipe-sequence
+    (command)
+    : `(,$1)
+    (pipe-sequence PIPE linebreak command)
+    : `(<sh-pipe> ,(append $1 (list $4))))
+
+   (command
+    (simple-command)
+    : $1
+    (compound-command)
+    : $1
+    (compound-command redirect-list)
+    : `(<sh-with-redirects> ,$2 ,$1)
+    (function-definition)
+    : $1)
+
+   (compound-command
+    (brace-group)
+    : $1
+    (subshell)
+    : $1
+    (for-clause)
+    : $1
+    (case-clause)
+    : $1
+    (if-clause)
+    : $1
+    (while-clause)
+    : $1
+    (until-clause)
+    : $1)
+
+   (subshell
+    (LPAREN! compound-list RPAREN!)
+    : `(<sh-subshell> ,$2))
+
+   (compound-list
+    (linebreak term)
+    : (match $2
+        ((cmd) cmd)
+        (cmds `(<sh-begin> ,@(reverse! cmds))))
+    (linebreak term separator)
+    : (match (match $3
+               ('AND (cons `(<sh-async> ,(car $2)) (cdr $2)))
+               ((or 'SEMI 'NEWLINE) $2))
+        ((cmd) cmd)
+        (cmds `(<sh-begin> ,@(reverse! cmds)))))
+
+   (term
+    (term separator and-or)
+    : (match $2
+        ('AND (cons* $3 `(<sh-async> ,(car $1)) (cdr $1)))
+        ((or 'SEMI 'NEWLINE) (cons $3 $1)))
+    (and-or)
+    : `(,$1))
+
+   (for-clause
+    (For name do-group)
+    : `(<sh-for> (,$2 (<sh-ref> "@")) ,$3)
+    (For name sequential-sep do-group)
+    : `(<sh-for> (,$2 (<sh-ref> "@")) ,$4)
+    (For name linebreak in sequential-sep do-group)
+    : `(<sh-for> (,$2 (<sh-ref> "@")) ,$6)
+    (For name linebreak in wordlist sequential-sep do-group)
+    : `(<sh-for> (,$2 ,$5) ,$7))
+
+   (name
+    (NAME-with-keywords)
+    : $1)
+
+   (in
+    (In)
+    : #f)
+
+   (wordlist
+    (wordlist WORD*)
+    : (append $1 `(,$2))
+    (WORD*)
+    : `(,$1))
+
+   (case-clause
+    (Case WORD* linebreak in linebreak case-list Esac)
+    : `(<sh-case> ,$2 ,@$6)
+    (Case WORD* linebreak in linebreak case-list-ns Esac)
+    : `(<sh-case> ,$2 ,@$6)
+    (Case WORD* linebreak in linebreak Esac)
+    : `(<sh-case> ,$2))
+
+   (case-list-ns
+    (case-list case-item-ns)
+    : (append $1 `(,$2))
+    (case-item-ns)
+    : `(,$1))
+
+   (case-list
+    (case-list case-item)
+    : (append $1 `(,$2))
+    (case-item)
+    : `(,$1))
+
+   (case-item-ns
+    (pattern! RPAREN! linebreak)
+    : `(,$1 #f)
+    (pattern! RPAREN! compound-list)
+    : `(,$1 ,$3)
+    (LPAREN! pattern RPAREN! linebreak)
+    : `(,$2 #f)
+    (LPAREN! pattern RPAREN! compound-list)
+    : `(,$2 ,$4))
+
+   (case-item
+    (pattern! RPAREN! linebreak DSEMI linebreak)
+    : `(,$1 #f)
+    (pattern! RPAREN! compound-list DSEMI linebreak)
+    : `(,$1 ,$3)
+    (LPAREN! pattern RPAREN! linebreak DSEMI linebreak)
+    : `(,$2 #f)
+    (LPAREN! pattern RPAREN! compound-list DSEMI linebreak)
+    : `(,$2 ,$4))
+
+   (pattern
+    (WORD*-with-non-Esac-keywords)
+    : `(,$1)
+    (pattern PIPE WORD*)
+    : (append $1 `(,$3)))
+
+   (if-clause
+    (If compound-list Then compound-list else-part Fi)
+    : `(<sh-cond> (,$2 ,$4) ,@$5)
+    (If compound-list Then compound-list Fi)
+    : `(<sh-cond> (,$2 ,$4)))
+
+   (else-part
+    (Elif compound-list Then compound-list)
+    : `((,$2 ,$4))
+    (Elif compound-list Then compound-list else-part)
+    : (cons `(,$2 ,$4) $5)
+    (Else compound-list)
+    : `((<sh-else> ,$2)))
+
+   (while-clause
+    (While compound-list do-group)
+    : `(<sh-while> ,$2 ,$3))
+
+   (until-clause
+    (Until compound-list do-group)
+    : `(<sh-until> ,$2 ,$3))
+
+   (function-definition
+    (fname LPAREN! RPAREN! linebreak function-body)
+    : `(<sh-define> (,$1) ,$5))
+
+   (function-body
+    (compound-command)
+    : $1
+    (compound-command redirect-list)
+    : `(<sh-with-redirects> ,$2 ,$1))
+
+   (fname
+    (NAME)
+    : $1)
+
+   (brace-group
+    (Lbrace compound-list Rbrace)
+    : $2)
+
+   (do-group
+    (Do compound-list Done)
+    : $2)
+
+   (simple-command
+    (cmd-prefix cmd-word cmd-suffix)
+    : (let*-values (((redirects-1 assignments*) (partition io-redirect? $1))
+                    ((redirects-2 args) (partition io-redirect? $3))
+                    ((assignments) (map split-assignment assignments*)))
+        (match (append redirects-1 redirects-2)
+          (() `(<sh-exec-let> ,assignments ,$2 ,@args))
+          (redirects `(<sh-with-redirects> ,redirects
+                        (<sh-exec-let> ,assignments ,$2 ,@args)))))
+    (cmd-prefix cmd-word)
+    : (let*-values (((redirects assignments*) (partition io-redirect? $1))
+                    ((assignments) (map split-assignment assignments*)))
+        (match redirects
+          (() `(<sh-exec-let> ,assignments ,$2))
+          (_ `(<sh-with-redirects> ,redirects
+                (<sh-exec-let> ,assignments ,$2)))))
+    (cmd-prefix)
+    : (let*-values (((redirects assignments*) (partition io-redirect? $1))
+                    ((assignments) (map split-assignment assignments*)))
+        (match redirects
+          (() `(<sh-set!> ,assignments))
+          (_ `(<sh-with-redirects> ,redirects
+                ,(if (null? assignments)
+                     #f
+                     `(<sh-set!> ,assignments))))))
+    (cmd-name cmd-suffix)
+    : (let-values (((redirects args) (partition io-redirect? $2)))
+        (match redirects
+          (() `(<sh-exec> ,$1 ,@args))
+          (_ `(<sh-with-redirects> ,redirects
+                (<sh-exec> ,$1 ,@args)))))
+    (cmd-name)
+    : `(<sh-exec> ,$1))
+
+   (cmd-name
+    (WORD*-without-ASSIGNMENT-WORD)
+    : $1)
+
+   (cmd-word
+    (WORD*-without-ASSIGNMENT-WORD)
+    : $1)
+
+   (cmd-prefix
+    (io-redirect)
+    : `(,$1)
+    (cmd-prefix io-redirect)
+    : (append $1 `(,$2))
+    (ASSIGNMENT-WORD)
+    : `(,$1)
+    (cmd-prefix ASSIGNMENT-WORD)
+    : (append $1 `(,$2)))
+
+   (cmd-suffix
+    (io-redirect)
+    : `(,$1)
+    (cmd-suffix io-redirect)
+    : (append $1 `(,$2))
+    (WORD*)
+    : `(,$1)
+    (cmd-suffix WORD*)
+    : (append $1 `(,$2)))
+
+   (redirect-list
+    (io-redirect)
+    : `(,$1)
+    (redirect-list io-redirect)
+    : (append $1 `(,$2)))
+
+   (io-redirect
+    (io-file)
+    : `(,(car $1) ,(assoc-ref io-redirect-defaults (car $1)) ,(cdr $1))
+    (IO-NUMBER io-file)
+    : `(,(car $2) ,(string->number $1) ,(cdr $2))
+    (io-here)
+    : `(,(car $1) ,(assoc-ref io-redirect-defaults (car $1)) ,(cdr $1))
+    (IO-NUMBER io-here)
+    : `(,(car $2) ,(string->number $1) ,(cdr $2)))
+
+   (io-file
+    (LESS filename)
+    : `(< . ,$2)
+    (LESSAND filename)
+    : `(<& . ,(process-dup-or-close-word $2))
+    (GREAT filename)
+    : `(> . ,$2)
+    (GREATAND filename)
+    : `(>& . ,(process-dup-or-close-word $2))
+    (DGREAT filename)
+    : `(>> . ,$2)
+    (LESSGREAT filename)
+    : `(<> . ,$2)
+    (CLOBBER filename)
+    : `(>! . ,$2))
+
+   (filename
+    (WORD*)
+    : $1)
+
+   (io-here
+    (DLESS here-end)
+    : `(<< . ,$2)
+    (DLESSDASH here-end)
+    : `(<<- . ,$2))
+
+   (here-end
+    (WORD*)
+    : $1)
+
+   (newline-list
+    (NEWLINE)
+    : #f
+    (newline-list NEWLINE)
+    : #f)
+
+   (linebreak
+    (newline-list)
+    : #f
+    ()
+    : #f)
+
+   (separator-op
+    (AND)
+    : 'AND
+    (SEMI)
+    : 'SEMI)
+
+   (separator
+    (separator-op linebreak)
+    : $1
+    (newline-list)
+    : 'NEWLINE)
+
+   (sequential-sep
+    (SEMI linebreak)
+    : #f
+    (newline-list)
+    : #f)
+
+   ;; Rules added to emulate the POSIX context-sensitive lexer
+   ;; approach.
+
+   ;; Accept all the specializations of a normal word. This corresponds
+   ;; to "rule 1" in the POSIX specification.
+   (WORD*
+    (WORD) : $1
+    (NAME) : $1
+    (ASSIGNMENT-WORD) : $1)
+
+   ;; Accept all keywords except "esac". This corresponds to "rule 4"
+   ;; in the POSIX specification.
+   (WORD*-with-non-Esac-keywords
+    (WORD) : $1
+    (NAME) : $1
+    (ASSIGNMENT-WORD) : $1
+    (If) : $1
+    (Then) : $1
+    (Else) : $1
+    (Elif) : $1
+    (Fi) : $1
+    (Do) : $1
+    (Done) : $1
+    (Case) : $1
+    ;; (Esac) : $1
+    (While) : $1
+    (Until) : $1
+    (For) : $1
+    (Lbrace) : $1
+    (Rbrace) : $1
+    (Bang) : $1
+    (In) : $1)
+
+   ;; Accept a "NAME" or any keyword. This corresponds to "rule 5" in
+   ;; the POSIX specification.
+   (NAME-with-keywords
+    (NAME) : $1
+    (If) : $1
+    (Then) : $1
+    (Else) : $1
+    (Elif) : $1
+    (Fi) : $1
+    (Do) : $1
+    (Done) : $1
+    (Case) : $1
+    (Esac) : $1
+    (While) : $1
+    (Until) : $1
+    (For) : $1
+    (Lbrace) : $1
+    (Rbrace) : $1
+    (Bang) : $1
+    (In) : $1)
+
+   ;; Accept any "WORD*" token except for "ASSIGNMENT-WORD". This
+   ;; corresponds to "rule 7" in the POSIX specification.
+   (WORD*-without-ASSIGNMENT-WORD
+    (WORD) : $1
+    (NAME) : $1)
+
+   ;; Rules for updating bracket balance.
+
+   (LPAREN!
+    (LPAREN)
+    : (begin (open-bracket-hook) $1))
+
+   (RPAREN!
+    (RPAREN)
+    : (begin (close-bracket-hook) $1))
+
+   ;; Sometimes a "pattern" non-terminal comes before an unbalanced
+   ;; "RPAREN". This reduction hook can be used to pretend that we
+   ;; encountered an "LPAREN".
+
+   (pattern!
+    (pattern)
+    : (begin (open-bracket-hook) $1))))
+
+(define* (syntax-error message #:optional token)
+  "Handle a parser error"
+  (if (lexical-token? token)
+      (throw 'syntax-error #f message
+             (and=> (lexical-token-source token)
+                    source-location->source-properties)
+             (or (lexical-token-value token)
+                 (lexical-token-category token))
+             #f)
+      (throw 'syntax-error #f message #f token #f)))
+
+(define (call-with-backquoted-input-port port proc)
+  "Call @var{proc} with a wrapped version of @var{port} that will
+return the end-of-file object upon encountering an unescaped backquote
+\"`\" (without consuming the backquote)."
+  (define wrapped-port
+    (make-soft-port
+     (vector
+      ;; put-char, put-string, and flush-output-port
+      #f #f #f
+      ;; get-char
+      (lambda ()
+        (match (lookahead-char port)
+          (#\` (eof-object))
+          (#\\ (begin
+                 (get-char port)
+                 (match (lookahead-char port)
+                   ((or #\$ #\` #\\) (get-char port))
+                   (_ #\\))))
+          (_ (get-char port))))
+      ;; close-port
+      #f)
+     "r"))
+  (proc wrapped-port))
+
+(define (read-sh/bracketed port)
+  "Read Shell code from @var{port} until the first unmatched closing
+bracket."
+  (let* ((bracket-depth 0)
+         (incr-bracket-depth! (lambda ()
+                                (set! bracket-depth (1+ bracket-depth))))
+         (decr-bracket-depth! (lambda ()
+                                (set! bracket-depth (1- bracket-depth))))
+         (balanced? (lambda () (= 0 bracket-depth)))
+         (pre-lex (make-lexer port read-sh/bracketed read-sh/backquoted))
+         (lex (lambda ()
+                (let ((token (pre-lex)))
+                  (if (and (balanced?)
+                           (lexical-token? token)
+                           (eq? (lexical-token-category token) 'RPAREN))
+                      (begin
+                        (unget-char port #\))
+                        '*eoi*)
+                      token))))
+         (parse (make-parser #:open-bracket-hook incr-bracket-depth!
+                             #:close-bracket-hook decr-bracket-depth!)))
+    (match (parse lex syntax-error)
+      ((? eof-object?) #f)
+      (code code))))
+
+(define (read-sh/backquoted port)
+  "Read Shell code from @var{port} until the first unescaped backquote."
+  (call-with-backquoted-input-port port
+    (lambda (port)
+      (let ((lex (make-lexer port read-sh/bracketed read-sh/backquoted))
+            (parse (make-parser)))
+        (match (parse lex syntax-error)
+          ((? eof-object?) #f)
+          (code code))))))
+
+(define (read-sh port)
+  "Read a complete Shell command from @var{port} (or the current input
+port if @var{port} is unspecified)."
+  (let* ((stop? #f)
+         (stop! (lambda () (set! stop? #t)))
+         (pre-lex (make-lexer port read-sh/bracketed read-sh/backquoted))
+         (lex (lambda () (if stop? '*eoi* (pre-lex))))
+         (parse (make-parser #:command-hook stop!)))
+    (parse lex syntax-error)))
diff --git a/tests/parser.scm b/tests/parser.scm
new file mode 100644
index 0000000..c99c9c4
--- /dev/null
+++ b/tests/parser.scm
@@ -0,0 +1,276 @@
+(define-module (test-parser)
+  #:use-module (geesh parser)
+  #:use-module (srfi srfi-64)
+  #:use-module (tests automake))
+
+;;; Commentary:
+;;;
+;;; Tests for the parser module.
+;;;
+;;; Code:
+
+(define (parse str)
+  (call-with-input-string str read-sh))
+
+(test-begin "reader")
+
+;; Commands and lists
+
+(test-equal "Parses simple command"
+  '(<sh-exec> "echo" "foo")
+  (parse "echo foo"))
+
+(test-equal "Parses command lists"
+  '((<sh-exec> "echo" "foo")
+    (<sh-exec> "echo" "bar"))
+  (parse "echo foo; echo bar"))
+
+(test-equal "Parses asynchronous command lists"
+  '((<sh-async> (<sh-exec> "echo" "foo"))
+    (<sh-async> (<sh-exec> "echo" "bar")))
+  (parse "echo foo& echo bar&"))
+
+(test-equal "Parses mixed command lists"
+  '((<sh-async> (<sh-exec> "echo" "foo"))
+    (<sh-exec> "echo" "bar"))
+  (parse "echo foo& echo bar"))
+
+(test-equal "Parses commands with assignments"
+  '(<sh-exec-let> (("FOO" "bar"))
+     "echo" (<sh-ref> "FOO"))
+  (parse "FOO=bar echo $FOO"))
+
+(test-equal "Parses commands with default redirects"
+  '(<sh-with-redirects> ((> 1 "bar"))
+     (<sh-exec> "echo" "foo"))
+  (parse "echo foo > bar"))
+
+(test-equal "Parses commands with specific redirects"
+  '(<sh-with-redirects> ((< 5 "bar"))
+     (<sh-exec> "echo" "foo"))
+  (parse "echo foo 5< bar"))
+
+(test-equal "Parses commands with dup redirects"
+  '(<sh-with-redirects> ((>& 1 3))
+     (<sh-exec> "exec"))
+  (parse "exec >&3"))
+
+(test-equal "Parses commands with close redirects"
+  '(<sh-with-redirects> ((<& 3 -))
+     (<sh-exec> "exec"))
+  (parse "exec 3<&-"))
+
+(test-equal "Parses assignments"
+  '(<sh-set!> (("FOO" "bar")))
+  (parse "FOO=bar"))
+
+;; Boolean expressions
+
+(test-equal "Parses disjunctions"
+  '(<sh-or> (<sh-exec> "echo" "foo")
+            (<sh-exec> "echo" "bar"))
+  (parse "echo foo || echo bar"))
+
+(test-equal "Parses conjunctions"
+  '(<sh-and> (<sh-exec> "echo" "foo")
+             (<sh-exec> "echo" "bar"))
+  (parse "echo foo && echo bar"))
+
+(test-equal "Parses conjunction than disjunction"
+  '(<sh-or> (<sh-and> (<sh-exec> "echo" "foo")
+                      (<sh-exec> "echo" "bar"))
+            (<sh-exec> "echo" "baz"))
+  (parse "echo foo && echo bar || echo baz"))
+
+(test-equal "Parses disjunction than conjunction"
+  '(<sh-and> (<sh-or> (<sh-exec> "echo" "foo")
+                      (<sh-exec> "echo" "bar"))
+             (<sh-exec> "echo" "baz"))
+  (parse "echo foo || echo bar && echo baz"))
+
+;; Pipelines
+
+(test-equal "Parses pipelines"
+  '(<sh-pipe> ((<sh-exec> "cat" "foo.txt")
+               (<sh-exec> "grep" "bar")))
+  (parse "cat foo.txt | grep bar"))
+
+;; Brace groups and subshells
+
+(test-equal "Parses brace groups"
+  '(<sh-begin> (<sh-exec> "echo" "foo")
+               (<sh-exec> "echo" "bar"))
+  (parse "{ echo foo
+            echo bar }"))
+
+(test-equal "Parses subshells"
+  '(<sh-subshell> (<sh-begin> (<sh-exec> "echo" "foo")
+                              (<sh-exec> "echo" "bar")))
+  (parse "(echo foo; echo bar)"))
+
+;; For loops
+
+(test-equal "Parses for loops over parameters without seperator"
+  '(<sh-for> ("x" (<sh-ref> "@"))
+     (<sh-exec> "echo" (<sh-ref> "x")))
+  (parse "for x do echo $x done"))
+
+(test-equal "Parses for loops over parameters with seperator"
+  '(<sh-for> ("x" (<sh-ref> "@"))
+     (<sh-exec> "echo" (<sh-ref> "x")))
+  (parse "for x; do echo $x done"))
+
+(test-equal "Parses for loops over parameters with \"in\""
+  '(<sh-for> ("x" (<sh-ref> "@"))
+     (<sh-exec> "echo" (<sh-ref> "x")))
+  (parse "for x in; do echo $x done"))
+
+(test-equal "Parses for loops over word lists"
+  '(<sh-for> ("x" ("foo" "bar" "baz"))
+     (<sh-exec> "echo" (<sh-ref> "x")))
+  (parse "for x in foo bar baz; do echo $x done"))
+
+;; Case statements
+
+(test-equal "Parses case statements with final seperator"
+  '(<sh-case> (<sh-ref> "foo")
+     (("bar") (<sh-exec> "echo" "bar")))
+  (parse "case $foo in bar) echo bar ;; esac"))
+
+(test-equal "Parses case statements without final seperator"
+  '(<sh-case> (<sh-ref> "foo")
+     (("bar") (<sh-exec> "echo" "bar")))
+  (parse "case $foo in bar) echo bar esac"))
+
+(test-equal "Parses empty case statements"
+  '(<sh-case> (<sh-ref> "foo"))
+  (parse "case $foo in esac"))
+
+(test-equal "Parses case statements with empty case item"
+  '(<sh-case> (<sh-ref> "foo")
+     (("bar") #f))
+  (parse "case $foo in bar) esac"))
+
+(test-equal "Parses case statements with multiple case items"
+  '(<sh-case> (<sh-ref> "foo")
+     (("bar") (<sh-exec> "echo" "bar"))
+     (("baz") (<sh-exec> "echo" "baz")))
+  (parse "case $foo in bar) echo bar ;; baz) echo baz esac"))
+
+(test-equal "Parses case statements with compound patterns"
+  '(<sh-case> (<sh-ref> "foo")
+     (("bar" "baz") (<sh-exec> "echo" (<sh-quote> "bar or baz"))))
+  (parse "case $foo in bar | baz) echo 'bar or baz' ;; esac"))
+
+;; If statements
+
+(test-equal "Parses one-branch if statements"
+  '(<sh-cond>
+    ((<sh-exec> "[" (<sh-ref> "foo") "=" "bar" "]")
+     (<sh-exec> "echo" "bar")))
+  (parse "if [ $foo = bar ] then echo bar fi"))
+
+(test-equal "Parses two-branch if statements"
+  '(<sh-cond>
+    ((<sh-exec> "[" (<sh-ref> "foo") "=" "bar" "]")
+     (<sh-exec> "echo" "bar"))
+    (<sh-else>
+     (<sh-exec> "echo" "baz")))
+  (parse "if [ $foo = bar ] then echo bar else echo baz fi"))
+
+(test-equal "Parses multi-branch if statements"
+  '(<sh-cond>
+    ((<sh-exec> "[" (<sh-ref> "foo") "=" "bar" "]")
+     (<sh-exec> "echo" "bar"))
+    ((<sh-exec> "[" (<sh-ref> "foo") "=" "baz" "]")
+     (<sh-exec> "echo" "baz"))
+    (<sh-else>
+     (<sh-exec> "echo" "quux")))
+  (parse "if [ $foo = bar ] then
+              echo bar
+          elif [ $foo = baz ] then
+              echo baz
+          else
+              echo quux
+          fi"))
+
+;; While and until loops
+
+(test-equal "Parses while loops"
+  '(<sh-while> (<sh-exec> "is-foo-time")
+     (<sh-exec> "foo"))
+  (parse "while is-foo-time do foo done"))
+
+(test-equal "Parses until loops"
+  '(<sh-until> (<sh-exec> "is-no-longer-foo-time")
+     (<sh-exec> "foo"))
+  (parse "until is-no-longer-foo-time do foo done"))
+
+;; Functions
+
+(test-equal "Parses functions"
+  '(<sh-define> ("foo")
+     (<sh-exec> "echo" "foo"))
+  (parse "foo() { echo foo }"))
+
+;; Nested commands
+
+(test-equal "Parses bracketed command substitions"
+  '(<sh-exec> "echo"
+              (<sh-cmd-sub> (<sh-exec> "foo"))
+              (<sh-cmd-sub> (<sh-exec> "bar")))
+  (parse "echo $(foo) $(bar)"))
+
+(test-equal "Parses nested bracketed command substitions"
+  '(<sh-exec> "echo"
+              (<sh-cmd-sub> (<sh-exec> "foo"
+                                       (<sh-cmd-sub> (<sh-exec> "bar")))))
+  (parse "echo $(foo $(bar))"))
+
+(test-equal "Parses empty bracketed command substitions"
+  '(<sh-exec> "echo" (<sh-cmd-sub> #f))
+  (parse "echo $()"))
+
+(test-equal "Parses multiline bracketed command substitions"
+  '(<sh-exec> "echo" (<sh-cmd-sub> ((<sh-exec> "foo")
+                                    (<sh-exec> "bar"))))
+  (parse "echo $(foo
+                 bar)"))
+
+(test-equal "Parses backquoted command substitions"
+  '(<sh-exec> "echo"
+              (<sh-cmd-sub> (<sh-exec> "foo"))
+              (<sh-cmd-sub> (<sh-exec> "bar")))
+  (parse "echo `foo` `bar`"))
+
+(test-equal "Parses nested backquoted command substitions"
+  '(<sh-exec> "echo"
+              (<sh-cmd-sub> (<sh-exec> "foo"
+                                       (<sh-cmd-sub> (<sh-exec> "bar")))))
+  (parse "echo `foo \\`bar\\``"))
+
+(test-equal "Parses empty backquoted command substitions"
+  '(<sh-exec> "echo" (<sh-cmd-sub> #f))
+  (parse "echo ``"))
+
+(test-equal "Parses multiline backquoted command substitions"
+  '(<sh-exec> "echo" (<sh-cmd-sub> ((<sh-exec> "foo")
+                                    (<sh-exec> "bar"))))
+  (parse "echo `foo
+                bar`"))
+
+;; Other tests
+
+(test-assert "Returns EOF on EOF"
+  (eof-object? (parse "")))
+
+(test-equal "Parses one statement at a time"
+  '((<sh-exec> "echo" "foo")
+    (<sh-exec> "echo" "bar"))
+  (call-with-input-string "echo foo
+                           echo bar"
+    (lambda (port)
+      (list (read-sh port)
+            (read-sh port)))))
+
+(test-end)