;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-DOC; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-doc/util.lisp,v 1.13 2015/05/29 18:21:33 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :lw-doc)
(defun file-contents (pathname &rest open-arguments)
  "Returns the whole contents of the file denoted by PATHNAME as
one sequence with the corresponding element type."
  (with-open-stream (stream (apply #'open pathname
                                   :direction :input
                                   open-arguments))
    (when stream
      (let ((buffer (make-array (file-length stream)
                                :element-type (stream-element-type stream))))
        (cond ((= (read-sequence buffer stream) (length buffer))
               buffer)
              (t (error "Incomplete READ-SEQUENCE from ~S."
                        (pathname stream))))))))
(defun first-two-equal (list-1 list-2)
  "Tests whether the first two elements of LIST-1 and LIST-2 are
pairwise EQUAL."
  (and (equal (first list-1) (first list-2))
       (equal (second list-1) (second list-2))))
(defun remove-html-entities (string)
  "Replaces \(some) HTML entities in STRING with the characters they denote."
  (flet ((un-html (target-string start end match-start match-end reg-starts reg-ends)
           (declare (ignore start end reg-starts reg-ends))
           (let ((match (subseq target-string (1+ match-start) (1- match-end))))
             (let ((entity (assoc match +html-entities+ :test #'string=)))
               (when entity
                 (return-from un-html (cdr entity))))
             (let ((char-code (parse-integer match :start 1 :junk-allowed t)))
               (when char-code
                 (return-from un-html (string (code-char char-code)))))
             (subseq target-string match-start match-end))))
    (regex-replace-all "&[^;]+;" string #'un-html)))
(defun normalize-char (char)
  "Returns a downcased version of CHAR if CHAR is an alphabetic
\(ASCII) character and #\* otherwise."
  (cond ((char<= #\a char #\z) char)
        ((char<= #\A char #\Z) (char-downcase char))
        (t #\*)))
(declaim (inline nsubseq))
(defun nsubseq (sequence start &optional (end (length sequence)))
  "Like SUBSEQ but the result shares structure with SEQUENCE."
  (make-array (- end start)
              :element-type (array-element-type sequence)
              :displaced-to sequence
              :displaced-index-offset start))
(defun make-file-name (&optional char (folder-name "permuted-index"))
  "Creates a pathname for the index file for the character CHAR
or for the start page if CHAR is NIL.  Depends on the value of
*TARGET-DIR*."
  (ensure-directories-exist
   (merge-pathnames
    (make-pathname :directory (list :relative folder-name)
                   :type "html"
                   :name (format nil "~@[permuted-~]index~@[-~A~]"
                                 (case char
                                   ((nil) nil)
                                   (#\* "non-alphabetic")
                                   (otherwise char))
                                 nil))
    *target-dir*)))
(defun escape-and-fill-spaces (string &optional start (end (length string)))
  "Replaces some characters in the substring of STRING denoted by
START and END with their XML character entities, also replaces
spaces with `&nbsp;'."
  (regex-replace-all " "
                     (escape-string (nsubseq string start end))
                     "&nbsp;"))

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-DOC; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-doc/specials.lisp,v 1.27 2015/05/29 18:21:33 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :lw-doc)
(defvar *docs-base-path*
  (make-pathname :name nil
                 :type nil
                 :version nil
                 :defaults 
                 #+(or :lispworks6.1 :lispworks7)
                 (sys:lispworks-dir "manual/online/")
                 #-(or :lispworks6.1 :lispworks7)
                 (sys:lispworks-dir "manual/online/web/"))
  "A pathname denoting the directory where the browsable
documentation can be found.")
(defvar *index-pages*
  (flet ((find-highest-numbered-html-file (pattern)
           "Finds and returns the pathname with the highest number
following the last hyphen in its name of those files in
*DOCS-BASE-PATH* which match PATTERN \(if any)."
           (lw:when-let (path
                         (first (sort (directory (merge-pathnames pattern *docs-base-path*))
                                      #'>
                                      :key (lambda (pathname)
                                             (let* ((basename (pathname-name pathname))
                                                    (hyphen-pos (position #\- basename :from-end t)))
                                               (or (parse-integer (subseq (pathname-name pathname)
                                                                          (1+ hyphen-pos))
                                                                  :junk-allowed t)
                                                   -1000000))))))
             (regex-replace-all "\\\\" (enough-namestring path *docs-base-path*) "/"))))
    `(#+win32
      ("COM" ,(find-highest-numbered-html-file "COM/html/com-*.htm")) 
      ("ED" #+:win32 ,(find-highest-numbered-html-file "EDUG-W/html/eduser-w-*.htm")
            #+(or :linux :freebsd) ,(find-highest-numbered-html-file "EDUG-U/html/eduser-u-*.htm")
            #+:mac ,(find-highest-numbered-html-file "EDUG-M/html/eduser-m-*.htm"))
      ("DLV" ,(or (find-highest-numbered-html-file "DV/html/delivery-*.htm")
		  (find-highest-numbered-html-file "DV/html/deluser-*.htm")))
      ("FLI" ,(find-highest-numbered-html-file "FLI/html/fli-*.htm"))
      ("LW" ,(or (find-highest-numbered-html-file "LW/html/lw-*.htm")
		 (find-highest-numbered-html-file "LWRM/html/lwref-*.htm")))
      ("CAPI" ,(or (find-highest-numbered-html-file "CAPRM/html/capiref-*.htm")
                   #+:win32 (find-highest-numbered-html-file "CAPI-W/html/capi-w-*.htm")
                   #+(or :linux :freebsd) (find-highest-numbered-html-file "CAPI-U/html/capi-u-*.htm")
                   #+:mac (find-highest-numbered-html-file "CAPI-M/html/capi-m-*.htm")))))
  "An alist mapping shortcuts for LW documentation sections to
the relative location of their index page.")
(defvar *link-table* (make-hash-table :test #'equal)
  "A hash table which maps symbols and editor commands to lists
with link information.")
(defvar *sorted-table* (make-hash-table :test #'equal)
  "A hash table which maps characters to a list of all
\(permuted) index entries starting with the corresponding
character.")
(defconstant +html-entities+ '(("amp" . "&")
                               ("lt" . "<")
                               ("gt" . ">")
                               ("nbsp" . " "))
  "An alist mapping some names of HTML entities to the characters
they denote.")
(defvar *link-prefix* nil
  "During the computation of the permuted index this variable can
be bound to a prefix which will be added to each link.")
(defvar *lw-link-prefix*
  #+:lispworks4.4 "http://www.lispworks.com/documentation/lw445/"
  #+:lispworks5.0 "http://www.lispworks.com/documentation/lw50/"
  #+:lispworks5.1 "http://www.lispworks.com/documentation/lw51/"
  #+:lispworks6.0 "http://www.lispworks.com/documentation/lw60/"
  #+:lispworks6.1 "http://www.lispworks.com/documentation/lw61/"
  #+:lispworks7.0 "http://www.lispworks.com/documentation/lw70/"
  "The prefix for the LispWorks online documentation.")
(defvar *html-stream* nil
  "During the creation of the permuted index this variable is
bound to the stream the HTML content is written to.")
(defvar *target-dir* nil
  "During the computation of the permuted index this variable is
bound to a pathname denoting the directory where the index should
be created.")

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-DOC; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-doc/parse.lisp,v 1.14 2015/06/08 19:01:22 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :lw-doc)
(defun save-links (shortcut symbol type links)
  "Puts all links which can be found in the string LINKS into the
hash table entry corresponding to SYMBOL and TYPE."
  (setq symbol (remove-html-entities symbol))
  (do-register-groups (link (#'parse-integer page-number))
      ("(?is)<EM\\s+CLASS=\"(?:MyCharTag|IndexPageNum)\">\\s*<A\\s+HREF=\"(.*?)\"\\s+CLASS=\"Index\">\\s*(\\d+)\\s*</A></EM>" links)
    (pushnew (list shortcut page-number link)
             (gethash (list symbol type) *link-table*)
             :test #'first-two-equal)))
(defun parse-one-file (shortcut file)
  "Parses the \(LW documentation index) file FILE for symbols and
editor commands and hands them over to SAVE-LINKS."
  (let ((contents (file-contents file)))
    (do-register-groups (symbol links)
        ("(?is)<CODE\\s+CLASS=\"Code\">\\s*([^<]*?)\\s*</CODE>[^<]*(<EM\\s*CLASS=\"(?:MyCharTag|IndexPageNum)\".*?)\\s*</P>" contents)
      (save-links shortcut symbol 'code links))
    (do-register-groups (symbol links)
        ("(?is)<B\\s+CLASS=\"Bold\">\\s*([^<]*?)\\s*</B>[^<]*(<EM\\s*CLASS=\"(?:MyCharTag|IndexPageNum)\".*?)\\s*</P>" contents)
      (save-links shortcut symbol 'bold links))))
(defun parse-files ()
  "Parses all files listed in *INDEX-PAGES* with PARSE-ONE-FILE."
  (clrhash *link-table*)
  (loop for (shortcut file%) in *index-pages*
        when file% do
        (parse-one-file shortcut (merge-pathnames file% *docs-base-path*))))
(defun find-boundaries (symbol)
  "Returns a list of indexes into the string SYMBOL which are
used to `permute' the string."
  (let ((result (list 0)))
    (do-matches (start end "(?i)(?<=\\W)\\b" symbol)
      (declare (ignore end))
      (push start result))
    (nreverse result)))
(defun fill-sorted-table ()
  "Fills the hash table *SORTED-TABLE* with all entries found in
*LINK-TABLE*."
  (loop for (symbol type) being the hash-keys of *link-table*
        using (hash-value link-info) do
          (loop for index in (find-boundaries symbol)
                for char = (normalize-char (char symbol index)) do
                  (push (list symbol index type link-info)
                        (gethash char *sorted-table*)))))
(defun sort-sorted-table-rows ()
  "Sorts the hash values of *SORTED-TABLE* in alphabetical order
\(starting at the position denoted by the `permutation' index)."
  (loop for char being the hash-keys of *sorted-table* do
    (setf (gethash char *sorted-table*)
            (stable-sort (sort (gethash char *sorted-table*)
                               #'string-lessp
                               :key #'first)
                         #'string-lessp
                         :key (lambda (link-info)
                                (destructuring-bind (symbol index &rest rest)
                                    link-info
                                  (declare (ignore rest))
                                  (nsubseq symbol index)))))))

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-DOC; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-doc/pages.lisp,v 1.12 2015/05/29 18:21:33 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :lw-doc)
(defun make-link (shortcut link)
  "Creates a HTML link for the saved link LINK and the shortcut
SHORTCUT.  Depends on the value of *LINK-PREFIX*."
  (format nil "~A~A~A"
          (case *link-prefix*
            ((nil) "../")
            ((t) *lw-link-prefix*)
            (otherwise *link-prefix*))
          (regex-replace-all "\\\\"
                             (directory-namestring (second (assoc shortcut *index-pages* :test #'string=)))
                             "/")
          link))
(defun create-char-list ()
  "Creates a list of links for the characters which appear in the
permuted index."
  (with-html-output (*html-stream*)
    (:p
     (dotimes (i 26)
       (let ((char (code-char (+ #.(char-code #\a) i))))
         (when (gethash char *sorted-table*)
           (htm
            (:a :href (file-namestring (make-file-name char))
                (str (string-upcase char)))
            " "))))
     (when (gethash #\* *sorted-table*)
       (htm
        (:a :href (file-namestring (make-file-name #\*))
            "Non-Alphabetic"))))))
(defun create-table (char)
  "Creates the HTML table with the permuted index for the
character CHAR."
  (with-html-output (*html-stream*)
    (loop for (symbol index type link-info) in (gethash char *sorted-table*)
          for left = (escape-and-fill-spaces symbol 0 index)
          for right = (escape-and-fill-spaces symbol index) do
            (labels ((write-part (string)
                       (ecase type
                         (bold
                          (htm (:b (str string))))
                         (code
                          (htm (:code (str string))))))
                     (write-link (string)
                       (cond ((null (cdr link-info))
                              (destructuring-bind (shortcut page-number link)
                                  (first link-info)
                                (htm
                                 (:a :href (make-link shortcut link)
                                     :title (format nil "~A-~A" shortcut page-number)
                                     (write-part string)))))
                              (t (write-part string)))))
              (htm
               (:tr
                (:td :align "right"
                     (write-link left))
                (:td :align "left"
                     (write-link right)
                     (when (cdr link-info)
                       (htm "   ["
                            (loop for (shortcut page-number link) in (sort (copy-list link-info)
                                           (lambda (link-entry-1 link-entry-2)
                                             (or (string< (first link-entry-1)
                                                          (first link-entry-2))
                                                 (and (string= (first link-entry-1)
                                                               (first link-entry-2))
                                                      (< (second link-entry-1)
                                                         (second link-entry-2))))))
                                  for spaces = "" then "&nbsp;" do
                                    (htm
                                      (str spaces)
                                      (:a :href (make-link shortcut link)
                                          (:em (fmt "~A-~A" shortcut page-number)))))
                            "]")))))))))
(defun create-page (&optional char)
  "Creates the index page for the character CHAR or the start
page if CHAR is NIL."
  (with-open-file (*html-stream* (make-file-name char)
                   :direction :output
                   :if-exists :supersede)
    (with-html-output (*html-stream*)
      (flet ((make-title ()
               (htm
                (fmt "Permuted Index for ~A ~A Docs~@[ - ~A~]"
                     (lisp-implementation-type)
                     (lisp-implementation-version)
                     (case char
                       ((nil) nil)
                       (#\* "Non-Alphabetic")
                       (otherwise (char-upcase char)))))))
        (htm
         (:html
          (:head
           (:title (make-title))
           (:meta :name "author" :content "Dr. Edmund Weitz, Hamburg, Germany")
           (:meta :name "copyright" :content "Dr. Edmund Weitz, Hamburg, Germany")
           (:style :type "text/css"
                   "* { font-size: 10pt; font-weight: bold; font-family: Verdana, Arial, Helvetica, Geneva, sans-serif; }
code { font-family: Courier; }
em { font-size: 8pt; font-weight: medium; }
h2 { font-size: 12pt; } "))
          (:body
           (:h2 (make-title))
           (create-char-list)
           (when char
             (htm
              (:p
               (:table :border 0 :cellspacing 0 :cellpadding 0
                       (create-table char)))
              (create-char-list))))))))))
(defun create-permuted-index (&key ((:link-prefix *link-prefix*) nil)
                                   ((:target-dir *target-dir*) *docs-base-path*))
  "Creates a directory called `permuted-index' which contains a
file `index.html' and several other files linked from there which
together comprise a permuted index for \(parts of) the LispWorks
documentation.  By default the directory is created in the same
directory where the LW browsable documentation can be found but
this can be changed by providing the TARGET-DIR keyword
parameter.  By default the links are created relative to the
afore-mentioned default directory but you can provide an
arbitrary prefix string through the keyword parameter
LINK-PREFIX.  If this parameter is T the index entries are linked
to the documentation found at the LispWorks website."
  (parse-files)
  (clrhash *sorted-table*)
  (fill-sorted-table)
  (sort-sorted-table-rows)
  (loop for char being the hash-keys of *sorted-table* do
    (create-page char))
  (create-page))

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-doc/packages.lisp,v 1.11 2015/05/29 18:21:33 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-user)
(defpackage :lw-doc
  (:use :cl
        :cl-ppcre
        :cl-who)
  (:export :*docs-base-path*
           :*link-prefix*
           :*target-dir*
           :create-permuted-index
           :make-file-name
           :make-link
           :parse-files))

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-doc/lw-doc.asd,v 1.21 2015/06/08 19:01:22 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz. All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(asdf:defsystem :lw-doc
  :version "0.3.6"
  :serial t
  :components ((:file "packages")
               (:file "specials")
               (:file "util")
               (:file "parse")
               (:file "pages"))
  :depends-on (:cl-ppcre :cl-who))

This is a quick hack to create a permuted index (similar to the one
found in the CLHS) for (parts of) the LispWorks documentation.
Exported symbols and editor commands are assembled from the
documentation's index pages using simple regular expressions.
The application was developed and tested using LispWorks 4.4.5 pro
through 6.0.0 pro on Windows and (sometimes) Linux.  No attempt has
been made to ensure that it works with other versions of LispWorks.
Requirements: ASDF, CL-PPCRE, CL-WHO.  (Google if you don't know them.)
Usage: (asdf:oos 'asdf:load-op :lw-doc)
       (lw-doc:create-permuted-index)
       See the documentation string of this function for more options.

Version 0.3.6
2015-06-08
More changes for 7.0 release
Version 0.3.5
2015-05-29
Changes for 7.0 release
Version 0.3.4
2012-05-05
Changes for 6.1 release (thanks to Kamil Shakirov)
Version 0.3.3
2010-06-21
Fix bug introduced in 0.3.2 (reported by Yuri Davidovsky)
Version 0.3.2
2010-01-19
A version-independent way of generating *INDEX-PAGES* (Raymond Wiker)
Version 0.3.1
2010-01-11
Fix typo in README (thanks to Nico de Jager)
Version 0.3.0
2010-01-10
Changes for 6.0 release
Version 0.2.1
2008-08-18
Added index page for FreeBSD (thanks to Rommel Martinez)
Version 0.2.0
2008-03-27
Changes for 5.1 release
Version 0.1.7
2008-03-11
Internal release
Changes for 5.1 RC1
Changed order of manuals (for better documentation lookup in LW-ADD-ONS)
Version 0.1.6
2007-12-22
Internal release
Changes for 5.1 beta
Version 0.1.5
2006-08-01
Changes for 5.0 release
Version 0.1.4
2006-05-24
Prepare for 5.0 release
Version 0.1.3
2005-07-11
Use SYS:LISPWORKS-DIR instead of hack.  (Note to self: RTFM.)
Version 0.1.2
2005-07-01
Better sorting.
Version 0.1.1
2005-06-27
Make MAKE-FILE-NAME usable for CAPI-OVERVIEW module.
Export more names.
Version 0.1.0
2005-05-17
Initial release.

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-ADD-ONS; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/systems.lisp,v 1.21 2015/05/29 18:23:24 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :lw-add-ons)
(defun list-all-systems-known-to-asdf ()
  "Returns a list of all systems ASDF knows already."
  (loop for name being the hash-keys of asdf::*defined-systems*
        collect name))
(defun list-all-systems-in-central-registry ()
  "Returns a list of all systems in ASDF's central registry."
  (mapcar #'pathname-name
          (delete-duplicates
           (loop for dir in asdf:*central-registry*
                 for defaults = (eval dir)
                 when defaults
                 nconc (mapcar #'file-namestring
                               (directory
                                (make-pathname :defaults defaults
                                               :version :newest
                                               :type "asd"
                                               :name :wild
                                               :case :local))))
           :test #'string=)))
(defun list-asdf-systems ()
  "Returns the systems in ASDF's central registry and those which ASDF
already knows."
  (nunion (list-all-systems-known-to-asdf)
          (list-all-systems-in-central-registry)
          :test #'string=))
(defun pathname-name* (name)
  "First \(using ASDF) converts NAME to a string if it isn't one
already, then treats the resulting string as a pathname
designator and returns its name component."
  (pathname-name (asdf::coerce-name name)))
(defun component-foreign-dependencies (operation component)
  "The set difference of ASDF::COMPONENT-DEPENDS-ON and
ASDF::COMPONENT-SELF-DEPENDENCIES."
  (remove-if (lambda (dep)
               (member (asdf:component-name component) (cdr dep)
                       :test #'string=))
             (asdf:component-depends-on operation component)))
(defun translate-dep (dep)
  "Translate an ASDF dependency into a Common Defsystem
requirement."
  (ecase (first dep)
    (asdf:compile-op
     `(:compile ,@(mapcar #'pathname-name* (rest dep))))
    (asdf:load-op
     `(:load ,@(mapcar #'pathname-name* (rest dep))))))
(defun translate-deps (deps)
  "Translate a list of ASDF dependencies into a list of Common
Defsystem requirement."
  (loop for dep in deps
        collect (translate-dep dep)))
(defun make-unique-module-name (name parent-names)
  "Tries to create a `unique' module name from a list of parent
name strings and the name of an internal module itself."
  ;; note that we use "->" which we hope won't occur as the name of
  ;; some `real' ASDF system
  (intern (format nil "~{~A->~}~A"
                  (mapcar #'string-upcase parent-names)
                  (string-upcase name))
          :cl-user))
(let ((load-op (load-time-value
                 (asdf:make-operation 'asdf:load-op)))
      (compile-op (load-time-value
                    (asdf:make-operation 'asdf:compile-op))))
  (defun translate-module (module &optional parent-names)
    "Translates the ASDF module MODULE into a Common Defsystem
system definition.  If the module is not a `stand-alone' system
with its own .asd file then PARENT-NAMES is the list of the names
of its parent systems.  Returns the name of the module."
    ;; set to 0 temporarily as we'll have a lot of calls to INTERN
    (let ((*symbol-alloc-gen-num* 0)
          (module-name (asdf:component-name module))
          (module-pathname (asdf:component-pathname module))
          members rules substitutions global-deps)
      (labels ((to-symbol (name &key symbol no-subs)
                 "Converts the string NAME into a symbol in the
CL-USER package after upcasing it.  Registers this conversion in
the SUBSTITUTIONS alist unless NO-SUBS if true.  If SYMBOL is not
NIL take this argument as the resulting symbol, i.e. no
conversion, just registration."
                 (let ((symbol (or symbol
                                   (intern (string-upcase name) :cl-user))))
                   (unless no-subs
                     (push (cons name symbol) substitutions))
                   symbol))
               (resolve-global-deps (translated-deps)
                 "Accepts a list of dependencies \(requirements)
in Common Defsystem format and registers the involved components
as members of type :SYSTEM.  Returns its original argument."
                 (dolist (translated-dep translated-deps)
                   (dolist (candidate (rest translated-dep))
                     ;; make sure each members occurs only once
                     (unless (find candidate global-deps :test #'equal)
                       (push candidate global-deps)
                       (push `(,(to-symbol candidate) :type :system) members))))
                 translated-deps))
        (unless parent-names
          ;; if this is a "top-level" system record its "external"
          ;; dependencies as well (if there are any) - don't do this
          ;; for "internal" modules as they may depend on files in the
          ;; containing system which can't be expressed in Common
          ;; Defsystem
          (when-let (load-deps (component-foreign-dependencies load-op module))
            (push `(:in-order-to :load :all
                                 (:requires ,@(resolve-global-deps
                                               (translate-deps load-deps))))
                  rules))
          (when-let (compile-deps (component-foreign-dependencies compile-op module))
            (push `(:in-order-to :compile :all
                                 (:requires ,@(resolve-global-deps
                                               (translate-deps compile-deps))))
                  rules)))
        ;; loop through all components of the system
        (dolist (component (asdf:module-components module))
          (let* ((input-files (asdf:input-files compile-op component))
                 (input-file (first input-files))
                 (component-name (asdf:component-name component)))
            (when (cdr input-files)
              (error "More than one input file for component ~S." component-name))
            ;; first the requirement - note that we don't translate
            ;; the name here (as in NAME-TO-USE below)
            (when-let (load-deps (asdf::component-depends-on load-op component))
              (push `(:in-order-to :load (,component-name)
                                   (:requires ,@(translate-deps load-deps)))
                    rules))
            (when-let (compile-deps (asdf::component-depends-on compile-op component))
              (push `(:in-order-to :compile (,component-name)
                                   (:requires ,@(translate-deps compile-deps)))
                    rules))
            (etypecase component
              (asdf:system
               ;; an external system: just list it
               (push `(,(to-symbol component-name) :type :system) members))
              (asdf:module
               ;; a module: list it but also create it as a Common
               ;; Defsystem system - this ain't really correct as a
               ;; module isn't a `stand-alone' system but I see no
               ;; better way to do it as LW can't do nested `modules'
               (let ((child-name
                       (translate-module component
                                         (append parent-names (list module-name)))))
                 (push `(,(to-symbol component-name :symbol child-name) :type :system)
                       members)))
              ((or asdf:c-source-file asdf:cl-source-file)
               ;; a file: the tricky part is to get the name right
               (let* ((real-file-name (enough-namestring input-file module-pathname))
                      (file-type (or (pathname-type real-file-name)
                                     (asdf:source-file-type component module)))
                      ;; use the Common Defsystem file types if possible
                      (type (cond ((string-equal file-type "lisp")
                                   :lisp-file)
                                  ((string-equal file-type "lsp")
                                   :lsp-file)
                                  ((string-equal file-type "c")
                                   :c-file) 
                                  (t nil)))
                      ;; compute pathname of file from component name
                      ;; like Common Defsystem would do it
                      (path-computed-from-name (merge-pathnames
                                                (merge-pathnames (string component-name)
                                                                 (cond (type
                                                                        (make-pathname :type file-type))
                                                                       (t (make-pathname))))
                                                module-pathname))
                      ;; compute pathname of file from REAL-FILE-NAME
                      ;; like Common Defsystem would do it
                      (path-computed-from-file-name (merge-pathnames real-file-name
                                                                     module-pathname))
                      ;; decide which name to use for the component
                      ;; based on some value of `elegance' - we want
                      ;; it short if possible
                      (name-to-use (cond ((equal input-file path-computed-from-name)
                                          component-name)
                                         ((equal input-file path-computed-from-file-name)
                                          (namestring real-file-name))
                                         (t (namestring input-file)))))
                 ;; if we couldn't use the component name itself we
                 ;; have to register this conversion
                 (unless (equal component-name name-to-use)
                   (push (cons component-name (pathname-name* name-to-use))
                         substitutions))
                 ;; finally list it as a member
                 (push `(,name-to-use :type ,(or type :lisp-file)) members))))))
        (let ((module-name (cond (parent-names
                                  ;; if this module has parents then
                                  ;; construct an artifical name that
                                  ;; shows the heritage and tries to
                                  ;; make the module unique
                                  (make-unique-module-name module-name
                                                           parent-names))
                                 (t
                                  ;; otherwise just convert to symbol
                                  ;; without registering
                                  (to-symbol module-name :no-subs t)))))
          (eval
           `(defsystem ,module-name
                (:default-pathname ,module-pathname)
              :members ,(nreverse members)
              ;; now finally the substitutions
              :rules ,(nsublis substitutions (nreverse rules)
                               :test #'equal)))
          ;; may be useful for large systems...
          (gc-if-needed)
          module-name)))))
#-:lispworks7
(defadvice (asdf::parse-component-form translate :around
                                       :documentation "Whenever
an ASDF system is parsed we translate it to a Common Defsystem
system definition on the fly.")
    (parent options)
  (let ((candidate (call-next-advice parent options)))
    (when (and *translate-asdf-systems*
               (typep candidate 'asdf:system))
      (ignore-errors*
        (translate-module candidate)))
    candidate))
#-:lispworks7
;; translate the systems that have already been loaded
(dolist (sys-name '(:cl-ppcre :cl-who :lw-doc :lw-add-ons))
  (translate-module (asdf:find-system sys-name)))

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-ADD-ONS; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/specials.lisp,v 1.41 2015/03/06 12:54:25 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;; This code copied almost verbatim from SLIME, see
;;; <http://common-lisp.net/project/slime/>
(in-package :lw-add-ons)
(defvar *show-doc-string-when-showing-arglist* nil
  "Whether the editor command \"Insert Space and Show Arglist\"
is supposed to show the documentation string as well.")
(defvar *max-completions-to-show* 14
  "The maximum number of possible completions shown in the echo
area by \"Complete Symbol Without Dialog.\"")
(defvar *insert-right-parenthesis-if-no-args* t
  "Whether \"Complete Symbol Without Dialog\" should insert a
right parenthesis if the function is known to have an empty
argument list.")
(defvar *mop-page* "c:/home/lisp/doc/mop/dictionary.html"
  "A pathname specifier denoting the location of the dictionary
page from the AMOP HTML version.  The page is available online at
<http://www.lisp.org/mop/dictionary.html>")
(defvar *completion-match-function* 'compound-prefix-match
  "The function used by \"Complete Symbol Without Dialog\" to
check possible completions.  Should be a designator for a
function of two arguments and return true iff the second argument
is a possible completion of the first one.")
(defvar *use-abbreviated-complete-symbol* t
  "Whether \"Indent And Complete Symbol\" should call \"Abbreviated
Complete Symbol\" \(only available in LispWorks 5.1 or higher) instead
of \"Complete Symbol Without Dialog\".")
(defvar *make-backup-filename-function* nil
  "If the value of this variable is not NIL, then it should be a
designator for a function of one argument which accepts a pathname and
returns a pathname.  LispWork's own EDITOR::MAKE-BACKUP-FILENAME
function will be replaced with this one in this case.")
(defvar *backup-directory*
  #+(or :win32 :macosx)
  (merge-pathnames "LW-ADD-ONS/Backups/"
                   (probe-file
                    (sys:get-folder-path #+:win32 :local-appdata
                                         #+:macosx :my-appsupport
                                         :create t)))
  #+:linux #p"~/.lw-backups/"
  "The directory where backups are stored if the value of
*MAKE-BACKUP-FILENAME-FUNCTION* denotes the function
'MAKE-BACKUP-FILENAME-USING-BACKUP-DIRECTORY.  It is recommended that
you dont't use this directory for other purposes.")
(defvar *swank-loader-pathname* #p"c:/emacs/site-lisp/slime/swank-loader.lisp"
  "A pathname specifier denoting the location of the
`swank-loader.lisp' file.  Only needed if one wants to start the
Swank server from LW - see function START-SWANK-SERVER.")
(defvar *translate-asdf-systems* t
  "Whether ASDF systems should be automatically converted to LispWorks
Common Defsystem systems.")
(defvar *max-info-length* 400
  "The maximum length \(in characters) of a message shown by
SHOW-INFO \(unless FULL-LENGTH-P is true).")
(defvar *apropos-max-search-list-length* 20
  "The maximal number of items in the CAPI:TEXT-INPUT-CHOICE in the
Apropos Dialog.")
(defvar *apropos-max-string-length* 50
  "The maximum amount of characters to show when an object is printed
in the pull down menu of an Apropos Dialog.")
(defvar *apropos-print-length* 5
  "*PRINT-LENGTH* is bound to this value while the Apropos Dialog
displays objects.")
(defvar *apropos-print-level* 5
  "*PRINT-LEVEL* is bound to this value while the Apropos Dialog
displays objects.")
(defvar *product-registry-path* '("Software" "Edi Weitz" "LW-ADD-ONS")
  "The product registry path used for storing and retrieving user
preferences.")
(defconstant +apropos-headline+ '("Symbol Name" "Package" "Fun" "Var" "Class" "Exp")
  "The headline of the Apropos Dialog's result panel.")
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *use-quicklisp-for-shortcut-l* t
    "Whether listener shortcuts should prefer Quicklisp."))
(defvar *listener-shortcuts*
  (load-time-value
   (append
    (list '("c" . "Compile ASDF System")
          '("t" . "Test ASDF System")
          '("p" . "Change Package")
          '("i" . "Change Package")
          '("cd" . "Change Directory")
          '("pwd" . "Show Directory")
          '("q" . "Quit")
          '("s" . "Quit"))
    #-:quicklisp
    (list '("l" . "Load ASDF System"))
    #+:quicklisp
    (if *use-quicklisp-for-shortcut-l*
      (list '("a" . "Load ASDF System") '("l" . "Quickload Library"))
      (list '("l" . "Load ASDF System") '("ql" . "Quickload Library")))))
  "An alist of commands that can be invoked with \"Invoke Listener
Shortcut\" or with comma at beginning of listener line, each one
preceded by a shortcut.")
(defvar *swank-started-p* nil
  "Whether START-SWANK-SERVER has already been called.")
(defvar *doc-hash* (make-hash-table :test #'equalp)
  "A hash table which maps entries \(mostly strings) for the
\"Meta Documentation\" command to URLs.")
(defvar *doc-hash-entries* nil
  "The list of all keys of *DOC-HASH*.")
(defvar *hyperdoc-packages* nil
  "Temporarily set to a list of all packages that have a symbol named
HYPERDOC-LOOKUP during execution of \"Meta Documentation\" command.")
(defvar *doc-entries* nil
  "Temporarily set to a list of all candidates during completion in
\"Meta Documentation\" command.")
(defconstant +cl-user-package+ (load-time-value (find-package :cl-user))
  "The CL-USER package.")
(defconstant +keyword-package+ (load-time-value (find-package :keyword))
  "The KEYWORD package.")
(defvar *all-asdf-systems* nil
  "Temporarily bound to a list of all ASDF system names while
prompting for a system name.")
(defvar *search-end* nil
  "If this variable is bound to a true value then it should be a
pointer and EDITOR::FIND-PATTERN \(and EDITOR:I-FIND-PATTERN) won't
search beyond this point \(unless called with a non-NIL LIMIT
argument).")
(defvar *change-default-for-file-prompt* nil
  "If this variable is bound to a a true value then the function
EDITOR:PROMPT-FOR-FILE will use the full file name \(as opposed
to the file's location) as its default string \(unless a default
string was explicitly specified or the DEFAULT argument is a
string).")
#+:editor-does-not-have-go-back
(defvar *find-definitions-stack* nil
  "Stack of previous positions \(points) within the editor, used by
new \"Pop Definitions Stack\" command.  See docs.")
(defvar *lw-add-ons-break-on-signals* nil
  "The value *BREAK-ON-SIGNALS* is bound to in IGNORE-ERRORS*.  Set
this to NIL to debug LW-ADD-ONS.")
(defvar *temp-files* nil
  "A list of temporary files which should be deleted when the image
exits.")
(defvar *clhs-add-ons*
  '(("~C: Character" "22_caa.htm")
    ("~%: Newline" "22_cab.htm")
    ("~&: Freshline" "22_cac.htm")
    ("~|: Page" "22_cad.htm")
    ("~~: Tilde" "22_cae.htm")
    ("~R: Radix" "22_cba.htm")
    ("~D: Decimal" "22_cbb.htm")
    ("~B: Binary" "22_cbc.htm")
    ("~O: Octal" "22_cbd.htm")
    ("~X: Hexadecimal" "22_cbe.htm")
    ("~F: Fixed-Format Floating-Point" "22_cca.htm")
    ("~E: Exponential Floating-Point" "22_ccb.htm")
    ("~G: General Floating-Point" "22_ccc.htm")
    ("~$: Monetary Floating-Point" "22_ccd.htm")
    ("~A: Aesthetic" "22_cda.htm")
    ("~S: Standard" "22_cdb.htm")
    ("~W: Write" "22_cdc.htm")
    ("~_: Conditional Newline" "22_cea.htm")
    ("~<: Logical Block" "22_ceb.htm")
    ("~I: Indent" "22_cec.htm")
    ("~/: Call Function" "22_ced.htm")
    ("~T: Tabulate" "22_cfa.htm")
    ("~<: Justification" "22_cfb.htm")
    ("~>: End of Justification" "22_cfc.htm")
    ("~*: Go-To" "22_cga.htm")
    ("~[: Conditional Expression" "22_cgb.htm")
    ("~]: End of Conditional Expression" "22_cgc.htm")
    ("~{: Iteration" "22_cgd.htm")
    ("~}: End of Iteration" "22_cge.htm")
    ("~?: Recursive Processing" "22_cgf.htm")
    ("~(: Case Conversion" "22_cha.htm")
    ("~): End of Case Conversion" "22_chb.htm")
    ("~P: Plural" "22_chc.htm")
    ("~;: Clause Separator" "22_cia.htm")
    ("~^: Escape Upward" "22_cib.htm")
    ("~NEWLINE: Ignored Newline" "22_cic.htm")
    ("\(" "02_da.htm")
    (")" "02_db.htm")
    ("'" "02_dc.htm")
    (";" "02_dd.htm")
    ("\"" "02_de.htm")
    ("`" "02_df.htm")
    ("," "02_dg.htm")
    ("#" "02_dh.htm")
    ("#\\" "02_dha.htm")
    ("#'" "02_dhb.htm")
    ("#\(" "02_dhc.htm")
    ("#*" "02_dhd.htm")
    ("#:" "02_dhe.htm")
    ("#." "02_dhf.htm")
    ("#b" "02_dhg.htm")
    ("#o" "02_dhh.htm")
    ("#x" "02_dhi.htm")
    ("#r" "02_dhj.htm")
    ("#c" "02_dhk.htm")
    ("#a" "02_dhl.htm")
    ("#s" "02_dhm.htm")
    ("#p" "02_dhn.htm")
    ("#=" "02_dho.htm")
    ("##" "02_dhp.htm")
    ("#+" "02_dhq.htm")
    ("#-" "02_dhr.htm")
    ("#|" "02_dhs.htm")
    ("#<" "02_dht.htm")
    ("loop:with" "06_abb.htm")
    ("loop:for-as-..." "06_aba.htm")
    ("loop:for-as-arithmetic" "06_abaa.htm")
    ("loop:for-as-in-list" "06_abab.htm")
    ("loop:for-as-on-list" "06_abac.htm")
    ("loop:for-as-equals-then" "06_abad.htm")
    ("loop:for-as-across" "06_abae.htm")
    ("loop:for-as-hash" "06_abaf.htm")
    ("loop:for-as-package" "06_abag.htm")            
    ("loop:collect" "06_ac.htm")
    ("loop:append" "06_ac.htm")
    ("loop:nconc" "06_ac.htm")
    ("loop:count" "06_ac.htm")
    ("loop:maximize" "06_ac.htm")
    ("loop:minimize" "06_ac.htm")
    ("loop:sum" "06_ac.htm")
    ("loop:repeat" "06_ad.htm")
    ("loop:always" "06_ad.htm")
    ("loop:never" "06_ad.htm")
    ("loop:thereis" "06_ad.htm")
    ("loop:while" "06_ad.htm")
    ("loop:until" "06_ad.htm")
    ("loop:do" "06_ae.htm")
    ("loop:return" "06_ae.htm")
    ("loop:if" "06_af.htm")
    ("loop:when" "06_af.htm")
    ("loop:unless" "06_af.htm")
    ("loop:else" "06_af.htm")
    ("loop:it" "06_af.htm")
    ("loop:end" "06_af.htm")
    ("loop:named" "06_aga.htm")
    ("loop:initially" "06_agb.htm")
    ("loop:finally" "06_agb.htm")
    (":test" "17_ba.htm")
    (":test-not" "17_ba.htm")
    (":key" "17_bb.htm")
    (":eof-error-p" "23_aca.htm")
    (":recursive-p" "23_acb.htm"))
  "A couple of additions to the `standard' CLHS entries that can
be found in the symbol-index.")
(defparameter *mop-links*
  '(("add-dependent" "#add-dependent")
    ("add-direct-method" "#add-direct-method")
    ("add-direct-subclass" "#add-direct-subclass")
    ("add-method" "#add-method")
    ("allocate-instance" "#allocate-instance")
    ("class-... " "#class-")
    ("class-default-initargs" "#class-mo-readers")
    ("class-direct-default-initargs" "#class-mo-readers")
    ("class-direct-slots" "#class-mo-readers")
    ("class-direct-subclasses" "#class-mo-readers")
    ("class-direct-superclasses" "#class-mo-readers")
    ("class-finalized-p" "#class-mo-readers")
    ("class-name" "#class-mo-readers")
    ("class-precedence-list" "#class-mo-readers")
    ("class-prototype" "#class-mo-readers")
    ("class-slots" "#class-mo-readers")
    ("compute-applicable-methods" "#compute-applicable-methods")
    ("compute-applicable-methods-using-classes" "#compute-applicable-methods-using-classes")
    ("compute-class-precedence-list" "#compute-class-precedence-list")
    ("compute-default-initargs" "#compute-default-initargs")
    ("compute-discriminating-function" "#compute-discriminating-function")
    ("compute-effective-method" "#compute-effective-method")
    ("compute-effective-slot-definition" "#compute-effective-slot-definition")
    ("compute-slots" "#compute-slots")
    ("direct-slot-definition-class" "#direct-slot-definition-class")
    ("effective-slot-definition-class" "#effective-slot-definition-class")
    ("ensure-class" "#ensure-class")
    ("ensure-class-using-class" "#ensure-class-using-class")
    ("ensure-generic-function" "#ensure-generic-function")
    ("ensure-generic-function-using-class" "#ensure-generic-function-using-class")
    ("eql-specializer-object" "#eql-specializer-object")
    ("extract-lambda-list" "#extract-lambda-list")
    ("extract-specializer-names" "#extract-specializer-names")
    ("finalize-inheritance" "#finalize-inheritance")
    ("find-method-combination" "#find-method-combination")
    ("funcallable-standard-instance-access" "#funcallable-standard-instance-access")
    ("generic-function-..." "#generic-function-")
    ("generic-function-argument-precedence-order" "#gf-mo-readers")
    ("generic-function-declarations" "#gf-mo-readers")
    ("generic-function-lambda-list" "#gf-mo-readers")
    ("generic-function-method-class" "#gf-mo-readers")
    ("generic-function-method-combination" "#gf-mo-readers")
    ("generic-function-methods" "#gf-mo-readers")
    ("generic-function-name" "#gf-mo-readers")
    ("Initialization of Class Metaobjects" "#class-mo-init")
    ("Initialization of Generic Function Metaobjects" "#gf-mo-init")
    ("Initialization of Method Metaobjects" "#Initialization")
    ("Initialization of Slot Definition Metaobjects" "#Initialization")    
    ("intern-eql-specializer" "#intern-eql-specializer")
    ("make-instance" "#make-instance")
    ("make-method-lambda" "#make-method-lambda")
    ("map-dependents" "#map-dependents")
    ("method-..." "#method-")
    ("method-function" "#method-mo-readers")
    ("method-generic-function" "#method-mo-readers")
    ("method-lambda-list" "#method-mo-readers")
    ("method-specializers" "#method-mo-readers")
    ("method-qualifiers" "#method-mo-readers")
    ("accessor-method-slot-definition" "#method-mo-readers")
    ("Readers for Class Metaobjects" "#class-mo-readers")
    ("Readers for Generic Function Metaobjects" "#gf-mo-readers")
    ("Readers for Method Metaobjects" "#method-mo-readers")
    ("Readers for Slot Definition Metaobjects" "#slotd-mo-readers")
    ("reader-method-class" "#reader-method-class")
    ("remove-dependent" "#remove-dependent")
    ("remove-direct-method" "#remove-direct-method")
    ("remove-direct-subclass" "#remove-direct-subclass")
    ("remove-method" "#remove-method")
    ("set-funcallable-instance-function" "#set-funcallable-instance-function")
    ("\(setf class-name)" "#\(setf class-name)")
    ("\(setf generic-function-name)" "#\(setf generic-function-name)")
    ("\(setf slot-value-using-class)" "#\(setf slot-value-using-class)")
    ("slot-boundp-using-class" "#slot-boundp-using-class")
    ("slot-definition-..." "#slot-definition-")
    ("slot-definition-allocation" "#slotd-mo-readers")
    ("slot-definition-initargs" "#slotd-mo-readers")
    ("slot-definition-initform" "#slotd-mo-readers")
    ("slot-definition-initfunction" "#slotd-mo-readers")
    ("slot-definition-location" "#slotd-mo-readers")
    ("slot-definition-name" "#slotd-mo-readers")
    ("slot-definition-readers" "#slotd-mo-readers")
    ("slot-definition-writers" "#slotd-mo-readers")
    ("slot-definition-type" "#slotd-mo-readers")
    ("slot-makunbound-using-class" "#slot-makunbound-using-class")
    ("slot-value-using-class" "#slot-value-using-class")
    ("specializer-direct-generic-functions" "#specializer-direct-generic-functions")
    ("specializer-direct-methods" "#specializer-direct-methods")
    ("standard-instance-access" "#standard-instance-access")
    ("update-dependent" "#update-dependent")
    ("validate-superclass" "#validate-superclass")
    ("writer-method-class" "#writer-method-class"))
  "URL fragments for all relevant entries in the MOP dictionary
page.")

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/packages.lisp,v 1.21 2015/05/29 18:23:24 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-user)
(defpackage :lw-add-ons
  (:use :editor :cl-ppcre)
  (:add-use-defaults t)
  (:export :*backup-directory*
           :*completion-match-function*
           :*insert-right-parenthesis-if-no-args*
           :*listener-shortcuts*
           :*make-backup-filename-function*
           :*max-completions-to-show*
           :*max-info-length*
           :*mop-page*
           :*product-registry-path*
           :*show-doc-string-when-showing-arglist*
           :*swank-loader-pathname*
           #-:lispworks7
           :*translate-asdf-systems*
           :*use-abbreviated-complete-symbol*
           :*use-quicklisp-for-shortcut-l*
           :make-backup-filename-using-backup-directory
           :start-swank-server))

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-ADD-ONS; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/misc.lisp,v 1.31 2015/03/06 12:54:25 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :lw-add-ons)
(defmacro ignore-errors* (&body body)
  "Like IGNORE-ERRORS, but also binds *BREAK-ON-SIGNALS* to
*LW-ADD-ONS-BREAK-ON-SIGNALS* so that LW-ADD-ONS usually doesn't
interfer with debugging."
  `(let ((*break-on-signals* *lw-add-ons-break-on-signals*))
     (ignore-errors ,@body)))
(defun browse-anchored-uri (uri)
  "Show the URI URI in a browser."
  ;; workaround because older versions of LispWorks's HWEB:BROWSE
  ;; function swallow the fragment part of the URI - based on an
  ;; idea by Nick Levine
  #-(or :lispworks5 :lispworks6)
  (let ((temp-file (make-temp-file nil "html")))
    (push temp-file *temp-files*)
    (with-open-file (out temp-file
                         :direction :output
                         :if-exists :supersede)
      (format out "<html><head><meta http-equiv=refresh content=\"0;url=~A\"></head></html>"
              uri))
    (hweb:browse (namestring temp-file)))
  #+(or :lispworks5 :lispworks6)
  (hweb:browse uri))
(defun start-swank-server ()
  "Starts Swank so you can control LispWorks from Emacs via
SLIME.  Note that this might cause conflicts with the LW IDE."
  (unless *swank-loader-pathname*
    (error "You need to specify *SWANK-LOADER-PATHNAME*."))
  (unless *swank-started-p*
    (load *swank-loader-pathname*)
    (setq *swank-started-p* t))
  (funcall (find-symbol "CREATE-SERVER" :swank) :dont-close t))
(defun starts-with-p (string prefix &key (test #'char-equal))
  "Whether the string STRING starts with PREFIX."
  (let ((mismatch (mismatch string prefix :test test)))
    (or (null mismatch)
        (= mismatch (length prefix)))))
(defun tile-windows-vertically (screen)
  "Tiles windows vertically if in MDI mode."
  (let ((podium
         (capi:locate-interface 'lispworks-tools::lispworks-podium
                                :screen screen)))
    (when (and podium
               (typep podium 'lispworks-tools::lispworks-win32-mdi-podium))
      (capi:execute-with-interface podium 'capi::windows-menu-callback 
                                   podium :tile-vertically))))
(defun open-editor-and-tile-windows-vertically (screen)
  "Opens an editor if necessary and tiles windows vertically."
  (capi:find-interface 'lw-tools:editor)
  (tile-windows-vertically screen))
(defun gui-inspect (object)
  "Opens an IDE inspector to inspect the object OBJECT."
  (capi:find-interface 'lw-tools:inspector :object object))
(defun format-object-for-apropos (object)
  "Returns a string representing OBJECT which isn't \(much) longer
than *APROPOS-STRING-LENGTH*."
  (with-standard-io-syntax
    (let* ((*print-circle* t)
           (*print-readably* nil)
           (*print-length* *apropos-print-length*)
           (*print-level* *apropos-print-level*)
           (string (format nil "~S" object)))
      (cond ((<= (length string) *apropos-max-string-length*)
             string)
            (t (format nil "~A ..."
                       (subseq string 0 *apropos-max-string-length*)))))))
(defun source-can-be-found (symbol)
  "Whether a source location for the symbol SYMBOL is known."
  (remove :unknown
          (append (dspec:find-name-locations dspec:*dspec-classes* symbol)
                  (dspec:find-name-locations '(function) `(setf ,symbol)))
          :test #'eq
          :key #'second))
(defun documentation-uri (symbol)
  "Returns the documentation URI for the symbol SYMBOL if it exists."
  ;; see "Meta Documentation" command
  (let* ((symbol-string (and symbol
                             (format nil "~:[~;:~]~A"
                                     (keywordp symbol)
                                     (symbol-name symbol)))))
    (and symbol-string (doc-entry symbol-string))))
(setf (sys:product-registry-path :lw-add-ons)
      *product-registry-path*)
(defun get-apropos-user-preference (key default)
  (multiple-value-bind (value present)
      (user-preference "Apropos Dialog Settings" key
                       :product :lw-add-ons)
    (if present value default)))
(defun set-apropos-user-preferences (&rest args)
  (loop for (key value . nil) on args by #'cddr
        do (setf (user-preference "Apropos Dialog Settings" key
                                  :product :lw-add-ons)
                 value)))
(define-action "When quitting image" "Delete temporary files"
  (lambda ()
    (loop for file in *temp-files*
          do (ignore-errors* (delete-file file)))))
;; stuff for Nikodemus Siivola's HYPERDOC
;; see <http://common-lisp.net/project/hyperdoc/>
;; and <http://www.cliki.net/hyperdoc>
(defvar *hyperdoc-base-uri* "http://weitz.de/lw-add-ons/")
(let ((exported-symbols-alist
       (loop for symbol in '(*completion-match-function*
                             *show-doc-string-when-showing-arglist*
                             *max-completions-to-show*
                             *insert-right-parenthesis-if-no-args*
                             *mop-page*
                             *translate-asdf-systems*
                             *listener-shortcuts*
                             *max-info-length*
                             *swank-loader-pathname*
                             start-swank-server)
             collect (cons symbol
                           (concatenate 'string
                                        "#"
                                        (string-downcase symbol))))))
  (defun hyperdoc-lookup (symbol type)
    (declare (ignore type))
    (cdr (assoc symbol
                exported-symbols-alist
                :test #'eq))))
               

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/lw-add-ons.asd,v 1.63 2015/08/09 15:18:49 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :cl-user)
(defpackage :lw-add-ons-asd
  (:use :cl :asdf))
(in-package :lw-add-ons-asd)
(unless (find-symbol "LIST-PANEL-RIGHT-CLICK-SELECTION-BEHAVIOR" :capi)
  (pushnew :no-right-click-selection-behavior *features*))
(when (find-symbol "*DONT-UNDO*" :editor)
  (pushnew :editor-has-dont-undo *features*))
(unless (find-symbol "WITH-BUFFER-LOCKED" :editor)
  (pushnew :editor-does-not-have-with-buffer-locked *features*))
(unless (find-symbol "I-FIND-PATTERN" :editor)
  (pushnew :editor-does-not-have-i-find-pattern *features*))
(unless (find-symbol "ABBREVIATED-COMPLETE-SYMBOL-COMMAND" :editor)
  (pushnew :editor-does-not-have-abbreviated-complete-symbol *features*))
(unless (find-symbol "GO-BACK-COMMAND" :editor)
  (pushnew :editor-does-not-have-go-back *features*))
(unless system::*auto-start-environment-p*
  (pushnew :console-image *features*))
(pushnew :lw-add-ons *features*)
#-:lispworks7
(require "hqn-web")
#+(and :win32 (not :console-image))
(require "dde")
(asdf:defsystem :lw-add-ons
  :version "0.10.3"
  :serial t
  :components ((:file "packages")
               (:file "specials")
               (:file "misc")
               (:file "documentation")
               #+(and :win32 (not :console-image)) (:file "ide-server")
               (:file "apropos")
               (:file "completions")
               (:file "systems")
               (:file "editor")
               (:file "commands"))
  :depends-on (:lw-doc))

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-ADD-ONS; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/ide-server.lisp,v 1.11 2015/03/06 12:54:25 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;; This code is from the LispWorks Knowledgebase - see
;;; <http://www.lispworks.com/kb/55af67dc408cab568025687f004b1442.html>
(in-package :lw-add-ons)
(win32:define-dde-server lispworks-ide-server ()
                         ()
                         (:service "LispWorks"))
(win32:define-dde-dispatch-topic editor
                                 :server lispworks-ide-server)
(win32:define-dde-server-function (open :topic editor)
                                  :execute
                                  ((filename string))
                                  (let ((path (probe-file filename)))
                                    (when path
                                      (ed path)
                                      t)))
(defun run-lispworks-ide-server-loop ()
  "Starts the DDE server and runs its message loop."
  (win32:start-dde-server 'lispworks-ide-server)
  (loop (mp:wait-processing-events 1)))
(defvar *lispworks-ide-server-process-info*
  '("DDE IDE Server" () run-lispworks-ide-server-loop))
;; Make the server run automatically when LispWorks starts.
(pushnew *lispworks-ide-server-process-info* mp:*initial-processes*
         :test 'equal :key 'car)

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-ADD-ONS; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/editor.lisp,v 1.47 2015/03/06 12:54:25 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved. 
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :lw-add-ons)
(defun symbol-string-at-point (&key (point (current-point)) previous)
  "Returns two values - a string denoting the symbol at POINT and
the package to use at that POINT if the symbol isn't
package-qualified.  PREVIOUS controls whether to look at the
previous symbol if POINT is between two symbols."
  (ignore-errors*
    (let ((string (editor::read-symbol-from-point :point point
                                                  :read-package-name t
                                                  :previous previous))
          (package (editor::buffer-package-to-use point)))
      (values string package))))
(defun symbol-at-point (&key (point (current-point)) previous)
  "Returns the symbol at POINT.  PREVIOUS controls whether to
look at the previous symbol if POINT is between two symbols."
  (ignore-errors*
    (multiple-value-bind (string package)
        (symbol-string-at-point :point point :previous previous)
      (let* ((*package* package)
             (candidate (read-from-string string)))
        (and (symbolp candidate)
             candidate)))))
(defun enclosing-operators ()
  "Returns a list of potential operators \(symbols behind an
opening parenthesis) starting from point and going up backwards."
  (save-excursion
    (loop while (ignore-errors*
                  (backward-up-list-command 1) t)
          when (when (looking-at "\(")
                 (forward-character-command 1)
                 (prog1
                   (symbol-at-point)
                   (forward-character-command -1)))
          collect it)))
(defun show-info (info &key full-length-p)
  "Shows the string INFO in the echo area.  Shows no more than
*MAX-INFO-LENGTH* unless FULL-LENGHT-P is true."
  (apply #'message
         (if (and (not full-length-p)
                  (> (length info) *max-info-length*))
           (list "~A [...]" (subseq info 0 *max-info-length*))
           (list "~A" info))))
(defun show-arglist ()
  "Shows the argument list of the nearest enclosing operator that
has a function definition in the echo arrea.  Shows the doc
string as well unless *SHOW-DOC-STRING-WHEN-SHOWING-ARGLIST* is
NIL."
  (when-let (object
             (loop for operator in (enclosing-operators)
                   when (and (symbolp operator)
                             (fboundp operator))
                   do (return operator)))
    (show-info (format nil "~A~@[~%~A~]"
                       (cons object (function-lambda-list object))
                       (and *show-doc-string-when-showing-arglist*
                            (documentation object 'function))))))
(defun completions-for-echo-area (completions)
  "Returns a string which shows a two-column list of the elements
\(which should be strings) in COMPLETIONS but no more than
*MAX-COMPLETIONS-TO-SHOW* of them."
  (let ((max-left-width
         (loop for completion in completions
               for i from 1 to *max-completions-to-show*
               when (oddp i)
               maximize (length completion))))
    (with-output-to-string (out)
      (format out "~&Possible completions:~%~%")
      (loop for (completion-1 completion-2 . rest) on completions by #'cddr
            for i from 1 to *max-completions-to-show* by 2
            do (format out "~&~VA  ~A" max-left-width
                       completion-1
                       (cond ((and rest
                                   (>= (1+ i) *max-completions-to-show*))
                              "[...]")
                             (completion-2)
                             (t "")))))))
(defun char-before ()
  "Returns the character before the current point."
  (character-at (current-point) -1))
(defun maybe-insert-right-parenthesis ()
  "If the symbol at or before point is in function position and
denotes a function with an empty lambda list inserts a right
parenthesis, otherwise inserts a space and show the argument list
in the echo area."
  (when-let (symbol (symbol-at-point :previous t))
    (when (and (save-excursion
                 (backward-form-command 1)
                 (eql (char-before) #\())
               (symbolp symbol)
               (fboundp symbol))
      (cond ((null (function-lambda-list symbol))
             (self-insert-command 1 #\)))
            ((not (looking-at " "))
             (insert-space-and-show-arglist-command nil))))))
#-:editor-has-dont-undo
(defmacro without-undo-with-cleanups (buffer form &body cleanups)
  "Editor utility macro.  See source code for LW editor."
  (lw:rebinding (buffer)
    (lw:with-unique-names (was-recording)
      `(let ((,was-recording (editor::check-set-buffer-without-undo ,buffer)))
         (unwind-protect
             ,form
           (when ,was-recording
             (editor::set-buffer-flag-bit ,buffer editor::*buffer-flag-dont-record-undo* nil))
           ,@cleanups)))))
#-:editor-has-dont-undo
(defmacro recording-for-undo-internal (point1 point2 line-start-p &body body)
  "Does the whole work for RECORDING-FOR-UNDO.  See source code for LW editor."
  (lw:with-unique-names (old-string start end want-undo before-modified buffer-sym)
    (lw:rebinding (point1 point2)
      `(let* ((,buffer-sym (point-buffer ,point1))
              (,want-undo (editor::check-want-to-record-undo-p ,buffer-sym nil))
              (,before-modified (editor::buffer-modified-tick ,buffer-sym))
              (,start (when ,want-undo 
                         (let ((lsp ,line-start-p)
                               (sp (copy-i-point ,point1 :before-insert)))
                           (if lsp 
                             (line-start sp))
                           sp)))
              (,end (when ,want-undo (copy-i-point ,point2 :after-insert)))
              (,old-string (when ,want-undo
                             (editor::points-to-buffer-string ,start ,end))))
         (without-undo-with-cleanups ,buffer-sym
             (progn ,@body)
           (when ,want-undo
             (editor::record-replace-region ,start ,end ,old-string ,before-modified)
             (editor::delete-it ,start)
             (editor::delete-it ,end)))))))
#-:editor-has-dont-undo
(defmacro recording-for-undo (point1 point2 &body body)
  "Performs code in BODY and records changes between POINT1 and
POINT2 for undo operation.  See source code for LW editor."
  `(recording-for-undo-internal ,point1 ,point2 nil ,@body))
#-:editor-has-dont-undo
(defmacro recording-for-undo-locking (point1 point2 &body body)
  "Like RECORDING-FOR-UNDO, but with lock.  See source code for LW editor."
  (lw:rebinding (point1)
    #-:editor-does-not-have-with-buffer-locked
    `(with-buffer-locked ((point-buffer ,point1))
       (recording-for-undo ,point1 ,point2 ,@body))
    #+:editor-does-not-have-with-buffer-locked
    `(editor::with-locked-buffer (point-buffer ,point1)
       (recording-for-undo ,point1 ,point2 ,@body))))
#+:editor-has-dont-undo
(defmacro recording-for-undo (point1 point2 &body body)
  "Performs code in BODY and records changes between POINT1 and
POINT2 for undo operation.  See source code for LW editor."
  (lw:with-unique-names (old-string start end dont changed)
    (lw:rebinding (point1 point2)
      `(let* ((,dont editor::*dont-undo*)
              (,changed (buffer-modified (point-buffer ,point1)))
              (,start (unless ,dont (copy-i-point ,point1 :before-insert)))
              (,end (unless ,dont (copy-i-point ,point2 :after-insert)))
              (,old-string (unless ,dont (editor::points-to-buffer-string ,point1 ,point2))))
         (unwind-protect
             (let ((editor::*dont-undo* t))
               ,@body)
           (progn
             (unless ,dont
               (editor::record-replace-region ,start ,end ,old-string ,changed)
               (editor::delete-it ,start)
               (editor::delete-it ,end))))))))
(defmacro recording-for-undo% (point1 point2 &body body)
  "Helper macro which dispatches to RECORDING-FOR-UNDO or
RECORDING-FOR-UNDO-LOCKING depending on the LispWorks release."
  #-:editor-has-dont-undo
  `(recording-for-undo-locking ,point1 ,point2
     ,@body)
  #+:editor-has-dont-undo
  `(recording-for-undo ,point1 ,point2
     ,@body))
(defun current-line ()
  "Returns the line the point is currently on as a string."
  (line-string (current-point)))
(defun can-move-upwards-p ()
  "Returns true if it is possible to move backward up from the
current point."
  (save-excursion
    (with-point ((point (current-point)))
      (backward-up-list-command 1)
      (point< (current-point) point))))
(defadvice (editor:find-alternate-file-command change-prompt :around
                                               :documentation "Makes
sure FIND-ALTERNATE-FILE-COMMAND provides the full pathname of the
current buffer as the default when prompting.")
    (p &optional pathname (buffer (current-buffer)))
  (let ((*change-default-for-file-prompt* t))
    (call-next-advice p pathname buffer)))
(defadvice (editor:find-alternate-file-command refresh :after
                                               :documentation "After
FIND-ALTERNATE-COMMAND has run makes sure the contents of the buffer
are consistent with the file on disk.")
    (p &optional pathname (buffer (current-buffer)))
  (declare (ignore p pathname))
  (let ((pathname (buffer-pathname buffer)))
    (unless (check-disk-version-consistent pathname buffer)
      (let* ((tn (probe-file pathname))
             (pn (or tn (editor::canonical-pathname pathname))))
        (editor::read-da-file pn tn buffer)))))
(defadvice (editor:prompt-for-file change-prompt :around
                                   :documentation "When DEFAULT-STRING
is NIL, DEFAULT is a pathname, and *CHANGE-DEFAULT-FOR-FILE-PROMPT* is
true sets the full namestring of DEFAULT to be the default string.")
    (&rest rest &key default default-string &allow-other-keys)
  (let ((default-string (cond (default-string)
                              ((and *change-default-for-file-prompt*
                                    (pathnamep default))
                               (namestring default))
                              ((pathnamep default)
                               (namestring (pathname-location default)))
                              (t default))))
    (apply #'call-next-advice
           :default-string default-string
           rest)))
                                        
(defadvice (editor::find-pattern region-only :around
                                 :documentation "Searches only up
until *SEARCH-END* unless the value of this variable is NIL.")
    (point pattern &optional limit)
  (cond ((and (null limit)
              *search-end*)
         (call-next-advice point pattern *search-end*))
        (t (call-next-advice point pattern limit))))
#-:editor-does-not-have-i-find-pattern
(defadvice (editor::i-find-pattern region-only :around
                                   :documentation "Searches only up
until *SEARCH-END* unless the value of this variable is NIL.")
    (point pattern &optional limit)
  (cond ((and (null limit)
              *search-end*)
         (call-next-advice point pattern *search-end*))
        (t (call-next-advice point pattern limit))))
(defadvice (editor::query-replace-string region-only :around
                                         :documentation "Performs
operation only up until *SEARCH-END* unless the value of this variable
is NIL.  Also makes sure that all replacements can be undone with one
undo command.")
    (&rest rest &key (point (current-point)) &allow-other-keys)
  (let* ((current-mark (and (variable-value-if-bound 'editor::active-region-overlay
                                                     :buffer (current-buffer))
                            (current-mark nil t)))
         (switch-p (and current-mark
                        (point< current-mark (current-point))))
         (*search-end* (and current-mark
                            (copy-point (cond (switch-p (current-point))
                                              (t current-mark)))))
         (start (cond ((and current-mark switch-p)
                       current-mark)
                      (current-mark (current-point))
                      (t point))))
    (unwind-protect
        (with-point ((%start start)
                     (%end (or *search-end*
                               (current-point))))
          (unless *search-end*
            (editor:buffer-end %end))
          #+:editor-has-dont-undo
          (recording-for-undo %start %end
            (apply #'call-next-advice :point start rest))
          ;; in new LispWorks versions it is no longer necessary to
          ;; record for undo here
          #-:editor-has-dont-undo          
          (apply #'call-next-advice :point start rest))
      (when *search-end*
        (delete-point *search-end*)))))
(defadvice (editor::find-next-ordinary-window allow-listener :around
                                              :documentation "Allows
the \"Next Ordinary Window\" command to switch to a listener window.")
    (current-window)
  (let ((*forbidden-buffers* (remove :listener *forbidden-buffers*)))
    (call-next-advice current-window)))
#+:editor-does-not-have-go-back
(defun push-onto-definitions-stack ()
  "Pushes current point onto *FIND-DEFINITIONS-STACK* unless the
buffer isn't selectable."
  (unless (editor::forbidden-buffer-p (current-buffer))
    (push (copy-point (current-point))
          *find-definitions-stack*)))
#+:editor-does-not-have-go-back
(defadvice (find-source-command push-onto-definitions-stack :around
                                :documentation "Pushes current point
onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))
#+:editor-does-not-have-go-back
(defadvice (find-source-for-dspec-command push-onto-definitions-stack :around
                                          :documentation "Pushes
current point onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))
#+:editor-does-not-have-go-back
(defadvice (find-command-definition-command push-onto-definitions-stack :around
                                            :documentation "Pushes
current point onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))
#+:editor-does-not-have-go-back
(defadvice (editor::edit-callers-command push-onto-definitions-stack :around
                                         :documentation "Pushes
current point onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))
#+:editor-does-not-have-go-back
(defadvice (editor::edit-callees-command push-onto-definitions-stack :around
                                         :documentation "Pushes
current point onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))
#+:editor-does-not-have-go-back
(defadvice (find-tag-command push-onto-definitions-stack :around
                             :documentation "Pushes current point onto
*FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))
#+:editor-does-not-have-go-back
(defadvice (tags-search-command push-onto-definitions-stack :around
                                :documentation "Pushes current point
onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))
#+:editor-does-not-have-go-back
(defadvice (continue-tags-search-command push-onto-definitions-stack :around
                                         :documentation "Pushes
current point onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (when editor::*meta-comma-action*
    (push-onto-definitions-stack))
  (apply #'call-next-advice args))
(defun complete-system (string parse-inf)
  "Completion function used by PROMPT-FOR-ASDF-SYSTEM."
  (declare (ignore parse-inf))
  (editor::complete-string string *all-asdf-systems*
                           :ignore-case t))
(defun prompt-for-asdf-system (string &optional prompt help no-check)
  "Prompts for an ASDF system name with STRING being the default."
  (let ((*all-asdf-systems* (list-asdf-systems)))
    (editor::parse-for-something
     :prompt (or prompt "ASDF system: ")
     :must-exist t
     :help (or help "Type a name of an ASDF system.")
     :default (or string "")
     :default-string (or string "")
     :verify-func (if no-check
                    (lambda (string parse-inf)
                      (declare (ignore parse-inf))
                      string)
                    (lambda (string parse-inf)
                      (declare (ignore parse-inf))
                      (and (find string *all-asdf-systems* :test #'string-equal)
                           string)))
     :type :string
     :default-in-prompt nil
     :complete-func 'complete-system)))
(defun prompt-for-asdf-system-with-default (&optional prompt help no-check)
  "Prompts for an ASDF system name and tries to find a default in the
default directory of the current buffer."
  (let* ((directory (editor::buffer-default-directory (editor:current-buffer)))
         (candidate (first (directory (make-pathname :name nil
                                                     :type "asd"
                                                     :defaults directory))))
         (default (and candidate
                       (pathname-name candidate))))
    (prompt-for-asdf-system default prompt help no-check)))
(defun complete-shortcut (string parse-inf)
  "Completion function used by PROMPT-FOR-LISTENER-SHORTCUT."
  (declare (ignore parse-inf))
  (editor::complete-string string (mapcar #'cdr *listener-shortcuts*)
                           :ignore-case t))
(defun find-full-name (abbrev)
  "Given an abbreviation finds the first item in *LISTENER-SHORTCUTS*
that is named by this abbreviation."
  (or (loop for (short . long) in *listener-shortcuts*
            when (string-equal short abbrev)
            do (return long))
      (loop for (nil . long) in *listener-shortcuts*
            when (starts-with-p long abbrev)
            do (return long))))
(defun prompt-for-listener-shortcut ()
  "Prompts for a listener shortcut."
  (let ((input
         (editor::parse-for-something
          :prompt (format nil "Shortcut [~{~A~^,~}] or Command: "
                          (sort (mapcar #'car *listener-shortcuts*) #'string-lessp))
          :must-exist t
          :help (format nil "Type the name or abbreviation of a listener shortcut:~%~%~{~A: ~A~%~}"
                        (loop for (short . long) in *listener-shortcuts*
                              collect short
                              collect long))
          :default ""
          :default-string ""
          :verify-func (lambda (string parse-inf)
                         (declare (ignore parse-inf))
                         (and (find-full-name string)
                              string))
          :type :string
          :default-in-prompt nil
          :complete-func 'complete-shortcut)))
    (find-full-name input)))
(eval-when (:compile-toplevel :load-toplevel :execute)
  (let ((*handle-warn-on-redefinition* :quiet))
    (defmacro with-input-from-region ((var start end) &body body &environment env)
      "During the evaluation of BODY, VAR is bound to a stream which
returns input from the region denoted by START and END."
      (multiple-value-bind (forms decls)
          (dspec:separate-declarations body env)
        `(let ((,var (pop editor::*free-editor-region-streams*)))
           ,@decls
           (setq ,var 
                 (if ,var
                   (editor::modify-editor-region-stream ,var ,start ,end)
                   (editor::make-editor-region-stream ,start ,end)))
           (unwind-protect
               (progn ,@forms)
             (editor::free-region-stream ,var)))))))
(defmacro with-compilation-environment-at-point ((point &key (compilep nil)
                                                             start-message
                                                             end-message)
                                                        &body body)
  (with-unique-names (buffer)
    `(editor::with-compilation-environment-at-point-fn
      ,point ,start-message ,end-message
      #'(lambda (,buffer)
          (let* ((,(if compilep '*compile-file-pathname* '*load-pathname*)
                  (buffer-pathname ,buffer))
                 (,(if compilep '*compile-file-truename* '*load-truename*)
                  (buffer-pathname ,buffer)) ; buffer-pathname _is_ a truename
                 )
            ,@body)))))
(defun returning-lisp-eval (buffer start end print)
  "Evaluates the region in the buffer BUFFER which is denoted by
START and END and returns the result."
  (with-compilation-environment-at-point (start :start-message "Evaluating..."
                                                :end-message (and (not (editor::windowp print))
                                                                  "Finished evaluating"))
    (with-input-from-region (stream start end)
      (let ((out-stream (if (streamp print)
                          print
                          (editor::buffer-stream buffer)))
            return-value)
        (handler-case
            (progn
              (common-utilities:load-text-stream
               stream
               :exit-load-p t
               :eval-function #'(lambda (form)
                                  (multiple-value-list
                                    (editor::editor-eval buffer form)))
               :print-function #'(lambda (result)
                                   (setq return-value result)
                                   (and print
                                        (if (editor::windowp print)
                                          (process-character
                                           `(message ,editor::*values-format-string* ,result)
                                           print)
                                          (editor::in-output-eval-results out-stream result)))))
              return-value)
          (end-of-file (x)
            (editor::report-region-lisp-eval-error "Incomplete S-expression in region " x)
            (return-from returning-lisp-eval nil))
          (reader-error (x)
            (editor::report-region-lisp-eval-error "Error while reading: ~a " x)
            (return-from returning-lisp-eval nil)))))))
(defmacro with-output-to-help-window ((stream &rest options) &body body)
  "Executes BODY with output that goes to STREAM redirected to an
IDE help window."
  `(editor::with-output-to-help-window-1
       #'(lambda (,stream) ,@body)
     ,@options))
(defun complete-package-name (string parse-inf)
  "Like the function of the same name in the EDITOR package, but
case-insensitive."
  (declare (ignore parse-inf))
  (editor::complete-string
   string
   (sort (loop for pkg in (list-all-packages)
               append (cons (package-name pkg) (package-nicknames pkg)))
         'string<)
   :ignore-case t))
(defun verify-package-func (string parse-inf)
  "Like the function of the same name in the EDITOR package, but
case-insensitive."
  (declare (type editor::parse-inf parse-inf))
  (or (find-package (ignore-errors* (read-from-string (string-upcase string))))
      (if (and (parse-inf-must-exist parse-inf)
	       (not (editor::recursive-parse 'prompt-for-y-or-n
                                             :prompt 
                                             "No such package.  Create it?")))
	  (values nil :no-value)
	(make-package string))))
(defun prompt-for-package* (&key (must-exist  t)
                                 (default *package*)
                                 (prompt  "package: ")
                                 (help  "Type a package name.")
                                 &allow-other-keys)
  "Like EDITOR:PROMPT-FOR-PACKAGE, but case-insensitive."
  (editor::parse-for-something :prompt prompt
                               :must-exist must-exist
                               :help help
                               :default default
                               :verify-func  'verify-package-func
                               :type :keyword
                               :complete-func 'complete-package-name
                               :default default))
(defun clean-namestring (namestring)
  "Replaces characters in NAMESTRING which are illegal for a filename
with underlines.  This function is aimed at Microsoft Windows but
shouldn't do any harm on OS X or Linux."
  (regex-replace-all "[\\\\/?*:<>|\"\\000-\\037]" namestring "_"))
(defun normalize-pathname-for-backup (pathname)
  "Converts the full form of the pathname designator PATHNAME to a
string that is suitable \(modulo illegal characters) as the NAME
component of a filename.  This is a simplified form of what GNU Emacs
does."
  (regex-replace-all "[/\\\\]" 
                     (regex-replace "^([a-zA-Z]):[/\\\\]"
                                    (namestring pathname)
                                    "!drive_\\1!")
                     "!"))
(defun make-backup-filename-using-backup-directory (pathname)
  "Creates and returns a backup pathname for PATHNAME.  Assumes that
*BACKUP-DIRECTORY* denotes a directory.  Note that due to the way the
backup pathname is constructed it is possible that two different files
end up with the same backup filename!"
  (ensure-directories-exist
   (make-pathname :name (clean-namestring
                         (normalize-pathname-for-backup pathname))
                  :type nil
                  :version nil
                  :defaults *backup-directory*)))
(defadvice (editor::make-backup-filename alternative-location :around
                                         :documentation "Circumvents
the original function if the variable *MAKE-BACKUP-FILENAME-FUNCTION*
specifies another function to be used instead.")
    (pathname)
  (cond (*make-backup-filename-function*
         (funcall *make-backup-filename-function* pathname))
        (t (call-next-advice pathname))))

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-ADD-ONS; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/documentation.lisp,v 1.20 2015/05/29 18:23:24 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :lw-add-ons)
(defun manual-dir (&optional relative-path)
  "Returns a namestring for the LW browsable documentation
directory, optionally appending the string RELATIVE-PATH."
  (namestring (sys:lispworks-dir
               (format nil
                       #+(or :lispworks6.1 :lispworks7)
                       "manual/online/~A"
                       #-(or :lispworks6.1 :lispworks7)
                       "manual/online/web/~A"
                       (or relative-path "")))))
(defun remove-backslashes (string)
  "Returns STRING with backslashes replaced with slashes."
  (regex-replace-all "\\\\" string "/"))
(defun make-file-url (pathspec)
  "Accepts a pathname designator and returns a corresponding file
URL."
  (format nil "file:///~A"
          (remove-backslashes (namestring pathspec))))
(defun doc-entry (entry)
  "Returns the URL for the entry ENTRY."
  (or (ignore-errors* (do-hyperdoc-lookup entry))
      (gethash entry *doc-hash*)))
(defun add-doc-entry (entry link)
  "Sets the URL for the entry ENTRY to be LINK."
  (setf (gethash entry *doc-hash*) link))
(defun add-clhs-entry (entry link)
  "Accepts a CLHS entry and the name of the corresponding HTML
file \(maybe with fragment part) and creates the right *DOC-HASH*
entry."
  (let ((clhs-prefix
          (load-time-value
            (make-file-url (manual-dir "CLHS/Body/")))))
    (add-doc-entry entry (format nil "~A~A" clhs-prefix link))))
(defun collect-lw-links ()
  "Puts entries for all LW-specific functions into *DOC-HASH*
using functionality from the LW-DOC module."
  (lw-doc:parse-files)
  (let ((lw-doc:*link-prefix*
          (make-file-url (manual-dir))))
    (loop for (symbol nil) being the hash-keys of lw-doc::*link-table*
          using (hash-value ((shortcut nil link) . nil))
          do (add-doc-entry symbol (lw-doc::make-link shortcut link)))))
(defun collect-clhs-links ()
  "Puts all CLHS `standard' entries into *DOC-HASH* using the
`Map_Sym.txt' file."
  (with-open-file (map (merge-pathnames "Map_Sym.txt"
                                        (manual-dir "CLHS/Data/")))
    (loop for symbol-line = (read-line map nil nil)
          for link-line = (read-line map nil nil)
          while (and symbol-line link-line)
          do (add-clhs-entry symbol-line (subseq link-line 8)))))
(defun collect-clhs-add-on-links ()
  "Adds additional CLHS entries as defined in *CLHS-ADD-ONS*."
  (loop for (entry link) in *clhs-add-ons*
        do (add-clhs-entry entry link)))
(defun collect-mop-links ()
  "Adds MOP entries as defined by the fragments in *MOP-LINKS*."
  (let ((mop-url (make-file-url *mop-page*)))
    (loop for (entry link) in *mop-links*
          do (add-doc-entry entry (format nil "~A~A" mop-url link)))))
(defun setup-doc-entries ()
  "Empties *DOC-HASH* and then \(re-)fills it as described above.
Finally sets up *DOC-HASH-ENTRIES* as well."
  (clrhash *doc-hash*)
  (collect-mop-links)
  (collect-lw-links)
  (collect-clhs-links)
  (collect-clhs-add-on-links)
  (setq *doc-hash-entries*
        (loop for key being the hash-keys of *doc-hash*
              collect key)))
;; now do it
(setup-doc-entries)
(defun complete-doc-entry (string parse-inf)
  "Completion function used by \"Meta Documentation\" command."
  (declare (ignore parse-inf))
  (editor::complete-string string *doc-entries*
                           :ignore-case t))
(defun hyperdoc-lookup-function-and-base-uri (package)
  "If PACKAGE is a package with Hyperdoc support the lookup function
and the base URI are returned as two values."
  (let ((lookup-symbol (find-symbol "HYPERDOC-LOOKUP" package))
        (base-uri-symbol (find-symbol "*HYPERDOC-BASE-URI*" package)))
    (when (and lookup-symbol
               base-uri-symbol
               (fboundp lookup-symbol)
               (boundp base-uri-symbol))
      (values (symbol-function lookup-symbol)
              (symbol-value base-uri-symbol)))))
(defmethod do-hyperdoc-lookup ((symbol symbol))
  "Checks if SYMBOL has an associated Hyperdoc URI and returns it."
  (let ((package (symbol-package symbol)))
    (multiple-value-bind (lookup-function base-uri)
        (hyperdoc-lookup-function-and-base-uri package)
      (when-let (partial-uri (and lookup-function
                                  (or (funcall lookup-function symbol 'function)
                                      (funcall lookup-function symbol 'variable))))
        (string-append base-uri partial-uri)))))
(defmethod do-hyperdoc-lookup ((string string))
  "Applies DO-HYPERDOC-LOOKUP to all external symbols named STRING in
all packages with Hyperdoc support."
  (loop for package in (list-all-packages)
        for is-candidate = (hyperdoc-lookup-function-and-base-uri package)
        for (symbol status) = (multiple-value-list
                               (and is-candidate
                                    (find-symbol (string-upcase string) package)))
        for uri = (and symbol (eq status :external)
                       (do-hyperdoc-lookup symbol))
        when uri do (return uri)))
(defun collect-hyperdoc-entries ()
  "Collects a list of \(downcased) symbol names of all external
symbols in all packages with Hyperdoc support."
  (loop for package in (list-all-packages)
        when (hyperdoc-lookup-function-and-base-uri package)
        nconc (loop for symbol being the external-symbols of package
                    when (do-hyperdoc-lookup symbol)
                    collect (string-downcase (symbol-name symbol)))))

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<html> 
<head>
  <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
  <title>LW-ADD-ONS - Some additions to the LispWorks IDE</title>
  <style type="text/css">
  pre { padding:5px; background-color:#e0e0e0 }
  h3, h4 { text-decoration: underline; }
  a { text-decoration: none; padding: 1px 2px 1px 2px; }
  a:visited { text-decoration: none; padding: 1px 2px 1px 2px; }
  a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; } 
  a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; }
  a.none { text-decoration: none; padding: 0; }
  a.none:visited { text-decoration: none; padding: 0; } 
  a.none:hover { text-decoration: none; border: none; padding: 0; } 
  a.none:focus { text-decoration: none; border: none; padding: 0; } 
  a.noborder { text-decoration: none; padding: 0; } 
  a.noborder:visited { text-decoration: none; padding: 0; } 
  a.noborder:hover { text-decoration: none; border: none; padding: 0; } 
  a.noborder:focus { text-decoration: none; border: none; padding: 0; }  
  pre.none { padding:5px; background-color:#ffffff }
  </style>
</head>
<body bgcolor=white>
<h2>LW-ADD-ONS - Some additions to the LispWorks IDE</h2>
<blockquote>
<br>&nbsp;<br><h3><a name=abstract class=none>Abstract</a></h3>
LW-ADD-ONS is a collection of small &quot;enhancements&quot; to
the <a href="http://www.lispworks.com/">LispWorks</a> IDE that I
usually load from my initialization file.  Most of this code is
intended to make LispWorks behave similar
to <a href="http://common-lisp.net/project/slime/">SLIME</a> and <a href="http://www.gnu.org/software/emacs/emacs.html">GNU
Emacs</a>.  The details of what's included are outlined below.  (Whether
one thinks these are enhancements or rather distractions is of course
a matter of taste.)
<p>
The code has been used and tested on LispWorks for Windows mostly (I
don't use the IDE on Linux), but I hear there are also some Mac
hackers using it successfully.  For an overview of which LispWorks
releases are supported, see
<a href="#compatibility">below</a>.
<p>
It comes with a <a
href="http://www.opensource.org/licenses/bsd-license.php">BSD-style
license</a> so you can basically do with it whatever you want.
</blockquote>
<center>
<a class=none name="apropos-pic" title="The Apropos Dialog" href="#apropos"><img alt="The Apropos Dialog" src="apropos.png" border=0 width=821 height=619></a>
</center>
<br>&nbsp;<br><h3><a class=none name="contents">Contents</a></h3>
<ol>
  <li><a href="#download">Download and installation</a>
  <li><a href="#compatibility">Compatibility with different LispWorks releases</a>
  <li><a href="#overview">Overview</a>
  <ol>
      <li><a href="#completion">Symbol completion</a>
      <li><a href="#arglist">Information about the arguments of a function</a>
      <li><a href="#apropos">Apropos dialog</a>
      <li><a href="#transient">"Transient mark mode"</a>
      <li><a href="#search">Search and replace</a>
      <li><a href="#documentation">Online documentation</a>
      <li><a href="#asdf">ASDF integration</a>
      <li><a href="#quicklisp">Quicklisp integration</a>
      <li><a href="#shortcuts">Listener shortcuts</a>
      <li><a href="#backups">Alternative editor backups</a>
      <li><a href="#misc">Miscellaneous</a>
  </ol>
  <li><a href="#dictionary">The LW-ADD-ONS dictionary</a>
  <ol>
      <li><a href="#*backup-directory*"><code>*backup-directory*</code></a>
      <li><a href="#*completion-match-function*"><code>*completion-match-function*</code></a>
      <li><a href="#*insert-right-parenthesis-if-no-args*"><code>*insert-right-parenthesis-if-no-args*</code></a>
      <li><a href="#*listener-shortcuts*"><code>*listener-shortcuts*</code></a>
      <li><a href="#*make-backup-filename-function*"><code>*make-backup-filename-function*</code></a>
      <li><a href="#*max-completions-to-show*"><code>*max-completions-to-show*</code></a>
      <li><a href="#*max-info-length*"><code>*max-info-length*</code></a>
      <li><a href="#*mop-page*"><code>*mop-page*</code></a>
      <li><a href="#*product-registry-path*"><code>*product-registry-path*</code></a>
      <li><a href="#*show-doc-string-when-showing-arglist*"><code>*show-doc-string-when-showing-arglist*</code></a>
      <li><a href="#*swank-loader-pathname*"><code>*swank-loader-pathname*</code></a>
      <li><a href="#*translate-asdf-systems*"><code>*translate-asdf-systems*</code></a>
      <li><a href="#*use-abbreviated-complete-symbol*"><code>*use-abbreviated-complete-symbol*</code></a>
      <li><a href="#*use-quicklisp-for-shortcut-l*"><code>*use-quicklisp-for-shortcut-l*</code></a>
      <li><a href="#make-backup-filename-using-backup-directory"><code>make-backup-filename-using-backup-directory</code></a>
      <li><a href="#start-swank-server"><code>start-swank-server</code></a>
  </ol>
  <li><a href="#ack">Acknowledgements</a>
</ol>
<br>&nbsp;<br><h3><a class=none name="download">Download and installation</a></h3>
LW-ADD-ONS together with this documentation can be downloaded
from <a
href="http://weitz.de/files/lw-add-ons.tar.gz">http://weitz.de/files/lw-add-ons.tar.gz</a>. The
current version is 0.10.3.  It depends on
my <a href="http://weitz.de/lw-doc/">LW-DOC</a> library.  (Note that
LW-DOC in turn depends
on <a href="http://weitz.de/cl-ppcre/">CL-PPCRE</a> and you should
have at least version 1.2.12.)
<p>
LW-ADD-ONS comes with a system definition
for <a href="http://www.cliki.net/asdf">ASDF</a>.  It is supposed to
be loaded from your init file and a sample init file
(called <code>.lispworks</code>) which amongst other things sets up
ASDF and loads LW-ADD-ONS is included.  See the
file <code>README.txt</code> for more detailed instructions.  Note
that the key bindings which can be found in the sample init file and
which are mentioned below <em>won't</em> work if you use
LispWorks' <a href="http://www.lispworks.com/documentation/lw50/EDUG-W/html/eduser-w-119.htm">Windows
editor emulation</a>.
<p>
If you want to send patches, please <a href="http://weitz.de/patches.html">read this first</a>.
<br>&nbsp;<br><h3><a class=none name="compatibility">Compatibility with different LispWorks releases</a></h3>
LW-ADD-ONS was originally (in 2005) conceived and written for
LispWorks 4.4.5/4.4.6 (and it will likely not work with older
versions).  Since then, the fine LispWorks hackers have added several
new features to their IDE which rendered some parts of LW-ADD-ONS
obsolete.  As I usually use the latest LispWorks version, you can
expect LW-ADD-ONS to be adapted to it pretty soon after its release.
This might include dropping features which are now superseded by
capabilities offered by the LispWorks IDE itself.
<p>
The newest LispWorks release which is currently supported is 7.0.
Support for older LispWorks versions might at some point disappear.
Keep your old LW-ADD-ONS tarballs if you plan on sticking with a
certain LispWorks release.
<br>&nbsp;<br><h3><a class=none name="overview">Overview</a></h3>
Here's an overview of what's currently in LW-ADD-ONS.  If you want
more details you got to look at the source code which should be
reasonably documented.
<h4><a class=none name="completion">Symbol completion</a></h4>
<p>Symbol completion is divided into two editor commands.  The "outer"
command is &quot;<code><b>Indent And Complete Symbol</b></code>&quot;
which tries to indent the current line and only performs completion if
the line hasn't changed.  I have bound this command to
the <code>TAB</code> key in my init file, so I can
use <code>TAB</code> for both indentation and completion.
  (In LispWorks 7.0 the editor command &quot;<code><b>Indent Selection or Complete Symbol</b></code>&quot;
  was introduced, so you probably no longer need my workaround.)
<p>
The "inner" command is &quot;<code><b>Complete Symbol Without
Dialog</b></code>&quot; which is intended to work more or less like
SLIME's <code>slime-complete-symbol*</code> function, i.e. you can
type, e.g., <code>m-v-b</code> and it'll be expanded
to <code>multiple-value-bind</code>.  If there's more than one
possible completion, then the command only performs completion up to
the longest unambiguous prefix and shows a list of
(<a href="#*max-completions-to-show*">some of</a>) the possible
completions in the echo area.  There's no GUI dialog popping up
because I think that's distracting.
<p>
&quot;<code><b>Indent And Complete Symbol</b></code>&quot; calls
&quot;<code><b>Complete Symbol Without Dialog</b></code>&quot; on
LispWorks 4.4.x and 5.0.x.  In 5.1, however, the new command
&quot;<code><b>Abbreviated Complete Symbol</b></code>&quot; was
introduced by LispWorks, so now you can decide which function should
be used via the special
variable <a href="#*use-abbreviated-complete-symbol*"><code>*USE-ABBREVIATED-COMPLETE-SYMBOL*</code></a>.
<p>If it can be determined that you're within a string then
&quot;<code><b>Indent And Complete Symbol</b></code>&quot; tries
pathname completion instead.  (This is not perfect, though, as it
won't work if the string contains spaces.)</p>
<p>If the symbol which is completed denotes a function without
arguments, &quot;<code><b>Complete Symbol Without
Dialog</b></code>&quot; will automatically add a closing parenthesis.
This can be customized through the
variable <a href="#*insert-right-parenthesis-if-no-args*"><code>*INSERT-RIGHT-PARENTHESIS-IF-NO-ARGS*</code></a>.</p>
<p>You can customize the behavior of &quot;<code><b>Complete Symbol Without
Dialog</b></code>&quot; by changing the value of
the
variable <a href="#*completion-match-function*"><code>*COMPLETION-MATCH-FUNCTION*</code></a>.</p>
<p>Note that for LispWorks 7.0 the default behavior had to be changed -- see <a href="http://permalink.gmane.org/gmane.lisp.lispworks.general/13414">here</a>.
<h4><a class=none name="arglist">Information about the arguments of a function</a></h4>
<p>The editor command "<code><b>Insert Space and Show
Arglist</b></code>" which I've bound to the space key inserts a space
and shows the argument list of the nearest enclosing operator in the
echo area.
If <a
href="#*show-doc-string-when-showing-arglist*"><code>*SHOW-DOC-STRING-WHEN-SHOWING-ARGLIST*</code></a>
is true the documentation string of the operator is also shown.</p>
<p>Note that this command is different from the one that's distributed
as an example together with LispWorks.</p>
<h4><a class=none name="apropos">Apropos dialog</a></h4>
<p>There is an Apropos dialog (see <a href="#apropos-pic">picture
above</a>) that can be reached via the LispWorks 'Tools' menu or the
"<code><b>Tools Apropos</b></code>" editor command (bound
to <code>C-c&nbsp;C-a</code>).  The dialog should be mostly
self-explanatory.  Note that right-clicking on the results in the
multi-column list panel (after selecting one or more items) pops up a
menu with various options similar to other IDE tools.  Double-clicking
an item tries to find the corresponding source code or, failing that,
the documentation.</p>
<p>
Note that in LispWorks 5.0
a <a href="http://www.lispworks.com/documentation/lw50/CLWUG-W/html/clwuser-w-318.htm">similar
tool</a> was introduced.
</p>
<h4><a class=none name="transient">"Transient mark mode"</a></h4>
<p>The editor tries to emulate GNU Emacs' <em>transient mark mode</em>
if you bind the command "<code><b>Set Mark And Highlight</b></code>"
to <code>C-SPC</code> and/or <code>C-@</code>.  This results in the
marked region always being highlighted.</p>
<h4><a class=none name="search">Search and replace</a></h4>
<p>The editor commands to find and replace strings are modified in
such a way that they only operate on the marked region if there is
one.  Also, the effects of a
&quot;<a href="http://www.lispworks.com/documentation/lw50/EDUG-W/html/eduser-w-69.htm#marker-885310"><code><b>Replace...</b></code></a>&quot;
command can be undone with a single
&quot;<a href="http://www.lispworks.com/documentation/lw50/EDUG-W/html/eduser-w-54.htm#marker-884739"><code><b>Undo</b></code></a>&quot;
command.  (The latter feature comes for free with LispWorks&nbsp;5.1 and higher.)</p>
<p>In LispWorks 5.0 and earlier, the editor command
&quot;<a href="http://www.lispworks.com/documentation/lw50/EDUG-W/html/eduser-w-96.htm#marker-928756"><code><b>Continue
Tags Search</b></code></a>&quot; and all commands (like, say,
&quot;<a href="http://www.lispworks.com/documentation/lw50/EDUG-W/html/eduser-w-98.htm#marker-920148"><code><b>Edit
Callers</b></code></a>&quot;) that make it applicable (see
the <a href="http://www.lispworks.com/documentation/lw50/EDUG-W/html/eduser-w.htm">LispWorks
Editor User Guide</a>) push the current position of point onto
a <em>definitions stack</em> before they move to a new position.  You
can walk back through this &quot;history&quot; using the new editor
command &quot;<code><b>Pop Definitions Stack</b></code>&quot;.
<p>
Note that in LispWorks 5.1 a new command "<code><b>Go Back</b></code>"
was introduced, so the code related to the definitions stack is
disabled for 5.1 and higher.
</p>
<h4><a class=none name="documentation">Online documentation</a></h4>
<p>The editor command "<code><b>Meta Documentation</b></code>" (bound
to <code>F5</code> in the sample init file) tries to find HTML
documentation for the symbol at point and immediately shows it using
the default web browser.  This applies to the <a href="http://www.lispworks.com/documentation/HyperSpec/Front/index.htm">HyperSpec</a>, the <a href="http://www.lispworks.com/documentation/">LispWorks
reference manuals</a>, the <a href="http://www.lisp.org/mop/index.html">MOP</a>
(see <a href="#*mop-page*"><code>*MOP-PAGE*</code></a>), and some
other useful stuff,  e.g. format strings like <a href="http://www.lispworks.com/documentation/HyperSpec/Body/22_cga.htm"><code>~*</code></a>, reader macros
like <a href="http://www.lispworks.com/documentation/HyperSpec/Body/02_dhi.htm"><code>#x</code></a>, and loop clauses like <a href="http://www.lispworks.com/documentation/HyperSpec/Body/06_ad.htm"><code>loop:until</code></a>.
Finally, HTML documentation for libraries like <a href="http://weitz.de/cl-ppcre/">CL-PPCRE</a> or LW-ADD-ONS itself that have <a href="http://common-lisp.net/project/hyperdoc/">Hyperdoc</a> support will also be found.</p>
<p>
If the command is invoked with a prefix argument you are prompted for
a symbol and completion is available.</p>
<p>Note that this command is similar although not identical to the
undocumented LispWorks command "<code><b>Function
Documentation</b></code>".</p>
<h4><a class=none name="asdf">ASDF integration</a></h4>
<center>
<a class=none title="The LispWorks System Browser showing an ASDF system" href="#asdf"><img alt="The LispWorks System Browser showing an ASDF system" src="system_browser.png" border=0 width=682 height=851></a>
</center>
<p>If <a
href="#*translate-asdf-systems*"><code>*TRANSLATE-ASDF-SYSTEMS*</code></a>
is set to a true value
then <a href="http://www.cliki.net/asdf">ASDF</a> system definitions
are automatically converted
to <a
href="http://www.lispworks.com/documentation/lw50/LWUG/html/lwuser-195.htm">Common
Defsystem</a> definitions whenever you load or compile an ASDF system.</p>
<p>Note that ASDF is a lot more flexible than Common Defsystem and
there's no hope to convert every conceivable ASDF system to an
equivalent Common Defsystem system.  The conversion is mainly intended
to enable you to browse ASDF systems from the LispWorks IDE and use
editor commands like &quot;<a href="http://www.lispworks.com/documentation/lw50/EDUG-W/html/eduser-w-66.htm#marker-885260"><code><b>System Search</b></code></a>&quot; and
&quot;<a href="http://www.lispworks.com/documentation/lw50/EDUG-W/html/eduser-w-69.htm#marker-885341"><code><b>System Query Replace</b></code></a>&quot;.  It seems to work in
practice for a lot of open source ASDF systems that can be used with
LispWorks.</p>
<p>Note that this has been rendered mostly obsolete due to <a href="http://www.lispworks.com/documentation/lw60/RNIG/html/readme-372.htm">a new feature in LispWorks&nbsp;6.1</a> and
  has been disabled for LispWorks&nbsp;7.
<h4><a class=none name="quicklisp">Quicklisp integration</a></h4>
<p>LW-ADD-ONS contains <a href="http://www.quicklisp.org/">Quicklisp</a> support.
<p>Download <a href="http://beta.quicklisp.org/quicklisp.lisp">
http://beta.quicklisp.org/quicklisp.lisp</a> and load
it. Installation is self-explanatory, simply follow the
  instructions.  Do <em>not</em> let Quicklisp write anything into init files.
<p>The command <code><b>Quickload Library</b></code> executes
  <code>(ql:quickload lib)</code> which loads publicly available libraries via http or
  if already loaded from <code>$home/quicklisp/dists/quicklisp/software</code>.
  <p>The command <code><b>Quicklisp Update Client</b></code> updates the quicklisp
client if a newer version is available online.
    <p>The command <code><b>Quicklisp Update All Dists</b></code> updates the
libraries managed by quicklisp.
<h4><a class=none name="shortcuts">Listener shortcuts</a></h4>
<p>Similar to SLIME's <code>slime-handle-repl-shortcut</code> you can
press <code>,</code> (comma, for "<code><b>Maybe Invoke Listener Shortcut</b></code>") in the listener and then choose from a
couple of shortcuts
(see <a
href="#*listener-shortcuts*"><code>*LISTENER-SHORTCUTS*</code></a>) to
perform administrative tasks like loading a system via ASDF or
changing the current directory.</p>
<p>Type <code>F1</code> when prompted for a shortcut to see a list of
what's available. Currently there are shortcuts for 
<ul>
<li>"<code><b>Load ASDF System</b></code>" (<code>l</code>), 
<li>"<code><b>Test ASDF System</b></code>" (<code>t</code>), 
<li>"<code><b>Compile ASDF System</b></code>" (<code>c</code>), 
<li>"<code><b>Change Package</b></code>" (<code>p</code>), 
<li>"<code><b>Change Directory</b></code>" (<code>cd</code>), 
<li>"<code><b>Show Directory</b></code>" (<code>pwd</code>), and
<li>"<code><b>Quit</b></code>" (<code>q</code> or <code>s</code>)
</ul> - see
the documentation strings of these commands for details.</p>
<p>If Quicklisp is used, the first is changed to
<ul>
<li>"<code><b>Quickload Library</b></code>" (<code>l</code>),
</ul>
<p> and loading with ASDF is changed to:
<ul>
<li>"<code><b>Load ASDF System</b></code>" (<code>a</code>), 
</ul>
<p>If you don't like this change and want the old behavior while
using Quicklisp simply switch <a href="#*use-quicklisp-for-shortcut-l*"><code>*USE-QUICKLISP-FOR-SHORTCUT-L*</code></a>
to <code>NIL</code>.
<h4><a class=none name="backups">Alternative editor backups</a></h4>
LW-ADD-ONS can alter the way the IDE editor creates pathnames for
backups.  This might come in handy if you don't want your code
directories to be cluttered with files like <code>foo.lisp~</code>.
Read about
<a href="#*make-backup-filename-function*"><code>*MAKE-BACKUP-FILENAME-FUNCTION*</code></a>,
<a href="#make-backup-filename-using-backup-directory"><code>MAKE-BACKUP-FILENAME-USING-BACKUP-DIRECTORY</code></a>,
and <a href="#*backup-directory*"><code>*BACKUP-DIRECTORY*</code></a>
and set these to values suiting your needs.
<h4><a class=none name="misc">Miscellaneous</a></h4>
<p>The command &quot;<a href="http://www.lispworks.com/documentation/lw50/EDUG-W/html/eduser-w-63.htm#marker-885088"><code><b>Next Ordinary Window</b></code></a>&quot; (usually bound
to <code>C-x&nbsp;o</code>) is modified to also allow switching from
an editor window to a listener window.</p>
<p>The command "<code><b>Find Alternate File</b></code>" (usually
bound to <code>C-x&nbsp;C-v</code>) is modified such that it checks
whether the contents of the buffer are consistent with the file on
disk.  Also, it'll provide the full pathname of the current
buffer as the default when prompting.</p>
<p>The command "<a href="#completion"><code><b>Indent And Complete
Symbol</b></code></a>" includes a workaround to make sure that the
start of a top-level form will always be indented to the beginning of
a line.  LispWorks usually doesn't do that.</p>
<p>The commands "<code><b>Evaluate Last Form And Inspect</b></code>" (<code>C-c&nbsp;i</code>) and "<code><b>Evaluate Last Form And Describe</b></code>" (<code>C-c&nbsp;d</code>) are like 
"<code><b>Evaluate Last Form</b></code>" but open the result in an IDE inspector or describe it in a help window respectively.</p>
<p>The command "<code><b>Untrace All</b></code>"
executes <code>(untrace)</code>, the command "<code><b>Toggle
Trace</b></code>" (<code>C-c&nbsp;C-t</code>) traces or untraces a function depending on its
current state.</p>
<p>The included initialization file makes sure you start with an
editor and (if you use the MDI interface) tiles the windows
vertically.</p>
<p>A DDE
Server <a
href="http://www.lispworks.com/kb/55af67dc408cab568025687f004b1442.html">as
described in the LispWorks Knowledgebase</a> is set up so you can open
Lisp source files by double-clicking them.  You have to configure
Windows Explorer to use this facility, of course.</p>
<p>The function keys <code>F11</code> and <code>F12</code> are bound
to commands that switch to an editor or a listener respectively (and
create these tools if necessary).</p>
<br>&nbsp;<br><h3><a class=none name="dictionary">The LW-ADD-ONS dictionary</a></h3>
LW-ADD-ONS exports the following symbols:
<p><br>[Special variable]<br><a class=none name='*backup-directory*'><b>*backup-directory*</b></a>
<blockquote><br>
The directory where backups are stored if the value of
<a href="#*make-backup-filename-function*"><code>*MAKE-BACKUP-FILENAME-FUNCTION*</code></a>
designates the
function <a href="#make-backup-filename-using-backup-directory"><code>MAKE-BACKUP-FILENAME-USING-BACKUP-DIRECTORY</code></a>.
It is recommended that you <b>don't</b> use this directory for other
purposes.
</blockquote>
<p><br>[Special variable]
<br><a class=none name="*completion-match-function*"><b>*completion-match-function*</b></a>
<blockquote><br>
The function used by "<a href="#completion"><code><b>Complete Symbol Without Dialog</b></code></a>" to
check possible completions.  Should be a designator for a
function of two arguments and return true <em>iff</em> the second argument
is a possible completion of the first one.
</blockquote>
<p><br>[Special variable]
<br><a class=none name="*insert-right-parenthesis-if-no-args*"><b>*insert-right-parenthesis-if-no-args*</b></a>
<blockquote><br>
Whether "<a href="#completion"><code><b>Complete Symbol Without Dialog</b></code></a>" should insert a
right parenthesis if the function is known to have an empty
argument list.
</blockquote>
<p><br>[Special variable]
<br><a class=none name="*listener-shortcuts*"><b>*listener-shortcuts*</b></a>
<blockquote><br> An <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_a.htm#alist">alist</a> of commands that can be invoked with
"<a href="#shortcuts"><code><b>Invoke Listener Shortcut</b></code></a>", each one preceded by a shortcut.
</blockquote>
<p><br>[Special variable]<br><a class=none name='*make-backup-filename-function*'><b>*make-backup-filename-function*</b></a>
<blockquote><br>
If the value of this variable is not <code>NIL</code> (which is the
default), then it should be a designator for a function of one
argument which accepts a pathname and returns a pathname.  LispWork's
own
<code>EDITOR::MAKE-BACKUP-FILENAME</code> function will be replaced
with this one in this case.
</blockquote>
<p><br>[Special variable]
<br><a class=none name="*max-completions-to-show*"><b>*max-completions-to-show*</b></a>
<blockquote><br>
The maximum number of possible completions shown in the echo
area by "<a href="#completion"><code><b>Complete Symbol Without Dialog</b></code></a>".
</blockquote>
<p><br>[Special variable]
<br><a class=none name="*max-info-length*"><b>*max-info-length*</b></a>
<blockquote><br>
The maximum length (in characters) of a message shown by the function
<code>SHOW-INFO</code> (see source code) - unless <code>FULL-LENGTH-P</code> is true.
</blockquote>
<p><br>[Special variable]
<br><a class=none name="*mop-page*"><b>*mop-page*</b></a>
<blockquote><br>
A pathname specifier denoting the location of the dictionary
page from the AMOP HTML version.  The page is available online at
<a href="http://www.alu.org/mop/dictionary.html">http://www.alu.org/mop/dictionary.html</a>.  Used by the "<a href="#documentation"><code><b>Meta Documentation</b></code></a>" command.
</blockquote>
<p><br>[Special variable]
<br><a class=none name="*product-registry-path*"><b>*product-registry-path*</b></a>
<blockquote><br>
Where LW-ADD-ONS stores persistent information - see <a href="http://www.lispworks.com/documentation/lw50/LWRM/html/lwref-706.htm"><code>PRODUCT-REGISTRY-PATH</code></a>.
</blockquote>
<p><br>[Special variable]
<br><a class=none name="*show-doc-string-when-showing-arglist*"><b>*show-doc-string-when-showing-arglist*</b></a>
<blockquote><br>
Whether the editor command "<a href="#arglist"><code><b>Insert Space And Show Arglist</b></code></a>"
is supposed to show the documentation string as well.
</blockquote>
<p><br>[Special variable]
<br><a class=none name="*swank-loader-pathname*"><b>*swank-loader-pathname*</b></a>
<blockquote><br>
A pathname specifier denoting the location of the
<code>swank-loader.lisp</code> file.  Only needed if one wants to start the
<em>Swank</em> server from LispWorks - see function <a href="#start-swank-server"><code>START-SWANK-SERVER</code></a>.
</blockquote>
<p><br>[Special variable]
<br><a class=none name="*translate-asdf-systems*"><b>*translate-asdf-systems*</b></a>
<blockquote><br>
Whether ASDF systems should be <a href="#asdf">automatically converted</a> to LispWorks
Common Defsystem systems.
</blockquote>
<p><br>[Special variable]
<br><a class=none name="*use-abbreviated-complete-symbol*"><b>*use-abbreviated-complete-symbol*</b></a>
<blockquote><br> Whether &quot;<a href="#completion"><code><b>Indent
And Complete Symbol</b></code></a>&quot; should call
&quot;<code><b>Abbreviated Complete Symbol</b></code>&quot; (only
available in LispWorks 5.1 or higher) instead of
"<a href="#completion"><code><b>Complete Symbol Without
Dialog</b></code></a>".
</blockquote>
<p><br>[Special variable]
<br><a class=none name="*use-quicklisp-for-shortcut-l*"><b>*use-quicklisp-for-shortcut-l*</b></a>
<blockquote><br> Whether the <a href="#shortcuts">listener shortcut</a> <code>l</code>
  should be interpreted as loading a library via <a href="#quicklisp">Quicklisp</a>.
This is the default behavior if Quicklisp is present.  If you want the old, pre-Quicklisp
  behavior for this shortcut, set the value to <code>NIL</code>.
</blockquote>
<p><br>[Function]<br><a class=none name='make-backup-filename-using-backup-directory'><b>make-backup-filename-using-backup-directory</b> <i>pathname</i> =&gt; <i>pathname'</i></a>
<blockquote><br>
Creates and returns a backup pathname for <code><i>pathname</i></code>
(doing a simplified version of what GNU Emacs does if you
use <code>backup-directory-alist</code> there).  Assumes that
<a href="#*backup-directory*"><code>*BACKUP-DIRECTORY*</code></a>
denotes a directory.  Note that due to the way the backup pathname is
constructed it is possible that two different files end up with the
same backup filename!  If in doubt, look at the source code of this
function before you use it.
</blockquote>
<p><br>[Function]
<br><a class=none name="start-swank-server"><b>start-swank-server</b> =&gt; <i>port</i></a>
<blockquote><br>
Starts <em>Swank</em> so you can control LispWorks from Emacs via
<a href="http://common-lisp.net/project/slime">SLIME</a>.
</blockquote>
<br>&nbsp;<br><h3><a class=none name="ack">Acknowledgements</a></h3>
The inhabitants of the LispWorks mailing list are an invaluable source of information when one writes LispWorks-specific code.  Specifically, Jeff Caldwell, Bill Clementson, John DeSoi, Dmitriy Ivanov, Arthur Lemmens, Nick Levine, Sean Ross, Jens Teich, Barry Wilkes, and (from LispWorks Ltd.) Dave Fox and Martin Simmons have been very helpful in various ways.  Thanks also go to the cool <a href="http://common-lisp.net/project/slime">SLIME</a> project which provided inspiration and code to steal.
<p>
$Header: /usr/local/cvsrep/lw-add-ons/doc/index.html,v 1.89 2015/08/09 15:18:51 edi Exp $
<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
</body>
</html>

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-ADD-ONS; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/completions.lisp,v 1.14 2015/03/06 12:54:25 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;; This code copied almost verbatim from SLIME, see
;;; <http://common-lisp.net/project/slime/>
(in-package :lw-add-ons)
(defun compound-prefix-match (prefix target)
  "Return true if PREFIX is a compound-prefix of TARGET.
Viewing each of PREFIX and TARGET as a series of substrings delimited
by hyphens, if each substring of PREFIX is a prefix of the
corresponding substring in TARGET then we call PREFIX a
compound-prefix of TARGET.
Examples:
\(compound-prefix-match \"foo\" \"foobar\") => t
\(compound-prefix-match \"m--b\" \"multiple-value-bind\") => t
\(compound-prefix-match \"m-v-c\" \"multiple-value-bind\") => NIL"
  (declare (type simple-string prefix target))
  (loop for ch across prefix
        with tpos = 0
        always (and (< tpos (length target))
                    (if (char= ch #\-)
                        (setf tpos (position #\- target :start tpos))
                        (char= ch (aref target tpos))))
        do (incf tpos)))
;; FIXME: deal with #\| etc.  hard to do portably.
(defun tokenize-symbol (string)
  (let ((package (let ((pos (position #\: string)))
                   (if pos (subseq string 0 pos) nil)))
        (symbol (let ((pos (position #\: string :from-end t)))
                  (if pos (subseq string (1+ pos)) string)))
        (internp (search "::" string)))
    (values symbol package internp)))
(defun parse-package (string)
  "Find the package named STRING.
Return the package or nil."
  (multiple-value-bind (name pos) 
      (if (zerop (length string))
          (values :|| 0)
          (let ((*package* +keyword-package+))
            (ignore-errors* (read-from-string string))))
    (if (and (or (keywordp name) (stringp name))
             (= (length string) pos))
        (find-package name))))
(defun guess-package-from-string (name &optional (default-package *package*))
  (or (and name
           (or (parse-package name)
               (find-package (string-upcase name))
               (parse-package (substitute #\- #\! name))))
      default-package))
(defun carefully-find-package (name default-package-name)
  "Find the package with name NAME, or DEFAULT-PACKAGE-NAME, or
the CL-USER package.  NAME and DEFAULT-PACKAGE-NAME can be nil."
  (let ((string (cond ((equal name "") "KEYWORD")
                      (t (or name default-package-name)))))
    (if string
        (guess-package-from-string string nil)
        +cl-user-package+)))
(defun parse-completion-arguments (string default-package-name)
  "Parse STRING as a symbol designator.
Return these values:
 SYMBOL-NAME
 PACKAGE-NAME, or nil if the designator does not include an explicit package.
 PACKAGE, the package to complete in
 INTERNAL-P, if the symbol is qualified with `::'."
  (multiple-value-bind (name package-name internal-p)
      (tokenize-symbol string)
    (let ((package (carefully-find-package package-name default-package-name)))
      (values name package-name package internal-p))))
(defun determine-case (string)
  "Return two booleans LOWER and UPPER indicating whether STRING
contains lower or upper case characters."
  (values (some #'lower-case-p string)
          (some #'upper-case-p string)))
(defun output-case-converter (input)
  "Return a function to case convert strings for output.
INPUT is used to guess the preferred case."
  (ecase (readtable-case *readtable*)
    (:upcase (if (some #'lower-case-p input) #'string-downcase #'identity))
    (:invert (lambda (output)
               (multiple-value-bind (lower upper) (determine-case output)
                 (cond ((and lower upper) output)
                       (lower (string-upcase output))
                       (upper (string-downcase output))
                       (t output)))))
    (:downcase (if (some #'upper-case-p input) #'string-upcase #'identity))
    (:preserve #'identity)))
(defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
  "True if SYMBOL is external in PACKAGE.
If PACKAGE is not specified, the home package of SYMBOL is used."
  (unless package
    (setq package (symbol-package symbol)))
  (when package
    (multiple-value-bind (_ status)
        (find-symbol (symbol-name symbol) package)
      (declare (ignore _))
      (eq status :external))))
(defun find-matching-symbols (string package external test)
  "Return a list of symbols in PACKAGE matching STRING.
TEST is called with two strings.  If EXTERNAL is true, only external
symbols are returned."
  (let ((completions '())
        (converter (output-case-converter string)))
    (flet ((symbol-matches-p (symbol)
             (and (or (not external)
                      (symbol-external-p symbol package))
                  (funcall test string
                           (funcall converter (symbol-name symbol))))))
      (do-symbols (symbol package) 
        (when (symbol-matches-p symbol)
          (push symbol completions))))
    (delete-duplicates completions)))
(defun find-matching-packages (name matcher)
  "Return a list of package names matching NAME using the fuzzy
completion algorithm."
  (let ((to-match (string-upcase name)))
    (remove-if-not (lambda (x) (funcall matcher to-match x))
                   (mapcar (lambda (pkgname)
                             (concatenate 'string pkgname ":"))
                           (loop for package in (list-all-packages)
                                 collect (package-name package)
                                 append (package-nicknames package))))))
(defun format-completion-result (string internal-p package-name)
  (let ((prefix (cond (internal-p (format nil "~A::" package-name))
                      (package-name (format nil "~A:" package-name))
                      (t ""))))
    (values (concatenate 'string prefix string)
            (length prefix))))
(defun format-completion-set (strings internal-p package-name)
  "Format a set of completion strings.
Returns a list of completions with package qualifiers if needed."
 (mapcar (lambda (string)
            (format-completion-result string internal-p package-name))
          (sort strings #'string<)))
(defun completion-set (string default-package-name matchp)
  "Return the set of completion-candidates as strings."
  (multiple-value-bind (name package-name package internal-p)
      (parse-completion-arguments string default-package-name)
    (let* ((symbols (and package
                         (find-matching-symbols name
                                                package
                                                (and (not internal-p)
                                                     package-name)
                                                matchp)))
           (packs (and (not package-name)
                       (find-matching-packages name matchp)))
           (converter (output-case-converter name))
           (strings
            (mapcar converter
                    (nconc (mapcar #'symbol-name symbols) packs))))
      (format-completion-set strings internal-p package-name))))
(defun longest-common-prefix (strings)
  "Return the longest string that is a common prefix of STRINGS."
  (if (null strings)
      ""
      (flet ((common-prefix (s1 s2)
               (let ((diff-pos (mismatch s1 s2)))
                 (if diff-pos (subseq s1 0 diff-pos) s1))))
        (reduce #'common-prefix strings))))
(defun transpose-lists (lists)
  "Turn a list-of-lists on its side.
If the rows are of unequal length, truncate uniformly to the shortest.
For example:
\(transpose-lists '((ONE TWO THREE) (1 2)))
  => ((ONE 1) (TWO 2))"
  (cond ((null lists) '())
        ((some #'null lists) '())
        (t (cons (mapcar #'car lists)
                 (transpose-lists (mapcar #'cdr lists))))))
(defun untokenize-completion (tokens)
  (format nil "~{~A~^-~}" tokens))
(defun tokenize-completion (string)
  "Return all substrings of STRING delimited by #\-."
  (loop with end
        for start = 0 then (1+ end)
        until (> start (length string))
        do (setq end (or (position #\- string :start start) (length string)))
        collect (subseq string start end)))
(defun longest-completion (completions)
  "Return the longest prefix for all COMPLETIONS.
COMPLETIONS is a list of strings."
  (untokenize-completion
   (mapcar #'longest-common-prefix
           (transpose-lists (mapcar #'tokenize-completion completions)))))
(defun completions (string default-package-name)
  "Return a list of completions for a symbol designator STRING.  
The result is the list \(COMPLETION-SET
COMPLETED-PREFIX). COMPLETION-SET is the list of all matching
completions, and COMPLETED-PREFIX is the best (partial)
completion of the input string.
If STRING is package qualified the result list will also be
qualified.  If string is non-qualified the result strings are
also not qualified and are considered relative to
DEFAULT-PACKAGE-NAME.
The way symbols are matched depends on the symbol designator's
format. The cases are as follows:
  FOO      - Symbols with matching prefix and accessible in the buffer package.
  PKG:FOO  - Symbols with matching prefix and external in package PKG.
  PKG::FOO - Symbols with matching prefix and accessible in package PKG."
  (let ((completion-set (completion-set string default-package-name 
                                        *completion-match-function*)))
    (values completion-set (longest-completion completion-set))))

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-ADD-ONS; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/commands.lisp,v 1.31 2015/03/06 12:54:25 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved. 
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :lw-add-ons)
(defcommand "Insert Space And Show Arglist" (p)
     "Displays arglist of nearest enclosing operator in the echo
area after inserting a space."
     "Displays arglist."
  (self-insert-command p #\Space)
  (show-arglist))
(defcommand "Set Mark And Highlight" (p)
      "Sets the mark and turns on highlighting.  To be used as a
replacement for the normal \"Set Mark\" command if you want
something similar to `transient mark mode.'"
      "Sets the mark and turns on highlighting."
  ;; from Barry Wilkes
  (set-mark-command p)
  (hl-on-command p))
(defcommand "Complete Symbol Without Dialog" (p)
     "Completes the symbol before or around point.  Doesn't pop
up a CAPI dialog window."
     "Completes the symbol before or around point."
  (declare (ignore p))
  (multiple-value-bind (string package)
      (symbol-string-at-point :previous t)
    (multiple-value-bind (completion-set completed-prefix)
        (completions string (package-name package))
      (when (null completion-set)
        (editor-error "No completions for ~S" string))
      (let ((quoted-string (editor::regexp-quote string)))
        (loop until (looking-at quoted-string)
              do (backward-character-command  1)))
      (with-point ((start (current-point))
                   (end (current-point)))
        (increment-point end (length string))
        (let (single-completion-p)
          (recording-for-undo% start end
            (delete-next-character-command (length string))
            (loop for char across completed-prefix
                  do (self-insert-command 1 char))
            (cond ((and (member completed-prefix completion-set :test #'string=)
                        (null (cdr completion-set)))
                   (setq single-completion-p t)
                   (when *insert-right-parenthesis-if-no-args*
                     (maybe-insert-right-parenthesis)))
                  (t
                   (let ((unambiguous-completion-length
                          (loop for c in completion-set
                                minimizing (or (mismatch completed-prefix c)
                                               (length completed-prefix)))))
                     (backward-character-command (- (length completed-prefix)
                                                    unambiguous-completion-length))))))
          ;; this part has to happen without the lock acquired for
          ;; RECORDING-FOR-UNDO% above
          (cond (single-completion-p
                 (editor::clear-echo-area-if-not-current "Sole completion")
                 (sleep .7)
                 (show-arglist))
                (t (show-info
                    (completions-for-echo-area completion-set)))))))))
(defun in-string-p ()
  "Helper function which checks whether we're within a string.  Simply
goes back in steps of one char until it finds a double quote.  Doesn't
check for escaped characters."
  (save-excursion
    (backward-form-command nil)
    (eql #\" (char-before))))
(defcommand "Indent And Complete Symbol" (p)
     "Indents the current line and performs symbol completion.
First indents the line.  If indenting doesn't change the line
point is in, completes the symbol.  If there's no symbol at the
point, shows the arglist for the most recently enclosed macro or
function."
     "Indents the current line and performs symbol completion."
  (let ((line-before (current-line)))
    ;; make sure top-level forms are indented flush left
    (with-point ((line-start (current-point))
                 (line-end (current-point)))
      (line-start line-start)
      (line-end line-end)
      (recording-for-undo% line-start line-end
        (editor::delete-horizontal-space line-start)
        (indent-command p)))
    (when (and (string= line-before (current-line))
               (or (not (string= (editor::buffer-major-mode-name (current-buffer))
                                 "LISP"))
                   (can-move-upwards-p)))
      (let ((char-before (char-before))) 
        (cond ((in-string-p) (expand-file-name-command p))
              ((not (find char-before
                          '(#\( #\) #\Space #\Tab #\Linefeed #\Return #\")))
               (cond #-:editor-does-not-have-abbreviated-complete-symbol
                     (*use-abbreviated-complete-symbol*
                      ;; we need to go to the end of the symbol
                      (let* ((string (symbol-string-at-point :previous t))
                             (quoted-string (editor::regexp-quote string)))
                        (loop until (looking-at quoted-string)
                              do (backward-character-command  1))
                        (increment-point (current-point) (length string)))
                      (editor::abbreviated-complete-symbol-command p))
                     (t (complete-symbol-without-dialog-command p))))
              ((find char-before '(#\Space #\Tab))
               (show-arglist)))))))
(defcommand "Meta Documentation" (p)
     "Finds and displays documentation for the given symbol if it is
supported by Hyperdoc or can be found in one of the online manuals
\(CLHS, LW, MOP).  If point is on a symbol which is known to have
documentation the page is immediately shown.  Otherwise, or with a
prefix argument, the user is queried for the symbol."
     "Shows CLHS/LW/MOP online documentation in browser."
  (let* ((symbol (and (not p)
                      (symbol-at-point :previous t)))
         (string (and symbol
                      (format nil "~:[~;:~]~A"
                              (keywordp symbol)
                              (symbol-name symbol))))
         (uri (and string (doc-entry string))))
    (unless uri
      (let ((*doc-entries* (append (collect-hyperdoc-entries)
                                   *doc-hash-entries*)))
        (setq string (editor::parse-for-something
                      :prompt "Documentation entry for: "
                      :must-exist t
                      :help "Type the symbol you want to see documentation about."
                      :default (or string "")
                      :default-string (or string "")
                      :verify-func (lambda (string parse-inf)
                                     (declare (ignore parse-inf))
                                     (and (doc-entry string)
                                          string))
                      :type :string
                      :default-in-prompt nil
                      :complete-func 'complete-doc-entry)
              uri (doc-entry string))))
    (when (and uri (plusp (length uri)))
      (browse-anchored-uri uri))))
                             
#+:editor-does-not-have-go-back
(defcommand "Pop Definitions Stack" (p)
      "Pops one point from *FIND-DEFINITIONS-STACK* and goes to that
location if the stack wasn't empty.*"
      "Pops one point from definitions stack and goes there."
   (declare (ignore p))
   (let ((point (loop for point = (pop *find-definitions-stack*)
                      while point
                      when (buffer-name (point-buffer point))
                      do (return point))))
     (unless point
       (message "No more point to go.")
       (return-from pop-definitions-stack-command))
     (goto-buffer-point (point-buffer point)
                        point
                        :in-same-window t
                        :warp t)
     (delete-point point)
     (pop-mark-command nil)))
(defcommand "Load ASDF System" (p)
     "Loads an ASDF system \(and compiles it if necessary)."
     "Loads an ASDF system."
  (declare (ignore p))
  (when-let (name (prompt-for-asdf-system-with-default "Load ASDF System: "))
    (editor::funcall-background-job-with-typeout
     (editor::choose-lispeval-pane (current-buffer) (current-window))
     'asdf:oos 'asdf:load-op name)))
(defcommand "Compile ASDF System" (p)
     "Compiles an ASDF system \(and compiles it if necessary)."
     "Compiles an ASDF system."
  (declare (ignore p))
  (when-let (name (prompt-for-asdf-system-with-default "Compile ASDF System: "))
    (editor::funcall-background-job-with-typeout
     (editor::choose-lispeval-pane (current-buffer) (current-window))
     'asdf:oos 'asdf:compile-op name)))
(defcommand "Test ASDF System" (p)
  "Tests an ASDF system \(and compiles it if necessary)."
  "Tests an ASDF system."
  (declare (ignore p))
  (when-let (name (prompt-for-asdf-system-with-default "Test ASDF System: "))
    (editor::funcall-background-job-with-typeout
     (editor::choose-lispeval-pane (current-buffer) (current-window))
     'asdf:operate 'asdf:test-op name :force t)))
(defcommand "Invoke Listener Shortcut" (p)
     "Prompts for a listener shortcut and invokes the corresponding command."
     "Prompts for a listener shortcut and invokes it."
  (let* ((command-name (prompt-for-listener-shortcut))
         (command (and command-name
                       (editor::getstring command-name editor::*command-names*))))
    (when command
      (editor::funcall-command command p))))
(defcommand "Maybe Invoke Listener Shortcut" (p)
     "Like \"Invoke Listener Shortcut\" but works only if point is in
a listener window immediately after the last prompt with no input
after it.  Otherwise insert a comma."
     "Restricted version of \"Invoke Listener Shortcut\"."
  (cond ((eq (buffer-flag (current-buffer)) :listener)
         (let* ((stream (editor:variable-value 'editor::rubber-stream))
                (start (editor::editor-region-stream-start stream))
                (end (editor::editor-region-stream-end stream)))
           (cond ((and (point= start (current-point))
                       (point= start end))
                  (invoke-listener-shortcut-command p))
                 (t (self-insert-command p #\,)))))
        (t (self-insert-command p #\,))))
(defcommand "Change Package" (p)
     "Prompts for a package and invokes IN-PACKAGE in listener.  Works
only if in listener."
     "Prompts for a package and invokes IN-PACKAGE in listener."
  (declare (ignore p))
  (when (eq (buffer-flag (current-buffer)) :listener)
    (let ((package (prompt-for-package* :prompt "Package: "
                                        :must-exist t)))
      (when package
        (editor::execute-listener-command 'in-package (package-name package))))))
(defcommand "Change Directory" (p)
     "Changes the default directory and *DEFAULT-PATHNAME-DEFAULTS*."
     "Changes default directory."
  (declare (ignore p))
  (let ((directory (prompt-for-directory)))
    (when directory
      (setq *default-pathname-defaults*
            (change-directory directory)))))
(defcommand "Show Directory" (p)
     "Shows the default directory in the echo area."
     "Shows default directory."
  (declare (ignore p))
  (show-info (namestring (get-working-directory))))
(defcommand "Quit" (p)
     "Quits image without asking for confirmation."
     "Quits image immediately."
  (declare (ignore p))
  (quit))
(defcommand "Tools Listener" (p)
     "Like menu Works > Tools > Listener."
     "Like menu Works > Tools > Listener."
  ;; from Dmitri Ivanov
  (declare (ignore p))
  (capi:find-interface 'lw-tools:listener))
(defcommand "Tools Editor" (p)
     "Like menu Works > Tools > Editor."
     "Like menu Works > Tools > Editor."
  ;; from Dmitri Ivanov
  (declare (ignore p))
  (capi:find-interface 'lw-tools:editor))
(defcommand "Tools Apropos" (p)
     "Shows Apropos Dialog."
     "Shows Apropos Dialog."
  (declare (ignore p))
  (capi:find-interface 'apropos-dialog))
(defcommand "Untrace All" (p)
     "Untraces all traced definitions."
     "Untraces all traced definitions."
  (declare (ignore p))
  (untrace))
(defcommand "Toggle Trace" (p &optional name)
     "Toggles Trace."
     "Traces or Untraces the given function."
  (let ((name (or name
                  (and (not p)
                       (symbol-at-point :previous t))
                  (prompt-for-symbol p :prompt "Symbol to Trace: "))))
    (flet ((traced ()
             (member name (eval '(trace)))))
      (cond ((traced)
             (eval `(untrace ,name)))
            (t
             (eval `(trace ,name))))
      (show-info (format nil "~A is now ~@[un~]traced."
                         name (not (traced)))))))
(defcommand "Evaluate Last Form And Inspect" (p &optional (point (current-point)))
     "Evaluates Lisp form before the current point.  The result
is inspected in an IDE Inspector."
     "Evaluates Lisp form before point and inspects result."
  (declare (ignore p))
  (with-point ((start point)
               (end point))
    (unless (editor:form-offset start -1 t 0)
      (editor-error "Cannot find start of the form to evaluate"))
    (let ((buffer (editor:point-buffer start)))
      (let ((value (returning-lisp-eval buffer start end
                                        (editor::current-echo-area-window))))
        (gui-inspect (case (length value)
                       (1 (car value))
                       (t value)))))))
(defcommand "Evaluate Last Form And Describe" (p &optional (point (current-point)))
     "Evaluates Lisp form before the current point.  The result is
described in a help window."
     "Evaluates Lisp form before point and describes result."
  (declare (ignore p))
  (with-point ((start point)
               (end point))
    (unless (editor:form-offset start -1 t 0)
      (editor-error "Cannot find start of the form to evaluate"))
    (let ((buffer (editor:point-buffer start)))
      (let ((values (returning-lisp-eval buffer start end
                                         (editor::current-echo-area-window))))
        (with-compilation-environment-at-point ((current-point))
          (with-output-to-help-window (*standard-output*)
            (dolist (val values)
              (describe val)
              (terpri))))))))
#+:quicklisp
(defcommand "Quickload Library" (p)
     "Load a library with Quicklisp (see http://www.quicklisp.org)."
     "Load Library with Quicklisp."
  (declare (ignore p))
  (when-let (name (prompt-for-asdf-system-with-default
                   "Library to open with Quicklisp: "
                   "Type a name of an ASDF system or a Quicklisp-loadable library."
                   t))
    (editor::funcall-background-job-with-typeout
     (editor::choose-lispeval-pane (current-buffer) (current-window))
     'ql:quickload name)))
#+:quicklisp
(defcommand "Quicklisp Update Client" (p)
     "Update Quicklisp Client"
     "Update Quicklisp Client"
  (editor::funcall-background-job-with-typeout
     (editor::choose-lispeval-pane (current-buffer) (current-window))
     'ql:update-client))
#+:quicklisp
(defcommand "Quicklisp Update All Dists" (p)
      "Update all Quicklisp dists"
      "Update all Quicklisp dists"
  (editor::funcall-background-job-with-typeout
     (editor::choose-lispeval-pane (current-buffer) (current-window))
     'ql:update-all-dists))

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-ADD-ONS; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/apropos.lisp,v 1.32 2015/03/06 12:54:25 edi Exp $
;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved. 
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :lw-add-ons)
(defclass apropos-result-panel (capi:multi-column-list-panel)
  ()
  (:documentation "A subclass of CAPI:MULTI-COLUMN-LIST-PANEL which
solely exists for the purpose of specializing
CAPI:MAKE-PANE-POPUP-MENU - see below."))
(capi:define-interface apropos-dialog (lispworks-tools::lispworks-interface)
  ((search-list :initform nil
                :accessor apropos-dialog-search-list
                :documentation "A list of previous search strings.")
   (search-string :initform nil
                  :accessor apropos-dialog-search-string
                  :documentation "The current search string.")
   (result-list :initform nil
                :accessor apropos-dialog-result-list
                :documentation "A list of symbols that are the result
of the current Apropos search.")
   (sort-key :initform :name
             :accessor apropos-dialog-sort-key
             :documentation "A keyword denoting how the result panel
is currently sorted.  Each keyword corresponds to a column header.")
   (type-test :initform (constantly t)
              :accessor apropos-dialog-type-test
              :documentation "The function that's currently used to
check whether a symbol should be included in the result panel.
Controlled by the buttons within the `Show' frame."))
  (:panes
   (string-input
    capi:text-input-choice
    :accessor apropos-dialog-string-input
    :title "String: "
    :text (get-apropos-user-preference "string-input" "")
    :callback-type :interface
    :callback 'update-search-list
    :selection-callback 'update-result-list
    :items nil)
   (search-button
    capi:push-button
    :text "Search"
    :callback-type :interface
    :callback 'update-search-list)
   (exported-button
    capi:check-button
    :accessor apropos-dialog-exported-button
    :selected (get-apropos-user-preference "exported-button" t)
    :callback-type :interface
    :selection-callback 'update-result-panel
    :retract-callback 'update-result-panel
    :text "Show only exported symbols")
   (present-symbols-button
    capi:check-button
    :accessor apropos-dialog-present-symbols-button
    :selected (get-apropos-user-preference "present-symbols-button" nil)
    :enabled (not (get-apropos-user-preference "all-packages-button" t))
    :callback-type :interface
    :selection-callback 'update-result-panel
    :retract-callback 'update-result-panel
    :text "Show only symbols present in selected package")
   (warn-on-long-searches-button
    capi:check-button
    :accessor apropos-dialog-warn-on-long-searches-button
    :selected (get-apropos-user-preference "warn-on-long-searches-button" t)
    :callback-type :none
    :text "Warn on \(most) long searches")
   (regex-button
    capi:check-button
    :accessor apropos-dialog-regex-button
    :selected (get-apropos-user-preference "regex-button" t)
    :callback-type :interface
    :selection-callback 'update-result-list
    :retract-callback 'update-result-list
    :text "Search string is regular expression")
   (all-packages-button
    capi:check-button
    :accessor apropos-dialog-all-packages-button
    :text "All"
    :callback-type :none
    :selected (get-apropos-user-preference "all-packages-button" t)
    ;; disable some stuff when this button is checked
    :selection-callback (lambda ()
                          (setf (capi:option-pane-enabled package-pull-down) nil
                                (capi:button-enabled present-symbols-button) nil)
                          (update-result-list capi:interface))
    :retract-callback (lambda ()
                        (setf (capi:option-pane-enabled package-pull-down) t
                              (capi:button-enabled present-symbols-button) t)
                        (update-result-list capi:interface)))
   (package-pull-down
    capi:option-pane
    :accessor apropos-dialog-package-pull-down
    :items (sort (list-all-packages) #'string< :key #'package-name)
    :print-function #'package-name
    :enabled (not (get-apropos-user-preference "all-packages-button" t))
    :selected-item (let ((package-name (get-apropos-user-preference "package-pull-down" "LW-ADD-ONS")))
                     (or (and package-name
                              (find-package package-name))
                         (find-package :lw-add-ons)))
    :callback-type :interface
    :selection-callback 'update-result-list)
   (all-types-button
    capi:check-button
    :accessor apropos-dialog-all-types-button
    :text "All"
    :selected (get-apropos-user-preference "all-types-button" t)
    :callback-type :none
    ;; disable the other three buttons when this button is checked
    :selection-callback (lambda ()
                          (setf (capi:button-enabled variables-button) nil
                                (capi:button-enabled functions-button) nil
                                (capi:button-enabled classes-button) nil)
                          (update-type-test capi:interface))
    :retract-callback (lambda ()
                        (setf (capi:button-enabled variables-button) t
                              (capi:button-enabled functions-button) t
                              (capi:button-enabled classes-button) t)
                        (update-type-test capi:interface)))
   (variables-button
    capi:check-button
    :accessor apropos-dialog-variables-button
    :text "Variables"
    :enabled (not (get-apropos-user-preference "all-types-button" t))
    :selected (get-apropos-user-preference "variables-button" nil)
    :callback-type :interface
    :selection-callback 'update-type-test
    :retract-callback 'update-type-test)
   (functions-button
    capi:check-button
    :accessor apropos-dialog-functions-button
    :text "Functions"
    :enabled (not (get-apropos-user-preference "all-types-button" t))
    :selected (get-apropos-user-preference "functions-button" t)
    :callback-type :interface
    :selection-callback 'update-type-test
    :retract-callback 'update-type-test)
   (classes-button
    capi:check-button
    :accessor apropos-dialog-classes-button
    :text "Classes"
    :enabled (not (get-apropos-user-preference "all-types-button" t))
    :selected (get-apropos-user-preference "classes-button" nil)
    :callback-type :interface
    :selection-callback 'update-type-test
    :retract-callback 'update-type-test)
   (result-panel
    apropos-result-panel
    :accessor apropos-dialog-result-panel
    :title ""
    :interaction :extended-selection
    #-:no-right-click-selection-behavior #-:no-right-click-selection-behavior
    :right-click-selection-behavior :temporary-selection
    :callback-type :item-interface
    :action-callback (lambda (item interface)
                       (let* ((symbol-name (first item))
                              (symbol-package (second item))
                              (symbol (intern symbol-name (find-package symbol-package))))
                         (cond ((source-can-be-found symbol)
                                (ignore-errors*
                                  (lispworks-tools::interface-find-source interface symbol)))
                               ((documentation-uri symbol)
                                (browse-anchored-uri (documentation-uri symbol))))))
    :columns '((:width (:character 60))
               (:width (:character 40))
               (:width (:character 10))
               (:width (:character 10))
               (:adjust :center :width (:character 10))
               (:adjust :center :width (:character 10)))
    :header-args `(:items ,+apropos-headline+
                   :alignments (:left :left :center :center :center :center)
                   :callback-type :item
                   ;; clicking on a column header changes the sort order
                   :selection-callback ,(lambda (item)
                                          (setq sort-key
                                                (case (position item +apropos-headline+ :test #'string=)
                                                  (1 :package)
                                                  (2 :fun)
                                                  (3 :var)
                                                  (4 :class)
                                                  (5 :exp)
                                                  (otherwise :name)))
                                          (re-sort-result-panel capi:interface)))
    :sort-descriptions (mapcar (lambda (type key)
                                 (capi:make-sorting-description
                                  :type type
                                  :key key
                                  :sort #'string-lessp
                                  :reverse-sort #'string-greaterp))
                               '(:name :package :fun :var :class :exp)
                               (list #'first #'second #'third #'fourth #'fifth #'sixth))))
  (:layouts
   (string-layout
    capi:row-layout
    '(string-input search-button))
   (button-layout
    capi:grid-layout
    '(exported-button present-symbols-button regex-button warn-on-long-searches-button)
    :columns 2
    :x-gap 5
    :y-gap 5)
   (package-layout
    capi:row-layout
    '(all-packages-button package-pull-down)
    :adjust :center
    :title "Package(s) to search"
    :title-position :frame)
   (type-layout
    capi:grid-layout
    '(all-types-button variables-button functions-button classes-button)
    :columns 2
    :x-gap 5
    :y-gap 5
    :title "Show"
    :title-position :frame)
   (left-control-layout
    capi:column-layout
    '(button-layout package-layout))
   (control-layout
    capi:row-layout
    '(left-control-layout type-layout))
   (main-layout
    capi:column-layout
    '(string-layout control-layout result-panel)))
  (:default-initargs
   :layout 'main-layout
   :create-callback (lambda (interface)
                      ;; we have to jump through some hoops -
                      ;; see <http://thread.gmane.org/gmane.lisp.lispworks.general/4873>
                      (mp:process-run-function
                       "apropos-preselect-text" nil
                       (lambda ()
                         (capi:execute-with-interface
                          interface
                          (lambda (interface)
                            (let* ((string-input (apropos-dialog-string-input interface))
                                   (text (capi:text-input-pane-text string-input)))
                              (capi:set-pane-focus string-input)
                              (capi:set-text-input-pane-selection string-input
                                                                  0
                                                                  (length text))))
                          interface))))
   :destroy-callback (lambda (interface)
                       (set-apropos-user-preferences
                        "exported-button"
                        (capi:button-selected
                         (apropos-dialog-exported-button interface))
                        "present-symbols-button"
                        (capi:button-selected
                         (apropos-dialog-present-symbols-button interface))
                        "warn-on-long-searches-button"
                        (capi:button-selected
                         (apropos-dialog-warn-on-long-searches-button interface))
                        "regex-button"
                        (capi:button-selected
                         (apropos-dialog-regex-button interface))
                        "all-packages-button"
                        (capi:button-selected
                         (apropos-dialog-all-packages-button interface))
                        "all-types-button"
                        (capi:button-selected
                         (apropos-dialog-all-types-button interface))
                        "variables-button"
                        (capi:button-selected
                         (apropos-dialog-variables-button interface))
                        "functions-button"
                        (capi:button-selected
                         (apropos-dialog-functions-button interface))
                        "classes-button"
                        (capi:button-selected
                         (apropos-dialog-classes-button interface))
                        "string-input"
                        (capi:text-input-pane-text
                         (apropos-dialog-string-input interface))
                        "package-pull-down"
                        (package-name
                         (capi:choice-selected-item
                          (apropos-dialog-package-pull-down interface))))))
  (:documentation "The definition of the CAPI interface that's used to
display the Apropos Dialog."))
  
(defmethod update-type-test ((interface apropos-dialog))
  "Updates the TYPE-TEST slot of INTERFACE according to the buttons in
the `Show' frame.  Calls UPDATE-RESULT-PANEL afterwards."
  (with-accessors ((type-test apropos-dialog-type-test)
                   (all-types-button apropos-dialog-all-types-button)
                   (variables-button apropos-dialog-variables-button)
                   (functions-button apropos-dialog-functions-button)
                   (classes-button apropos-dialog-classes-button))
      interface
    (setq type-test
          (cond ((capi:button-selected all-types-button)
                 (constantly t))
                (t (let ((variablesp (capi:button-selected variables-button))
                         (functionsp (capi:button-selected functions-button))
                         (classesp (capi:button-selected classes-button)))
                     (cond ((or variablesp functionsp classesp)
                            (lambda (symbol)
                              (or (and variablesp
                                       (boundp symbol))
                                  (and functionsp
                                       (fboundp symbol))
                                  (and classesp
                                       (find-class symbol nil)))))
                           (t (constantly nil)))))))
    (update-result-panel interface)))
(defmethod update-search-list ((interface apropos-dialog))
  "Updates the SEARCH-STRING slot of INTERFACE from the input provided
by the STRING-INPUT pane.  SEARCH-LIST is also modified accordingly
and afterwards UPDATE-RESULT-LIST is called."
  (with-accessors ((search-list apropos-dialog-search-list)
                   (search-string apropos-dialog-search-string)
                   (string-input apropos-dialog-string-input)
                   (warn-on-long-searches-button apropos-dialog-warn-on-long-searches-button)
                   (all-packages-button apropos-dialog-all-packages-button))
      interface
    (let ((string (capi:text-input-pane-text string-input))
          cancelp)
      (when (and (< (length string) 3)
                 (cond ((capi:button-selected all-packages-button) t)
                       (t (capi:button-selected warn-on-long-searches-button))))
        (setq cancelp
              (not (capi:confirm-yes-or-no "Search string is very short, APROPOS might take a looooong time.~%Do you really want to start the search?"))))
      (unless cancelp
        (pushnew string search-list :test #'string=)
        (when (> (length search-list) *apropos-max-search-list-length*)
          (setq search-list (subseq search-list 0 *apropos-max-search-list-length*)))
        (setf (capi:collection-items string-input)
              (sort (copy-list search-list) #'string-lessp)
              (capi:text-input-pane-text string-input)
              string
              search-string
              string)
        (update-result-list interface)))))
(defmethod update-result-list ((interface apropos-dialog))
  "Updates the RESULT-LIST slot of INTERFACE according to
SEARCH-STRING, the REGEX-BUTTON button and the package selection.
Calls UPDATE-RESULT-PANEL afterwards."
  (with-accessors ((result-list apropos-dialog-result-list)
                   (search-string apropos-dialog-search-string)
                   (regex-button apropos-dialog-regex-button)
                   (all-packages-button apropos-dialog-all-packages-button)
                   (package-pull-down apropos-dialog-package-pull-down))
      interface
    (when search-string
      (let ((regex (cond ((capi:button-selected regex-button)
                          search-string)
                         (t (quote-meta-chars search-string))))
            (package (and (not (capi:button-selected all-packages-button))
                          (capi:choice-selected-item package-pull-down))))
        (setq result-list
              (handler-case 
                  (sort (remove-duplicates (regex-apropos-list regex package)
                                           :test #'eq)
                        #'string-lessp :key #'symbol-name)
                (error (msg)
                       (capi:display-message "~A" msg)
                       nil)))))
    (update-result-panel interface)))
(defun symbol-exported-p (symbol)
  "Returns a true value iff the symbol SYMBOL is exported from its
home package."
  (eq (nth-value 1 (find-symbol (symbol-name symbol)
                                (symbol-package symbol)))
      :external))
(defun function-info (symbol)
  "Returns a string with information about the symbol SYMBOL that can
be used for the `Fun' column of the result panel."
  (cond ((special-operator-p symbol) "special op")
        ((macro-function symbol) "macro")
        ((fboundp symbol)
         (cond ((typep (symbol-function symbol) 'generic-function) "generic")
               (t "function")))
        (t "")))
(defun var-info (symbol)
  "Returns a string with information about the symbol SYMBOL that can
be used for the `Var' column of the result panel."
  (cond ((constantp symbol) "const")
        ((boundp symbol) "bound")
        (t "")))
(defmethod update-result-panel ((interface apropos-dialog))
  "Updates the items shown in the result panel of INTERFACE according
to the contents of the RESULT-LIST slot and various other settings."
  (with-accessors ((result-list apropos-dialog-result-list)
                   (result-panel apropos-dialog-result-panel)
                   (search-string apropos-dialog-search-string)
                   (regex-button apropos-dialog-regex-button)
                   (exported-button apropos-dialog-exported-button)
                   (present-symbols-button apropos-dialog-present-symbols-button)
                   (package-pull-down apropos-dialog-package-pull-down)
                   (type-test apropos-dialog-type-test))
      interface
    (when search-string
      (let* ((selected-package (capi:choice-selected-item package-pull-down))
             (show-present-symbols-p (and selected-package
                                          (capi:button-enabled present-symbols-button)
                                          (capi:button-selected present-symbols-button)))
             (package-test (cond ((and show-present-symbols-p
                                       (capi:button-selected exported-button))
                                  (lambda (symbol)
                                    (and (symbol-exported-p symbol)
                                         (eq (symbol-package symbol) selected-package))))
                                 (show-present-symbols-p
                                  (lambda (symbol)
                                    (eq (symbol-package symbol) selected-package)))
                                 ((capi:button-selected exported-button)
                                  #'symbol-exported-p)
                                 (t (constantly t)))))
        (setf (capi:titled-object-title result-panel)
              (format nil "Symbols ~:[containing~;matching~] ~S"
                      (capi:button-selected regex-button)
                      search-string)
              (capi:collection-items result-panel)
              (loop for symbol in result-list
                    when (and (funcall package-test symbol)
                              (funcall type-test symbol))
                    collect (list (symbol-name symbol)
                                  (package-name (symbol-package symbol))
                                  (function-info symbol)
                                  (var-info symbol)
                                  (if (find-class symbol nil) "x" "")
                                  (if (symbol-exported-p symbol) "x" ""))))))))
(defmethod re-sort-result-panel ((interface apropos-dialog))
  "Changes the sort order of the items in the result panel of
INTERFACE according to the SORT-KEY slot."
  (with-accessors ((result-panel apropos-dialog-result-panel)
                   (search-string apropos-dialog-search-string)
                   (sort-key apropos-dialog-sort-key))
      interface
    (when search-string
      (capi:sorted-object-sort-by result-panel sort-key))))
(defmethod capi:make-pane-popup-menu ((result-panel apropos-result-panel)
                                      (interface apropos-dialog)
                                      &key &allow-other-keys)
  "This method is responsible for the right-click popup menu in the
Apropos dialog.  Unfortunately, this doesn't seem to work on LWM."
  (let* ((items (capi:collection-items result-panel))
         (selection (capi:choice-selection result-panel))
         (length (length selection)))
    (cond ((zerop length)
           #-:macosx nil
           ;; dummy menu to work around a deficiency in OS X
           #+:macosx (make-instance 'capi:menu
                                    :title "Dummy Menu"
                                    :items (list (make-instance 'capi:menu-item
                                                                :title "Dummy Item"))))
          ((= length 1)
           (let* ((index (first selection))
                  (item (elt items index)))
             (destructuring-bind (title menu-items)
                 (create-apropos-popup-menu item interface)
               (make-instance 'capi:menu
                              ;; add title as a dummy menu entry
                              :items (cons (make-instance 'capi:menu-component
                                                          :items (list (make-instance 'capi:menu-item
                                                                                      :title title)))
                                           menu-items)))))
          (t
           ;; if there's more than one item in the selection
           ;; each one gets its own submenu
           (make-instance 'capi:menu
                          :items (loop for index in selection
                                       for item = (elt items index)
                                       for (title menu-items) = (create-apropos-popup-menu item interface)
                                       collect (make-instance 'capi:menu
                                                              :title title
                                                              :items menu-items)))))))
      
(defun create-apropos-popup-menu (item interface)
  "Returns a list of two elements - a title and a popup menu for the
item ITEM which is a list of strings used for the result panel."
  (let* ((symbol-name (first item))
         (symbol-package (second item))
         (symbol (intern symbol-name (find-package symbol-package)))
         menu-items
         submenu-items)
    (flet ((inspect-symbol ()
             "A function that opens an IDE inspector for the symbol SYMBOL."
             (gui-inspect symbol)))
      (when-let (class (find-class symbol nil))
        (push (make-instance 'capi:menu-item
                             :callback-type :none
                             :callback (lambda ()
                                         "A function that opens a
class browser for the class named by the symbol SYMBOL."
                                         (capi:find-interface 'lispworks-tools:class-browser
                                                              :object class))
                             :title (format nil "Class: ~A" (format-object-for-apropos class)))
            submenu-items))
      (when (fboundp symbol)
        (let ((symbol-function (symbol-function symbol)))
          (push (make-instance 'capi:menu-item
                               :callback-type :none
                               :callback (cond ((typep symbol-function 'generic-function)
                                                (lambda ()
                                                  "A function that opens a generic function browser for the generic function named by the symbol SYMBOL."
                                                  (capi:find-interface 'lispworks-tools:generic-function-browser
                                                                       :object symbol-function)))
                                               (t #'inspect-symbol))
                               :title (format nil "Function cell: ~A" (format-object-for-apropos symbol-function)))
                submenu-items)))
      (when (boundp symbol)
        (push (make-instance 'capi:menu-item
                             :callback-type :none
                             :callback #'inspect-symbol
                             :title (format nil "Value cell: ~A" (format-object-for-apropos (symbol-value symbol))))
              submenu-items)))
    (when submenu-items
      (push (make-instance 'capi:menu-component :items submenu-items) menu-items)
      (setq submenu-items nil))
    (let ((uri (documentation-uri symbol)))
      (push (make-instance 'capi:menu-item
                           :enabled-function (constantly uri)
                           :title "Documentation"
                           :callback-type :none
                           ;; only enable if a documentation URI was found
                           :callback (lambda ()
                                       (browse-anchored-uri uri)))
            submenu-items))
    (push (make-instance 'capi:menu-item
                         :title "Find Source"
                         ;; only enable if we can locate the source code
                         :enabled-function (constantly
                                            (source-can-be-found symbol))
                         :callback-type :none
                         :callback (lambda ()
                                     (ignore-errors*
                                       (lispworks-tools::interface-find-source interface symbol))))
          submenu-items)
    (push (make-instance 'capi:menu-component :items submenu-items) menu-items)
    (list (format-object-for-apropos symbol) menu-items)))