;;;; it-lookup.lisp

(in-package #:it-lookup)
(declaim (optimize (debug 3)))

;;; "it-lookup" goes here. Hacks and glory await!

(defparameter *post-url*  "http://www.corpusthomisticum.org/it/index.age")

(defparameter *cookie-jar* (make-instance 'drakma:cookie-jar))

(defun run-query (results)
  (with-accessors ((query query) (page page)) results
    (drakma:http-request *post-url*
                         :method :POST
                         :parameters `(("text" . ,query)
                                       ("Form.option.concordances" . "concordances")
                                       ("results.currentPage" . ,(prin1-to-string page)))
                         :cookie-jar *cookie-jar*)))

(defclass it-case ()
  ((reference :initarg :reference :accessor case-reference)
   (text :initarg :text :accessor case-text)))

(defun make-adjustable-vector (&optional (base-size 10))
  (make-array base-size :adjustable t :fill-pointer 0))

(defun to-adjustable-vector (values)
  (let ((els (length values)))
    (make-array els
                :adjustable t
                :fill-pointer els
                :initial-contents values)))

(defclass it-results ()
  ((%query :initarg :query :accessor query :initform (make-adjustable-vector))
   (%page :initarg :page :accessor page :initform 1)
   (%cases :initarg :cases :accessor cases)))

(defmethod initialize-instance :after ((object it-case) &key)
  (with-slots (reference text) object
    (when (arrayp reference)
      (setf reference (elt reference 0)))
    (when (plump:element-p reference)
      (setf reference (plump-dom:text reference)))
    (setf text (subseq text (+ (search reference text) (length reference))))
    (setf reference (string-right-trim '(#\space) reference))))

(defmacro make-constructor (class &rest initargs)
  (let ((initarg-syms (mapcar #'(lambda (x) x (gensym)) initargs)))
    `(defun ,(intern (concatenate 'string (string 'make-) (string class))) ,initarg-syms
       (make-instance ',class ,@(loop for initarg in initargs
                                     for sym in initarg-syms
                                     nconc (list initarg sym))))))

(make-constructor it-case :reference :text)
(make-constructor it-results :query :cases)

(defun parse-results (results query-result)
  (setf (cases results)
        (lquery:$ (initialize query-result)
                  "p[title]"
                  (:combine ".ref" (text))
                  (map-apply #'make-it-case))))

(defgeneric format-reference (it-case stream)
  (:method ((it-case it-case) stream)
   (princ (case-reference it-case) stream)
   (fresh-line stream)))

(defparameter *underlying-stream* nil)
(defun get-real-stream (&optional default)
  (or *underlying-stream* default))

(defun format-result (parsed-result &optional (stream t))
  (let ((real-stream stream))
    (pprint-logical-block (stream nil)
      (let ((*underlying-stream* real-stream))
        (format-reference parsed-result stream))
      (pprint-indent :block 4 stream)
      (pprint-newline :mandatory stream)
      (with-slots (text) parsed-result
        (pprint-logical-block (stream (tokens text))
          (loop
            (princ (pprint-pop) stream)
            (pprint-exit-if-list-exhausted)
            (princ #\space stream)
            (pprint-newline :fill stream)))))))

(defun format-results (parsed-results &optional (stream t))
  (fresh-line stream)
  (loop :for parsed-result :across parsed-results
        :do (format-result parsed-result stream)
        :do (terpri stream)))

(defmacro compose-funcs ((&rest funcs) &rest args)
  `(funcall (compose ,@funcs) ,@args))

(defun main (args)
  (let ((results (make-instance 'it-results
                                :query nil)))

    (format *terminal-io* "~&Index Thomisticus Query Utility v0.1~%")

    (when (cadr args)
      (setf (query results) (cadr args)))

    (mainloop results)))

(defun mainloop (results)
  (handler-case
      (labels ((next-page () (incf (page results)))
               (prev-page ()
                 (with-accessors ((current-page page)) results
                   (when (> current-page 0)
                     (decf current-page))))
               (print-results (results)
                 (format *terminal-io* "~&Query: ~a, Page: ~3d~%"
                         (query results)
                         (page results)))
               (get-results (results)
                 (with-accessors ((page page) (query query)) results
                   (parse-results results
                                  (run-query results))
                   (format-results (cases results))))
               (do-action (action results)
                 (funcall action)
                 (get-results results)))

        (loop
          (format *terminal-io* "~&Query? ")
          (finish-output *terminal-io*)
          (let ((action (or (query results)
                            (read-line *terminal-io*))))
            (string-case action
              ("quit" (return-from mainloop))
              ("help"
               (format *terminal-io* "~&Help:~%~:{~4t~a: ~a~%~}~%Anything else searches.~%"
                       `(("next" "Next page of results")
                         ("prev" "Previous page of results")
                         ("quit" "Quits"))))

              ("prev"
               (do-action #'prev-page results))

              ("next"
               (do-action #'next-page results))

              (t (setf (query results)
                       action)
                 (get-results results)))
            (setf (query results) nil))))

    (end-of-file (c) (declare (ignore c)))
    (sb-sys:interactive-interrupt (c) (declare (ignore c)))))