cabal-gild 1.8.0.0 → 1.8.1.0
raw patch · 7 files changed
+364/−175 lines, 7 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- CabalGild.Unstable.Action.EvaluatePragmas: clean :: FilePath -> FilePath
- CabalGild.Unstable.Action.EvaluatePragmas: discover :: forall (m :: Type -> Type) p q. (MonadThrow m, MonadWalk m) => FilePath -> Name (p, Comments q) -> [FieldLine (p, Comments q)] -> DiscoverTarget -> [String] -> MaybeT m (Field (p, Comments q))
- CabalGild.Unstable.Action.EvaluatePragmas: extensions :: Set String
- CabalGild.Unstable.Action.EvaluatePragmas: field :: (MonadThrow m, MonadWalk m) => FilePath -> Field (p, Comments q) -> m (Field (p, Comments q))
- CabalGild.Unstable.Action.EvaluatePragmas: hoistMaybe :: forall (f :: Type -> Type) a. Applicative f => Maybe a -> MaybeT f a
- CabalGild.Unstable.Action.EvaluatePragmas: relevantFieldNames :: Map FieldName DiscoverTarget
- CabalGild.Unstable.Action.EvaluatePragmas: stripAnyExtension :: Set String -> FilePath -> Maybe String
- CabalGild.Unstable.Action.EvaluatePragmas: toModuleName :: [FilePath] -> FilePath -> Maybe ModuleName
- CabalGild.Unstable.Type.Pragma: Discover :: [String] -> Pragma
- CabalGild.Unstable.Type.Pragma: instance Distribution.Parsec.Parsec CabalGild.Unstable.Type.Pragma.Pragma
- CabalGild.Unstable.Type.Pragma: instance GHC.Classes.Eq CabalGild.Unstable.Type.Pragma.Pragma
- CabalGild.Unstable.Type.Pragma: instance GHC.Internal.Show.Show CabalGild.Unstable.Type.Pragma.Pragma
+ CabalGild.Unstable.Action.EvaluatePragmas.Discover: Discover :: [String] -> Discover
+ CabalGild.Unstable.Action.EvaluatePragmas.Discover: clean :: FilePath -> FilePath
+ CabalGild.Unstable.Action.EvaluatePragmas.Discover: discover :: forall (m :: Type -> Type) p q. (MonadThrow m, MonadWalk m) => FilePath -> Name (p, Comments q) -> [FieldLine (p, Comments q)] -> DiscoverTarget -> [String] -> MaybeT m (Field (p, Comments q))
+ CabalGild.Unstable.Action.EvaluatePragmas.Discover: extensions :: Set String
+ CabalGild.Unstable.Action.EvaluatePragmas.Discover: field :: (MonadThrow m, MonadWalk m) => FilePath -> Field (p, Comments q) -> m (Field (p, Comments q))
+ CabalGild.Unstable.Action.EvaluatePragmas.Discover: hoistMaybe :: forall (f :: Type -> Type) a. Applicative f => Maybe a -> MaybeT f a
+ CabalGild.Unstable.Action.EvaluatePragmas.Discover: instance Distribution.Parsec.Parsec CabalGild.Unstable.Action.EvaluatePragmas.Discover.Discover
+ CabalGild.Unstable.Action.EvaluatePragmas.Discover: newtype Discover
+ CabalGild.Unstable.Action.EvaluatePragmas.Discover: relevantFieldNames :: Map FieldName DiscoverTarget
+ CabalGild.Unstable.Action.EvaluatePragmas.Discover: stripAnyExtension :: Set String -> FilePath -> Maybe String
+ CabalGild.Unstable.Action.EvaluatePragmas.Discover: toModuleName :: [FilePath] -> FilePath -> Maybe ModuleName
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: Version :: Version
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: data Version
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: dropGenerated :: [Comment q] -> [Comment q]
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: expandVersion :: [Comment q] -> [Comment q]
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: field :: Field (p, Comments q) -> Field (p, Comments q)
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: generatedComment :: Comment q -> Comment q
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: generatedPrefix :: String
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: generatedText :: String
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: instance Distribution.Parsec.Parsec CabalGild.Unstable.Action.EvaluatePragmas.Version.Version
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: instance GHC.Classes.Eq CabalGild.Unstable.Action.EvaluatePragmas.Version.Version
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: instance GHC.Internal.Show.Show CabalGild.Unstable.Action.EvaluatePragmas.Version.Version
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: isGenerated :: Comment q -> Bool
+ CabalGild.Unstable.Action.EvaluatePragmas.Version: versionComments :: Comments q -> Comments q
+ CabalGild.Unstable.Type.Pragma: Pragma :: a -> Pragma a
+ CabalGild.Unstable.Type.Pragma: cabalGildPragmaPrefix :: String
+ CabalGild.Unstable.Type.Pragma: instance Distribution.Parsec.Parsec a => Distribution.Parsec.Parsec (CabalGild.Unstable.Type.Pragma.Pragma a)
+ CabalGild.Unstable.Type.Pragma: instance GHC.Classes.Eq a => GHC.Classes.Eq (CabalGild.Unstable.Type.Pragma.Pragma a)
+ CabalGild.Unstable.Type.Pragma: instance GHC.Internal.Show.Show a => GHC.Internal.Show.Show (CabalGild.Unstable.Type.Pragma.Pragma a)
- CabalGild.Unstable.Action.EvaluatePragmas: run :: (MonadThrow m, MonadWalk m) => FilePath -> ([Field (p, Comments q)], cs) -> m ([Field (p, Comments q)], cs)
+ CabalGild.Unstable.Action.EvaluatePragmas: run :: (MonadThrow m, MonadWalk m) => FilePath -> ([Field (p, Comments q)], [Comment q]) -> m ([Field (p, Comments q)], [Comment q])
- CabalGild.Unstable.Type.Pragma: newtype Pragma
+ CabalGild.Unstable.Type.Pragma: newtype Pragma a
Files
- README.md +26/−0
- cabal-gild.cabal +3/−1
- source/library/CabalGild/Unstable/Action/EvaluatePragmas.hs +5/−161
- source/library/CabalGild/Unstable/Action/EvaluatePragmas/Discover.hs +179/−0
- source/library/CabalGild/Unstable/Action/EvaluatePragmas/Version.hs +68/−0
- source/library/CabalGild/Unstable/Type/Pragma.hs +7/−13
- source/test-suite/Main.hs +76/−0
README.md view
@@ -269,3 +269,29 @@ If a file would match both the `--include` pattern and the `--exclude` pattern, it will be excluded.++#### `version`++```+-- cabal-gild: version+```++This pragma will insert a comment below it indicating which version of Gild+produced the output. For example, given this input:++``` cabal+-- cabal-gild: version+name: my-package+```++Gild will produce this output:++``` cabal+-- cabal-gild: version+-- Generated with cabal-gild version 1.8.0.0+name: my-package+```++On subsequent runs, the generated comment will be updated to reflect the+current version of Gild. The pragma itself is left unchanged. This pragma can+be used on any field or section.
cabal-gild.cabal view
@@ -11,7 +11,7 @@ maintainer: Taylor Fausak name: cabal-gild synopsis: Formats package descriptions.-version: 1.8.0.0+version: 1.8.1.0 source-repository head type: git@@ -69,6 +69,8 @@ CabalGild CabalGild.Unstable.Action.AttachComments CabalGild.Unstable.Action.EvaluatePragmas+ CabalGild.Unstable.Action.EvaluatePragmas.Discover+ CabalGild.Unstable.Action.EvaluatePragmas.Version CabalGild.Unstable.Action.ExtractComments CabalGild.Unstable.Action.FormatFields CabalGild.Unstable.Action.GetCabalVersion
source/library/CabalGild/Unstable/Action/EvaluatePragmas.hs view
@@ -1,174 +1,18 @@ module CabalGild.Unstable.Action.EvaluatePragmas where +import qualified CabalGild.Unstable.Action.EvaluatePragmas.Discover as EvaluateDiscover+import qualified CabalGild.Unstable.Action.EvaluatePragmas.Version as EvaluateVersion import qualified CabalGild.Unstable.Class.MonadWalk as MonadWalk-import qualified CabalGild.Unstable.Exception.InvalidOption as InvalidOption-import qualified CabalGild.Unstable.Exception.UnknownOption as UnknownOption-import qualified CabalGild.Unstable.Extra.FieldLine as FieldLine-import qualified CabalGild.Unstable.Extra.FilePath as FilePath-import qualified CabalGild.Unstable.Extra.ModuleName as ModuleName-import qualified CabalGild.Unstable.Extra.Name as Name-import qualified CabalGild.Unstable.Extra.String as String import qualified CabalGild.Unstable.Type.Comment as Comment import qualified CabalGild.Unstable.Type.Comments as Comments-import qualified CabalGild.Unstable.Type.DiscoverTarget as DiscoverTarget-import qualified CabalGild.Unstable.Type.Pragma as Pragma-import qualified Control.Applicative as Applicative import qualified Control.Monad.Catch as Exception-import qualified Control.Monad.Trans.Class as Trans-import qualified Control.Monad.Trans.Maybe as MaybeT-import qualified Data.Containers.ListUtils as List-import qualified Data.Either as Either-import qualified Data.Map as Map-import qualified Data.Maybe as Maybe-import qualified Data.Set as Set-import qualified Distribution.Compat.Lens as Lens 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.Console.GetOpt as GetOpt-import qualified System.FilePath as FilePath -- | High level wrapper around 'field' that makes this action easier to compose -- with other actions. run :: (Exception.MonadThrow m, MonadWalk.MonadWalk m) => FilePath ->- ([Fields.Field (p, Comments.Comments q)], cs) ->- m ([Fields.Field (p, Comments.Comments q)], cs)-run p (fs, cs) = (,) <$> traverse (field p) fs <*> pure cs---- | Evaluates pragmas within the given field. Or, if the field is a section,--- evaluates pragmas recursively within the fields of the section.-field ::- (Exception.MonadThrow m, MonadWalk.MonadWalk m) =>- FilePath ->- Fields.Field (p, Comments.Comments q) ->- m (Fields.Field (p, Comments.Comments q))-field p f = case f of- Fields.Field n fls -> fmap (Maybe.fromMaybe f) . MaybeT.runMaybeT $ do- dt <-- maybe Applicative.empty pure $- Map.lookup (Name.value n) relevantFieldNames- comment <- hoistMaybe . Utils.safeLast . Comments.toList . snd $ Name.annotation n- pragma <- hoistMaybe . Parsec.simpleParsecBS $ Comment.value comment- case pragma of- Pragma.Discover ds -> discover p n fls dt ds- Fields.Section n sas fs -> Fields.Section n sas <$> traverse (field p) fs---- | If modules are discovered for a field, that fields lines are completely--- replaced.-discover ::- (Exception.MonadThrow m, MonadWalk.MonadWalk m) =>- FilePath ->- Fields.Name (p, Comments.Comments q) ->- [Fields.FieldLine (p, Comments.Comments q)] ->- DiscoverTarget.DiscoverTarget ->- [String] ->- MaybeT.MaybeT m (Fields.Field (p, Comments.Comments q))-discover p n fls dt ds = do- let (flgs, args, opts, errs) =- GetOpt.getOpt'- GetOpt.Permute- [ GetOpt.Option [] ["include"] (GetOpt.ReqArg Right "PATTERN") "",- GetOpt.Option [] ["exclude"] (GetOpt.ReqArg Left "PATTERN") ""- ]- ds- let (excs, incs) = Either.partitionEithers flgs- mapM_ (Exception.throwM . UnknownOption.fromString) opts- mapM_ (Exception.throwM . InvalidOption.fromString) errs- let root = FilePath.dropTrailingPathSeparator . clean $ FilePath.takeDirectory p- directories =- List.nubOrd- . fmap clean- $ if null args then ["."] else args- exclusions = List.nubOrd $ fmap clean excs- inclusions =- List.nubOrd- . fmap clean- $ if null incs then fmap (`FilePath.combine` "**") directories else incs- files <- Trans.lift $ MonadWalk.walk root inclusions exclusions- let comments = foldMap (snd . FieldLine.annotation) fls- position =- maybe (fst $ Name.annotation n) (fst . FieldLine.annotation) $- Maybe.listToMaybe fls- fieldLines = case dt of- DiscoverTarget.Modules ->- zipWith ModuleName.toFieldLine ((,) position <$> comments : repeat Comments.empty)- . Maybe.mapMaybe (toModuleName directories)- $ Maybe.mapMaybe (stripAnyExtension extensions . clean) files- DiscoverTarget.Files ->- zipWith- (\a -> Fields.FieldLine a . String.toUtf8)- ((,) position <$> comments : repeat Comments.empty)- files- -- This isn't great, but the comments have to go /somewhere/.- name =- if null fieldLines- then Lens.over (Name.annotationLens . Lens._2) (comments <>) n- else n- pure $ Fields.Field name fieldLines---- | Converts separators into POSIX format and then normalizes the result.-clean :: FilePath -> FilePath-clean = FilePath.normalise . FilePath.toPosixSeparators---- | These are the names of the fields that can have this action applied to--- them.-relevantFieldNames :: Map.Map Fields.FieldName DiscoverTarget.DiscoverTarget-relevantFieldNames =- Map.mapKeys String.toUtf8 . Map.fromList $- [ ("asm-sources", DiscoverTarget.Files),- ("c-sources", DiscoverTarget.Files),- ("cxx-sources", DiscoverTarget.Files),- ("data-files", DiscoverTarget.Files),- ("exposed-modules", DiscoverTarget.Modules),- ("extra-doc-files", DiscoverTarget.Files),- ("extra-source-files", DiscoverTarget.Files),- ("includes", DiscoverTarget.Files),- ("install-includes", DiscoverTarget.Files),- ("js-sources", DiscoverTarget.Files),- ("license-files", DiscoverTarget.Files),- ("other-modules", DiscoverTarget.Modules),- ("signatures", DiscoverTarget.Modules)- ]---- | 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-stripAnyExtension es p =- Maybe.listToMaybe- . Maybe.mapMaybe (`FilePath.stripExtension` p)- $ Set.toList es---- | The set of extensions that should be discovered by this pragma. Any file--- with one of these extensions will be discovered.------ <https://cabal.readthedocs.io/en/3.10/cabal-package.html#modules-and-preprocessors>-extensions :: Set.Set String-extensions =- 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--- <https://hub.darcs.net/ross/transformers/issue/49>.-hoistMaybe :: (Applicative f) => Maybe a -> MaybeT.MaybeT f a-hoistMaybe = MaybeT.MaybeT . pure+ ([Fields.Field (p, Comments.Comments q)], [Comment.Comment q]) ->+ m ([Fields.Field (p, Comments.Comments q)], [Comment.Comment q])+run p (fs, cs) = (,) <$> traverse (EvaluateDiscover.field p . EvaluateVersion.field) fs <*> pure (EvaluateVersion.expandVersion cs)
+ source/library/CabalGild/Unstable/Action/EvaluatePragmas/Discover.hs view
@@ -0,0 +1,179 @@+module CabalGild.Unstable.Action.EvaluatePragmas.Discover where++import qualified CabalGild.Unstable.Class.MonadWalk as MonadWalk+import qualified CabalGild.Unstable.Exception.InvalidOption as InvalidOption+import qualified CabalGild.Unstable.Exception.UnknownOption as UnknownOption+import qualified CabalGild.Unstable.Extra.FieldLine as FieldLine+import qualified CabalGild.Unstable.Extra.FilePath as FilePath+import qualified CabalGild.Unstable.Extra.ModuleName as ModuleName+import qualified CabalGild.Unstable.Extra.Name as Name+import qualified CabalGild.Unstable.Extra.String as String+import qualified CabalGild.Unstable.Type.Comment as Comment+import qualified CabalGild.Unstable.Type.Comments as Comments+import qualified CabalGild.Unstable.Type.DiscoverTarget as DiscoverTarget+import qualified CabalGild.Unstable.Type.Pragma as Pragma+import qualified Control.Applicative as Applicative+import qualified Control.Monad as Monad+import qualified Control.Monad.Catch as Exception+import qualified Control.Monad.Trans.Class as Trans+import qualified Control.Monad.Trans.Maybe as MaybeT+import qualified Data.Containers.ListUtils as List+import qualified Data.Either as Either+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import qualified Data.Set as Set+import qualified Distribution.Compat.CharParsing as CharParsing+import qualified Distribution.Compat.Lens as Lens+import qualified Distribution.FieldGrammar.Newtypes as Newtypes+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.Console.GetOpt as GetOpt+import qualified System.FilePath as FilePath++-- | Evaluates pragmas within the given field. Or, if the field is a section,+-- evaluates pragmas recursively within the fields of the section.+field ::+ (Exception.MonadThrow m, MonadWalk.MonadWalk m) =>+ FilePath ->+ Fields.Field (p, Comments.Comments q) ->+ m (Fields.Field (p, Comments.Comments q))+field p f = case f of+ Fields.Field n fls -> fmap (Maybe.fromMaybe f) . MaybeT.runMaybeT $ do+ dt <-+ maybe Applicative.empty pure $+ Map.lookup (Name.value n) relevantFieldNames+ comment <- hoistMaybe . Utils.safeLast . Comments.toList . snd $ Name.annotation n+ Pragma.Pragma (Discover ds) <- hoistMaybe . Parsec.simpleParsecBS $ Comment.value comment+ discover p n fls dt ds+ Fields.Section n sas fs -> Fields.Section n sas <$> traverse (field p) fs++newtype Discover = Discover [String]++instance Parsec.Parsec Discover where+ parsec = do+ Monad.void $ CharParsing.string "discover"+ arguments <-+ Monad.mplus+ (CharParsing.skipSpaces1 *> CharParsing.sepBy Parsec.parsec CharParsing.skipSpaces1)+ ([] <$ CharParsing.spaces)+ CharParsing.eof+ pure . Discover $ fmap Newtypes.getToken' arguments++-- | If modules are discovered for a field, that fields lines are completely+-- replaced.+discover ::+ (Exception.MonadThrow m, MonadWalk.MonadWalk m) =>+ FilePath ->+ Fields.Name (p, Comments.Comments q) ->+ [Fields.FieldLine (p, Comments.Comments q)] ->+ DiscoverTarget.DiscoverTarget ->+ [String] ->+ MaybeT.MaybeT m (Fields.Field (p, Comments.Comments q))+discover p n fls dt ds = do+ let (flgs, args, opts, errs) =+ GetOpt.getOpt'+ GetOpt.Permute+ [ GetOpt.Option [] ["include"] (GetOpt.ReqArg Right "PATTERN") "",+ GetOpt.Option [] ["exclude"] (GetOpt.ReqArg Left "PATTERN") ""+ ]+ ds+ let (excs, incs) = Either.partitionEithers flgs+ mapM_ (Exception.throwM . UnknownOption.fromString) opts+ mapM_ (Exception.throwM . InvalidOption.fromString) errs+ let root = FilePath.dropTrailingPathSeparator . clean $ FilePath.takeDirectory p+ directories =+ List.nubOrd+ . fmap clean+ $ if null args then ["."] else args+ exclusions = List.nubOrd $ fmap clean excs+ inclusions =+ List.nubOrd+ . fmap clean+ $ if null incs then fmap (`FilePath.combine` "**") directories else incs+ files <- Trans.lift $ MonadWalk.walk root inclusions exclusions+ let comments = foldMap (snd . FieldLine.annotation) fls+ position =+ maybe (fst $ Name.annotation n) (fst . FieldLine.annotation) $+ Maybe.listToMaybe fls+ fieldLines = case dt of+ DiscoverTarget.Modules ->+ zipWith ModuleName.toFieldLine ((,) position <$> comments : repeat Comments.empty)+ . Maybe.mapMaybe (toModuleName directories)+ $ Maybe.mapMaybe (stripAnyExtension extensions . clean) files+ DiscoverTarget.Files ->+ zipWith+ (\a -> Fields.FieldLine a . String.toUtf8)+ ((,) position <$> comments : repeat Comments.empty)+ files+ -- This isn't great, but the comments have to go /somewhere/.+ name =+ if null fieldLines+ then Lens.over (Name.annotationLens . Lens._2) (comments <>) n+ else n+ pure $ Fields.Field name fieldLines++-- | Converts separators into POSIX format and then normalizes the result.+clean :: FilePath -> FilePath+clean = FilePath.normalise . FilePath.toPosixSeparators++-- | These are the names of the fields that can have this action applied to+-- them.+relevantFieldNames :: Map.Map Fields.FieldName DiscoverTarget.DiscoverTarget+relevantFieldNames =+ Map.mapKeys String.toUtf8 . Map.fromList $+ [ ("asm-sources", DiscoverTarget.Files),+ ("c-sources", DiscoverTarget.Files),+ ("cxx-sources", DiscoverTarget.Files),+ ("data-files", DiscoverTarget.Files),+ ("exposed-modules", DiscoverTarget.Modules),+ ("extra-doc-files", DiscoverTarget.Files),+ ("extra-source-files", DiscoverTarget.Files),+ ("includes", DiscoverTarget.Files),+ ("install-includes", DiscoverTarget.Files),+ ("js-sources", DiscoverTarget.Files),+ ("license-files", DiscoverTarget.Files),+ ("other-modules", DiscoverTarget.Modules),+ ("signatures", DiscoverTarget.Modules)+ ]++-- | 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+stripAnyExtension es p =+ Maybe.listToMaybe+ . Maybe.mapMaybe (`FilePath.stripExtension` p)+ $ Set.toList es++-- | The set of extensions that should be discovered by this pragma. Any file+-- with one of these extensions will be discovered.+--+-- <https://cabal.readthedocs.io/en/3.10/cabal-package.html#modules-and-preprocessors>+extensions :: Set.Set String+extensions =+ 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+-- <https://hub.darcs.net/ross/transformers/issue/49>.+hoistMaybe :: (Applicative f) => Maybe a -> MaybeT.MaybeT f a+hoistMaybe = MaybeT.MaybeT . pure
+ source/library/CabalGild/Unstable/Action/EvaluatePragmas/Version.hs view
@@ -0,0 +1,68 @@+module CabalGild.Unstable.Action.EvaluatePragmas.Version where++import qualified CabalGild.Unstable.Type.Comment as Comment+import qualified CabalGild.Unstable.Type.Comments as Comments+import qualified CabalGild.Unstable.Type.Pragma as Pragma+import qualified Data.ByteString as ByteString+import qualified Data.String as String+import qualified Data.Version as Version+import qualified Distribution.Compat.CharParsing as CharParsing+import qualified Distribution.Fields as Fields+import qualified Distribution.Parsec as Parsec+import qualified Paths_cabal_gild as This++field ::+ Fields.Field (p, Comments.Comments q) ->+ Fields.Field (p, Comments.Comments q)+field = fmap $ fmap versionComments++data Version = Version+ deriving (Eq, Show)++instance Parsec.Parsec Version where+ parsec = Version <$ CharParsing.string "version"++versionComments ::+ Comments.Comments q ->+ Comments.Comments q+versionComments cs =+ cs+ { Comments.before = expandVersion (Comments.before cs),+ Comments.after = expandVersion (Comments.after cs)+ }++-- | Walks a list of comments. When a version pragma is found, ensures it is+-- followed by a generated version comment. Any existing generated comment is+-- replaced with the current version.+expandVersion :: [Comment.Comment q] -> [Comment.Comment q]+expandVersion [] = []+expandVersion (c : cs) = case Parsec.simpleParsecBS $ Comment.value c of+ Just (Pragma.Pragma Version) ->+ c : generatedComment c : expandVersion (dropGenerated cs)+ Nothing -> c : expandVersion cs++-- | Creates a generated version comment, borrowing the annotation from the+-- pragma comment.+generatedComment :: Comment.Comment q -> Comment.Comment q+generatedComment pragma =+ Comment.Comment+ { Comment.annotation = Comment.annotation pragma,+ Comment.value = String.fromString generatedText+ }++-- | The full text of a generated version comment (without the @--@ delimiter).+generatedText :: String+generatedText = generatedPrefix <> Version.showVersion This.version++-- | The prefix used to identify generated version comments.+generatedPrefix :: String+generatedPrefix = " Generated with cabal-gild version "++-- | Checks whether a comment is a generated version comment.+isGenerated :: Comment.Comment q -> Bool+isGenerated = (String.fromString generatedPrefix `ByteString.isPrefixOf`) . Comment.value++-- | Drops a leading generated version comment, if present.+dropGenerated :: [Comment.Comment q] -> [Comment.Comment q]+dropGenerated (c : cs) | isGenerated c = cs+dropGenerated cs = cs
source/library/CabalGild/Unstable/Type/Pragma.hs view
@@ -2,24 +2,18 @@ import qualified Control.Monad as Monad import qualified Distribution.Compat.CharParsing as CharParsing-import qualified Distribution.FieldGrammar.Newtypes as Newtypes import qualified Distribution.Parsec as Parsec -- | A pragma, which is a special comment used to customize behavior.-newtype Pragma- = -- | Discover modules using the given arguments.- Discover [String]+newtype Pragma a = Pragma a deriving (Eq, Show) -instance Parsec.Parsec Pragma where+instance (Parsec.Parsec a) => Parsec.Parsec (Pragma a) where parsec = do CharParsing.spaces- Monad.void $ CharParsing.string "cabal-gild:"+ Monad.void $ CharParsing.string cabalGildPragmaPrefix CharParsing.spaces- Monad.void $ CharParsing.string "discover"- arguments <-- Monad.mplus- (CharParsing.skipSpaces1 *> CharParsing.sepBy Parsec.parsec CharParsing.skipSpaces1)- ([] <$ CharParsing.spaces)- CharParsing.eof- pure . Discover $ fmap Newtypes.getToken' arguments+ Pragma <$> Parsec.parsec++cabalGildPragmaPrefix :: String+cabalGildPragmaPrefix = "cabal-gild:"
source/test-suite/Main.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +import qualified CabalGild.Unstable.Action.EvaluatePragmas.Version as Version import qualified CabalGild.Unstable.Class.MonadHandle as MonadHandle import qualified CabalGild.Unstable.Class.MonadLog as MonadLog import qualified CabalGild.Unstable.Class.MonadRead as MonadRead@@ -1544,6 +1545,78 @@ "library\n -- cabal-gild: discover\n exposed-modules:\n -- c\n N" "library\n -- c\n -- cabal-gild: discover\n exposed-modules:\n" + Hspec.describe "pragma" $ do+ Hspec.describe "version" $ do+ Hspec.it "works without any fields" $ do+ expectGilded+ "-- cabal-gild: version"+ ("-- cabal-gild: version\n" <> versionComment <> "\n")++ Hspec.it "works before a field" $ do+ expectGilded+ "-- cabal-gild: version\nfld: val"+ ("-- cabal-gild: version\n" <> versionComment <> "\nfld: val\n")++ Hspec.it "works within a field" $ do+ expectGilded+ "fld:\n a\n -- cabal-gild: version\n b"+ ("fld:\n -- cabal-gild: version\n " <> versionComment <> "\n a\n b\n")++ Hspec.it "works after a field" $ do+ expectGilded+ "fld: val\n-- cabal-gild: version"+ ("fld: val\n-- cabal-gild: version\n" <> versionComment <> "\n")++ Hspec.it "works before a section" $ do+ expectGilded+ "-- cabal-gild: version\nsec"+ ("-- cabal-gild: version\n" <> versionComment <> "\nsec\n")++ Hspec.it "works within a section" $ do+ expectGilded+ "sec\n -- cabal-gild: version"+ ("sec\n -- cabal-gild: version\n " <> versionComment <> "\n")++ Hspec.it "works after a section" $ do+ expectGilded+ "sec\n-- cabal-gild: version"+ ("sec\n\n-- cabal-gild: version\n" <> versionComment <> "\n")++ Hspec.it "works twice in a row" $ do+ expectGilded+ "-- cabal-gild: version\n-- cabal-gild: version"+ ("-- cabal-gild: version\n" <> versionComment <> "\n-- cabal-gild: version\n" <> versionComment <> "\n")++ Hspec.it "works before a comment" $ do+ expectGilded+ "-- cabal-gild: version\n-- cmt"+ ("-- cabal-gild: version\n" <> versionComment <> "\n-- cmt\n")++ Hspec.it "does not replace a standalone version comment" $ do+ expectGilded+ versionComment+ (versionComment <> "\n")++ Hspec.it "replaces a version comment after the pragma" $ do+ expectGilded+ "-- cabal-gild: version\n-- Generated with cabal-gild version 0"+ ("-- cabal-gild: version\n" <> versionComment <> "\n")++ Hspec.it "replaces a version comment after the pragma with a blank line" $ do+ expectGilded+ "-- cabal-gild: version\n\n-- Generated with cabal-gild version 0"+ ("-- cabal-gild: version\n" <> versionComment <> "\n")++ Hspec.it "does not replace a distant version comment" $ do+ expectGilded+ "-- cabal-gild: version\n-- cmt\n-- Generated with cabal-gild version 0"+ ("-- cabal-gild: version\n" <> versionComment <> "\n-- cmt\n-- Generated with cabal-gild version 0\n")++ Hspec.it "only replaces a single version comment" $ do+ expectGilded+ "-- cabal-gild: version\n-- Generated with cabal-gild version 0\n-- Generated with cabal-gild version 1"+ ("-- cabal-gild: version\n" <> versionComment <> "\n-- Generated with cabal-gild version 1\n")+ Hspec.it "parses an empty brace section" $ do expectGilded "s{}"@@ -1923,6 +1996,9 @@ expectGilded :: (Stack.HasCallStack) => String -> String -> Hspec.Expectation expectGilded = expectDiscover (".", [])++versionComment :: String+versionComment = "--" <> Version.generatedText expectStable :: (Stack.HasCallStack) =>