diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,16 @@ +5.2.3: + + * Sort explicit import lists + * Report the `SrcLoc` when there's a parse error + * Improve long type signatures pretty printing + * Support custom line-break operators, add `--line-breaks` argument + * Fix infix data constructor + * Disable `RecursiveDo` and `DoRec` extensions by default + * Add RecStmt support + * Improve GADT records, data declaration records + * Complicated type alias and type signatures pretty printing + * Fix quasi-quoter names + 5.2.2: * Parallel list comprehensions diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,10 @@ -# hindent [![Hackage](https://img.shields.io/hackage/v/hindent.svg?style=flat)](https://hackage.haskell.org/package/hindent) [![Build Status](https://travis-ci.org/chrisdone/hindent.png)](https://travis-ci.org/chrisdone/hindent) +# hindent [![Hackage](https://img.shields.io/hackage/v/hindent.svg?style=flat)](https://hackage.haskell.org/package/hindent) [![Build Status](https://travis-ci.org/commercialhaskell/hindent.png)](https://travis-ci.org/commercialhaskell/hindent) Haskell pretty printer [Demonstration site](http://chrisdone.com/hindent/) -[Examples](https://github.com/chrisdone/hindent/blob/master/TESTS.md) +[Examples](https://github.com/commercialhaskell/hindent/blob/master/TESTS.md) ## Install @@ -52,7 +52,7 @@ ## Emacs In -[elisp/hindent.el](https://github.com/chrisdone/hindent/blob/master/elisp/hindent.el) +[elisp/hindent.el](https://github.com/commercialhaskell/hindent/blob/master/elisp/hindent.el) there is `hindent-mode`, which provides keybindings to reindent parts of the buffer: diff --git a/TESTS.md b/TESTS.md --- a/TESTS.md +++ b/TESTS.md @@ -64,6 +64,19 @@ import B ``` +Explicit imports - capitals first (typeclasses/types), then operators, then identifiers + +```haskell given +import qualified MegaModule as M ((>>>), MonadBaseControl, void, MaybeT(..), join, Maybe(Nothing, Just), liftIO, Either, (<<<), Monad(return, (>>=), (>>))) +``` + +```haskell expect +import qualified MegaModule as M + (Either, Maybe(Just, Nothing), MaybeT(..), + Monad((>>), (>>=), return), MonadBaseControl, (<<<), (>>>), join, + liftIO, void) +``` + # Declarations Type declaration @@ -97,6 +110,16 @@ k p ``` +GADT declarations +```haskell +data Ty :: (* -> *) where + TCon + :: { field1 :: Int + , field2 :: Bool} + -> Ty Bool + TCon' :: (a :: *) -> a -> Ty a +``` + # Expressions Lazy patterns in a lambda @@ -324,38 +347,29 @@ # Type signatures -Long arguments list - -```haskell -longLongFunction :: ReaderT r (WriterT w (StateT s m)) a - -> StateT s (WriterT w (ReaderT r m)) a -``` - Long argument list should line break -```haskell pending +```haskell longLongFunction :: ReaderT r (WriterT w (StateT s m)) a -> StateT s (WriterT w (ReaderT r m)) a ``` -Class constraints should leave :: on same line +Class constraints should leave `::` on same line -``` haskell pending +``` haskell -- see https://github.com/chrisdone/hindent/pull/266#issuecomment-244182805 fun :: - (Class a, Class b) - => foo bar mu zot - -> foo bar mu zot + (Class a, Class b) + => fooooooooooo bar mu zot + -> fooooooooooo bar mu zot -> c ``` Class constraints ``` haskell -fun - :: (Class a, Class b) - => a -> b -> c +fun :: (Class a, Class b) => a -> b -> c ``` Tuples @@ -384,9 +398,7 @@ Implicit parameters ```haskell -f - :: (?x :: Int) - => Int +f :: (?x :: Int) => Int ``` Promoted list (issue #348) @@ -416,9 +428,7 @@ Prefix notation for operators ``` haskell -(+) - :: Num a - => a -> a -> a +(+) :: Num a => a -> a -> a (+) a b = a ``` @@ -818,16 +828,15 @@ meditans hindent freezes when trying to format this code #222 ``` haskell -c - :: forall new. +c :: forall new. ( Settable "pitch" Pitch (Map.AsMap (new Map.:\ "pitch")) new , Default (Book' (Map.AsMap (new Map.:\ "pitch"))) ) => Book' new c = set #pitch C (def :: Book' (Map.AsMap (new Map.:\ "pitch"))) -foo - :: ( Foooooooooooooooooooooooooooooooooooooooooo +foo :: + ( Foooooooooooooooooooooooooooooooooooooooooo , Foooooooooooooooooooooooooooooooooooooooooo ) => A @@ -863,8 +872,7 @@ -- https://github.com/chrisdone/hindent/issues/218 instance forall x. C -instance forall x. Show x => - C x +instance forall x. Show x => C x ``` tfausak support shebangs #208 @@ -914,12 +922,18 @@ Wrapped import list shouldn't add newline -```haskell +```haskell given import ATooLongList (alpha, beta, gamma, delta, epsilon, zeta, eta, theta) import B ``` +```haskell expect +import ATooLongList + (alpha, beta, delta, epsilon, eta, gamma, theta, zeta) +import B +``` + radupopescu `deriving` keyword not aligned with pipe symbol for type declarations ``` haskell @@ -1019,6 +1033,129 @@ instance Foo (T.<^) ``` +neongreen "{" is lost when formatting "Foo{}" #366 + +```haskell +-- https://github.com/chrisdone/hindent/issues/366 +foo = Nothing {} +``` + +jparoz Trailing space in list comprehension #357 + +```haskell +-- https://github.com/chrisdone/hindent/issues/357 +foo = + [ (x, y) + | x <- [1 .. 10] + , y <- [11 .. 20] + , even x + , even x + , even x + , even x + , even x + , odd y + ] +``` + +ttuegel Record formatting applied to expressions with RecordWildCards #274 + +```haskell +-- https://github.com/chrisdone/hindent/issues/274 +foo (Bar {..}) = Bar {..} +``` + +RecursiveDo `rec` and `mdo` keyword #328 + +```haskell +rec = undefined + +mdo = undefined +``` + +sophie-h Record syntax change in 5.2.2 #393 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/393 +data X + = X { x :: Int } + | X' + +data X = X + { x :: Int + , x' :: Int + } + +data X + = X { x :: Int + , x' :: Int } + | X' +``` + +k-bx Infix data constructor gets reformatted into a parse error #328 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/328 +data Expect = + String :--> String + deriving (Show) +``` + +tfausak Class constraints cause too many newlines #244 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/244 +x :: Num a => a +x = undefined + +-- instance +instance Num a => C a + +-- long instance +instance Nuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuum a => + C a where + f = undefined +``` + +expipiplus1 Always break before `::` on overlong signatures #390 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/390 +fun :: Is => Short +fun = undefined + +someFunctionSignature :: + Wiiiiiiiiiiiiiiiiith + -> Enough + -> (Arguments -> To ()) + -> Overflow (The Line Limit) +``` + +duog Long Type Constraint Synonyms are not reformatted #290 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/290 +type MyContext m + = ( MonadState Int m + , MonadReader Int m + , MonadError Text m + , MonadMask m + , Monoid m + , Functor m) +``` + +ocharles Type application differs from function application (leading to long lines) #359 + +```haskell +-- https://github.com/commercialhaskell/hindent/issues/359 +thing :: + ( ResB.BomEx + , Maybe [( Entity BomSnapshot + , ( [ResBS.OrderSubstituteAggr] + , ( Maybe (Entity BomSnapshotHistory) + , Maybe (Entity BomSnapshotHistory))))]) + -> [(ResB.BomEx, Maybe ResBS.BomSnapshotAggr)] +``` + # MINIMAL pragma Monad example @@ -1125,4 +1262,10 @@ flatten :: Exp NodeInfo -> [Exp NodeInfo] -> (Exp NodeInfo, [Exp NodeInfo]) flatten (App _ f' a') b = flatten f' (a' : b) flatten f' as = (f', as) +``` + +Quasi quotes + +```haskell +exp = [name|exp|] ``` diff --git a/elisp/hindent.el b/elisp/hindent.el --- a/elisp/hindent.el +++ b/elisp/hindent.el @@ -1,325 +1,325 @@ -;;; 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-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 diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,9 +1,9 @@ name: hindent -version: 5.2.2 +version: 5.2.3 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . - See the Github page for usage\/explanation: + See the Github page for usage\/explanation: license: BSD3 stability: Unstable license-file: LICENSE.md @@ -13,8 +13,8 @@ category: Development build-type: Simple cabal-version: >=1.8 -homepage: http://www.github.com/chrisdone/hindent -bug-reports: https://github.com/chrisdone/hindent/issues +homepage: https://github.com/commercialhaskell/hindent +bug-reports: https://github.com/commercialhaskell/hindent/issues data-files: elisp/hindent.el extra-source-files: README.md @@ -24,7 +24,7 @@ source-repository head type: git - location: https://github.com/chrisdone/hindent + location: https://github.com/commercialhaskell/hindent library hs-source-dirs: src/ diff --git a/src/HIndent.hs b/src/HIndent.hs --- a/src/HIndent.hs +++ b/src/HIndent.hs @@ -43,26 +43,28 @@ import Data.Traversable hiding (mapM) import HIndent.Pretty import HIndent.Types +import qualified Language.Haskell.Exts as Exts import Language.Haskell.Exts hiding (Style, prettyPrint, Pretty, style, parse) import Prelude -- | A block of code. data CodeBlock = Shebang ByteString - | HaskellSource ByteString + | HaskellSource Int ByteString + -- ^ Includes the starting line (indexed from 0) for error reporting | CPPDirectives ByteString deriving (Show, Eq) -- | Format the given source. -reformat :: Config -> Maybe [Extension] -> ByteString -> Either String Builder -reformat config mexts = +reformat :: Config -> Maybe [Extension] -> Maybe FilePath -> ByteString -> Either String Builder +reformat config mexts mfilepath = preserveTrailingNewline (fmap (mconcat . intersperse "\n") . mapM processBlock . cppSplitBlocks) where processBlock :: CodeBlock -> Either String Builder processBlock (Shebang text) = Right $ S.byteString text processBlock (CPPDirectives text) = Right $ S.byteString text - processBlock (HaskellSource text) = + processBlock (HaskellSource line text) = let ls = S8.lines text prefix = findPrefix ls code = unlines' (map (stripPrefix prefix) ls) @@ -71,7 +73,8 @@ fmap (S.lazyByteString . addPrefix prefix . S.toLazyByteString) (prettyPrint config m comments) - ParseFailed _ e -> Left e + ParseFailed loc e -> + Left (Exts.prettyPrint (loc {srcLine = srcLine loc + line}) ++ ": " ++ e) unlines' = S.concat . intersperse "\n" unlines'' = L.concat . intersperse "\n" addPrefix :: ByteString -> L8.ByteString -> L8.ByteString @@ -110,12 +113,13 @@ (findSmallestPrefix (S.tail p : map S.tail ps)) else "" mode' = - case mexts of - Just exts -> - parseMode - { extensions = exts - } - Nothing -> parseMode + let m = case mexts of + Just exts -> + parseMode + { extensions = exts + } + Nothing -> parseMode + in m { parseFilename = fromMaybe "" mfilepath } preserveTrailingNewline f x = if S8.null x || S8.all isSpace x then return mempty @@ -152,12 +156,12 @@ cppSplitBlocks :: ByteString -> [CodeBlock] cppSplitBlocks inp = modifyLast (inBlock (<> trailing)) . - map (classify . mconcat . intersperse "\n") . - groupBy ((==) `on` nonHaskellLine) . S8.lines $ + map (classify . unlines') . + groupBy ((==) `on` nonHaskellLine) . zip [0 ..] . S8.lines $ inp where - nonHaskellLine :: ByteString -> Bool - nonHaskellLine src = cppLine src || shebangLine src + nonHaskellLine :: (Int, ByteString) -> Bool + nonHaskellLine (_, src) = cppLine src || shebangLine src shebangLine :: ByteString -> Bool shebangLine = S8.isPrefixOf "#!" cppLine :: ByteString -> Bool @@ -165,16 +169,19 @@ any (`S8.isPrefixOf` src) ["#if", "#end", "#else", "#define", "#undef", "#elif"] - classify :: ByteString -> CodeBlock - classify text + unlines' :: [(Int, ByteString)] -> (Int, ByteString) + unlines' [] = (0, S.empty) + unlines' srcs@((line, _):_) = + (line, mconcat . intersperse "\n" $ map snd srcs) + classify :: (Int, ByteString) -> CodeBlock + classify (line, text) | shebangLine text = Shebang text | cppLine text = CPPDirectives text - | otherwise = HaskellSource text + | otherwise = HaskellSource line text -- Hack to work around some parser issues in haskell-src-exts: Some pragmas -- need to have a newline following them in order to parse properly, so we include -- the trailing newline in the code block if it existed. - trailing - :: ByteString + trailing :: ByteString trailing = if S8.isSuffixOf "\n" inp then "\n" @@ -184,7 +191,7 @@ modifyLast f [x] = [f x] modifyLast f (x:xs) = x : modifyLast f xs inBlock :: (ByteString -> ByteString) -> CodeBlock -> CodeBlock - inBlock f (HaskellSource txt) = HaskellSource (f txt) + inBlock f (HaskellSource line txt) = HaskellSource line (f txt) inBlock _ dir = dir @@ -229,10 +236,9 @@ defaultParseMode {extensions = allExtensions ,fixities = Nothing} where allExtensions = - filter isDisabledExtention knownExtensions - isDisabledExtention (DisableExtension _) = False - isDisabledExtention _ = True - + filter isDisabledExtension knownExtensions + isDisabledExtension (DisableExtension _) = False + isDisabledExtension _ = True -- | Test the given file. testFile :: FilePath -> IO () @@ -246,7 +252,7 @@ test :: ByteString -> IO () test = either error (L8.putStrLn . S.toLazyByteString) . - reformat defaultConfig Nothing + reformat defaultConfig Nothing Nothing -- | Parse the source and annotate it with comments, yielding the resulting AST. testAst :: ByteString -> Either String (Module NodeInfo) @@ -278,6 +284,8 @@ ,UnboxedTuples -- breaks (#) lens operator -- ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break ,PatternSynonyms -- steals the pattern keyword + ,RecursiveDo -- steals the rec keyword + ,DoRec -- same ] diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} -- | Pretty printing. @@ -400,8 +401,7 @@ write " -> ") (pretty p) PQuasiQuote _ name str -> - brackets (depend (do write "$" - string name + brackets (depend (do string name write "|") (string str)) PBangPat _ p -> @@ -778,12 +778,13 @@ unless (null (fromMaybe [] decls)) (do newline indentedBlock (lined (map pretty (fromMaybe [] decls)))) -decl (TypeDecl _ typehead typ') = - depend (write "type ") - (depend (pretty typehead) - (depend (write " = ") - (pretty typ'))) - +decl (TypeDecl _ typehead typ') = do + write "type " + pretty typehead + ifFitsOnOneLineOrElse + (depend (write " = ") (pretty typ')) + (do newline + indentedBlock (depend (write " = ") (pretty typ'))) decl (TypeFamDecl _ declhead result injectivity) = do write "type family " pretty declhead @@ -849,6 +850,27 @@ (prefixedLined "|" (map (depend space . pretty) xs))) +decl (GDataDecl _ dataornew ctx dhead mkind condecls mderivs) = + do depend (pretty dataornew >> space) + (withCtx ctx + (do pretty dhead + case mkind of + Nothing -> return () + Just kind -> do write " :: " + pretty kind + write " where")) + indentedBlock $ do + case condecls of + [] -> return () + _ -> do + newline + lined (map pretty condecls) + case mderivs of + Nothing -> return () + Just derivs -> + do newline + pretty derivs + decl (InlineSig _ inline active name) = do write "{-# " @@ -918,7 +940,16 @@ write " ~ " pretty b ParenA _ asst -> parens (pretty asst) - AppA _ name tys -> spaced (pretty name : map pretty (reverse tys)) + AppA _ name tys -> + let +#if MIN_VERSION_haskell_src_exts(1,19,0) + hse_workaround = id +#else + -- Workaround for bug in haskell-src-exts < 1.19.0 + -- + hse_workaround = reverse +#endif + in spaced (pretty name : map pretty (hse_workaround tys)) WildCardA _ name -> case name of Nothing -> write "_" @@ -1063,6 +1094,32 @@ (withCtx ctx (pretty d)) +instance Pretty GadtDecl where + prettyInternal (GadtDecl _ name fields t) = + horVar `ifFitsOnOneLineOrElse` verVar + where + fields' p = + case fromMaybe [] fields of + [] -> return () + fs -> do + depend (write "{") $ do + prefixedLined "," (map (depend space . pretty) fs) + write "}" + p + horVar = + depend (pretty name >> write " :: ") $ do + fields' (write " -> ") + declTy t + verVar = do + pretty name + newline + indentedBlock $ + depend (write ":: ") $ do + fields' $ do + newline + indented (-3) (write "-> ") + declTy t + instance Pretty Rhs where prettyInternal = rhs @@ -1085,7 +1142,19 @@ Just xs -> do write "forall " spaced (map pretty xs) write ". " - withCtx mctx (pretty ihead) + case mctx of + Nothing -> pretty ihead + Just ctx -> do + mst <- fitsOnOneLine (do pretty ctx + write " => " + pretty ihead + write " where") + case mst of + Nothing -> withCtx mctx (pretty ihead) + Just {} -> do + pretty ctx + write " => " + pretty ihead instance Pretty InstHead where prettyInternal x = @@ -1184,15 +1253,22 @@ shouldSortImports <- gets $ configSortImports . psConfig let imps1 = if shouldSortImports - then sortOn moduleVisibleName imps + then sortImports imps else imps sequence_ . intersperse newline $ map formatImport imps1 - where - moduleVisibleName idecl = - let ModuleName _ name = importModule idecl - in name + moduleVisibleName idecl = + let ModuleName _ name = importModule idecl + in name formatImport = pretty + sortImports imps = sortOn moduleVisibleName . map sortImportSpecsOnImport $ imps + sortImportSpecsOnImport imp = imp { importSpecs = fmap sortImportSpecs (importSpecs imp) } + sortImportSpecs (ImportSpecList l hiding specs) = ImportSpecList l hiding sortedSpecs + where + sortedSpecs = sortBy importSpecCompare . map sortCNames $ specs + sortCNames (IThingWith l2 name cNames) = IThingWith l2 name . sortBy cNameCompare $ cNames + sortCNames is = is + groupAdjacentBy :: (a -> a -> Bool) -> [a] -> [[a]] groupAdjacentBy _ [] = [] groupAdjacentBy adj items = xs : groupAdjacentBy adj rest @@ -1208,6 +1284,70 @@ in (x : xs', rest') | otherwise = ([x], xs) +importSpecCompare :: ImportSpec l -> ImportSpec l -> Ordering +importSpecCompare (IAbs _ _ (Ident _ s1)) (IAbs _ _ (Ident _ s2)) = compare s1 s2 +importSpecCompare (IAbs _ _ (Ident _ _)) (IAbs _ _ (Symbol _ _)) = GT +importSpecCompare (IAbs _ _ (Ident _ s1)) (IThingAll _ (Ident _ s2)) = compare s1 s2 +importSpecCompare (IAbs _ _ (Ident _ _)) (IThingAll _ (Symbol _ _)) = GT +importSpecCompare (IAbs _ _ (Ident _ s1)) (IThingWith _ (Ident _ s2) _) = compare s1 s2 +importSpecCompare (IAbs _ _ (Ident _ _)) (IThingWith _ (Symbol _ _) _) = GT +importSpecCompare (IAbs _ _ (Symbol _ _)) (IAbs _ _ (Ident _ _)) = LT +importSpecCompare (IAbs _ _ (Symbol _ s1)) (IAbs _ _ (Symbol _ s2)) = compare s1 s2 +importSpecCompare (IAbs _ _ (Symbol _ _)) (IThingAll _ (Ident _ _)) = LT +importSpecCompare (IAbs _ _ (Symbol _ s1)) (IThingAll _ (Symbol _ s2)) = compare s1 s2 +importSpecCompare (IAbs _ _ (Symbol _ _)) (IThingWith _ (Ident _ _) _) = LT +importSpecCompare (IAbs _ _ (Symbol _ s1)) (IThingWith _ (Symbol _ s2) _) = compare s1 s2 +importSpecCompare (IAbs _ _ _) (IVar _ _) = LT +importSpecCompare (IThingAll _ (Ident _ s1)) (IAbs _ _ (Ident _ s2)) = compare s1 s2 +importSpecCompare (IThingAll _ (Ident _ _)) (IAbs _ _ (Symbol _ _)) = GT +importSpecCompare (IThingAll _ (Ident _ s1)) (IThingAll _ (Ident _ s2)) = compare s1 s2 +importSpecCompare (IThingAll _ (Ident _ _)) (IThingAll _ (Symbol _ _)) = GT +importSpecCompare (IThingAll _ (Ident _ s1)) (IThingWith _ (Ident _ s2) _) = compare s1 s2 +importSpecCompare (IThingAll _ (Ident _ _)) (IThingWith _ (Symbol _ _) _) = GT +importSpecCompare (IThingAll _ (Symbol _ _)) (IAbs _ _ (Ident _ _)) = LT +importSpecCompare (IThingAll _ (Symbol _ s1)) (IAbs _ _ (Symbol _ s2)) = compare s1 s2 +importSpecCompare (IThingAll _ (Symbol _ _)) (IThingAll _ (Ident _ _)) = LT +importSpecCompare (IThingAll _ (Symbol _ s1)) (IThingAll _ (Symbol _ s2)) = compare s1 s2 +importSpecCompare (IThingAll _ (Symbol _ _)) (IThingWith _ (Ident _ _) _) = LT +importSpecCompare (IThingAll _ (Symbol _ s1)) (IThingWith _ (Symbol _ s2) _) = compare s1 s2 +importSpecCompare (IThingAll _ _) (IVar _ _) = LT +importSpecCompare (IThingWith _ (Ident _ s1) _) (IAbs _ _ (Ident _ s2)) = compare s1 s2 +importSpecCompare (IThingWith _ (Ident _ _) _) (IAbs _ _ (Symbol _ _)) = GT +importSpecCompare (IThingWith _ (Ident _ s1) _) (IThingAll _ (Ident _ s2)) = compare s1 s2 +importSpecCompare (IThingWith _ (Ident _ _) _) (IThingAll _ (Symbol _ _)) = GT +importSpecCompare (IThingWith _ (Ident _ s1) _) (IThingWith _ (Ident _ s2) _) = compare s1 s2 +importSpecCompare (IThingWith _ (Ident _ _) _) (IThingWith _ (Symbol _ _) _) = GT +importSpecCompare (IThingWith _ (Symbol _ _) _) (IAbs _ _ (Ident _ _)) = LT +importSpecCompare (IThingWith _ (Symbol _ s1) _) (IAbs _ _ (Symbol _ s2)) = compare s1 s2 +importSpecCompare (IThingWith _ (Symbol _ _) _) (IThingAll _ (Ident _ _)) = LT +importSpecCompare (IThingWith _ (Symbol _ s1) _) (IThingAll _ (Symbol _ s2)) = compare s1 s2 +importSpecCompare (IThingWith _ (Symbol _ _) _) (IThingWith _ (Ident _ _) _) = LT +importSpecCompare (IThingWith _ (Symbol _ s1) _) (IThingWith _ (Symbol _ s2) _) = compare s1 s2 +importSpecCompare (IThingWith _ _ _) (IVar _ _) = LT +importSpecCompare (IVar _ (Ident _ s1)) (IVar _ (Ident _ s2)) = compare s1 s2 +importSpecCompare (IVar _ (Ident _ _)) (IVar _ (Symbol _ _)) = GT +importSpecCompare (IVar _ (Symbol _ _)) (IVar _ (Ident _ _)) = LT +importSpecCompare (IVar _ (Symbol _ s1)) (IVar _ (Symbol _ s2)) = compare s1 s2 +importSpecCompare (IVar _ _) _ = GT + +cNameCompare :: CName l -> CName l -> Ordering +cNameCompare (VarName _ (Ident _ s1)) (VarName _ (Ident _ s2)) = compare s1 s2 +cNameCompare (VarName _ (Ident _ _)) (VarName _ (Symbol _ _)) = GT +cNameCompare (VarName _ (Ident _ s1)) (ConName _ (Ident _ s2)) = compare s1 s2 +cNameCompare (VarName _ (Ident _ _)) (ConName _ (Symbol _ _)) = GT +cNameCompare (VarName _ (Symbol _ _)) (VarName _ (Ident _ _)) = LT +cNameCompare (VarName _ (Symbol _ s1)) (VarName _ (Symbol _ s2)) = compare s1 s2 +cNameCompare (VarName _ (Symbol _ _)) (ConName _ (Ident _ _)) = LT +cNameCompare (VarName _ (Symbol _ s1)) (ConName _ (Symbol _ s2)) = compare s1 s2 +cNameCompare (ConName _ (Ident _ s1)) (VarName _ (Ident _ s2)) = compare s1 s2 +cNameCompare (ConName _ (Ident _ _)) (VarName _ (Symbol _ _)) = GT +cNameCompare (ConName _ (Ident _ s1)) (ConName _ (Ident _ s2)) = compare s1 s2 +cNameCompare (ConName _ (Ident _ _)) (ConName _ (Symbol _ _)) = GT +cNameCompare (ConName _ (Symbol _ _)) (VarName _ (Ident _ _)) = LT +cNameCompare (ConName _ (Symbol _ s1)) (VarName _ (Symbol _ s2)) = compare s1 s2 +cNameCompare (ConName _ (Symbol _ _)) (ConName _ (Ident _ _)) = LT +cNameCompare (ConName _ (Symbol _ s1)) (ConName _ (Symbol _ s2)) = compare s1 s2 + instance Pretty Bracket where prettyInternal x = case x of @@ -1407,8 +1547,9 @@ LetStmt _ binds -> depend (write "let ") (pretty binds) - RecStmt{} -> - error "FIXME: No implementation for RecStmt." + RecStmt _ es -> + depend (write "rec ") + (lined (map pretty es)) -- | Make the right hand side dependent if it fits on one line, -- otherwise send it to the next line. @@ -1539,104 +1680,102 @@ write ")" CxEmpty _ -> parens (return ()) -unboxParens :: Printer a -> Printer a -unboxParens p = - depend (write "(# ") - (do v <- p - write " #)" - return v) - typ :: Type NodeInfo -> Printer () -typ (TyTuple _ Boxed types) = parens $ inter (write ", ") $ map pretty types -typ (TyTuple _ Unboxed types) = unboxParens $ inter (write ", ") $ map pretty types -typ x = case x of - TyForall _ mbinds ctx ty -> - depend (case mbinds of - Nothing -> return () - Just ts -> - do write "forall " - spaced (map pretty ts) - write ". ") - (do indentSpaces <- getIndentSpaces - withCtx ctx (indented indentSpaces (pretty ty))) - TyFun _ a b -> - depend (do pretty a - write " -> ") - (pretty b) - TyTuple _ boxed tys -> - depend (write (case boxed of - Unboxed -> "(#" - Boxed -> "(")) - (do commas (map pretty tys) - write (case boxed of - Unboxed -> "#)" - Boxed -> ")")) - TyList _ t -> brackets (pretty t) - TyParArray _ t -> - brackets (do write ":" - pretty t - write ":") - TyApp _ f a -> spaced [pretty f, pretty a] - TyVar _ n -> pretty n - TyCon _ p -> - case p of - Qual _ _ name -> - case name of - Ident _ _ -> pretty p - Symbol _ _ -> parens (pretty p) - UnQual _ name -> - case name of - Ident _ _ -> pretty p - Symbol _ _ -> parens (pretty p) - Special _ con -> - case con of - FunCon _ -> parens (pretty p) - _ -> pretty p - TyParen _ e -> parens (pretty e) - TyInfix _ a op b -> - depend (do pretty a - space) - (depend (do prettyInfixOp op - space) - (pretty b)) - TyKind _ ty k -> - parens (do pretty ty - write " :: " - pretty k) - TyBang _ bangty unpackty right -> - do pretty unpackty - pretty bangty - pretty right - TyEquals _ left right -> - do pretty left - write " ~ " - pretty right - TyPromoted _ (PromotedList _ _ ts) -> - do write "'[" - unless (null ts) $ write " " - commas (map pretty ts) - write "]" - TyPromoted _ (PromotedTuple _ ts) -> - do write "'(" - unless (null ts) $ write " " - commas (map pretty ts) - write ")" - TyPromoted _ (PromotedCon _ _ tname) -> - do write "'" - pretty tname - ty@TyPromoted{} -> pretty' ty - TySplice _ splice -> pretty splice - TyWildCard _ name -> - case name of - Nothing -> write "_" - Just n -> - do write "_" - pretty n - TyQuasiQuote _ n s -> - brackets (depend (do string n - write "|") - (do string s - write "|")) +typ (TyTuple _ Boxed types) = do + let horVar = parens $ inter (write ", ") (map pretty types) + let verVar = parens $ prefixedLined "," (map (depend space . pretty) types) + horVar `ifFitsOnOneLineOrElse` verVar +typ (TyTuple _ Unboxed types) = do + let horVar = wrap "(# " " #)" $ inter (write ", ") (map pretty types) + let verVar = wrap "(#" " #)" $ prefixedLined "," (map (depend space . pretty) types) + horVar `ifFitsOnOneLineOrElse` verVar +typ (TyForall _ mbinds ctx ty) = + depend (case mbinds of + Nothing -> return () + Just ts -> + do write "forall " + spaced (map pretty ts) + write ". ") + (do indentSpaces <- getIndentSpaces + withCtx ctx (indented indentSpaces (pretty ty))) +typ (TyFun _ a b) = + depend (do pretty a + write " -> ") + (pretty b) +typ (TyList _ t) = brackets (pretty t) +typ (TyParArray _ t) = + brackets (do write ":" + pretty t + write ":") +typ (TyApp _ f a) = spaced [pretty f, pretty a] +typ (TyVar _ n) = pretty n +typ (TyCon _ p) = + case p of + Qual _ _ name -> + case name of + Ident _ _ -> pretty p + Symbol _ _ -> parens (pretty p) + UnQual _ name -> + case name of + Ident _ _ -> pretty p + Symbol _ _ -> parens (pretty p) + Special _ con -> + case con of + FunCon _ -> parens (pretty p) + _ -> pretty p +typ (TyParen _ e) = parens (pretty e) +typ (TyInfix _ a op b) = do + -- Apply special rules to line-break operators. + linebreak <- isLineBreak op + if linebreak + then do pretty a + newline + prettyInfixOp op + space + pretty b + else do pretty a + space + prettyInfixOp op + space + pretty b +typ (TyKind _ ty k) = + parens (do pretty ty + write " :: " + pretty k) +typ (TyBang _ bangty unpackty right) = + do pretty unpackty + pretty bangty + pretty right +typ (TyEquals _ left right) = + do pretty left + write " ~ " + pretty right +typ (TyPromoted _ (PromotedList _ _ ts)) = + do write "'[" + unless (null ts) $ write " " + commas (map pretty ts) + write "]" +typ (TyPromoted _ (PromotedTuple _ ts)) = + do write "'(" + unless (null ts) $ write " " + commas (map pretty ts) + write ")" +typ (TyPromoted _ (PromotedCon _ _ tname)) = + do write "'" + pretty tname +typ ty@TyPromoted{} = pretty' ty +typ (TySplice _ splice) = pretty splice +typ (TyWildCard _ name) = + case name of + Nothing -> write "_" + Just n -> + do write "_" + pretty n +typ (TyQuasiQuote _ n s) = + brackets (depend (do string n + write "|") + (do string s + write "|")) prettyTopName :: Name NodeInfo -> Printer () prettyTopName x@Ident{} = pretty x @@ -1653,49 +1792,24 @@ -- -> IO () -- decl' (TypeSig _ names ty') = do - mst <- fitsOnOneLine (declTy ty') + mst <- fitsOnOneLine (depend (do commas (map prettyTopName names) + write " :: ") + (declTy ty')) case mst of - Just {} -> - depend - (do commas (map prettyTopName names) - write " :: ") - (declTy ty') Nothing -> do commas (map prettyTopName names) - newline indentSpaces <- getIndentSpaces - indented indentSpaces (depend (write ":: ") (declTy ty')) + if allNamesLength >= indentSpaces + then do write " ::" + newline + indented indentSpaces (depend (write " ") (declTy ty')) + else (depend (write " :: ") (declTy ty')) + Just st -> put st + where + nameLength (Ident _ s) = length s + nameLength (Symbol _ s) = length s + 2 + allNamesLength = fromIntegral $ sum (map nameLength names) + 2 * (length names - 1) - where declTy dty = - case dty of - TyForall _ mbinds mctx ty -> - do case mbinds of - Nothing -> return () - Just ts -> - do write "forall " - spaced (map pretty ts) - write "." - newline - case mctx of - Nothing -> prettyTy ty - Just ctx -> - do pretty ctx - newline - indented (-3) - (depend (write "=> ") - (prettyTy ty)) - _ -> prettyTy dty - collapseFaps (TyFun _ arg result) = arg : collapseFaps result - collapseFaps e = [e] - prettyTy ty = - do mst <- fitsOnOneLine (pretty ty) - case mst of - Nothing -> case collapseFaps ty of - [] -> pretty ty - tys -> - prefixedLined "-> " - (map pretty tys) - Just st -> put st decl' (PatBind _ pat rhs' mbinds) = withCaseContext False $ do pretty pat @@ -1703,32 +1817,89 @@ for_ mbinds bindingGroup -- | Handle records specially for a prettier display (see guide). -decl' (DataDecl _ dataornew ctx dhead condecls@[_] mderivs) - | any isRecord condecls = +decl' (DataDecl _ dataornew ctx dhead [con] mderivs) + | isRecord con = do depend (do pretty dataornew - unless (null condecls) space) + space) (withCtx ctx (do pretty dhead - multiCons condecls)) + singleCons con)) case mderivs of Nothing -> return () Just derivs -> space >> pretty derivs - where multiCons xs = + where singleCons x = depend (write " =") - (inter (write "|") - (map (depend space . qualConDecl) xs)) + ((depend space . qualConDecl) x) decl' e = decl e +declTy :: Type NodeInfo -> Printer () +declTy dty = + case dty of + TyForall _ mbinds mctx ty -> + case mbinds of + Nothing -> do + case mctx of + Nothing -> prettyTy False ty + Just ctx -> do + mst <- fitsOnOneLine (do pretty ctx + depend (write " => ") (prettyTy False ty)) + case mst of + Nothing -> do + pretty ctx + newline + indented (-3) (depend (write "=> ") (prettyTy True ty)) + Just st -> put st + Just ts -> do + write "forall " + spaced (map pretty ts) + write "." + case mctx of + Nothing -> do + mst <- fitsOnOneLine (space >> prettyTy False ty) + case mst of + Nothing -> do + newline + prettyTy True ty + Just st -> put st + Just ctx -> do + mst <- fitsOnOneLine (space >> pretty ctx) + case mst of + Nothing -> do + newline + pretty ctx + newline + indented (-3) (depend (write "=> ") (prettyTy True ty)) + Just st -> do + put st + newline + indented (-3) (depend (write "=> ") (prettyTy True ty)) + _ -> prettyTy False dty + where + collapseFaps (TyFun _ arg result) = arg : collapseFaps result + collapseFaps e = [e] + prettyTy breakLine ty = do + if breakLine + then + case collapseFaps ty of + [] -> pretty ty + tys -> prefixedLined "-> " (map pretty tys) + else do + mst <- fitsOnOneLine (pretty ty) + case mst of + Nothing -> + case collapseFaps ty of + [] -> pretty ty + tys -> prefixedLined "-> " (map pretty tys) + Just st -> put st + -- | Use special record display, used by 'dataDecl' in a record scenario. qualConDecl :: QualConDecl NodeInfo -> Printer () -qualConDecl x = - case x of - QualConDecl _ tyvars ctx d -> - depend (unless (null (fromMaybe [] tyvars)) - (do write "forall " - spaced (map pretty (fromMaybe [] tyvars)) - write ". ")) - (withCtx ctx (recDecl d)) +qualConDecl (QualConDecl _ tyvars ctx d) = + depend (unless (null (fromMaybe [] tyvars)) + (do write "forall " + spaced (map pretty (fromMaybe [] tyvars)) + write ". ")) + (withCtx ctx (recDecl d)) -- | Fields are preceded with a space. conDecl :: ConDecl NodeInfo -> Printer () @@ -1736,23 +1907,15 @@ depend (do pretty name write " ") (do depend (write "{") - (prefixedLined ", " + (prefixedLined "," (map (depend space . pretty) fields)) - write "}") -conDecl x = case x of - ConDecl _ name bangty -> - depend (do pretty name - unless (null bangty) space) - (lined (map pretty bangty)) - InfixConDecl l a f b -> - pretty (ConDecl l f [a,b]) - RecDecl _ name fields -> - depend (do pretty name - space) - (do depend (write "{") - (prefixedLined ", " - (map pretty fields)) - write "}") + write " }") +conDecl (ConDecl _ name bangty) = + depend (do pretty name + unless (null bangty) space) + (lined (map pretty bangty)) +conDecl (InfixConDecl _ a f b) = + inter space [pretty a, pretty f, pretty b] -- | Record decls are formatted like: Foo -- { bar :: X @@ -1794,6 +1957,13 @@ isRecord :: QualConDecl t -> Bool isRecord (QualConDecl _ _ _ RecDecl{}) = True isRecord _ = False + +-- | If the given operator is an element of line breaks in configuration. +isLineBreak :: QName NodeInfo -> Printer Bool +isLineBreak (UnQual _ (Symbol _ s)) = do + breaks <- gets (configLineBreaks . psConfig) + return $ s `elem` breaks +isLineBreak _ = return False -- | Does printing the given thing overflow column limit? (e.g. 80) fitsOnOneLine :: Printer a -> Printer (Maybe PrintState) diff --git a/src/HIndent/Types.hs b/src/HIndent/Types.hs --- a/src/HIndent/Types.hs +++ b/src/HIndent/Types.hs @@ -63,19 +63,27 @@ , configIndentSpaces :: !Int64 -- ^ How many spaces to indent? , configTrailingNewline :: !Bool -- ^ End with a newline. , configSortImports :: !Bool -- ^ Sort imports in groups. + , configLineBreaks :: [String] -- ^ Break line when meets these operators. } instance FromJSON Config where parseJSON (Y.Object v) = Config <$> - fmap (fromMaybe (configMaxColumns defaultConfig)) (v Y..:? "line-length") <*> - fmap - (fromMaybe (configIndentSpaces defaultConfig)) - (v Y..:? "indent-size" <|> v Y..:? "tab-size") <*> - fmap - (fromMaybe (configTrailingNewline defaultConfig)) - (v Y..:? "force-trailing-newline") <*> - fmap (fromMaybe (configSortImports defaultConfig)) (v Y..:? "sort-imports") + fmap + (fromMaybe (configMaxColumns defaultConfig)) + (v Y..:? "line-length") <*> + fmap + (fromMaybe (configIndentSpaces defaultConfig)) + (v Y..:? "indent-size" <|> v Y..:? "tab-size") <*> + fmap + (fromMaybe (configTrailingNewline defaultConfig)) + (v Y..:? "force-trailing-newline") <*> + fmap + (fromMaybe (configSortImports defaultConfig)) + (v Y..:? "sort-imports") <*> + fmap + (fromMaybe (configLineBreaks defaultConfig)) + (v Y..:? "line-breaks") parseJSON _ = fail "Expected Object for Config value" -- | Default style configuration. @@ -86,6 +94,7 @@ , configIndentSpaces = 2 , configTrailingNewline = True , configSortImports = True + , configLineBreaks = [] } -- | Some comment to print. diff --git a/src/main/Benchmark.hs b/src/main/Benchmark.hs --- a/src/main/Benchmark.hs +++ b/src/main/Benchmark.hs @@ -38,11 +38,11 @@ (either error L.toLazyByteString . reformat HIndent.Types.defaultConfig - (Just defaultExtensions)) + (Just defaultExtensions) + Nothing) code)) : go next else go next go (PlainText {}:next) = go next go (CodeFence {}:next) = go next go [] = [] - diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -43,8 +43,8 @@ case mfilepath of Just filepath -> do text <- S.readFile filepath - case reformat style (Just exts) text of - Left e -> error (filepath ++ ": " ++ e) + 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" @@ -59,7 +59,7 @@ IO.renameFile fp filepath `catch` exdev Nothing -> L8.interact - (either error S.toLazyByteString . reformat style (Just exts) . L8.toStrict) + (either error S.toLazyByteString . reformat style (Just exts) Nothing . L8.toStrict) Failed (Wrap (Stopped Version) _) -> putStrLn ("hindent " ++ showVersion version) Failed (Wrap (Stopped Help) _) -> putStrLn (help defaultConfig) diff --git a/src/main/Path/Find.hs b/src/main/Path/Find.hs --- a/src/main/Path/Find.hs +++ b/src/main/Path/Find.hs @@ -1,98 +1,98 @@ -{-# LANGUAGE DataKinds #-} - --- | Finding files. - --- Lifted from Stack. - -module Path.Find - (findFileUp - ,findDirUp - ,findFiles - ,findInParents) - where - -import Control.Exception (evaluate) -import Control.DeepSeq (force) -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class -import System.IO.Error (isPermissionError) -import Data.List -import Path -import Path.IO hiding (findFiles) -import System.PosixCompat.Files (getSymbolicLinkStatus, isSymbolicLink) - --- | Find the location of a file matching the given predicate. -findFileUp :: (MonadIO m,MonadThrow m) - => Path Abs Dir -- ^ Start here. - -> (Path Abs File -> Bool) -- ^ Predicate to match the file. - -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. - -> m (Maybe (Path Abs File)) -- ^ Absolute file path. -findFileUp = findPathUp snd - --- | Find the location of a directory matching the given predicate. -findDirUp :: (MonadIO m,MonadThrow m) - => Path Abs Dir -- ^ Start here. - -> (Path Abs Dir -> Bool) -- ^ Predicate to match the directory. - -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. - -> m (Maybe (Path Abs Dir)) -- ^ Absolute directory path. -findDirUp = findPathUp fst - --- | Find the location of a path matching the given predicate. -findPathUp :: (MonadIO m,MonadThrow m) - => (([Path Abs Dir],[Path Abs File]) -> [Path Abs t]) - -- ^ Choose path type from pair. - -> Path Abs Dir -- ^ Start here. - -> (Path Abs t -> Bool) -- ^ Predicate to match the path. - -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. - -> m (Maybe (Path Abs t)) -- ^ Absolute path. -findPathUp pathType dir p upperBound = - do entries <- listDir dir - case find p (pathType entries) of - Just path -> return (Just path) - Nothing | Just dir == upperBound -> return Nothing - | parent dir == dir -> return Nothing - | otherwise -> findPathUp pathType (parent dir) p upperBound - --- | Find files matching predicate below a root directory. --- --- NOTE: this skips symbolic directory links, to avoid loops. This may --- not make sense for all uses of file finding. --- --- TODO: write one of these that traverses symbolic links but --- efficiently ignores loops. -findFiles :: Path Abs Dir -- ^ Root directory to begin with. - -> (Path Abs File -> Bool) -- ^ Predicate to match files. - -> (Path Abs Dir -> Bool) -- ^ Predicate for which directories to traverse. - -> IO [Path Abs File] -- ^ List of matching files. -findFiles dir p traversep = - do (dirs,files) <- catchJust (\ e -> if isPermissionError e - then Just () - else Nothing) - (listDir dir) - (\ _ -> return ([], [])) - filteredFiles <- evaluate $ force (filter p files) - filteredDirs <- filterM (fmap not . isSymLink) dirs - subResults <- - forM filteredDirs - (\entry -> - if traversep entry - then findFiles entry p traversep - else return []) - return (concat (filteredFiles : subResults)) - -isSymLink :: Path Abs t -> IO Bool -isSymLink = fmap isSymbolicLink . getSymbolicLinkStatus . toFilePath - --- | @findInParents f path@ applies @f@ to @path@ and its 'parent's until --- it finds a 'Just' or reaches the root directory. -findInParents :: MonadIO m => (Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a) -findInParents f path = do - mres <- f path - case mres of - Just res -> return (Just res) - Nothing -> do - let next = parent path - if next == path - then return Nothing - else findInParents f next +{-# LANGUAGE DataKinds #-} + +-- | Finding files. + +-- Lifted from Stack. + +module Path.Find + (findFileUp + ,findDirUp + ,findFiles + ,findInParents) + where + +import Control.Exception (evaluate) +import Control.DeepSeq (force) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import System.IO.Error (isPermissionError) +import Data.List +import Path +import Path.IO hiding (findFiles) +import System.PosixCompat.Files (getSymbolicLinkStatus, isSymbolicLink) + +-- | Find the location of a file matching the given predicate. +findFileUp :: (MonadIO m,MonadThrow m) + => Path Abs Dir -- ^ Start here. + -> (Path Abs File -> Bool) -- ^ Predicate to match the file. + -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. + -> m (Maybe (Path Abs File)) -- ^ Absolute file path. +findFileUp = findPathUp snd + +-- | Find the location of a directory matching the given predicate. +findDirUp :: (MonadIO m,MonadThrow m) + => Path Abs Dir -- ^ Start here. + -> (Path Abs Dir -> Bool) -- ^ Predicate to match the directory. + -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. + -> m (Maybe (Path Abs Dir)) -- ^ Absolute directory path. +findDirUp = findPathUp fst + +-- | Find the location of a path matching the given predicate. +findPathUp :: (MonadIO m,MonadThrow m) + => (([Path Abs Dir],[Path Abs File]) -> [Path Abs t]) + -- ^ Choose path type from pair. + -> Path Abs Dir -- ^ Start here. + -> (Path Abs t -> Bool) -- ^ Predicate to match the path. + -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. + -> m (Maybe (Path Abs t)) -- ^ Absolute path. +findPathUp pathType dir p upperBound = + do entries <- listDir dir + case find p (pathType entries) of + Just path -> return (Just path) + Nothing | Just dir == upperBound -> return Nothing + | parent dir == dir -> return Nothing + | otherwise -> findPathUp pathType (parent dir) p upperBound + +-- | Find files matching predicate below a root directory. +-- +-- NOTE: this skips symbolic directory links, to avoid loops. This may +-- not make sense for all uses of file finding. +-- +-- TODO: write one of these that traverses symbolic links but +-- efficiently ignores loops. +findFiles :: Path Abs Dir -- ^ Root directory to begin with. + -> (Path Abs File -> Bool) -- ^ Predicate to match files. + -> (Path Abs Dir -> Bool) -- ^ Predicate for which directories to traverse. + -> IO [Path Abs File] -- ^ List of matching files. +findFiles dir p traversep = + do (dirs,files) <- catchJust (\ e -> if isPermissionError e + then Just () + else Nothing) + (listDir dir) + (\ _ -> return ([], [])) + filteredFiles <- evaluate $ force (filter p files) + filteredDirs <- filterM (fmap not . isSymLink) dirs + subResults <- + forM filteredDirs + (\entry -> + if traversep entry + then findFiles entry p traversep + else return []) + return (concat (filteredFiles : subResults)) + +isSymLink :: Path Abs t -> IO Bool +isSymLink = fmap isSymbolicLink . getSymbolicLinkStatus . toFilePath + +-- | @findInParents f path@ applies @f@ to @path@ and its 'parent's until +-- it finds a 'Just' or reaches the root directory. +findInParents :: MonadIO m => (Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a) +findInParents f path = do + mres <- f path + case mres of + Just res -> return (Just res) + Nothing -> do + let next = parent path + if next == path + then return Nothing + else findInParents f next diff --git a/src/main/Test.hs b/src/main/Test.hs --- a/src/main/Test.hs +++ b/src/main/Test.hs @@ -30,7 +30,7 @@ reformat :: Config -> S.ByteString -> ByteString reformat cfg code = either (("-- " <>) . L8.pack) L.toLazyByteString $ - HIndent.reformat cfg (Just HIndent.defaultExtensions) code + HIndent.reformat cfg (Just HIndent.defaultExtensions) Nothing code -- | Convert the Markdone document to Spec benchmarks. toSpec :: [Markdone] -> Spec