(defvar stepper-program "/home/isstaff/asai/bin/stepper")
(defvar stepper-buffer-name "step_buffer.ml")
(defvar stepper-remove-sharpuse "/home/isstaff/asai/bin/remove-sharpuse")
(defvar stepper-tmp-buffer (concat "stepper_" (user-login-name) ".ml"))
(defvar stepper-tmp-file (concat "/tmp/" stepper-tmp-buffer))

; the same as predefined highlight but with different color
(defface highlight2
  '((((class color) (min-colors 88) (background light))
     :background "slateBlue1")
    (((class color) (min-colors 88) (background dark))
     :background "slateBlue1")
    (((class color) (min-colors 16) (background light))
     :background "slateBlue1")
    (((class color) (min-colors 16) (background dark))
     :background "slateBlue1")
    (((class color) (min-colors 8))
     :background "slateBlue1" :foreground "black")
    (t :inverse-video t))
  "Basic face for highlighting."
  :group 'basic-faces)

(defface highlight3
  '((((class color) (min-colors 88) (background light))
     :background "pink")
    (((class color) (min-colors 88) (background dark))
     :background "pink")
    (((class color) (min-colors 16) (background light))
     :background "pink")
    (((class color) (min-colors 16) (background dark))
     :background "pink")
    (((class color) (min-colors 8))
     :background "pink" :foreground "black")
    (t : inverse-video t))
  "Basic face for highlighting."
  :group 'basic-faces)

(defun stepper-redex-highlight (str prop)
  "highlight redex or reduct"
  (interactive)
  (progn
    (goto-char (point-max))
    (while (re-search-backward (concat "\\[@stepper." str) nil t 1)
      ; (<p0>(<p1>true<p2>)   <p3>[@stepper.str ]<p4>)
      (let ((p3 (point)))
        (search-forward "]")
        (let ((p4 (point)))
          (search-backward ")")
          (let ((p2 (point)))
            (goto-char (1+ p2))
            (backward-list 1)
            (let* ((p0 (point))
                   (p1 (1+ p0)))
              (add-text-properties p0 p1 '(invisible t))
              (add-text-properties p1 p2 prop)
              (add-text-properties p2 p3 '(invisible t))
              (add-text-properties p3 p4 '(invisible t))
              )))))))

(defun stepper-printed-highlight ()
  "highlight printed string"
  (interactive)
  (progn
    (goto-char (point-max))
    (while (search-backward "[@stepper.printed" nil t 1)
      ; <p0>(<p1>printedstring<p2>)  [@stepper.printed ]<p3>
      (search-forward "]")
      (let ((p3 (point)))
        (search-backward ")")
        (let ((p2 (point)))
          (goto-char (1+ p2))
          (backward-list 1)
          (let* ((p0 (point))
                 (p1 (1+ p0)))
            (add-text-properties p0 p1 '(invisible t))
            (add-text-properties p1 p2 '(face highlight3))
            (add-text-properties p2 p3 '(invisible t))
          ))))))

(defun stepper-remove-indent (n p0 p1)
  "remove uncesessary indent (n spaces) up from p0 (not including p0)
   to p1 (not including p1)"
  (progn
    (goto-char p0)
    (search-forward "\n")
    (while (< (point) p1)
      (add-text-properties (point) (+ n (point)) '(invisible t))
      (search-forward "\n"))))

(defun stepper-remove-semisemi ()
  "remove unnecessary ;;"
  (progn
    (goto-char (point-min))
    (while (re-search-forward "^;;" nil t 1)
      (add-text-properties (match-beginning 0) (match-end 0) '(invisible t))
      (let ((p0 (point)))
        (re-search-forward "^$" nil t 1)
        (stepper-remove-indent 2 p0 (point))))))

(defun stepper-remove-exc ()
  "remove error messages"
  (progn
    (goto-char (point-min))
    (while (re-search-forward "^propagating exc2?\n" nil t 1)
      (add-text-properties (match-beginning 0) (match-end 0) '(invisible t)))))

(defun stepper-highlight ()
  "highlight redex and reduct, remove unnecessary ;;"
  (interactive)
  (progn
    (stepper-redex-highlight "redex" '(face highlight))
    (stepper-redex-highlight "reduct" '(face highlight2))
    (stepper-printed-highlight)
    (stepper-remove-exc)
    (stepper-remove-semisemi)))

(defun stepper-find-step-redex (n)
  "return the beginning point of nth redex"
  ;    (* Step n *) ... [@stepper.reduct ] ...
  ; <p>(* Step n *) ... [@stepper.redex ] ...
  (progn
    (goto-char (point-max))
    (search-backward (format "(* Step %d *)" n) nil t 1)
    (point)))

(defun stepper-find-step-reduct (n)
  "return the beginning point of nth reduct"
  ; <p>(* Step n *) ... [@stepper.reduct ] ...
  ;    (* Step n *) ... [@stepper.redex ] ...
  (progn
    (goto-char (point-max))
    (search-backward (format "(* Step %d *)" n) nil t 2)
    (point)))

(defun stepper-find-app-between (p1 p2)
  "return the position of the first application mark between two points"
  ; <p1>(* Step a *) ...
  ;  <p>(* Application k start/end *)
  ;     (* Application l start/end *)
  ; <p2>(* Step b *) ...
  (progn
    (goto-char p1)
    (if (search-forward "(* Application " p2 t 1)
	(line-beginning-position)
      p2)))

(defun stepper-change-text-properties (add-or-remove n m)
  "add or remove invisible text properties for nth and mth step"
  ; <p0> ...
  ; <p1>(* Step n *) ... [@stepper.redex ] ...
  ; <p2>(* Application n start *) ...
  ; <p3>(* Step n+1 *) ... [@stepper.reduct ] ...
  ; <p4>(* Step m *) ... [@stepper.reduct ] ...
  ; <p5>(* Application k end *) ...
  ;     (* Application l end *) ...
  ; <p6>(* Step m *) ... [@stepper.redex ] ...<p7>
  ; visible: <p1>~<p2>, <p4>~<p5>
  ; may be the same: (p2, p3), (p3, p4), (p5, p6)
  (progn
    (let* ((p0 (point-min))
	   (p1 (stepper-find-step-redex n))
	   (p3 (stepper-find-step-reduct (1+ n)))
	   (p2 (stepper-find-app-between p1 p3))
	   (p4 (stepper-find-step-reduct m))
	   (p6 (stepper-find-step-redex m))
	   (p5 (stepper-find-app-between p4 p6))
	   (p7 (point-max)))
      (cond ((eq add-or-remove 'add)
	     (if (eq p2 p4)
		 (progn
		   (add-text-properties p0 p1 '(invisible t))
		   (add-text-properties p5 p7 '(invisible t)))
	       (progn
		 (add-text-properties p0 p1 '(invisible t))
		 (add-text-properties p2 p4 '(invisible t))
		 (add-text-properties p5 p7 '(invisible t)))))
	    ((eq add-or-remove 'remove)
	     (if (eq p2 p4)
		 (progn
		   (remove-text-properties p0 p1 '(invisible t))
		   (remove-text-properties p5 p7 '(invisible t)))
	       (progn
		 (remove-text-properties p0 p1 '(invisible t))
		 (remove-text-properties p2 p4 '(invisible t))
		 (remove-text-properties p5 p7 '(invisible t)))))
	    (not-modified)))))

(defun stepper-add-invisible-except-for (n m)
  "add invisible text properties except for nth and mth step"
  (stepper-change-text-properties 'add n m))

(defun stepper-remove-invisible (n m)
  "remove invisible text properties"
  (stepper-change-text-properties 'remove n m))

(defun find-prev-apply-end ()
  "return the greatest number of evaluated application before the current position"
  (progn
    (if (re-search-backward "(\\* Application \\([0-9]+\\) end \\*)" nil t 1)
      (string-to-int (substring (buffer-string)
                       (- (match-beginning 1) 1)
                       (- (match-end 1) 1)))
      -1)))

(defun find-prev-step ()
  "return the step number before the current position"
  (progn
    (re-search-backward "(\\* Step \\([0-9]+\\) \\*)" nil t 1)
    (string-to-int (substring (buffer-string)
                     (- (match-beginning 1) 1)
                     (- (match-end 1) 1)))))

(defun count-step ()
  "count the number of steps"
  (progn
    (goto-char (point-max))
    (find-prev-step)))

(defvar stepper-redex-n 0)
(defvar stepper-reduct-n 1)
(defvar stepper-steps 0)

(defun print-n (format-string &rest arg)
  "debugging by printf"
; (prog1 ; returns the value of the first expression
    (apply 'message format-string arg)
;   (sleep-for 0.5))
  )

;(defun stepper-start-org ()
;  "start stepping"
;  (interactive)
;  (let ((filename buffer-file-name))
;    (if (null filename)
;      (print-n "Select OCaml buffer first")
;      (if (string= filename stepper-buffer-name)
;        (print-n "Stepper is already running")
;        (if (string-match-p "\.ml$" filename)
;          (progn
;            (save-buffer)
;            (save-excursion
;              (if (get-buffer stepper-buffer-name)
;                (kill-buffer stepper-buffer-name))
;              (get-buffer-create stepper-buffer-name)
;              (set-buffer stepper-buffer-name)
;              (insert (shell-command-to-string 
;                        (concat stepper-program " " filename)))
;              (goto-char (point-min))
;              (if (null (search-forward "redex" nil t 1))
;                (progn ; no redex to reduce
;                  (print-n "No step to display")
;                  (kill-buffer stepper-buffer-name))
;                (progn
;                  (switch-to-buffer stepper-buffer-name)
;                  (goto-char (point-min))
;                  (setq stepper-redex-n 0)
;                  (setq stepper-steps (count-step))
;                  (stepper-highlight)
;                  (stepper-add-invisible-except-for stepper-redex-n)))))
;          (print-n "Select OCaml buffer first"))))))

(defun stepper-prev ()
  "display the previous step"
  (interactive)
  (if (get-buffer stepper-buffer-name)
    (if (or (< 0 stepper-redex-n) (< 1 stepper-reduct-n))
      (progn
        (set-buffer stepper-buffer-name)
        (stepper-remove-invisible stepper-redex-n stepper-reduct-n)
        (if (eq (1+ stepper-redex-n) stepper-reduct-n)
          (progn
            (setq stepper-redex-n (1- stepper-redex-n))
            (setq stepper-reduct-n (1- stepper-reduct-n))
            (stepper-highlight)
            (stepper-add-invisible-except-for stepper-redex-n stepper-reduct-n))
          (progn
            (setq stepper-redex-n (1- stepper-reduct-n))
            (stepper-highlight)
            (stepper-add-invisible-except-for stepper-redex-n stepper-reduct-n))))
      (print-n "No previous step"))
    (print-n "Start stepper first")))

(defun stepper-next ()
  "display the next step"
  (interactive)
  (if (get-buffer stepper-buffer-name)
    (if (< stepper-reduct-n stepper-steps)
      (progn
        (set-buffer stepper-buffer-name)
        (stepper-remove-invisible stepper-redex-n stepper-reduct-n)
        (setq stepper-redex-n stepper-reduct-n)
        (setq stepper-reduct-n (1+ stepper-reduct-n))
        (stepper-highlight)
        (stepper-add-invisible-except-for stepper-redex-n stepper-reduct-n))
      (print-n "No more steps"))
    (print-n "Start stepper first")))

(defun stepper-back ()
  "display the previous step skipping the steps of an application"
  (interactive)
  (if (get-buffer stepper-buffer-name)
    (if (< 0 stepper-redex-n)
      (progn
        (set-buffer stepper-buffer-name)
        ; ...
        ; (* Step m *)<p1> ... [@stepper.reduct ] ...
        ; (* Application k end *)<p2>
        ; (* Step m *)<p3> ... [@stepper.redex ] ...
        (goto-char (point-min))
        (search-forward (format "(* Step %d *)" stepper-reduct-n) nil t 1)
        (let ((p1 (point)))
          (search-forward (format "(* Step %d *)" stepper-reduct-n) nil 1 1)
          (let ((p3 (point))
                (appnum (find-prev-apply-end)))
            (goto-char (point-min))
            (if (search-forward (format "(* Application %d end *)" appnum) nil 1 1)
              (let ((p2 (point)))
                (if (and (/= -1 appnum) (< p1 p2 p3))
                  (progn
                    (stepper-remove-invisible stepper-redex-n stepper-reduct-n)
                    (if (eq stepper-redex-n appnum)
                      (progn
                        (setq stepper-redex-n (1- stepper-redex-n))
                        (setq stepper-reduct-n (1+ stepper-redex-n)))
                      (setq stepper-redex-n appnum))
                    (stepper-highlight)
                    (stepper-add-invisible-except-for stepper-redex-n stepper-reduct-n))
                  (stepper-prev)))
                (stepper-prev)))))
      (print-n "No previous step"))
    (print-n "Start stepper first")))

(defun stepper-skip ()
  "display the next step skipping the steps of an application"
  (interactive)
  (if (get-buffer stepper-buffer-name)
    (if (< stepper-reduct-n stepper-steps)
      (progn
        (set-buffer stepper-buffer-name)
        (goto-char (point-max))
        (if (search-backward (format "(* Application %d end *)" stepper-redex-n) nil t 1)
          (let ((end-n (find-prev-step)))
            (stepper-remove-invisible stepper-redex-n stepper-reduct-n)
            (if (eq stepper-reduct-n end-n)
              (progn
                (setq stepper-redex-n end-n)
                (setq stepper-reduct-n (1+ end-n)))
              (progn
                (setq stepper-reduct-n end-n)))
            (stepper-highlight)
            (stepper-add-invisible-except-for stepper-redex-n stepper-reduct-n))
          (stepper-next)))
      (print-n "No more steps"))
    (print-n "Start stepper first")))

(defun stepper-jump ()
  "jump to the nth step"
  (interactive)
  (if (get-buffer stepper-buffer-name)
    (let ((ans (read)))
      (if (and (<= 0 ans) (< ans stepper-steps))
        (progn
          (set-buffer stepper-buffer-name)
          (stepper-remove-invisible stepper-redex-n stepper-reduct-n)
          (setq stepper-redex-n ans)
          (setq stepper-reduct-n (1+ ans))
          (stepper-highlight)
          (stepper-add-invisible-except-for stepper-redex-n stepper-reduct-n))
        (print-n "Your input should be between 0 and %d" (- stepper-steps 1))))
    (print-n "Start stepper first")))

(defun stepper-quit ()
  "quit stepper"
  (interactive)
  (if (get-buffer stepper-buffer-name)
    (kill-buffer stepper-buffer-name)
    (print-n "Stepper is not running")))

(defun stepper-launch (stepper-tmp-file &optional log-dir)
  "launch stepper"
  (let ((stepper-buffer (ochadai-get-buffer-create stepper-buffer-name)))
    (if log-dir
      (let ((coding-system-for-read 'utf-8-dos))
        (call-process "script" nil stepper-buffer nil
		      "-aq" (concat log-dir stepper-buffer-name)
		      stepper-program stepper-tmp-file))
      (call-process stepper-program nil stepper-buffer nil stepper-tmp-file))
    (delete-file stepper-tmp-file)
    (switch-to-buffer stepper-buffer)
    (goto-char (point-min))
    (if (null (search-forward "redex" nil t 1))
      (progn ; no redex to reduce
        (print-n "No step to display")
        (kill-buffer stepper-buffer))
      (progn
        (switch-to-buffer stepper-buffer)
        (goto-char (point-min))
        (setq stepper-redex-n 0)
        (setq stepper-reduct-n 1)
        (setq stepper-steps (count-step))
        (stepper-highlight)
        (stepper-add-invisible-except-for stepper-redex-n stepper-reduct-n)))))

(defun stepper-start ()
  "If needed, launch type debugger.  Otherwise, launch stepper"
  (interactive)
  (let ((file-name buffer-file-name))
    (if (null file-name)
      (print-n "Select OCaml buffer first")
      (if (string= (buffer-name) stepper-buffer-name) 
        (print-n "Stepper is already running")
        (if (string-match-p "\.ml$" file-name)
          (progn
            (save-buffer)
            (ochadai-kill-buffer stepper-tmp-buffer)
            (if (< 0 (call-process stepper-remove-sharpuse nil
                                   stepper-tmp-buffer nil file-name))
              (progn ; file-name has syntax error, launch type debugger
                (ochadai-kill-buffer stepper-tmp-buffer)
                (ochadai-eval-buffer))
              (progn
                (save-excursion
                  (set-buffer stepper-tmp-buffer)
                  (write-file stepper-tmp-file)
                  (ochadai-kill-buffer stepper-tmp-buffer))
                (if (< 0 (call-process "/usr/local/bin/ocamlc" nil nil nil
                                       "-i" stepper-tmp-file))
                  (progn ; file-name has type error, launch type debugger
		    (delete-file stepper-tmp-file)
		    (ochadai-eval-buffer))
                  (if ochadai-log-interaction
		    (let ((log-dir (ochadai-make-log-dir-and-copy
				     (current-buffer))))
		      (stepper-launch stepper-tmp-file log-dir))
                    (stepper-launch stepper-tmp-file))))))
          (print-n "Select OCaml buffer first"))))))

(defun stepper-show-all ()
  "display all steps"
  (interactive)
  (progn
    (stepper-start)
    (stepper-remove-invisible stepper-redex-n stepper-reduct-n)
    (stepper-highlight)))

;(defun stepper-start ()
;  "launch stepper with type debugger"
;  (interactive)
;  (let ((file-name buffer-file-name))
;    (if (null file-name)
;      (print-n "Select OCaml buffer first")
;      (if (string= (buffer-name) stepper-buffer-name) 
;        (print-n "Stepper is already running")
;        (if (string-match-p "\.ml$" file-name)
;          (progn
;            (save-buffer)
;            (save-excursion
;              (ochadai-kill-buffer tuareg-interactive-buffer-name)
;              (let ((buf (apply #'ochadai-make-comint (current-buffer)
;                            "env" ochadai-language-level
;                            stepper-program
;                            (append (split-string ochadai-warn-error)
;                                    (list file-name)))
;;                        (if ochadai-log-interaction
;;                          (let* ((log-file (ochadai-take-log
;;                                             (current-buffer))))
;;                            (apply #'make-comint "ocaml-toplevel" "script" nil
;;                                   "-akq" "-t 0" log-file "env"
;;                                   ochadai-language-level
;;                                   stepper-program
;;                                   (append (split-string ochadai-warn-error)
;;                                           (list file-name))))
;;                          (apply #'make-comint "ocaml-toplevel" "env" nil
;;                                 ochadai-language-level
;;                                 stepper-program
;;                                 (append (split-string ochadai-warn-error)
;;                                         (list file-name))))
;                         ))
;                (display-buffer buf))))
;          (print-n "Select OCaml buffer first"))))))

(add-hook 'tuareg-mode-hook
  (lambda ()
    (easy-menu-add-item nil
      '("Tuareg" "Interactive Mode")
      ["Start Stepper" stepper-start t])
    (tool-bar-add-item "image/start" 'stepper-start 'start)
    (tool-bar-add-item "image/back" 'stepper-back 'back)
    (tool-bar-add-item "image/prev" 'stepper-prev 'prev)
    (tool-bar-add-item "image/next" 'stepper-next 'next)
    (tool-bar-add-item "image/skip" 'stepper-skip 'skip)
    (tool-bar-add-item "image/jump" 'stepper-jump 'jump)
    (tool-bar-add-item "image/quit" 'stepper-quit 'end)
    (setq initial-frame-alist
	'((top . 1) (left . 100) (width . 86) (height . 40)))
))

;(defun stepper-filter (_text)
;  "Output filter for stepper"
;  (save-excursion
;    (if (re-search-backward "(\\* Stepper\.go ends\. \\*)" nil t 1)
;      (let ((text (buffer-string)))
;        (delete-windows-on tuareg-interactive-buffer-name)
;        (with-current-buffer
;          ;(find-file stepper-buffer-name) ; これだとハイライトが出ない
;          (ochadai-get-buffer-create stepper-buffer-name)
;          ; これだと OCaml のコードに色がつかないが...
;          ;(make-indirect-buffer tuareg-interactive-buffer-name
;          ;                      stepper-buffer-name) ; 
;          ; これだと Process ocaml-toplevel finished が出る
;          (insert text)
;          (goto-char (point-min))
;          (if (null (search-forward "redex" nil t 1))
;            (progn ; no redex to reduce
;              (print-n "No step to display")
;              (kill-buffer stepper-buffer-name))
;            (progn
;              (switch-to-buffer stepper-buffer-name)
;              (goto-char (point-min))
;              (setq stepper-redex-n 0)
;              (setq stepper-steps (count-step))
;              (stepper-highlight)
;              (stepper-add-invisible-except-for stepper-redex-n)
;              )))
;      ))))

;(add-hook 'comint-output-filter-functions 'stepper-filter t)
; 最後の t は、この filter を最後につけるという意味。filter の中で
; ファイルを読み込む可能性があり、その際、ファイル読み込み時の hook を
; 実行するため、それとここでの hook が競合する。最後につけると、これが
; 最後に実行されて、その後何も実行するものがないのでエラーにならない。