xy-reference:lookup の代替品 #xyzzy

quick-reference.l

;;; -*- mode:lisp; package:quick-reference -*-

;; Copyright (c) 2012  Yousuke Ushiki
;;
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to deal
;; in the Software without restriction, including without limitation the rights
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;; copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;; THE SOFTWARE.

(provide "quick-reference")

(defpackage :quick-reference
  (:nicknames :qref)
  (:use :lisp :ed))

(in-package :quick-reference)
(export '(*reference-directory*
	  find-chapter
	  index
	  lookup
	  lookup-regexp
	  full-text-search))

(defvar *reference-directory* "~/reference")
(defvar *reference* nil)
(defvar *title-index* nil)
(defvar *loaded-references* nil)

(defconstant +msxml-domdoc-progid+ "Msxml2.DOMDocument.6.0")


;;; utilities
(defmacro iflet (var expr then &optional else)
  `(let ((,var ,expr)) (if ,var ,then ,else)))

(defmacro whenlet (var expr &body body)
  `(let ((,var ,expr)) (when ,var ,@body)))

(defmacro accum (name &body body)
  (let ((acc (gensym "acc"))
	(v (gensym)))
    `(let ((,acc nil))
       (flet ((,name (,v) (push ,v ,acc))) ,@body)
       (nreverse ,acc))))

(defmacro $ (oleobj &rest chain)
  (flet ((mkform (obj arg)
	   (let ((a (if (listp arg) arg (list arg))))
	     `(ole-method ,obj ',(car a) ,@(cdr a)))))
    (reduce #'mkform chain :initial-value oleobj)))

(defun mapcol (func col)
  (let ((result nil))
    (ole-for-each (e col)
      (push (funcall func e) result))
    (nreverse result)))


;;; msxml
(defun create-ole-xmldoc ()
  (let ((xmldom (ole-create-object +msxml-domdoc-progid+)))
    (setf ($ xmldom validateOnParse) nil)
    ($ xmldom (setProperty "ProhibitDTD" nil))
    xmldom))

(defun load-xml (path)
  (let ((doc (create-ole-xmldoc)))
    (if ($ doc (load path))
	doc
      (let ((perr ($ doc parseError)))
	(error "~A~%ParseError at line ~D, column ~D~%~S~%~A"
	       path ($ perr line) ($ perr linepos)
	       ($ perr srcText) ($ perr reason))))))

(defun find-nodes (dom xpath)
  (delete #'null (mapcol #'dom->sexp ($ dom (selectNodes xpath)))))

(defun find-1node (dom xpath)
  (dom->sexp ($ dom (selectSingleNode xpath))))

(defun dom->sexp (dom)
  (case ($ dom NodeType)
    (1 (cons (intern ($ dom NodeName) "keyword")
	     (delete #'null (mapcol #'dom->sexp ($ dom ChildNodes)))))
    (2 (cons (intern ($ dom Name) "keyword") ($ dom Value)))
    ((3 4 6) ($ dom NodeValue))
    (9 (delete #'null (mapcol #'dom->sexp ($ dom ChildNodes))))
    (t nil)))


;;; load reference files
(defun load-all-references (&optional reload)
  (when (and *reference* (typep *reference* 'oledata) (not reload))
    (return-from load-all-references))
  (let ((files (directory *reference-directory* :absolute t :wild "*.xml" :recursive t))
	(failed nil))
    (unless files
      (error "ファイルが見つかりません : ~A/*.xml" *reference-directory*))
    (setf *reference* (create-ole-xmldoc)
	  *title-index* nil
	  *loaded-references* nil
	  ($ *reference* documentElement) ($ *reference* (createElement "book")))
    (dolist (xml files)
      (handler-case (load-reference xml)
	(error (c) (push (si:*condition-string c) failed))))
    (if failed
	(message-box (format nil "以下のファイルはロードされませんでした。~{~%~A~}" failed)
		     "quick-reference")
      (message "load-all-references: done"))
    t))

(defun load-reference (xmlfile &aux (name (pathname-name xmlfile)))
  (when (find name *loaded-references* :test #'string=)
    (return-from load-reference))
  (unless (file-exist-p xmlfile)
    (error "ファイルが見つかりません : ~A" xmlfile))
  (let* ((root ($ *reference* documentElement))
	 (chapters ($ (load-xml xmlfile) (selectNodes "book/chapter")))
	 (count ($ chapters Length)))
    (when (> count 0)
      (ole-for-each (c chapters)
	(whenlet title ($ c (selectSingleNode "title"))
	  (push (cadr (dom->sexp title)) *title-index*))
	($ root (appendChild c)))
      (push name *loaded-references*)
      (message "~A : ~D chapters" name count))))

(defun index (&optional reload)
  (when (and (not reload) *title-index*)
    (return-from index *title-index*))
  (load-all-references t)
  *title-index*)


;;; exports
(defun find-chapter (&key title package section file type partial-match)
  (let ((xpath (format nil "/book/chapter~@?"
		       (if partial-match
			   "~{[contains(~A, '~A')]~}"
			 "~{[~A = '~A']~}")
		       (append (and title `(:title ,title))
			       (and package `(:package ,package))
			       (and section `(:section ,section))
			       (and file `(:file ,file))
			       (and type `(:type ,type))))))
    (mapcar #'cdr (find-nodes *reference* xpath))))

(defun lookup (title &key partial-match)
  (load-all-references)
  (find-chapter :title title :partial-match partial-match))

(defun lookup-regexp (regexp)
  (load-all-references)
  (accum a
    (dolist (title *title-index*)
      (when (string-match regexp title)
	(mapc #'a (lookup title))))))

(defun full-text-search (word)
  (load-all-references)
  (let ((xpath (format nil "/book/chapter[contains(., '~A')]" word)))
    (mapcar #'cdr (find-nodes *reference* xpath))))


;;; for edit
(setf (get 'whenlet #0='ed::lisp-indent-hook) 2
      (get 'iflet #0#) 2
      (get 'accum #0#) 1)

ロード時間比較

user> :time (length (xy-reference::index t))

6140 msec

2001


user> :time (length (qref::index t))
344 msec

2002

;; "verify-visited-file-modtime" が2chapterあるらしい