cabal-gild 0.2.1.0 → 0.2.1.1
raw patch · 20 files changed
+188/−281 lines, 20 filesdep +exceptionsdep −integer-logarithmsdep −optparse-applicative
Dependencies added: exceptions
Dependencies removed: integer-logarithms, optparse-applicative
Files
- cabal-gild.cabal +2/−4
- source/library/CabalGild.hs +19/−14
- source/library/CabalGild/Comments.hs +4/−4
- source/library/CabalGild/Fields.hs +6/−6
- source/library/CabalGild/Fields/BuildDepends.hs +8/−5
- source/library/CabalGild/Fields/Extensions.hs +4/−3
- source/library/CabalGild/Fields/Modules.hs +8/−5
- source/library/CabalGild/Fields/SourceFiles.hs +8/−5
- source/library/CabalGild/Fields/TestedWith.hs +3/−3
- source/library/CabalGild/FreeText.hs +3/−2
- source/library/CabalGild/Glob.hs +2/−2
- source/library/CabalGild/Main.hs +85/−86
- source/library/CabalGild/Parser.hs +3/−3
- source/library/CabalGild/Pragma.hs +7/−5
- source/library/CabalGild/Prelude.hs +0/−117
- source/library/CabalGild/Refactoring/ExpandExposedModules.hs +9/−5
- source/library/CabalGild/Refactoring/Fragments.hs +8/−6
- source/library/CabalGild/Refactoring/GlobFiles.hs +3/−2
- source/test-suite/CabalGild/Test/Golden.hs +2/−2
- source/test-suite/CabalGild/Test/Interval.hs +4/−2
cabal-gild.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: cabal-gild-version: 0.2.1.0+version: 0.2.1.1 synopsis: Format .cabal files category: Development description:@@ -61,9 +61,9 @@ , Cabal-syntax ^>=3.8.1.0 || ^>=3.10.1.0 , containers ^>=0.6.7 , directory ^>=1.3.7.1+ , exceptions ^>=0.10.5 , filepath ^>=1.4.2.2 , mtl ^>=2.2.2 || ^>=2.3.1- , optparse-applicative ^>=0.18.1.0 , parsec ^>=3.1.16.1 , pretty ^>=1.1.3.6 @@ -85,7 +85,6 @@ CabalGild.Options CabalGild.Parser CabalGild.Pragma- CabalGild.Prelude CabalGild.Refactoring CabalGild.Refactoring.ExpandExposedModules CabalGild.Refactoring.Fragments@@ -113,7 +112,6 @@ , Cabal-syntax , containers , filepath- , integer-logarithms ^>=1.0.3.1 , QuickCheck ^>=2.14.3 , tasty ^>=1.5 , tasty-hunit ^>=0.10.1
source/library/CabalGild.hs view
@@ -21,13 +21,18 @@ import CabalGild.Options import CabalGild.Parser import CabalGild.Pragma-import CabalGild.Prelude import CabalGild.Refactoring import Control.Monad (join)+import qualified Control.Monad.Except as Except import Control.Monad.Reader (asks, local) import qualified Data.ByteString as BS+import qualified Data.Either as Either+import qualified Data.Foldable as Foldable+import Data.Function ((&)) import Data.Functor (($>))+import qualified Data.Maybe as Maybe import qualified Distribution.CabalSpecVersion as C+import qualified Distribution.Compat.Lens as Lens import qualified Distribution.FieldGrammar.Parsec as C import qualified Distribution.Fields as C import qualified Distribution.Fields.ConfVar as C@@ -50,7 +55,7 @@ cabalGild :: (MonadCabalGild r m) => FilePath -> BS.ByteString -> m String cabalGild filepath contents = do -- determine cabal-version- cabalFile <- asks (optCabalFile . view options)+ cabalFile <- asks (optCabalFile . Lens.view options) csv <- if cabalFile then do@@ -65,10 +70,10 @@ -- parse pragmas let parse :: (MonadCabalGild r f) => (a, Comments) -> f (a, Comments, [Pragma])- parse (pos, c) = case parsePragmas c of (ws, ps) -> traverse_ displayWarning ws $> (pos, c, ps)+ parse (pos, c) = case parsePragmas c of (ws, ps) -> Foldable.traverse_ displayWarning ws $> (pos, c, ps) inputFieldsP' <- traverse (traverse parse) inputFieldsC endCommentsPragmas <- case parsePragmas endComments of- (ws, ps) -> traverse_ displayWarning ws $> ps+ (ws, ps) -> Foldable.traverse_ displayWarning ws $> ps -- apply refactorings let inputFieldsP :: [C.Field CommentsPragmas]@@ -81,23 +86,23 @@ pragmas = fst $ partitionPragmas $- foldMap (foldMap trdOf3) inputFieldsP' <> endCommentsPragmas+ foldMap (foldMap $ \(_, _, z) -> z) inputFieldsP' <> endCommentsPragmas optsEndo :: OptionsMorphism optsEndo = foldMap pragmaToOM pragmas - local (over options $ \o -> runOptionsMorphism optsEndo $ o {optSpecVersion = csv}) $ do- indentWith <- asks (optIndent . view options)+ local (Lens.over options $ \o -> runOptionsMorphism optsEndo $ o {optSpecVersion = csv}) $ do+ indentWith <- asks (optIndent . Lens.view options) let inputFields = inputFieldsR outputPrettyFields <- genericFromParsecFields- (\n ann -> prettyFieldLines n (fstOf3 ann))+ (\n (x, _, _) -> prettyFieldLines n x) prettySectionArgs inputFields return $- C.showFields' (fromComments . sndOf3) (const id) indentWith outputPrettyFields+ C.showFields' (fromComments . (\(_, y, _) -> y)) (const id) indentWith outputPrettyFields & if nullComments endComments then id else (++ unlines ("" : [C.fromUTF8BS c | c <- unComments endComments]))@@ -127,13 +132,13 @@ prettyFieldLines :: (MonadCabalGild 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+ Maybe.fromMaybe (C.prettyFieldLines fn fls) <$> knownField fn pos fls knownField :: (MonadCabalGild r m) => C.FieldName -> C.Position -> [C.FieldLine CommentsPragmas] -> m (Maybe PP.Doc) knownField fn pos fls = do- opts <- asks (view options)+ opts <- asks (Lens.view options) let v = optSpecVersion opts- let ft = fieldlinesToFreeText v pos (fmap (fmap fstOf3) fls)+ let ft = fieldlinesToFreeText v pos (fmap (fmap $ \(x, _, _) -> x) fls) let ft' = showFreeText v ft return $ join $ fieldDescrLookup (fieldDescrs opts) fn (Just ft') $ \p pp ->@@ -161,7 +166,7 @@ prettySectionArgs :: (MonadCabalGild r m) => C.FieldName -> [C.SectionArg ann] -> m [PP.Doc] prettySectionArgs x args =- prettySectionArgs' x args `catchError` \_ ->+ prettySectionArgs' x args `Except.catchError` \_ -> return (C.prettySectionArgs x args) prettySectionArgs' :: (MonadCabalGild r m) => a -> [C.SectionArg ann] -> m [PP.Doc]@@ -195,7 +200,7 @@ ------------------------------------------------------------------------------- partitionPragmas :: [Pragma] -> ([GlobalPragma], [FieldPragma])-partitionPragmas = partitionEithers . map p+partitionPragmas = Either.partitionEithers . map p where p (GlobalPragma x) = Left x p (FieldPragma x) = Right x
source/library/CabalGild/Comments.hs view
@@ -8,10 +8,10 @@ -- Copyright: Oleg Grenrus module CabalGild.Comments where -import CabalGild.Prelude import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.Map.Strict as Map+import qualified Data.Maybe as Maybe import qualified Distribution.Fields as C import qualified Distribution.Fields.Field as C import qualified Distribution.Parsec as C@@ -60,7 +60,7 @@ (flip (<>)) [ (path, cs) | (l, cs) <- comments,- path <- toList (findPath C.fieldAnn l inputFieldsU)+ path <- Maybe.maybeToList (findPath C.fieldAnn l inputFieldsU) ] endComments :: Comments@@ -68,11 +68,11 @@ mconcat [ cs | (l, cs) <- comments,- isNothing (findPath C.fieldAnn l inputFieldsU)+ Maybe.isNothing (findPath C.fieldAnn l inputFieldsU) ] attach :: FieldPath -> C.Position -> (C.Position, Comments)- attach fp pos = (pos, fromMaybe mempty (Map.lookup fp comments'))+ attach fp pos = (pos, Maybe.fromMaybe mempty (Map.lookup fp comments')) attach' :: C.Position -> (C.Position, Comments) attach' pos = (pos, mempty)
source/library/CabalGild/Fields.hs view
@@ -17,8 +17,8 @@ ) where -import CabalGild.Prelude import qualified Data.Map.Strict as Map+import qualified Distribution.Compat.Newtype as Newtype import qualified Distribution.FieldGrammar as C import qualified Distribution.Fields.Field as C import qualified Distribution.Parsec as C@@ -86,20 +86,20 @@ f s = PP.text (show s) uniqueFieldAla fn _pack _ =- singletonF fn (C.pretty . pack' _pack) (unpack' _pack <$> C.parsec)+ singletonF fn (C.pretty . Newtype.pack' _pack) (Newtype.unpack' _pack <$> C.parsec) optionalFieldAla fn _pack _ =- singletonF fn (C.pretty . pack' _pack) (unpack' _pack <$> C.parsec)+ singletonF fn (C.pretty . Newtype.pack' _pack) (Newtype.unpack' _pack <$> C.parsec) optionalFieldDefAla fn _pack _ def =- singletonF fn f (unpack' _pack <$> C.parsec)+ singletonF fn f (Newtype.unpack' _pack <$> C.parsec) where f s | s == def = PP.empty- | otherwise = C.pretty (pack' _pack s)+ | otherwise = C.pretty (Newtype.pack' _pack s) monoidalFieldAla fn _pack _ =- singletonF fn (C.pretty . pack' _pack) (unpack' _pack <$> C.parsec)+ singletonF fn (C.pretty . Newtype.pack' _pack) (Newtype.unpack' _pack <$> C.parsec) freeTextField fn _ = F $ Map.singleton fn FreeText freeTextFieldDef fn _ = F $ Map.singleton fn FreeText
source/library/CabalGild/Fields/BuildDepends.hs view
@@ -13,9 +13,12 @@ import CabalGild.Fields import CabalGild.Options-import CabalGild.Prelude+import Control.Arrow ((&&&))+import qualified Data.Char as Char import Data.List (dropWhileEnd)+import qualified Data.List as List import qualified Distribution.CabalSpecVersion as C+import qualified Distribution.Compat.Newtype as Newtype import qualified Distribution.FieldGrammar as C import qualified Distribution.Parsec as C import qualified Distribution.Pretty as C@@ -36,10 +39,10 @@ buildToolDependsF opts = singletonF "build-tool-depends" (prettyExe opts) parseExe parse :: (C.CabalParsing m) => m [C.Dependency]-parse = unpack' (C.alaList C.CommaVCat) <$> C.parsec+parse = Newtype.unpack' (C.alaList C.CommaVCat) <$> C.parsec parseExe :: (C.CabalParsing m) => m [C.ExeDependency]-parseExe = unpack' (C.alaList C.CommaVCat) <$> C.parsec+parseExe = Newtype.unpack' (C.alaList C.CommaVCat) <$> C.parsec normaliseVersionRange' :: C.VersionRange -> C.VersionRange normaliseVersionRange' vr = either fromConversionProblem id (normaliseVersionRange vr)@@ -63,7 +66,7 @@ where deps' :: [(String, C.VersionRange)] deps' =- sortOn (map toLower . fst) $+ List.sortOn (map Char.toLower . fst) $ map (prettyDepNoVersion &&& C.depVerRange) $ C.fromDepMap . C.toDepMap $ -- this combines duplicate packages deps@@ -87,7 +90,7 @@ where deps' :: [(String, C.VersionRange)] deps' =- sortOn (map toLower . fst) $+ List.sortOn (map Char.toLower . fst) $ map (exeDepExeName &&& exeDepVerRange) -- C.fromDepMap . C.toDepMap -- this combines duplicate packages
source/library/CabalGild/Fields/Extensions.hs view
@@ -10,7 +10,8 @@ where import CabalGild.Fields-import CabalGild.Prelude+import qualified Data.List as List+import qualified Distribution.Compat.Newtype as Newtype import qualified Distribution.FieldGrammar as C import qualified Distribution.Parsec as C import qualified Distribution.Pretty as C@@ -24,7 +25,7 @@ defaultExtensionsF = singletonF "default-extensions" pretty parse parse :: (C.CabalParsing m) => m [C.Extension]-parse = unpack' (C.alaList' C.FSep C.MQuoted) <$> C.parsec+parse = Newtype.unpack' (C.alaList' C.FSep C.MQuoted) <$> C.parsec pretty :: [C.Extension] -> PP.Doc-pretty = PP.vcat . map C.pretty . sortOn C.prettyShow+pretty = PP.vcat . map C.pretty . List.sortOn C.prettyShow
source/library/CabalGild/Fields/Modules.hs view
@@ -10,7 +10,10 @@ where import CabalGild.Fields-import CabalGild.Prelude+import qualified Data.Char as Char+import qualified Data.Function as Function+import qualified Data.List as List+import qualified Distribution.Compat.Newtype as Newtype import qualified Distribution.FieldGrammar as C import qualified Distribution.ModuleName as C import qualified Distribution.Parsec as C@@ -24,14 +27,14 @@ otherModulesF = singletonF "other-modules" pretty parse parse :: (C.CabalParsing m) => m [C.ModuleName]-parse = unpack' (C.alaList' C.VCat C.MQuoted) <$> C.parsec+parse = Newtype.unpack' (C.alaList' C.VCat C.MQuoted) <$> C.parsec pretty :: [C.ModuleName] -> PP.Doc pretty = PP.vcat . map C.pretty- . nub- . sortBy (cmp `on` map strToLower . C.components)+ . List.nub+ . List.sortBy (cmp `Function.on` map strToLower . C.components) where cmp :: (Ord a) => [a] -> [a] -> Ordering cmp a b = case dropCommonPrefix a b of@@ -41,7 +44,7 @@ (a', b') -> compare a' b' strToLower :: String -> String-strToLower = map toLower+strToLower = map Char.toLower dropCommonPrefix :: (Eq a) => [a] -> [a] -> ([a], [a]) dropCommonPrefix [] [] = ([], [])
source/library/CabalGild/Fields/SourceFiles.hs view
@@ -13,7 +13,10 @@ -- when parsing glob syntax since only `/` is valid, and not '\\' import CabalGild.Fields-import CabalGild.Prelude+import qualified Data.Char as Char+import qualified Data.Function as Function+import qualified Data.List as List+import qualified Distribution.Compat.Newtype as Newtype import qualified Distribution.FieldGrammar as C import qualified Distribution.Fields as C import qualified Distribution.Parsec as C@@ -43,14 +46,14 @@ ] parse :: (C.CabalParsing m) => m [FilePath]-parse = unpack' (C.alaList' C.VCat C.FilePathNT) <$> C.parsec+parse = Newtype.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 . Posix.splitDirectories)+ . List.nub+ . List.sortBy (cmp `Function.on` map strToLower . Posix.splitDirectories) where cmp :: (Ord a) => [a] -> [a] -> Ordering cmp a b = case dropCommonPrefix a b of@@ -60,7 +63,7 @@ (a', b') -> compare a' b' strToLower :: String -> String-strToLower = map toLower+strToLower = map Char.toLower dropCommonPrefix :: (Eq a) => [a] -> [a] -> ([a], [a]) dropCommonPrefix [] [] = ([], [])
source/library/CabalGild/Fields/TestedWith.hs view
@@ -11,10 +11,10 @@ import CabalGild.Fields import CabalGild.Options-import CabalGild.Prelude import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Distribution.CabalSpecVersion as C+import qualified Distribution.Compat.Newtype as Newtype import qualified Distribution.Compiler as C import qualified Distribution.FieldGrammar as C import qualified Distribution.Parsec as C@@ -26,7 +26,7 @@ testedWithF Options {optSpecVersion = ver} = singletonF "tested-with" pretty parse where parse :: (C.CabalParsing m) => m [(C.CompilerFlavor, C.VersionRange)]- parse = unpack' (C.alaList' C.FSep C.TestedWith) <$> C.parsec+ parse = Newtype.unpack' (C.alaList' C.FSep C.TestedWith) <$> C.parsec pretty :: [(C.CompilerFlavor, C.VersionRange)] -> PP.Doc pretty tw0 =@@ -58,7 +58,7 @@ | isFirst, v < C.CabalSpecV3_0 = PP.char ' ' PP.<+> doc | otherwise = PP.char ',' PP.<+> doc -isVersionSet :: C.VersionRange -> Maybe (Set C.Version)+isVersionSet :: C.VersionRange -> Maybe (Set.Set C.Version) isVersionSet vr = go Set.empty (C.asVersionIntervals vr) where go !acc [] = Just acc
source/library/CabalGild/FreeText.hs view
@@ -6,13 +6,14 @@ ) where -import CabalGild.Prelude import Data.List (foldl')+import qualified Data.List as List 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 Distribution.Utils.Generic (fromUTF8BS) import qualified Distribution.Utils.String as C (trim) import qualified Text.PrettyPrint as PP @@ -33,7 +34,7 @@ fieldlinesToFreeText2 :: [C.FieldLine C.Position] -> String fieldlinesToFreeText2 [C.FieldLine _ "."] = "."-fieldlinesToFreeText2 fls = intercalate "\n" (map go fls)+fieldlinesToFreeText2 fls = List.intercalate "\n" (map go fls) where go :: C.FieldLine ann -> String go (C.FieldLine _ bs)
source/library/CabalGild/Glob.hs view
@@ -1,8 +1,8 @@ module CabalGild.Glob where -import CabalGild.Prelude import Data.List (isInfixOf) import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty import qualified System.FilePath as Native (splitDirectories) import qualified System.FilePath.Posix as Posix (splitDirectories) @@ -36,7 +36,7 @@ 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+ go (s : ss) (GlobPiece cs : gs) = matches s (NonEmpty.toList cs) && go ss gs matches :: FilePath -> [GlobChar] -> Bool matches [] [] = True
source/library/CabalGild/Main.hs view
@@ -7,51 +7,56 @@ import CabalGild.Error (Error (SomeError), renderError) import CabalGild.Monad (runCabalGildIO) import CabalGild.Options-import CabalGild.Prelude-import Control.Applicative (many, (<**>))+import qualified Control.Monad as Monad+import qualified Control.Monad.Catch as Exception import qualified Data.ByteString as BS+import qualified Data.Maybe as Maybe import Data.Traversable (for)-import Data.Version (showVersion)-import qualified Options.Applicative as O-import Paths_cabal_gild (version)+import qualified Data.Version as Version+import Distribution.Utils.Generic (toUTF8BS)+import qualified Paths_cabal_gild as This+import qualified System.Console.GetOpt as GetOpt+import qualified System.Environment as Environment import System.Exit (exitFailure)+import qualified System.Exit as Exit import System.FilePath (takeDirectory) import System.IO (hPutStrLn, stderr)+import qualified Text.Read as Read main :: IO () main = do- (opts', filepaths) <- O.execParser optsP'- let opts = runOptionsMorphism opts' defaultOptions+ arguments <- Environment.getArgs+ let (flags, filepaths, unknowns, invalids) = GetOpt.getOpt' GetOpt.Permute flagOptions arguments+ mapM_ (Exception.throwM . userError . mappend "unknown option: ") unknowns+ mapM_ (Exception.throwM . userError . mappend "invalid option: ") invalids+ config <- flagsToConfig flags+ let opts = configOptions config + Monad.when (configHelp config) $ do+ name <- Environment.getProgName+ putStr $ GetOpt.usageInfo name flagOptions+ Exit.exitSuccess++ Monad.when (configVersion config) $ do+ putStrLn $ Version.showVersion This.version+ Exit.exitSuccess+ notFormatted <-- catMaybes <$> case filepaths of+ Maybe.catMaybes <$> case filepaths of [] -> fmap pure $ BS.getContents >>= main' opts Nothing (_ : _) -> for filepaths $ \filepath -> do contents <- BS.readFile filepath main' opts (Just filepath) contents - when ((optMode opts == ModeCheck) && not (null notFormatted)) $ do- for_ notFormatted $ \filepath ->+ Monad.when ((optMode opts == ModeCheck) && not (null notFormatted)) $ do+ Monad.forM_ notFormatted $ \filepath -> hPutStrLn stderr $ "error: Input " <> filepath <> " is not formatted." exitFailure- where- optsP' =- O.info (optsP <**> O.helper <**> versionP) $- mconcat- [ O.fullDesc,- O.progDesc "Reformat .cabal files",- O.header "cabal-gild - .cabal file reformatter"- ] - versionP :: O.Parser (a -> a)- versionP =- O.infoOption (showVersion version) $- O.long "version" <> O.help "Show version"- main' :: Options -> Maybe FilePath -> BS.ByteString -> IO (Maybe FilePath) main' opts mfilepath input = do -- name of the input- let filepath = fromMaybe "<stdin>" mfilepath+ let filepath = Maybe.fromMaybe "<stdin>" mfilepath mroot <- fmap takeDirectory <$> case (mfilepath, optStdinInputFile opts) of@@ -74,7 +79,7 @@ ModeStdout -> BS.putStr outputBS ModeInplace -> case mfilepath of Nothing -> BS.putStr outputBS- Just _ -> unless formatted $ BS.writeFile filepath outputBS+ Just _ -> Monad.unless formatted $ BS.writeFile filepath outputBS _ -> return () return $ if formatted then Nothing else Just filepath@@ -86,69 +91,63 @@ -- Options parser ------------------------------------------------------------------------------- -optsP :: O.Parser (OptionsMorphism, [FilePath])-optsP =- (,)- <$> optsP'- <*> many (O.strArgument (O.metavar "FILE..." <> O.help "input files"))- where- optsP' =- fmap mconcat $- many $- asum- [ werrorP,- noWerrorP,- indentP,- tabularP,- noTabularP,- cabalFileP,- noCabalFileP,- stdoutP,- inplaceP,- checkP,- rootP- ]-- werrorP =- O.flag' (mkOptionsMorphism $ \opts -> opts {optError = True}) $- O.long "Werror" <> O.help "Treat warnings as errors"-- noWerrorP =- O.flag' (mkOptionsMorphism $ \opts -> opts {optError = False}) $- O.long "Wno-error"-- indentP =- O.option (fmap (\n -> mkOptionsMorphism $ \opts -> opts {optIndent = n}) O.auto) $- O.long "indent" <> O.help "Indentation" <> O.metavar "N"-- tabularP =- O.flag' (mkOptionsMorphism $ \opts -> opts {optTabular = True}) $- O.long "tabular" <> O.help "Tabular formatting"-- noTabularP =- O.flag' (mkOptionsMorphism $ \opts -> opts {optTabular = False}) $- O.long "no-tabular"-- cabalFileP =- O.flag' (mkOptionsMorphism $ \opts -> opts {optCabalFile = True}) $- O.long "cabal-file"+data Flag+ = FlagCabalFile Bool+ | FlagError Bool+ | FlagHelp+ | FlagIndent String+ | FlagMode Mode+ | FlagStdinInputFile String+ | FlagTabular Bool+ | FlagVersion+ deriving (Eq, Show) - noCabalFileP =- O.flag' (mkOptionsMorphism $ \opts -> opts {optCabalFile = False}) $- O.short 'n' <> O.long "no-cabal-file" <> O.help "Don't parse as .cabal file"+flagOptions :: [GetOpt.OptDescr Flag]+flagOptions =+ [ GetOpt.Option [] ["Werror"] (GetOpt.NoArg $ FlagError True) "Treat warnings as errors",+ GetOpt.Option [] ["Wno-error"] (GetOpt.NoArg $ FlagError False) "",+ GetOpt.Option [] ["indent"] (GetOpt.ReqArg FlagIndent "N") "Indentation",+ GetOpt.Option [] ["tabular"] (GetOpt.NoArg $ FlagTabular True) "Tabular formatting",+ GetOpt.Option [] ["no-tabular"] (GetOpt.NoArg $ FlagTabular False) "",+ GetOpt.Option [] ["cabal-file"] (GetOpt.NoArg $ FlagCabalFile True) "",+ GetOpt.Option ['n'] ["no-cabal-file"] (GetOpt.NoArg $ FlagCabalFile False) "Don't parse as .cabal file",+ GetOpt.Option [] ["stdout"] (GetOpt.NoArg $ FlagMode ModeStdout) "Write output to stdout (default)",+ GetOpt.Option ['i'] ["inplace"] (GetOpt.NoArg $ FlagMode ModeInplace) "Process files in-place",+ GetOpt.Option ['c'] ["check"] (GetOpt.NoArg $ FlagMode ModeCheck) "Fail with non-zero exit code if input is not formatted",+ GetOpt.Option [] ["stdin-input-file"] (GetOpt.ReqArg FlagStdinInputFile "FILE") "When reading from STDIN, use this file path to resolve relative references",+ GetOpt.Option ['h'] ["help"] (GetOpt.NoArg FlagHelp) "Show this help text",+ GetOpt.Option [] ["version"] (GetOpt.NoArg FlagVersion) "Show version"+ ] - stdoutP =- O.flag' (mkOptionsMorphism $ \opts -> opts {optMode = ModeStdout}) $- O.long "stdout" <> O.help "Write output to stdout (default)"+data Config = Config+ { configHelp :: Bool,+ configOptions :: Options,+ configVersion :: Bool+ }+ deriving (Show) - inplaceP =- O.flag' (mkOptionsMorphism $ \opts -> opts {optMode = ModeInplace}) $- O.short 'i' <> O.long "inplace" <> O.help "Process files in-place"+initialConfig :: Config+initialConfig =+ Config+ { configHelp = False,+ configOptions = defaultOptions,+ configVersion = False+ } - checkP =- O.flag' (mkOptionsMorphism $ \opts -> opts {optMode = ModeCheck}) $- O.short 'c' <> O.long "check" <> O.help "Fail with non-zero exit code if input is not formatted"+applyFlag :: (Exception.MonadThrow m) => Config -> Flag -> m Config+applyFlag c f = case f of+ FlagCabalFile b -> pure c {configOptions = (configOptions c) {optCabalFile = b}}+ FlagError b -> pure c {configOptions = (configOptions c) {optError = b}}+ FlagHelp -> pure c {configHelp = True}+ FlagIndent s -> do+ i <- case Read.readMaybe s of+ Nothing -> Exception.throwM . userError $ "invalid indent: " <> show s+ Just i -> pure i+ pure c {configOptions = (configOptions c) {optIndent = i}}+ FlagMode m -> pure c {configOptions = (configOptions c) {optMode = m}}+ FlagStdinInputFile s -> pure c {configOptions = (configOptions c) {optStdinInputFile = Just s}}+ FlagTabular b -> pure c {configOptions = (configOptions c) {optTabular = b}}+ FlagVersion -> pure c {configVersion = True} - rootP =- O.option (fmap (\f -> mkOptionsMorphism $ \opts -> opts {optStdinInputFile = Just f}) O.str) $- O.long "stdin-input-file" <> O.help "When reading from STDIN, use this file path to resolve relative references" <> O.metavar "FILE"+flagsToConfig :: (Exception.MonadThrow m) => [Flag] -> m Config+flagsToConfig = Monad.foldM applyFlag initialConfig
source/library/CabalGild/Parser.hs view
@@ -5,7 +5,7 @@ import CabalGild.Error import CabalGild.Monad-import CabalGild.Prelude+import qualified Control.Monad.Except as Except import qualified Data.ByteString as BS import qualified Distribution.Fields as C import qualified Distribution.PackageDescription.Parsec as C@@ -15,7 +15,7 @@ runParseResult :: (MonadCabalGild r m) => FilePath -> BS.ByteString -> C.ParseResult a -> m a runParseResult filepath contents pr = case result of Right gpd -> return gpd- Left (mspecVersion, errors) -> throwError $ CabalParseError filepath contents errors mspecVersion warnings+ Left (mspecVersion, errors) -> Except.throwError $ CabalParseError filepath contents errors mspecVersion warnings where (warnings, result) = C.runParseResult pr @@ -24,5 +24,5 @@ parseFields :: (MonadCabalGild r m) => BS.ByteString -> m [C.Field C.Position] parseFields contents = case C.readFields contents of- Left err -> throwError $ PanicCannotParseInput err+ Left err -> Except.throwError $ PanicCannotParseInput err Right x -> return x
source/library/CabalGild/Pragma.hs view
@@ -4,8 +4,10 @@ import CabalGild.Comments import CabalGild.Glob-import CabalGild.Prelude+import qualified Data.Bifunctor as Bifunctor import qualified Data.ByteString as BS+import qualified Data.Either as Either+import qualified Data.Maybe as Maybe import qualified Distribution.Compat.CharParsing as C import qualified Distribution.ModuleName as C import qualified Distribution.Parsec as C@@ -40,10 +42,10 @@ -- | Parse pragma from 'ByteString'. -- -- An error ('Left') is reported only if input 'ByteString' starts with @-- cabal-gild:@.-parsePragma :: ByteString -> Either String (Maybe Pragma)+parsePragma :: BS.ByteString -> Either String (Maybe Pragma) parsePragma bs = case dropPrefix bs of Nothing -> Right Nothing- Just bs' -> bimap show Just $ C.runParsecParser parser "<input>" $ C.fieldLineStreamFromBS bs'+ Just bs' -> Bifunctor.bimap show Just $ C.runParsecParser parser "<input>" $ C.fieldLineStreamFromBS bs' where dropPrefix bs0 = do bs1 <- BS.stripPrefix "--" bs0@@ -87,7 +89,7 @@ Right g -> return $ FieldPragma $ PragmaGlobFiles g Left e -> C.unexpected e -stripWhitespace :: ByteString -> ByteString+stripWhitespace :: BS.ByteString -> BS.ByteString stripWhitespace bs = case BS.uncons bs of Nothing -> bs Just (w, bs')@@ -95,4 +97,4 @@ | otherwise -> bs parsePragmas :: Comments -> ([String], [Pragma])-parsePragmas = fmap catMaybes . partitionEithers . map parsePragma . unComments+parsePragmas = fmap Maybe.catMaybes . Either.partitionEithers . map parsePragma . unComments
− source/library/CabalGild/Prelude.hs
@@ -1,117 +0,0 @@--- |--- License: GPL-3.0-or-later--- Copyright: Oleg Grenrus------ Fat-prelude.-module CabalGild.Prelude- ( -- * Control.Arrow- (&&&),-- -- * Control.Monad- when,- unless,- void,-- -- * Data.Bifunctor- bimap,-- -- * Data.Char- toLower,-- -- * Data.Either- partitionEithers,-- -- * Data.Foldable- toList,- traverse_,- asum,- for_,-- -- * Data.Function- on,- (&),-- -- * Data.List- intercalate,- sortOn,- sortBy,- nub,-- -- * Data.Maybe- catMaybes,- fromMaybe,- isJust,- isNothing,-- -- * Packages-- -- ** bytestring- ByteString,-- -- ** Cabal- C.fromUTF8BS,- C.toUTF8BS,- pack',- unpack',-- -- ** containers- Set,-- -- ** directory- dropExtension,- splitDirectories,-- -- ** exceptions- catchError,- throwError,-- -- * Extras-- -- ** Lens- traverseOf,- over,- view,- _1,-- -- ** Tuples- fstOf3,- sndOf3,- trdOf3,- )-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 (asum, for_, toList, traverse_)-import Data.Function (on, (&))-import Data.List (intercalate, nub, sortBy, sortOn)-import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)-import Data.Set (Set)-import Distribution.Compat.Lens (over, view)-import Distribution.Compat.Newtype (pack', unpack')-import qualified Distribution.Utils.Generic as C-import System.FilePath (dropExtension, splitDirectories)--traverseOf ::- ((a -> f b) -> s -> f t) ->- (a -> f b) ->- s ->- f t-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
source/library/CabalGild/Refactoring/ExpandExposedModules.hs view
@@ -12,24 +12,28 @@ import CabalGild.Monad import CabalGild.Pragma-import CabalGild.Prelude import CabalGild.Refactoring.Type+import qualified Data.List as List+import qualified Data.Maybe as Maybe+import qualified Distribution.Compat.Lens as Lens import qualified Distribution.Fields as C import qualified Distribution.ModuleName as C+import Distribution.Utils.Generic (toUTF8BS)+import qualified System.FilePath as FilePath 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+ files <- (traverse . Lens._1) getFiles dirs let newModules :: [C.FieldLine CommentsPragmas] newModules =- catMaybes- [ return $ C.FieldLine emptyCommentsPragmas $ toUTF8BS $ intercalate "." parts+ Maybe.catMaybes+ [ return $ C.FieldLine emptyCommentsPragmas $ toUTF8BS $ List.intercalate "." parts | (files', mns) <- files, file <- files',- let parts = splitDirectories $ dropExtension file,+ let parts = FilePath.splitDirectories $ FilePath.dropExtension file, all C.validModuleComponent parts, let mn = C.fromComponents parts, -- TODO: don't use fromComponents mn `notElem` mns
source/library/CabalGild/Refactoring/Fragments.hs view
@@ -13,12 +13,14 @@ import CabalGild.Monad import CabalGild.Parser import CabalGild.Pragma-import CabalGild.Prelude import CabalGild.Refactoring.Type+import qualified Control.Monad as Monad+import qualified Data.Foldable as Foldable 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 Distribution.Utils.Generic (fromUTF8BS) import Text.PrettyPrint (hsep, render) -- | Expand fragments.@@ -48,7 +50,7 @@ displayWarning $ "Fragment " ++ p ++ " contains a field " ++ show n' ++ ", expecting section " ++ showSection name arg ++ "." pure Nothing (C.Field name@(C.Name _ n) _, C.Field (C.Name _ n') fls' : rest) -> do- unless (null rest) $+ Monad.unless (null rest) $ displayWarning $ "Fragment " ++ p ++ " contains multiple fields or sections, using only the first." if n == n'@@ -59,11 +61,11 @@ 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) $+ Monad.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'+ if Monad.void name == Monad.void name' && map Monad.void arg == map Monad.void arg' then do pure (Just (C.Section name arg (noCommentsPragmas fs'))) else do@@ -74,14 +76,14 @@ noCommentsPragmas = map ((C.zeroPos, Comments [], []) <$) getPragmas :: C.Field CommentsPragmas -> [FieldPragma]- getPragmas = trdOf3 . C.fieldAnn+ getPragmas = (\(_, _, z) -> z) . 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 :: (MonadCabalGild r m) => [FieldPragma] -> m (Maybe FilePath)- parse = fmap asum . traverse go+ parse = fmap Foldable.asum . traverse go where go :: (Monad m) => FieldPragma -> m (Maybe FilePath) go (PragmaFragment f) = return (Just f)
source/library/CabalGild/Refactoring/GlobFiles.hs view
@@ -12,9 +12,10 @@ import CabalGild.Glob import CabalGild.Monad import CabalGild.Pragma-import CabalGild.Prelude import CabalGild.Refactoring.Type+import qualified Data.Maybe as Maybe import qualified Distribution.Fields as C+import Distribution.Utils.Generic (toUTF8BS) import qualified System.FilePath as Native import qualified System.FilePath.Posix as Posix @@ -26,7 +27,7 @@ let newFiles :: [C.FieldLine CommentsPragmas] newFiles =- catMaybes+ Maybe.catMaybes [ return $ C.FieldLine emptyCommentsPragmas $ toUTF8BS file | file <- files ]
source/test-suite/CabalGild/Test/Golden.hs view
@@ -3,11 +3,11 @@ import CabalGild (cabalGild) import CabalGild.Monad (runCabalGild) import CabalGild.Options (defaultOptions)-import CabalGild.Prelude import qualified Control.Exception as Exception import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.Map as Map+import Distribution.Utils.Generic (toUTF8BS) import System.FilePath ((-<.>), (</>)) import Test.Tasty (TestTree, testGroup) import qualified Test.Tasty.HUnit as HUnit@@ -83,5 +83,5 @@ p ("cbits" </> "sub" </> "source3.c") "..." ] where- p :: a -> String -> (a, ByteString)+ p :: a -> String -> (a, BS.ByteString) p x y = (x, BS8.pack y)
source/test-suite/CabalGild/Test/Interval.hs view
@@ -28,7 +28,6 @@ withinVersion, ) import Distribution.Version (transformCaretUpper)-import Math.NumberTheory.Logarithms (intLog2) import Test.QuickCheck (Arbitrary (..), (===)) import qualified Test.QuickCheck as QC import Test.Tasty (TestTree, testGroup)@@ -316,7 +315,10 @@ ] instance Arbitrary VersionRange where- arbitrary = QC.sized $ \n -> genVersionRange (intLog2 (max 1 n))+ arbitrary =+ let intToDouble :: Int -> Double+ intToDouble = fromIntegral+ in QC.sized $ genVersionRange . round . logBase 2 . intToDouble . max 1 shrink vr = case projectVersionRange vr of LaterVersionF v -> laterVersion <$> shrink v