contexts.lisp

(in-package :parser-combinators)

(defparameter *tag-stack* nil)

(defclass context-front ()
  ((context :accessor context-of :initarg :context :initform nil)
   (tags    :accessor tags-of    :initarg :tags    :initform nil)))

(defclass context-common ()
  ((length      :accessor length-of      :initarg :length      :initform 0)
   (front       :accessor front-of       :initarg :front       :initform (make-instance 'context-front))
   (cache       :accessor cache-of       :initarg :cache       :initform nil)))

(defclass context ()
  ((common      :accessor common-of      :initarg :common)
   (position    :accessor position-of    :initarg :position    :initform 0)))

(defmethod cache-of ((context context))
  (cache-of (common-of context)))

(defmethod length-of ((context context))
  (length-of (common-of context)))

(defmethod front-of ((context context))
  (front-of (common-of context)))

(defmethod (setf front-of) (new-value (context context))
  (setf (front-of (common-of context)) new-value))

(defmethod position-of ((context-front context-front))
  (position-of (context-of context-front)))

(defmacro copy-context (context class &rest additional-arguments)
  `(make-instance ,class
                  ,@(iter (with default = (gensym))
                          (for (initarg accessor) in
                               '((:common common-of)
                                 (:position position-of)))
                          (appending (when (eql (getf additional-arguments initarg default)
                                                default)
                                       `(,initarg (,accessor ,context)))))
                  ,@additional-arguments))

(defgeneric context-peek (context))

(defgeneric context-next (context))

(defgeneric context-equal (context1 context2)
  (:method ((context1 context) (context2 context))
    (or (eq context1 context2)
        (and (eq (common-of context1)
                 (common-of context2))
             (eql (position-of context1)
                  (position-of context2))))))

(defgeneric context-greater (context1 context2)
  (:method ((context1 context) (context2 context))
    (and (eq (common-of context1)
             (common-of context2))
         (> (position-of context1)
            (position-of context2)))))

(defgeneric update-front-context (context)
  (:method ((context context))
    (let ((front (front-of context)))
      (cond ((or (null (context-of front))
                 (context-greater context (context-of front)))
             (setf (context-of front) context
                   (tags-of front) (list *tag-stack*)))
            ((context-equal context (context-of front))
             (push *tag-stack* (tags-of front)))))))

(defmethod context-peek :after ((context context))
  (update-front-context context))

(defmethod context-next :around ((context context))
  (let ((cache (cache-of context)))
    (etypecase cache
      (null (call-next-method))
      (vector (or (aref cache (position-of context))
                  (setf (aref cache (position-of context))
                        (call-next-method))))
      (hash-table (or (gethash (position-of context) cache)
                      (setf (gethash (position-of context) cache)
                            (call-next-method)))))))

(defgeneric context-interval (context1 context2 &optional result-type)
  (:method :before ((context1 context) (context2 context) &optional result-type)
    (declare (ignore result-type))
    (assert (eql (common-of context1)
                 (common-of context2)))
    (assert (<= (position-of context1)
                (position-of context2))))
  (:method ((context1 context) (context2 context) &optional (result-type 'string))
    (if (= (position-of context1) (position-of context2))
        (coerce nil result-type)
        (coerce (iter (for c initially context1 then (context-next c))
                      (until (eq c context2))
                      (collect (context-peek c)))
                result-type))))

(defclass end-context (context)
  ())

(defgeneric end-context-p (context)
  (:method ((context t))
    nil)
  (:method ((context end-context))
    t))

(defmethod context-next ((context end-context))
  (error "Can't go past the end"))

(defmethod context-peek ((context end-context))
  (warn "Trying to peek past the end.")
  nil)

(defclass list-context (context)
  ((storage :accessor storage-of :initarg :storage)))

(defmethod context-next ((context list-context))
  (let ((new-position (1+ (position-of context))))
    (if (= new-position (length-of context))
        (copy-context context 'end-context :position new-position)
        (copy-context context 'list-context :storage (cdr (storage-of context)) :position new-position))))

(defmethod context-peek ((context list-context))
  (car (storage-of context)))

(defclass vector-context-common (context-common)
  ((storage :accessor storage-of :initarg :storage)))

(defclass vector-context (context)
  ())

(defmethod storage-of ((context vector-context))
  (storage-of (common-of context)))

(defmethod context-next ((context vector-context))
  (let ((new-position (1+ (position-of context))))
    (if (= new-position (length-of context))
        (copy-context context 'end-context :position new-position)
        (copy-context context 'vector-context :position new-position))))

(defmethod context-peek ((context vector-context))
  (aref (storage-of context) (position-of context)))

(defmethod context-interval ((context1 vector-context) (context2 vector-context) &optional (result-type 'string))
  (let ((storage (storage-of context1)))
    (coerce (subseq storage (position-of context1) (position-of context2)) result-type)))

(defmethod context-interval ((context1 vector-context) (context2 end-context) &optional (result-type 'string))
  (let ((storage (storage-of context1)))
    (coerce (subseq storage (position-of context1)) result-type)))

(defvar *default-context-cache* :vector)

(defun make-cache (cache-type length)
  (ecase cache-type
    ((nil) nil)
    (:vector (make-array length :initial-element nil))
    (:hashtable (make-hash-table))))

(defgeneric make-context (sequence &optional cache-type))

(defmethod make-context ((list list) &optional (cache-type *default-context-cache*))
  (if (null list)
      (make-instance 'end-context :common (make-instance 'context-common))
      (make-instance 'list-context
                     :storage list
                     :common (make-instance 'context-common
                                            :length (length list)
                                            :cache (make-cache cache-type (length list))))))

(defmethod make-context ((vector vector) &optional (cache-type *default-context-cache*))
  (if (zerop (length vector))
      (make-instance 'end-context :common (make-instance 'vector-context-common))
      (make-instance 'vector-context
                     :common (make-instance 'vector-context-common
                                            :storage vector
                                            :length (length vector)
                                            :cache (make-cache cache-type (length vector))))))