;;; -*- lexical-binding: t -*-
;;; w3m-haddock.el --- Make browsing haddocks with w3m-mode better.

;; Copyright (C) 2014 Chris Done

;; Author: Chris Done <chrisdone@gmail.com>

;; This file is not part of GNU Emacs.

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

(require 'cl-lib)
(require 'haskell-mode)
(require 'haskell-font-lock)

(declare-function w3m-buffer-title "ext:w3m")
(declare-function w3m-browse-url "ext:w3m")
(defvar w3m-current-url)

(add-hook 'w3m-display-hook 'w3m-haddock-display)

;;;###autoload
(defface w3m-haddock-heading-face
  '((((class color)) :inherit highlight))
  "Face for quarantines."
  :group 'haskell)

(defcustom haskell-w3m-haddock-dirs
  '("~/.cabal/share/doc/")
  "The path to your cabal documentation dir. It should contain
directories of package-name-x.x.

You can rebind this if you're using hsenv by adding it to your
.dir-locals.el in your project root. E.g.

    ((haskell-mode . ((haskell-w3m-haddock-dirs . (\"/home/chris/Projects/foobar/.hsenv/cabal/share/doc\")))))

"
  :group 'haskell
  :type 'list)

(defvar w3m-haddock-entry-regex "^\\(\\(data\\|type\\) \\|[a-z].* :: \\)"
  "Regex to match entry headings.")

(defun haskell-w3m-open-haddock ()
  "Open a haddock page in w3m."
  (interactive)
  (let* ((entries (cl-remove-if (lambda (s) (string= s ""))
                                (apply 'append (mapcar (lambda (dir)
                                                         (split-string (shell-command-to-string (concat "ls -1 " dir))

                                                                       "\n"))
                                                       haskell-w3m-haddock-dirs))))
         (package-dir (ido-completing-read
                       "Package: "
                       entries)))
    (cond
     ((member package-dir entries)
      (unless (cl-loop for dir in haskell-w3m-haddock-dirs
                       when (w3m-haddock-find-index dir package-dir)
                       do (progn (w3m-browse-url (w3m-haddock-find-index dir package-dir)
                                                 t)
                                 (cl-return t)))
        (w3m-browse-url (concat "http://hackage.haskell.org/package/"
                                package-dir)
                        t)))
     (t
      (w3m-browse-url (concat "http://hackage.haskell.org/package/"
                              package-dir)
                      t)))))

(defun w3m-haddock-find-index (dir package)
  (let ((html-index (concat dir "/" package "/html/index.html"))
        (index (concat dir "/" package "/index.html")))
    (cond
     ((file-exists-p html-index)
      html-index)
     ((file-exists-p index)
      index))))

(defun w3m-haddock-page-p ()
  "Haddock general page?"
  (save-excursion
    (goto-char (point-max))
    (forward-line -2)
    (looking-at "[ ]*Produced by Haddock")))

(defun w3m-haddock-source-p ()
  "Haddock source page?"
  (save-excursion
    (goto-char (point-min))
    (or (looking-at "Location: https?://hackage.haskell.org/package/.*/docs/src/")
        (looking-at "Location: file://.*cabal/share/doc/.*/html/src/")
        (looking-at "Location: .*src/.*.html$"))))

(defun w3m-haddock-p ()
  "Any haddock page?"
  (or (w3m-haddock-page-p)
      (w3m-haddock-source-p)))

(defun w3m-haddock-find-tag ()
  "Find a tag by jumping to the \"All\" index and doing a
  search-forward."
  (interactive)
  (when (w3m-haddock-p)
    (let ((ident (haskell-ident-at-point)))
      (when ident
        (w3m-browse-url
         (replace-regexp-in-string "docs/.*" "docs/doc-index-All.html" w3m-current-url))
        (search-forward ident)))))

(defun w3m-haddock-display (_url)
  "To be run by w3m's display hook. This takes a normal w3m
  buffer containing hadddock documentation and reformats it to be
  more usable and look like a dedicated documentation page."
  (when (w3m-haddock-page-p)
    (save-excursion
      (goto-char (point-min))
      (let ((inhibit-read-only t))
        (delete-region (point)
                       (line-end-position))
        (w3m-haddock-next-heading)
        ;; Start formatting entries
        (while (looking-at w3m-haddock-entry-regex)
          (when (w3m-haddock-valid-heading)
            (w3m-haddock-format-heading))
          (w3m-haddock-next-heading))))
    (rename-buffer (concat "*haddock: " (w3m-buffer-title (current-buffer)) "*")))
  (when (w3m-haddock-source-p)
    (font-lock-mode -1)
    (let ((n (line-number-at-pos)))
      (save-excursion
        (goto-char (point-min))
        (forward-line 1)
        (let ((text (buffer-substring (point)
                                      (point-max)))
              (inhibit-read-only t))
          (delete-region (point)
                         (point-max))
          (insert
           (haskell-fontify-as-mode text
                                    'haskell-mode))))
      (goto-char (point-min))
      (forward-line (1- n)))))

(defun w3m-haddock-format-heading ()
  "Format a haddock entry."
  (let ((o (make-overlay (line-beginning-position)
                         (1- (save-excursion (w3m-haddock-header-end))))))
    (overlay-put o 'face 'w3m-haddock-heading-face))
  (let ((end (save-excursion
               (w3m-haddock-next-heading)
               (when (w3m-haddock-valid-heading)
                 (point)))))
    (when end
      (save-excursion
        (w3m-haddock-header-end)
        (indent-rigidly (point)
                        end
                        4)))))

(defun w3m-haddock-next-heading ()
  "Go to the next heading, or end of the buffer."
  (forward-line 1)
  (or (search-forward-regexp w3m-haddock-entry-regex nil t 1)
      (goto-char (point-max)))
  (goto-char (line-beginning-position)))

(defun w3m-haddock-valid-heading ()
  "Is this a valid heading?"
  (not (get-text-property (point) 'face)))

(defun w3m-haddock-header-end ()
  "Go to the end of the header."
  (search-forward-regexp "\n[ \n]"))

(provide 'w3m-haddock)