cabal-fmt 0.1.4 → 0.1.5

raw patch · 17 files changed

+431/−141 lines, 17 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Changelog.md +7/−0
• cabal-fmt.cabal +4/−1
• fixtures/Cabal.format +15/−15
• fixtures/simple-example.cabal +7/−0
• fixtures/simple-example.format +10/−0
• src/CabalFmt.hs +22/−19
• src/CabalFmt/Fields.hs +4/−0
• src/CabalFmt/Fields/SourceFiles.hs +66/−0
• src/CabalFmt/Glob.hs +70/−0
• src/CabalFmt/Monad.hs +15/−3
• src/CabalFmt/Pragma.hs +36/−7
• src/CabalFmt/Refactoring.hs +51/−4
• src/CabalFmt/Refactoring/ExpandExposedModules.hs +20/−22
• src/CabalFmt/Refactoring/Fragments.hs +47/−45
• src/CabalFmt/Refactoring/GlobFiles.hs +45/−0
• src/CabalFmt/Refactoring/Type.hs +7/−25
• tests/Golden.hs +5/−0

@@ -1,3 +1,10 @@+# 0.1.5++- Don't print redundant `-any` in `impl`+- Add `glob-files` pragma for source file fields (`c-sources`, ...)+  Glob syntax supports only stars (i.e. no `{}` etc. extras).+- Source file fields are now sorted+ # 0.1.4  - Add `-n` / `--no-cabal-file` to format cabal like, but not package files.

@@ -1,6 +1,6 @@ cabal-version:      2.2 name:               cabal-fmt-version:            0.1.4+version:            0.1.5 synopsis:           Format .cabal files category:           Development description:@@ -47,7 +47,9 @@     CabalFmt.Fields.BuildDepends     CabalFmt.Fields.Extensions     CabalFmt.Fields.Modules+    CabalFmt.Fields.SourceFiles     CabalFmt.Fields.TestedWith+    CabalFmt.Glob     CabalFmt.Monad     CabalFmt.Options     CabalFmt.Parser@@ -56,6 +58,7 @@     CabalFmt.Refactoring     CabalFmt.Refactoring.ExpandExposedModules     CabalFmt.Refactoring.Fragments+    CabalFmt.Refactoring.GlobFiles     CabalFmt.Refactoring.Type    other-extensions:

@@ -24,14 +24,13 @@ -- we can bootstrap.  extra-source-files:-  README.md-  tests/README.md   ChangeLog.md   doc/bugs-and-stability.rst   doc/concepts-and-development.rst   doc/conf.py   doc/config-and-install.rst   doc/developing-packages.rst+  doc/file-format-changelog.rst   doc/images/Cabal-dark.png   doc/index.rst   doc/installing-packages.rst@@ -39,9 +38,13 @@   doc/misc.rst   doc/nix-local-build-overview.rst   doc/nix-local-build.rst-  doc/file-format-changelog.rst   doc/README.md   doc/references.inc+  README.md+  tests/hackage/check.sh+  tests/hackage/download.sh+  tests/hackage/unpack.sh+  tests/misc/ghc-supported-languages.hs   tests/ParserTests/errors/common1.cabal   tests/ParserTests/errors/common1.errors   tests/ParserTests/errors/common2.cabal@@ -94,11 +97,6 @@   tests/ParserTests/ipi/transformers.cabal   tests/ParserTests/ipi/transformers.expr   tests/ParserTests/ipi/transformers.format-  tests/ParserTests/regressions/MiniAgda.cabal-  tests/ParserTests/regressions/MiniAgda.check-  tests/ParserTests/regressions/Octree-0.5.cabal-  tests/ParserTests/regressions/Octree-0.5.expr-  tests/ParserTests/regressions/Octree-0.5.format   tests/ParserTests/regressions/bad-glob-syntax.cabal   tests/ParserTests/regressions/bad-glob-syntax.check   tests/ParserTests/regressions/cc-options-with-optimization.cabal@@ -151,17 +149,22 @@   tests/ParserTests/regressions/leading-comma.cabal   tests/ParserTests/regressions/leading-comma.expr   tests/ParserTests/regressions/leading-comma.format+  tests/ParserTests/regressions/MiniAgda.cabal+  tests/ParserTests/regressions/MiniAgda.check   tests/ParserTests/regressions/multiple-libs-2.cabal   tests/ParserTests/regressions/multiple-libs-2.check   tests/ParserTests/regressions/multiple-libs-2.expr   tests/ParserTests/regressions/multiple-libs-2.format-  tests/ParserTests/regressions/noVersion.cabal-  tests/ParserTests/regressions/noVersion.expr-  tests/ParserTests/regressions/noVersion.format   tests/ParserTests/regressions/nothing-unicode.cabal   tests/ParserTests/regressions/nothing-unicode.check   tests/ParserTests/regressions/nothing-unicode.expr   tests/ParserTests/regressions/nothing-unicode.format+  tests/ParserTests/regressions/noVersion.cabal+  tests/ParserTests/regressions/noVersion.expr+  tests/ParserTests/regressions/noVersion.format+  tests/ParserTests/regressions/Octree-0.5.cabal+  tests/ParserTests/regressions/Octree-0.5.expr+  tests/ParserTests/regressions/Octree-0.5.format   tests/ParserTests/regressions/pre-1.6-glob.cabal   tests/ParserTests/regressions/pre-1.6-glob.check   tests/ParserTests/regressions/pre-2.4-globstar.cabal@@ -201,10 +204,7 @@   tests/ParserTests/warnings/unknownsection.cabal   tests/ParserTests/warnings/utf8.cabal   tests/ParserTests/warnings/versiontag.cabal-  tests/hackage/check.sh-  tests/hackage/download.sh-  tests/hackage/unpack.sh-  tests/misc/ghc-supported-languages.hs+  tests/README.md  -- Generated with 'make gen-extra-source-files' -- Do NOT edit this section manually; instead, run the script.

@@ -36,6 +36,13 @@   hs-source-dirs:      src   default-language:    Haskell2010 +  if impl(ghcjs)+    cpp-options: -DFOOBAR++  if impl(ghc)+    -- cabal-fmt: glob-files cbits/**/*.c+    c-sources:+ test-suite doctests   type:                exitcode-stdio-1.0   main-is:             doctests.hs

@@ -42,6 +42,16 @@   hs-source-dirs:     src   default-language:   Haskell2010 +  if impl(ghcjs)+    cpp-options: -DFOOBAR++  if impl(ghc)+    -- cabal-fmt: glob-files cbits/**/*.c+    c-sources:+      cbits/source1.c+      cbits/source2.c+      cbits/sub/source3.c+ test-suite doctests   type:             exitcode-stdio-1.0   main-is:          doctests.hs

@@ -9,8 +9,9 @@ -- module CabalFmt (cabalFmt) where -import Control.Monad        (foldM, join)+import Control.Monad        (join) import Control.Monad.Reader (asks, local)+import Data.Either          (partitionEithers)  import qualified Data.ByteString                              as BS import qualified Distribution.CabalSpecVersion                as C@@ -27,6 +28,7 @@ import qualified Distribution.Types.GenericPackageDescription as C import qualified Distribution.Types.PackageDescription        as C import qualified Distribution.Types.Version                   as C+import qualified Distribution.Types.VersionRange              as C import qualified Text.PrettyPrint                             as PP  import CabalFmt.Comments@@ -34,6 +36,7 @@ import CabalFmt.Fields.BuildDepends import CabalFmt.Fields.Extensions import CabalFmt.Fields.Modules+import CabalFmt.Fields.SourceFiles import CabalFmt.Fields.TestedWith import CabalFmt.Monad import CabalFmt.Options@@ -53,16 +56,20 @@      -- parse pragmas     let parse c = case parsePragmas c of (ws, ps) -> traverse_ displayWarning ws *> return (c, ps)-    inputFieldsP <- traverse (traverse parse) inputFieldsC+    inputFieldsP' <- traverse (traverse parse) inputFieldsC     endCommentsPragmas <- case parsePragmas endComments of         (ws, ps) -> traverse_ displayWarning ws *> return ps      -- apply refactorings-    inputFieldsR  <- foldM (&) inputFieldsP refactorings+    let inputFieldsP :: [C.Field CommentsPragmas]+        inputFieldsP = map (fmap (fmap (snd . partitionPragmas))) inputFieldsP' +    inputFieldsR  <- refactor inputFieldsP+     -- options morphisms-    let pragmas :: [Pragma]-        pragmas = foldMap (foldMap snd) inputFieldsR <> endCommentsPragmas+    let pragmas :: [GlobalPragma]+        pragmas = fst $ partitionPragmas $+            foldMap (foldMap snd) inputFieldsP' <> endCommentsPragmas          optsEndo :: OptionsMorphism         optsEndo = foldMap pragmaToOM pragmas@@ -94,16 +101,6 @@ fromComments (Comments bss) = map C.fromUTF8BS bss  ---------------------------------------------------------------------------------- Refactorings----------------------------------------------------------------------------------refactorings :: MonadCabalFmt r m => [Refactoring' r m]-refactorings =-    [ refactoringFragments-    , refactoringExpandExposedModules-    ]--------------------------------------------------------------------------------- -- Field prettyfying ------------------------------------------------------------------------------- @@ -129,6 +126,7 @@     <> exposedModulesF     <> otherModulesF     <> testedWithF opts+    <> mconcat sourceFilesF     <> coerceFieldDescrs C.packageDescriptionFieldGrammar     <> coerceFieldDescrs C.buildInfoFieldGrammar @@ -163,14 +161,19 @@ ppConfVar (C.OS os)     = PP.text "os"   PP.<> PP.parens (C.pretty os) ppConfVar (C.Arch arch) = PP.text "arch" PP.<> PP.parens (C.pretty arch) ppConfVar (C.Flag name) = PP.text "flag" PP.<> PP.parens (C.pretty name)-ppConfVar (C.Impl c v)  = PP.text "impl" PP.<> PP.parens (C.pretty c PP.<+> C.pretty v)+ppConfVar (C.Impl c v)+    | v == C.anyVersion = PP.text "impl" PP.<> PP.parens (C.pretty c)+    | otherwise         = PP.text "impl" PP.<> PP.parens (C.pretty c PP.<+> C.pretty v)  ------------------------------------------------------------------------------- -- Pragma to OM ------------------------------------------------------------------------------- -pragmaToOM :: Pragma -> OptionsMorphism+partitionPragmas :: [Pragma] -> ([GlobalPragma], [FieldPragma])+partitionPragmas = partitionEithers . map p where+    p (GlobalPragma x) = Left x+    p (FieldPragma x)  = Right x++pragmaToOM :: GlobalPragma -> OptionsMorphism pragmaToOM (PragmaOptIndent n)    = mkOptionsMorphism $ \opts -> opts { optIndent = n } pragmaToOM (PragmaOptTabular b)   = mkOptionsMorphism $ \opts -> opts { optTabular = b }-pragmaToOM PragmaExpandModules {} = mempty-pragmaToOM PragmaFragment {}      = mempty

@@ -54,6 +54,10 @@ instance Semigroup (FieldDescrs s a) where     F a <> F b = F (a <> b) +instance Monoid (FieldDescrs s a) where+    mempty  = F Map.empty+    mappend = (<>)+ instance Applicative (FieldDescrs s) where     pure _  = F mempty     f <*> x = F (mappend (runF f) (runF x))

@@ -0,0 +1,66 @@+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus+{-# LANGUAGE OverloadedStrings #-}+module CabalFmt.Fields.SourceFiles (+    sourceFilesF,+    fileFields,+    ) where++import System.FilePath.Posix (splitDirectories)++import qualified Distribution.Fields          as C+import qualified Distribution.Parsec          as C+import qualified Distribution.Parsec.Newtypes as C+import qualified Distribution.Pretty          as C+import qualified Text.PrettyPrint             as PP++import CabalFmt.Fields+import CabalFmt.Prelude++sourceFilesF :: [FieldDescrs () ()]+sourceFilesF =+    [ singletonF f pretty parse+    | f <- fileFields+    ]++fileFields :: [C.FieldName]+fileFields =+    [ "extra-source-files"+    , "extra-doc-files"+    , "data-files"+    , "license-files"+    , "asm-sources"+    , "cmm-sources"+    , "c-sources"+    , "cxx-sources"+    , "js-sources"+    , "includes"+    , "install-includes"+    ]++parse :: C.CabalParsing m => m [FilePath]+parse = unpack' (C.alaList' C.VCat C.FilePathNT) <$> C.parsec++pretty :: [FilePath] -> PP.Doc+pretty+    = PP.vcat . map C.showFilePath+    . nub+    . sortBy (cmp `on` map strToLower . splitDirectories)+  where+    cmp a b = case dropCommonPrefix a b of+        ([], [])  -> EQ+        ([], _:_) -> LT+        (_:_, []) -> GT+        (a', b')  -> compare a' b'++strToLower :: String -> String+strToLower = map toLower++dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a])+dropCommonPrefix [] [] = ([], [])+dropCommonPrefix [] ys = ([], ys)+dropCommonPrefix xs [] = (xs, [])+dropCommonPrefix xs@(x:xs') ys@(y:ys')+    | x == y    = dropCommonPrefix xs' ys'+    | otherwise = (xs, ys)

@@ -0,0 +1,70 @@+module CabalFmt.Glob where++import Data.List             (isInfixOf)+import Data.List.NonEmpty    (NonEmpty (..))+import System.FilePath.Posix (splitDirectories)++import CabalFmt.Prelude++data Glob = Glob FilePath [GlobPiece]+  deriving Show++data GlobPiece+    = GlobStarStar+    | GlobPiece (NonEmpty GlobChar)+  deriving Show++data GlobChar+    = GlobStar+    | GlobChar Char+  deriving Show++-- | Match glob+--+-- >>> let Right g = parseGlob "cbits/**/*.c"+--+-- >>> map (match g) ["foo", "cbits/header.h", "cbits/source.c", "cbits/dir/source.c"]+-- [False,False,True,True]+--+match :: Glob -> FilePath -> Bool+match (Glob g1 gs0) fp = go0 (splitDirectories fp) where+    go0 []     = False+    go0 (p:ps) = if p == g1 then go ps gs0 else False++    go :: [FilePath] -> [GlobPiece] -> Bool+    go []     []                  = True+    go []     (_:_)               = False+    go (_:_)  []                  = False+    go (s:ss) (GlobStarStar : gs) = go (s:ss) gs || go ss (GlobStarStar : gs)+    go (s:ss) (GlobPiece cs : gs) = matches s (toList cs) && go ss gs+++    matches :: FilePath -> [GlobChar] -> Bool+    matches []     []                = True+    matches (_:_)  []                = False+    matches []     (_:_)             = False+    matches (x:xs) (GlobStar : cs)   = matches (x:xs) cs || matches xs (GlobStar : cs)+    matches (x:xs) (GlobChar c : cs) = if x == c then matches xs cs else False++parseGlob :: String -> Either String Glob+parseGlob input = case splitDirectories input of+    []     -> Left "empty path"+    (x:xs) -> do+        p <- parseFirstPiece x+        ps <- traverse parsePiece xs+        return (Glob p ps)+  where+    parseFirstPiece :: String -> Either String FilePath+    parseFirstPiece ""                    = Left "empty path segment"+    parseFirstPiece s | "*" `isInfixOf` s = Left "wild card in first path segment"+    parseFirstPiece s                     = Right s++    parsePiece :: String -> Either String GlobPiece+    parsePiece ""                     = Left "empty path segment"+    parsePiece "**"                   = Right GlobStarStar+    parsePiece s | "**" `isInfixOf` s = Left $ "** inside path segment: " ++ s+    parsePiece (c:cs)                 = Right (GlobPiece (parseChar c :| map parseChar cs))++    parseChar :: Char -> GlobChar+    parseChar '*' = GlobStar+    parseChar c   = GlobChar c

@@ -19,13 +19,16 @@     runCabalFmtIO,     ) where -import Control.Exception      (IOException, catch, throwIO, try, displayException)+import Control.Exception+       (IOException, catch, displayException, throwIO, try) import Control.Monad          (when) import Control.Monad.Except   (MonadError (..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Reader   (MonadReader (..), ReaderT (..), asks, runReaderT) import Control.Monad.Writer   (WriterT, runWriterT, tell) import Data.Bifunctor         (first)+import Data.List              (isPrefixOf, stripPrefix)+import Data.Maybe             (mapMaybe) import System.Exit            (exitFailure) import System.FilePath        ((</>)) import System.IO              (hPutStrLn, stderr)@@ -77,8 +80,17 @@     local f (CabalFmt m) = CabalFmt $ local (first f) m  instance MonadCabalFmt Options CabalFmt where-    listDirectory _      = return []-    doesDirectoryExist _ = return False+    listDirectory dir = CabalFmt $ do+        files <- asks snd+        return $ mapMaybe f (Map.keys files)+      where+        f :: FilePath -> Maybe FilePath+        f fp = do+            rest <- stripPrefix (dir ++ "/") fp+            return $ takeWhile (/= '/') rest+    doesDirectoryExist dir = CabalFmt $ do+        files <- asks snd+        return (any (isPrefixOf (dir ++ "/")) (Map.keys files))     readFileBS p         = CabalFmt $ do         files <- asks snd         return (maybe (IOError "doesn't exist") Contents $ Map.lookup p files)

@@ -9,14 +9,34 @@  import CabalFmt.Prelude import CabalFmt.Comments+import CabalFmt.Glob +-------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------+ data Pragma+    = FieldPragma FieldPragma+    | GlobalPragma GlobalPragma+  deriving (Show)++-- | Pragmas applied per field+data FieldPragma+    = PragmaExpandModules FilePath [C.ModuleName]+    | PragmaGlobFiles Glob+    | PragmaFragment FilePath+  deriving (Show)++-- | Pragmas affecting global output+data GlobalPragma     = PragmaOptIndent Int     | PragmaOptTabular Bool-    | PragmaExpandModules FilePath [C.ModuleName]-    | PragmaFragment FilePath   deriving (Show) +-------------------------------------------------------------------------------+-- Parser+-------------------------------------------------------------------------------+ -- | Parse pragma from 'ByteString'. -- -- An error ('Left') is reported only if input 'ByteString' starts with @-- cabal-fmt:@.@@ -37,8 +57,9 @@         case t of             "expand"     -> expandModules             "indent"     -> indent-            "tabular"    -> return $ PragmaOptTabular True-            "no-tabular" -> return $ PragmaOptTabular False+            "glob-files" -> globFiles+            "tabular"    -> return $ GlobalPragma $ PragmaOptTabular True+            "no-tabular" -> return $ GlobalPragma $ PragmaOptTabular False             "fragment"   -> fragment             _            -> fail $ "Unknown pragma " ++ t @@ -47,19 +68,27 @@         C.spaces         dir <- C.parsecToken         mns <- C.many (C.space *> C.spaces *> C.char '-' *> C.parsec)-        return (PragmaExpandModules dir mns)+        return $ FieldPragma $ PragmaExpandModules dir mns      indent :: C.ParsecParser Pragma     indent = do         C.spaces         n <- C.integral-        return $ PragmaOptIndent n+        return $ GlobalPragma $ PragmaOptIndent n      fragment :: C.ParsecParser Pragma     fragment = do         C.spaces         fn <- C.parsecToken-        return (PragmaFragment fn)+        return $ FieldPragma $ PragmaFragment fn++    globFiles :: C.ParsecParser Pragma+    globFiles = do+        C.spaces+        t <- C.parsecToken+        case parseGlob t of+            Right g -> return $ FieldPragma $ PragmaGlobFiles g+            Left e  -> C.unexpected e  stripWhitespace :: ByteString -> ByteString stripWhitespace bs = case BS.uncons bs of

@@ -1,10 +1,57 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | -- License: GPL-3.0-or-later -- Copyright: Oleg Grenrus module CabalFmt.Refactoring (-    module X,+    CommentsPragmas,+    refactor,     ) where -import CabalFmt.Refactoring.ExpandExposedModules as X-import CabalFmt.Refactoring.Fragments            as X-import CabalFmt.Refactoring.Type                 as X+import qualified Distribution.Fields as C++import CabalFmt.Monad+import CabalFmt.Refactoring.ExpandExposedModules+import CabalFmt.Refactoring.Fragments+import CabalFmt.Refactoring.GlobFiles+import CabalFmt.Refactoring.Type+import CabalFmt.Fields.SourceFiles ++-------------------------------------------------------------------------------+-- Refactorings+-------------------------------------------------------------------------------++refactor :: forall m r. MonadCabalFmt r m => [C.Field CommentsPragmas] -> m [C.Field CommentsPragmas]+refactor = rewriteFields rewrite+  where+    rewrite :: C.Field CommentsPragmas -> m (Maybe (C.Field CommentsPragmas))+    rewrite f@(C.Field (C.Name _ n) _)+        | n == "exposed-modules" || n == "other-modules" = combine+            [ refactoringFragments+            , refactoringExpandExposedModules+            ] f+        | n `elem` fileFields = combine+            [ refactoringFragments+            , refactoringGlobFiles+            ] f+        | otherwise = combine+            [ refactoringFragments+            ] f++    rewrite f@(C.Section _ _ _)+        | otherwise = combine+            [ refactoringFragments+            ] f++-- | Try refactorings in turn,+-- considering it done if one applies.+combine+    :: Monad m+    => [C.Field CommentsPragmas -> m (Maybe (C.Field CommentsPragmas))]+    -> C.Field CommentsPragmas -> m (Maybe (C.Field CommentsPragmas))+combine []     _ = return Nothing+combine (r:rs) f = do+    m <- r f+    case m of+        Nothing -> combine rs f+        Just f' -> return (Just f')

@@ -15,33 +15,31 @@ import CabalFmt.Pragma import CabalFmt.Refactoring.Type -refactoringExpandExposedModules :: Refactoring-refactoringExpandExposedModules = traverseFields refact where-    refact :: RefactoringOfField-    refact name@(C.Name (_, pragmas) n) fls-        | n == "exposed-modules" || n == "other-modules" = do-            dirs <- parse pragmas-            files <- traverseOf (traverse . _1) getFiles dirs+refactoringExpandExposedModules :: FieldRefactoring+refactoringExpandExposedModules C.Section {} = pure Nothing+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-                    | (files', mns) <- files-                    , file <- files'-                    , let parts = splitDirectories $ dropExtension file-                    , all C.validModuleComponent parts-                    , let mn = C.fromComponents parts-                    , mn `notElem` mns-                    ]+    let newModules :: [C.FieldLine CommentsPragmas]+        newModules = catMaybes+            [ return $ C.FieldLine mempty $ toUTF8BS $ intercalate "." parts+            | (files', mns) <- files+            , file <- files'+            , let parts = splitDirectories $ dropExtension file+            , all C.validModuleComponent parts+            , let mn = C.fromComponents parts+            , mn `notElem` mns+            ] -            pure (name, newModules ++ fls)-        | otherwise = pure (name, fls)+    pure $ case newModules of+        [] -> Nothing+        _  -> Just (C.Field name (newModules ++ fls)) -    parse :: MonadCabalFmt r m => [Pragma] -> m [(FilePath, [C.ModuleName])]+  where+    parse :: MonadCabalFmt r m => [FieldPragma] -> m [(FilePath, [C.ModuleName])]     parse = fmap mconcat . traverse go where         go (PragmaExpandModules fp mns) = return [ (fp, mns) ]         go p = do             displayWarning $ "Skipped pragma " ++ show p             return []--

@@ -20,64 +20,66 @@ 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+-- | Expand fragments.+--+-- Applies to all fields and sections+refactoringFragments :: FieldRefactoring+refactoringFragments field = do+    mp <- parse (getPragmas field)+    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 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.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.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."+                    (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 -                            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+                    (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+  where     noCommentsPragmas :: Functor f => [f ann] -> [f CommentsPragmas]     noCommentsPragmas = map ((Comments [], []) <$) -    getPragmas :: C.Field CommentsPragmas -> [Pragma]+    getPragmas :: C.Field CommentsPragmas -> [FieldPragma]     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 :: MonadCabalFmt r m => [FieldPragma] -> m (Maybe FilePath)     parse = fmap asum . traverse go where         go (PragmaFragment f) = return (Just f)         go _                  = return Nothing

@@ -0,0 +1,45 @@+-- |+-- License: GPL-3.0-or-later+-- Copyright: Oleg Grenrus+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+module CabalFmt.Refactoring.GlobFiles (+    refactoringGlobFiles,+) where++import qualified Distribution.Fields     as C++import CabalFmt.Prelude+import CabalFmt.Monad+import CabalFmt.Glob+import CabalFmt.Pragma+import CabalFmt.Refactoring.Type++refactoringGlobFiles :: FieldRefactoring+refactoringGlobFiles C.Section {} = pure Nothing+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+            | file <- files+            ]++    pure $ case files of+        [] -> Nothing+        _  -> Just (C.Field name (newFiles ++ fls))++  where+    parse :: MonadCabalFmt r m => [FieldPragma] -> m [Glob]+    parse = fmap mconcat . traverse go where+        go (PragmaGlobFiles g) = return [ g ]+        go p = do+            displayWarning $ "Skipped pragma " ++ show p+            return []++    match' :: MonadCabalFmt r m => Glob -> m [FilePath]+    match' g@(Glob dir _) = do+        files <- map (\fp -> dir ++ "/" ++ fp) <$> getFiles dir +        return $ filter (match g) files

@@ -4,12 +4,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes        #-} module CabalFmt.Refactoring.Type (-    Refactoring,-    Refactoring',-    RefactoringOfField,-    RefactoringOfField',+    FieldRefactoring,     CommentsPragmas,-    traverseFields,     rewriteFields,     ) where @@ -23,33 +19,19 @@ -- Refactoring type ------------------------------------------------------------------------------- -type CommentsPragmas = (Comments, [Pragma])-type Refactoring             = forall r m. MonadCabalFmt r m => Refactoring' r m-type Refactoring' r m        = [C.Field CommentsPragmas] -> m [C.Field CommentsPragmas]-type RefactoringOfField      = forall r m. MonadCabalFmt r m => RefactoringOfField' r m-type RefactoringOfField' r m = C.Name CommentsPragmas -> [C.FieldLine CommentsPragmas] -> m (C.Name CommentsPragmas, [C.FieldLine CommentsPragmas])+type CommentsPragmas = (Comments, [FieldPragma]) +type FieldRefactoring+    = forall r m. MonadCabalFmt r m+    => (C.Field CommentsPragmas -> m (Maybe (C.Field CommentsPragmas)))+ ------------------------------------------------------------------------------- -- Traversing refactoring ------------------------------------------------------------------------------- --- | Allows modification of single field ------ E.g. sorting extensions *could* be done as refactoring,--- though it's currently implemented in special pretty-printer.-traverseFields-    :: Applicative f-    => RefactoringOfField' r f-    -> [C.Field CommentsPragmas] -> f [C.Field CommentsPragmas]-traverseFields f = goMany where-    goMany = traverse go--    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+    :: MonadCabalFmt r m     => (C.Field CommentsPragmas -> m (Maybe (C.Field CommentsPragmas)))     -> [C.Field CommentsPragmas] -> m [C.Field CommentsPragmas] rewriteFields f = goMany where

@@ -71,6 +71,11 @@      , 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)