;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
#|

    Hunchncells -- Cells, Parenscript, and HTML

Copyright (C) 2008 by Andy Chambers

This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
 (http://opensource.franz.com/preamble.html), known as the LLGPL.

This library is distributed  WITHOUT ANY WARRANTY; without even 
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  

See the Lisp Lesser GNU Public License for more details.

|#

;; from	Ken Tilton <kennytilton@optonline.net>
;; to	achambers.home@gmail.com (Yes, this is you.) Learn more,
;; date	Thu, Apr 3, 2008 at 3:15 PM
;; subject	Re: [cells-devel] undersold aspect of cells
;;
;; A an interactive Lisp apropos is a good idea. The ACL gui version does
;; not search as the user types, but for fun we could do that, perhaps
;; doing it both ways to show before/after live during the talk. The ACL
;; dialogue has a checkbox for "exported only" and a pop-up menu of known
;; packages to choose-from to limit search to one package. A checkbox
;; next to it says "All" and means ignore whatever might be selected
;; (most UIs have a top item that says "All". anyway...). Then there is a
;; radio group of four buttons that also imits search to functions,
;; classes, variables, or all. Results are displayed in a scrolling list
;; with seven columns: name, package, function, setf, var, class, and
;; exported. Several of those are just booleans with an "x" showing if,
;; eg, the symbol has a function, a setter, a class, or is exported. The
;; var column shows var or con if it is a constant. The columns are
;; resizeable (bit of a frill).

;; Oh, and the input field is also a pop-up of the query history (which
;; would not make sense if each keystroke was treated as a new query. ACL
;; has a "search" button instead. Otherwise, the results pane is rebuilt
;; as the other filters are changed--the user does not have to hit Search
;; each time.

;; Anyway, I would be tempted to reinvent that as far as widget sets
;; allow: checkbox, radio button/group, the straight "search" button,
;; popup menus, and a multi-column scrolling grid view, input of course,
;; and then any decorative frames, say, to group the radio buttons.

;; Bonus points for a double-click taking them to the CLHS. :)
;;
;;


(in-package :openair)

(progn
  (declaim (optimize (debug 3) (speed 0) (safety 1) (compilation-speed 0))))

#+test
(progn
  (when (and (boundp '*oa*) *oa*)
    (trc "stopping" *oa*)
    (hunchentoot:stop-server *oa*)
    (setf *oa* nil)))

#+ughh
(setf (log-file) "hunch.txt")

(defparameter *oa* nil)


#+test
(let ((x (start-server :port 8000
           :dispatch-table *dispatch-table*)))
  (setf *oa* x)
  (setf (log-file) "hunch.txt") ;; <-kt accomplished nothing
  (trc "got server" x)
  ;(hunchentoot:stop-server x)
  (describe x))

(defun reload ()
  (cells-reset)
  (reset-sessions)
  (setf *catch-errors-p* nil
	*dispatch-table* 
	(list 
;	 (test-page "/check-test" 'web-checkbox)
	 (test-page "/apropos" 'web-apropos)
	 (create-folder-dispatcher-and-handler "/js/"
					       "/mainline/js/"))))
(defmd web-checkbox (page)
  (status (c? (param? "STATUS")))
  (kids (c? (the-kids
             (mk-div ()
               (mk-form (:action "get")
                 (mk-checkbox "Status: " status)
                 (mk-div ()
                   (mk-text (status (u^ web-checkbox))))))))))

(defmd web-apropos (page)
  (title "Lisp Apropos")
  (style "style.css")
  ;; <-kt all attributes moved into value slots of corresponding nodes
  (kids (c? (trc "page kids rule entry!!!!!!!!" self .cause)
          (the-kids
             (mk-div ()
               (mk-form (:action "get")
                 (mk-label (:for "term")
                   "Apropos: ")
                 (mk-input (:md-name :term :name :term
                             :value (c-in "md-slot-v"))) ;; <-kt start somewhere for easier testing
                 
                 (mk-checkbox "Exported: " exported-only-p)
                 
                 (mk-label (:for "pkg")
                   "Package: ")
                 (mk-select (:md-name :pkg :name "pkg" :id "pkg")
                   ;; <-kt was there an extra (list... here? Not needed
                   (loop for pkg in (subseq (list-all-packages) 0 10)
                            collect (let ((pkg pkg))
                                      (mk-option ()
                                        (mk-text (package-name pkg))))))
                 
                 (mk-text (c? (if (fm^v :pkg) "on" "all")))
                 
                 (mk-div (:id :result)
                   (mk-ul ()
                     (loop for match
                         in (bwhen (search (fm^v :term))
                              (let ((a (apropos-list search
                                         nil ;; (fm^v :pkg) <-kt- this started sneaking in, I punted
                                         (fm^v 'exported-only-p))))
                                (trc "got match count" (length a) search (fm^v :pkg) (fm^v 'exported-only-p))
                                (subseq a 0 (min 10 (length a))))) ;; <-kt- just making debugging manageable
                         do (trc "piling up match" (^id) match)
                         collect (let ((match match))
                                   (mk-li ()
                                     (mk-text match))))))))))))


(defun test-web-apropos ()
  (cells-reset)
  (reload)
  #+nah
  (let ((app (mk-web-app (:prefix "testwa"
                           :request (c-in nil))
               (make-instance 'web-apropos
                 :fm-parent *parent*))))
    (declare (ignorable app))
    (inspect app)))

(defun test-request (self &rest req)
  (trc "test req" req)
  (describe req)
  (setf (request self) req)
  (loop for (h . xh) in (updates self)
      unless (loop for (h2 . nil) in (updates self)
                 thereis (unless (eq h h2)
                           (when (fm-ascendant-p h2 h)
                             (trc nil "suppressing redundant" h :seeing-ascendant h2 (id h2))
                             t)))
      do (trc "bingo changed" h (id h))
        (trc "new xhtml" xh)
      finally (setf (updates self) nil)))

(defvar *web-app* nil)

(defun test-page (path resource-class)
  (lambda (request)
    (trc "bingo request!!!!" request path resource-class)
    (start-session)
    (let ((root (or (session-value 'root)
                  (progn
                    (print "creating new web-app...")
                    (mk-web-app (:prefix path
                                  :request (c-in request))
                      (make-instance
                          resource-class
                        :fm-parent *parent*))))))
      (setf *web-app* root)
      (setf (session-value 'root) root)
      (assert (null (updates root))) ;; <-kt stumped at one point, then the issue just went away
      (setf (request root) request)
      (handler root))))
