hindent 5.2.1 → 5.2.2
raw patch · 10 files changed
+1117/−360 lines, 10 filesdep ~basePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base
API changes (from Hackage documentation)
+ HIndent.Pretty: instance HIndent.Pretty.Pretty Language.Haskell.Exts.Syntax.BooleanFormula
+ HIndent.Pretty: instance HIndent.Pretty.Pretty Language.Haskell.Exts.Syntax.TypeEqn
+ HIndent.Types: [configSortImports] :: Config -> !Bool
- HIndent.Types: CommentAfterLine :: SomeComment -> NodeComment
+ HIndent.Types: CommentAfterLine :: SrcSpan -> SomeComment -> NodeComment
- HIndent.Types: CommentBeforeLine :: SomeComment -> NodeComment
+ HIndent.Types: CommentBeforeLine :: SrcSpan -> SomeComment -> NodeComment
- HIndent.Types: CommentSameLine :: SomeComment -> NodeComment
+ HIndent.Types: CommentSameLine :: SrcSpan -> SomeComment -> NodeComment
- HIndent.Types: Config :: !Int64 -> !Int64 -> !Bool -> Config
+ HIndent.Types: Config :: !Int64 -> !Int64 -> !Bool -> !Bool -> Config
Files
- CHANGELOG.md +8/−1
- README.md +10/−0
- TESTS.md +542/−58
- elisp/hindent.el +58/−48
- hindent.cabal +1/−1
- src/HIndent.hs +11/−8
- src/HIndent/Pretty.hs +422/−209
- src/HIndent/Types.hs +9/−6
- src/main/Main.hs +13/−7
- src/main/Test.hs +43/−22
CHANGELOG.md view
@@ -1,4 +1,11 @@-5.1.1:+5.2.2:++ * Parallel list comprehensions+ * Leave do, lambda, lambda-case on previous line of $+ * Misc fixes++5.2.1:+ * Fix hanging on large constraints * Render multi-line comments * Rename --tab-size to --indent-size
README.md view
@@ -47,6 +47,8 @@ force-trailing-newline: true ``` +By default, HIndent preserves the newline or lack of newline in your input. With `force-trailing-newline`, it will make sure there is always a trailing newline.+ ## Emacs In@@ -82,6 +84,14 @@ much trouble you can try [vim-textobj-haskell](https://github.com/gilligan/vim-textobj-haskell) which provides a text object for top level bindings.++In order to format an entire source file execute:++ :%!hindent++Alternatively you could use the+[vim-hindent](https://github.com/alx741/vim-hindent) plugin which runs hindent+automatically when a Haskell file is saved. ## Atom
TESTS.md view
@@ -28,6 +28,17 @@ ) where ``` +Exports, indentation 4++``` haskell 4+module X+ ( x+ , y+ , Z+ , P(x, z)+ ) where+```+ # Imports Import lists@@ -41,6 +52,18 @@ import Data.Text hiding (a, b, c) ``` +Sorted++```haskell given+import B+import A+```++```haskell expect+import A+import B+```+ # Declarations Type declaration@@ -49,6 +72,16 @@ type EventSource a = (AddHandler a, a -> IO ()) ``` +Type declaration with infix promoted type constructor++```haskell+fun1 :: Def ('[ Ref s (Stored Uint32), IBool] 'T.:-> IBool)+fun1 = undefined++fun2 :: Def ('[ Ref s (Stored Uint32), IBool] ':-> IBool)+fun2 = undefined+```+ Instance declaration without decls ``` haskell@@ -80,32 +113,76 @@ -- \!a yields parse error on input ‘\!’ ``` -List comprehensions+List comprehensions, short ``` haskell+map f xs = [f x | x <- xs]+```++List comprehensions, long++``` haskell defaultExtensions = [ e- | e@EnableExtension {} <- knownExtensions ] \\+ | EnableExtension {extensionField1 = extensionField1} <-+ knownExtensions knownExtensions+ , let a = b+ -- comment+ , let c = d+ -- comment+ ]+```++List comprehensions with operators++```haskell+defaultExtensions =+ [e | e@EnableExtension {} <- knownExtensions] \\ map EnableExtension badExtensions ``` -Record indentation+Parallel list comprehension, short +```haskell+zip xs ys = [(x, y) | x <- xs | y <- ys]+```++Parallel list comprehension, long++```haskell+fun xs ys =+ [ (alphaBetaGamma, deltaEpsilonZeta)+ | x <- xs+ , z <- zs+ | y <- ys+ , cond+ , let t = t+ ]+```++Record, short+ ``` haskell getGitProvider :: EventProvider GitRecord () getGitProvider =- EventProvider- { getModuleName = "Git"- , getEvents = getRepoCommits- }+ EventProvider {getModuleName = "Git", getEvents = getRepoCommits} ``` -Records again+Record, medium ``` haskell commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event commitToEvent gitFolderPath timezone commit = Event.Event+ {pluginName = getModuleName getGitProvider, eventIcon = "glyphicon-cog"}+```++Record, long++``` haskell+commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event+commitToEvent gitFolderPath timezone commit =+ Event.Event { pluginName = getModuleName getGitProvider , eventIcon = "glyphicon-cog" , eventDate = localTimeToUTC timezone (commitDate commit)@@ -123,16 +200,156 @@ _ -> error $ "Unknown month " ++ month ``` -Operators+Operators, bad ``` haskell x =- Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*> Just thisissolong <*>- Just stilllonger+ Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*>+ Just thisissolong <*>+ Just stilllonger <*>+ evenlonger ``` +Operators, good++```haskell pending+x =+ Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*>+ Just thisissolong <*> Just stilllonger <*> evenlonger+```++Operator with `do`++```haskell+for xs $ do+ left x+ right x+```++Operator with lambda++```haskell+for xs $ \x -> do+ left x+ right x+```++Operator with lambda-case++```haskell+for xs $ \case+ Left x -> x+```++Type application++```haskell+fun @Int 12+```++Transform list comprehensions++```haskell+list =+ [ (x, y, map the v)+ | x <- [1 .. 10]+ , y <- [1 .. 10]+ , let v = x + y+ , then group by v using groupWith+ , then take 10+ , then group using permutations+ , t <- concat v+ , then takeWhile by t < 3+ ]+```++Type families++```haskell+type family Id a+```++Type family annotations++``` haskell+type family Id a :: *+```++Type family instances++```haskell+type instance Id Int = Int+```++Type family dependencies++```haskell+type family Id a = r | r -> a+```++Binding implicit parameters++```haskell+f =+ let ?x = 42+ in f+```++Closed type families++```haskell+type family Closed (a :: k) :: Bool where+ Closed x = 'True+```++# Template Haskell++Expression brackets++```haskell+add1 x = [|x + 1|]+```++Pattern brackets++```haskell+mkPat = [p|(x, y)|]+```++Type brackets++```haskell+foo :: $([t|Bool|]) -> a+```+ # 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+longLongFunction ::+ ReaderT r (WriterT w (StateT s m)) a+ -> StateT s (WriterT w (ReaderT r m)) a+```++Class constraints should leave :: on same line++``` haskell pending+-- see https://github.com/chrisdone/hindent/pull/266#issuecomment-244182805+fun ::+ (Class a, Class b)+ => foo bar mu zot+ -> foo bar mu zot+ -> c+```+ Class constraints ``` haskell@@ -147,8 +364,64 @@ fun :: (a, b, c) -> (a, b) ``` +Quasiquotes in types++```haskell+fun :: [a|bc|]+```++Default signatures++```haskell+-- https://github.com/chrisdone/hindent/issues/283+class Foo a where+ bar :: a -> a -> a+ default bar :: Monoid a =>+ a -> a -> a+ bar = mappend+```++Implicit parameters++```haskell+f+ :: (?x :: Int)+ => Int+```++Promoted list (issue #348)++```haskell+a :: A '[ 'True]+a = undefined++-- nested promoted list with multiple elements.+b :: A '[ '[ 'True, 'False], '[ 'False, 'True]]+b = undefined+```++Promoted list with a tuple (issue #348)++```haskell+a :: A '[ '( a, b, c, d)]+a = undefined++-- nested promoted tuples.+b :: A '[ '( 'True, 'False, '[], '( 'False, 'True))]+b = undefined+```+ # Function declarations +Prefix notation for operators++``` haskell+(+)+ :: Num a+ => a -> a -> a+(+) a b = a+```+ Where clause ``` haskell@@ -227,6 +500,73 @@ ] ``` +Long line, function application++```haskell+test = do+ alphaBetaGamma deltaEpsilonZeta etaThetaIota kappaLambdaMu nuXiOmicron piRh79+ alphaBetaGamma deltaEpsilonZeta etaThetaIota kappaLambdaMu nuXiOmicron piRho80+ alphaBetaGamma+ deltaEpsilonZeta+ etaThetaIota+ kappaLambdaMu+ nuXiOmicron+ piRhoS81+```++Long line, tuple++```haskell+test+ (alphaBetaGamma, deltaEpsilonZeta, etaThetaIota, kappaLambdaMu, nuXiOmicro79)+ (alphaBetaGamma, deltaEpsilonZeta, etaThetaIota, kappaLambdaMu, nuXiOmicron80)+ ( alphaBetaGamma+ , deltaEpsilonZeta+ , etaThetaIota+ , kappaLambdaMu+ , nuXiOmicronP81)+```++Long line, tuple section++```haskell+test+ (, alphaBetaGamma, , deltaEpsilonZeta, , etaThetaIota, kappaLambdaMu, nu79, )+ (, alphaBetaGamma, , deltaEpsilonZeta, , etaThetaIota, kappaLambdaMu, , n80, )+ (+ , alphaBetaGamma+ ,+ , deltaEpsilonZeta+ ,+ , etaThetaIota+ , kappaLambdaMu+ ,+ , nu81+ ,)+```++# Record syntax++Pattern matching, short++```haskell+fun Rec {alpha = beta, gamma = delta, epsilon = zeta, eta = theta, iota = kappa} = do+ beta + delta + zeta + theta + kappa+```++Pattern matching, long++```haskell+fun Rec { alpha = beta+ , gamma = delta+ , epsilon = zeta+ , eta = theta+ , iota = kappa+ , lambda = mu+ } =+ beta + delta + zeta + theta + kappa + mu + beta + delta + zeta + theta + kappa+```+ # Johan Tibell compatibility checks Basic example from Tibbe's style@@ -282,17 +622,15 @@ ``` haskell bar :: IO () bar =- forM_ [1, 2, 3] $- \n -> do+ forM_ [1, 2, 3] $ \n -> do putStrLn "Here comes a number!" print n foo :: IO () foo =- alloca 10 $- \a ->- alloca 20 $- \b -> cFunction fooo barrr muuu (fooo barrr muuu) (fooo barrr muuu)+ alloca 10 $ \a ->+ alloca 20 $ \b ->+ cFunction fooo barrr muuu (fooo barrr muuu) (fooo barrr muuu) ``` # Comments@@ -338,10 +676,37 @@ ) , 3 ]+ -- in the end of the function+ where+ alpha = alpha+ -- between alpha and beta+ beta = beta+ -- after beta foo = 1 -- after foo++gamma = do+ delta+ epsilon+ -- in the end of a do-block 1++gamma = do+ delta+ epsilon+ -- the very last block is detected differently ``` +Doesn't work yet (wrong comment position detection)++```haskell pending+gamma = do+ -- in the beginning of a do-block+ delta+ where+ -- before alpha+ alpha = alpha+```+ Haddock comments ``` haskell@@ -455,14 +820,16 @@ ``` haskell c :: forall new.- (Settable "pitch" Pitch (Map.AsMap (new Map.:\ "pitch")) new- ,Default (Book' (Map.AsMap (new Map.:\ "pitch"))))+ ( 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- ,Foooooooooooooooooooooooooooooooooooooooooo)+ :: ( Foooooooooooooooooooooooooooooooooooooooooo+ , Foooooooooooooooooooooooooooooooooooooooooo+ ) => A ``` @@ -487,9 +854,7 @@ trans One e n = M.singleton (Query Unmarked (Mark NonExistent)) -- The goal of this is to fail always- (emptyImage- { notPresent = S.singleton (TransitionResult Two (Just A) n)- })+ (emptyImage {notPresent = S.singleton (TransitionResult Two (Just A) n)}) ``` sheyll explicit forall in instances #218@@ -504,9 +869,17 @@ tfausak support shebangs #208 -``` haskell+``` haskell given #!/usr/bin/env stack -- stack runghc+main =+ pure ()+-- https://github.com/chrisdone/hindent/issues/208+```++``` haskell expect+#!/usr/bin/env stack+-- stack runghc main = pure () -- https://github.com/chrisdone/hindent/issues/208 ```@@ -518,8 +891,8 @@ import Data.List import Data.Maybe -import MyProject import FooBar+import MyProject import GHC.Monad @@ -542,9 +915,9 @@ Wrapped import list shouldn't add newline ```haskell-import TooLongList+import ATooLongList (alpha, beta, gamma, delta, epsilon, zeta, eta, theta)-import Test+import B ``` radupopescu `deriving` keyword not aligned with pipe symbol for type declarations@@ -561,6 +934,117 @@ deriving (Show) ``` +sgraf812 top-level pragmas should not add an additional newline #255++``` haskell+-- https://github.com/chrisdone/hindent/issues/255+{-# INLINE f #-}+f :: Int -> Int+f n = n+```++ivan-timokhin breaks code with type operators #277++```haskell+-- https://github.com/chrisdone/hindent/issues/277+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}++type m ~> n = ()++class (a :< b) c+```++ivan-timokhin variables swapped around in constraints #278++```haskell+-- https://github.com/chrisdone/hindent/issues/278+data Link c1 c2 a c =+ forall b. (c1 a b, c2 b c) =>+ Link (Proxy b)+```++ttuegel qualified infix sections get mangled #273++```haskell+-- https://github.com/chrisdone/hindent/issues/273+import qualified Data.Vector as V++main :: IO ()+main = do+ let _ = foldr1 (V.++) [V.empty, V.empty]+ pure ()++-- more corner cases.+xs = V.empty V.++ V.empty++ys = (++) [] []++cons :: V.Vector a -> V.Vector a -> V.Vector a+cons = (V.++)+```++ivan-timokhin breaks operators type signatures #301++```haskell+-- https://github.com/chrisdone/hindent/issues/301+(+) :: ()+```++cdepillabout Long deriving clauses are not reformatted #289++```haskell+newtype Foo =+ Foo Proxy+ deriving ( Functor+ , Applicative+ , Monad+ , Semigroup+ , Monoid+ , Alternative+ , MonadPlus+ , Foldable+ , Traversable+ )+```++ivan-timokhin Breaks instances with type operators #342++```haskell+-- https://github.com/chrisdone/hindent/issues/342+instance Foo (->)++instance Foo (^>)++instance Foo (T.<^)+```++# MINIMAL pragma++Monad example++```haskell+class A where+ {-# MINIMAL return, ((>>=) | (join, fmap)) #-}+```++Very long names #310++```haskell+class A where+ {-# MINIMAL averylongnamewithnoparticularmeaning+ | ananotherverylongnamewithnomoremeaning #-}+```++NorfairKing Do as left-hand side of an infix operation #296++```haskell+block =+ do ds <- inBraces $ inWhiteSpace declarations+ return $ Block ds+ <?> "block"+```+ # Behaviour checks Unicode@@ -591,36 +1075,36 @@ quasiQuotes = [ ( ''[] , \(typeVariable:_) _automaticPrinter ->- (let presentVar = varE (presentVarName typeVariable)- in lamE- [varP (presentVarName typeVariable)]- [|(let typeString = "[" ++ fst $(presentVar) ++ "]"- in ( typeString- , \xs ->- case fst $(presentVar) of- "GHC.Types.Char" ->- ChoicePresentation- "String"- [ ( "String"- , StringPresentation- "String"- (concatMap- getCh- (map (snd $(presentVar)) xs)))- , ( "List of characters"- , ListPresentation- typeString- (map (snd $(presentVar)) xs))- ]- where getCh (CharPresentation "GHC.Types.Char" ch) =- ch- getCh (ChoicePresentation _ ((_, CharPresentation _ ch):_)) =- ch- getCh _ = ""- _ ->- ListPresentation- typeString- (map (snd $(presentVar)) xs)))|]))+ (let presentVar = varE (presentVarName typeVariable)+ in lamE+ [varP (presentVarName typeVariable)]+ [|(let typeString = "[" ++ fst $(presentVar) ++ "]"+ in ( typeString+ , \xs ->+ case fst $(presentVar) of+ "GHC.Types.Char" ->+ ChoicePresentation+ "String"+ [ ( "String"+ , StringPresentation+ "String"+ (concatMap+ getCh+ (map (snd $(presentVar)) xs)))+ , ( "List of characters"+ , ListPresentation+ typeString+ (map (snd $(presentVar)) xs))+ ]+ where getCh (CharPresentation "GHC.Types.Char" ch) =+ ch+ getCh (ChoicePresentation _ ((_, CharPresentation _ ch):_)) =+ ch+ getCh _ = ""+ _ ->+ ListPresentation+ typeString+ (map (snd $(presentVar)) xs)))|])) ] ```
elisp/hindent.el view
@@ -36,26 +36,34 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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. -This customization is deprecated and ignored."- :group 'haskell+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 'haskell+ :group 'hindent :type 'string :safe #'stringp) (defcustom hindent-line-length 80 "Optionally override the line length."- :group 'haskell+ :group 'hindent :type '(choice (const :tag "Default: 80" 80) (integer :tag "Override" 120)) :safe (lambda (val) (or (integerp val) (not val))))@@ -63,15 +71,15 @@ (defcustom hindent-indent-size 2 "Optionally override the indent size."- :group 'haskell+ :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 'haskell+ "Set to t to run `hindent-reformat-buffer' when a buffer in `hindent-mode' is saved."+ :group 'hindent+ :type 'boolean :safe #'booleanp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;@@ -94,7 +102,7 @@ :init-value nil :keymap hindent-mode-map :lighter " HI"- :group 'haskell+ :group 'hindent :require 'hindent (if hindent-mode (add-hook 'before-save-hook 'hindent--before-save nil t)@@ -110,9 +118,10 @@ ;;;###autoload (defun hindent-reformat-decl ()- "Re-format the current declaration by parsing and pretty- printing it. Comments are preserved, although placement may be- funky."+ "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@@ -132,18 +141,22 @@ "Re-format current declaration, or fill paragraph. Fill paragraph if in a comment, otherwise reformat the current-declaration."+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)))+ (hindent-reformat-decl))) ;;;###autoload (defun hindent-reformat-region (beg end &optional drop-newline)- "Reformat the given region, accounting for indentation."+ "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))@@ -165,17 +178,19 @@ (insert new-string))))) ;;;###autoload-(defun hindent/reformat-decl ()- "See `hindent-reformat-decl'."- (hindent-reformat-decl))+(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 as-is.+ "Reformat the given region from BEG to END as-is. -This is the place where hindent is actually called."+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@@ -205,8 +220,8 @@ (new-str (with-current-buffer temp (when (and drop-newline (not last-decl)) (goto-char (point-max))- (when (looking-back "\n")- (delete-backward-char 1)))+ (when (looking-back "\n" (1- (point)))+ (delete-char -1))) (buffer-string)))) (if (not (string= new-str orig-str)) (let ((line (line-number-at-pos))@@ -219,25 +234,25 @@ (goto-char (point-min)) (forward-line (1- line)) (goto-char (+ (line-beginning-position) col))- (when (looking-back "^[ ]+")+ (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 (&optional use-line-comments)- "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."+(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 (not use-line-comments)- (hindent-in-comment)+ ((and (hindent-in-comment) (save-excursion (goto-char (line-beginning-position)) (hindent-in-comment))) nil)@@ -290,25 +305,20 @@ (point)) (/= (line-beginning-position) (point))) (forward-char -1))- (and (or (eq 'font-lock-comment-delimiter-face- (get-text-property (point) 'face))- (eq 'font-lock-doc-face- (get-text-property (point) 'face))- (eq 'font-lock-comment-face- (get-text-property (point) 'face))- (save-excursion (goto-char (line-beginning-position))- (looking-at "^\-\- ")))- ;; 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 "{-# "))))))+ (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 ()- "Pass in extra arguments, such as extensions and optionally-other things later."- (if (boundp 'haskell-language-extensions)- haskell-language-extensions- '()))+ "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.cabal view
@@ -1,5 +1,5 @@ name: hindent-version: 5.2.1+version: 5.2.2 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. .
src/HIndent.hs view
@@ -153,21 +153,23 @@ cppSplitBlocks inp = modifyLast (inBlock (<> trailing)) . map (classify . mconcat . intersperse "\n") .- groupBy ((==) `on` cppLine) . S8.lines $+ groupBy ((==) `on` nonHaskellLine) . S8.lines $ inp where+ nonHaskellLine :: ByteString -> Bool+ nonHaskellLine src = cppLine src || shebangLine src+ shebangLine :: ByteString -> Bool+ shebangLine = S8.isPrefixOf "#!" cppLine :: ByteString -> Bool cppLine src = any (`S8.isPrefixOf` src) ["#if", "#end", "#else", "#define", "#undef", "#elif"] classify :: ByteString -> CodeBlock- classify text =- if S8.isPrefixOf "#!" text- then Shebang text- else if cppLine text- then CPPDirectives text- else HaskellSource text+ classify text+ | shebangLine text = Shebang text+ | cppLine text = CPPDirectives text+ | otherwise = HaskellSource 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.@@ -399,7 +401,7 @@ -- the State. This allows for a multiple pass approach. collectCommentsBy :: ([NodeComment] -> [NodeComment] -> [NodeComment])- -> (SomeComment -> NodeComment)+ -> (SrcSpan -> SomeComment -> NodeComment) -> (SrcSpan -> SrcSpan -> Bool) -> NodeInfo -> State [Comment] NodeInfo@@ -412,6 +414,7 @@ if predicate nodeSpan (setFilename commentString commentSpan) then Right (cons+ commentSpan ((if multiLine then MultiLine else EndOfLine)
src/HIndent/Pretty.hs view
@@ -15,8 +15,7 @@ import Control.Applicative import Control.Monad.State.Strict hiding (state) import qualified Data.ByteString.Builder as S-import qualified Data.Foldable-import Data.Foldable (traverse_)+import Data.Foldable (for_, traverse_) import Data.Int import Data.List import Data.Maybe@@ -42,7 +41,7 @@ mapM_ (\c' -> do case c' of- CommentBeforeLine c -> do+ CommentBeforeLine _ c -> do case c of EndOfLine s -> write ("--" ++ s) MultiLine s -> write ("{-" ++ s ++ "-}")@@ -53,13 +52,21 @@ mapM_ (\(i, c') -> do case c' of- CommentSameLine c -> do+ CommentSameLine spn c -> do col <- gets psColumn- unless (col == 0) space- writeComment c- CommentAfterLine c -> do+ if col == 0+ then do+ -- write comment keeping original indentation+ let col' = fromIntegral $ srcSpanStartColumn spn - 1+ column col' $ writeComment c+ else do+ space+ writeComment c+ CommentAfterLine spn c -> do when (i == 0) newline- writeComment c+ -- write comment keeping original indentation+ let col = fromIntegral $ srcSpanStartColumn spn - 1+ column col $ writeComment c _ -> return ()) (zip [0 :: Int ..] comments) where@@ -110,7 +117,7 @@ -- | Print all the printers separated by commas. commas :: [Printer ()] -> Printer ()-commas = inter (do comma; space)+commas = inter (write ", ") -- | Print all the printers separated by sep. inter :: Printer () -> [Printer ()] -> Printer ()@@ -191,29 +198,21 @@ then column col dependent else dependent +-- | Wrap.+wrap :: String -> String -> Printer a -> Printer a+wrap open close p = depend (write open) $ p <* write close+ -- | Wrap in parens. parens :: Printer a -> Printer a-parens p =- depend (write "(")- (do v <- p- write ")"- return v)+parens = wrap "(" ")" -- | Wrap in braces. braces :: Printer a -> Printer a-braces p =- depend (write "{")- (do v <- p- write "}"- return v)+braces = wrap "{" "}" -- | Wrap in brackets. brackets :: Printer a -> Printer a-brackets p =- depend (write "[")- (do v <- p- write "]"- return v)+brackets = wrap "[" "]" -- | Write a space. space :: Printer ()@@ -235,11 +234,6 @@ let addingNewline = eol && x /= "\n" when addingNewline newline state <- get- when- hardFail- (guard- (additionalLines == 0 &&- (psColumn state < configMaxColumns (psConfig state)))) let writingNewline = x == "\n" out :: String out =@@ -248,15 +242,21 @@ ' ') <> x else x+ psColumn' =+ if additionalLines > 0+ then fromIntegral (length (concat (take 1 (reverse srclines))))+ else psColumn state + fromIntegral (length out)+ when+ hardFail+ (guard+ (additionalLines == 0 &&+ (psColumn' <= configMaxColumns (psConfig state)))) modify (\s -> s {psOutput = psOutput state <> S.stringUtf8 out ,psNewline = False ,psLine = psLine state + fromIntegral additionalLines ,psEolComment= False- ,psColumn =- if additionalLines > 0- then fromIntegral (length (concat (take 1 (reverse srclines))))- else psColumn state + fromIntegral (length out)})+ ,psColumn = psColumn'}) where srclines = lines x additionalLines = length (filter (== '\n') x)@@ -367,13 +367,22 @@ PList _ ps -> brackets (commas (map pretty ps)) PParen _ e -> parens (pretty e)- PRec _ qname fields ->- do indentSpaces <- getIndentSpaces- depend (do pretty qname- space)- (braces (prefixedLined ","- (map (indented indentSpaces . pretty) fields)))-+ PRec _ qname fields -> do+ let horVariant = do+ pretty qname+ space+ braces $ commas $ map pretty fields+ verVariant =+ depend (pretty qname >> space) $ do+ case fields of+ [] -> write "{}"+ [field] -> braces $ pretty field+ _ -> do+ depend (write "{") $+ prefixedLined "," $ map (depend space . pretty) fields+ newline+ write "}"+ horVariant `ifFitsOnOneLineOrElse` verVariant PAsPat _ n p -> depend (do pretty n write "@")@@ -445,28 +454,28 @@ (lined (map pretty stmts)) Just st -> put st -- | Space out tuples.-exp (Tuple _ boxed exps) =- depend (write (case boxed of- Unboxed -> "(#"- Boxed -> "("))- (do mst <- fitsOnOneLine p- case mst of- Nothing -> prefixedLined ","- (map (depend space . pretty) exps)- Just st -> put st- write (case boxed of- Unboxed -> "#)"- Boxed -> ")"))- where p = inter (write ", ") (map pretty exps)+exp (Tuple _ boxed exps) = do+ let horVariant = parensB boxed $ inter (write ", ") (map pretty exps)+ verVariant = parensB boxed $ prefixedLined "," (map (depend space . pretty) exps)+ mst <- fitsOnOneLine horVariant+ case mst of+ Nothing -> verVariant+ Just st -> put st+ where+ parensB Unboxed = wrap "(#" "#)"+ parensB Boxed = parens -- | Space out tuples.-exp (TupleSection _ boxed mexps) =- depend (write (case boxed of- Unboxed -> "(#"- Boxed -> "("))- (do inter (write ", ") (map (maybe (return ()) pretty) mexps)- write (case boxed of- Unboxed -> "#)"- Boxed -> ")"))+exp (TupleSection _ boxed mexps) = do+ let horVariant = parensB boxed $ inter (write ", ") (map (maybe (return ()) pretty) mexps)+ verVariant =+ parensB boxed $ prefixedLined "," (map (maybe (return ()) (depend space . pretty)) mexps)+ mst <- fitsOnOneLine horVariant+ case mst of+ Nothing -> verVariant+ Just st -> put st+ where+ parensB Unboxed = wrap "(#" "#)"+ parensB Boxed = parens -- | Infix apps, same algorithm as ChrisDone at the moment. exp e@(InfixApp _ a op b) = infixApp e a op b Nothing@@ -534,36 +543,53 @@ newline indented (-4) (depend (write "in ") (pretty e)))-exp (ListComp _ e qstmt) =- brackets (do space- pretty e- unless (null qstmt)- (do newline- indented (-1)- (write "|")- prefixedLined ","- (map (\x -> do space- pretty x- space)- qstmt)))-exp (TypeApp _ _) = error "FIXME: No implementation for TypeApp"+exp (ListComp _ e qstmt) = do+ let horVariant = brackets $ do+ pretty e+ write " | "+ commas $ map pretty qstmt+ verVariant = do+ write "[ "+ pretty e+ newline+ depend (write "| ") $ prefixedLined ", " $ map pretty qstmt+ newline+ write "]"+ horVariant `ifFitsOnOneLineOrElse` verVariant++exp (ParComp _ e qstmts) = do+ let horVariant = brackets $ do+ pretty e+ for_ qstmts $ \qstmt -> do+ write " | "+ commas $ map pretty qstmt+ verVariant = do+ depend (write "[ ") $ pretty e+ newline+ for_ qstmts $ \qstmt -> do+ depend (write "| ") $ prefixedLined ", " $ map pretty qstmt+ newline+ write "]"+ horVariant `ifFitsOnOneLineOrElse` verVariant++exp (TypeApp _ t) = do+ write "@"+ pretty t+ exp (ExprHole {}) = write "_" exp (NegApp _ e) = depend (write "-") (pretty e)-exp (Lambda _ ps e) =- depend- (write "\\")- (do spaced- (map- (\(i,x) -> do- case (i, x) of- (0,PIrrPat {}) -> space- (0,PBangPat {}) -> space- _ -> return ()- pretty x)- (zip [0 :: Int ..] ps))- swing (write " ->") (pretty e))+exp (Lambda _ ps e) = do+ write "\\"+ spaced [ do case (i, x) of+ (0, PIrrPat {}) -> space+ (0, PBangPat {}) -> space+ _ -> return ()+ pretty x+ | (i, x) <- zip [0 :: Int ..] ps+ ]+ swing (write " ->") $ pretty e exp (Paren _ e) = parens (pretty e) exp (Case _ e alts) = do depend (write "case ")@@ -651,6 +677,8 @@ exp (Lit _ lit) = prettyInternal lit exp (Var _ q) = case q of Special _ Cons{} -> parens (pretty q)+ Qual _ _ (Symbol _ _) -> parens (pretty q)+ UnQual _ (Symbol _ _) -> parens (pretty q) _ -> pretty q exp (IPVar _ q) = pretty q exp (Con _ q) = case q of@@ -674,8 +702,6 @@ exp x@ParArrayFromTo{} = pretty' x exp x@ParArrayFromThenTo{} = pretty' x exp x@ParArrayComp{} = pretty' x-exp ParComp{} =- error "FIXME: No implementation for ParComp." exp (OverloadedLabel _ label) = string ('#' : label) instance Pretty IPName where@@ -689,16 +715,25 @@ prettyInternal x = case x of QualStmt _ s -> pretty s- ThenTrans{} ->- error "FIXME: No implementation for ThenTrans."- ThenBy{} ->- error "FIXME: No implementation for ThenBy."- GroupBy{} ->- error "FIXME: No implementation for GroupBy."- GroupUsing{} ->- error "FIXME: No implementation for GroupUsing."- GroupByUsing{} ->- error "FIXME: No implementation for GroupByUsing."+ ThenTrans _ s -> do+ write "then "+ pretty s+ ThenBy _ s t -> do+ write "then "+ pretty s+ write " by "+ pretty t+ GroupBy _ s -> do+ write "then group by "+ pretty s+ GroupUsing _ s -> do+ write "then group using "+ pretty s+ GroupByUsing _ s t -> do+ write "then group by "+ pretty s+ write " using "+ pretty t instance Pretty Decl where prettyInternal = decl'@@ -734,8 +769,7 @@ decl (ClassDecl _ ctx dhead fundeps decls) = do depend (write "class ") (withCtx ctx- (depend (do pretty dhead- space)+ (depend (do pretty dhead) (depend (unless (null fundeps) (do write " | " commas (map pretty fundeps)))@@ -750,8 +784,42 @@ (depend (write " = ") (pretty typ'))) -decl TypeFamDecl{} =- error "FIXME: No implementation for TypeFamDecl."+decl (TypeFamDecl _ declhead result injectivity) = do+ write "type family "+ pretty declhead+ case result of+ Just r -> do+ space+ let sep = case r of+ KindSig _ _ -> "::"+ TyVarSig _ _ -> "="+ write sep+ space+ pretty r+ Nothing -> return ()+ case injectivity of+ Just i -> do+ space+ pretty i+ Nothing -> return ()+decl (ClosedTypeFamDecl _ declhead result injectivity instances) = do+ write "type family "+ pretty declhead+ for_ result $ \r -> do+ space+ let sep = case r of+ KindSig _ _ -> "::"+ TyVarSig _ _ -> "="+ write sep+ space+ pretty r+ for_ injectivity $ \i -> do+ space+ pretty i+ space+ write "where"+ newline+ indentedBlock (lined (map pretty instances)) decl (DataDecl _ dataornew ctx dhead condecls mderivs) = do depend (do pretty dataornew space)@@ -793,19 +861,35 @@ pretty name write " #-}"+decl (MinimalPragma _ (Just formula)) =+ wrap "{-# " " #-}" $ do+ depend (write "MINIMAL ") $ pretty formula decl x' = pretty' x' +instance Pretty TypeEqn where+ prettyInternal (TypeEqn _ in_ out_) = do+ pretty in_+ write " = "+ pretty out_+ instance Pretty Deriving where prettyInternal (Deriving _ heads) =- do write "deriving"- space- let heads' =- if length heads == 1- then map stripParens heads- else heads- parens (commas (map pretty heads'))- where stripParens (IParen _ iRule) = stripParens iRule- stripParens x = x+ depend (write "deriving" >> space) $ do+ let heads' =+ if length heads == 1+ then map stripParens heads+ else heads+ maybeDerives <- fitsOnOneLine $ parens (commas (map pretty heads'))+ case maybeDerives of+ Nothing -> formatMultiLine heads'+ Just derives -> put derives+ where+ stripParens (IParen _ iRule) = stripParens iRule+ stripParens x = x+ formatMultiLine derives = do+ depend (write "( ") $ prefixedLined ", " (map pretty derives)+ newline+ write ")" instance Pretty Alt where prettyInternal x =@@ -824,20 +908,23 @@ prettyInternal x = case x of ClassA _ name types -> spaced (pretty name : map pretty types)- i@InfixA{} -> pretty' i- IParam{} -> error "FIXME: No implementation for IParam."- EqualP _ a b ->- do pretty a- write " ~ "- pretty b+ i@InfixA {} -> pretty' i+ IParam _ name ty -> do+ pretty name+ write " :: "+ pretty ty+ EqualP _ a b -> do+ pretty a+ write " ~ "+ pretty b ParenA _ asst -> parens (pretty asst)- AppA _ name tys -> spaced (pretty name : map pretty tys)+ AppA _ name tys -> spaced (pretty name : map pretty (reverse tys)) WildCardA _ name -> case name of Nothing -> write "_"- Just n ->- do write "_"- pretty n+ Just n -> do+ write "_"+ pretty n instance Pretty BangType where prettyInternal x =@@ -1025,9 +1112,12 @@ DHInfix _ var name -> do pretty var space- write "`"- pretty name- write "`"+ case name of+ Ident _ _ -> do+ write "`"+ pretty name+ write "`"+ Symbol _ _ -> pretty name DHApp _ dhead var -> depend (pretty dhead) (do space@@ -1064,6 +1154,7 @@ ,interOf newline (map (\case r@TypeSig{} -> (1,pretty r)+ r@InlineSig{} -> (1, pretty r) r -> (2,pretty r)) decls))]) newline@@ -1078,42 +1169,93 @@ XmlPage{} -> error "FIXME: No implementation for XmlPage." XmlHybrid{} -> error "FIXME: No implementation for XmlHybrid." --- | Format imports, preserving empty newlines between them.+-- | Format imports, preserving empty newlines between groups. formatImports :: [ImportDecl NodeInfo] -> Printer ()-formatImports imps =- mapM_ formatImport (zip [1 ..] (zip (Nothing : map Just imps) imps))+formatImports =+ sequence_ .+ intersperse (newline >> newline) .+ map formatImportGroup . groupAdjacentBy atNextLine where- formatImport (i, (mprev, current)) = do- when (difference > 1) newline- pretty current- unless (i == length imps) newline+ atNextLine import1 import2 =+ let end1 = srcSpanEndLine (srcInfoSpan (nodeInfoSpan (ann import1)))+ start2 = srcSpanStartLine (srcInfoSpan (nodeInfoSpan (ann import2)))+ in start2 - end1 <= 1+ formatImportGroup imps = do+ shouldSortImports <- gets $ configSortImports . psConfig+ let imps1 =+ if shouldSortImports+ then sortOn moduleVisibleName imps+ else imps+ sequence_ . intersperse newline $ map formatImport imps1 where- difference =- case mprev of- Nothing -> 0- Just prev ->- fst (srcSpanStart (srcInfoSpan (nodeInfoSpan (ann current)))) -- fst (srcSpanEnd (srcInfoSpan (nodeInfoSpan (ann prev ))))+ moduleVisibleName idecl =+ let ModuleName _ name = importModule idecl+ in name+ formatImport = pretty +groupAdjacentBy :: (a -> a -> Bool) -> [a] -> [[a]]+groupAdjacentBy _ [] = []+groupAdjacentBy adj items = xs : groupAdjacentBy adj rest+ where+ (xs, rest) = spanAdjacentBy adj items++spanAdjacentBy :: (a -> a -> Bool) -> [a] -> ([a], [a])+spanAdjacentBy _ [] = ([], [])+spanAdjacentBy _ [x] = ([x], [])+spanAdjacentBy adj (x:xs@(y:_))+ | adj x y =+ let (xs', rest') = spanAdjacentBy adj xs+ in (x : xs', rest')+ | otherwise = ([x], xs)+ instance Pretty Bracket where prettyInternal x = case x of ExpBracket _ p ->- brackets (depend (write "|")- (do pretty p- write "|"))- PatBracket _ _ ->- error "FIXME: No implementation for PatBracket."- TypeBracket _ _ ->- error "FIXME: No implementation for TypeBracket."+ brackets+ (depend+ (write "|")+ (do pretty p+ write "|"))+ PatBracket _ p ->+ brackets+ (depend+ (write "p|")+ (do pretty p+ write "|"))+ TypeBracket _ ty ->+ brackets+ (depend+ (write "t|")+ (do pretty ty+ write "|")) d@(DeclBracket _ _) -> pretty' d instance Pretty IPBind where prettyInternal x = case x of- IPBind _ _ _ ->- error "FIXME: No implementation for IPBind."+ IPBind _ name expr -> do+ pretty name+ space+ write "="+ space+ pretty expr +instance Pretty BooleanFormula where+ prettyInternal (VarFormula _ i@(Ident _ _)) = pretty' i+ prettyInternal (VarFormula _ (Symbol _ s)) = write "(" >> string s >> write ")"+ prettyInternal (AndFormula _ fs) = do+ maybeFormulas <- fitsOnOneLine $ inter (write ", ") $ map pretty fs+ case maybeFormulas of+ Nothing -> prefixedLined ", " (map pretty fs)+ Just formulas -> put formulas+ prettyInternal (OrFormula _ fs) = do+ maybeFormulas <- fitsOnOneLine $ inter (write " | ") $ map pretty fs+ case maybeFormulas of+ Nothing -> prefixedLined "| " (map pretty fs)+ Just formulas -> put formulas+ prettyInternal (ParenFormula _ f) = parens $ pretty f+ -------------------------------------------------------------------------------- -- * Fallback printers @@ -1156,7 +1298,9 @@ prettyInternal x = pretty' x instance Pretty Name where- prettyInternal = pretty' -- Var+ prettyInternal x = case x of+ Ident _ _ -> pretty' x -- Identifiers.+ Symbol _ s -> string s -- Symbols instance Pretty QName where prettyInternal =@@ -1199,7 +1343,8 @@ maybe (return ()) (\exports -> do newline- indented 2 (pretty exports))+ indentSpaces <- getIndentSpaces+ indented indentSpaces (pretty exports)) mexports write " where" @@ -1360,11 +1505,17 @@ match :: Match NodeInfo -> Printer () match (Match _ name pats rhs' mbinds) =- do depend (do pretty name+ do depend (do case name of+ Ident _ _ ->+ pretty name+ Symbol _ _ ->+ do write "("+ pretty name+ write ")" space)- (spaced (map pretty pats))+ (spaced (map pretty pats)) withCaseContext False (pretty rhs')- Data.Foldable.forM_ mbinds bindingGroup+ for_ mbinds bindingGroup match (InfixMatch _ pat1 name pats rhs' mbinds) = do depend (do pretty pat1 space@@ -1375,14 +1526,17 @@ (do space spaced (map pretty pats)) withCaseContext False (pretty rhs')- Data.Foldable.forM_ mbinds bindingGroup+ for_ mbinds bindingGroup -- | Format contexts with spaces and commas between class constraints. context :: Context NodeInfo -> Printer () context ctx = case ctx of CxSingle _ a -> pretty a- CxTuple _ as -> parens (prefixedLined "," (map pretty as))+ CxTuple _ as -> do+ depend (write "( ") $ prefixedLined ", " (map pretty as)+ newline+ write ")" CxEmpty _ -> parens (return ()) unboxParens :: Printer a -> Printer a@@ -1403,7 +1557,8 @@ do write "forall " spaced (map pretty ts) write ". ")- (withCtx ctx (pretty ty))+ (do indentSpaces <- getIndentSpaces+ withCtx ctx (indented indentSpaces (pretty ty))) TyFun _ a b -> depend (do pretty a write " -> ")@@ -1421,9 +1576,22 @@ brackets (do write ":" pretty t write ":")- TyApp _ f a -> spaced [pretty f,pretty a]+ TyApp _ f a -> spaced [pretty f, pretty a] TyVar _ n -> pretty n- TyCon _ p -> pretty p+ 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@@ -1443,16 +1611,37 @@ 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{} -> error "FIXME: No implementation for TySplice."+ TySplice _ splice -> pretty splice TyWildCard _ name -> case name of Nothing -> write "_" Just n -> do write "_" pretty n- _ -> error ("FIXME: No implementation for " ++ show x)+ TyQuasiQuote _ n s ->+ brackets (depend (do string n+ write "|")+ (do string s+ write "|")) +prettyTopName :: Name NodeInfo -> Printer ()+prettyTopName x@Ident{} = pretty x+prettyTopName x@Symbol{} = parens $ pretty x+ -- | Specially format records. Indent where clauses only 2 spaces. decl' :: Decl NodeInfo -> Printer () -- | Pretty print type signatures like@@ -1463,20 +1652,19 @@ -- -> (Char -> X -> Y) -- -> IO () ---decl' (TypeSig _ names ty') =- do mst <- fitsOnOneLine (declTy ty')- case mst of- Just{} -> depend (do inter (write ", ")- (map pretty names)- write " :: ")- (declTy ty')- Nothing -> do inter (write ", ")- (map pretty names)- newline- indentSpaces <- getIndentSpaces- indented indentSpaces- (depend (write ":: ")- (declTy ty'))+decl' (TypeSig _ names ty') = do+ mst <- fitsOnOneLine (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')) where declTy dty = case dty of@@ -1512,7 +1700,7 @@ withCaseContext False $ do pretty pat pretty rhs'- Data.Foldable.forM_ mbinds bindingGroup+ for_ mbinds bindingGroup -- | Handle records specially for a prettier display (see guide). decl' (DataDecl _ dataornew ctx dhead condecls@[_] mderivs)@@ -1548,7 +1736,7 @@ depend (do pretty name write " ") (do depend (write "{")- (prefixedLined ","+ (prefixedLined ", " (map (depend space . pretty) fields)) write "}") conDecl x = case x of@@ -1562,7 +1750,7 @@ depend (do pretty name space) (do depend (write "{")- (prefixedLined ","+ (prefixedLined ", " (map pretty fields)) write "}") @@ -1584,17 +1772,20 @@ recUpdateExpr :: Printer () -> [FieldUpdate NodeInfo] -> Printer () recUpdateExpr expWriter updates = do+ ifFitsOnOneLineOrElse hor $ do expWriter newline- mapM_- (\(i,x) -> do- if i == 0- then write "{ "- else write ", "- pretty x- newline)- (zip [0::Int ..] updates)- write "}"+ updatesHor `ifFitsOnOneLineOrElse` updatesVer+ where+ hor = do+ expWriter+ space+ updatesHor+ updatesHor = braces $ commas $ map pretty updates+ updatesVer = do+ depend (write "{ ") $ prefixedLined ", " $ map pretty updates+ newline+ write "}" -------------------------------------------------------------------------------- -- Predicates@@ -1616,6 +1807,20 @@ then Just st' { psHardLimit = psHardLimit st } else Nothing) +-- | If first printer fits, use it, else use the second one.+ifFitsOnOneLineOrElse :: Printer a -> Printer a -> Printer a+ifFitsOnOneLineOrElse a b = do+ stOrig <- get+ put stOrig{psHardLimit = True}+ res <- fmap Just a <|> return Nothing+ case res of+ Just r -> do+ modify $ \st -> st{psHardLimit = psHardLimit stOrig}+ return r+ Nothing -> do+ put stOrig+ b+ bindingGroup :: Binds NodeInfo -> Printer () bindingGroup binds = do newline@@ -1631,30 +1836,38 @@ -> Maybe Int64 -> Printer () infixApp e a op b indent =- do msg <-- fitsOnOneLine- (spaced (map (\link ->- case link of- OpChainExp e' -> pretty e'- OpChainLink qop -> pretty qop)- (flattenOpChain e)))- case msg of- Nothing -> do prettyWithIndent a- space- pretty op- newline- case indent of- Nothing -> prettyWithIndent b- Just col ->- do indentSpaces <- getIndentSpaces- column (col + indentSpaces)- (prettyWithIndent b)- Just st -> put st- where prettyWithIndent e' =- case e' of- (InfixApp _ a' op' b') ->- infixApp e' a' op' b' indent- _ -> pretty e'+ hor `ifFitsOnOneLineOrElse` ver+ where+ hor =+ spaced+ [ case link of+ OpChainExp e' -> pretty e'+ OpChainLink qop -> pretty qop+ | link <- flattenOpChain e+ ]+ ver = do+ prettyWithIndent a+ beforeRhs <- case a of+ Do _ _ -> do+ indentSpaces <- getIndentSpaces+ column (fromMaybe 0 indent + indentSpaces + 3) (newline >> pretty op) -- 3 = "do "+ return space+ _ -> space >> pretty op >> return newline+ case b of+ Lambda{} -> space >> pretty b+ LCase{} -> space >> pretty b+ Do _ stmts -> swing (write " do") $ lined (map pretty stmts)+ _ -> do+ beforeRhs+ case indent of+ Nothing -> prettyWithIndent b+ Just col -> do+ indentSpaces <- getIndentSpaces+ column (col + indentSpaces) (prettyWithIndent b)+ prettyWithIndent e' =+ case e' of+ InfixApp _ a' op' b' -> infixApp e' a' op' b' indent+ _ -> pretty e' -- | A link in a chain of operator applications. data OpChainLink l
src/HIndent/Types.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-}@@ -63,6 +62,7 @@ { configMaxColumns :: !Int64 -- ^ Maximum columns to fit code into ideally. , configIndentSpaces :: !Int64 -- ^ How many spaces to indent? , configTrailingNewline :: !Bool -- ^ End with a newline.+ , configSortImports :: !Bool -- ^ Sort imports in groups. } instance FromJSON Config where@@ -74,7 +74,8 @@ (v Y..:? "indent-size" <|> v Y..:? "tab-size") <*> fmap (fromMaybe (configTrailingNewline defaultConfig))- (v Y..:? "force-trailing-newline")+ (v Y..:? "force-trailing-newline") <*>+ fmap (fromMaybe (configSortImports defaultConfig)) (v Y..:? "sort-imports") parseJSON _ = fail "Expected Object for Config value" -- | Default style configuration.@@ -84,6 +85,7 @@ { configMaxColumns = 80 , configIndentSpaces = 2 , configTrailingNewline = True+ , configSortImports = True } -- | Some comment to print.@@ -93,16 +95,17 @@ deriving (Show, Ord, Eq) -- | Comment associated with a node.+-- 'SrcSpan' is the original source span of the comment. data NodeComment- = CommentSameLine SomeComment- | CommentAfterLine SomeComment- | CommentBeforeLine SomeComment+ = CommentSameLine SrcSpan SomeComment+ | CommentAfterLine SrcSpan SomeComment+ | CommentBeforeLine SrcSpan SomeComment deriving (Show, Ord, Eq) -- | Information for each node in the AST. data NodeInfo = NodeInfo { nodeInfoSpan :: !SrcSpanInfo -- ^ Location info from the parser.- , nodeInfoComments :: ![NodeComment] -- ^ Comment attached to this node.+ , nodeInfoComments :: ![NodeComment] -- ^ Comments attached to this node. } instance Show NodeInfo where show (NodeInfo _ []) = ""
src/main/Main.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE Unsafe #-}-{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-} -- | Main entry point to hindent. --@@ -10,6 +8,7 @@ import Control.Applicative import Control.Exception+import Control.Monad import qualified Data.ByteString as S import qualified Data.ByteString.Builder as S import qualified Data.ByteString.Lazy.Char8 as L8@@ -44,11 +43,11 @@ case mfilepath of Just filepath -> do text <- S.readFile filepath- tmpDir <- IO.getTemporaryDirectory- (fp, h) <- IO.openTempFile tmpDir "hindent.hs" case reformat style (Just exts) text of Left e -> error (filepath ++ ": " ++ e)- Right out -> do+ Right out -> unless (L8.fromStrict text == S.toLazyByteString out) $ do+ tmpDir <- IO.getTemporaryDirectory+ (fp, h) <- IO.openTempFile tmpDir "hindent.hs" L8.hPutStr h (S.toLazyByteString out) IO.hFlush h IO.hClose h@@ -56,6 +55,7 @@ if ioe_errno e == Just ((\(Errno a) -> a) eXDEV) then IO.copyFile fp filepath >> IO.removeFile fp else throw e+ IO.copyPermissions filepath fp IO.renameFile fp filepath `catch` exdev Nothing -> L8.interact@@ -116,7 +116,8 @@ (constant "--style" "Style to print with" () *> anyString "STYLE")) <*> lineLen <*> indentSpaces <*>- trailingNewline+ trailingNewline <*>+ sortImports exts = fmap getExtensions (many (prefix "X" "Language extension")) indentSpaces = fmap@@ -131,10 +132,15 @@ trailingNewline = optional (constant "--no-force-newline" "Don't force a trailing newline" False)- makeStyle s mlen tabs trailing =+ sortImports =+ optional+ (constant "--sort-imports" "Sort imports in groups" True <|>+ constant "--no-sort-imports" "Don't sort imports" False)+ makeStyle s mlen tabs trailing imports = s { configMaxColumns = fromMaybe (configMaxColumns s) mlen , configIndentSpaces = fromMaybe (configIndentSpaces s) tabs , configTrailingNewline = fromMaybe (configTrailingNewline s) trailing+ , configSortImports = fromMaybe (configSortImports s) imports } file = fmap (fmap T.unpack) (optional (anyString "[<filename>]"))
src/main/Test.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -- | Test the pretty printer.- module Main where import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Builder as L@@ -15,7 +15,7 @@ import qualified Data.ByteString.UTF8 as UTF8 import Data.Function import Data.Monoid-import HIndent+import qualified HIndent import HIndent.Types import Markdone import Test.Hspec@@ -27,29 +27,43 @@ forest <- parse (tokenize bytes) hspec (toSpec forest) --- -- | Convert the Markdone document to Spec benchmarks.+reformat :: Config -> S.ByteString -> ByteString+reformat cfg code =+ either (("-- " <>) . L8.pack) L.toLazyByteString $+ HIndent.reformat cfg (Just HIndent.defaultExtensions) code++-- | Convert the Markdone document to Spec benchmarks. toSpec :: [Markdone] -> Spec toSpec = go where+ cfg = HIndent.Types.defaultConfig {configTrailingNewline = False} go (Section name children:next) = do- describe (UTF8.toString name) (go children)- go next+ describe (UTF8.toString name) (go children)+ go next go (PlainText desc:CodeFence lang code:next) =- if lang == "haskell"- then do- it- (UTF8.toString desc)- (shouldBeReadable- (either- (("-- " <>) . L8.pack)- L.toLazyByteString- (reformat- HIndent.Types.defaultConfig {configTrailingNewline = False}- (Just defaultExtensions)- code))- (L.fromStrict code))+ case lang of+ "haskell" -> do+ it (UTF8.toString desc) $+ shouldBeReadable (reformat cfg code) (L.fromStrict code) go next- else go next+ "haskell 4" -> do+ let cfg' = cfg {configIndentSpaces = 4}+ it (UTF8.toString desc) $+ shouldBeReadable (reformat cfg' code) (L.fromStrict code)+ go next+ "haskell given" ->+ case skipEmptyLines next of+ CodeFence "haskell expect" codeExpect:next' -> do+ it (UTF8.toString desc) $+ shouldBeReadable (reformat cfg code) (L.fromStrict codeExpect)+ go next'+ _ ->+ fail+ "'haskell given' block must be followed by a 'haskell expect' block"+ "haskell pending" -> do+ it (UTF8.toString desc) pending+ go next+ _ -> go next go (PlainText {}:next) = go next go (CodeFence {}:next) = go next go [] = return ()@@ -57,15 +71,18 @@ -- | Version of 'shouldBe' that prints strings in a readable way, -- better for our use-case. shouldBeReadable :: ByteString -> ByteString -> Expectation-shouldBeReadable x y = shouldBe (Readable x (Just (diff y x))) (Readable y Nothing)+shouldBeReadable x y =+ shouldBe (Readable x (Just (diff y x))) (Readable y Nothing) -- | Prints a string without quoting and escaping. data Readable = Readable { readableString :: ByteString- , readableDiff :: (Maybe String)+ , readableDiff :: Maybe String }+ instance Eq Readable where (==) = on (==) readableString+ instance Show Readable where show (Readable x d') = "\n" ++@@ -76,4 +93,8 @@ -- | A diff display. diff :: ByteString -> ByteString -> String-diff x y = ppDiff (on (getGroupedDiff) (lines . LUTF8.toString) x y)+diff x y = ppDiff (on getGroupedDiff (lines . LUTF8.toString) x y)++skipEmptyLines :: [Markdone] -> [Markdone]+skipEmptyLines (PlainText "":rest) = rest+skipEmptyLines other = other