Merge pull request #86 from phadej/issue29

Fix removal of empty lines in free text fields

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.

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:

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
+

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

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,49 +77,56 @@ 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 ]))
 
 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 "<input>" (C.fieldLinesToStream fls) of
             Right x -> Just (pp x)
             Left _  -> Nothing

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

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 ()

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