diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,14 +1,27 @@ +5.1.1: + + * Preserve spaces between groups of imports (fixes #200) + * Support shebangs (closes #208) + * Output filename for parse errors (fixes #179) + * Input with newline ends with newline (closes #211) + * Document -X (closes #212) + * Fix explicit forall in instances (closes #218) + * Put last paren of export list on a new line #227 + 5.1.0: - * Rewrote comment association, more reliable - * Added --tab-size flag for indentation spaces - * Fixed some miscellaneous bugs + * Rewrote comment association, more reliable + * Added --tab-size flag for indentation spaces + * Fixed some miscellaneous bugs + 5.0.1: + * Re-implement using bytestring instead of text * Made compatible with GHC 7.8 through to GHC 8.0 * Added test suite and benchmarks in TESTS.md and BENCHMARKS.md 5.0.0: + * Drop support for styles 4.6.4 diff --git a/TESTS.md b/TESTS.md --- a/TESTS.md +++ b/TESTS.md @@ -24,8 +24,8 @@ ( x , y , Z - , P(x, z)) - where + , P(x, z) + ) where ``` ## Imports @@ -49,6 +49,21 @@ type EventSource a = (AddHandler a, a -> IO ()) ``` +Instance declaration without decls + +``` haskell +instance C a +``` + +Instance declaration with decls + +``` haskell +instance C a where + foobar = do + x y + k p +``` + # Expressions Lazy patterns in a lambda @@ -362,6 +377,67 @@ -- This is another random comment. ``` +## Regression tests + +cocreature removed from declaration issue #186 + +``` haskell +-- https://github.com/chrisdone/hindent/issues/186 +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) + }) +``` + +sheyll explicit forall in instances #218 + +``` haskell +-- https://github.com/chrisdone/hindent/issues/218 +instance forall x. C + +instance forall x. Show x => + C x +``` + +tfausak support shebangs #208 + +``` haskell +#!/usr/bin/env stack +-- stack runghc +main = pure () +-- https://github.com/chrisdone/hindent/issues/208 +``` + +joe9 preserve newlines between import groups + +``` haskell +-- https://github.com/chrisdone/hindent/issues/200 +import Data.List +import Data.Maybe + +import MyProject +import FooBar + +import GHC.Monad + +-- blah +import Hello + +import CommentAfter -- Comment here shouldn't affect newlines +import HelloWorld + +import CommentAfter -- Comment here shouldn't affect newlines + +import HelloWorld + +-- Comment here shouldn't affect newlines +import CommentAfter + +import HelloWorld +``` + # Behaviour checks Unicode @@ -374,6 +450,15 @@ Empty module ``` haskell +``` + +Trailing newline is preserved + +``` haskell +module X where + +foo = 123 + ``` # Complex input diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,5 +1,5 @@ name: hindent -version: 5.1.0 +version: 5.1.1 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . diff --git a/src/HIndent.hs b/src/HIndent.hs --- a/src/HIndent.hs +++ b/src/HIndent.hs @@ -31,6 +31,7 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.Unsafe as S +import Data.Char import Data.Either import Data.Function import Data.Functor.Identity @@ -45,74 +46,96 @@ import Language.Haskell.Exts hiding (Style, prettyPrint, Pretty, style, parse) import Prelude -data CodeBlock = HaskellSource ByteString - | CPPDirectives ByteString - deriving (Show, Eq) +-- | A block of code. +data CodeBlock + = Shebang ByteString + | HaskellSource ByteString + | CPPDirectives ByteString + deriving (Show, Eq) -- | Format the given source. reformat :: Config -> Maybe [Extension] -> ByteString -> Either String Builder -reformat config mexts x = - fmap (mconcat . intersperse "\n") (mapM processBlock (cppSplitBlocks x)) +reformat config mexts = + 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) = - let ls = S8.lines text - prefix = findPrefix ls - code = unlines' (map (stripPrefix prefix) ls) - in case parseModuleWithComments mode' (UTF8.toString code) of - ParseOk (m, comments) -> - fmap (S.lazyByteString . - addPrefix prefix . - S.toLazyByteString) - (prettyPrint config m comments) - ParseFailed _ e -> Left e - + let ls = S8.lines text + prefix = findPrefix ls + code = unlines' (map (stripPrefix prefix) ls) + in case parseModuleWithComments mode' (UTF8.toString code) of + ParseOk (m, comments) -> + fmap + (S.lazyByteString . addPrefix prefix . S.toLazyByteString) + (prettyPrint config m comments) + ParseFailed _ e -> Left e unlines' = S.concat . intersperse "\n" unlines'' = L.concat . intersperse "\n" - addPrefix :: ByteString -> L8.ByteString -> L8.ByteString addPrefix prefix = unlines'' . map (L8.fromStrict prefix <>) . L8.lines - stripPrefix :: ByteString -> ByteString -> ByteString stripPrefix prefix line = - if S.null (S8.dropWhile (== '\n') line) - then line - else fromMaybe (error "Missing expected prefix") . s8_stripPrefix prefix $ line - + if S.null (S8.dropWhile (== '\n') line) + then line + else fromMaybe (error "Missing expected prefix") . s8_stripPrefix prefix $ + line findPrefix :: [ByteString] -> ByteString findPrefix = takePrefix False . findSmallestPrefix . dropNewlines - dropNewlines :: [ByteString] -> [ByteString] dropNewlines = filter (not . S.null . S8.dropWhile (== '\n')) - takePrefix :: Bool -> ByteString -> ByteString takePrefix bracketUsed txt = - case S8.uncons txt of - Nothing -> "" - Just ('>', txt') -> if not bracketUsed - then S8.cons '>' (takePrefix True txt') - else "" - Just (c, txt') -> if c == ' ' || c == '\t' - then S8.cons c (takePrefix bracketUsed txt') - else "" - - + case S8.uncons txt of + Nothing -> "" + Just ('>', txt') -> + if not bracketUsed + then S8.cons '>' (takePrefix True txt') + else "" + Just (c, txt') -> + if c == ' ' || c == '\t' + then S8.cons c (takePrefix bracketUsed txt') + else "" findSmallestPrefix :: [ByteString] -> ByteString findSmallestPrefix [] = "" findSmallestPrefix ("":_) = "" findSmallestPrefix (p:ps) = - let first = S8.head p - startsWithChar c x = S8.length x > 0 && S8.head x == c - in if all (startsWithChar first) ps - then S8.cons first (findSmallestPrefix (S.tail p : map S.tail ps)) - else "" - + let first = S8.head p + startsWithChar c x = S8.length x > 0 && S8.head x == c + in if all (startsWithChar first) ps + then S8.cons + first + (findSmallestPrefix (S.tail p : map S.tail ps)) + else "" mode' = - case mexts of - Just exts -> parseMode { extensions = exts } - Nothing -> parseMode + case mexts of + Just exts -> + parseMode + { extensions = exts + } + Nothing -> parseMode + preserveTrailingNewline f x = + if S8.null x || S8.all isSpace x + then return mempty + else if hasTrailingLine x || configTrailingNewline config + then fmap + (\x' -> + if hasTrailingLine + (L.toStrict (S.toLazyByteString x')) + then x' + else x' <> "\n") + (f x) + else f x +-- | Does the strict bytestring have a trailing newline? +hasTrailingLine :: ByteString -> Bool +hasTrailingLine xs = + if S8.null xs + then False + else S8.last xs == '\n' + -- | Break a Haskell code string into chunks, using CPP as a delimiter. -- Lines that start with '#if', '#end', or '#else' are their own chunks, and -- also act as chunk separators. For example, the code @@ -140,9 +163,11 @@ ["#if", "#end", "#else", "#define", "#undef", "#elif"] classify :: ByteString -> CodeBlock classify text = - if cppLine text - then CPPDirectives text - else HaskellSource text + if S8.isPrefixOf "#!" text + then Shebang text + else if cppLine text + then CPPDirectives text + else 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. diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -763,15 +763,19 @@ (prefixedLined "|" (map (depend space . pretty) xs))) -decl (InlineSig _ inline _ name) = do +decl (InlineSig _ inline active name) = do write "{-# " unless inline $ write "NO" write "INLINE " + case active of + Nothing -> return () + Just (ActiveFrom _ x) -> write ("[" ++ show x ++ "] ") + Just (ActiveUntil _ x) -> write ("[~" ++ show x ++ "] ") pretty name write " #-}" -decl x = pretty' x +decl x' = pretty' x' instance Pretty Deriving where prettyInternal (Deriving _ heads) = @@ -825,8 +829,8 @@ NoStrictAnnot _ -> return () instance Pretty Unpackedness where - prettyInternal (Unpack _) = write "{-# UNPACK -#}" - prettyInternal (NoUnpack _) = write "{-# NOUNPACK -#}" + prettyInternal (Unpack _) = write "{-# UNPACK #-}" + prettyInternal (NoUnpack _) = write "{-# NOUNPACK #-}" prettyInternal (NoUnpackPragma _) = return () instance Pretty Binds where @@ -973,7 +977,9 @@ prettyInternal (IRule _ mvarbinds mctx ihead) = do case mvarbinds of Nothing -> return () - Just xs -> spaced (map pretty xs) + Just xs -> do write "forall " + spaced (map pretty xs) + write ". " withCtx mctx (pretty ihead) instance Pretty InstHead where @@ -1035,7 +1041,7 @@ ,(case mayModHead of Nothing -> (True,return ()) Just modHead -> (False,pretty modHead)) - ,(null imps,inter newline (map pretty imps)) + ,(null imps,formatImports imps) ,(null decls ,interOf newline (map (\case @@ -1054,6 +1060,24 @@ XmlPage{} -> error "FIXME: No implementation for XmlPage." XmlHybrid{} -> error "FIXME: No implementation for XmlHybrid." +-- | Format imports, preserving empty newlines between them. +formatImports :: [ImportDecl NodeInfo] -> Printer () +formatImports imps = + mapM_ formatImport (zip [1 ..] (zip (Nothing : map Just imps) imps)) + where + formatImport (i, (mprev, current)) = do + when (difference > 1) newline + pretty current + unless (i == length imps) newline + where + difference = + case mprev of + Nothing -> 0 + Just prev -> + fst + (srcSpanStart (srcInfoSpan (nodeInfoSpan (ann current)))) - + fst (srcSpanStart (srcInfoSpan (nodeInfoSpan (ann prev)))) + instance Pretty Bracket where prettyInternal x = case x of @@ -1158,9 +1182,7 @@ maybe (return ()) (\exports -> do newline - indented 2 (pretty exports) - newline - space) + indented 2 (pretty exports)) mexports write " where" @@ -1187,9 +1209,11 @@ write "{-# WARNING " >> string s >> write " #-}" instance Pretty ExportSpecList where - prettyInternal (ExportSpecList _ es) = - parens (prefixedLined "," - (map pretty es)) + prettyInternal (ExportSpecList _ es) = do + depend (write "(") + (prefixedLined "," (map pretty es)) + newline + write ")" instance Pretty ExportSpec where prettyInternal x = string " " >> pretty' x diff --git a/src/HIndent/Types.hs b/src/HIndent/Types.hs --- a/src/HIndent/Types.hs +++ b/src/HIndent/Types.hs @@ -54,16 +54,20 @@ -- | Configurations shared among the different styles. Styles may pay -- attention to or completely disregard this configuration. -data Config = - Config {configMaxColumns :: !Int64 -- ^ Maximum columns to fit code into ideally. - ,configIndentSpaces :: !Int64 -- ^ How many spaces to indent? - } +data Config = Config + { configMaxColumns :: !Int64 -- ^ Maximum columns to fit code into ideally. + , configIndentSpaces :: !Int64 -- ^ How many spaces to indent? + , configTrailingNewline :: !Bool -- ^ End with a newline. + } -- | Default style configuration. defaultConfig :: Config defaultConfig = - Config {configMaxColumns = 80 - ,configIndentSpaces = 4} + Config + { configMaxColumns = 80 + , configIndentSpaces = 4 + , configTrailingNewline = True + } data NodeComment = CommentSameLine String diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -36,42 +36,43 @@ main = do args <- getArgs case consume options (map T.pack args) of - Succeeded (style,exts,mfilepath) -> + Succeeded (style, exts, mfilepath) -> case mfilepath of Just filepath -> do text <- S.readFile filepath tmpDir <- getTemporaryDirectory - (fp,h) <- openTempFile tmpDir "hindent.hs" - L8.putStrLn - (either - error - S.toLazyByteString - (reformat style (Just exts) text)) - hFlush h - hClose h - let exdev e = - if ioe_errno e == - Just - ((\(Errno a) -> - a) - eXDEV) - then copyFile fp filepath >> removeFile fp - else throw e - renameFile fp filepath `catch` exdev + (fp, h) <- openTempFile tmpDir "hindent.hs" + case reformat style (Just exts) text of + Left e -> error (filepath ++ ": " ++ e) + Right out -> do + L8.hPutStr h (S.toLazyByteString out) + hFlush h + hClose h + let exdev e = + if ioe_errno e == + Just ((\(Errno a) -> a) eXDEV) + then copyFile fp filepath >> + removeFile fp + else throw e + 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) . L8.toStrict) Failed (Wrap (Stopped Version) _) -> putStrLn ("hindent " ++ showVersion version) Failed (Wrap (Stopped Help) _) -> putStrLn help _ -> error help where + + help :: [Char] help = "hindent " ++ T.unpack (textDescription (describe options [])) ++ "\nVersion " ++ showVersion version ++ "\n" ++ + "-X to pass extensions e.g. -XMagicHash etc.\n" ++ "The --style option is now ignored, but preserved for backwards-compatibility.\n" ++ "Johan Tibell is the default and only style." @@ -94,7 +95,9 @@ (optional (constant "--style" "Style to print with" () *> anyString "STYLE")) <*> - lineLen <*> tabsize + lineLen <*> + tabsize <*> + trailingNewline exts = fmap getExtensions (many (prefix "X" "Language extension")) tabsize = fmap @@ -104,9 +107,13 @@ fmap (>>= (readMaybe . T.unpack)) (optional (arg "line-length" "Desired length of lines")) - makeStyle s mlen tabs = + trailingNewline = + optional + (constant "--no-force-newline" "Don't force a trailing newline" False) + makeStyle s mlen tabs trailing = s { configMaxColumns = fromMaybe (configMaxColumns s) mlen , configIndentSpaces = fromMaybe (configIndentSpaces s) tabs + , configTrailingNewline = fromMaybe (configTrailingNewline s) trailing } file = fmap (fmap T.unpack) (optional (anyString "[]")) diff --git a/src/main/Markdone.hs b/src/main/Markdone.hs --- a/src/main/Markdone.hs +++ b/src/main/Markdone.hs @@ -48,7 +48,7 @@ tokenize = map token . S8.lines where token line = - if S8.isPrefixOf "#" line + if S8.isPrefixOf "#" line && not (S8.isPrefixOf "#!" line) then let (hashes,title) = S8.span (== '#') line in Heading (S8.length hashes) (S8.dropWhile isSpace title) else if S8.isPrefixOf "```" line diff --git a/src/main/Test.hs b/src/main/Test.hs --- a/src/main/Test.hs +++ b/src/main/Test.hs @@ -44,7 +44,7 @@ (("-- " <>) . L8.pack) L.toLazyByteString (reformat - HIndent.Types.defaultConfig + HIndent.Types.defaultConfig {configTrailingNewline = False} (Just defaultExtensions) code)) (L.fromStrict code))