dotfiles/emacs/.emacs.d/elpa/haskell-mode-20191113.2243/haskell-cabal.el

;;; haskell-cabal.el --- Support for Cabal packages -*- lexical-binding: t -*-

;; Copyright © 2007, 2008  Stefan Monnier
;;             2016 Arthur Fayzrakhmanov

;; Author: Stefan Monnier <monnier@iro.umontreal.ca>

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

;;; Commentary:

;; Todo:

;; - distinguish continued lines from indented lines.
;; - indent-line-function.
;; - outline-minor-mode.

;;; Code:

;; (defun haskell-cabal-extract-fields-from-doc ()
;;   (require 'xml)
;;   (let ((section (completing-read
;;                   "Section: "
;;                   '("general-fields" "library" "executable" "buildinfo"))))
;;     (goto-char (point-min))
;;     (search-forward (concat "<sect3 id=\"" section "\">")))
;;   (let* ((xml (xml-parse-region
;;                (progn (search-forward "<variablelist>") (match-beginning 0))
;;                (progn (search-forward "</variablelist>") (point))))
;;          (varlist (cl-remove-if-not 'consp (cl-cddar xml)))
;;          (syms (mapcar (lambda (entry) (cl-caddr (assq 'literal (assq 'term entry))))
;;                        varlist))
;;          (fields (mapcar (lambda (sym) (substring-no-properties sym 0 -1)) syms)))
;;     fields))

(require 'cl-lib)
(require 'haskell-utils)

(defcustom haskell-hasktags-path "hasktags"
  "Path to `hasktags' executable."
  :group 'haskell
  :type 'string)

(defcustom haskell-hasktags-arguments '("-e" "-x")
  "Additional arguments for `hasktags' executable.
By default these are:

-e - generate ETAGS file
-x - generate additional information in CTAGS file."
  :group 'haskell
  :type '(list string))

(defconst haskell-cabal-general-fields
  ;; Extracted with (haskell-cabal-extract-fields-from-doc "general-fields")
  '("name" "version" "cabal-version" "license" "license-file" "copyright"
    "author" "maintainer" "stability" "homepage" "package-url" "synopsis"
    "description" "category" "tested-with" "build-depends" "data-files"
    "extra-source-files" "extra-tmp-files" "import"))

(defconst haskell-cabal-library-fields
  ;; Extracted with (haskell-cabal-extract-fields-from-doc "library")
  '("exposed-modules"))

(defconst haskell-cabal-executable-fields
  ;; Extracted with (haskell-cabal-extract-fields-from-doc "executable")
  '("executable" "main-is"))

(defconst haskell-cabal-buildinfo-fields
  ;; Extracted with (haskell-cabal-extract-fields-from-doc "buildinfo")
  '("buildable" "other-modules" "hs-source-dirs" "extensions" "ghc-options"
    "ghc-prof-options" "hugs-options" "nhc-options" "includes"
    "install-includes" "include-dirs" "c-sources" "extra-libraries"
    "extra-lib-dirs" "cc-options" "ld-options" "frameworks"))

(defvar haskell-cabal-mode-syntax-table
  (let ((st (make-syntax-table)))
    ;; The comment syntax can't be described simply in syntax-table.
    ;; We could use font-lock-syntactic-keywords, but is it worth it?
    ;; (modify-syntax-entry ?- ". 12" st)
    (modify-syntax-entry ?\n ">" st)
    (modify-syntax-entry ?- "w" st)
    st))

(defvar haskell-cabal-font-lock-keywords
  ;; The comment syntax can't be described simply in syntax-table.
  ;; We could use font-lock-syntactic-keywords, but is it worth it?
  '(("^[ \t]*--.*" . font-lock-comment-face)
    ("^ *\\([^ \t:]+\\):" (1 font-lock-keyword-face))
    ("^\\(Library\\)[ \t]*\\({\\|$\\)" (1 font-lock-keyword-face))
    ("^\\(Executable\\|Test-Suite\\|Benchmark\\|Common\\)[ \t]+\\([^\n \t]*\\)"
     (1 font-lock-keyword-face) (2 font-lock-function-name-face))
    ("^\\(Flag\\)[ \t]+\\([^\n \t]*\\)"
     (1 font-lock-keyword-face) (2 font-lock-constant-face))
    ("^\\(Source-Repository\\)[ \t]+\\(head\\|this\\)"
     (1 font-lock-keyword-face) (2 font-lock-constant-face))
    ("^ *\\(if\\)[ \t]+.*\\({\\|$\\)" (1 font-lock-keyword-face))
    ("^ *\\(}[ \t]*\\)?\\(else\\)[ \t]*\\({\\|$\\)"
     (2 font-lock-keyword-face))
    ("\\<\\(?:True\\|False\\)\\>"
     (0 font-lock-constant-face))))

(defvar haskell-cabal-buffers nil
  "List of Cabal buffers.")

(defun haskell-cabal-buffers-clean (&optional buffer)
  "Refresh list of known cabal buffers.

Check each buffer in variable `haskell-cabal-buffers' and remove
it from list if one of the following conditions are hold:
+ buffer is killed;
+ buffer's mode is not derived from `haskell-cabal-mode';
+ buffer is a BUFFER (if given)."
  (let ((bufs ()))
    (dolist (buf haskell-cabal-buffers)
      (if (and (buffer-live-p buf)
               (not (eq buf buffer))
               (with-current-buffer buf (derived-mode-p 'haskell-cabal-mode)))
          (push buf bufs)))
    (setq haskell-cabal-buffers bufs)))

(defun haskell-cabal-unregister-buffer ()
  "Exclude current buffer from global list of known cabal buffers."
  (haskell-cabal-buffers-clean (current-buffer)))

;;;###autoload
(add-to-list 'auto-mode-alist '("\\.cabal\\'" . haskell-cabal-mode))

(defvar haskell-cabal-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "C-c C-s") 'haskell-cabal-subsection-arrange-lines)
    (define-key map (kbd "C-M-n") 'haskell-cabal-next-section)
    (define-key map (kbd "C-M-p") 'haskell-cabal-previous-section)
    (define-key map (kbd "M-n") 'haskell-cabal-next-subsection)
    (define-key map (kbd "M-p") 'haskell-cabal-previous-subsection)
    (define-key map (kbd "C-<down>") 'haskell-cabal-next-subsection)
    (define-key map (kbd "C-<up>") 'haskell-cabal-previous-subsection)
    (define-key map (kbd "C-c C-f") 'haskell-cabal-find-or-create-source-file)
    (define-key map (kbd "M-g l") 'haskell-cabal-goto-library-section)
    (define-key map (kbd "M-g e") 'haskell-cabal-goto-executable-section)
    (define-key map (kbd "M-g b") 'haskell-cabal-goto-benchmark-section)
    (define-key map (kbd "M-g o") 'haskell-cabal-goto-common-section)
    (define-key map (kbd "M-g t") 'haskell-cabal-goto-test-suite-section)
    map))

;;;###autoload
(define-derived-mode haskell-cabal-mode fundamental-mode "Haskell-Cabal"
  "Major mode for Cabal package description files."
  (setq-local font-lock-defaults
              '(haskell-cabal-font-lock-keywords t t nil nil))
  (add-to-list 'haskell-cabal-buffers (current-buffer))
  (add-hook 'change-major-mode-hook 'haskell-cabal-unregister-buffer nil 'local)
  (add-hook 'kill-buffer-hook 'haskell-cabal-unregister-buffer nil 'local)
  (setq-local comment-start "-- ")
  (setq-local comment-start-skip "\\(^[ \t]*\\)--[ \t]*")
  (setq-local comment-end "")
  (setq-local comment-end-skip "[ \t]*\\(\\s>\\|\n\\)")
  (setq-local indent-line-function 'haskell-cabal-indent-line)
  (setq indent-tabs-mode nil)
  )

(make-obsolete 'haskell-cabal-get-setting
               'haskell-cabal--get-field
               "March 14, 2016")
(defalias 'haskell-cabal-get-setting 'haskell-cabal--get-field
  "Try to read value of field with NAME from current buffer.
Obsolete function.  Defined for backward compatibility.  Use
`haskell-cabal--get-field' instead.")

(defun haskell-cabal--get-field (name)
  "Try to read value of field with NAME from current buffer."
  (save-excursion
    (let ((case-fold-search t))
      (goto-char (point-min))
      (when (re-search-forward
             (concat "^[ \t]*" (regexp-quote name)
                     ":[ \t]*\\(.*\\(\n[ \t]+[ \t\n].*\\)*\\)")
             nil t)
        (let ((val (match-string 1))
              (start 1))
          (when (match-end 2)             ;Multiple lines.
            ;; The documentation is not very precise about what to do about
            ;; the \n and the indentation: are they part of the value or
            ;; the encoding?  I take the point of view that \n is part of
            ;; the value (so that values can span multiple lines as well),
            ;; and that only the first char in the indentation is part of
            ;; the encoding, the rest is part of the value (otherwise, lines
            ;; in the value cannot start with spaces or tabs).
            (while (string-match "^[ \t]\\(?:\\.$\\)?" val start)
              (setq start (1+ (match-beginning 0)))
              (setq val (replace-match "" t t val))))
          val)))))


(make-obsolete 'haskell-cabal-guess-setting
               'haskell-cabal-get-field
               "March 14, 2016")
(defalias 'haskell-cabal-guess-setting 'haskell-cabal-get-field
  "Read the value of field with NAME from project's cabal file.
Obsolete function.  Defined for backward compatibility.  Use
`haskell-cabal-get-field' instead.")

;;;###autoload
(defun haskell-cabal-get-field (name)
  "Read the value of field with NAME from project's cabal file.
If there is no valid .cabal file to get the setting from (or
there is no corresponding setting with that name in the .cabal
file), then this function returns nil."
  (interactive)
  (when (and name buffer-file-name)
    (let ((cabal-file (haskell-cabal-find-file)))
      (when (and cabal-file (file-readable-p cabal-file))
        (with-temp-buffer
          (insert-file-contents cabal-file)
          (haskell-cabal--get-field name))))))

;;;###autoload
(defun haskell-cabal-get-dir (&optional use-defaults)
  "Get the Cabal dir for a new project. Various ways of figuring this out,
   and indeed just prompting the user. Do them all."
  (let* ((file (haskell-cabal-find-file))
         (dir (if file (file-name-directory file) default-directory)))
    (if use-defaults
        dir
        (haskell-utils-read-directory-name
         (format "Cabal dir%s: " (if file (format " (guessed from %s)" (file-relative-name file)) ""))
         dir))))

(defun haskell-cabal-compute-checksum (dir)
  "Compute MD5 checksum of package description file in DIR.
Return nil if no Cabal description file could be located via
`haskell-cabal-find-pkg-desc'."
  (let ((cabal-file (haskell-cabal-find-pkg-desc dir)))
    (when cabal-file
      (with-temp-buffer
        (insert-file-contents cabal-file)
        (md5 (buffer-string))))))

(defun haskell-cabal-find-file (&optional dir)
  "Search for package description file upwards starting from DIR.
If DIR is nil, `default-directory' is used as starting point for
directory traversal.  Upward traversal is aborted if file owner
changes.  Uses `haskell-cabal-find-pkg-desc' internally."
  (let ((use-dir (or dir default-directory)))
    (while (and use-dir (not (file-directory-p use-dir)))
      (setq use-dir (file-name-directory (directory-file-name use-dir))))
    (when use-dir
      (catch 'found
        (let ((user (nth 2 (file-attributes use-dir)))
              ;; Abbreviate, so as to stop when we cross ~/.
              (root (abbreviate-file-name use-dir)))
          ;; traverse current dir up to root as long as file owner doesn't change
          (while (and root (equal user (nth 2 (file-attributes root))))
            (let ((cabal-file (haskell-cabal-find-pkg-desc root)))
              (when cabal-file
                (throw 'found cabal-file)))

            (let ((proot (file-name-directory (directory-file-name root))))
              (if (equal proot root) ;; fix-point reached?
                  (throw 'found nil)
                (setq root proot))))
          nil)))))

(defun haskell-cabal-find-pkg-desc (dir &optional allow-multiple)
  "Find a package description file in the directory DIR.
Returns nil if none or multiple \".cabal\" files were found.  If
ALLOW-MULTIPLE is non nil, in case of multiple \".cabal\" files,
a list is returned instead of failing with a nil result."
  ;; This is basically a port of Cabal's
  ;; Distribution.Simple.Utils.findPackageDesc function
  ;;  http://hackage.haskell.org/packages/archive/Cabal/1.16.0.3/doc/html/Distribution-Simple-Utils.html
  ;; but without the exception throwing.
  (let* ((cabal-files
          (cl-remove-if 'file-directory-p
                        (cl-remove-if-not 'file-exists-p
                                          (directory-files dir t ".\\.cabal\\'")))))
    (cond
     ((= (length cabal-files) 1) (car cabal-files)) ;; exactly one candidate found
     (allow-multiple cabal-files) ;; pass-thru multiple candidates
     (t nil))))

(defun haskell-cabal-find-dir (&optional dir)
  "Like `haskell-cabal-find-file' but returns directory instead.
See `haskell-cabal-find-file' for meaning of DIR argument."
  (let ((cabal-file (haskell-cabal-find-file dir)))
    (when cabal-file
      (file-name-directory cabal-file))))

;;;###autoload
(defun haskell-cabal-visit-file (other-window)
  "Locate and visit package description file for file visited by current buffer.
This uses `haskell-cabal-find-file' to locate the closest
\".cabal\" file and open it.  This command assumes a common Cabal
project structure where the \".cabal\" file is in the top-folder
of the project, and all files related to the project are in or
below the top-folder.  If called with non-nil prefix argument
OTHER-WINDOW use `find-file-other-window'."
  (interactive "P")
  ;; Note: We aren't allowed to rely on haskell-session here (which,
  ;; in pathological cases, can have a different .cabal file
  ;; associated with the current buffer)
  (if buffer-file-name
      (let ((cabal-file (haskell-cabal-find-file (file-name-directory buffer-file-name))))
        (if cabal-file
            (if other-window
                (find-file-other-window cabal-file)
              (find-file cabal-file))
          (error "Could not locate \".cabal\" file for %S" buffer-file-name)))
    (error "Cannot locate \".cabal\" file for buffers not visiting any file")))

(defvar haskell-cabal-commands
  '("install"
    "update"
    "list"
    "info"
    "upgrade"
    "fetch"
    "unpack"
    "check"
    "sdist"
    "upload"
    "report"
    "init"
    "configure"
    "build"
    "copy"
    "haddock"
    "clean"
    "hscolour"
    "register"
    "test"
    "help"
    "run"))

;;;###autoload
(defgroup haskell-cabal nil
  "Haskell cabal files"
  :group 'haskell
)

(defconst haskell-cabal-section-header-regexp "^[[:alnum:]]" )
(defconst haskell-cabal-subsection-header-regexp "^[ \t]*[[:alnum:]]\\w*:")
(defconst haskell-cabal-comment-regexp "^[ \t]*--")
(defconst haskell-cabal-empty-regexp "^[ \t]*$")
(defconst haskell-cabal-conditional-regexp "^[ \t]*\\(\\if\\|else\\|}\\)")

(defun haskell-cabal-classify-line ()
  "Classify the current line into 'section-header 'subsection-header 'section-data 'comment and 'empty '"
  (save-excursion
    (beginning-of-line)
    (cond
     ((looking-at haskell-cabal-subsection-header-regexp ) 'subsection-header)
     ((looking-at haskell-cabal-section-header-regexp) 'section-header)
     ((looking-at haskell-cabal-comment-regexp) 'comment)
     ((looking-at haskell-cabal-empty-regexp ) 'empty)
     ((looking-at haskell-cabal-conditional-regexp ) 'conditional)
     (t 'section-data))))

(defun haskell-cabal-header-p ()
  "Is the current line a section or subsection header?"
  (cl-case (haskell-cabal-classify-line)
    ((section-header subsection-header) t)))

(defun haskell-cabal-section-header-p ()
  "Is the current line a section or subsection header?"
  (cl-case (haskell-cabal-classify-line)
    ((section-header) t)))


(defun haskell-cabal-section-beginning ()
  "Find the beginning of the current section"
  (save-excursion
    (while (not (or (bobp) (haskell-cabal-section-header-p)))
      (forward-line -1))
    (point)))

(defun haskell-cabal-beginning-of-section ()
  "go to the beginning of the section"
  (interactive)
  (goto-char (haskell-cabal-section-beginning))
)

(defun haskell-cabal-section-end ()
  "Find the end of the current section"
  (interactive)
  (save-excursion
    (if (re-search-forward "\n\\([ \t]*\n\\)*[[:alnum:]]" nil t)
        (match-beginning 0)
        (point-max))))

(defun haskell-cabal-end-of-section ()
  "go to the end of the section"
  (interactive)
  (goto-char (haskell-cabal-section-end)))

(defun haskell-cabal-next-section ()
  "Go to the next section"
  (interactive)
  (when (haskell-cabal-section-header-p) (forward-line))
  (while (not (or (eobp) (haskell-cabal-section-header-p)))
    (forward-line)))

(defun haskell-cabal-previous-section ()
  "Go to the next section"
  (interactive)
  (when (haskell-cabal-section-header-p) (forward-line -1))
  (while (not (or (bobp) (haskell-cabal-section-header-p)))
    (forward-line -1)))

(defun haskell-cabal-subsection-end ()
  "find the end of the current subsection"
  (save-excursion
    (haskell-cabal-beginning-of-subsection)
    (forward-line)
    (while (and (not (eobp))
                (member (haskell-cabal-classify-line) '(empty section-data)))
      (forward-line))
    (unless (eobp) (forward-line -1))
    (while (and (equal (haskell-cabal-classify-line) 'empty)
                (not (bobp)))
      (forward-line -1))
    (end-of-line)
    (point)))

(defun haskell-cabal-end-of-subsection ()
  "go to the end of the current subsection"
  (interactive)
  (goto-char (haskell-cabal-subsection-end)))

(defun haskell-cabal-section ()
  "Get the name and data of the associated section"
  (save-excursion
    (haskell-cabal-beginning-of-section)
    (when (and (haskell-cabal-section-header-p)
               (looking-at "^\\(\\w+\\)[ \t]*\\(.*\\)$"))
      (list :name (match-string-no-properties 1)
            :value (match-string-no-properties 2)
            :beginning (match-beginning 0)
            :end (haskell-cabal-section-end)))))


(defun haskell-cabal-subsection ()
  "Get the name and bounds of of the current subsection"
  (save-excursion
    (haskell-cabal-beginning-of-subsection)
    (when (looking-at "\\([ \t]*\\(\\w*\\):\\)[ \t]*")
      (list :name (match-string-no-properties 2)
            :beginning (match-end 0)
            :end (save-match-data (haskell-cabal-subsection-end))
            :data-start-column (save-excursion (goto-char (match-end 0))
                                               (current-column))
            :data-indent-column (save-excursion (goto-char (match-end 0))
                                                (when (looking-at "\n  +\\(\\w*\\)") (goto-char (match-beginning 1)))
                                                (current-column)
                                                )))))


(defun haskell-cabal-section-name (section)
  (plist-get section :name))

(defun haskell-cabal-section-value (section)
  (plist-get section :value))

(defun haskell-cabal-section-start (section)
  (plist-get section :beginning))

(defun haskell-cabal-section-data-start-column (section)
  (plist-get section :data-start-column))

(defun haskell-cabal-section-data-indent-column (section)
  (plist-get section :data-indent-column))

(defun haskell-cabal-map-component-type (component-type)
  "Map from cabal file COMPONENT-TYPE to build command component-type."
  (let ((component-type (downcase component-type)))
    (cond ((equal component-type "executable") "exe")
          ((equal component-type "test-suite") "test")
          ((equal component-type "benchmark")  "bench"))))

(defun haskell-cabal-enum-targets (&optional process-type)
  "Enumerate .cabal targets. PROCESS-TYPE determines the format of the returned target."
  (let ((cabal-file (haskell-cabal-find-file))
        (process-type (if process-type process-type 'ghci)))
    (when (and cabal-file (file-readable-p cabal-file))
      (with-temp-buffer
        (insert-file-contents cabal-file)
        (haskell-cabal-mode)
        (goto-char (point-min))
        (let ((matches)
              (package-name (haskell-cabal--get-field "name")))
          (haskell-cabal-next-section)
          (while (not (eobp))
            (if (haskell-cabal-source-section-p (haskell-cabal-section))
                (let* ((section (haskell-cabal-section))
                       (component-type (haskell-cabal-section-name section))
                       (val (car (split-string
                                  (haskell-cabal-section-value section)))))
                  (if (equal (downcase component-type) "library")
                      (let ((lib-target (if (eq 'stack-ghci process-type)
                                            (concat package-name ":lib")
                                          (concat "lib:" package-name))))
                        (push lib-target matches))
                    (push (concat  (when (eq 'stack-ghci process-type)
                                     (concat package-name ":"))
                                   (haskell-cabal-map-component-type component-type)
                                   ":"
                                   val)
                          matches))))
            (haskell-cabal-next-section))
          (reverse matches))))))

(defmacro haskell-cabal-with-subsection (subsection replace &rest funs)
  "Copy subsection data into a temporary buffer, save indentation
and execute FORMS

If REPLACE is non-nil the subsection data is replaced with the
resulting buffer-content"
  (let ((section (make-symbol "section"))
        (beg (make-symbol "beg"))
        (end (make-symbol "end"))
        (start-col (make-symbol "start-col"))
        (section-data (make-symbol "section-data")))
    `(let* ((,section ,subsection)
            (,beg (plist-get ,section :beginning))
            (,end (plist-get ,section :end))
            (,start-col (plist-get ,section :data-start-column))
            (,section-data (buffer-substring ,beg ,end)))
       (save-excursion
         (prog1
             (with-temp-buffer
               (setq indent-tabs-mode nil)
               (indent-to ,start-col)
               (insert ,section-data)
               (goto-char (point-min))
               (prog1
                   (progn (haskell-cabal-save-indentation ,@funs))
                 (goto-char (point-min))
                 (when (looking-at (format "[ ]\\{0,%d\\}" (1+ ,start-col)))
                     (replace-match ""))

                 (setq ,section-data (buffer-substring (point-min) (point-max)))))
           ,@(when replace
               `((delete-region ,beg ,end)
                 (goto-char ,beg)
                 (insert ,section-data))))))))

(defmacro haskell-cabal-each-line (&rest fun)
  "Execute FORMS on each line"
  `(save-excursion
     (while (< (point) (point-max))
       ,@fun
       (forward-line))))

(defun haskell-cabal-chomp-line ()
  "Remove leading and trailing whitespaces from current line"
  (beginning-of-line)
  (when (looking-at "^[ \t]*\\([^ \t]\\|\\(?:[^ \t].*[^ \t]\\)\\)[ \t]*$")
    (replace-match (match-string 1) nil t)
    t))


(defun haskell-cabal-min-indentation (&optional beg end)
  "Compute largest common whitespace prefix of each line in between BEG and END"
  (save-excursion
    (goto-char (or beg (point-min)))
    (let ((min-indent nil))
      (while (< (point) (or end (point-max)))
        (let ((indent (current-indentation)))
          (if (and (not (haskell-cabal-ignore-line-p))
                   (or (not min-indent)
                       (< indent min-indent)))
              (setq min-indent indent)))
        (forward-line))
      min-indent)))

(defun haskell-cabal-ignore-line-p ()
  "Does line only contain whitespaces and comments?"
  (save-excursion
    (beginning-of-line)
    (looking-at "^[ \t]*\\(?:--.*\\)?$")))

(defun haskell-cabal-kill-indentation ()
  "Remove longest common whitespace prefix from each line"
  (goto-char (point-min))
  (let ((indent (haskell-cabal-min-indentation)))
    (haskell-cabal-each-line (unless (haskell-cabal-ignore-line-p)
                               (delete-char indent)) )
    indent))

(defun haskell-cabal-add-indentation (indent)
  (goto-char (point-min))
  (haskell-cabal-each-line
   (unless (haskell-cabal-ignore-line-p)
     (indent-to indent))))


(defmacro haskell-cabal-save-indentation (&rest funs)
  "Strip indentation from each line, execute FORMS and reinstate indentation
   so that the indentation of the FIRST LINE matches"
  (let ((old-l1-indent (make-symbol "new-l1-indent"))
        (new-l1-indent (make-symbol "old-l1-indent")))
    `(let ( (,old-l1-indent (save-excursion
                              (goto-char (point-min))
                              (current-indentation))))
       (unwind-protect
           (progn
             (haskell-cabal-kill-indentation)
             ,@funs)
         (progn
           (goto-char (point-min))
           (let ((,new-l1-indent (current-indentation)))
             (haskell-cabal-add-indentation (- ,old-l1-indent
                                           ,new-l1-indent))))))))

(defun haskell-cabal-comma-separatorp (pos)
  "Return non-nil when the char at POS is a comma separator.
Characters that are not a comma, or commas inside a commment or
string, are not comma separators."
  (when (eq (char-after pos) ?,)
    (let ((ss (syntax-ppss pos)))
      (not
       (or
        ;; inside a string
        (nth 3 ss)
        ;; inside a comment
        (nth 4 ss))))))

(defun haskell-cabal-strip-list-and-detect-style ()
  "Strip commas from a comma-separated list.
Detect and return the comma style.  The possible options are:

before: a comma at the start of each line (except the first), e.g.
    Foo
  , Bar

after: a comma at the end of each line (except the last), e.g.
    Foo,
    Bar

single: everything on a single line, but comma-separated, e.g.
    Foo, Bar

nil: no commas, e.g.
    Foo Bar

If the styles are mixed, the position of the first comma
determines the style. If there is only one element then `after'
style is assumed."
  (let (comma-style)
    ;; split list items on single line
    (goto-char (point-min))
    (while (re-search-forward
            "\\([^ \t,\n]\\)[ \t]*\\(,\\)[ \t]*\\([^ \t,\n]\\)" nil t)
      (when (haskell-cabal-comma-separatorp (match-beginning 2))
        (setq comma-style 'single)
        (replace-match "\\1\n\\3" nil nil)))
    ;; remove commas before
    (goto-char (point-min))
    (while (re-search-forward "^\\([ \t]*\\),\\([ \t]*\\)" nil t)
      (setq comma-style 'before)
      (replace-match "" nil nil))
    ;; remove trailing commas
    (goto-char (point-min))
    (while (re-search-forward ",[ \t]*$" nil t)
      (unless (eq comma-style 'before)
        (setq comma-style 'after))
      (replace-match "" nil nil))

    ;; if there is just one line then set default as 'after
    (unless comma-style
      (goto-char (point-min))
      (forward-line)
      (when (eobp)
        (setq comma-style 'after)))
    (goto-char (point-min))

    (haskell-cabal-each-line (haskell-cabal-chomp-line))
    comma-style))

(defun haskell-cabal-listify (comma-style)
  "Add commas so that the buffer contains a comma-separated list.
Respect the COMMA-STYLE, see
`haskell-cabal-strip-list-and-detect-style' for the possible
styles."
  (cl-case comma-style
    ('before
     (goto-char (point-min))
     (while (haskell-cabal-ignore-line-p) (forward-line))
     (indent-to 2)
     (forward-line)
     (haskell-cabal-each-line
      (unless (haskell-cabal-ignore-line-p)
        (insert ", "))))
    ('after
     (goto-char (point-max))
     (while (equal 0 (forward-line -1))
       (unless (haskell-cabal-ignore-line-p)
         (end-of-line)
         (insert ",")
         (beginning-of-line))))
    ('single
     (goto-char (point-min))
     (while (not (eobp))
       (end-of-line)
       (unless (eobp)
         (insert ", ")
         (delete-char 1)
         (just-one-space))))))

(defmacro haskell-cabal-with-cs-list (&rest funs)
  "Format the buffer so that each line contains a list element.
Respect the comma style."
  (let ((comma-style (make-symbol "comma-style")))
    `(let ((,comma-style
            (save-excursion
              (haskell-cabal-strip-list-and-detect-style))))
       (unwind-protect (progn ,@funs)
         (haskell-cabal-listify ,comma-style)))))


(defun haskell-cabal-sort-lines-key-fun ()
  (when (looking-at "[ \t]*--[ \t,]*")
    (goto-char (match-end 0)))
  nil)

(defmacro haskell-cabal-save-position (&rest forms)
  "Save position as mark, execute FORMs and go back to mark"
  `(prog2
       (haskell-cabal-mark)
       (progn ,@forms)
     (haskell-cabal-goto-mark)
     (haskell-cabal-remove-mark)))

(defun haskell-cabal-sort-lines-depends-compare (key1 key2)
  (let* ((key1str (buffer-substring (car key1) (cdr key1)))
         (key2str (buffer-substring (car key2) (cdr key2)))
         (base-regex "^[ \t]*base\\($\\|[^[:alnum:]-]\\)"))
    (cond
     ((string-match base-regex key1str) t)
     ((string-match base-regex key2str) nil)
     (t (string< key1str key2str)))))

(defun haskell-cabal-subsection-arrange-lines ()
  "Sort lines of current subsection"
  (interactive)
  (haskell-cabal-save-position
   (let* ((subsection (haskell-cabal-section-name (haskell-cabal-subsection)))
          (compare-lines (if (string= (downcase subsection) "build-depends")
                            'haskell-cabal-sort-lines-depends-compare
                          nil)))
     (haskell-cabal-with-subsection
      (haskell-cabal-subsection) t
      (haskell-cabal-with-cs-list
       (sort-subr nil 'forward-line 'end-of-line
                  'haskell-cabal-sort-lines-key-fun
                  'end-of-line
                  compare-lines
                  ))))))

(defun haskell-cabal-subsection-beginning ()
  "find the beginning of the current subsection"
  (save-excursion
    (while (and (not (bobp))
                (not (haskell-cabal-header-p)))
      (forward-line -1))
    (back-to-indentation)
    (point)))

(defun haskell-cabal-beginning-of-subsection ()
  "go to the beginning of the current subsection"
  (interactive)
  (goto-char (haskell-cabal-subsection-beginning)))

(defun haskell-cabal-next-subsection ()
  "go to the next subsection"
  (interactive)
  (if (haskell-cabal-header-p) (forward-line))
  (while (and (not (eobp))
              (not (haskell-cabal-header-p)))
    (forward-line))
  (haskell-cabal-forward-to-line-entry))

(defun haskell-cabal-previous-subsection ()
  "go to the previous subsection"
  (interactive)
  (if (haskell-cabal-header-p) (forward-line -1))
  (while (and (not (bobp))
              (not (haskell-cabal-header-p)))
    (forward-line -1))
  (haskell-cabal-forward-to-line-entry)
  )


(defun haskell-cabal-find-subsection-by (section pred)
  "Find subsection with name NAME"
  (save-excursion
    (when section (goto-char (haskell-cabal-section-start section)))
    (let* ((end (if section (haskell-cabal-section-end) (point-max)))
           (found nil))
      (while (and (< (point) end)
                  (not found))
        (let ((subsection (haskell-cabal-subsection)))
          (when (and subsection (funcall pred subsection))
            (setq found subsection)))
        (haskell-cabal-next-subsection))
      found)))

(defun haskell-cabal-find-subsection (section name)
  "Find subsection with name NAME"
  (let ((downcase-name (downcase name)))
    (haskell-cabal-find-subsection-by
     section
     `(lambda (subsection)
        (string= (downcase (haskell-cabal-section-name subsection))
                 ,downcase-name)))))

(defun haskell-cabal-goto-subsection (name)
  (let ((subsection (haskell-cabal-find-subsection (haskell-cabal-section) name)))
    (when subsection
      (goto-char (haskell-cabal-section-start subsection)))))

(defun haskell-cabal-goto-exposed-modules ()
  (interactive)
  (haskell-cabal-goto-subsection "exposed-modules"))

(defun haskell-cabal-subsection-entry-list (section name)
  "Get the data of a subsection as a list"
  (let ((subsection (haskell-cabal-find-subsection section name)))
    (when subsection
      (haskell-cabal-with-subsection
       subsection nil
       (haskell-cabal-with-cs-list
        (delete-matching-lines
         (format "\\(?:%s\\)\\|\\(?:%s\\)"
                 haskell-cabal-comment-regexp
                 haskell-cabal-empty-regexp)
         (point-min) (point-max))
        (split-string (buffer-substring-no-properties (point-min) (point-max))
                      "\n" t))))))

(defun haskell-cabal-remove-mark ()
  (remove-list-of-text-properties (point-min) (point-max)
                                  '(haskell-cabal-marker)))


(defun haskell-cabal-mark ()
  "Mark the current position with the text property haskell-cabal-marker"
  (haskell-cabal-remove-mark)
  (put-text-property (line-beginning-position) (line-end-position)
                     'haskell-cabal-marker 'marked-line)
  (put-text-property (point) (1+ (point))
                     'haskell-cabal-marker 'marked))


(defun haskell-cabal-goto-mark ()
  "Go to marked line"
  (let ((marked-pos (text-property-any (point-min) (point-max)
                                       'haskell-cabal-marker
                                       'marked))
        (marked-line (text-property-any (point-min) (point-max)
                                       'haskell-cabal-marker
                                       'marked-line) )
        )
    (cond (marked-pos (goto-char marked-pos))
          (marked-line (goto-char marked-line)))))

(defmacro haskell-cabal-with-subsection-line (replace &rest forms)
  "Mark line, copy subsection data into a temporary buffer, save indentation
and execute FORMS at the marked line.

If REPLACE is non-nil the subsection data is replaced with the
resulting buffer-content.  Unmark line at the end."
  `(progn
     (haskell-cabal-mark)
     (unwind-protect
         (haskell-cabal-with-subsection (haskell-cabal-subsection) ,replace
          (haskell-cabal-goto-mark)
          ,@forms)
       (haskell-cabal-remove-mark))))


(defun haskell-cabal-get-line-content ()
  (haskell-cabal-with-subsection-line
   nil
   (haskell-cabal-with-cs-list
    (haskell-cabal-goto-mark)
    (buffer-substring-no-properties (line-beginning-position)
                                    (line-end-position)))))

(defun haskell-cabal-module-to-filename (module)
  (concat (replace-regexp-in-string "[.]" "/" module ) ".hs"))

(defconst haskell-cabal-module-sections '("exposed-modules" "other-modules")
  "List of sections that contain module names"
)

(defconst haskell-cabal-file-sections
  '("main-is" "c-sources" "data-files" "extra-source-files"
    "extra-doc-files" "extra-tmp-files" )
  "List of subsections that contain filenames"
  )

(defconst haskell-cabal-source-bearing-sections
  '("library" "executable" "test-suite" "benchmark"))

(defun haskell-cabal-source-section-p (section)
  (not (not (member (downcase (haskell-cabal-section-name section))
                    haskell-cabal-source-bearing-sections))))

(defun haskell-cabal-line-filename ()
  "Expand filename in current line according to the subsection type

Module names in exposed-modules and other-modules are expanded by replacing each dot (.) in the module name with a foward slash (/) and appending \".hs\"

Example: Foo.Bar.Quux ==> Foo/Bar/Quux.hs

Source names from main-is and c-sources sections are left untouched

"
  (let ((entry (haskell-cabal-get-line-content))
        (subsection (downcase (haskell-cabal-section-name
                               (haskell-cabal-subsection)))))
    (cond ((member subsection haskell-cabal-module-sections)
           (haskell-cabal-module-to-filename entry))
          ((member subsection haskell-cabal-file-sections) entry))))

(defun haskell-cabal-join-paths (&rest args)
  "Crude hack to replace f-join"
  (mapconcat 'identity args "/")
)

(defun haskell-cabal-find-or-create-source-file ()
  "Open the source file this line refers to."
  (interactive)
  (let* ((src-dirs (append (haskell-cabal-subsection-entry-list
                            (haskell-cabal-section) "hs-source-dirs")
                           '("")))
         (base-dir (file-name-directory (buffer-file-name)))
         (filename (haskell-cabal-line-filename)))
    (when filename
      (let ((candidates
             (delq nil (mapcar
                        (lambda (dir)
                          (let ((file (haskell-cabal-join-paths base-dir
                                                                dir
                                                                filename)))
                            (when (and (file-readable-p file)
                                       (not (file-directory-p file)))
                              file)))
                        src-dirs))))
        (if (null candidates)
            (unwind-protect
                (progn
                  (haskell-mode-toggle-interactive-prompt-state)
                  (let* ((src-dir
                          (haskell-cabal-join-paths base-dir
                                                    (or (car src-dirs) "")))
                         (newfile (haskell-cabal-join-paths src-dir filename))
                         (do-create-p (y-or-n-p (format "Create file %s ?" newfile))))
                    (when do-create-p
                      (find-file-other-window newfile ))))
              (haskell-mode-toggle-interactive-prompt-state t))
          (find-file-other-window (car candidates)))))))


(defun haskell-cabal-find-section-type (type &optional wrap)
  (save-excursion
    (haskell-cabal-next-section)
    (while
        (not
         (or
          (eobp)
          (string=
           (downcase type)
           (downcase (haskell-cabal-section-name (haskell-cabal-section))))))
      (haskell-cabal-next-section))
    (if (eobp)
      (if wrap (progn
                 (goto-char (point-min))
                 (haskell-cabal-find-section-type type nil) )
        nil)
      (point))))

(defun haskell-cabal-goto-section-type (type)
  (let ((section (haskell-cabal-find-section-type type t)))
    (if section (goto-char section)
      (message "No %s section found" type))))

(defun haskell-cabal-goto-library-section ()
  (interactive)
  (haskell-cabal-goto-section-type "library"))

(defun haskell-cabal-goto-test-suite-section ()
  (interactive)
  (haskell-cabal-goto-section-type "test-suite"))

(defun haskell-cabal-goto-executable-section ()
  (interactive)
  (haskell-cabal-goto-section-type "executable"))

(defun haskell-cabal-goto-benchmark-section ()
  (interactive)
  (haskell-cabal-goto-section-type "benchmark"))

(defun haskell-cabal-goto-common-section ()
  (interactive)
  (haskell-cabal-goto-section-type "common"))


(defun haskell-cabal-line-entry-column ()
  "Column at which the line entry starts"
  (save-excursion
    (cl-case (haskell-cabal-classify-line)
      (section-data (beginning-of-line)
                    (when (looking-at "[ ]*\\(?:,[ ]*\\)?")
                      (goto-char (match-end 0))
                      (current-column)))
      (subsection-header
       (haskell-cabal-section-data-start-column (haskell-cabal-subsection))))))

(defun haskell-cabal-forward-to-line-entry ()
  "go forward to the beginning of the line entry (but never move backwards)"
  (let ((col (haskell-cabal-line-entry-column)))
    (when (and col (< (current-column) col))
      (beginning-of-line)
      (forward-char col))))

(defun haskell-cabal-indent-line ()
  "Indent current line according to subsection"
  (interactive)
  (cl-case (haskell-cabal-classify-line)
    (section-data
     (save-excursion
       (let ((indent (haskell-cabal-section-data-indent-column
                      (haskell-cabal-subsection))))
         (indent-line-to indent)
         (beginning-of-line)
         (when (looking-at "[ ]*\\([ ]\\{2\\},[ ]*\\)")
           (replace-match ", " t t nil 1)))))
    (empty
     (indent-relative)))
  (haskell-cabal-forward-to-line-entry))

(defun haskell-cabal-map-sections (fun)
  "Execute fun over each section, collecting the result"
  (save-excursion
    (goto-char (point-min))
    (let ((results nil))
        (while (not (eobp))
          (let* ((section (haskell-cabal-section))
                 (result (and section (funcall fun (haskell-cabal-section)))))
            (when section (setq results (cons result results))))
          (haskell-cabal-next-section))
        (nreverse results))))

(defun haskell-cabal-section-add-build-dependency (dependency &optional sort sec)
  "Add a build dependency to the build-depends section"
  (let* ((section (or sec (haskell-cabal-section)))
         (subsection (and section
                          (haskell-cabal-find-subsection section "build-depends"))))
    (when subsection
      (haskell-cabal-with-subsection
       subsection t
       (haskell-cabal-with-cs-list
        (insert dependency)
        (insert "\n")
        (when sort
          (goto-char (point-min))
          (sort-subr nil 'forward-line 'end-of-line
                     'haskell-cabal-sort-lines-key-fun)))))))

(defun haskell-cabal-add-build-dependency (dependency &optional sort silent)
  "Add the given DEPENDENCY to every section in cabal file.
If SORT argument is given sort dependencies in section after update.
Pass SILENT argument to update all sections without asking user."
  (haskell-cabal-map-sections
   (lambda (section)
     (when (haskell-cabal-source-section-p section)
       (unwind-protect
           (progn
             (when
                 (or silent
                     (y-or-n-p (format "Add dependency %s to %s section %s?"
                                       dependency
                                       (haskell-cabal-section-name section)
                                       (haskell-cabal-section-value section))))
               (haskell-cabal-section-add-build-dependency dependency
                                                           sort
                                                           section))
             nil)
         (haskell-mode-toggle-interactive-prompt-state t))))))

(defun haskell-cabal-add-dependency
    (package &optional version no-prompt sort silent)
  "Add PACKAGE to the cabal file.
If VERSION is non-nil it will be appended as a minimum version.
If NO-PROMPT is nil the minimum package version is read from the
minibuffer.  When SORT is non-nil the package entries are sorted
afterwards.  If SILENT is non-nil the user is prompted for each
source-section."
  (interactive
   (list (read-from-minibuffer "Package entry: ") nil t t nil))
  (haskell-mode-toggle-interactive-prompt-state)
  (unwind-protect
      (save-window-excursion
        (find-file-other-window (haskell-cabal-find-file))
        (let ((entry (if no-prompt package
                       (read-from-minibuffer
                        "Package entry: "
                        (concat package
                                (if version (concat " >= " version) ""))))))
          (haskell-cabal-add-build-dependency entry sort silent)
          (when (or silent (y-or-n-p "Save cabal file? "))
            (save-buffer))))
    ;; unwind
    (haskell-mode-toggle-interactive-prompt-state t)))


(defun haskell-cabal--find-tags-dir ()
  "Return a directory where TAGS file will be generated.
Tries to find cabal file first and if succeeds uses its location.
If cabal file not found uses current file directory.  If current
buffer not visiting a file returns nil."
  (or (haskell-cabal-find-dir)
      (when buffer-file-name
        (file-name-directory buffer-file-name))))

(defun haskell-cabal--compose-hasktags-command (dir)
  "Prepare command to execute `hasktags` command in DIR folder.

To customise the command executed, see `haskell-hasktags-path'
and `haskell-hasktags-arguments'.

This function takes into account the user's operating system: in case
of Windows it generates a simple command, relying on Hasktags
itself to find source files:

hasktags --output=DIR\TAGS -x -e DIR

In other cases it uses `find` command to find all source files
recursively avoiding visiting unnecessary heavy directories like
.git, .svn, _darcs and build directories created by
cabal-install, stack, etc and passes list of found files to Hasktags."
  (if (eq system-type 'windows-nt)
      (format "%s --output=%s %s %s"
              haskell-hasktags-path
              (shell-quote-argument (expand-file-name "TAGS" dir))
              (mapconcat #'identity haskell-hasktags-arguments " ")
              (shell-quote-argument dir))
    (format "cd %s && %s | %s"
            (shell-quote-argument dir)
            (concat "find . "
                    "-type d \\( "
                    "-name .git "
                    "-o -name .svn "
                    "-o -name _darcs "
                    "-o -name .stack-work "
                    "-o -name dist "
                    "-o -name dist-newstyle "
                    "-o -name .cabal-sandbox "
                    "\\) -prune "
                    "-o -type f \\( "
                    "-name '*.hs' "
                    "-or -name '*.lhs' "
                    "-or -name '*.hsc' "
                    "\\) -not \\( "
                    "-name '#*' "
                    "-or -name '.*' "
                    "\\) -print0")
            (format "xargs -0 %s %s"
                    (shell-quote-argument haskell-hasktags-path)
                    (mapconcat #'identity haskell-hasktags-arguments " ")))))

(provide 'haskell-cabal)
;;; haskell-cabal.el ends here