;;; Copyright © 2021 Gerald Sussman and Chris Hanson
;;; Copyright © 2021 David Thompson <dthompson2@worcester.edu>
;;;
;;; This program 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.
;;;
;;; This program 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 this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(use-modules (ice-9 popen)
             (srfi srfi-1))


;; 2.2.2 Implementation of the translator

(define-syntax-rule (assert cond)
  (unless cond
    (error "assertion failed" 'cond)))

;; I am excluding the write-bourne-shell-grep-command and
;; bourne-shell-command-string procedures in the book in favor of
;; using Guile's pipe API. open-pipe* does not open a shell but runs
;; grep directly, eliminating the need to do shell quoting.  The book
;; asks "Are we having fun yet?" to which I say "yes, but I draw the
;; line at shell quoting."
(define (grep regexp string)
  (let ((pipe (open-pipe* OPEN_WRITE "grep" "-e" regexp)))
    (display string pipe)
    (newline pipe)
    (zero? (status:exit-val (close-pipe pipe)))))

(define (grep-test regexp . specs)
  (for-each (lambda (spec)
              (assert
               (if (and (pair? spec) (eq? (car spec) 'not))
                   (not (grep regexp (list-ref spec 1)))
                   (grep regexp spec))))
            specs))

(define (r:dot) ".")
(define (r:bol) "^")
(define (r:eol) "$")

(define (r:seq . exprs)
  (string-append "\\(" (apply string-append exprs) "\\)"))

(define chars-needing-quoting
  '(#\. #\[ #\\ #\^ #\$ #\*))

(define (r:quote string)
  (r:seq
   (list->string
    (append-map (lambda (char)
                  (if (memv char chars-needing-quoting)
                      (list #\\ char)
                      (list char)))
                (string->list string)))))

(grep-test (r:seq (r:quote "a") (r:dot) (r:quote "c"))
           "abc")

(define (r:alt . exprs)
  (if (pair? exprs)
      (apply r:seq
             (cons (car exprs)
                   (append-map (lambda (expr)
                                 (list "\\|" expr))
                               (cdr exprs))))
      (r:seq)))

(grep-test (r:alt (r:quote "foo") (r:quote "bar") (r:quote "baz"))
           "foo" "bar" "baz" '(not "frob"))

(define (r:repeat min max expr)
  (apply r:seq
         (append (make-list min expr)
                 (cond
                  ((not max)
                   (list expr "*"))
                  ((= max min)
                   '())
                  (else
                   (make-list (- max min) (r:alt expr "")))))))

(grep-test (r:repeat 3 5 (r:alt (r:quote "cat") (r:quote "dog")))
           "catdogcat"
           "catcatdogdog"
           "dogdogcatdogdog"
           '(not "catdogfrog"))

(define (bracket string procedure)
  (list->string
   (append '(#\[)
           (procedure (string->list string))
           '(#\]))))

(define chars-needing-quoting-in-brackets
  '(#\] #\^ #\-))

(define (quote-bracketed-contents members)
  (define (optional char)
    (if (memv char members)
        (list char)
        '()))
  (append (optional #\])
          (remove (lambda (c)
                    (memv c chars-needing-quoting-in-brackets))
                  members)
          (optional #\^)
          (optional #\-)))

(define (r:char-from string)
  (case (string-length string)
    ((0) (r:seq))
    ((1) (r:quote string))
    (else
     (bracket string
              (lambda (members)
                (if (lset= eq? '(#\- #\^) members)
                    '(#\- #\^)
                    (quote-bracketed-contents members)))))))

(define (r:char-not-from string)
  (bracket string
           (lambda (members)
             (cons #\^ (quote-bracketed-contents members)))))


;; Exercise 2.6: Adding * and + to regular expressions

(define (r:* expr)
  (r:repeat 0 #f expr))

(define (r:+ expr)
  (r:repeat 1 #f expr))

(grep-test (r:* (r:quote "foo"))
           "" "foo" "bar")
(grep-test (r:seq (r:quote "foo") (r:* (r:quote "bar")))
           "foo" "foobar" '(not ""))
(grep-test (r:+ (r:quote "foo"))
           '(not "") "foo" "foofoo")
(grep-test (r:seq (r:quote "foo") (r:+ (r:quote "bar")))
           '(not "foo") "foobar" "foobarbar")

;; Exercise 2.7: A bug, one bad joke, two tweaks, and a revelation