hindent 5.2.2 → 5.2.3
raw patch · 12 files changed
+1026/−683 lines, 12 filesnew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ HIndent.Pretty: instance HIndent.Pretty.Pretty Language.Haskell.Exts.Syntax.GadtDecl
+ HIndent.Types: [configLineBreaks] :: Config -> [String]
- HIndent: reformat :: Config -> Maybe [Extension] -> ByteString -> Either String Builder
+ HIndent: reformat :: Config -> Maybe [Extension] -> Maybe FilePath -> ByteString -> Either String Builder
- HIndent.Types: Config :: !Int64 -> !Int64 -> !Bool -> !Bool -> Config
+ HIndent.Types: Config :: !Int64 -> !Int64 -> !Bool -> !Bool -> [String] -> Config
Files
- CHANGELOG.md +13/−0
- README.md +3/−3
- TESTS.md +172/−29
- elisp/hindent.el +325/−325
- hindent.cabal +5/−5
- src/HIndent.hs +34/−26
- src/HIndent/Pretty.hs +353/−183
- src/HIndent/Types.hs +17/−8
- src/main/Benchmark.hs +2/−2
- src/main/Main.hs +3/−3
- src/main/Path/Find.hs +98/−98
- src/main/Test.hs +1/−1
CHANGELOG.md view
@@ -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
README.md view
@@ -1,10 +1,10 @@-# hindent [](https://hackage.haskell.org/package/hindent) [](https://travis-ci.org/chrisdone/hindent)+# hindent [](https://hackage.haskell.org/package/hindent) [](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:
TESTS.md view
@@ -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|] ```
elisp/hindent.el view
@@ -1,325 +1,325 @@-;;; hindent.el --- Indent haskell code using the "hindent" program--;; Copyright (c) 2014 Chris Done. All rights reserved.--;; Author: Chris Done <chrisdone@gmail.com>-;; 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 <http://www.gnu.org/licenses/>.--;;; 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 <chrisdone@gmail.com> +;; 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 <http://www.gnu.org/licenses/>. + +;;; 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.cabal view
@@ -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: <https://github.com/chrisdone/hindent>+ See the Github page for usage\/explanation: <https://github.com/commercialhaskell/hindent> 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/
src/HIndent.hs view
@@ -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 "<interactive>" 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 ]
src/HIndent/Pretty.hs view
@@ -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+ -- <https://github.com/haskell-suite/haskell-src-exts/issues/328>+ 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)
src/HIndent/Types.hs view
@@ -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.
src/main/Benchmark.hs view
@@ -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 [] = []-
src/main/Main.hs view
@@ -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)
src/main/Path/Find.hs view
@@ -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
src/main/Test.hs view
@@ -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