;;;; -*- 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.

(require 'haskell-mode)

(defun typalyze-buffer ()
  (interactive)
  (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)
    (with-current-buffer (typalyze-buffer-name)
      (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)))))