1. Phil Hargett
  2. HH-Parse


HH-Parse / source.lisp

(in-package :hh-parse)

;; =====================================================================================================================
;; Helpers
;; =====================================================================================================================

(defun make-lines ()
  (make-array 0 :element-type 'source-code-line :adjustable t)

;; =====================================================================================================================
;; Types
;; =====================================================================================================================

(defclass source-code-line ()
  ((parser :initform nil :initarg :parser :accessor parser-of
	   :documentation "Parser positioned at end of the line")
   (text :initform "" :initarg :text :accessor text-of)))

(defclass source-code-position ()
  ((line :initform 0 :initarg :line :accessor line-at)
   (column :initform 0 :initarg :column :accessor column-at))
  (:documentation "Represents a location within a file"))

(defclass source-code-file ()
  ((lines :initform (make-lines) :accessor lines-of)
   (position :initform (make-instance 'source-code-position) :accessor current-position))
  (:documentation "Represents the state of a file being edited or parsed"))

;; =====================================================================================================================
;; Constants + globals
;; =====================================================================================================================

;; =====================================================================================================================
;; Generics
;; =====================================================================================================================

(defgeneric source-text (source)
  (:documentation "Return the text of the lines of source code as raw text"))

(defgeneric (setf source-text) (text source)
  (:documentation "Convenience method for replacing all text in source with new text"))

(defgeneric insert-line ( source text)
  (:documentation "Insert a line of text at the current position in code, and move the position to the next line after"))

(defgeneric insert-text ( source text)
  (:documentation "Insert text into the file at its current position, adjusting lines as necessary, and
    moving position to just after inserted text"))

(defgeneric insert-character ( source c )
  (:documentation "Insert a character into the file at its current position, adjusting lines as necessary, and
    moving position to just after inserted text"))

(defgeneric insert-into ( array element position)
  (:documentation "General function to insert an element into a single-dimension array"))

(defgeneric split-line ( line column )
  (:documentation "Split the line at the indicated column, returning as values the modified
   old line and the following line created from split"))

(defgeneric current-line ( source ))

(defgeneric (setf current-line) ( line source ))

(defgeneric current-line-position ( source ))

(defgeneric (setf current-line-position) ( line source))

(defgeneric current-column-position ( source ))

(defgeneric (setf current-column-position) ( column source ))

(defgeneric parse-position ( code ) )

(defgeneric (setf parse-position) ( position code ) )

(defgeneric current-lex-character ( source position )
  (:documentation "Return the character at the current position in the source"))

(defgeneric incf-lex-position (source position)
  (:documentation "Increment the position to the next character in source, adjusting for line breaks"))

(defgeneric next-lex-character ( source position)
  (:documentation "Return the current character, and advance the position in the source"))

(defgeneric next-column ( position )
  (:documentation "Increment the column component of position"))

(defgeneric next-line ( position )
  (:documentation "Increment the line component of position"))

(defgeneric flush-parsers ( source &optional line )
  (:documentation "Flush all line parsers starting at the indicated line to end of the text"))

(defgeneric reparse ( source top-node )
  (:documentation "If necessary, reparse and record the parsers for each line of the text"))

;; =====================================================================================================================
;; Implementations
;; =====================================================================================================================

(defmethod (setf current-position) :around ( (source source-code-file) (position source-code-position) )
  ;; TODO validate that the line and column are in bounds (<= # of lines, <= # of columns in line)
  (let ((new-position (call-next-method) ))

(defmethod source-text ( (source source-code-file) )
  (with-output-to-string (text)
    (loop for line across (lines-of source)
	 do (write-string (text-of line) text))))

(defmethod (setf source-text) ( (text string) (source source-code-file) )
  ;; Drop existing lines
  (setf (lines-of source) (make-lines) )
  (insert-text source text))

(defmethod (setf source-text) ( (text stream) (source source-code-file) )
  (loop for line = (read-line text nil)
       while line
       do (setf (source-text line) source)))

(defmethod insert-line ( (source source-code-file) text)
  (unless (char= (elt text (- (length text) 1) ) #\Newline)
    (setf text (concatenate 'string text #(#\Newline))))
  (insert-into (lines-of source) 
	       (make-instance 'source-code-line :text text) 
	       (line-at (current-position source)))
  (next-line source))

(defmethod insert-text ( (source source-code-file) (text string) )
  (loop for c across text
       do (insert-character source c)))

(defmethod insert-character ( (source source-code-file) (c character) )
  (flush-parsers source)
  (if (= (line-at (current-position source)) (length (lines-of source)) )
      (insert-into (lines-of source) (make-instance 'source-code-line) (line-at (current-position source))))
  (setf (text-of (current-line source) ) 
	(insert-into (text-of (current-line source)) c (column-at (current-position source))))
  (next-column source )

  (when (char= c #\Newline)
      (multiple-value-bind (old-line new-line) 
	  (split-line (current-line source) (column-at (current-position source) ) )
	(setf (current-line source) old-line)
	(next-line source)
	(insert-into (lines-of source) new-line 
		     (line-at (current-position source)))
	(setf (column-at (current-position source) ) 0))))

(defmethod insert-into ( array element position)
  ;; TODO add some type-safety here
  (unless (and (<= position (length array) ) (>= position 0) )
    (error "Insert position not in the range of 0 to the length of the array"))
  (let ((new-array (adjust-array array (+ 1 (length array)))))
    (when (> (length array) 1) ;; if was an empty array, nothing to move
      (loop for point from (- (length new-array) 2) downto position
	 do (setf (elt new-array (+ 1 point) ) (elt new-array point))))
    (setf (elt new-array position) element)

(defmethod split-line ( (old-line source-code-line) column )
  (unless (and (<= column (length (text-of old-line) ) ) (>= column 0) )
    (error "Split position not in the range of 0 to the length of the line"))
  (let* ((old-text (subseq (text-of old-line) 0 column) )
	 (new-text (subseq (text-of old-line) column) )
	 (new-line (make-instance 'source-code-line :text new-text)))
    (setf (text-of old-line) old-text)
    (values old-line new-line)))

(defmethod current-line ( (source source-code-file) )
  (elt (lines-of source) (current-line-position source)))

(defmethod (setf current-line) ( (line source-code-line) (source source-code-file)  )
  (setf (elt (lines-of source) (current-line-position source )) line))

(defmethod (setf current-line) ( (line string) (source source-code-file) )
  (setf (current-line source) (make-instance 'source-code-line :text line) ))

(defmethod current-line-position ( (source source-code-file) )
  (current-line-position (current-position source)))

(defmethod current-line-position ( (position source-code-position))
  (line-at position))

(defmethod (setf current-line-position) ( line (source source-code-file))
  (setf (current-line-position (current-position source)) line))

(defmethod (setf current-line-position) ( line (position source-code-position))
  (setf (line-at position ) line))

(defmethod current-column-position ( (source source-code-file) )
  (current-column-position (current-position source)))

(defmethod current-column-position ( (position source-code-position) )
  (column-at position))

(defmethod (setf current-column-position) ( column (source source-code-file))
  (setf (current-column-position (current-position source) ) column))

(defmethod (setf current-column-position) ( column (position source-code-position))
  (setf (column-at position ) column))

(defmethod next-column ( (position source-code-position) )
  (incf (column-at position) ))

(defmethod next-line ( (position source-code-position) )
  (incf (line-at position) ))

(defmethod next-column ( (source source-code-file) )
  (next-column (current-position source) ))

(defmethod next-line ( (source source-code-file) )
  (next-line (current-position source) ))

(defmethod positions-equal ( (left source-code-position) (right source-code-position) )
  (and (equal (line-at left) (line-at right))
       (equal (column-at left) (column-at right))))

(defmethod parse-position ( (code source-code-file) )
  "Return a copy of the current position"
  (make-instance 'source-code-position 
		 :column (current-column-position code)
		 :line (current-line-position code)))

(defmethod (setf parse-position) ( position (code source-code-file) )
  "Adjust the current position; do not retain the provided position object"
  (setf (current-column-position code) (column-at position))
  (setf (current-line-position code) (line-at position)))

(defmethod current-lex-character ( (source source-code-file) (position source-code-position))
  (let ((line-pos (current-line-position position)))
    ;; TODO we're only checking line position right now,
    ;; because if using next-character, then should never
    ;; have column-position of end of the current-line.
    ;; Of course, since it is possible to explicitly set
    ;; the column position then the assumption we make
    ;; here may not be safe
    (when (< line-pos (length (lines-of source)))   
      (let* ((line (elt (lines-of source) (current-line-position position)))
	     (text (text-of line))
	     (pos (current-column-position position)))
	(elt text pos)))))

(defmethod incf-lex-position ( (source source-code-file) (position source-code-position) )
  (let ((line-pos (current-line-position position))
	(column-pos (current-column-position position))
	(line (elt (lines-of source) (current-line-position position))))
    (if (< (1+ column-pos) (length (text-of line)))
	;; next column on same line
	(setf (current-column-position position) (1+ column-pos))
	;; go to start of next line
	  (setf (current-line-position position) (1+ line-pos))
	  (setf (current-column-position position) 0)))))

(defmethod next-lex-character ( (source source-code-file) (position source-code-position))
  (let ((c (current-lex-character source position)))
    (when c
      ;; only increment if wasn't already at end
      (incf-lex-position source position))

(defmethod flush-parsers ( (source source-code-file) &optional (line nil) )
  (loop for i from (or line (current-line-position source) ) below (length (lines-of source) )
       do (setf (parser-of (elt (lines-of source) i) ) nil)))

(defmethod reparse ( (source source-code-file) top-node)

(defun make-source (&optional text)
  (let ((source (make-instance 'source-code-file)))
    (when text
      (setf (source-text source) text))

;; =====================================================================================================================
;; Printing
;; =====================================================================================================================

(defmethod print-object ( (obj source-code-position) stream )
  (print-unreadable-object (obj stream :type t :identity t)
    (format stream " LINE=~a COLUMN=~a" (line-at obj) (column-at obj))))