diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,12 @@ +# 0.1.4 + +- Add `-n` / `--no-cabal-file` to format cabal like, but not package files. + Useful to format `cabal.project` or `cabal.haskell-ci`. +- Add `fragment` pragma to substitute a field or a section with + contents of external file. + Useful in multi-package setting to keep for example + `tested-with` field or `common deps` stanza in sync. + # 0.1.3 - GHC-8.10 support. Require Cabal-3.2 diff --git a/cabal-fmt.cabal b/cabal-fmt.cabal --- a/cabal-fmt.cabal +++ b/cabal-fmt.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: cabal-fmt -version: 0.1.3 +version: 0.1.4 synopsis: Format .cabal files category: Development description: @@ -55,6 +55,7 @@ CabalFmt.Prelude CabalFmt.Refactoring CabalFmt.Refactoring.ExpandExposedModules + CabalFmt.Refactoring.Fragments CabalFmt.Refactoring.Type other-extensions: @@ -83,7 +84,7 @@ , filepath -- extra dependencies - build-depends: optparse-applicative >=0.14.3.0 && <0.16 + build-depends: optparse-applicative >=0.14.3.0 && <0.17 test-suite golden type: exitcode-stdio-1.0 @@ -97,6 +98,7 @@ , bytestring , Cabal , cabal-fmt-internal + , containers -- test dependencies build-depends: diff --git a/cli/Main.hs b/cli/Main.hs --- a/cli/Main.hs +++ b/cli/Main.hs @@ -90,6 +90,8 @@ , indentP , tabularP , noTabularP + , cabalFileP + , noCabalFileP , stdoutP , inplaceP , checkP @@ -109,6 +111,12 @@ noTabularP = O.flag' (mkOptionsMorphism $ \opts -> opts { optTabular = False }) $ O.long "no-tabular" + + cabalFileP = O.flag' (mkOptionsMorphism $ \opts -> opts { optCabalFile = True }) + $ O.long "cabal-file" + + noCabalFileP = O.flag' (mkOptionsMorphism $ \opts -> opts { optCabalFile = False }) + $ O.short 'n' <> O.long "no-cabal-file" <> O.help "Don't parse as .cabal file" stdoutP = O.flag' (mkOptionsMorphism $ \opts -> opts { optMode = ModeStdout }) $ O.long "stdout" <> O.help "Write output to stdout (default)" diff --git a/fixtures/fragment-empty.cabal b/fixtures/fragment-empty.cabal new file mode 100644 --- /dev/null +++ b/fixtures/fragment-empty.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.4 +name: fragment +version: 1 + +library + exposed-modules: Example + -- cabal-fmt: fragment empty.fragment + build-depends: base >=4.3 && <4.13 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/fixtures/fragment-empty.format b/fixtures/fragment-empty.format new file mode 100644 --- /dev/null +++ b/fixtures/fragment-empty.format @@ -0,0 +1,12 @@ +-- Fragment empty.fragment is empty. +cabal-version: 2.4 +name: fragment +version: 1 + +library + exposed-modules: Example + + -- cabal-fmt: fragment empty.fragment + build-depends: base >=4.3 && <4.13 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/fixtures/fragment-missing.cabal b/fixtures/fragment-missing.cabal new file mode 100644 --- /dev/null +++ b/fixtures/fragment-missing.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.4 +name: fragment +version: 1 + +library + exposed-modules: Example + -- cabal-fmt: fragment missing.fragment + build-depends: base >=4.3 && <4.13 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/fixtures/fragment-missing.format b/fixtures/fragment-missing.format new file mode 100644 --- /dev/null +++ b/fixtures/fragment-missing.format @@ -0,0 +1,12 @@ +-- Fragment missing.fragment failed to read: "doesn't exist" +cabal-version: 2.4 +name: fragment +version: 1 + +library + exposed-modules: Example + + -- cabal-fmt: fragment missing.fragment + build-depends: base >=4.3 && <4.13 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/fixtures/fragment-multiple.cabal b/fixtures/fragment-multiple.cabal new file mode 100644 --- /dev/null +++ b/fixtures/fragment-multiple.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.4 +name: fragment +version: 1 + +library + exposed-modules: Example + -- cabal-fmt: fragment multiple.fragment + build-depends: base >=4.3 && <4.13 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/fixtures/fragment-multiple.format b/fixtures/fragment-multiple.format new file mode 100644 --- /dev/null +++ b/fixtures/fragment-multiple.format @@ -0,0 +1,12 @@ +-- Fragment multiple.fragment contains multiple fields or sections, using only the first. +cabal-version: 2.4 +name: fragment +version: 1 + +library + exposed-modules: Example + + -- cabal-fmt: fragment multiple.fragment + build-depends: base + hs-source-dirs: src + default-language: Haskell2010 diff --git a/fixtures/fragment-section.cabal b/fixtures/fragment-section.cabal new file mode 100644 --- /dev/null +++ b/fixtures/fragment-section.cabal @@ -0,0 +1,12 @@ +cabal-version: 2.4 +name: fragment +version: 1 + +-- cabal-fmt: fragment common.fragment +common deps + +library + import: deps + exposed-modules: Example + hs-source-dirs: src + default-language: Haskell2010 diff --git a/fixtures/fragment-section.format b/fixtures/fragment-section.format new file mode 100644 --- /dev/null +++ b/fixtures/fragment-section.format @@ -0,0 +1,18 @@ +cabal-version: 2.4 +name: fragment +version: 1 + +-- cabal-fmt: fragment common.fragment +common deps + build-depends: + , base + , bytestring + , containers + + ghc-options: -Wall + +library + import: deps + exposed-modules: Example + hs-source-dirs: src + default-language: Haskell2010 diff --git a/fixtures/fragment-wrong-field.cabal b/fixtures/fragment-wrong-field.cabal new file mode 100644 --- /dev/null +++ b/fixtures/fragment-wrong-field.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.4 +name: fragment +version: 1 + +library + exposed-modules: Example + -- cabal-fmt: fragment tested-with.fragment + build-depends: base >=4.3 && <4.13 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/fixtures/fragment-wrong-field.format b/fixtures/fragment-wrong-field.format new file mode 100644 --- /dev/null +++ b/fixtures/fragment-wrong-field.format @@ -0,0 +1,12 @@ +-- Fragment tested-with.fragment contains field "tested-with", expecting field "build-depends". +cabal-version: 2.4 +name: fragment +version: 1 + +library + exposed-modules: Example + + -- cabal-fmt: fragment tested-with.fragment + build-depends: base >=4.3 && <4.13 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/fixtures/fragment-wrong-type.cabal b/fixtures/fragment-wrong-type.cabal new file mode 100644 --- /dev/null +++ b/fixtures/fragment-wrong-type.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.4 +name: fragment +version: 1 + +library + exposed-modules: Example + -- cabal-fmt: fragment common.fragment + build-depends: base >=4.3 && <4.13 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/fixtures/fragment-wrong-type.format b/fixtures/fragment-wrong-type.format new file mode 100644 --- /dev/null +++ b/fixtures/fragment-wrong-type.format @@ -0,0 +1,12 @@ +-- Fragment common.fragment contains a section "common deps", expecting field "build-depends". +cabal-version: 2.4 +name: fragment +version: 1 + +library + exposed-modules: Example + + -- cabal-fmt: fragment common.fragment + build-depends: base >=4.3 && <4.13 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/fixtures/simple-example.cabal b/fixtures/simple-example.cabal --- a/fixtures/simple-example.cabal +++ b/fixtures/simple-example.cabal @@ -39,12 +39,9 @@ test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs + + -- cabal-fmt: fragment build-depends.fragment build-depends: - base, - doctest >= 0.15 && <0.17, - QuickCheck ==2.12.*, - simple-example, - template-haskell ghc-options: -Wall -threaded hs-source-dirs: tests diff --git a/fixtures/simple-example.format b/fixtures/simple-example.format --- a/fixtures/simple-example.format +++ b/fixtures/simple-example.format @@ -45,6 +45,8 @@ test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs + + -- cabal-fmt: fragment build-depends.fragment build-depends: base , doctest >=0.15 && <0.17 diff --git a/src/CabalFmt.hs b/src/CabalFmt.hs --- a/src/CabalFmt.hs +++ b/src/CabalFmt.hs @@ -48,7 +48,6 @@ cabalFmt :: MonadCabalFmt r m => FilePath -> BS.ByteString -> m String cabalFmt filepath contents = do - gpd <- parseGpd filepath contents inputFields' <- parseFields contents let (inputFieldsC, endComments) = attachComments contents inputFields' @@ -62,16 +61,23 @@ inputFieldsR <- foldM (&) inputFieldsP refactorings -- options morphisms - let pragmas = foldMap (foldMap snd) inputFieldsR <> endCommentsPragmas + let pragmas :: [Pragma] + pragmas = foldMap (foldMap snd) inputFieldsR <> endCommentsPragmas + optsEndo :: OptionsMorphism optsEndo = foldMap pragmaToOM pragmas - let v = C.cabalSpecFromVersionDigits - $ C.versionNumbers - $ C.specVersion - $ C.packageDescription gpd + cabalFile <- asks (optCabalFile . view options) + csv <- case cabalFile of + False -> return C.cabalSpecLatest + True -> do + gpd <- parseGpd filepath contents + return $ C.cabalSpecFromVersionDigits + $ C.versionNumbers + $ C.specVersion + $ C.packageDescription gpd - local (over options $ \o -> runOptionsMorphism optsEndo $ o { optSpecVersion = v }) $ do + local (over options $ \o -> runOptionsMorphism optsEndo $ o { optSpecVersion = csv }) $ do indentWith <- asks (optIndent . view options) let inputFields = fmap (fmap fst) inputFieldsR @@ -93,7 +99,8 @@ refactorings :: MonadCabalFmt r m => [Refactoring' r m] refactorings = - [ refactoringExpandExposedModules + [ refactoringFragments + , refactoringExpandExposedModules ] ------------------------------------------------------------------------------- @@ -166,3 +173,4 @@ pragmaToOM (PragmaOptIndent n) = mkOptionsMorphism $ \opts -> opts { optIndent = n } pragmaToOM (PragmaOptTabular b) = mkOptionsMorphism $ \opts -> opts { optTabular = b } pragmaToOM PragmaExpandModules {} = mempty +pragmaToOM PragmaFragment {} = mempty diff --git a/src/CabalFmt/Monad.hs b/src/CabalFmt/Monad.hs --- a/src/CabalFmt/Monad.hs +++ b/src/CabalFmt/Monad.hs @@ -3,13 +3,14 @@ -- Copyright: Oleg Grenrus {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} module CabalFmt.Monad ( -- * Monad class MonadCabalFmt (..), getFiles, + Contents (..), -- * Pure implementation CabalFmt, runCabalFmt, @@ -18,15 +19,19 @@ runCabalFmtIO, ) where -import Control.Exception (catch, throwIO, try) +import Control.Exception (IOException, catch, throwIO, try, displayException) import Control.Monad (when) import Control.Monad.Except (MonadError (..)) import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Reader (MonadReader, ReaderT (..), runReaderT, asks) +import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks, runReaderT) +import Control.Monad.Writer (WriterT, runWriterT, tell) +import Data.Bifunctor (first) +import System.Exit (exitFailure) import System.FilePath (()) import System.IO (hPutStrLn, stderr) -import System.Exit (exitFailure) +import qualified Data.ByteString as BS +import qualified Data.Map as Map import qualified System.Directory as D import CabalFmt.Error @@ -45,8 +50,16 @@ class (HasOptions r, MonadReader r m, MonadError Error m) => MonadCabalFmt r m | m -> r where listDirectory :: FilePath -> m [FilePath] doesDirectoryExist :: FilePath -> m Bool + + readFileBS :: FilePath -> m Contents + displayWarning :: String -> m () +data Contents + = Contents BS.ByteString + | NoIO + | IOError String + ------------------------------------------------------------------------------- -- Pure ------------------------------------------------------------------------------- @@ -55,18 +68,30 @@ -- -- 'listDirectory' always return empty list. -- -newtype CabalFmt a = CabalFmt { unCabalFmt :: ReaderT Options (Either Error) a } - deriving newtype (Functor, Applicative, Monad, MonadError Error, MonadReader Options) +newtype CabalFmt a = CabalFmt { unCabalFmt :: ReaderT (Options, Map.Map FilePath BS.ByteString) (WriterT [String] (Either Error)) a } + deriving newtype (Functor, Applicative, Monad, MonadError Error) +instance MonadReader Options CabalFmt where + ask = CabalFmt $ asks fst + + local f (CabalFmt m) = CabalFmt $ local (first f) m + instance MonadCabalFmt Options CabalFmt where listDirectory _ = return [] doesDirectoryExist _ = return False + readFileBS p = CabalFmt $ do + files <- asks snd + return (maybe (IOError "doesn't exist") Contents $ Map.lookup p files) displayWarning w = do werror <- asks optError - when werror $ throwError $ WarningError w + if werror + then throwError $ WarningError w + else CabalFmt $ tell [w] -runCabalFmt :: Options -> CabalFmt a -> Either Error a -runCabalFmt opts m = runReaderT (unCabalFmt m) opts +runCabalFmt + :: Map.Map FilePath BS.ByteString -> Options + -> CabalFmt a -> Either Error (a, [String]) +runCabalFmt files opts m = runWriterT (runReaderT (unCabalFmt m) (opts, files)) ------------------------------------------------------------------------------- -- IO @@ -102,11 +127,21 @@ case rd of Nothing -> return False Just d -> liftIO (D.doesDirectoryExist (d p)) - displayWarning w = do + readFileBS p = do + rd <- asks optRootDir + case rd of + Nothing -> return NoIO + Just d -> liftIO $ catchIOError $ BS.readFile (d p) + displayWarning w = do werror <- asks (optError . optOpt) liftIO $ do hPutStrLn stderr $ (if werror then "ERROR: " else "WARNING: ") ++ w when werror exitFailure + +catchIOError :: IO BS.ByteString -> IO Contents +catchIOError m = catch (fmap Contents m) handler where + handler :: IOException -> IO Contents + handler exc = return (IOError (displayException exc)) runCabalFmtIO :: Maybe FilePath -> Options -> CabalFmtIO a -> IO (Either Error a) runCabalFmtIO mfp opts m = try $ runReaderT (unCabalFmtIO m) (Options' mfp opts) diff --git a/src/CabalFmt/Options.hs b/src/CabalFmt/Options.hs --- a/src/CabalFmt/Options.hs +++ b/src/CabalFmt/Options.hs @@ -23,6 +23,7 @@ { optError :: !Bool , optIndent :: !Int , optTabular :: !Bool + , optCabalFile :: !Bool , optSpecVersion :: !C.CabalSpecVersion , optMode :: !Mode } @@ -33,6 +34,7 @@ { optError = False , optIndent = 2 , optTabular = True + , optCabalFile = True , optSpecVersion = C.cabalSpecLatest , optMode = ModeStdout } diff --git a/src/CabalFmt/Pragma.hs b/src/CabalFmt/Pragma.hs --- a/src/CabalFmt/Pragma.hs +++ b/src/CabalFmt/Pragma.hs @@ -14,6 +14,7 @@ = PragmaOptIndent Int | PragmaOptTabular Bool | PragmaExpandModules FilePath [C.ModuleName] + | PragmaFragment FilePath deriving (Show) -- | Parse pragma from 'ByteString'. @@ -38,6 +39,7 @@ "indent" -> indent "tabular" -> return $ PragmaOptTabular True "no-tabular" -> return $ PragmaOptTabular False + "fragment" -> fragment _ -> fail $ "Unknown pragma " ++ t expandModules :: C.ParsecParser Pragma @@ -52,6 +54,12 @@ C.spaces n <- C.integral return $ PragmaOptIndent n + + fragment :: C.ParsecParser Pragma + fragment = do + C.spaces + fn <- C.parsecToken + return (PragmaFragment fn) stripWhitespace :: ByteString -> ByteString stripWhitespace bs = case BS.uncons bs of diff --git a/src/CabalFmt/Prelude.hs b/src/CabalFmt/Prelude.hs --- a/src/CabalFmt/Prelude.hs +++ b/src/CabalFmt/Prelude.hs @@ -6,6 +6,8 @@ module CabalFmt.Prelude ( -- * Control.Arrow (&&&), + -- * Control.Monad + when, unless, void, -- * Data.Bifunctor bimap, -- * Data.Char @@ -13,7 +15,7 @@ -- * Data.Either partitionEithers, -- * Data.Foldable - toList, traverse_, + toList, traverse_, asum, -- * Data.Function on, (&), -- * Data.List @@ -43,12 +45,13 @@ ) where import Control.Arrow ((&&&)) +import Control.Monad (unless, void, when) import Control.Monad.Except (catchError, throwError) import Data.Bifunctor (bimap) import Data.ByteString (ByteString) import Data.Char (toLower) import Data.Either (partitionEithers) -import Data.Foldable (toList, traverse_) +import Data.Foldable (asum, toList, traverse_) import Data.Function (on, (&)) import Data.List (intercalate, nub, sortBy, sortOn) import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) diff --git a/src/CabalFmt/Refactoring.hs b/src/CabalFmt/Refactoring.hs --- a/src/CabalFmt/Refactoring.hs +++ b/src/CabalFmt/Refactoring.hs @@ -6,4 +6,5 @@ ) where import CabalFmt.Refactoring.ExpandExposedModules as X +import CabalFmt.Refactoring.Fragments as X import CabalFmt.Refactoring.Type as X diff --git a/src/CabalFmt/Refactoring/ExpandExposedModules.hs b/src/CabalFmt/Refactoring/ExpandExposedModules.hs --- a/src/CabalFmt/Refactoring/ExpandExposedModules.hs +++ b/src/CabalFmt/Refactoring/ExpandExposedModules.hs @@ -4,8 +4,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module CabalFmt.Refactoring.ExpandExposedModules ( - Refactoring, - Refactoring', refactoringExpandExposedModules, ) where diff --git a/src/CabalFmt/Refactoring/Fragments.hs b/src/CabalFmt/Refactoring/Fragments.hs new file mode 100644 --- /dev/null +++ b/src/CabalFmt/Refactoring/Fragments.hs @@ -0,0 +1,83 @@ +-- | +-- License: GPL-3.0-or-later +-- Copyright: Oleg Grenrus +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +module CabalFmt.Refactoring.Fragments ( + refactoringFragments, + ) where + +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 CabalFmt.Comments +import CabalFmt.Monad +import CabalFmt.Parser +import CabalFmt.Pragma +import CabalFmt.Prelude +import CabalFmt.Refactoring.Type + +refactoringFragments :: Refactoring +refactoringFragments = rewriteFields refact where + refact :: MonadCabalFmt r m => C.Field CommentsPragmas -> m (Maybe (C.Field CommentsPragmas)) + refact field = do + parse (getPragmas field) >>= \mp -> case mp of + Nothing -> pure Nothing + Just p -> readFileBS p >>= \mcontents -> case mcontents of + NoIO -> pure Nothing + IOError err -> do + displayWarning $ "Fragment " ++ p ++ " failed to read: " ++ show err + pure Nothing + Contents c -> do + fields <- parseFields c + case (field, fields) of + (_, []) -> do + displayWarning $ "Fragment " ++ p ++ " is empty." + pure Nothing + + (C.Field (C.Name _ n) _, C.Section name@(C.Name _ _) arg _ : _) -> do + displayWarning $ "Fragment " ++ p ++ " contains a section " ++ showSection name arg ++ ", expecting field " ++ show n ++ "." + pure Nothing + (C.Section name@(C.Name _ _) arg _, C.Field (C.Name _ n') _ : _) -> do + displayWarning $ "Fragment " ++ p ++ " contains a field " ++ show n' ++ ", expection section " ++ showSection name arg ++ "." + pure Nothing + + (C.Field name@(C.Name _ n) _, C.Field (C.Name _ n') fls' : rest) -> do + unless (null rest) $ + displayWarning $ "Fragment " ++ p ++ " contains multiple fields or sections, using only the first." + if n == n' + then do + -- everything is fine, replace + pure (Just (C.Field name (noCommentsPragmas fls'))) + else do + displayWarning $ "Fragment " ++ p ++ " contains field " ++ show n' ++ ", expecting field " ++ show n ++ "." + pure Nothing + + (C.Section name@(C.Name _ _) arg _, C.Section name'@(C.Name _ _) arg' fs' : rest) -> do + unless (null rest) $ + displayWarning $ "Fragment " ++ p ++ " contains multiple fields or sections, using only the first." + + if (void name == void name' && map void arg == map void arg') + then do + pure (Just (C.Section name arg (noCommentsPragmas fs'))) + else do + displayWarning $ "Fragment " ++ p ++ " contains a section " ++ showSection name arg ++ ", expection section " ++ showSection name' arg' ++ "." + pure Nothing + + noCommentsPragmas :: Functor f => [f ann] -> [f CommentsPragmas] + noCommentsPragmas = map ((Comments [], []) <$) + + getPragmas :: C.Field CommentsPragmas -> [Pragma] + getPragmas = snd . C.fieldAnn + + showSection :: C.Name ann -> [C.SectionArg ann] -> String + showSection (C.Name _ n) [] = show n + showSection (C.Name _ n) args = show (fromUTF8BS n ++ " " ++ render (hsep (C.prettySectionArgs n args))) + + parse :: MonadCabalFmt r m => [Pragma] -> m (Maybe FilePath) + parse = fmap asum . traverse go where + go (PragmaFragment f) = return (Just f) + go _ = return Nothing diff --git a/src/CabalFmt/Refactoring/Type.hs b/src/CabalFmt/Refactoring/Type.hs --- a/src/CabalFmt/Refactoring/Type.hs +++ b/src/CabalFmt/Refactoring/Type.hs @@ -9,7 +9,8 @@ RefactoringOfField, RefactoringOfField', CommentsPragmas, - traverseFields + traverseFields, + rewriteFields, ) where import qualified Distribution.Fields as C @@ -45,3 +46,19 @@ go (C.Field name fls) = uncurry C.Field <$> f name fls go (C.Section name args fs) = C.Section name args <$> goMany fs + +-- | A top-to-bottom rewrite of sections and fields +rewriteFields + :: Monad m + => (C.Field CommentsPragmas -> m (Maybe (C.Field CommentsPragmas))) + -> [C.Field CommentsPragmas] -> m [C.Field CommentsPragmas] +rewriteFields f = goMany where + goMany = traverse go + + go x = do + m <- f x + case m of + Just y -> return y + Nothing -> case x of + C.Field {} -> return x + C.Section name args fs -> C.Section name args <$> goMany fs diff --git a/tests/Golden.hs b/tests/Golden.hs --- a/tests/Golden.hs +++ b/tests/Golden.hs @@ -1,14 +1,16 @@ module Main (main) where -import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) import System.FilePath ((-<.>), ()) 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 as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Map as Map import CabalFmt (cabalFmt) +import CabalFmt.Prelude import CabalFmt.Monad (runCabalFmt) import CabalFmt.Options (defaultOptions) @@ -17,6 +19,13 @@ [ goldenTest' "cabal-fmt" , goldenTest' "Cabal" , goldenTest' "simple-example" + + , goldenTest' "fragment-missing" + , goldenTest' "fragment-empty" + , goldenTest' "fragment-wrong-field" + , goldenTest' "fragment-wrong-type" + , goldenTest' "fragment-multiple" + , goldenTest' "fragment-section" ] goldenTest' :: String -> TestTree @@ -30,14 +39,38 @@ makeTest = do contents <- BS.readFile inputPath - case runCabalFmt defaultOptions $ cabalFmt inputPath contents of - Right output' -> return (toUTF8BS output') - Left err -> fail (show err) + 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'') $ fail "Output not idempotent" + return (toUTF8BS $ unlines (map ("-- " ++) ws) ++ output') cmp a b | a == b = return Nothing | otherwise = Just <$> readProcess' "diff" ["-u", goldenPath, "-"] (fromUTF8BS b) - 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" + ] + where + p x y = (x, BS8.pack y)