;;;; -*- Mode: Lisp -*-
;;;;
;;;; Interacts with the typalyze program, which aides Haskell
;;;; development.
;;;;
;;;; C-c C-a C-c   Analyze current buffer.
;;;; C-c C-a C-t   Show type of thing at point.
;;;;
;;;; Also, typalyzes buffer whenever it is saved.
;;;;
;;;; Alternatively, M-x hswatch will start a background process to
;;;; typalyze on file modification.  Requires inotify-tools.
(require 'haskell-mode)

(defun typalyze-buffer ()
  (interactive)
  (unless (ignore-errors
            (file-readable-p (hswatch-typalyze-dump buffer-file-name)))
    (ignore-errors (kill-buffer (typalyze-buffer-name)))
    (call-process "typalyze" nil (typalyze-buffer-name) nil buffer-file-name)
    (message "typalyzed")))

(defun typalyze-buffer-name ()
  "*typalyze*")

(defun typalyze-analyze-opened-file ()
  (typalyze-buffer)
  (add-hook 'after-save-hook 'typalyze-after-save nil t)
  (local-set-key (kbd "C-c C-a C-c") 'typalyze-buffer)
  (local-set-key (kbd "C-c C-a t") 'typalyze-point)
  (local-set-key (kbd "C-c C-a C-t") 'typalyze-point))

(defun typalyze-after-save ()
  (typalyze-buffer))

(add-hook 'haskell-mode-hook 'typalyze-analyze-opened-file)

(defun get-current-column ()
  (save-excursion
    (let ((a (point)))
      (move-to-column 0)
      (- a (point)))))

(defun get-eol ()
  (save-excursion
    (move-end-of-line 1)
    (point)))

(defun typalyze-point ()
  (interactive)
  (let ((row (line-number-at-pos))
        (col (get-current-column))
        (buf (current-buffer))
        entries
        (typalyze-buffer (typalyze-buffer-name)))
    (when (ignore-errors
            (file-readable-p (hswatch-typalyze-dump buffer-file-name)))
      (setq typalyze-buffer
            (find-file-noselect (hswatch-typalyze-dump buffer-file-name) t))
      (bury-buffer typalyze-buffer))
    (with-current-buffer typalyze-buffer
      (save-excursion
        (goto-char (point-min))
        (setq entries (typalyze-find-entries buf row col))))
    (when entries
      (message "%s" (cdr (first entries))))))

(defun typalyze-find-entries (buf row col)
  (let ((results nil))
    (while (not (eobp))
      (when (and (eql 0 (typalyze-compare-current-row row))
                 (eql 0 (typalyze-compare-current-col col)))
        (push (typalyze-get-entry) results))
      (typalyze-next-entry))
    (typalyze-sort-entries-by-size buf results)))

(defun typalyze-get-entry ()
  (cons (typalyze-get-current-span)
        (typalyze-get-current-type)))

(defun typalyze-sort-entries-by-size (typalyze-buf entries)
  (sort entries #'(lambda (e1 e2)
                    (< (typalyze-span-size typalyze-buf e1)
                       (typalyze-span-size typalyze-buf e2)))))

(defun typalyze-span-size (buf e)
  (destructuring-bind (((row1 . col1) . (row2 . col2)) . ty) e
    (with-current-buffer buf
      (save-excursion
        (goto-line row1)
        (move-to-column col1)
        (let ((a (point)))
          (goto-line row2)
          (move-to-column col2)
          (- (point) a))))))

(defun typalyze-next-entry ()
  (move-to-column 0)
  (forward-line 1)
  (while (looking-at " ")
    (forward-line 1)))

(defun typalyze-compare-current-row (row)
  (destructuring-bind ((row1 . col1) . (row2 . col2))
      (typalyze-get-current-span)
    (cond ((< row row1) 1)
          ((and (<= row1 row)
                (<= row row2))
           0)
          (t
           -1))))

(defun typalyze-compare-current-col (col)
  (destructuring-bind ((row1 . col1) . (row2 . col2))
      (typalyze-get-current-span)
                         
    (cond ((< col col1) 1)
          ((and (<= col1 col)
                (<= col col2))
           0)
          (t
           -1))))

(defun typalyze-get-current-span ()
  (let ((eol (get-eol)) row1 col1 row2 col2)
    (save-excursion
      (cond ((re-search-forward "^/.*:\\([0-9]*\\):\\([0-9]*\\)-\\([0-9]*\\)" eol t)
             (setq row1 (string-to-int (match-string 1)) 
                   row2 row1
                   col1 (string-to-int (match-string 2))
                   col2 (string-to-int (match-string 3))))
            ((re-search-forward "^/.*:(\\([0-9]*\\),\\([0-9]*\\))-(\\([0-9]*\\),\\([0-9]*\\))" eol t)
             (setq row1 (string-to-int (match-string 1))
                   col1 (string-to-int (match-string 2))
                   row2 (string-to-int (match-string 3))
                   col2 (string-to-int (match-string 4))))
            ((re-search-forward "^/.*:\\([0-9]*\\):\\([0-9]*\\)" eol t)
             (setq row1 (string-to-int (match-string 1))
                   col1 (string-to-int (match-string 2))
                   row2 row1
                   col2 col1))
            (t
             (error "broken"))))
    (cons (cons row1 col1)
          (cons row2 col2))))

(defun typalyze-get-current-type ()
  (save-excursion
    (forward-line 1)
    (let ((a (point)))
      (while (looking-at " ")
        (forward-line 1))
      (backward-char 1)
      (buffer-substring-no-properties (+ 2 a) (point)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HSWATCH

(defvar *hswatch-bin* "hswatch")
(defvar *hswatch-args* '("+RTS" "-N2" "-RTS"))

(defvar *hswatch-process-name* "hswatch")
(defvar *hswatch-buffer-name* "*hswatch*")

(defvar *hswatch-process* nil)
(defvar *hswatch-wdir* nil)

(defun hswatch (wdir)
  (interactive "DWatch Directory: ")
  (stop-hswatch)
  (setq *hswatch-wdir* (file-truename wdir))
  (setq *hswatch-process*
        (apply 'start-process
               *hswatch-process-name* *hswatch-buffer-name*
               *hswatch-bin* *hswatch-wdir* *hswatch-args*)))

(defun stop-hswatch ()
  (interactive)
  (when *hswatch-process*
    (delete-process *hswatch-process*)
    (ignore-errors (kill-buffer *hswatch-buffer-name*))
    (setq *hswatch-process* nil)
    (setq *hswatch-wdir* nil)))

(defun hswatch-hswdir ()
  (when *hswatch-wdir*
    (format "%s/.hswatch" *hswatch-wdir*)))

(defun hswatch-typedb ()
  (when *hswatch-wdir*
    (format "%s/.hswatch/typedb" *hswatch-wdir*)))

(defun hswatch-typalyze-dump (filename)
  (when *hswatch-wdir*
    (format "%s/.hswatch/typedb/%s.dump" *hswatch-wdir* (file-truename filename))))