Skip to content

Instantly share code, notes, and snippets.

@youz
Created February 16, 2012 08:33
Show Gist options
  • Save youz/1843330 to your computer and use it in GitHub Desktop.
Save youz/1843330 to your computer and use it in GitHub Desktop.
xy-reference:lookup の代替品 #xyzzy
;;; -*- 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あるらしい
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment