diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +5.2.4: + + * Pretty print imports + * Fix pretty print for string literals for `DataKinds` + * Support `--validate` option for checking the format without reformatting + * Support parse `#include`, `#error`, `#warning` directives + * Support read `LANGUAGE` pragma and parse the declared extensions from source + * Treat `TypeApplications` extension as 'badExtensions' due to the `@` symbol + * Improve pretty print for unboxed tuples + * Fix many issues related to infix operators, includes TH name quotes, + `INLINE`/`NOINLINE` pragmas, infix type operator and infix constructor + * Fix pretty print for operators in `INLINE`/`NOINLINE` pragmas + * Support for `EmptyCases` extension + * Fix TH name quotes on operator names + * Optimize pretty print for many fundeps + * Fix extra linebreaks after short identifiers + 5.2.3: * Sort explicit import lists diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,8 +2,6 @@ Haskell pretty printer -[Demonstration site](http://chrisdone.com/hindent/) - [Examples](https://github.com/commercialhaskell/hindent/blob/master/TESTS.md) ## Install diff --git a/TESTS.md b/TESTS.md --- a/TESTS.md +++ b/TESTS.md @@ -9,6 +9,14 @@ # Modules +Extension pragmas + +```haskell +{-# LANGUAGE TypeApplications #-} + +fun @Int 12 +``` + Module header ``` haskell @@ -72,11 +80,37 @@ ```haskell expect import qualified MegaModule as M - (Either, Maybe(Just, Nothing), MaybeT(..), - Monad((>>), (>>=), return), MonadBaseControl, (<<<), (>>>), join, - liftIO, void) + ( Either + , Maybe(Just, Nothing) + , MaybeT(..) + , Monad((>>), (>>=), return) + , MonadBaseControl + , (<<<) + , (>>>) + , join + , liftIO + , void + ) ``` +Pretty import specification + +```haskell +import A hiding + ( foobarbazqux + , foobarbazqux + , foobarbazqux + , foobarbazqux + , foobarbazqux + , foobarbazqux + , foobarbazqux + ) + +import Name hiding () + +import {-# SOURCE #-} safe qualified Module as M hiding (a, b, c, d, e, f) +``` + # Declarations Type declaration @@ -111,6 +145,7 @@ ``` GADT declarations + ```haskell data Ty :: (* -> *) where TCon @@ -267,6 +302,8 @@ Type application ```haskell +{-# LANGUAGE TypeApplications #-} + fun @Int 12 ``` @@ -929,8 +966,7 @@ ``` ```haskell expect -import ATooLongList - (alpha, beta, delta, epsilon, eta, gamma, theta, zeta) +import ATooLongList (alpha, beta, delta, epsilon, eta, gamma, theta, zeta) import B ``` @@ -1156,6 +1192,154 @@ -> [(ResB.BomEx, Maybe ResBS.BomSnapshotAggr)] ``` +NorfairKing Do as left-hand side of an infix operation #296 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/296 +block = + do ds <- inBraces $ inWhiteSpace declarations + return $ Block ds + "block" +``` + +NorfairKing Hindent linebreaks after very short names if the total line length goes over 80 #405 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/405 +t = + f "this is a very loooooooooooooooooooooooooooong string that goes over the line length" + argx + argy + argz + +t = + function + "this is a very loooooooooooooooooooooooooooong string that goes over the line length" + argx + argy + argz +``` + +ivan-timokhin No linebreaks for long functional dependency declarations #323 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/323 +class Foo a b | a -> b where + f :: a -> b + +class Foo a b c d e f + | a b c d e -> f + , a b c d f -> e + , a b c e f -> d + , a b d e f -> c + , a c d e f -> b + , b c d e f -> a + where + foo :: a -> b -> c -> d -> e -> f +``` + +utdemir Hindent breaks TH name captures of operators #412 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/412 +data T = + (-) + +q = '(-) + +data (-) + +q = ''(-) +``` + +utdemir Hindent can not parse empty case statements #414 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/414 +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE LambdaCase #-} + +f1 = case () of {} + +f2 = \case {} +``` + +TimoFreiberg INLINE (and other) pragmas for operators are reformatted without parens #415 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/415 +{-# NOINLINE (<>) #-} +``` + +NorfairKing Hindent breaks servant API's #417 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/417 +type API = api1 :<|> api2 +``` + +andersk Cannot parse @: operator #421 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/421 +a @: b = a + b + +main = print (2 @: 2) +``` + +andersk Corrupts parenthesized type operators #422 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/422 +data T a = + a :@ a + +test = (:@) +``` + +NorfairKing Infix constructor pattern is broken #424 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/424 +from $ \(author `InnerJoin` post) -> pure () +``` + +NorfairKing Hindent can no longer parse type applications code #426 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/426 +{-# LANGUAGE TypeApplications #-} + +f :: Num a => a +f = id + +x = f @Int 12 +``` + +michalrus Multiline `GHC.TypeLits.Symbol`s are being broken #451 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/451 +import GHC.TypeLits (Symbol) + +data X (sym :: Symbol) + deriving (Typeable) + +type Y = X "abc\n\n\ndef" +``` + +DavidEichmann Existential Quantification reordered #443 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/443 +{-# LANGUAGE ExistentialQuantification #-} + +data D = + forall a b c. D a + b + c +``` + # MINIMAL pragma Monad example @@ -1171,15 +1355,6 @@ class A where {-# MINIMAL averylongnamewithnoparticularmeaning | ananotherverylongnamewithnomoremeaning #-} -``` - -NorfairKing Do as left-hand side of an infix operation #296 - -```haskell -block = - do ds <- inBraces $ inWhiteSpace declarations - return $ Block ds - "block" ``` # Behaviour checks diff --git a/elisp/hindent.el b/elisp/hindent.el --- a/elisp/hindent.el +++ b/elisp/hindent.el @@ -1,325 +1,309 @@ -;;; hindent.el --- Indent haskell code using the "hindent" program - -;; Copyright (c) 2014 Chris Done. All rights reserved. - -;; Author: Chris Done -;; URL: https://github.com/chrisdone/hindent -;; Package-Requires: ((cl-lib "0.5")) - -;; 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 this program. If not, see . - -;;; Commentary: - -;; Provides a minor mode and commands for easily using the "hindent" -;; program to reformat Haskell code. - -;; Add `hindent-mode' to your `haskell-mode-hook' and use the provided -;; keybindings as needed. Set `hindent-reformat-buffer-on-save' to -;; `t' globally or in local variables to have your code automatically -;; reformatted. - -;;; Code: - -(require 'cl-lib) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Customization properties - -(defgroup hindent nil - "Integration with the \"hindent\" reformatting program." - :prefix "hindent-" - :group 'haskell) - -(defcustom hindent-style - nil - "The style to use for formatting. - -For hindent versions lower than 5, you must set this to a non-nil string." - :group 'hindent - :type 'string - :safe #'stringp) - -(make-obsolete-variable 'hindent-style nil "hindent 5") - - -(defcustom hindent-process-path - "hindent" - "Location where the hindent executable is located." - :group 'hindent - :type 'string - :safe #'stringp) - -(defcustom hindent-line-length - 80 - "Optionally override the line length." - :group 'hindent - :type '(choice (const :tag "Default: 80" 80) - (integer :tag "Override" 120)) - :safe (lambda (val) (or (integerp val) (not val)))) - -(defcustom hindent-indent-size - 2 - "Optionally override the indent size." - :group 'hindent - :type '(choice (const :tag "Default: 2" 2) - (integer :tag "Override" 4)) - :safe (lambda (val) (or (integerp val) (not val)))) - -(defcustom hindent-reformat-buffer-on-save nil - "Set to t to run `hindent-reformat-buffer' when a buffer in `hindent-mode' is saved." - :group 'hindent - :type 'boolean - :safe #'booleanp) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Minor mode - -(defvar hindent-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [remap indent-region] #'hindent-reformat-region) - (define-key map [remap fill-paragraph] #'hindent-reformat-decl-or-fill) - map) - "Keymap for `hindent-mode'.") - -;;;###autoload -(define-minor-mode hindent-mode - "Indent code with the hindent program. - -Provide the following keybindings: - -\\{hindent-mode-map}" - :init-value nil - :keymap hindent-mode-map - :lighter " HI" - :group 'hindent - :require 'hindent - (if hindent-mode - (add-hook 'before-save-hook 'hindent--before-save nil t) - (remove-hook 'before-save-hook 'hindent--before-save t))) - -(defun hindent--before-save () - "Optionally reformat the buffer on save." - (when hindent-reformat-buffer-on-save - (hindent-reformat-buffer))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Interactive functions - -;;;###autoload -(defun hindent-reformat-decl () - "Re-format the current declaration. - -The declaration is parsed and pretty printed. Comments are -preserved, although placement may be funky." - (interactive) - (let ((start-end (hindent-decl-points))) - (when start-end - (let ((beg (car start-end)) - (end (cdr start-end))) - (hindent-reformat-region beg end t))))) - -;;;###autoload -(defun hindent-reformat-buffer () - "Reformat the whole buffer." - (interactive) - (hindent-reformat-region (point-min) - (point-max))) - -;;;###autoload -(defun hindent-reformat-decl-or-fill (justify) - "Re-format current declaration, or fill paragraph. - -Fill paragraph if in a comment, otherwise reformat the current -declaration. When filling, the prefix argument JUSTIFY will -cause the text to be justified, as per `fill-paragraph'." - (interactive (progn - ;; Copied from `fill-paragraph' - (barf-if-buffer-read-only) - (list (if current-prefix-arg 'full)))) - (if (hindent-in-comment) - (fill-paragraph justify t) - (hindent-reformat-decl))) - -;;;###autoload -(defun hindent-reformat-region (beg end &optional drop-newline) - "Reformat the region from BEG to END, accounting for indentation. - -If DROP-NEWLINE is non-nil, don't require a newline at the end of -the file." - (interactive "r") - (if (= (save-excursion (goto-char beg) - (line-beginning-position)) - beg) - (hindent-reformat-region-as-is beg end drop-newline) - (let* ((column (- beg (line-beginning-position))) - (string (buffer-substring-no-properties beg end)) - (new-string (with-temp-buffer - (insert (make-string column ? ) string) - (hindent-reformat-region-as-is (point-min) - (point-max) - drop-newline) - (delete-region (point-min) (1+ column)) - (buffer-substring (point-min) - (point-max))))) - (save-excursion - (goto-char beg) - (delete-region beg end) - (insert new-string))))) - -;;;###autoload -(define-obsolete-function-alias 'hindent/reformat-decl 'hindent-reformat-decl) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Internal library - -(defun hindent-reformat-region-as-is (beg end &optional drop-newline) - "Reformat the given region from BEG to END as-is. - -This is the place where hindent is actually called. - -If DROP-NEWLINE is non-nil, don't require a newline at the end of -the file." - (let* ((original (current-buffer)) - (orig-str (buffer-substring-no-properties beg end))) - (with-temp-buffer - (let ((temp (current-buffer))) - (with-current-buffer original - (let ((ret (apply #'call-process-region - (append (list beg - end - hindent-process-path - nil ; delete - temp ; output - nil) - (hindent-extra-arguments))))) - (cond - ((= ret 1) - (let ((error-string - (with-current-buffer temp - (let ((string (progn (goto-char (point-min)) - (buffer-substring (line-beginning-position) - (line-end-position))))) - string)))) - (if (string= error-string "hindent: Parse error: EOF") - (message "language pragma") - (error error-string)))) - ((= ret 0) - (let* ((last-decl (= end (point-max))) - (new-str (with-current-buffer temp - (when (and drop-newline (not last-decl)) - (goto-char (point-max)) - (when (looking-back "\n" (1- (point))) - (delete-char -1))) - (buffer-string)))) - (if (not (string= new-str orig-str)) - (let ((line (line-number-at-pos)) - (col (current-column))) - (delete-region beg - end) - (let ((new-start (point))) - (insert new-str) - (let ((new-end (point))) - (goto-char (point-min)) - (forward-line (1- line)) - (goto-char (+ (line-beginning-position) col)) - (when (looking-back "^[ ]+" (line-beginning-position)) - (back-to-indentation)) - (delete-trailing-whitespace new-start new-end))) - (message "Formatted.")) - (message "Already formatted."))))))))))) - -(defun hindent-decl-points () - "Get the start and end position of the current declaration. - -This assumes that declarations start at column zero and that the -rest is always indented by one space afterwards, so Template -Haskell uses with it all being at column zero are not expected to -work." - (cond - ;; If we're in a block comment spanning multiple lines then let's - ;; see if it starts at the beginning of the line (or if any comment - ;; is at the beginning of the line, we don't care to treat it as a - ;; proper declaration. - ((and (hindent-in-comment) - (save-excursion (goto-char (line-beginning-position)) - (hindent-in-comment))) - nil) - ((save-excursion - (goto-char (line-beginning-position)) - (or (looking-at "^-}$") - (looking-at "^{-$"))) - nil) - ;; Otherwise we just do our line-based hack. - (t - (save-excursion - (let ((start - (or (cl-letf - (((symbol-function 'jump) - #'(lambda () - (search-backward-regexp "^[^ \n]" nil t 1) - (cond - ((save-excursion (goto-char (line-beginning-position)) - (looking-at "|]")) - (jump)) - (t (unless (or (looking-at "^-}$") - (looking-at "^{-$")) - (point))))))) - (goto-char (line-end-position)) - (jump)) - 0)) - (end - (progn - (goto-char (1+ (point))) - (or (cl-letf - (((symbol-function 'jump) - #'(lambda () - (when (search-forward-regexp "[\n]+[^ \n]" nil t 1) - (cond - ((save-excursion (goto-char (line-beginning-position)) - (looking-at "|]")) - (jump)) - (t (forward-char -1) - (search-backward-regexp "[^\n ]" nil t) - (forward-char) - (point))))))) - (jump)) - (point-max))))) - (cons start end)))))) - -(defun hindent-in-comment () - "Are we currently in a comment?" - (save-excursion - (when (and (= (line-end-position) - (point)) - (/= (line-beginning-position) (point))) - (forward-char -1)) - (and - (elt (syntax-ppss) 4) - ;; Pragmas {-# SPECIALIZE .. #-} etc are not to be treated as - ;; comments, even though they are highlighted as such - (not (save-excursion (goto-char (line-beginning-position)) - (looking-at "{-# ")))))) - -(defun hindent-extra-arguments () - "Extra command line arguments for the hindent invocation." - (append - (when (boundp 'haskell-language-extensions) - haskell-language-extensions) - (when hindent-style - (list "--style" hindent-style)))) - -(provide 'hindent) - -;;; hindent.el ends here +;;; hindent.el --- Indent haskell code using the "hindent" program + +;; Copyright (c) 2014 Chris Done. All rights reserved. + +;; Author: Chris Done +;; URL: https://github.com/chrisdone/hindent +;; Package-Requires: ((cl-lib "0.5")) + +;; 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 this program. If not, see . + +;;; Commentary: + +;; Provides a minor mode and commands for easily using the "hindent" +;; program to reformat Haskell code. + +;; Add `hindent-mode' to your `haskell-mode-hook' and use the provided +;; keybindings as needed. Set `hindent-reformat-buffer-on-save' to +;; `t' globally or in local variables to have your code automatically +;; reformatted. + +;;; Code: + +(require 'cl-lib) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Customization properties + +(defgroup hindent nil + "Integration with the \"hindent\" reformatting program." + :prefix "hindent-" + :group 'haskell) + +(defcustom hindent-style + nil + "The style to use for formatting. + +For hindent versions lower than 5, you must set this to a non-nil string." + :group 'hindent + :type 'string + :safe #'stringp) + +(make-obsolete-variable 'hindent-style nil "hindent 5") + + +(defcustom hindent-process-path + "hindent" + "Location where the hindent executable is located." + :group 'hindent + :type 'string + :safe #'stringp) + +(defcustom hindent-reformat-buffer-on-save nil + "Set to t to run `hindent-reformat-buffer' when a buffer in `hindent-mode' is saved." + :group 'hindent + :type 'boolean + :safe #'booleanp) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Minor mode + +(defvar hindent-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [remap indent-region] #'hindent-reformat-region) + (define-key map [remap fill-paragraph] #'hindent-reformat-decl-or-fill) + map) + "Keymap for `hindent-mode'.") + +;;;###autoload +(define-minor-mode hindent-mode + "Indent code with the hindent program. + +Provide the following keybindings: + +\\{hindent-mode-map}" + :init-value nil + :keymap hindent-mode-map + :lighter " HI" + :group 'hindent + :require 'hindent + (if hindent-mode + (add-hook 'before-save-hook 'hindent--before-save nil t) + (remove-hook 'before-save-hook 'hindent--before-save t))) + +(defun hindent--before-save () + "Optionally reformat the buffer on save." + (when hindent-reformat-buffer-on-save + (hindent-reformat-buffer))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Interactive functions + +;;;###autoload +(defun hindent-reformat-decl () + "Re-format the current declaration. + +The declaration is parsed and pretty printed. Comments are +preserved, although placement may be funky." + (interactive) + (let ((start-end (hindent-decl-points))) + (when start-end + (let ((beg (car start-end)) + (end (cdr start-end))) + (hindent-reformat-region beg end t))))) + +;;;###autoload +(defun hindent-reformat-buffer () + "Reformat the whole buffer." + (interactive) + (hindent-reformat-region (point-min) + (point-max))) + +;;;###autoload +(defun hindent-reformat-decl-or-fill (justify) + "Re-format current declaration, or fill paragraph. + +Fill paragraph if in a comment, otherwise reformat the current +declaration. When filling, the prefix argument JUSTIFY will +cause the text to be justified, as per `fill-paragraph'." + (interactive (progn + ;; Copied from `fill-paragraph' + (barf-if-buffer-read-only) + (list (if current-prefix-arg 'full)))) + (if (hindent-in-comment) + (fill-paragraph justify t) + (hindent-reformat-decl))) + +;;;###autoload +(defun hindent-reformat-region (beg end &optional drop-newline) + "Reformat the region from BEG to END, accounting for indentation. + +If DROP-NEWLINE is non-nil, don't require a newline at the end of +the file." + (interactive "r") + (if (= (save-excursion (goto-char beg) + (line-beginning-position)) + beg) + (hindent-reformat-region-as-is beg end drop-newline) + (let* ((column (- beg (line-beginning-position))) + (string (buffer-substring-no-properties beg end)) + (new-string (with-temp-buffer + (insert (make-string column ? ) string) + (hindent-reformat-region-as-is (point-min) + (point-max) + drop-newline) + (delete-region (point-min) (1+ column)) + (buffer-substring (point-min) + (point-max))))) + (save-excursion + (goto-char beg) + (delete-region beg end) + (insert new-string))))) + +;;;###autoload +(define-obsolete-function-alias 'hindent/reformat-decl 'hindent-reformat-decl) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Internal library + +(defun hindent-reformat-region-as-is (beg end &optional drop-newline) + "Reformat the given region from BEG to END as-is. + +This is the place where hindent is actually called. + +If DROP-NEWLINE is non-nil, don't require a newline at the end of +the file." + (let* ((original (current-buffer)) + (orig-str (buffer-substring-no-properties beg end))) + (with-temp-buffer + (let ((temp (current-buffer))) + (with-current-buffer original + (let ((ret (apply #'call-process-region + (append (list beg + end + hindent-process-path + nil ; delete + temp ; output + nil) + (hindent-extra-arguments))))) + (cond + ((= ret 1) + (let ((error-string + (with-current-buffer temp + (let ((string (progn (goto-char (point-min)) + (buffer-substring (line-beginning-position) + (line-end-position))))) + string)))) + (if (string= error-string "hindent: Parse error: EOF") + (message "language pragma") + (error error-string)))) + ((= ret 0) + (let* ((last-decl (= end (point-max))) + (new-str (with-current-buffer temp + (when (and drop-newline (not last-decl)) + (goto-char (point-max)) + (when (looking-back "\n" (1- (point))) + (delete-char -1))) + (buffer-string)))) + (if (not (string= new-str orig-str)) + (let ((line (line-number-at-pos)) + (col (current-column))) + (delete-region beg + end) + (let ((new-start (point))) + (insert new-str) + (let ((new-end (point))) + (goto-char (point-min)) + (forward-line (1- line)) + (goto-char (+ (line-beginning-position) col)) + (when (looking-back "^[ ]+" (line-beginning-position)) + (back-to-indentation)) + (delete-trailing-whitespace new-start new-end))) + (message "Formatted.")) + (message "Already formatted."))))))))))) + +(defun hindent-decl-points () + "Get the start and end position of the current declaration. + +This assumes that declarations start at column zero and that the +rest is always indented by one space afterwards, so Template +Haskell uses with it all being at column zero are not expected to +work." + (cond + ;; If we're in a block comment spanning multiple lines then let's + ;; see if it starts at the beginning of the line (or if any comment + ;; is at the beginning of the line, we don't care to treat it as a + ;; proper declaration. + ((and (hindent-in-comment) + (save-excursion (goto-char (line-beginning-position)) + (hindent-in-comment))) + nil) + ((save-excursion + (goto-char (line-beginning-position)) + (or (looking-at "^-}$") + (looking-at "^{-$"))) + nil) + ;; Otherwise we just do our line-based hack. + (t + (save-excursion + (let ((start + (or (cl-letf + (((symbol-function 'jump) + #'(lambda () + (search-backward-regexp "^[^ \n]" nil t 1) + (cond + ((save-excursion (goto-char (line-beginning-position)) + (looking-at "|]")) + (jump)) + (t (unless (or (looking-at "^-}$") + (looking-at "^{-$")) + (point))))))) + (goto-char (line-end-position)) + (jump)) + 0)) + (end + (progn + (goto-char (1+ (point))) + (or (cl-letf + (((symbol-function 'jump) + #'(lambda () + (when (search-forward-regexp "[\n]+[^ \n]" nil t 1) + (cond + ((save-excursion (goto-char (line-beginning-position)) + (looking-at "|]")) + (jump)) + (t (forward-char -1) + (search-backward-regexp "[^\n ]" nil t) + (forward-char) + (point))))))) + (jump)) + (point-max))))) + (cons start end)))))) + +(defun hindent-in-comment () + "Are we currently in a comment?" + (save-excursion + (when (and (= (line-end-position) + (point)) + (/= (line-beginning-position) (point))) + (forward-char -1)) + (and + (elt (syntax-ppss) 4) + ;; Pragmas {-# SPECIALIZE .. #-} etc are not to be treated as + ;; comments, even though they are highlighted as such + (not (save-excursion (goto-char (line-beginning-position)) + (looking-at "{-# ")))))) + +(defun hindent-extra-arguments () + "Extra command line arguments for the hindent invocation." + (append + (when (boundp 'haskell-language-extensions) + haskell-language-extensions) + (when hindent-style + (list "--style" hindent-style)))) + +(provide 'hindent) + +;;; hindent.el ends here diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,5 +1,5 @@ name: hindent -version: 5.2.3 +version: 5.2.4 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . @@ -34,7 +34,7 @@ HIndent.Pretty build-depends: base >= 4.7 && <5 , containers - , haskell-src-exts >= 1.18 + , haskell-src-exts >= 1.19 , monad-loops , mtl , bytestring diff --git a/src/HIndent.hs b/src/HIndent.hs --- a/src/HIndent.hs +++ b/src/HIndent.hs @@ -68,7 +68,15 @@ let ls = S8.lines text prefix = findPrefix ls code = unlines' (map (stripPrefix prefix) ls) - in case parseModuleWithComments mode' (UTF8.toString code) of + exts = readExtensions (UTF8.toString code) + mode'' = case exts of + Nothing -> mode' + Just (Nothing, exts') -> + mode' { extensions = exts' ++ extensions mode' } + Just (Just lang, exts') -> + mode' { baseLanguage = lang + , extensions = exts' ++ extensions mode' } + in case parseModuleWithComments mode'' (UTF8.toString code) of ParseOk (m, comments) -> fmap (S.lazyByteString . addPrefix prefix . S.toLazyByteString) @@ -168,7 +176,8 @@ cppLine src = any (`S8.isPrefixOf` src) - ["#if", "#end", "#else", "#define", "#undef", "#elif"] + ["#if", "#end", "#else", "#define", "#undef", "#elif", "#include", "#error", "#warning"] + -- Note: #ifdef and #ifndef are handled by #if unlines' :: [(Int, ByteString)] -> (Int, ByteString) unlines' [] = (0, S.empty) unlines' srcs@((line, _):_) = @@ -286,6 +295,7 @@ ,PatternSynonyms -- steals the pattern keyword ,RecursiveDo -- steals the rec keyword ,DoRec -- same + ,TypeApplications -- since GHC 8 and haskell-src-exts-1.19 ] diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -359,11 +359,11 @@ (spaced (map pretty args)) PTuple _ boxed pats -> depend (write (case boxed of - Unboxed -> "(#" + Unboxed -> "(# " Boxed -> "(")) (do commas (map pretty pats) write (case boxed of - Unboxed -> "#)" + Unboxed -> " #)" Boxed -> ")")) PList _ ps -> brackets (commas (map pretty ps)) @@ -415,6 +415,11 @@ PXRPats{} -> pretty' x PVar{} -> pretty' x +-- | Pretty infix application of a name (identifier or symbol). +prettyInfixName :: Name NodeInfo -> Printer () +prettyInfixName (Ident _ n) = do write "`"; string n; write "`"; +prettyInfixName (Symbol _ s) = string s + -- | Pretty print a name for being an infix operator. prettyInfixOp :: QName NodeInfo -> Printer () prettyInfixOp x = @@ -423,10 +428,26 @@ case n of Ident _ i -> do write "`"; pretty mn; write "."; string i; write "`"; Symbol _ s -> do pretty mn; write "."; string s; + UnQual _ n -> prettyInfixName n + Special _ s -> pretty s + +prettyQuoteName :: Name NodeInfo -> Printer () +prettyQuoteName x = + case x of + Ident _ i -> string i + Symbol _ s -> string ("(" ++ s ++ ")") + +prettyQuoteQName :: QName NodeInfo -> Printer () +prettyQuoteQName x = + case x of + Qual _ mn n -> + case n of + Ident _ i -> do pretty mn; write "."; string i; + Symbol _ s -> do write "("; pretty mn; write "."; string s; write ")"; UnQual _ n -> case n of - Ident _ i -> string ("`" ++ i ++ "`") - Symbol _ s -> string s + Ident _ i -> string i + Symbol _ s -> do write "("; string s; write ")"; Special _ s -> pretty s instance Pretty Type where @@ -455,27 +476,31 @@ Just st -> put st -- | Space out tuples. exp (Tuple _ boxed exps) = do - let horVariant = parensB boxed $ inter (write ", ") (map pretty exps) - verVariant = parensB boxed $ prefixedLined "," (map (depend space . pretty) exps) + let horVariant = parensHorB boxed $ inter (write ", ") (map pretty exps) + verVariant = parensVerB boxed $ prefixedLined "," (map (depend space . pretty) exps) mst <- fitsOnOneLine horVariant case mst of Nothing -> verVariant Just st -> put st where - parensB Unboxed = wrap "(#" "#)" - parensB Boxed = parens + parensHorB Boxed = parens + parensHorB Unboxed = wrap "(# " " #)" + parensVerB Boxed = parens + parensVerB Unboxed = wrap "(#" "#)" -- | Space out tuples. exp (TupleSection _ boxed mexps) = do - let horVariant = parensB boxed $ inter (write ", ") (map (maybe (return ()) pretty) mexps) + let horVariant = parensHorB boxed $ inter (write ", ") (map (maybe (return ()) pretty) mexps) verVariant = - parensB boxed $ prefixedLined "," (map (maybe (return ()) (depend space . pretty)) mexps) + parensVerB boxed $ prefixedLined "," (map (maybe (return ()) (depend space . pretty)) mexps) mst <- fitsOnOneLine horVariant case mst of Nothing -> verVariant Just st -> put st where - parensB Unboxed = wrap "(#" "#)" - parensB Boxed = parens + parensHorB Boxed = parens + parensHorB Unboxed = wrap "(# " " #)" + parensVerB Boxed = parens + parensVerB Unboxed = wrap "(#" "#)" -- | Infix apps, same algorithm as ChrisDone at the moment. exp e@(InfixApp _ a op b) = infixApp e a op b Nothing @@ -509,10 +534,16 @@ case mst of Nothing -> do let (f:args) = flattened - pretty f - newline + col <- gets psColumn spaces <- getIndentSpaces - indented spaces (lined (map pretty args)) + pretty f + col' <- gets psColumn + let diff = col' - col - if col == 0 then spaces else 0 + if diff + 1 <= spaces + then space + else newline + spaces' <- getIndentSpaces + indented spaces' (lined (map pretty args)) Just st -> put st where flatten (App label' op' arg') = flatten op' ++ [amap (addComments label') arg'] @@ -595,8 +626,9 @@ do depend (write "case ") (do pretty e write " of") - newline - indentedBlock (lined (map (withCaseContext True . pretty) alts)) + if null alts + then write " {}" + else do indentedBlock (lined (map (withCaseContext True . pretty) alts)) exp (Do _ stmts) = depend (write "do ") (lined (map pretty stmts)) @@ -635,10 +667,10 @@ (pretty t) exp (VarQuote _ x) = depend (write "'") - (pretty x) + (prettyQuoteQName x) exp (TypQuote _ x) = depend (write "''") - (pretty x) + (prettyQuoteQName x) exp (BracketExp _ b) = pretty b exp (SpliceExp _ s) = pretty s exp (QuasiQuote _ n s) = @@ -648,8 +680,10 @@ write "|")) exp (LCase _ alts) = do write "\\case" - newline - indentedBlock (lined (map (withCaseContext True . pretty) alts)) + if null alts + then write " {}" + else do newline + indentedBlock (lined (map (withCaseContext True . pretty) alts)) exp (MultiIf _ alts) = withCaseContext True @@ -683,6 +717,8 @@ exp (IPVar _ q) = pretty q exp (Con _ q) = case q of Special _ Cons{} -> parens (pretty q) + Qual _ _ (Symbol _ _) -> parens (pretty q) + UnQual _ (Symbol _ _) -> parens (pretty q) _ -> pretty q exp x@XTag{} = pretty' x @@ -767,14 +803,7 @@ decl (FunBind _ matches) = lined (map pretty matches) decl (ClassDecl _ ctx dhead fundeps decls) = - do depend (write "class ") - (withCtx ctx - (depend (do pretty dhead) - (depend (unless (null fundeps) - (do write " | " - commas (map pretty fundeps))) - (unless (null (fromMaybe [] decls)) - (write " where"))))) + do classHead ctx dhead fundeps decls unless (null (fromMaybe [] decls)) (do newline indentedBlock (lined (map pretty (fromMaybe [] decls)))) @@ -880,7 +909,7 @@ Nothing -> return () Just (ActiveFrom _ x) -> write ("[" ++ show x ++ "] ") Just (ActiveUntil _ x) -> write ("[~" ++ show x ++ "] ") - pretty name + prettyQuoteQName name write " #-}" decl (MinimalPragma _ (Just formula)) = @@ -888,6 +917,30 @@ depend (write "MINIMAL ") $ pretty formula decl x' = pretty' x' +classHead + :: Maybe (Context NodeInfo) + -> DeclHead NodeInfo + -> [FunDep NodeInfo] + -> Maybe [ClassDecl NodeInfo] + -> Printer () +classHead ctx dhead fundeps decls = shortHead `ifFitsOnOneLineOrElse` longHead + where + shortHead = + depend + (write "class ") + (withCtx ctx $ + depend + (pretty dhead) + (depend (unless (null fundeps) (write " | " >> commas (map pretty fundeps))) + (unless (null (fromMaybe [] decls)) (write " where")))) + longHead = do + depend (write "class ") (withCtx ctx $ pretty dhead) + newline + indentedBlock $ do + depend (write "| ") $ prefixedLined ", " $ map pretty fundeps + newline + unless (null (fromMaybe [] decls)) (write "where") + instance Pretty TypeEqn where prettyInternal (TypeEqn _ in_ out_) = do pretty in_ @@ -1059,10 +1112,7 @@ InfixMatch _ pat1 name pats rhs' mbinds -> do depend (do pretty pat1 space - case name of - Ident _ i -> - string ("`" ++ i ++ "`") - Symbol _ s -> string s) + prettyInfixName name) (do space spaced (map pretty pats)) withCaseContext False (pretty rhs') @@ -1089,7 +1139,7 @@ QualConDecl _ tyvars ctx d -> depend (unless (null (fromMaybe [] tyvars)) (do write "forall " - spaced (map pretty (fromMaybe [] tyvars)) + spaced (map pretty (reverse (fromMaybe [] tyvars))) write ". ")) (withCtx ctx (pretty d)) @@ -1176,17 +1226,12 @@ instance Pretty DeclHead where prettyInternal x = case x of - DHead _ name -> pretty name + DHead _ name -> prettyQuoteName name DHParen _ h -> parens (pretty h) DHInfix _ var name -> do pretty var space - case name of - Ident _ _ -> do - write "`" - pretty name - write "`" - Symbol _ _ -> pretty name + prettyInfixName name DHApp _ dhead var -> depend (pretty dhead) (do space @@ -1463,9 +1508,9 @@ replicate (i - 1) ',' ++ ")") TupleCon _ Unboxed i -> - string ("(#" ++ + string ("(# " ++ replicate (i - 1) ',' ++ - "#)") + " #)") Cons _ -> write ":" UnboxedSingleCon _ -> write "(##)" @@ -1492,14 +1537,43 @@ prettyInternal = pretty' instance Pretty ImportDecl where - prettyInternal = pretty' + prettyInternal (ImportDecl _ name qualified source safe mpkg mas mspec) = do + write "import" + when source $ write " {-# SOURCE #-}" + when safe $ write " safe" + when qualified $ write " qualified" + case mpkg of + Nothing -> return () + Just pkg -> space >> write pkg + space + pretty name + case mas of + Nothing -> return () + Just asName -> do + space + write "as " + pretty asName + case mspec of + Nothing -> return () + Just spec -> pretty spec instance Pretty ModuleName where prettyInternal (ModuleName _ name) = write name instance Pretty ImportSpecList where - prettyInternal = pretty' + prettyInternal (ImportSpecList _ hiding spec) = do + when hiding $ write " hiding" + let verVar = do + space + parens (commas (map pretty spec)) + let horVar = do + newline + indentedBlock + (do depend (write "( ") (prefixedLined ", " (map pretty spec)) + newline + write ")") + verVar `ifFitsOnOneLineOrElse` horVar instance Pretty ImportSpec where prettyInternal = pretty' @@ -1660,10 +1734,7 @@ match (InfixMatch _ pat1 name pats rhs' mbinds) = do depend (do pretty pat1 space - case name of - Ident _ i -> - string ("`" ++ i ++ "`") - Symbol _ s -> string s) + prettyInfixName name) (do space spaced (map pretty pats)) withCaseContext False (pretty rhs') @@ -1763,6 +1834,10 @@ typ (TyPromoted _ (PromotedCon _ _ tname)) = do write "'" pretty tname +typ (TyPromoted _ (PromotedString _ _ raw)) = do + do write "\"" + string raw + write "\"" typ ty@TyPromoted{} = pretty' ty typ (TySplice _ splice) = pretty splice typ (TyWildCard _ name) = @@ -1911,7 +1986,7 @@ (map (depend space . pretty) fields)) write " }") conDecl (ConDecl _ name bangty) = - depend (do pretty name + depend (do prettyQuoteName name unless (null bangty) space) (lined (map pretty bangty)) conDecl (InfixConDecl _ a f b) = diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -30,6 +30,7 @@ import Paths_hindent (version) import qualified System.Directory as IO import System.Environment +import System.Exit (exitWith) import qualified System.IO as IO import Text.Read @@ -39,24 +40,30 @@ args <- getArgs config <- getConfig case consume (options config) (map T.pack args) of - Succeeded (style, exts, mfilepath) -> + Succeeded (style, exts, action, mfilepath) -> case mfilepath of Just filepath -> do text <- S.readFile filepath case reformat style (Just exts) mfilepath text of Left e -> error e - Right out -> unless (L8.fromStrict text == S.toLazyByteString out) $ do - tmpDir <- IO.getTemporaryDirectory - (fp, h) <- IO.openTempFile tmpDir "hindent.hs" - L8.hPutStr h (S.toLazyByteString out) - IO.hFlush h - IO.hClose h - let exdev e = - if ioe_errno e == Just ((\(Errno a) -> a) eXDEV) - then IO.copyFile fp filepath >> IO.removeFile fp - else throw e - IO.copyPermissions filepath fp - IO.renameFile fp filepath `catch` exdev + Right out -> + unless (L8.fromStrict text == S.toLazyByteString out) $ + case action of + Validate -> do + IO.putStrLn $ filepath ++ " is not formatted" + exitWith (ExitFailure 1) + Reformat -> do + tmpDir <- IO.getTemporaryDirectory + (fp, h) <- IO.openTempFile tmpDir "hindent.hs" + L8.hPutStr h (S.toLazyByteString out) + IO.hFlush h + IO.hClose h + let exdev e = + if ioe_errno e == Just ((\(Errno a) -> a) eXDEV) + then IO.copyFile fp filepath >> IO.removeFile fp + else throw e + IO.copyPermissions filepath fp + IO.renameFile fp filepath `catch` exdev Nothing -> L8.interact (either error S.toLazyByteString . reformat style (Just exts) Nothing . L8.toStrict) @@ -65,6 +72,26 @@ Failed (Wrap (Stopped Help) _) -> putStrLn (help defaultConfig) _ -> error (help defaultConfig) +-- -- | Main entry point. +-- testformat :: [String] -> IO () +-- testformat args = do +-- config <- getConfig +-- case consume (options config) (map T.pack args) of +-- Succeeded (style, exts, mfilepath) -> +-- case mfilepath of +-- Just filepath -> do +-- text <- S.readFile filepath +-- case reformat style (Just exts) text of +-- Left e -> error (filepath ++ ": " ++ e) +-- Right out -> L8.putStrLn (S.toLazyByteString out) +-- Nothing -> +-- L8.interact +-- (either error S.toLazyByteString . reformat style (Just exts) . L8.toStrict) +-- Failed (Wrap (Stopped Version) _) -> +-- putStrLn ("hindent " ++ showVersion version) +-- Failed (Wrap (Stopped Help) _) -> putStrLn (help defaultConfig) +-- _ -> error (help defaultConfig) + -- | Read config from a config file, or return 'defaultConfig'. getConfig :: IO Config getConfig = do @@ -99,11 +126,13 @@ | Help deriving (Show) +data Action = Validate | Reformat + -- | Program options. options :: Monad m - => Config -> Consumer [Text] (Option Stoppers) m (Config, [Extension], Maybe FilePath) -options config = ver *> ((,,) <$> style <*> exts <*> file) + => Config -> Consumer [Text] (Option Stoppers) m (Config, [Extension], Action, Maybe FilePath) +options config = ver *> ((,,,) <$> style <*> exts <*> action <*> file) where ver = stop (flag "version" "Print the version" Version) *> @@ -136,6 +165,8 @@ optional (constant "--sort-imports" "Sort imports in groups" True <|> constant "--no-sort-imports" "Don't sort imports" False) + action = fromMaybe Reformat <$> + optional (constant "--validate" "Check if files are formatted without changing them" Validate) makeStyle s mlen tabs trailing imports = s { configMaxColumns = fromMaybe (configMaxColumns s) mlen