packages feed

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 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) =>