path: root/emacs.d/nxhtml/tests/mumamo-test.el

;;; mumamo-test.el --- Test routines for mumamo
;;
;; Author: Lennart Borgman
;; Created: Sat Mar 31 03:59:26 2007
;; Version: 0.1
;; Last-Updated:
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; This file defines some test for mumamo.el and a the minor mode
;; `mumamu-test-mode' to bind the test functions to some keys for
;; convenient use. This will define F3 to run
;; `mumamo-test-create-chunk-at' and Shift-F3 to
;; `mumamo-test-create-chunks-at-all-points'.
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Change log:
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:

;;(eval-when-compile (require 'mumamo))
(eval-when-compile (require 'mumamo))
(require 'whelp)

;;;;;;; TESTS, run in fundamental-mode buffer

(defvar mumamo-test-mode-keymap
  (let ((map (make-sparse-keymap)))
    (define-key map [f11] 'goto-char)
    (define-key map [(meta f3)] 'mumamo-test-fontify-region)
    (define-key map [(shift f3)] 'mumamo-test-create-chunks-at-all-points)
    (define-key map [f3] 'mumamo-test-create-chunk-at-point)
    map))

(defvar mumamo-test-current-chunk-family nil)
(make-variable-buffer-local 'mumamo-test-current-chunk-family)

(define-minor-mode mumamo-test-mode
  "For testing creating mumamo-mode chunks.
When this mode is on the following keys are defined:

  \\{mumamo-test-mode-keymap}

"
  nil
  " MuMaMo-TEST"
  :keymap mumamo-test-mode-keymap
  (if mumamo-test-mode
      (progn
        (setq mumamo-test-current-chunk-family mumamo-current-chunk-family)
        (setq mumamo-use-condition-case nil)
        (setq mumamo-debugger nil)
        (run-with-idle-timer 0 nil 'mumamo-test-tell-bindings))
    (setq mumamo-use-condition-case t)
    (setq mumamo-debugger (default-value 'mumamo-debugger)))
  )

(defun mumamo-test-tell-bindings ()
  (save-match-data ;; runs in timer
    (let ((s "mumamo-test-mode is on, use F3/shift-F3 for simple testing"))
      (put-text-property 0 (length s)
                         'face 'font-lock-warning-face
                         s)
      (message "%s" s))))

;;(mumamo-test-mode 1)


;; (defun mumamo-test-fontify-buffer ()
;;   (interactive)
;;   (unless mumamo-current-chunk-family
;;     (mumamo-select-chunk-family))
;;   ;;(when mumamo-mode (mumamo-mode 0))
;;   (when mumamo-multi-major-mode (mumamo-turn-off-actions))
;;   (save-excursion
;;     (mumamo-remove-all-chunk-overlays)
;;     (mumamo-save-buffer-state nil
;;       (put-text-property (point-min) (point-max) 'face nil))
;;     (mumamo-fontify-buffer)))

(defun mumamo-test-create-chunk-at-point ()
  (interactive)
  (remove-hook 'post-command-hook 'mumamo-post-command t)
  (font-lock-mode -1)
  (setq fontification-functions nil)
  (save-excursion
    (mumamo-remove-all-chunk-overlays)
    (mumamo-save-buffer-state nil
      (remove-text-properties (point-min) (point-max) '(face nil syntax-table nil)))
    (let* ((mumamo-current-chunk-family mumamo-test-current-chunk-family)
           (here (point))
           chunk
           chunk2)
      (mumamo-save-buffer-state nil
        ;;(setq chunk (mumamo-create-chunk-at here)))
        (setq chunk (mumamo-find-chunks here "test1")))
      ;;(setq chunk2 (mumamo-get-chunk-at here))
      (setq chunk2 (mumamo-find-chunks here "set chunk2"))
      ;;(message "mumamo-test-create-chunk-at-point.chunk 1=%s" chunk)
      ;;(lwarn 'test-create-chunk-at :warning "chunk=%s, chunk2=%s" chunk chunk2)
      ;;(when (overlay-buffer chunk)
        (assert (eq chunk chunk2))
        ;;)
      ;;(message "mumamo-test-create-chunk-at-point.chunk 2=%s" chunk)
      ;;(syntax-ppss-flush-cache (1- (overlay-start chunk)))
      (syntax-ppss-flush-cache (overlay-start chunk))
      (let ((start (overlay-start chunk))
            (end   (overlay-end chunk)))
        ;;(setq syntax-ppss-last (cons 319 (parse-partial-sexp 1 1)))
        ;;(message "mumamo-test-create-chunk-at-point.chunk 2a=%s" chunk)
        (mumamo-save-buffer-state nil
          (mumamo-fontify-region-1 start end nil)))
      ;;(message "mumamo-test-create-chunk-at-point.chunk 3=%s" chunk)
      (unless mumamo-test-mode (mumamo-test-mode 1))
      ;;(message "mumamo-test-create-chunk-at-point.chunk 4=%s" chunk)
      chunk
      ;;(message "test 2.debugger=%s" debugger)
      ;;(mumamo-get-chunk-at here)
      (mumamo-find-chunks here "return value")
      )))

(defun mumamo-test-create-chunks-at-all-points ()
  (interactive)
  ;;(goto-char (point-min))
  (let (last-ovl
        this-ovl)
    (while (< (point) (point-max))
      ;;(setq this-ovl (mumamo-test-create-chunk-at-point))
      (setq this-ovl (mumamo-find-chunks (point) "test loop"))
      ;;(message "this-ovl=%s" this-ovl)
      (sit-for 0.005)
      ;;(sit-for 0)
      (when last-ovl
        (if (= (point) (overlay-end last-ovl))
            (assert (= (overlay-end last-ovl) (overlay-start this-ovl)))
          (assert (= (overlay-start last-ovl) (overlay-start this-ovl)))
          (assert (= (overlay-end last-ovl) (overlay-end this-ovl)))
          ))
      (if last-ovl
          (move-overlay last-ovl (overlay-start this-ovl) (overlay-end this-ovl))
        (setq last-ovl (make-overlay (overlay-start this-ovl) (overlay-end this-ovl))))
      (forward-char 1)
      )
    (message "No problems found")))

(defun mumamo-test-fontify-region ()
  (interactive)
  (let ((font-lock-mode t))
    ;;(mumamo-fontify-region-with (point-min) (point-max) nil 'php-mode nil)
    (mumamo-fontify-region (point-min) (point-max) t)))

;; Fix-me: can't byte compile:
;; (defun mumamo-test-easy-make ()
;;   (interactive)
;;   (let ((start-str "--Start Submode:")
;;         (end-str "--End Submode--")
;;         (start-reg nil))
;;     (setq start-reg
;;           ;; (rx
;;           ;;  (eval start-str)
;;           ;;  (0+ space)
;;           ;;  (submatch
;;           ;;   (0+ (any "a-z-")))
;;           ;;  (0+ space)
;;           ;;  "--"
;;           ;;  )
;;           (rx-to-string
;;            `(and
;;              ,start-str
;;              (0+ space)
;;              (submatch
;;               (0+ (any "a-z-")))
;;              (0+ space)
;;              "--"
;;              ))
;;           )
;;     (mumamo-easy-make-chunk-fun testchunk
;;       start-str
;;       start-reg
;;       end-str))
;;   (setq mumamo-current-chunk-family
;;         (list "testing"
;;               'text-mode
;;               (list
;;                'testchunk
;;                ))))

;; (defun mumamo-test-emb-perl ()
;;   (interactive)
;;   (let ((start-str "[-")
;;         (end-str "-]")
;;         (start-reg nil))
;;     (mumamo-easy-make-chunk-fun testchunk-ep
;;       start-str
;;       start-reg
;;       end-str))
;;   (setq mumamo-current-chunk-family
;;         (list "emb perl test"
;;               'perl-mode
;;               (list
;;                'testchunk-ep
;;                ))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; These are for testing bad initialization in mumamo. They can be
;; used for example with php-mode. (They are mainly for development
;; purposes.)
;;
;; (mumamo-bad-c-init)
(defun mumamo-bad-c-init() (/ 1 0))
(defun mumamo-setup-bad-c-init ()
  (interactive)
  (add-hook 'c-mode-common-hook 'mumamo-bad-c-init))
(defun mumamo-teardown-bad-c-init ()
  (interactive)
  (remove-hook 'c-mode-common-hook 'mumamo-bad-c-init))


;; (defmacro mumamo-get-backtrace (bodyform)
;;   "Evaluate BODYFORM, return backtrace as a string.
;; If there is an error in BODYFORM then return the backtrace as a
;; string, otherwise return nil."
;;   `(let* ((debugger-ret nil)
;;           (debugger (lambda (&rest debugger-args)
;;                       (message "DEBUGGER CALLED BEFORE")
;;                       (setq debugger-ret (with-output-to-string (backtrace)))
;;                       (message "DEBUGGER CALLED AFTER, debugger-ret=%s" debugger-ret)
;;                       ))
;;           (debug-on-error t)
;;           (debug-on-signal t)
;;           )
;;      (condition-case err
;;          (progn
;;            ,bodyform
;;            nil)
;;        (error
;;         (message "err=%S" err)
;;         (message "debugger-ret=%S\n\n\n" debugger-ret)
;;         (let* ((errmsg (error-message-string err))
;;                (debugger-lines (split-string debugger-ret "\n"))
;;                (dbg-ret (mapconcat 'identity (nthcdr 6 debugger-lines) "\n")))
;;           (concat errmsg "\n" dbg-ret))))))

;; (defun mumamo-test3-debug()
;;   (interactive)
;;   (message "%s"
;;            (mumamo-get-backtrace
;;             (mumamo-test-major-mode-init 'php-mode))))

;; (defun mumamo-test2-debug()
;;   (interactive)
;;   (mumamo-condition-case var
;;                          (mumamo-test-major-mode-init 'php-mode)
;;                          handlers))

(defun mumamo-test-debug()
  (interactive)
  (condition-case err
      (let ((debugger 'mumamo-debug)
            (debug-on-error t)
            (debug-on-signal t))
        ;;(message "here d")(sit-for 1)
        (mumamo-test-major-mode-init 'php-mode))
    (error (message "here 2 err=%S" err))))

(defun mumamo-debug (&rest debugger-args)
  (let ((s (with-output-to-string (backtrace))))
    (message "mumamo-debug: %s" s)))

;; (defun mumamo-bt-to-msg (msg)
;;   (mumamo-msgfntfy "%s: %s" msg
;;            (with-output-to-string
;;              (backtrace))))

(defun mumamo-test-major-mode-init (major)
  "Turn on major mode MAJOR in a temp buffer.
This function should be used after getting errors during
fontification where the message in the *Message* buffer tells
that you should call it to get a traceback.

Send the traceback you get, if any, together with the message in
the message buffer when reporting the error."
  (interactive "CMajor mode: ")
  (with-temp-buffer
    ;;(setq mumamo-explicitly-turned-on-off t)
    (setq debug-on-error t)
    (funcall major)))

(provide 'mumamo-test)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mumamo-test.el ends here