;;; -*- Mode: emacs-lisp; -*-

;; templates are handy....
(require 'tempo)

(tempo-define-template
 "read-only-slot"
 (list 
 '(p "Slot name?  " slot-name 'noinsert)
 "(" '(s slot-name) 'n>
 ":initarg :" '(s slot-name) 'n>
 ":reader " '(s slot-name) 'n>
 ")"
 ))

(tempo-define-template
 "read-write-slot"
 (list 
 '(p "Slot name?  " slot-name 'noinsert)
 "(" '(s slot-name) 'n>
 ":initarg :" '(s slot-name) 'n>
 ":accessor " '(s slot-name) 'n>
 ")"
 ))

(tempo-define-template
 "defclass"
 (list
  '(p "Class name?  " class-name 'noinsert)
  '(p "Superclasses? " superclass-list 'noinsert)
  "(defclass " '(s class-name) " (" '(s superclass-list) ")" 'n>
  "()" 'n> ;; slots
  ")" 'n>
  ))

(tempo-define-template
 "defun"
 (list
  '(p "function name?  " fun-name 'noinsert)
  '(p "arguments? " arg-list 'noinsert)
  "(defun " '(s fun-name) " (" '(s arg-list) ")" 'n>
  'p ")" 'n>
  '(prog1 nil (tempo-backward-mark))
  ))


(tempo-define-template
 "define-condition"
 (list
  '(p "Condition name?  " class-name 'noinsert)
  '(p "Superclasses? " superclass-list 'noinsert)
  "(define-condition " '(s class-name) " (" '(s superclass-list) ")" 'n>
  "()" 'n> ;; slots
  ")" 'n>
  ))
  
(tempo-define-template
 "defgeneric"
 (list
  "(defgeneric " '(p "function name?  ")
  " (" '(p "arguments? ") ")" 'n>
  '(p "doc string?" docstring noinsert)
  '(unless (equal (tempo-lookup-named 'docstring) "")
       (list 'l "(:documentation \"" '(s docstring) "\")" 'n>))
  ")" 'n>
  ))

(tempo-define-template
 "defgeneric-method"
 (list "(:method " 
       '(p "Qualifier?  ")
       " (" '(p "arguments? ") ")" 'n>
       ")" 'n>))

(tempo-define-template
 "defmethod"
 (list
  "(defmethod " '(p "function name?  ")
  " (" '(p "arguments? ") ")" 'n>
  '(p "doc string?" docstring noinsert)
  '(unless (equal (tempo-lookup-named 'docstring) "")
       (list 'l "\"" '(s docstring) "\"" 'n>))
  ")" 'n>
  ))

(tempo-define-template
 "defstruct"
 (list
  "(defstruct " '(p "structure name?  ")
  " (" '(p "arguments? ") ")" 'n>
  "\"" '(p "doc string?") "\"" 'n> 
  ")" 'n>
  ))

(tempo-define-template
 "documentation"
 (list
 '(p "doc string?" docstr 'noinsert)
  "(:documentation \""
  '(s docstr)
  "\")"
  ))

(tempo-define-template
 "defvar"
 (list
  "(defvar " '(p "variable name?  ") 'n>
  '(p "initial value?  ") 'n>
  "\"" '(p "doc string?"  ) "\")" 'n> 
  ))

(tempo-define-template
 "defpackage"
 (list
  "(defpackage " '(p "package name?  ") 'n>
  '(p "uses package (list or single package)?  " uses noinsert)
  '(let ((uses (first (read-from-string (tempo-lookup-named 'uses)))))
    (cond ((null uses) nil)
	  ((listp uses)
	   `(l "(:use" ,@(loop for x in uses
			       collect " "
				collect (symbol-name x))
	       ")"))
	  (t
	   `(l "(:use " (s uses) ")"))))
  ;; nicknames would be a nice addition...
  ")"
  'n>
  ))

(tempo-define-template
 "asdf-prefix"
 (list
  "(defpackage " ":" '(p "system name?  " name) "-asd" 'n>
  "(:use :common-lisp :asdf)" 'n>
  ")"
  'n>
  "(in-package " ":" '(s name) "-asd" ")" 'n>
  "(defsystem " '(s name) 'n>
     ":depends-on ()" 'n>
     ":components ()" 'n>
  ")"
  ))

(tempo-define-template
 "defstruct"
 (list
  '(p "Struct type name?  " class-name 'noinsert)
  "(defstruct " '(s class-name) 'n>
  'n>;; slots
  ")" 'n>
  ))

(tempo-define-template
 "in-package"
 (list
  '(p "Package name?  " pkg-name 'noinsert)
  "(in-package #:" '(s pkg-name) ")"
  ))

(tempo-define-template
 "function-declaration"
 (list
  "(declaim" 'n>
  "(ftype" 'n>
  "(function "
  '(p "function name?  " fname t)
  "(" '(p "argument types? ") ")" 'n>
  "(values " '(p "return values? ") " &optional))" 'n>
  '(s fname) "))" '>
  ))


(defun make-cl-tempo-map (map &optional map-key)
  (unless map-key (setf map-key (kbd "C-c C-c")))
  (let ((tempo-map (make-sparse-keymap "lisp-tempo-map")))
    (define-key map map-key tempo-map)
    (cl-template-populate-tempo-map tempo-map)))

(defun cl-template-populate-tempo-map (tempo-map)
    (define-key tempo-map "r" 'tempo-template-read-only-slot)
    (define-key tempo-map "w" 'tempo-template-read-write-slot)
    (let ((defgeneric-submap (make-sparse-keymap "lisp-defgeneric-tempo-map")))
      (define-key tempo-map "g" defgeneric-submap)
      (define-key defgeneric-submap "g" 'tempo-template-defgeneric)
      (define-key defgeneric-submap "m" 'tempo-template-defgeneric-method)
      (define-key defgeneric-submap "d" 'tempo-template-documentation))
    (define-key tempo-map "c" 'tempo-template-defclass)
    (define-key tempo-map "C" 'tempo-template-define-condition)
    (define-key tempo-map "p" 'tempo-template-defpackage)
    (define-key tempo-map "d" 'tempo-template-documentation)
    (define-key tempo-map "m" 'tempo-template-defmethod)
    (define-key tempo-map "v" 'tempo-template-defvar)
    (define-key tempo-map "a" 'tempo-template-asdf-prefix)
    (define-key tempo-map "s" 'tempo-template-defstruct)
    (define-key tempo-map "f" 'tempo-template-defun)
    (define-key tempo-map "i" 'tempo-template-in-package)
    )

(defun cl-template-populate-tempo-menu (parent-keymap)
  "Add a submenu to the PARENT-KEYMAP for CL templates."
  (easy-menu-define sly-cl-template-menu parent-keymap
    "Menu of Common Lisp Templates"
    '("CL Templates"
      ("Defclass helpers"
       [ "New DEFCLASS " tempo-template-defclass]
       ["Add read-only slot" tempo-template-read-only-slot]
       ["Add read-write slot" tempo-template-read-write-slot]
       ["Add docstring" tempo-template-documentation]
       )
      ("Defgeneric helpers"
       [ "New DEFGENERIC " tempo-template-defgeneric]
       [ "Internal method definition" tempo-template-defgeneric-method]
       ["Add docstring" tempo-template-documentation]
       )
      ("Other Top level constructs"
       ["Define condition" tempo-template-define-condition]
       ["Define method" tempo-template-defmethod]
       ["Define variable" tempo-template-defvar]
       ["Define function" tempo-template-defun]
       ["Define structure" tempo-template-defstruct]
       )
      ("Misc"
       ["ASDF file header" tempo-template-asdf-prefix]
       ["IN-PACKAGE" tempo-template-in-package]))))

(provide 'cl-templates)