diff --git a/Changelog.md b/Changelog.md index 323faa5..a7b040d 100644 --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,8 @@ +# 0.1.10 + +- Fix removal of empty lines in free text fields (like `description`) + when using `cabal-version: 3.0` (where you can use empty lines) + # 0.1.9 - Change how version ranges with carets are formatted once again. diff --git a/cabal-fmt.cabal b/cabal-fmt.cabal index 7f61797..9eafc0d 100644 --- a/cabal-fmt.cabal +++ b/cabal-fmt.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: cabal-fmt -version: 0.1.9 +version: 0.1.10 synopsis: Format .cabal files category: Development description: @@ -56,6 +56,9 @@ library cabal-fmt-internal , parsec ^>=3.1.13.0 , pretty ^>=1.1.3.6 + if impl(ghc <8.10) + build-depends: base-orphans >=0.9.1 + -- our version interval normalisation build-depends: version-interval @@ -70,6 +73,7 @@ library cabal-fmt-internal CabalFmt.Fields.Modules CabalFmt.Fields.SourceFiles CabalFmt.Fields.TestedWith + CabalFmt.FreeText CabalFmt.Glob CabalFmt.Monad CabalFmt.Options @@ -114,7 +118,7 @@ test-suite golden type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: tests - main-is: Golden.hs + main-is: golden.hs -- dependencies in library build-depends: diff --git a/fixtures/issue29.cabal b/fixtures/issue29.cabal new file mode 100644 index 0000000..ddbac51 --- /dev/null +++ b/fixtures/issue29.cabal @@ -0,0 +1,22 @@ +cabal-version: 3.0 +name: issue29 +version: 0 +description: + First Paragraph + + + + + + Second Paragraph + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: + base >=4.3 && <4.18 + + exposed-modules: + Data.Bifunctor.Assoc + Data.Bifunctor.Swap + diff --git a/fixtures/issue29.format b/fixtures/issue29.format new file mode 100644 index 0000000..f4f08bb --- /dev/null +++ b/fixtures/issue29.format @@ -0,0 +1,15 @@ +cabal-version: 3.0 +name: issue29 +version: 0 +description: + First Paragraph + + Second Paragraph + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: base >=4.3 && <4.18 + exposed-modules: + Data.Bifunctor.Assoc + Data.Bifunctor.Swap diff --git a/src/CabalFmt.hs b/src/CabalFmt.hs index 54f51e8..f09b052 100644 --- a/src/CabalFmt.hs +++ b/src/CabalFmt.hs @@ -33,6 +33,7 @@ import CabalFmt.Comments import CabalFmt.Fields import CabalFmt.Fields.BuildDepends import CabalFmt.Fields.Extensions +import CabalFmt.FreeText import CabalFmt.Fields.Modules import CabalFmt.Fields.SourceFiles import CabalFmt.Fields.TestedWith @@ -49,11 +50,20 @@ import CabalFmt.Refactoring cabalFmt :: MonadCabalFmt r m => FilePath -> BS.ByteString -> m String cabalFmt filepath contents = do + -- determine cabal-version + cabalFile <- asks (optCabalFile . view options) + csv <- case cabalFile of + False -> return C.cabalSpecLatest + True -> do + gpd <- parseGpd filepath contents + return $ C.specVersion + $ C.packageDescription gpd + inputFields' <- parseFields contents let (inputFieldsC, endComments) = attachComments contents inputFields' -- parse pragmas - let parse c = case parsePragmas c of (ws, ps) -> traverse_ displayWarning ws *> return (c, ps) + let parse (pos, c) = case parsePragmas c of (ws, ps) -> traverse_ displayWarning ws *> return (pos, c, ps) inputFieldsP' <- traverse (traverse parse) inputFieldsC endCommentsPragmas <- case parsePragmas endComments of (ws, ps) -> traverse_ displayWarning ws *> return ps @@ -67,29 +77,21 @@ cabalFmt filepath contents = do -- options morphisms let pragmas :: [GlobalPragma] pragmas = fst $ partitionPragmas $ - foldMap (foldMap snd) inputFieldsP' <> endCommentsPragmas + foldMap (foldMap trdOf3) inputFieldsP' <> endCommentsPragmas optsEndo :: OptionsMorphism optsEndo = foldMap pragmaToOM pragmas - cabalFile <- asks (optCabalFile . view options) - csv <- case cabalFile of - False -> return C.cabalSpecLatest - True -> do - gpd <- parseGpd filepath contents - return $ C.specVersion - $ C.packageDescription gpd - local (over options $ \o -> runOptionsMorphism optsEndo $ o { optSpecVersion = csv }) $ do indentWith <- asks (optIndent . view options) - let inputFields = fmap (fmap fst) inputFieldsR + let inputFields = inputFieldsR - outputPrettyFields <- C.genericFromParsecFields - prettyFieldLines + outputPrettyFields <- genericFromParsecFields + (\n ann -> prettyFieldLines n (fstOf3 ann)) prettySectionArgs inputFields - return $ C.showFields' fromComments (const id) indentWith outputPrettyFields + return $ C.showFields' (fromComments . sndOf3) (const id) indentWith outputPrettyFields & if nullComments endComments then id else (++ unlines ("" : [ C.fromUTF8BS c | c <- unComments endComments ])) @@ -97,19 +99,34 @@ fromComments :: Comments -> C.CommentPosition fromComments (Comments []) = C.NoComment fromComments (Comments bss) = C.CommentBefore (map C.fromUTF8BS bss) +genericFromParsecFields + :: Applicative f + => (C.FieldName -> ann -> [C.FieldLine ann] -> f PP.Doc) -- ^ transform field contents + -> (C.FieldName -> [C.SectionArg ann] -> f [PP.Doc]) -- ^ transform section arguments + -> [C.Field ann] + -> f [C.PrettyField ann] +genericFromParsecFields f g = goMany where + goMany = traverse go + + go (C.Field (C.Name ann name) fls) = C.PrettyField ann name <$> f name ann fls + go (C.Section (C.Name ann name) secargs fs) = C.PrettySection ann name <$> g name secargs <*> goMany fs + ------------------------------------------------------------------------------- -- Field prettyfying ------------------------------------------------------------------------------- -prettyFieldLines :: MonadCabalFmt r m => C.FieldName -> [C.FieldLine ann] -> m PP.Doc -prettyFieldLines fn fls = - fromMaybe (C.prettyFieldLines fn fls) <$> knownField fn fls +prettyFieldLines :: MonadCabalFmt r m => C.FieldName -> C.Position -> [C.FieldLine CommentsPragmas] -> m PP.Doc +prettyFieldLines fn pos fls = + fromMaybe (C.prettyFieldLines fn fls) <$> knownField fn pos fls -knownField :: MonadCabalFmt r m => C.FieldName -> [C.FieldLine ann] -> m (Maybe PP.Doc) -knownField fn fls = do +knownField :: MonadCabalFmt r m => C.FieldName -> C.Position -> [C.FieldLine CommentsPragmas] -> m (Maybe PP.Doc) +knownField fn pos fls = do opts <- asks (view options) - let v = optSpecVersion opts - return $ join $ fieldDescrLookup (fieldDescrs opts) fn $ \p pp -> + let v = optSpecVersion opts + let ft = fieldlinesToFreeText v pos (fmap (fmap fstOf3) fls) + let ft' = showFreeText v ft + + return $ join $ fieldDescrLookup (fieldDescrs opts) fn (Just ft') $ \p pp -> case C.runParsecParser' v p "" (C.fieldLinesToStream fls) of Right x -> Just (pp x) Left _ -> Nothing diff --git a/src/CabalFmt/Comments.hs b/src/CabalFmt/Comments.hs index 9362868..e70ee22 100644 --- a/src/CabalFmt/Comments.hs +++ b/src/CabalFmt/Comments.hs @@ -44,9 +44,9 @@ nullComments (Comments cs) = null cs attachComments :: BS.ByteString -- ^ source with comments -> [C.Field C.Position] -- ^ parsed source fields - -> ([C.Field Comments], Comments) + -> ([C.Field (C.Position, Comments)], Comments) attachComments input inputFields = - (overAnn attach inputFields, endComments) + (overAnn attach attach' inputFields, endComments) where inputFieldsU :: [(FieldPath, C.Field C.Position)] inputFieldsU = fieldUniverseN inputFields @@ -68,27 +68,30 @@ attachComments input inputFields = , isNothing (findPath C.fieldAnn l inputFieldsU) ] - attach :: FieldPath -> C.Position -> Comments - attach fp _pos = fromMaybe mempty (Map.lookup fp comments') + attach :: FieldPath -> C.Position -> (C.Position, Comments) + attach fp pos = (pos, fromMaybe mempty (Map.lookup fp comments')) -overAnn :: forall a b. (FieldPath -> a -> b) -> [C.Field a] -> [C.Field b] -overAnn f = go' id where + attach' :: C.Position -> (C.Position, Comments) + attach' pos = (pos, mempty) + +overAnn :: forall a b. (FieldPath -> a -> b) -> (a -> b) -> [C.Field a] -> [C.Field b] +overAnn f h = go' id where go :: (FieldPath -> FieldPath) -> Int -> C.Field a -> C.Field b go g i (C.Field (C.Name a name) fls) = - C.Field (C.Name b name) (b <$$ fls) + C.Field (C.Name b name) (h <$$> fls) where b = f (g (Nth i End)) a go g i (C.Section (C.Name a name) args fls) = - C.Section (C.Name b name) (b <$$ args) (go' (g . Nth i) fls) + C.Section (C.Name b name) (h <$$> args) (go' (g . Nth i) fls) where b = f (g (Nth i End)) a go' :: (FieldPath -> FieldPath) -> [C.Field a] -> [C.Field b] go' g xs = zipWith (go g) [0..] xs - (<$$) :: (Functor f, Functor g) => x -> f (g y) -> f (g x) - x <$$ y = (x <$) <$> y + (<$$>) :: (Functor f, Functor g) => (x -> y) -> f (g x) -> f (g y) + x <$$> y = (x <$>) <$> y ------------------------------------------------------------------------------- -- Find comments in the input diff --git a/src/CabalFmt/Fields.hs b/src/CabalFmt/Fields.hs index 7c58031..fd2e545 100644 --- a/src/CabalFmt/Fields.hs +++ b/src/CabalFmt/Fields.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} @@ -15,7 +16,6 @@ module CabalFmt.Fields ( ) where import qualified Data.Map.Strict as Map -import qualified Distribution.Compat.CharParsing as C import qualified Distribution.FieldGrammar as C import qualified Distribution.Fields.Field as C import qualified Distribution.Parsec as C @@ -29,10 +29,11 @@ import CabalFmt.Prelude ------------------------------------------------------------------------------- -- strict pair -data SP = forall f. SP - { _pPretty :: !(f -> PP.Doc) - , _pParse :: !(forall m. C.CabalParsing m => m f) - } +data SP where + FreeText :: SP + SP :: !(f -> PP.Doc) + -> !(forall m. C.CabalParsing m => m f) + -> SP -- | Lookup both pretty-printer and value parser. -- @@ -42,10 +43,12 @@ fieldDescrLookup :: C.CabalParsing m => FieldDescrs s a -> C.FieldName + -> r -- field is freetext -> (forall f. m f -> (f -> PP.Doc) -> r) -> Maybe r -fieldDescrLookup (F m) fn kont = kont' <$> Map.lookup fn m where +fieldDescrLookup (F m) fn ft kont = kont' <$> Map.lookup fn m where kont' (SP a b) = kont b a + kont' FreeText = ft -- | A collection field parsers and pretty-printers. newtype FieldDescrs s a = F { runF :: Map.Map C.FieldName SP } @@ -94,17 +97,9 @@ instance C.FieldGrammar PrettyParsec FieldDescrs where monoidalFieldAla fn _pack _ = singletonF fn (C.pretty . pack' _pack) (unpack' _pack <$> C.parsec) - freeTextField fn _ = singletonF fn - PP.text - (C.munch $ const True) - - freeTextFieldDef fn _ = singletonF fn - PP.text - (C.munch $ const True) - - freeTextFieldDefST fn _ = singletonF fn - PP.text - (C.munch $ const True) + freeTextField fn _ = F $ Map.singleton fn FreeText + freeTextFieldDef fn _ = F $ Map.singleton fn FreeText + freeTextFieldDefST fn _ = F $ Map.singleton fn FreeText prefixedFields _fnPfx _l = F mempty knownField _ = pure () diff --git a/src/CabalFmt/FreeText.hs b/src/CabalFmt/FreeText.hs new file mode 100644 index 0000000..95659e5 --- /dev/null +++ b/src/CabalFmt/FreeText.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} +module CabalFmt.FreeText ( + fieldlinesToFreeText, + showFreeText, +) where + +import Data.List (foldl') + +import qualified Distribution.CabalSpecVersion as C +import qualified Distribution.Fields.Field as C +import qualified Distribution.Parsec as C +import qualified Distribution.Parsec.Position as C +import qualified Distribution.Pretty as C +import qualified Distribution.Utils.String as C (trim) +import qualified Text.PrettyPrint as PP + +import CabalFmt.Prelude + +showFreeText :: C.CabalSpecVersion -> String -> PP.Doc +showFreeText v + | v >= C.CabalSpecV3_0 + = C.showFreeTextV3 + + | otherwise + = C.showFreeText + +-- This should perfectly be exported from Cabal-syntax +fieldlinesToFreeText :: C.CabalSpecVersion -> C.Position -> [C.FieldLine C.Position] -> String +fieldlinesToFreeText v + | v >= C.CabalSpecV3_0 + = fieldlinesToFreeText3 + + | otherwise + = \_ -> fieldlinesToFreeText2 + +fieldlinesToFreeText2 :: [C.FieldLine C.Position] -> String +fieldlinesToFreeText2 [C.FieldLine _ "."] = "." +fieldlinesToFreeText2 fls = intercalate "\n" (map go fls) + where + go (C.FieldLine _ bs) + | s == "." = "" + | otherwise = s + where + s = C.trim (fromUTF8BS bs) + +fieldlinesToFreeText3 :: C.Position -> [C.FieldLine C.Position] -> String +fieldlinesToFreeText3 _ [] = "" +fieldlinesToFreeText3 _ [C.FieldLine _ bs] = fromUTF8BS bs +fieldlinesToFreeText3 pos (C.FieldLine pos1 bs1 : fls2@(C.FieldLine pos2 _ : _)) + -- if first line is on the same line with field name: + -- the indentation level is either + -- 1. the indentation of left most line in rest fields + -- 2. the indentation of the first line + -- whichever is leftmost + | C.positionRow pos == C.positionRow pos1 = + concat $ + fromUTF8BS bs1 + : mealy (mk mcol1) pos1 fls2 + -- otherwise, also indent the first line + | otherwise = + concat $ + replicate (C.positionCol pos1 - mcol2) ' ' + : fromUTF8BS bs1 + : mealy (mk mcol2) pos1 fls2 + where + mcol1 = foldl' (\a b -> min a $ C.positionCol $ C.fieldLineAnn b) (min (C.positionCol pos1) (C.positionCol pos2)) fls2 + mcol2 = foldl' (\a b -> min a $ C.positionCol $ C.fieldLineAnn b) (C.positionCol pos1) fls2 + + mk :: Int -> C.Position -> C.FieldLine C.Position -> (C.Position, String) + mk col p (C.FieldLine q bs) = + ( q + -- in Cabal-syntax there is no upper limit, i.e. no min + -- we squash multiple empty lines to one + , replicate (min 2 newlines) '\n' + ++ replicate indent ' ' + ++ fromUTF8BS bs + ) + where + newlines = C.positionRow q - C.positionRow p + indent = C.positionCol q - col + +mealy :: (s -> a -> (s, b)) -> s -> [a] -> [b] +mealy f = go + where + go _ [] = [] + go s (x : xs) = let ~(s', y) = f s x in y : go s' xs diff --git a/src/CabalFmt/Prelude.hs b/src/CabalFmt/Prelude.hs index f2a6bc7..877fbbd 100644 --- a/src/CabalFmt/Prelude.hs +++ b/src/CabalFmt/Prelude.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- License: GPL-3.0-or-later -- Copyright: Oleg Grenrus @@ -42,6 +43,10 @@ module CabalFmt.Prelude ( traverseOf, over, view, _1, + -- ** Tuples + fstOf3, + sndOf3, + trdOf3, ) where import Control.Arrow ((&&&)) @@ -62,6 +67,10 @@ import System.FilePath (dropExtension, splitDirectories) import qualified Distribution.Utils.Generic as C +#ifdef MIN_VERSION_base_orphans +import Data.Orphans () +#endif + traverseOf :: Applicative f => ((a -> f b) -> s -> f t) @@ -70,3 +79,12 @@ traverseOf = id _1 :: Functor f => (a -> f b) -> (a, c) -> f (b, c) _1 f (a, c) = (\b -> (b, c)) <$> f a + +fstOf3 :: (a,b,c) -> a +fstOf3 (a,_,_) = a + +sndOf3 :: (a,b,c) -> b +sndOf3 (_,b,_) = b + +trdOf3 :: (a,b,c) -> c +trdOf3 (_,_,c) = c diff --git a/src/CabalFmt/Refactoring/ExpandExposedModules.hs b/src/CabalFmt/Refactoring/ExpandExposedModules.hs index f9bfd8d..e2b82d3 100644 --- a/src/CabalFmt/Refactoring/ExpandExposedModules.hs +++ b/src/CabalFmt/Refactoring/ExpandExposedModules.hs @@ -18,13 +18,13 @@ import CabalFmt.Refactoring.Type refactoringExpandExposedModules :: FieldRefactoring refactoringExpandExposedModules C.Section {} = pure Nothing -refactoringExpandExposedModules (C.Field name@(C.Name (_, pragmas) _n) fls) = do +refactoringExpandExposedModules (C.Field name@(C.Name (_, _, pragmas) _n) fls) = do dirs <- parse pragmas files <- traverseOf (traverse . _1) getFiles dirs let newModules :: [C.FieldLine CommentsPragmas] newModules = catMaybes - [ return $ C.FieldLine mempty $ toUTF8BS $ intercalate "." parts + [ return $ C.FieldLine emptyCommentsPragmas $ toUTF8BS $ intercalate "." parts | (files', mns) <- files , file <- files' , let parts = splitDirectories $ dropExtension file diff --git a/src/CabalFmt/Refactoring/Fragments.hs b/src/CabalFmt/Refactoring/Fragments.hs index 9827260..37d51ff 100644 --- a/src/CabalFmt/Refactoring/Fragments.hs +++ b/src/CabalFmt/Refactoring/Fragments.hs @@ -12,6 +12,7 @@ import Text.PrettyPrint (hsep, render) import qualified Distribution.Fields as C import qualified Distribution.Fields.Field as C import qualified Distribution.Fields.Pretty as C +import qualified Distribution.Parsec as C import CabalFmt.Comments import CabalFmt.Monad @@ -70,10 +71,10 @@ refactoringFragments field = do pure Nothing where noCommentsPragmas :: Functor f => [f ann] -> [f CommentsPragmas] - noCommentsPragmas = map ((Comments [], []) <$) + noCommentsPragmas = map ((C.zeroPos, Comments [], []) <$) getPragmas :: C.Field CommentsPragmas -> [FieldPragma] - getPragmas = snd . C.fieldAnn + getPragmas = trdOf3 . C.fieldAnn showSection :: C.Name ann -> [C.SectionArg ann] -> String showSection (C.Name _ n) [] = show n diff --git a/src/CabalFmt/Refactoring/GlobFiles.hs b/src/CabalFmt/Refactoring/GlobFiles.hs index 3b83892..da3d63e 100644 --- a/src/CabalFmt/Refactoring/GlobFiles.hs +++ b/src/CabalFmt/Refactoring/GlobFiles.hs @@ -19,13 +19,13 @@ import CabalFmt.Refactoring.Type refactoringGlobFiles :: FieldRefactoring refactoringGlobFiles C.Section {} = pure Nothing -refactoringGlobFiles (C.Field name@(C.Name (_, pragmas) _n) fls) = do +refactoringGlobFiles (C.Field name@(C.Name (_, _, pragmas) _n) fls) = do globs <- parse pragmas files <- fmap concat (traverse match' globs) let newFiles :: [C.FieldLine CommentsPragmas] newFiles = catMaybes - [ return $ C.FieldLine mempty $ toUTF8BS file + [ return $ C.FieldLine emptyCommentsPragmas $ toUTF8BS file | file <- files ] diff --git a/src/CabalFmt/Refactoring/Type.hs b/src/CabalFmt/Refactoring/Type.hs index ee04bbf..34ddbe3 100644 --- a/src/CabalFmt/Refactoring/Type.hs +++ b/src/CabalFmt/Refactoring/Type.hs @@ -6,10 +6,12 @@ module CabalFmt.Refactoring.Type ( FieldRefactoring, CommentsPragmas, + emptyCommentsPragmas, rewriteFields, ) where -import qualified Distribution.Fields as C +import qualified Distribution.Fields as C +import qualified Distribution.Parsec as C import CabalFmt.Comments import CabalFmt.Monad @@ -19,7 +21,10 @@ import CabalFmt.Pragma -- Refactoring type ------------------------------------------------------------------------------- -type CommentsPragmas = (Comments, [FieldPragma]) +type CommentsPragmas = (C.Position, Comments, [FieldPragma]) + +emptyCommentsPragmas :: CommentsPragmas +emptyCommentsPragmas = (C.zeroPos, mempty, mempty) type FieldRefactoring = forall r m. MonadCabalFmt r m diff --git a/tests/Golden.hs b/tests/golden.hs similarity index 90% rename from tests/Golden.hs rename to tests/golden.hs index dd3ad3f..52945a2 100644 --- a/tests/Golden.hs +++ b/tests/golden.hs @@ -32,6 +32,7 @@ main = defaultMain $ testGroup "tests" , goldenTest' "fragment-section" , goldenTest' "issue69" + , goldenTest' "issue29" ] goldenTest' :: String -> TestTree @@ -52,7 +53,13 @@ goldenTest' n = goldenTest n readGolden makeTest cmp writeGolden case runCabalFmt files defaultOptions $ cabalFmt inputPath (toUTF8BS output') of Left err -> fail ("Second pass: " ++ show err) Right (output'', _) -> do - unless (output' == output'') $ fail "Output not idempotent" + unless (output' == output'') $ do + putStrLn "<<<<<<<" + putStr output' + putStrLn "=======" + putStr output'' + putStrLn ">>>>>>>" + fail "Output not idempotent" return (toUTF8BS $ unlines (map ("-- " ++) ws) ++ output') cmp a b | a == b = return Nothing