foo

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/FreeText.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE OverloadedStrings #-}
+module CabalFmt.FreeText (
+    fieldlinesToFreeText,
+) 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.Utils.String as C (trim)
+
+import CabalFmt.Prelude
+
+-- 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
+      , replicate 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

tests/golden.hs

@@ -0,0 +1,105 @@
+module Main (main) where
+
+import System.FilePath            ((-<.>), (</>))
+import System.IO                  (hClose, hFlush)
+import System.IO.Temp             (withSystemTempFile)
+import System.Process             (readProcessWithExitCode)
+import Test.Tasty                 (TestTree, defaultMain, testGroup)
+import Test.Tasty.Golden.Advanced (goldenTest)
+
+import qualified Data.ByteString       as BS
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.Map              as Map
+
+import CabalFmt         (cabalFmt)
+import CabalFmt.Monad   (runCabalFmt)
+import CabalFmt.Options (defaultOptions)
+import CabalFmt.Prelude
+
+main :: IO ()
+main = defaultMain $ testGroup "tests"
+    [ goldenTest' "cabal-fmt"
+    , goldenTest' "Cabal"
+    , goldenTest' "Cabal-notab"
+    , goldenTest' "simple-example"
+    , goldenTest' "tree-diff"
+
+    , goldenTest' "fragment-missing"
+    , goldenTest' "fragment-empty"
+    , goldenTest' "fragment-wrong-field"
+    , goldenTest' "fragment-wrong-type"
+    , goldenTest' "fragment-multiple"
+    , goldenTest' "fragment-section"
+
+    , goldenTest' "issue69"
+    , goldenTest' "issue29"
+    ]
+
+goldenTest' :: String -> TestTree
+goldenTest' n = goldenTest n readGolden makeTest cmp writeGolden
+  where
+    goldenPath = "fixtures" </> n -<.> "format"
+    inputPath  = "fixtures" </> n -<.> "cabal"
+
+    readGolden  = BS.readFile goldenPath
+    writeGolden = BS.writeFile goldenPath
+
+    makeTest = do
+        contents <- BS.readFile inputPath
+        case runCabalFmt files defaultOptions $ cabalFmt inputPath contents of
+            Left err            -> fail ("First pass: " ++ show err)
+            Right (output', ws) -> do
+                -- idempotent
+                case runCabalFmt files defaultOptions $ cabalFmt inputPath (toUTF8BS output') of
+                    Left err            -> fail ("Second pass: " ++ show err)
+                    Right (output'', _) -> do
+                        unless (output' == output'') $ do
+                            print output'
+                            fail "Output not idempotent"
+                        return (toUTF8BS $ unlines (map ("-- " ++) ws) ++ output')
+
+    cmp a b | a == b    = return Nothing
+            | otherwise =
+        withSystemTempFile "cabal-fmt-test.txt" $ \fpA hdlA ->
+        withSystemTempFile "cabal-fmt-test.txt" $ \fpB hdlB -> do
+            BS.hPutStr hdlA a
+            BS.hPutStr hdlB b
+            hFlush hdlA
+            hFlush hdlB
+            hClose hdlA
+            hClose hdlB
+
+            Just . postProcess <$> readProcess' "diff" ["-u", fpA, fpB] ""
+
+    postProcess :: String -> String
+    postProcess = unlines . (["======"] ++) . map (concatMap char) . (++ ["======"]). lines where
+        char '\r' = "{CR}"
+        char c    = [c]
+
+    readProcess' proc args input = do
+        (_, out, _) <- readProcessWithExitCode proc args input
+        return out
+
+files :: Map.Map FilePath BS.ByteString
+files = Map.fromList
+    [ p "empty.fragment" ""
+
+    , p "build-depends.fragment"
+        "build-depends: base, doctest >=0.15 && <0.17, QuickCheck >=2.12 && <2.13, simple-example, template-haskell"
+
+    , p "tested-with.fragment"
+        "tested-with: GHC ==8.0.2"
+
+    , p "common.fragment"
+        "common deps\n  build-depends: base, bytestring, containers\n  ghc-options: -Wall"
+
+    , p "multiple.fragment"
+        "build-depends: base\nghc-options: -Wall"
+
+    , p ("cbits" </> "header.h") "..."
+    , p ("cbits" </> "source1.c") "..."
+    , p ("cbits" </> "source2.c") "..."
+    , p ("cbits" </> "sub" </> "source3.c") "..."
+    ]
+  where
+    p x y = (x, BS8.pack y)