;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Macro comment-out
; a macro to produce funcitions for comment out for individual modes.
; by T.Shido 
; November  22, 2005 (ver 0.03)
; September 01, 2005 (ver 0.02)
; December  25, 2004 (ver 0.01)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; go to package editor
(in-package "editor")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; comment out <-> text body for region or rest of a line
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(eval-when (:compile-toplevel :load-toplevel)

  (defun make-sep (parms n front)
    (if front
        (concatenate 'string
                     (first parms)
                     (make-array n :initial-element (or (second parms) (char (first parms) 0))))
      (concatenate 'string
                   (make-array (+ n (- (length (first parms)) (length (third parms))))
                               :initial-element (or (second parms) (char (first parms) 0)))
                   (third parms))))

  (defun format-sym (form sym)
    (multiple-value-bind (sym status) (intern (format nil form sym))
      sym)))

(defun empty-line-p ()
  (save-excursion
    (goto-bol)
    (looking-at "[  	]*$")))

(defun delete-line ()
  (delete-region
   (progn (goto-bol) (point))
   (progn (forward-line) (goto-bol) (point)))
  (forward-line -1))


(defmacro comment-out (key-out key-in n &rest clauses)
  (let* ((modes (mapcar #'car clauses))
         (patterns-list (mapcar #'cdr clauses))
	 (comment-out-funs (mapcar #'(lambda (md) (format-sym "~A-comment-out" md)) modes))
         (comment-in-funs (mapcar #'(lambda (md) (format-sym "~A-comment-in" md)) modes)))
    `(progn
       (export ',(append comment-out-funs comment-in-funs))
       ,@(mapcar #'(lambda (patterns f-out)
		     `(defun ,f-out ()
			(interactive)
                        (if (pre-selection-p)
                            (let ((m (selection-mark))
                                  (p (selection-point)))
                              (stop-selection)
                              (let ((p0 (min m p)))
                                (goto-char (max m p))
                                (if (and (not (empty-line-p)) (eolp)) (forward-char))
                                (insert ,(make-sep patterns n (not (cdr patterns))) #\LFD)
                                (forward-line -2)
                                (loop 
                                  (insert ,(if (cdr patterns)
                                               (format nil "~A " (second patterns))
                                             (format nil "~A " (first patterns) )))
                                  (if (> (progn (goto-bol) (point)) p0)
                                      (forward-line -1)
                                    (return)))
                                (insert #\LFD ,(make-sep patterns n t) #\LFD)))
                          (progn
                            (insert ,(concat (first patterns) " "))
                            ,(if (cdr patterns)
                                 `(progn
                                    (goto-eol)
                                    (insert ,(concat " " (third patterns)))))))))
                 patterns-list comment-out-funs)

       ,@(mapcar #'(lambda (patterns f-in)
                     `(defun ,f-in ()
                        (interactive)
                        (if (pre-selection-p)
                            (let ((m (selection-mark))
                                  (p (selection-point)))
                              (stop-selection)
                              (let ((p0 (min m p)))
                                (goto-char (max m p))
                                (if (bolp) (forward-line -1))
                                (delete-line)
                                (loop
                                  (delete-char ,(if (cdr patterns) 2 (1+ (length (first patterns)))))
                                  (if (> (progn (goto-bol) (point)) p0)
                                      (forward-line -1)
                                    (return)))
                                (delete-line)))
                            
                          ,(if (cdr patterns)
                               `(let ((limit (progn (goto-eol) (point))))
                                  (goto-bol)
                                  (scan-buffer ,(concat (first patterns) " ") :limit limit)
                                  (delete-region (match-beginning 0) (match-end 0))
                                  (scan-buffer ,(concat " " (third patterns)) :limit limit)
                                  (delete-region (match-beginning 0) (match-end 0)))
                               `(progn
                                  (goto-bol)
                                  (delete-char ,(1+ (length (first patterns)))))))))
                 patterns-list comment-in-funs)
                 
       ,@(mapcar #'(lambda (md fout fin)
                     `(add-hook ',(format-sym "*~A-hook*" md)
                                #'(lambda ()
                                    (define-key ,(format-sym "*~A-map*" md) ,key-out ',fout)
                                    (define-key ,(format-sym "*~A-map*" md) ,key-in ',fin))))
                 modes comment-out-funs comment-in-funs))))


;;; example
; (comment-out #\M-o #\M-p
;              40
;              (lisp-mode ";" )
;              (hs-mode "--")
;              (c-mode "/*" #\* "*/")
;              (c++-mode "//")
;              (perl-mode "#")
;              (LaTeX-mode "%")
;              (html-mode "<!--" #\- "-->")
;              (html+-mode "<!--" #\- "-->")
;              (py-mode "#")
;              (awk-mode "#")
;              )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;: return to package user
(in-package "user")