hindent 5.2.7 → 5.3.0
raw patch · 12 files changed
+752/−374 lines, 12 filesdep ~basedep ~haskell-src-exts
Dependency ranges changed: base, haskell-src-exts
Files
- CHANGELOG.md +15/−0
- README.md +1/−1
- TESTS.md +384/−130
- hindent.cabal +3/−1
- src/HIndent.hs +9/−74
- src/HIndent/CabalFile.hs +3/−1
- src/HIndent/CodeBlock.hs +95/−0
- src/HIndent/Pretty.hs +105/−139
- src/HIndent/Types.hs +16/−2
- src/main/Main.hs +9/−9
- src/main/Markdone.hs +33/−16
- src/main/Test.hs +79/−1
CHANGELOG.md view
@@ -1,3 +1,18 @@+5.3.0:+ * Handle multiple deriving clauses in a DerivingStrategies scenario+ * Ignore non-files in findCabalFiles+ * Allow batch processing of multiple files+ * Prevent hindent from trying to open non-files when searching for+ .cabal files+ * Specify default extensions in configuration file+ * Fix bad output for [p|Foo|] pattern quasi-quotes+ * Parse C preprocessor line continuations+ * Fix pretty printing of '(:)+ * Add parens around symbols (:|) when required+ * Support $p pattern splices+ * Fix associated type families+ * Non-dependent record constructor formatting+ 5.2.7: * Fix -X option bug
README.md view
@@ -1,4 +1,4 @@-# hindent [](https://hackage.haskell.org/package/hindent) [](https://travis-ci.org/commercialhaskell/hindent)+# hindent [](https://hackage.haskell.org/package/hindent) [](https://travis-ci.org/commercialhaskell/hindent) Haskell pretty printer
TESTS.md view
@@ -9,6 +9,19 @@ # Modules +Empty module++``` haskell+```++Double shebangs++``` haskell+#!/usr/bin/env stack+#!/usr/bin/env stack+main = pure ()+```+ Extension pragmas ```haskell@@ -144,6 +157,14 @@ k p ``` +Symbol class constructor in instance declaration++```haskell+instance Bool :?: Bool++instance (:?:) Int Bool+```+ GADT declarations ```haskell@@ -247,6 +268,20 @@ } ``` +Record with symbol constructor++```haskell+f = (:..?) {}+```++Record with symbol field++```haskell+f x = x {(..?) = wat}++g x = Rec {(..?)}+```+ Cases ``` haskell@@ -299,6 +334,40 @@ Left x -> x ``` +Operator in parentheses++```haskell+cat = (++)+```++Symbol data constructor in parentheses++```haskell+cons = (:)++cons' = (:|)+```++n+k patterns++``` haskell+f (n+5) = 0+```++Binary symbol data constructor in pattern++```haskell+f (x :| _) = x++f' ((:|) x _) = x++f'' ((Data.List.NonEmpty.:|) x _) = x++g (x:xs) = x++g' ((:) x _) = x+```+ Type application ```haskell@@ -382,6 +451,23 @@ foo :: $([t|Bool|]) -> a ``` +Quoted data constructors++```haskell+cons = '(:)+```++Pattern splices++```haskell+f $pat = ()++g =+ case x of+ $(mkPat y z) -> True+ _ -> False+```+ # Type signatures Long argument list should line break@@ -409,6 +495,13 @@ fun :: (Class a, Class b) => a -> b -> c ``` +Symbol class constructor in class constraint++```haskell+f :: (a :?: b) => (a, b)+f' :: ((:?:) a b) => (a, b)+```+ Tuples ``` haskell@@ -438,6 +531,13 @@ f :: (?x :: Int) => Int ``` +Symbol type constructor++```haskell+f :: a :?: b+f' :: (:?:) a b+```+ Promoted list (issue #348) ```haskell@@ -460,6 +560,15 @@ b = undefined ``` +Prefix promoted symbol type constructor++```haskell+a :: '(T.:->) 'True 'False+b :: (T.:->) 'True 'False+c :: '(:->) 'True 'False+d :: (:->) 'True 'False+```+ # Function declarations Prefix notation for operators@@ -614,6 +723,37 @@ beta + delta + zeta + theta + kappa + mu + beta + delta + zeta + theta + kappa ``` +Symbol constructor, short++```haskell+fun ((:..?) {}) = undefined+```++Symbol constructor, long++```+fun (:..?) { alpha = beta+ , gamma = delta+ , epsilon = zeta+ , eta = theta+ , iota = kappa+ , lambda = mu+ } =+ beta + delta + zeta + theta + kappa + mu + beta + delta + zeta + theta + kappa+```++Symbol field++```haskell+f (X {(..?) = x}) = x+```++Punned symbol field++```haskell+f' (X {(..?)}) = (..?)+```+ # Johan Tibell compatibility checks Basic example from Tibbe's style@@ -637,31 +777,64 @@ ``` haskell data Tree a- = Branch !a- !(Tree a)- !(Tree a)+ = Branch !a !(Tree a) !(Tree a) | Leaf +data Tree a+ = Branch+ !a+ !(Tree a)+ !(Tree a)+ !(Tree a)+ !(Tree a)+ !(Tree a)+ !(Tree a)+ !(Tree a)+ | Leaf+ data HttpException = InvalidStatusCode Int | MissingContentHeader -data Person = Person- { firstName :: !String -- ^ First name- , lastName :: !String -- ^ Last name- , age :: !Int -- ^ Age- }+data Person =+ Person+ { firstName :: !String -- ^ First name+ , lastName :: !String -- ^ Last name+ , age :: !Int -- ^ Age+ }++data Expression a+ = VariableExpression+ { id :: Id Expression+ , label :: a+ }+ | FunctionExpression+ { var :: Id Expression+ , body :: Expression a+ , label :: a+ }+ | ApplyExpression+ { func :: Expression a+ , arg :: Expression a+ , label :: a+ }+ | ConstructorExpression+ { id :: Id Constructor+ , label :: a+ } ``` Spaces between deriving classes ``` haskell -- From https://github.com/chrisdone/hindent/issues/167-data Person = Person- { firstName :: !String -- ^ First name- , lastName :: !String -- ^ Last name- , age :: !Int -- ^ Age- } deriving (Eq, Show)+data Person =+ Person+ { firstName :: !String -- ^ First name+ , lastName :: !String -- ^ Last name+ , age :: !Int -- ^ Age+ }+ deriving (Eq, Show) ``` Hanging lambdas@@ -768,18 +941,19 @@ = X -- ^ X is for xylophone. | Y -- ^ Y is for why did I eat that pizza. -data X = X- { field1 :: Int -- ^ Field1 is the first field.- , field11 :: Char- -- ^ This field comment is on its own line.- , field2 :: Int -- ^ Field2 is the second field.- , field3 :: Char -- ^ This is a long comment which starts next to- -- the field but continues onto the next line, it aligns exactly- -- with the field name.- , field4 :: Char- -- ^ This is a long comment which starts on the following line- -- from from the field, lines continue at the sme column.- }+data X =+ X+ { field1 :: Int -- ^ Field1 is the first field.+ , field11 :: Char+ -- ^ This field comment is on its own line.+ , field2 :: Int -- ^ Field2 is the second field.+ , field3 :: Char -- ^ This is a long comment which starts next to+ -- the field but continues onto the next line, it aligns exactly+ -- with the field name.+ , field4 :: Char+ -- ^ This is a long comment which starts on the following line+ -- from from the field, lines continue at the sme column.+ } ``` Comments around regular declarations@@ -847,6 +1021,145 @@ {- This is another random comment. -} ``` +# MINIMAL pragma++Monad example++```haskell+class A where+ {-# MINIMAL return, ((>>=) | (join, fmap)) #-}+```++Very long names #310++```haskell+class A where+ {-# MINIMAL averylongnamewithnoparticularmeaning+ | ananotherverylongnamewithnomoremeaning #-}+```++# Behaviour checks++Unicode++``` haskell+α = γ * "ω"+-- υ+```++Empty module++``` haskell+```++Trailing newline is preserved++``` haskell+module X where++foo = 123+```++# Complex input++A complex, slow-to-print decl++``` haskell+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)))|]))+ ]+```++Random snippet from hindent itself++``` haskell+exp' (App _ op a) = do+ (fits, st) <- fitsOnOneLine (spaced (map pretty (f : args)))+ if fits+ then put st+ else do+ pretty f+ newline+ spaces <- getIndentSpaces+ indented spaces (lined (map pretty args))+ where+ (f, args) = flatten op [a]+ 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|]++f [qq|pattern|] = ()+```++# C preprocessor++Conditionals (`#if`)++```haskell+isDebug :: Bool+#if DEBUG+isDebug = True+#else+isDebug = False+#endif+```++Macro definitions (`#define`)++```haskell+#define STRINGIFY(x) #x+f = STRINGIFY (y)+```++Escaped newlines++```haskell+#define LONG_MACRO_DEFINITION \+ data Pair a b = Pair \+ { first :: a \+ , second :: b \+ }+#define SHORT_MACRO_DEFINITION \+ x+```+ # Regression tests jml Adds trailing whitespace when wrapping #221@@ -1085,8 +1398,26 @@ } ``` -# MINIMAL pragma+paraseba Deriving strategies with multiple deriving clauses+```haskell+-- https://github.com/commercialhaskell/hindent/issues/503+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Foo where++import Data.Typeable+import GHC.Generics++newtype Number a =+ Number a+ deriving (Generic)+ deriving newtype (Show, Eq)+ deriving anyclass (Typeable)+```+ neongreen "{" is lost when formatting "Foo{}" #366 ```haskell@@ -1131,17 +1462,22 @@ ```haskell -- https://github.com/commercialhaskell/hindent/issues/393 data X- = X { x :: Int }+ = X+ { x :: Int+ } | X' -data X = X- { x :: Int- , x' :: Int- }+data X =+ X+ { x :: Int+ , x' :: Int+ } data X- = X { x :: Int- , x' :: Int }+ = X+ { x :: Int+ , x' :: Int+ } | X' ``` @@ -1353,9 +1689,7 @@ {-# LANGUAGE ExistentialQuantification #-} data D =- forall a b c. D a- b- c+ forall a b c. D a b c ``` sophie-h Regression: Breaks basic type class code by inserting "|" #459@@ -1428,107 +1762,27 @@ import qualified "base" Prelude as P ``` -# MINIMAL pragma--Monad example+alexwl Hindent breaks associated type families annotated with injectivity information #528 ```haskell-class A where- {-# MINIMAL return, ((>>=) | (join, fmap)) #-}+-- https://github.com/commercialhaskell/hindent/issues/528+class C a where+ type F a = b | b -> a ``` -Very long names #310+sophie-h Fails to create required indentation for infix #238 ```haskell-class A where- {-# MINIMAL averylongnamewithnoparticularmeaning- | ananotherverylongnamewithnomoremeaning #-}-```--# Behaviour checks--Unicode--``` haskell-α = γ * "ω"--- υ-```--Empty module--``` haskell-```--Trailing newline is preserved--``` haskell-module X where--foo = 123-```--# Complex input--A complex, slow-to-print decl--``` haskell-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)))|]))- ]-```--Random snippet from hindent itself+-- https://github.com/commercialhaskell/hindent/issues/238+{-# LANGUAGE ScopedTypeVariables #-} -``` haskell-exp' (App _ op a) = do- (fits, st) <- fitsOnOneLine (spaced (map pretty (f : args)))- if fits- then put st- else do- pretty f- newline- spaces <- getIndentSpaces- indented spaces (lined (map pretty args))- where- (f, args) = flatten op [a]- flatten :: Exp NodeInfo -> [Exp NodeInfo] -> (Exp NodeInfo, [Exp NodeInfo])- flatten (App _ f' a') b = flatten f' (a' : b)- flatten f' as = (f', as)-```+import Control.Exception -Quasi quotes+x :: IO Int+x =+ do putStrLn "ok"+ error "ok"+ `catch` (\(_ :: IOException) -> pure 1) `catch`+ (\(_ :: ErrorCall) -> pure 2) -```haskell-exp = [name|exp|] ```
hindent.cabal view
@@ -1,5 +1,5 @@ name: hindent-version: 5.2.7+version: 5.3.0 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. .@@ -33,6 +33,7 @@ HIndent.Types HIndent.Pretty HIndent.CabalFile+ HIndent.CodeBlock build-depends: base >= 4.7 && <5 , containers , Cabal@@ -105,3 +106,4 @@ , criterion , deepseq , exceptions+ , mtl
src/HIndent.hs view
@@ -41,20 +41,13 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Traversable hiding (mapM)+import HIndent.CodeBlock 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 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] -> Maybe FilePath -> ByteString -> Either String Builder reformat config mexts mfilepath =@@ -72,10 +65,16 @@ mode'' = case exts of Nothing -> mode' Just (Nothing, exts') ->- mode' { extensions = exts' ++ extensions mode' }+ mode' { extensions =+ exts'+ ++ configExtensions config+ ++ extensions mode' } Just (Just lang, exts') -> mode' { baseLanguage = lang- , extensions = exts' ++ extensions mode' }+ , extensions =+ exts'+ ++ configExtensions config+ ++ extensions mode' } in case parseModuleWithComments mode'' (UTF8.toString code) of ParseOk (m, comments) -> fmap@@ -148,62 +147,6 @@ 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------ > #ifdef X--- > x = X--- > y = Y--- > #else--- > x = Y--- > y = X--- > #endif------ will become five blocks, one for each CPP line and one for each pair of declarations.-cppSplitBlocks :: ByteString -> [CodeBlock]-cppSplitBlocks inp =- modifyLast (inBlock (<> trailing)) .- map (classify . unlines') .- groupBy ((==) `on` nonHaskellLine) . zip [0 ..] . S8.lines $- inp- where- nonHaskellLine :: (Int, 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", "#include", "#error", "#warning"]- -- Note: #ifdef and #ifndef are handled by #if- 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 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 =- if S8.isSuffixOf "\n" inp- then "\n"- else ""- modifyLast :: (a -> a) -> [a] -> [a]- modifyLast _ [] = []- modifyLast f [x] = [f x]- modifyLast f (x:xs) = x : modifyLast f xs- inBlock :: (ByteString -> ByteString) -> CodeBlock -> CodeBlock- inBlock f (HaskellSource line txt) = HaskellSource line (f txt)- inBlock _ dir = dir-- -- | Print the module. prettyPrint :: Config -> Module SrcSpanInfo@@ -319,14 +262,6 @@ x' : delete x' a f _ x = error $ "Unknown extension: " ++ x---- | Parse an extension.-readExtension :: String -> Maybe Extension-readExtension x =- case classifyExtension x -- Foo- of- UnknownExtension _ -> Nothing- x' -> Just x' -------------------------------------------------------------------------------- -- Comments
src/HIndent/CabalFile.hs view
@@ -4,6 +4,7 @@ ( getCabalExtensionsForSourcePath ) where +import Control.Monad import qualified Data.ByteString as BS import Data.List import Data.Maybe@@ -82,7 +83,8 @@ findCabalFiles :: FilePath -> FilePath -> IO (Maybe ([FilePath], FilePath)) findCabalFiles dir rel = do names <- getDirectoryContents dir- let cabalnames = filter (isSuffixOf ".cabal") names+ cabalnames <-+ filterM (doesFileExist . (dir </>)) $ filter (isSuffixOf ".cabal") names case cabalnames of [] | dir == "/" -> return Nothing
+ src/HIndent/CodeBlock.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}++module HIndent.CodeBlock+ ( CodeBlock(..)+ , cppSplitBlocks+ ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Monoid++-- | A block of code.+data CodeBlock+ = Shebang ByteString+ | HaskellSource Int ByteString+ -- ^ Includes the starting line (indexed from 0) for error reporting+ | CPPDirectives ByteString+ deriving (Show, Eq)++-- | 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+--+-- > #ifdef X+-- > x = X+-- > y = Y+-- > #else+-- > x = Y+-- > y = X+-- > #endif+--+-- will become five blocks, one for each CPP line and one for each pair of declarations.+cppSplitBlocks :: ByteString -> [CodeBlock]+cppSplitBlocks inp =+ modifyLast (inBlock (<> trailing)) .+ groupLines . classifyLines . zip [0 ..] . S8.lines $+ inp+ where+ groupLines :: [CodeBlock] -> [CodeBlock]+ groupLines (line1:line2:remainingLines) =+ case mergeLines line1 line2 of+ Just line1And2 -> groupLines (line1And2 : remainingLines)+ Nothing -> line1 : groupLines (line2 : remainingLines)+ groupLines xs@[_] = xs+ groupLines xs@[] = xs+ mergeLines :: CodeBlock -> CodeBlock -> Maybe CodeBlock+ mergeLines (CPPDirectives src1) (CPPDirectives src2) =+ Just $ CPPDirectives (src1 <> "\n" <> src2)+ mergeLines (Shebang src1) (Shebang src2) =+ Just $ Shebang (src1 <> "\n" <> src2)+ mergeLines (HaskellSource lineNumber1 src1) (HaskellSource _lineNumber2 src2) =+ Just $ HaskellSource lineNumber1 (src1 <> "\n" <> src2)+ mergeLines _ _ = Nothing+ shebangLine :: ByteString -> Bool+ shebangLine = S8.isPrefixOf "#!"+ cppLine :: ByteString -> Bool+ cppLine src =+ any+ (`S8.isPrefixOf` src)+ ["#if", "#end", "#else", "#define", "#undef", "#elif", "#include", "#error", "#warning"]+ -- Note: #ifdef and #ifndef are handled by #if+ hasEscapedTrailingNewline :: ByteString -> Bool+ hasEscapedTrailingNewline src = "\\" `S8.isSuffixOf` src+ classifyLines :: [(Int, ByteString)] -> [CodeBlock]+ classifyLines allLines@((lineIndex, src):nextLines)+ | cppLine src =+ let (cppLines, nextLines') = spanCPPLines allLines+ in CPPDirectives (S8.intercalate "\n" (map snd cppLines)) :+ classifyLines nextLines'+ | shebangLine src = Shebang src : classifyLines nextLines+ | otherwise = HaskellSource lineIndex src : classifyLines nextLines+ classifyLines [] = []+ spanCPPLines ::+ [(Int, ByteString)] -> ([(Int, ByteString)], [(Int, ByteString)])+ spanCPPLines (line@(_, src):nextLines)+ | hasEscapedTrailingNewline src =+ let (cppLines, nextLines') = spanCPPLines nextLines+ in (line : cppLines, nextLines')+ | otherwise = ([line], nextLines)+ spanCPPLines [] = ([], [])+ -- 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 =+ if S8.isSuffixOf "\n" inp+ then "\n"+ else ""+ modifyLast :: (a -> a) -> [a] -> [a]+ modifyLast _ [] = []+ modifyLast f [x] = [f x]+ modifyLast f (x:xs) = x : modifyLast f xs+ inBlock :: (ByteString -> ByteString) -> CodeBlock -> CodeBlock+ inBlock f (HaskellSource line txt) = HaskellSource line (f txt)+ inBlock _ dir = dir
src/HIndent/Pretty.hs view
@@ -16,7 +16,7 @@ import Control.Applicative import Control.Monad.State.Strict hiding (state) import qualified Data.ByteString.Builder as S-import Data.Foldable (for_, traverse_)+import Data.Foldable (for_, forM_, traverse_) import Data.Int import Data.List import Data.Maybe@@ -400,10 +400,7 @@ depend (do pretty e write " -> ") (pretty p)- PQuasiQuote _ name str ->- brackets (depend (do string name- write "|")- (string str))+ PQuasiQuote _ name str -> quotation name (string str) PBangPat _ p -> depend (write "!") (pretty p)@@ -414,6 +411,7 @@ PXPatTag{} -> pretty' x PXRPats{} -> pretty' x PVar{} -> pretty' x+ PSplice _ s -> pretty s -- | Pretty infix application of a name (identifier or symbol). prettyInfixName :: Name NodeInfo -> Printer ()@@ -437,19 +435,6 @@ Ident _ i -> string i Symbol _ s -> string ("(" ++ s ++ ")") -prettyQuoteQName :: QName NodeInfo -> Printer ()-prettyQuoteQName x =- case x of- Qual _ mn n ->- case n of- Ident _ i -> do pretty mn; write "."; string i;- Symbol _ s -> do write "("; pretty mn; write "."; string s; write ")";- UnQual _ n ->- case n of- Ident _ i -> string i- Symbol _ s -> do write "("; string s; write ")";- Special _ s -> pretty s- instance Pretty Type where prettyInternal = typ @@ -666,17 +651,13 @@ (pretty t) exp (VarQuote _ x) = depend (write "'")- (prettyQuoteQName x)+ (pretty x) exp (TypQuote _ x) = depend (write "''")- (prettyQuoteQName x)+ (pretty x) exp (BracketExp _ b) = pretty b exp (SpliceExp _ s) = pretty s-exp (QuasiQuote _ n s) =- brackets (depend (do string n- write "|")- (do string s- write "|"))+exp (QuasiQuote _ n s) = quotation n (string s) exp (LCase _ alts) = do write "\\case" if null alts@@ -708,17 +689,9 @@ (zip [1..] stmts)))) swing (write " " >> rhsSeparator) (pretty e) 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 (Var _ q) = pretty q exp (IPVar _ q) = pretty q-exp (Con _ q) = case q of- Special _ Cons{} -> parens (pretty q)- Qual _ _ (Symbol _ _) -> parens (pretty q)- UnQual _ (Symbol _ _) -> parens (pretty q)- _ -> pretty q+exp (Con _ q) = pretty q exp x@XTag{} = pretty' x exp x@XETag{} = pretty' x@@ -850,11 +823,7 @@ [x] -> singleCons x xs -> multiCons xs)) indentSpaces <- getIndentSpaces- case mderivs of- [] -> return ()- [derivs] ->- do newline- column indentSpaces (pretty derivs)+ forM_ mderivs $ \deriv -> newline >> column indentSpaces (pretty deriv) where singleCons x = do write " =" indentSpaces <- getIndentSpaces@@ -884,10 +853,7 @@ _ -> do newline lined (map pretty condecls)- case mderivs of- [] -> return ()- [derivs] -> do newline- pretty derivs+ forM_ mderivs $ \deriv -> newline >> pretty deriv decl (InlineSig _ inline active name) = do write "{-# "@@ -898,7 +864,7 @@ Nothing -> return () Just (ActiveFrom _ x) -> write ("[" ++ show x ++ "] ") Just (ActiveUntil _ x) -> write ("[~" ++ show x ++ "] ")- prettyQuoteQName name+ pretty name write " #-}" decl (MinimalPragma _ (Just formula)) =@@ -969,8 +935,8 @@ pretty out_ instance Pretty Deriving where- prettyInternal (Deriving _ _ heads) =- depend (write "deriving" >> space) $ do+ prettyInternal (Deriving _ strategy heads) =+ depend (write "deriving" >> space >> writeStrategy) $ do let heads' = if length heads == 1 then map stripParens heads@@ -980,6 +946,9 @@ Nothing -> formatMultiLine heads' Just derives -> put derives where+ writeStrategy = case strategy of+ Nothing -> return ()+ Just st -> pretty st >> space stripParens (IParen _ iRule) = stripParens iRule stripParens x = x formatMultiLine derives = do@@ -987,6 +956,13 @@ newline write ")" +instance Pretty DerivStrategy where+ prettyInternal x =+ case x of+ DerivStock _ -> return ()+ DerivAnyclass _ -> write "anyclass"+ DerivNewtype _ -> write "newtype"+ instance Pretty Alt where prettyInternal x = case x of@@ -1046,29 +1022,38 @@ case x of ClsDecl _ d -> pretty d ClsDataFam _ ctx h mkind ->- depend (write "data ")- (withCtx ctx- (do pretty h- (case mkind of- Nothing -> return ()- Just kind ->- do write " :: "- pretty kind)))- ClsTyFam _ h mkind minj ->- depend (write "type ")- (depend (pretty h)- (depend (traverse_ (\kind -> write " :: " >> pretty kind) mkind)- (traverse_ pretty minj)))- ClsTyDef _ (TypeEqn _ this that) ->- do write "type "- pretty this- write " = "- pretty that- ClsDefSig _ name ty ->- do write "default "- pretty name- write " :: "- pretty ty+ depend+ (write "data ")+ (withCtx+ ctx+ (do pretty h+ (case mkind of+ Nothing -> return ()+ Just kind -> do+ write " :: "+ pretty kind)))+ ClsTyFam _ h msig minj ->+ depend+ (write "type ")+ (depend+ (pretty h)+ (depend+ (traverse_+ (\case+ KindSig _ kind -> write " :: " >> pretty kind+ TyVarSig _ tyVarBind -> write " = " >> pretty tyVarBind)+ msig)+ (traverse_ (\inj -> space >> pretty inj) minj)))+ ClsTyDef _ (TypeEqn _ this that) -> do+ write "type "+ pretty this+ write " = "+ pretty that+ ClsDefSig _ name ty -> do+ write "default "+ pretty name+ write " :: "+ pretty ty instance Pretty ConDecl where prettyInternal x =@@ -1418,24 +1403,9 @@ instance Pretty Bracket where prettyInternal x = case x of- ExpBracket _ p ->- 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 "|"))+ ExpBracket _ p -> quotation "" (pretty p)+ PatBracket _ p -> quotation "p" (pretty p)+ TypeBracket _ ty -> quotation "t" (pretty ty) d@(DeclBracket _ _) -> pretty' d instance Pretty IPBind where@@ -1512,13 +1482,19 @@ instance Pretty QName where prettyInternal = \case- Qual _ m n -> do- pretty m- write "."- pretty n- UnQual _ n -> pretty n- Special _ c -> pretty c+ Qual _ mn n ->+ case n of+ Ident _ i -> do pretty mn; write "."; string i;+ Symbol _ s -> do write "("; pretty mn; write "."; string s; write ")";+ UnQual _ n ->+ case n of+ Ident _ i -> string i+ Symbol _ s -> do write "("; string s; write ")";+ Special _ s@Cons{} -> parens (pretty s)+ Special _ s@FunCon{} -> parens (pretty s)+ Special _ s -> pretty s + instance Pretty SpecialCon where prettyInternal s = case s of@@ -1803,20 +1779,7 @@ 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 (TyCon _ p) = pretty p typ (TyParen _ e) = parens (pretty e) typ (TyInfix _ a promotedop b) = do -- Apply special rules to line-break operators.@@ -1877,11 +1840,7 @@ Just n -> do write "_" pretty n-typ (TyQuasiQuote _ n s) =- brackets (depend (do string n- write "|")- (do string s- write "|"))+typ (TyQuasiQuote _ n s) = quotation n (string s) typ (TyUnboxedSum{}) = error "FIXME: No implementation for TyUnboxedSum." prettyTopName :: Name NodeInfo -> Printer ()@@ -1924,20 +1883,6 @@ for_ mbinds bindingGroup -- | Handle records specially for a prettier display (see guide).-decl' (DataDecl _ dataornew ctx dhead [con] mderivs)- | isRecord con =- do depend (do pretty dataornew- space)- (withCtx ctx- (do pretty dhead- singleCons con))- case mderivs of- [] -> return ()- [derivs] -> do space- pretty derivs- where singleCons x =- depend (write " =")- ((depend space . qualConDecl) x) decl' e = decl e declTy :: Type NodeInfo -> Printer ()@@ -2011,17 +1956,25 @@ -- | Fields are preceded with a space. conDecl :: ConDecl NodeInfo -> Printer ()-conDecl (RecDecl _ name fields) =- depend (do pretty name- write " ")- (do depend (write "{")- (prefixedLined ","- (map (depend space . pretty) fields))- write " }")-conDecl (ConDecl _ name bangty) =- depend (do prettyQuoteName name- unless (null bangty) space)- (lined (map pretty bangty))+conDecl (RecDecl _ name fields) = do+ pretty name+ newline+ indentedBlock+ (do depend (write "{")+ (prefixedLined ","+ (map (depend space . pretty) fields))+ newline+ write "}"+ )+conDecl (ConDecl _ name bangty) = do+ prettyQuoteName name+ unless+ (null bangty)+ (ifFitsOnOneLineOrElse+ (do space+ spaced (map pretty bangty))+ (do newline+ indentedBlock (lined (map pretty bangty)))) conDecl (InfixConDecl _ a f b) = inter space [pretty a, pretty f, pretty b] @@ -2034,7 +1987,7 @@ indentSpaces <- getIndentSpaces newline column indentSpaces- (do depend (write "{")+ (do depend (write "{!") (prefixedLined "," (map (depend space . pretty) fields)) newline@@ -2168,3 +2121,16 @@ [OpChainLink op] <> flattenOpChain right flattenOpChain e = [OpChainExp e]++-- | Write a Template Haskell quotation or a quasi-quotation.+--+-- >>> quotation "t" (string "Foo")+-- > [t|Foo|]+quotation :: String -> Printer () -> Printer ()+quotation quoter body =+ brackets+ (depend+ (do string quoter+ write "|")+ (do body+ write "|"))
src/HIndent/Types.hs view
@@ -11,6 +11,7 @@ (Printer(..) ,PrintState(..) ,Config(..)+ ,readExtension ,defaultConfig ,NodeInfo(..) ,NodeComment(..)@@ -27,7 +28,7 @@ import Data.Maybe import Data.Yaml (FromJSON(..)) import qualified Data.Yaml as Y-import Language.Haskell.Exts.SrcLoc+import Language.Haskell.Exts hiding (Style, prettyPrint, Pretty, style, parse) -- | A pretty printing monad. newtype Printer a =@@ -64,8 +65,18 @@ , configTrailingNewline :: !Bool -- ^ End with a newline. , configSortImports :: !Bool -- ^ Sort imports in groups. , configLineBreaks :: [String] -- ^ Break line when meets these operators.+ , configExtensions :: [Extension]+ -- ^ Extra language extensions enabled by default. } +-- | Parse an extension.+readExtension :: Monad m => String -> m Extension+readExtension x =+ case classifyExtension x -- Foo+ of+ UnknownExtension _ -> fail ("Unknown extension: " ++ x)+ x' -> return x'+ instance FromJSON Config where parseJSON (Y.Object v) = Config <$>@@ -83,7 +94,9 @@ (v Y..:? "sort-imports") <*> fmap (fromMaybe (configLineBreaks defaultConfig))- (v Y..:? "line-breaks")+ (v Y..:? "line-breaks") <*>+ (traverse readExtension+ =<< fmap (fromMaybe []) (v Y..:? "extensions")) parseJSON _ = fail "Expected Object for Config value" -- | Default style configuration.@@ -95,6 +108,7 @@ , configTrailingNewline = True , configSortImports = True , configLineBreaks = []+ , configExtensions = [] } -- | Some comment to print.
src/main/Main.hs view
@@ -34,7 +34,7 @@ data Action = Validate | Reformat -data RunMode = ShowVersion | Run Config [Extension] Action (Maybe FilePath)+data RunMode = ShowVersion | Run Config [Extension] Action [FilePath] -- | Main entry point. main :: IO ()@@ -44,12 +44,15 @@ case runMode of ShowVersion -> putStrLn ("hindent " ++ showVersion version)- Run style exts action mfilepath ->- case mfilepath of- Just filepath -> do+ Run style exts action paths ->+ if null paths then+ L8.interact+ (either error S.toLazyByteString . reformat style (Just exts) Nothing . L8.toStrict)+ else+ forM_ paths $ \filepath -> do cabalexts <- getCabalExtensionsForSourcePath filepath text <- S.readFile filepath- case reformat style (Just $ cabalexts ++ exts) mfilepath text of+ case reformat style (Just $ cabalexts ++ exts) (Just filepath) text of Left e -> error e Right out -> unless (L8.fromStrict text == S.toLazyByteString out) $@@ -69,9 +72,6 @@ else throw e IO.copyPermissions filepath fp IO.renameFile fp filepath `catch` exdev- Nothing ->- L8.interact- (either error S.toLazyByteString . reformat style (Just exts) Nothing . L8.toStrict) -- | Read config from a config file, or return 'defaultConfig'. getConfig :: IO Config@@ -124,4 +124,4 @@ , configTrailingNewline = trailing , configSortImports = fromMaybe (configSortImports s) imports }- files = optional (strArgument (metavar "FILENAME"))+ files = many (strArgument (metavar "FILENAMES"))
src/main/Markdone.hs view
@@ -13,6 +13,7 @@ import Control.DeepSeq import Control.Monad.Catch+import Control.Monad.State.Strict (State, evalState, get, put) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Char@@ -26,7 +27,7 @@ | PlainLine !ByteString | BeginFence !ByteString | EndFence- deriving (Show)+ deriving (Eq, Show) -- | A markdone document. data Markdone@@ -35,7 +36,7 @@ | CodeFence !ByteString !ByteString | PlainText !ByteString- deriving (Show,Generic)+ deriving (Eq,Show,Generic) instance NFData Markdone -- | Parse error.@@ -43,23 +44,39 @@ deriving (Typeable,Show) instance Exception MarkdownError +data TokenizerMode+ = Normal+ | Fenced+ -- | Tokenize the bytestring. tokenize :: ByteString -> [Token]-tokenize = map token . S8.lines+tokenize input = evalState (mapM token (S8.lines input)) Normal where- token 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- then if line == "```"- then EndFence- else BeginFence- (S8.dropWhile- (\c ->- c == '`' || c == ' ')- line)- else PlainLine line+ token :: ByteString -> State TokenizerMode Token+ token line = do+ mode <- get+ case mode of+ Normal ->+ if S8.isPrefixOf "#" line+ then let (hashes,title) = S8.span (== '#') line+ in return $+ Heading (S8.length hashes) (S8.dropWhile isSpace title)+ else if S8.isPrefixOf "```" line+ then do+ put Fenced+ return $+ BeginFence+ (S8.dropWhile+ (\c ->+ c == '`' || c == ' ')+ line)+ else return $ PlainLine line+ Fenced ->+ if line == "```"+ then do+ put Normal+ return EndFence+ else return $ PlainLine line -- | Parse into a forest. parse :: (Functor m,MonadThrow m) => [Token] -> m [Markdone]
src/main/Test.hs view
@@ -15,6 +15,7 @@ import Data.Function import Data.Monoid import qualified HIndent+import HIndent.CodeBlock import HIndent.Types import Markdone import Test.Hspec@@ -24,7 +25,10 @@ main = do bytes <- S.readFile "TESTS.md" forest <- parse (tokenize bytes)- hspec (toSpec forest)+ hspec $ do+ codeBlocksSpec+ markdoneSpec+ toSpec forest reformat :: Config -> S.ByteString -> ByteString reformat cfg code =@@ -97,3 +101,77 @@ skipEmptyLines :: [Markdone] -> [Markdone] skipEmptyLines (PlainText "":rest) = rest skipEmptyLines other = other++codeBlocksSpec :: Spec+codeBlocksSpec =+ describe "splitting source into code blocks" $ do+ it "should put just Haskell code in its own block" $ do+ let input = "this is totally haskell code\n\nit deserves its own block!\n"+ cppSplitBlocks input `shouldBe` [HaskellSource 0 input]+ it "should put #if/#endif and Haskell code into separate blocks" $ do+ cppSplitBlocks+ "haskell code\n#if DEBUG\ndebug code\n#endif\nmore haskell code\n" `shouldBe`+ [ HaskellSource 0 "haskell code"+ , CPPDirectives "#if DEBUG"+ , HaskellSource 2 "debug code"+ , CPPDirectives "#endif"+ , HaskellSource 4 "more haskell code\n"+ ]+ it "should put the shebang line into its own block" $ do+ cppSplitBlocks+ "#!/usr/bin/env runhaskell\n{-# LANGUAGE OverloadedStrings #-}\n" `shouldBe`+ [ Shebang "#!/usr/bin/env runhaskell"+ , HaskellSource 1 "{-# LANGUAGE OverloadedStrings #-}\n"+ ]+ it "should put a multi-line #define into its own block" $ do+ let input = "#define A \\\n macro contents \\\n go here\nhaskell code\n"+ cppSplitBlocks input `shouldBe`+ [ CPPDirectives "#define A \\\n macro contents \\\n go here"+ , HaskellSource 3 "haskell code\n"+ ]+ it "should put an unterminated multi-line #define into its own block" $ do+ cppSplitBlocks "#define A \\" `shouldBe` [CPPDirectives "#define A \\"]+ cppSplitBlocks "#define A \\\n" `shouldBe` [CPPDirectives "#define A \\"]+ cppSplitBlocks "#define A \\\n.\\" `shouldBe`+ [CPPDirectives "#define A \\\n.\\"]++markdoneSpec :: Spec+markdoneSpec = do+ describe "markdown tokenizer" $ do+ it "should tokenize plain text" $ do+ let input =+ "this is a line\nthis is another line\n\nthis is a new paragraph\n"+ tokenize input `shouldBe`+ [ PlainLine "this is a line"+ , PlainLine "this is another line"+ , PlainLine ""+ , PlainLine "this is a new paragraph"+ ]+ it "should tokenize headings" $ do+ tokenize "# Heading" `shouldBe` [Heading 1 "Heading"]+ it "should tokenize code fence beginnings with labels" $ do+ tokenize "``` haskell\n" `shouldBe` [BeginFence "haskell"]+ tokenize "```haskell expect\n" `shouldBe` [BeginFence "haskell expect"]+ tokenize "before\n```code\nafter\n" `shouldBe`+ [PlainLine "before", BeginFence "code", PlainLine "after"]+ it "should tokenize full code fences" $ do+ tokenize "```haskell\ncode goes here\n```" `shouldBe`+ [BeginFence "haskell", PlainLine "code goes here", EndFence]+ it "should tokenize lines inside code fences as plain text" $ do+ tokenize "```haskell\n#!/usr/bin/env stack\n```" `shouldBe`+ [BeginFence "haskell", PlainLine "#!/usr/bin/env stack", EndFence]+ tokenize "```haskell\n# not a heading\n```" `shouldBe`+ [BeginFence "haskell", PlainLine "# not a heading", EndFence]+ describe "markdown parser" $ do+ it "should parse a heading followed by text as a section" $ do+ let input =+ [ Heading 1 "This is a heading"+ , PlainLine "This is plain text"+ , PlainLine "split across two lines."+ ]+ output <- parse input+ output `shouldBe`+ [ Section+ "This is a heading"+ [PlainText "This is plain text\nsplit across two lines."]+ ]