Skip to content
Browse files

initial commit of manifest search

  • Loading branch information...
1 parent 340968b commit 36785ed33e372690e26a60bf4f6ded0c532b6a2b @bobbysmith007 bobbysmith007 committed Dec 22, 2011
Showing with 176 additions and 0 deletions.
  1. +55 −0 manifest-search.asd
  2. +121 −0 manifest-search.lisp
View
55 manifest-search.asd
@@ -0,0 +1,55 @@
+;; -*- lisp -*-
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package :manifest-search.system)
+ (defpackage :manifest-search.system
+ (:use :common-lisp :asdf))))
+
+(in-package manifest-search.system)
+
+(defsystem :manifest-search
+ :description "A library providing various collector type macros
+ pulled from arnesi into its own library and stripped of dependencies"
+ :licence "BSD"
+ :version "0.1"
+ :components ((:file "manifest-search"))
+ :depends-on (:alexandria :collectors :iterate :manifest :montezuma))
+
+(defsystem :manifest-search-test
+ :description "A library providing various collector type macros
+ pulled from arnesi into its own library"
+ :licence "BSD"
+ :version "0.1"
+ :components ((:module :tests
+ :serial t
+ :components ((:file "manifest-search"))))
+ :depends-on (:manifest-search :lisp-unit))
+
+(defmethod asdf:perform ((o asdf:test-op) (c (eql (find-system :manifest-search))))
+ (asdf:oos 'asdf:load-op :manifest-search-test))
+
+;; Copyright (c) 2011 Russ Tyndall , Acceleration.net http://www.acceleration.net
+;; 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 COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS 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 COPYRIGHT
+;; OWNER OR CONTRIBUTORS 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.
View
121 manifest-search.lisp
@@ -0,0 +1,121 @@
+;; -*- lisp -*-
+
+(cl:defpackage :manifest-search
+ (:use :cl :cl-user :iterate)
+ (:shadowing-import-from :alexandria :ensure-list)
+ (:export
+
+ ))
+
+(in-package :manifest-search)
+
+(defparameter *cl-doc-index*
+ (make-instance
+ 'montezuma:index
+ :path "~/lisp/doc-index"
+ :default-field "*"))
+
+(defun join-strings (list
+ &optional (delim ", ")
+ (ignore-empty-strings-and-nil t))
+ (collectors:with-string-builder-output
+ (collect :delimiter delim
+ :ignore-empty-strings-and-nil ignore-empty-strings-and-nil)
+ (iter (for i in (ensure-list list)) (collect (%to-s i)))))
+
+(defun doc-fn (type)
+ (handler-case
+ (fdefinition (intern (format nil "MAKE-~A-DOC" type) :manifest-search))
+ (undefined-function ()
+ #'make-default-doc)))
+
+(defun doc-with-fields (&rest fields)
+ (let ((doc (make-instance 'montezuma:document)))
+ (iter (for f in fields)
+ (when f (montezuma:add-field doc f)))
+ doc))
+
+(defun %to-s (thing)
+ "Turns whatever we were given into an indexable string"
+ (typecase thing
+ (null "")
+ (string thing)
+ (package (package-name thing))
+ (list (join-strings thing))
+ (t (princ-to-string thing))))
+
+(defun make-field (name value &optional (index? t))
+ (montezuma:make-field
+ (%to-s name)
+ (%to-s value)
+ :index (when index? :tokenized)))
+
+(defun make-default-doc (thing
+ &optional type package
+ &aux (docs (manifest::docs-for thing type)))
+ (doc-with-fields
+ (make-field :name thing)
+ (make-field :type type nil)
+ (make-field :package package nil)
+ (when docs (make-field :documentation docs))))
+
+(defun make-package-doc (package &optional (type :package) package-package)
+ (doc-with-fields
+ (make-field :name (package-name package))
+ (make-field :nicknames (package-nicknames package))
+ (make-field :type type nil)
+ (make-field :package package-package nil)
+ (make-field :documentation (documentation package t))
+ (make-field :readme (manifest::readme-text package))))
+
+(defun add-to-index (thing type &optional
+ package (index *cl-doc-index*)
+ &aux (doc-fn (doc-fn type)))
+ (montezuma:add-document-to-index
+ index (funcall doc-fn thing type package)))
+
+(defun index-package (package-name)
+ (let ((package (find-package package-name)))
+ (add-to-index package :package)
+ (iter (for what in manifest::*categories*)
+ (iter (for name in (manifest::names package what))
+ (add-to-index name what package)))
+ ))
+
+(defun get-doc (idx)
+ "Get a document for the thing passed in"
+ (etypecase idx
+ (montezuma:document idx)
+ (integer
+ (ignore-errors
+ (montezuma:get-document *cl-doc-index* idx)))))
+
+(defun doc-value (idx field
+ &aux (doc (get-doc idx)))
+ "When we have a document get its value"
+ (setf field (%to-s field))
+ (when doc
+ (when (montezuma:document-field doc field)
+ ;; this breaks when the field doesnt exist
+ (montezuma:document-value doc field))))
+
+(defun print-index-contents ()
+ (iter (for i upfrom 0)
+ (for d = (get-doc i))
+ (while d)
+ (format T "~A:~A:~A~%"
+ (doc-value d :package)
+ (doc-value d :name)
+ (doc-value d :type))))
+
+(defun search-manifest (phrase)
+ (montezuma:search-each
+ *cl-doc-index*
+ phrase
+ (lambda (d score)
+ (format T "~A:~A <~A : ~A> ~%"
+ (doc-value d :package)
+ (doc-value d :name)
+ (doc-value d :type)
+ score))))
+

0 comments on commit 36785ed

Please sign in to comment.
Something went wrong with that request. Please try again.