;;; -*-lisp-*-
;;;
;;; Test for the charbuf scanner
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD 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 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD 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 SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

;;; The charbuf scanner is a hairy beast and in need of a thorough going
;;; over.

(cl:in-package #:sod-test)

;;;--------------------------------------------------------------------------
;;; Tests of the low-level seeking and fetching machinery.

(defclass charbuf-test (test-case) (scanner))
(add-test *sod-test-suite* (get-suite charbuf-test))

(defparameter *background-pattern*
  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789."
  "Basic pattern underlying our initial buffer contents.

   The pattern is one character short of the base-64 sequence `A-Za-z0-9./',
   with the aim of making its length be prime to the actual buffer length --
   so that the pattern doesn't repeat exactly for many buffers.")
(assert (= (gcd (length *background-pattern*) charbuf-size) 1))

(defun make-pattern-string (start end)
  "Return a string containing the buffer pattern between START and END.

   The most interesting cases occur at the boundaries between buffers; so we
   shall want to put recognizable patterns there.  The buffers are quite big
   (we import `charbuf-size' off the books so that we don't actually have to
   know exactly) but we should still fill with a repeating pattern so that we
   can detect synchronization failures.

   We fill most of the buffer with the `*background-pattern*', which has been
   chosen so as not to align nicely with the buffer size.  Across the joins,
   we write a string `<<N][N+1>>', where the boundary is between `]' and `[',
   and the numbers N and N + 1 are the numbers, in words, of the respective
   buffers."

  (with-output-to-string (out)
    (multiple-value-bind (n0 i0) (floor start charbuf-size)
      (multiple-value-bind (n1 i1) (floor end charbuf-size)

	(do ((n n0 (1+ n))) ((> n n1))
	  (let* ((l (format nil "[~R>>" n))
		 (r (format nil "<<~R]" n))
		 (m (length l))
		 (q (length *background-pattern*))
		 (i (if (= n n0) i0 0))
		 (e (if (= n n1) i1 charbuf-size))
		 (k (min (- charbuf-size m) e)))
	    (when (< i (length l))
	      (write-string l out :start i :end (min e m))
	      (setf i m))
	    (do ((o (mod (+ (* charbuf-size n) i) q) 0))
		((>= i k))
	      (let ((p (min (- k i) (- q o))))
		(write-string *background-pattern* out :start o :end (+ o p))
		(incf i p)))
	    (when (< k e)
	      (write-string r out :start (- i k) :end (- e k)))))))))

(defparameter *test-pattern* (make-pattern-string 0 10000)
  "The pattern that our test scanner is reading.")

(defmethod set-up ((test charbuf-test))
  (with-slots (scanner) test
    (let ((stream (make-string-input-stream *test-pattern*)))
      (setf scanner (make-instance 'charbuf-scanner
				   :stream stream
				   :filename "<magic test>")))))

(defun skip (scanner n)
  (assert (>= n 0))
  (charbuf-scanner-map scanner
		       (lambda (buf start end)
			 (declare (ignore buf))
			 (let ((d (- end start)))
			   (if (>= d n)
			       (values t (+ start n))
			       (progn (decf n d) (values nil 0)))))))

(defun assert-string-next (scanner pos len)
  "Assert that the next LEN characters from SCANNER are correct.

   That is, that they match the corresponding LEN characters starting at
   position POS as returned by `make-pattern-string'."
  (let ((want (make-pattern-string pos (+ pos len))))
    (dotimes (i len)
      (assert-false (scanner-at-eof-p scanner))
      (assert-eql (scanner-current-char scanner) (char want i))
      (scanner-step scanner))))

(def-test-method test-pattern ((test charbuf-test) :run nil)
  ;; Make sure the pattern is what we expect.  This is a completely different
  ;; (and considerably more stupid) way of generating the basic pattern up to
  ;; a particular length.
  (let* ((len (length *background-pattern*))
	 (string ""))
    (loop while (< (length string) len)
	  do (setf string (concatenate 'string string *test-pattern*)))
    (loop for n from 0
	  for i from 0 by charbuf-size below len
	  for l = (format nil "[~R>>" n) and r = (format nil "<<~R]" n)
	  for e = (- (+ i charbuf-size) (length r))
	  do (setf (subseq string i) l)
	  when (< e len) do (setf (subseq string e) r))
    (assert-equal (subseq string 0 len)
		  (make-pattern-string 0 len))))

(def-test-method test-read ((test charbuf-test) :run nil)
  ;; Test reading from various places.
  (with-slots (scanner) test
    (loop for prev = 0 then (+ pos len)
	  for (pos len) in '((0 10) (50 250) (4086 20)
			     (5000 3192) (9800 200)) do
	  (assert (>= pos prev))
	  (skip scanner (- pos prev))
	  (assert-string-next scanner pos len))
    (assert-true (scanner-at-eof-p scanner))))

(def-test-method test-unread ((test charbuf-test) :run nil)
  ;; Torture test for `scanner-unread', which is distressingly hairy.
  (with-slots (scanner) test

    (flet ((test (here next skip there note)
	     (assert-eql (scanner-current-char scanner) here
			 (format nil "Here (~A)." note))
	     (scanner-step scanner)
	     (assert-eql (scanner-current-char scanner) next
			 (format nil "Next (~A)." note))
	     (scanner-unread scanner here)
	     (with-scanner-place (place scanner)
	       (assert-eql (scanner-current-char scanner) here
			   (format nil "Here again (~A)." note))
	       (scanner-step scanner)
	       (assert-eql (scanner-current-char scanner) next
			   (format nil "Next again (~A)." note))
	       (skip scanner skip)
	       (assert-eql (scanner-current-char scanner) there
			   (format nil "There (~A)." note))
	       (scanner-unread scanner there)
	       (with-scanner-place (another-place scanner)
		 (scanner-restore-place scanner place)
		 (assert-eql (scanner-current-char scanner) here
			     (format nil "Here restored (~A)." note))))))

      (test #\[ #\z 51 #\0 "start")
      (skip scanner 4095)
      (test #\] #\[ 4096 #\[ "edge")

      ;; Check behaviour at EOF.  Ought to test behaviour when EOF is on a
      ;; buffer boundary too.
      (skip scanner 5904)
      (assert-false (scanner-at-eof-p scanner))
      (assert-eql (scanner-current-char scanner) #\t "EOF.")
      (scanner-step scanner)
      (assert-true (scanner-at-eof-p scanner))
      (scanner-unread scanner #\t)
      (assert-false (scanner-at-eof-p scanner))
      (assert-eql (scanner-current-char scanner) #\t "EOF again."))))

(def-test-method test-rewind ((test charbuf-test) :run nil)
  ;; Test reading, like before, but this time with rewinding.
  (with-slots (scanner) test
    (let* ((list '((0 10) (0 10000) (50 250) (4086 20)
		   (4095 4097) (5000 3192) (9999 1)))
	   (places (loop for prev = 0 then pos
			 for (pos) in list
			 do (skip scanner (- pos prev))
			 collect (scanner-capture-place scanner))))
      (loop for (pos len) in list
	    for place in places do
	    (scanner-restore-place scanner place)
	    (assert-string-next scanner pos len))
      (assert-true (scanner-at-eof-p scanner)))))

(def-test-method test-interval ((test charbuf-test) :run nil)
  ;; Test fetching intervals of text.
  (with-slots (scanner) test
    (let* ((posns '(0 12 4080 4110 5000 9000 10000))
	   (places (loop for prev = 0 then pos
			 for pos in posns
			 do (skip scanner (- pos prev))
			 collect (scanner-capture-place scanner))))
      (loop for p0 in places
	    for i0 in posns do
	    (loop for p1 in places
		  for i1 in posns do
		  (if (< i1 i0)
		      (assert-condition 'error (scanner-interval p0 p1))
		      (assert-equal (scanner-interval scanner p0 p1)
				    (make-pattern-string i0 i1)
				    (format nil "Mismatch interval ~A .. ~A."
					    i0 i1)))
		  (assert-true (scanner-at-eof-p scanner)))))))

;;;--------------------------------------------------------------------------
;;; Tests of the position tracking machinery.

(defparameter *position-test-text*
  ;; Use a roundabout method of getting tabs in there, so that they don't get
  ;; screwed by strange editors and suchlike.
  (substitute #\tab #\@ "Line one
Line two is rather longer, but not noticeably more interesting.
Line three explains that line four contains column numbers mod 10.
012345678@6789@@2345678@012
@@Line five is indented somewhat.")
  "Text for the position-tracking test.

   The text should /look/ like the following.  Note that this text here may
   get trashed by tab/space conversions and whatever, and I've indented it so
   that it doesn't look daft in the source; but the columns should remain
   where they are.

   0         1         2         3         4         5         6         7
   0123456789012345678901234567890123456789012345678901234567890123456789012
   Line one
   Line two is rather longer, but not noticeably more interesting.
   Line three explains that line four contains column numbers mod 10.
   012345678       6789            2345678 012
		   Line five is indented somewhat.

   It would be nice at some point to add additional tests for edge cases
   around buffer boundaries.  This isn't completely essential, though: the
   current implementation manages positions fairly independently of the
   buffering.")

(defparameter *known-positions*
  '(
    ;; The first few line aren't actually very interesting.  We'll
    ;; check the start and end positions, and maybe a few in the
    ;; middle.  Note that a newline character is logically a part of
    ;; the preceding line.
    (0 #\L 1 0 #\i 1 1 0) (5 #\o 1 5 #\n 1 6 5) (8 #\newline 1 8 #\L 2 0 0)
    (9 #\L 2 0 #\i 2 1 0) (72 #\newline 2 63 #\L 3 0 0)
    (73 #\L 3 0 #\i 3 1 0) (139 #\newline 3 66 #\0 4 0 0)

    ;; Now for the line with the fancy tabbings.
    (140 #\0 4 0 #\1 4 1 0)
    (148 #\8 4 8 #\tab 4 9 8)		; nothing so far
    (149 #\tab 4 9 #\6 4 16 15)		; the tab itself just follows on
    (150 #\6 4 16 #\7 4 17 16)		; but the char after is tabbed
    (154 #\tab 4 20 #\tab 4 24 23)	; next tab position
    (155 #\tab 4 24 #\2 4 32 31)	; two in a row
    (156 #\2 4 32 #\3 4 33 32)		; should be here now
    (162 #\8 4 38 #\tab 4 39 38)	; skip to the next bit
    (163 #\tab 4 39 #\0 4 40 39)	; tab is here
    (164 #\0 4 40 #\1 4 41 40)		; and doesn't move us much
    (166 #\2 4 42 #\newline 4 43 42)	; last actual character on the line
    (167 #\newline 4 43 #\tab 5 0 0)	; and the ending newline

    ;; And the final line.
    (168 #\tab 5 0 #\tab 5 8 7)		; first tab on next line
    (169 #\tab 5 8 #\L 5 16 15)		; and the second
    (170 #\L 5 16 #\i 5 17 16)		; beginning of the text
    (200 #\. 5 46 :eof 5 47 46)		; last character in the stream
    (201 :eof 5 47))			; but eof has a position too
  "List of character positions, characters and line/column numbers.

   The characters are there for sanity-checking purposes.  The format is

	(INDEX CHAR LINE COLUMN NEXT-CHAR
	 NEXT-LINE NEXT-COLUMN REWIND-COLUMN)

   which asserts that the character at INDEX is CHAR, found at the given LINE
   and COLUMN, that the next character is NEXT-CHAR, at the NEXT-LINE and
   NEXT-COLUMN, and if one unreads from there, it will be (possibly
   erroneously) claimed that the character at INDEX is at REWIND-COLUMN.
   (Restoring a captured place shouldn't get the column wrong -- only
   unreading.)

   The symbol `:eof' means that there is no character at the given INDEX,
   because the file has already ended.  However, EOF has a position which
   should be correct, and it should be possible to unread from EOF.")

(defclass charbuf-position-test (test-case) (scanner))
(add-test *sod-test-suite* (get-suite charbuf-position-test))

(defmethod set-up ((test charbuf-position-test))
  (with-slots (scanner) test
    (let ((stream (make-string-input-stream *position-test-text*)))
      (setf scanner (make-instance 'charbuf-scanner
				   :stream stream
				   :filename "<position test>")))))

(defun check-position (scanner pos char line column note)
  (if (eq char :eof)
      (assert-true (scanner-at-eof-p scanner)
		   (format nil "EOF, position ~A (~A)." pos note))
      (assert-eql char (scanner-current-char scanner)
		  (format nil "Character, position ~A (~A)." pos note)))
  (assert-eql line (scanner-line scanner)
	      (format nil "Line number, position ~A (~A)." pos note))
  (assert-eql column (scanner-column scanner)
	      (format nil "Column number, position ~A (~A)." pos note)))

(def-test-method test-simple-positions
    ((test charbuf-position-test) :run nil)
  (with-slots (scanner) test
    (loop for prev = 0 then pos
	  for (pos char line column) in *known-positions* do
	  (loop repeat (- pos prev) do (scanner-step scanner))
	  (check-position scanner pos char line column "simple"))))

(def-test-method test-rewind-positions
    ((test charbuf-position-test) :run nil)
  (with-slots (scanner) test
    (let ((places (loop for prev = 0 then pos
			for (pos char line column) in *known-positions* do
			(skip scanner (- pos prev))
			(check-position scanner pos char line column "skip")
			collect (scanner-capture-place scanner))))
      (loop for place in places
	    for (pos char line column
		     next-char next-line next-column
		     rewind-column)
	    in *known-positions* do
	    (scanner-restore-place scanner place)
	    (check-position scanner pos char line column "rewind")
	    (unless (eq char :eof)
	      (scanner-step scanner)
	      (check-position scanner (1+ pos) next-char
			      next-line next-column "step")
	      (scanner-unread scanner char)
	      (check-position scanner pos char line rewind-column
			      "unread")
	      (scanner-step scanner)
	      (check-position scanner (1+ pos) next-char
			      next-line next-column "restep"))))))

;;;----- That's all, folks --------------------------------------------------