From a5773e90eb379bf2630cc20924b07407ab5a89c6 Mon Sep 17 00:00:00 2001
From: Timothy Sample <samplet@ngyro.com>
Date: Wed, 11 Jul 2018 22:05:15 -0400
Subject: [PATCH] Add word

* geesh/word.scm: New file.
* tests/word.scm: New file.
* Makefile.am: Add them.
---
 Makefile.am    |   6 +-
 geesh/word.scm | 162 ++++++++++++++++++++++++
 tests/word.scm | 338 +++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 504 insertions(+), 2 deletions(-)
 create mode 100644 geesh/word.scm
 create mode 100644 tests/word.scm

diff --git a/Makefile.am b/Makefile.am
index eaca651..70c8e4d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -40,7 +40,8 @@ MODULES =                                       \
   geesh/environment.scm                         \
   geesh/lexer.scm                               \
   geesh/parser.scm                              \
-  geesh/repl.scm
+  geesh/repl.scm                                \
+  geesh/word.scm
 
 bin_SCRIPTS =                                   \
   scripts/geesh
@@ -49,7 +50,8 @@ TESTS =                                         \
   tests/environment.scm                         \
   tests/lexer.scm                               \
   tests/parser.scm                              \
-  tests/repl.scm
+  tests/repl.scm                                \
+  tests/word.scm
 
 CLEANFILES =                                    \
   $(GOBJECTS)                                   \
diff --git a/geesh/word.scm b/geesh/word.scm
new file mode 100644
index 0000000..e935a7d
--- /dev/null
+++ b/geesh/word.scm
@@ -0,0 +1,162 @@
+;;; 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 word)
+  #:use-module (geesh environment)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (eval-cmd-sub
+            expand-word))
+
+;;; Commentary:
+;;;
+;;; This module contains functions for manipulating shell words.  This
+;;; includes tilde expansion, parameter expansions, field splitting,
+;;; globbing, etc.
+;;;
+;;; In the code below, the term "qword" is used to refer to words that
+;;; only contain quotations (i.e., no substitutions).
+;;;
+;;; Code:
+
+(define (normalize-word word)
+  "Normalize @var{word} (which may be a word or a qword) so that it is
+guaranteed to be a list."
+  (match word
+    ((? string?) (list word))
+    (((? symbol?) _) (list word))
+    (_ word)))
+
+(define (infix x xs)
+  "Place @var{x} between each element of the list @var{xs}."
+  (if (null? xs)
+      xs
+      (let loop ((xs (cdr xs)) (acc (list (car xs))))
+        (if (null? xs)
+            (reverse acc)
+            (loop (cdr xs) (cons* (car xs) x acc))))))
+
+(define (list-split xs sym)
+  "Split the list @var{xs} into sublists delimited by the symbol
+@var{sym}."
+  (let loop ((xs xs) (small-acc '()) (big-acc '()))
+    (cond
+     ((null? xs)
+      (reverse (cons (reverse small-acc) big-acc)))
+     ((eq? (car xs) sym)
+      (loop (cdr xs) '() (cons (reverse small-acc) big-acc)))
+     (else
+      (loop (cdr xs) (cons (car xs) small-acc) big-acc)))))
+
+(define (split-fields qword ifs)
+  "Split @var{qword} into a list of qwords delimited by the character
+set @var{ifs}."
+
+  (define (wedge-apart qword-part ifs)
+    (match qword-part
+      (('<sh-quote> _) (list qword-part))
+      ("" '(""))
+      (str (let ((str-parts (string-split str ifs)))
+             (if (every string-null? str-parts)
+                 '(wedge)
+                 (infix 'wedge (filter (compose not string-null?)
+                                       str-parts)))))))
+
+  (let ((wedged (append-map (cut wedge-apart <> ifs)
+                            (normalize-word qword))))
+    (list-split wedged 'wedge)))
+
+(define (remove-quotes qword)
+  "Remove quote forms from @var{qword} and concatenate the result into a
+single field (string)."
+  (let loop ((qword (normalize-word qword)) (acc '()))
+    (match qword
+      (() (string-concatenate-reverse acc))
+      ((('<sh-quote> qword*) . t) (loop t (cons (remove-quotes qword*) acc)))
+      (((? string? h) . t) (loop t (cons h acc))))))
+
+(define eval-cmd-sub
+  ;; A procedure for evaluating (expanding) a command substitution.
+  ;; This is parameterized to avoid a circular dependency.
+  (make-parameter (lambda (exps) (throw 'eval-cmd-sub-unset))))
+
+(define (string-not-null? str)
+  "Check if @var{str} is a non-null string."
+  (and (string? str) (not (string-null? str))))
+
+(define (word->qword env word)
+  "Convert @var{word} into a qword by resolving all parameter, command,
+and arithmetic substitions using the environment @var{env}."
+  (match word
+    ((? string?)
+     word)
+    (('<sh-quote> quoted-word)
+     `(<sh-quote> ,(word->qword env quoted-word)))
+    (('<sh-cmd-sub> . exps)
+     ((eval-cmd-sub) exps))
+    (('<sh-ref> name)
+     (or (var-ref env name) ""))
+    (('<sh-ref-or> name default)
+     (or (var-ref env name)
+         (word->qword env (or default ""))))
+    (('<sh-ref-or*> name default)
+     (let ((value (var-ref env name)))
+       (if (string-not-null? value)
+           value
+           (word->qword env (or default "")))))
+    (('<sh-ref-or!> name default)
+     (or (var-ref env name)
+         (let ((new-value (expand-word env (or default "")
+                                       #:split? #f #:rhs-tildes? #t)))
+           (set-var! env name new-value)
+           new-value)))
+    (('<sh-ref-or!*> name default)
+     (let ((value (var-ref env name)))
+       (if (string-not-null? value)
+           value
+           (let ((new-value (expand-word env (or default "")
+                                         #:split? #f #:rhs-tildes? #t)))
+             (set-var! env name new-value)
+             new-value))))
+    (('<sh-ref-assert> name message) (error "Not implemented"))
+    (('<sh-ref-assert*> name message) (error "Not implemented"))
+    (('<sh-ref-and> name value)
+     (if (string-not-null? (var-ref env name))
+         (word->qword env (or value ""))
+         ""))
+    (('<sh-ref-and*> name value)
+     (or (and (var-ref env name)
+              (word->qword env (or value "")))
+         ""))
+    (('<sh-ref-except-min> name pattern) (error "Not implemented"))
+    (('<sh-ref-except-max> name pattern) (error "Not implemented"))
+    (('<sh-ref-skip-min> name pattern) (error "Not implemented"))
+    (('<sh-ref-skip-max> name pattern) (error "Not implemented"))
+    (('<sh-ref-length> name)
+     (number->string (string-length (or (var-ref env name) ""))))
+    (_ (map (cut word->qword env <>) word))))
+
+(define* (expand-word env word #:key (split? #t) (rhs-tildes? #f))
+  "Expand @var{word} into a list of fields using the environment
+@var{env}."
+  (let ((qword (word->qword env word)))
+    (if split?
+        (map remove-quotes
+             (split-fields qword (char-set #\newline #\tab #\space)))
+        (remove-quotes qword))))
diff --git a/tests/word.scm b/tests/word.scm
new file mode 100644
index 0000000..bdc4185
--- /dev/null
+++ b/tests/word.scm
@@ -0,0 +1,338 @@
+;;; 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 (test-word)
+  #:use-module (geesh environment)
+  #:use-module (geesh word)
+  #:use-module (srfi srfi-64)
+  #:use-module (tests automake))
+
+;;; Commentary:
+;;;
+;;; Tests for the word module.
+;;;
+;;; Code:
+
+;; This function exists to add a layer of slippage between the
+;; "environment" module and our tests.  The "environment" module is
+;; still under development, and it would be annoying to have to
+;; rewrite all the tests.
+(define* (make-test-env vars #:key (noglob? #f) (nounset? #f))
+  "Create a testing environment with the alist @var{vars} as the
+current variables.  If @var{noglob?} is set, enable the `noglob'
+option.  If @var{nounset?} is set, enable the `nounset' option.  (See
+the `set' built-in for details on these options.)"
+  (make-environment vars))
+
+(test-begin "word")
+
+
+;;; Basic string handling.
+
+(test-equal "Converts a simple word (string) to a single field"
+  '("foo")
+  (expand-word #f "foo"))
+
+(test-equal "Converts a simple word (list) to a single field"
+  '("foo")
+  (expand-word #f '("foo")))
+
+(test-equal "Concatenates contiguous parts into a single field"
+  '("foobar")
+  (expand-word #f '("foo" "bar")))
+
+(test-equal "Splits a word along unquoted spaces"
+  '("foo" "bar")
+  (expand-word #f '("foo bar")))
+
+(test-equal "Ignores leading spaces"
+  '("foo")
+  (expand-word #f '(" foo")))
+
+(test-equal "Ignores trailing spaces"
+  '("foo")
+  (expand-word #f '("foo ")))
+
+(test-equal "Treats multiple spaces as a single space"
+  '("foo" "bar")
+  (expand-word #f '("foo  bar")))
+
+(test-equal "Handles multiple joins and splits"
+  '("hi_how" "are_you")
+  (expand-word #f '("hi_" "how are" "_you")))
+
+
+;;; Quotes.
+
+(test-equal "Ignores spaces in quotes"
+  '("foo bar")
+  (expand-word #f '(<sh-quote> "foo bar")))
+
+(test-equal "Concatenates strings and quotes"
+  '("foo bar")
+  (expand-word #f '("foo" (<sh-quote> " bar"))))
+
+(test-equal "Concatenates quotes"
+  '("foo bar")
+  (expand-word #f '((<sh-quote> "foo") (<sh-quote> " bar"))))
+
+(test-equal "Handles nested quotes"
+  '("foo bar")
+  (expand-word #f '(<sh-quote> (<sh-quote> "foo bar"))))
+
+(test-equal "Splits and concatenates words and quotes"
+  '("foo" "bar")
+  (expand-word #f '((<sh-quote> "foo") " " (<sh-quote> "bar"))))
+
+
+;;; Tildes.
+;;;
+;;; Not yet implemented.
+
+
+;;; Basic parameter references.
+;;;
+;;; FIXME: Test "nounset" ("set -u").
+
+(test-equal "Resolves parameters"
+  '("foo")
+  (expand-word (make-test-env '(("x" . "foo")))
+               '(<sh-ref> "x")))
+
+(test-equal "Splits parameter results"
+  '("foo" "bar")
+  (expand-word (make-test-env '(("x" . "foo bar")))
+               '(<sh-ref> "x")))
+
+(test-equal "Resolves quoted parameters"
+  '("foo")
+  (expand-word (make-test-env '(("x" . "foo")))
+               '(<sh-quote> (<sh-ref> "x"))))
+
+(test-equal "Ignores spaces in quoted parameters"
+  '("foo bar")
+  (expand-word (make-test-env '(("x" . "foo bar")))
+               '(<sh-quote> (<sh-ref> "x"))))
+
+(test-equal "Treats unset variables as blank"
+  '("")
+  (expand-word (make-test-env '())
+               '(<sh-ref> "x")))
+
+
+;;; Parameter operations.
+
+;;; or
+
+(test-equal "Handles 'or' when parameter is set"
+  '("foo")
+  (expand-word (make-test-env '(("x" . "foo")))
+               '(<sh-ref-or> "x" "bar")))
+
+(test-equal "Handles 'or' when parameter is set and empty"
+  '("")
+  (expand-word (make-test-env '(("x" . "")))
+               '(<sh-ref-or> "x" "bar")))
+
+(test-equal "Handles 'or' when parameter is unset"
+  '("bar")
+  (expand-word (make-test-env '())
+               '(<sh-ref-or> "x" "bar")))
+
+(test-equal "Handles 'or' fall-through without default"
+  '("")
+  (expand-word (make-test-env '())
+               '(<sh-ref-or> "x" #f)))
+
+;;; or*
+
+(test-equal "Handles 'or*' when parameter is set"
+  '("foo")
+  (expand-word (make-test-env '(("x" . "foo")))
+               '(<sh-ref-or*> "x" "bar")))
+
+(test-equal "Handles 'or*' when parameter is set and empty"
+  '("bar")
+  (expand-word (make-test-env '(("x" . "")))
+               '(<sh-ref-or*> "x" "bar")))
+
+(test-equal "Handles 'or*' when parameter is unset"
+  '("bar")
+  (expand-word (make-test-env '())
+               '(<sh-ref-or*> "x" "bar")))
+
+(test-equal "Handles 'or*' fall-through without default"
+  '("")
+  (expand-word (make-test-env '())
+               '(<sh-ref-or*> "x" #f)))
+
+;;; or!
+
+(test-equal "Handles 'or!' when parameter is set"
+  '(("foo") "foo")
+  (let ((env (make-test-env '(("x" . "foo")))))
+    (list (expand-word env '(<sh-ref-or!> "x" "bar"))
+          (var-ref env "x"))))
+
+(test-equal "Handles 'or!' when parameter is set and empty"
+  '(("") "")
+  (let ((env (make-test-env '(("x" . "")))))
+    (list (expand-word env '(<sh-ref-or!> "x" "bar"))
+          (var-ref env "x"))))
+
+(test-equal "Handles 'or!' when parameter is unset"
+  '(("bar") "bar")
+  (let ((env (make-test-env '())))
+    (list (expand-word env '(<sh-ref-or!> "x" "bar"))
+          (var-ref env "x"))))
+
+(test-equal "Handles 'or!' fall-through without default"
+  '(("") "")
+  (let ((env (make-test-env '())))
+    (list (expand-word env '(<sh-ref-or!> "x" #f))
+          (var-ref env "x"))))
+
+;;; or!*
+
+(test-equal "Handles 'or!*' when parameter is set"
+  '(("foo") "foo")
+  (let ((env (make-test-env '(("x" . "foo")))))
+    (list (expand-word env '(<sh-ref-or!*> "x" "bar"))
+          (var-ref env "x"))))
+
+(test-equal "Handles 'or!*' when parameter is set and empty"
+  '(("bar") "bar")
+  (let ((env (make-test-env '(("x" . "")))))
+    (list (expand-word env '(<sh-ref-or!*> "x" "bar"))
+          (var-ref env "x"))))
+
+(test-equal "Handles 'or!*' when parameter is unset"
+  '(("bar") "bar")
+  (let ((env (make-test-env '())))
+    (list (expand-word env '(<sh-ref-or!*> "x" "bar"))
+          (var-ref env "x"))))
+
+(test-equal "Handles 'or!*' fall-through without default"
+  '(("") "")
+  (let ((env (make-test-env '())))
+    (list (expand-word env '(<sh-ref-or!*> "x" #f))
+          (var-ref env "x"))))
+
+(test-equal "Does not split fields on assignment"
+  '(("foo" "bar") "foo bar")
+  (let ((env (make-test-env '(("y" . "foo bar")))))
+    (list (expand-word env '(<sh-ref-or!*> "x" (<sh-ref> "y")))
+          (var-ref env "x"))))
+
+;;; FIXME: Test 'assert'.
+
+;;; and
+
+(test-equal "Handles 'and' when parameter is set"
+  '("bar")
+  (expand-word (make-test-env '(("x" . "foo")))
+               '(<sh-ref-and> "x" "bar")))
+
+(test-equal "Handles 'and' when parameter is set and empty"
+  '("")
+  (expand-word (make-test-env '(("x" . "")))
+               '(<sh-ref-and> "x" "bar")))
+
+(test-equal "Handles 'and' when parameter is unset"
+  '("")
+  (expand-word (make-test-env '())
+               '(<sh-ref-and> "x" "bar")))
+
+(test-equal "Handles 'and' fall-through without default"
+  '("")
+  (expand-word (make-test-env '(("x" . "foo")))
+               '(<sh-ref-and> "x" #f)))
+
+;;; and*
+
+(test-equal "Handles 'and*' when parameter is set"
+  '("bar")
+  (expand-word (make-test-env '(("x" . "foo")))
+               '(<sh-ref-and*> "x" "bar")))
+
+(test-equal "Handles 'and*' when parameter is set and empty"
+  '("bar")
+  (expand-word (make-test-env '(("x" . "")))
+               '(<sh-ref-and*> "x" "bar")))
+
+(test-equal "Handles 'and*' when parameter is unset"
+  '("")
+  (expand-word (make-test-env '())
+               '(<sh-ref-and*> "x" "bar")))
+
+(test-equal "Handles 'and*' fall-through without default"
+  '("")
+  (expand-word (make-test-env '(("x" . "foo")))
+               '(<sh-ref-and*> "x" #f)))
+
+;;; length
+
+(test-equal "Handles 'length' when parameter is set"
+  '("3")
+  (expand-word (make-test-env '(("x" . "foo")))
+               '(<sh-ref-length> "x")))
+
+(test-equal "Handles 'length' when parameter is unset"
+  '("0")
+  (expand-word (make-test-env '())
+               '(<sh-ref-length> "x")))
+
+
+;;; Command substition.
+
+(test-equal "Resolves commands"
+  '("foo")
+  (parameterize ((eval-cmd-sub identity))
+    (expand-word #f '(<sh-cmd-sub> "foo"))))
+
+(test-equal "Splits command results"
+  '("foo" "bar")
+  (parameterize ((eval-cmd-sub identity))
+    (expand-word #f '(<sh-cmd-sub> "foo bar"))))
+
+(test-equal "Resolves quoted commands"
+  '("foo")
+  (parameterize ((eval-cmd-sub identity))
+    (expand-word #f '(<sh-quote> (<sh-cmd-sub> "foo")))))
+
+(test-equal "Ignores spaces in quoted commands"
+  '("foo bar")
+  (parameterize ((eval-cmd-sub identity))
+    (expand-word #f '(<sh-quote> (<sh-cmd-sub> "foo bar")))))
+
+
+;;; Arithmetic expansion.
+;;;
+;;; Not yet implemented.
+
+
+;;; Pattern expansion.
+;;;
+;;; Not yet implemented.
+
+
+;;; Field splitting (IFS)
+;;;
+;;; FIXME: Test that field splitting respects the IFS variable.
+
+(test-end)