diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -161,9 +161,9 @@ Each pragma starts with `-- cabal-gild:`. Pragmas must be the last comment before a field. -- `-- cabal-gild: discover DIRECTORY`: This pragma will discover any Haskell - files (`*.hs` or `*.lhs`) in the given directory and use those to populate - the list of modules. For example, given this input: +- `-- cabal-gild: discover DIRECTORY [DIRECTORY ...]`: This pragma will + discover any Haskell files in any of the given directories and use those to + populate the list of modules or signatures. For example, given this input: ``` cabal library @@ -180,9 +180,13 @@ exposed-modules: M ``` - This pragma only works with the `exposed-modules` and `other-modules` fields. - It will be ignored on all other fields. + This pragma only works with the `exposed-modules`, `other-modules`, and + `signatures` fields. It will be ignored on all other fields. - Any existing modules in the list will be ignored. The entire field will be - replaced. This means adding, removing, and renaming modules should be handled - automatically. + Any existing modules or signatures in the list will be ignored. The entire + field (including comments) will be replaced. This means adding, removing, and + renaming modules or signatures should be handled automatically. + + This pragma searches for files with any of the following extensions: `*.chs`, + `*.cpphs`, `*.gc`, `*.hs`, `*.hsc`, `*.hsig`, `*.lhs`, `*.lhsig`, `*.ly`, + `*.x`, or `*.y`, diff --git a/cabal-gild.cabal b/cabal-gild.cabal --- a/cabal-gild.cabal +++ b/cabal-gild.cabal @@ -11,7 +11,7 @@ maintainer: Taylor Fausak name: cabal-gild synopsis: Formats package descriptions. -version: 1.0.1.0 +version: 1.0.2.0 source-repository head type: git diff --git a/source/library/CabalGild/Action/EvaluatePragmas.hs b/source/library/CabalGild/Action/EvaluatePragmas.hs --- a/source/library/CabalGild/Action/EvaluatePragmas.hs +++ b/source/library/CabalGild/Action/EvaluatePragmas.hs @@ -6,12 +6,14 @@ import qualified CabalGild.Extra.String as String import qualified CabalGild.Type.Comment as Comment import qualified CabalGild.Type.Pragma as Pragma +import qualified Control.Monad as Monad import qualified Control.Monad.Trans.Class as Trans import qualified Control.Monad.Trans.Maybe as MaybeT -import qualified Data.Map as Map +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Distribution.Fields as Fields +import qualified Distribution.ModuleName as ModuleName import qualified Distribution.Parsec as Parsec import qualified Distribution.Utils.Generic as Utils import qualified System.FilePath as FilePath @@ -31,7 +33,7 @@ FilePath -> [Fields.Field [Comment.Comment a]] -> m [Fields.Field [Comment.Comment a]] -fields = mapM . field +fields = traverse . field -- | Evaluates pragmas within the given field. Or, if the field is a section, -- evaluates pragmas recursively within the fields of the section. @@ -46,20 +48,37 @@ m (Fields.Field [Comment.Comment a]) field p f = case f of Fields.Field n _ -> fmap (Maybe.fromMaybe f) . MaybeT.runMaybeT $ do - es <- hoistMaybe . Map.lookup (Name.value n) $ extensions - c <- hoistMaybe . Utils.safeLast $ Name.annotation n - x <- hoistMaybe . Parsec.simpleParsecBS $ Comment.value c - y <- case x of - Pragma.Discover y -> pure y - let d = FilePath.combine (FilePath.takeDirectory p) y - fs <- Trans.lift $ MonadWalk.walk d - pure - . Fields.Field n - . fmap (ModuleName.toFieldLine []) - . Maybe.mapMaybe (ModuleName.fromFilePath . FilePath.makeRelative d) - $ Maybe.mapMaybe (stripAnyExtension es) fs + Monad.guard $ Set.member (Name.value n) relevantFieldNames + comment <- hoistMaybe . Utils.safeLast $ Name.annotation n + pragma <- hoistMaybe . Parsec.simpleParsecBS $ Comment.value comment + case pragma of + Pragma.Discover ds -> do + let root = FilePath.takeDirectory p + directories = + FilePath.dropTrailingPathSeparator + . FilePath.normalise + . FilePath.combine root + <$> NonEmpty.toList ds + files <- Trans.lift . fmap mconcat $ traverse MonadWalk.walk directories + pure + . Fields.Field n + . fmap (ModuleName.toFieldLine []) + . Maybe.mapMaybe (toModuleName directories) + $ Maybe.mapMaybe (stripAnyExtension extensions) files Fields.Section n sas fs -> Fields.Section n sas <$> fields p fs +-- | These are the names of the fields that can have this action applied to +-- them. +relevantFieldNames :: Set.Set Fields.FieldName +relevantFieldNames = + Set.fromList $ + fmap + String.toUtf8 + [ "exposed-modules", + "other-modules", + "signatures" + ] + -- | Attempts to strip any of the given extensions from the file path. If any -- of them succeed, the result is returned. Otherwise 'Nothing' is returned. stripAnyExtension :: Set.Set String -> FilePath -> Maybe String @@ -68,16 +87,32 @@ . Maybe.mapMaybe (`FilePath.stripExtension` p) $ Set.toList es --- | A map from field names to the set of extensions that should be discovered --- for that field. -extensions :: Map.Map Fields.FieldName (Set.Set String) +-- | The set of extensions that should be discovered by this pragma. Any file +-- with one of these extensions will be discovered. +-- +-- +extensions :: Set.Set String extensions = - let (=:) :: String -> [String] -> (Fields.FieldName, Set.Set String) - k =: v = (String.toUtf8 k, Set.fromList v) - in Map.fromList - [ "exposed-modules" =: ["hs", "lhs"], - "other-modules" =: ["hs", "lhs"] - ] + Set.fromList + [ "chs", + "cpphs", + "gc", + "hs", + "hsc", + "hsig", + "lhs", + "lhsig", + "ly", + "x", + "y" + ] + +-- | Attempts to convert a file path (without an extension) into a module name +-- by making it relative to one of the given directories. +toModuleName :: [FilePath] -> FilePath -> Maybe ModuleName.ModuleName +toModuleName ds f = + Maybe.listToMaybe $ + Maybe.mapMaybe (ModuleName.fromFilePath . flip FilePath.makeRelative f) ds -- | This was added in @transformers-0.6.0.0@. See -- . diff --git a/source/library/CabalGild/Class/MonadWalk.hs b/source/library/CabalGild/Class/MonadWalk.hs --- a/source/library/CabalGild/Class/MonadWalk.hs +++ b/source/library/CabalGild/Class/MonadWalk.hs @@ -25,4 +25,4 @@ if b then listDirectoryRecursively p else pure [p] - concat <$> mapM f es + mconcat <$> traverse f es diff --git a/source/library/CabalGild/Type/Flag.hs b/source/library/CabalGild/Type/Flag.hs --- a/source/library/CabalGild/Type/Flag.hs +++ b/source/library/CabalGild/Type/Flag.hs @@ -4,6 +4,7 @@ import qualified CabalGild.Exception.UnexpectedArgument as UnexpectedArgument import qualified CabalGild.Exception.UnknownOption as UnknownOption import qualified Control.Monad.Catch as Exception +import qualified Data.Foldable as Foldable import qualified System.Console.GetOpt as GetOpt -- | A flag, which represents a command line option. The values associated with @@ -69,7 +70,7 @@ fromArguments :: (Exception.MonadThrow m) => [String] -> m [Flag] fromArguments arguments = do let (flgs, args, opts, errs) = GetOpt.getOpt' GetOpt.Permute options arguments - mapM_ (Exception.throwM . UnexpectedArgument.fromString) args - mapM_ (Exception.throwM . InvalidOption.fromString) errs - mapM_ (Exception.throwM . UnknownOption.fromString) opts + Foldable.traverse_ (Exception.throwM . UnexpectedArgument.fromString) args + Foldable.traverse_ (Exception.throwM . InvalidOption.fromString) errs + Foldable.traverse_ (Exception.throwM . UnknownOption.fromString) opts pure flgs diff --git a/source/library/CabalGild/Type/Pragma.hs b/source/library/CabalGild/Type/Pragma.hs --- a/source/library/CabalGild/Type/Pragma.hs +++ b/source/library/CabalGild/Type/Pragma.hs @@ -1,6 +1,7 @@ module CabalGild.Type.Pragma where import qualified Control.Monad as Monad +import qualified Data.List.NonEmpty as NonEmpty import qualified Distribution.Compat.CharParsing as CharParsing import qualified Distribution.FieldGrammar.Newtypes as Newtypes import qualified Distribution.Parsec as Parsec @@ -8,7 +9,7 @@ -- | A pragma, which is a special comment used to customize behavior. newtype Pragma = -- | Discover modules within the given directory. - Discover FilePath + Discover (NonEmpty.NonEmpty FilePath) deriving (Eq, Show) instance Parsec.Parsec Pragma where @@ -18,4 +19,6 @@ CharParsing.spaces Monad.void $ CharParsing.string "discover" CharParsing.skipSpaces1 - Discover . Newtypes.getFilePathNT <$> Parsec.parsec + Discover + . fmap Newtypes.getFilePathNT + <$> CharParsing.sepByNonEmpty Parsec.parsec CharParsing.skipSpaces1 diff --git a/source/library/CabalGild/Type/SomeParsecParser.hs b/source/library/CabalGild/Type/SomeParsecParser.hs --- a/source/library/CabalGild/Type/SomeParsecParser.hs +++ b/source/library/CabalGild/Type/SomeParsecParser.hs @@ -17,7 +17,8 @@ -- | This type bundles up a parser and a pretty printer for some type. -- Typically they will just be monomorphic versions of 'Parsec.parsec' and -- 'Pretty.prettyVersioned'. -data SomeParsecParser = forall a. +data SomeParsecParser + = forall a. SomeParsecParser { parsec :: Parsec.ParsecParser a, pretty :: CabalSpecVersion.CabalSpecVersion -> a -> PrettyPrint.Doc diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -752,34 +752,94 @@ Hspec.it "discovers an exposed module" $ do expectDiscover - ["M.hs"] + [(".", ["M.hs"])] "library\n -- cabal-gild: discover .\n exposed-modules:" "library\n -- cabal-gild: discover .\n exposed-modules: M\n" Hspec.it "discovers an other module" $ do expectDiscover - ["M.hs"] + [(".", ["M.hs"])] "library\n -- cabal-gild: discover .\n other-modules:" "library\n -- cabal-gild: discover .\n other-modules: M\n" Hspec.it "discovers a nested module" $ do expectDiscover - [FilePath.combine "N" "O.hs"] + [(".", [FilePath.combine "N" "O.hs"])] "library\n -- cabal-gild: discover .\n exposed-modules:" "library\n -- cabal-gild: discover .\n exposed-modules: N.O\n" Hspec.it "discovers multiple modules" $ do expectDiscover - ["M.hs", "N.hs"] + [(".", ["M.hs", "N.hs"])] "library\n -- cabal-gild: discover .\n exposed-modules:" "library\n -- cabal-gild: discover .\n exposed-modules:\n M\n N\n" - Hspec.it "discovers a literate haskell module" $ do + Hspec.it "discovers a .lhs file" $ do expectDiscover - ["M.lhs"] + [(".", ["M.lhs"])] "library\n -- cabal-gild: discover .\n exposed-modules:" "library\n -- cabal-gild: discover .\n exposed-modules: M\n" + Hspec.it "discovers a .gc file" $ do + expectDiscover + [(".", ["M.gc"])] + "library\n -- cabal-gild: discover .\n exposed-modules:" + "library\n -- cabal-gild: discover .\n exposed-modules: M\n" + + Hspec.it "discovers a .chs file" $ do + expectDiscover + [(".", ["M.chs"])] + "library\n -- cabal-gild: discover .\n exposed-modules:" + "library\n -- cabal-gild: discover .\n exposed-modules: M\n" + + Hspec.it "discovers a .hsc file" $ do + expectDiscover + [(".", ["M.hsc"])] + "library\n -- cabal-gild: discover .\n exposed-modules:" + "library\n -- cabal-gild: discover .\n exposed-modules: M\n" + + Hspec.it "discovers a .y file" $ do + expectDiscover + [(".", ["M.y"])] + "library\n -- cabal-gild: discover .\n exposed-modules:" + "library\n -- cabal-gild: discover .\n exposed-modules: M\n" + + Hspec.it "discovers a .ly file" $ do + expectDiscover + [(".", ["M.ly"])] + "library\n -- cabal-gild: discover .\n exposed-modules:" + "library\n -- cabal-gild: discover .\n exposed-modules: M\n" + + Hspec.it "discovers a .x file" $ do + expectDiscover + [(".", ["M.x"])] + "library\n -- cabal-gild: discover .\n exposed-modules:" + "library\n -- cabal-gild: discover .\n exposed-modules: M\n" + + Hspec.it "discovers a .cpphs file" $ do + expectDiscover + [(".", ["M.cpphs"])] + "library\n -- cabal-gild: discover .\n exposed-modules:" + "library\n -- cabal-gild: discover .\n exposed-modules: M\n" + + Hspec.it "discovers a .hsig file" $ do + expectDiscover + [(".", ["M.hsig"])] + "library\n -- cabal-gild: discover .\n exposed-modules:" + "library\n -- cabal-gild: discover .\n exposed-modules: M\n" + + Hspec.it "discovers a .lhsig file" $ do + expectDiscover + [(".", ["M.lhsig"])] + "library\n -- cabal-gild: discover .\n exposed-modules:" + "library\n -- cabal-gild: discover .\n exposed-modules: M\n" + + Hspec.it "discovers a signature" $ do + expectDiscover + [(".", ["S.hsig"])] + "library\n -- cabal-gild: discover .\n signatures:" + "library\n -- cabal-gild: discover .\n signatures: S\n" + Hspec.it "ignores discover pragma separated by comment" $ do expectGilded "library\n -- cabal-gild: discover .\n -- foo\n exposed-modules: M" @@ -795,12 +855,18 @@ "-- cabal-gild: unknown" "-- cabal-gild: unknown\n" + Hspec.it "discovers from multiple directories" $ do + expectDiscover + [("d", ["M.hs"]), ("e", ["N.hs"])] + "library\n -- cabal-gild: discover d e\n exposed-modules:" + "library\n -- cabal-gild: discover d e\n exposed-modules:\n M\n N\n" + expectGilded :: (Stack.HasCallStack) => String -> String -> Hspec.Expectation expectGilded input expected = do let (a, s, w) = runTest (Gild.mainWith "" []) - (Map.singleton Nothing (String.toUtf8 input), Map.empty) + (Map.singleton Nothing $ String.toUtf8 input, Map.empty) Map.empty a `Hspec.shouldBe` Right () w `Hspec.shouldBe` [] @@ -825,13 +891,13 @@ _ -> fail $ "impossible: " <> show s output `Hspec.shouldBe` input -expectDiscover :: [FilePath] -> String -> String -> Hspec.Expectation +expectDiscover :: [(FilePath, [FilePath])] -> String -> String -> Hspec.Expectation expectDiscover files input expected = do let (a, s, w) = runTest (Gild.mainWith "" []) - ( Map.singleton Nothing (String.toUtf8 input), - Map.singleton (FilePath.combine "." ".") files + ( Map.singleton Nothing $ String.toUtf8 input, + Map.fromList $ fmap (\(d, fs) -> (d, FilePath.combine d <$> fs)) files ) Map.empty a `Hspec.shouldBe` Right ()