;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; This file is part of "NOVA":  NOVA = search + COCOMO tools
; Copyright, 2008, Tim Menzies tim@menzies.us
;
; NOVA is free software: you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation, either version 3 of the License, or
; (at your option) any later version.
;
; NOVA is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.
; You should have received a copy of the GNU General Public License
; a long with NOVA.  If not, see <http://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :wvu-lib.tricks)
;;TODO consider having registry export key
(defmacro defregistry (name type &key (export nil))
  (labels ((catsym (&rest vars) (intern (apply #'concatenate (cons 'string vars))))
           (catlc  (&rest vars) (string-downcase (apply #'concatenate (cons 'string vars)))))
    (let* ((namestr (symbol-name name))
           (typestr (symbol-name type))
           (regvar (catsym "*" namestr "S*"))
           ;;function names
           (register-fn-name (catsym "REGISTER-" namestr))
           (register-by-parameters-fn-name (catsym "REGISTER-" namestr "-BY-PARAMETERS"))
           (lookup-fn-name (catsym "LOOKUP-" namestr))
           (all-ids-fn-name (catsym "ALL-" namestr "-IDS"))
           (all-fn-name (catsym "ALL-" namestr "S")))
      `(progn
         (defvar ,regvar nil)

         (defun ,register-fn-name (id ,name)
           ,(catlc "register a new " namestr)
           (declare (,type ,name))
           (puta id ,name
                 ,regvar))

         (defun ,register-by-parameters-fn-name (id &rest params)
           ,(catlc "register a new " namestr " with parameters")
           (puta id (apply #',(catsym "MAKE-" typestr) params)
                 ,regvar))

         (defun ,lookup-fn-name (id)
           ,(catlc "lookup a particular " namestr " based on id")
           (geta id ,regvar))

         (defun ,all-ids-fn-name ()
           ,(catlc "returns a list of the registered " namestr " ids")
           (mapcar #'car ,regvar))

         (defun ,all-fn-name ()
           ,(catlc "returns a list of the registered " namestr "s")
           (mapcar #'cdr ,regvar))
         ,(when export
                `(export '(,register-fn-name ,register-by-parameters-fn-name
                           ,lookup-fn-name ,all-ids-fn-name ,all-fn-name)))
         t))))