diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,8 +12,11 @@ [cabal-gild-setup-action]: https://github.com/tfausak/cabal-gild-setup-action Gild started as a fork of [phadej/cabal-fmt][], but is now totally separate. +For a brief summary of the differences between Gild and `cabal-fmt`, read [the +announcement post][]. [phadej/cabal-fmt]: https://github.com/phadej/cabal-fmt +[the announcement post]: https://taylor.fausak.me/2024/02/17/gild/ ## Summary 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.0.0 +version: 1.0.0.1 source-repository head type: git @@ -69,11 +69,11 @@ -- cabal-gild: discover source/library exposed-modules: CabalGild.Action.AttachComments - CabalGild.Action.Discover + CabalGild.Action.EvaluatePragmas CabalGild.Action.ExtractComments - CabalGild.Action.Format + CabalGild.Action.FormatFields CabalGild.Action.GetCabalVersion - CabalGild.Action.Reindent + CabalGild.Action.ReflowText CabalGild.Action.RemovePositions CabalGild.Action.Render CabalGild.Class.MonadLog diff --git a/source/library/CabalGild/Action/Discover.hs b/source/library/CabalGild/Action/Discover.hs deleted file mode 100644 --- a/source/library/CabalGild/Action/Discover.hs +++ /dev/null @@ -1,76 +0,0 @@ -module CabalGild.Action.Discover where - -import qualified CabalGild.Class.MonadWalk as MonadWalk -import qualified CabalGild.Extra.ModuleName as ModuleName -import qualified CabalGild.Extra.Name as Name -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.Maybe as Maybe -import qualified Data.Set as Set -import qualified Distribution.Fields as Fields -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Utils.Generic as Utils -import qualified System.FilePath as FilePath - --- | High level wrapper around 'fields' that makes this action easier to --- compose with other actions. -run :: - (MonadWalk.MonadWalk m) => - FilePath -> - ([Fields.Field [Comment.Comment a]], cs) -> - m ([Fields.Field [Comment.Comment a]], cs) -run p (fs, cs) = (,) <$> fields p fs <*> pure cs - --- | Discovers modules within the given fields. -fields :: - (MonadWalk.MonadWalk m) => - FilePath -> - [Fields.Field [Comment.Comment a]] -> - m [Fields.Field [Comment.Comment a]] -fields = mapM . field - --- | Discovers modules within the given field. Or, if the field is a section, --- discover modules recursively within the fields of the section. If modules --- are discovered for a field, that fields lines are completely replaced. If --- anything goes wrong while discovering modules, the original field is --- returned. -field :: - (MonadWalk.MonadWalk m) => - FilePath -> - Fields.Field [Comment.Comment a] -> - m (Fields.Field [Comment.Comment a]) -field p f = case f of - Fields.Field n _ -> fmap (Maybe.fromMaybe f) . MaybeT.runMaybeT $ do - Monad.guard $ Set.member (Name.value n) relevantFieldNames - 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 (FilePath.stripExtension "hs") fs - 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" - ] - --- | This was added in @transformers-0.6.0.0@. See --- . -hoistMaybe :: (Applicative f) => Maybe a -> MaybeT.MaybeT f a -hoistMaybe = MaybeT.MaybeT . pure diff --git a/source/library/CabalGild/Action/EvaluatePragmas.hs b/source/library/CabalGild/Action/EvaluatePragmas.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Action/EvaluatePragmas.hs @@ -0,0 +1,77 @@ +module CabalGild.Action.EvaluatePragmas where + +import qualified CabalGild.Class.MonadWalk as MonadWalk +import qualified CabalGild.Extra.ModuleName as ModuleName +import qualified CabalGild.Extra.Name as Name +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.Maybe as Maybe +import qualified Data.Set as Set +import qualified Distribution.Fields as Fields +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Utils.Generic as Utils +import qualified System.FilePath as FilePath + +-- | High level wrapper around 'fields' that makes this action easier to +-- compose with other actions. +run :: + (MonadWalk.MonadWalk m) => + FilePath -> + ([Fields.Field [Comment.Comment a]], cs) -> + m ([Fields.Field [Comment.Comment a]], cs) +run p (fs, cs) = (,) <$> fields p fs <*> pure cs + +-- | Evaluates pragmas modules within the given fields. +fields :: + (MonadWalk.MonadWalk m) => + FilePath -> + [Fields.Field [Comment.Comment a]] -> + m [Fields.Field [Comment.Comment a]] +fields = mapM . field + +-- | Evaluates pragmas within the given field. Or, if the field is a section, +-- evaluates pragmas recursively within the fields of the section. +-- +-- If modules are discovered for a field, that fields lines are completely +-- replaced. If anything goes wrong while discovering modules, the original +-- field is returned. +field :: + (MonadWalk.MonadWalk m) => + FilePath -> + Fields.Field [Comment.Comment a] -> + m (Fields.Field [Comment.Comment a]) +field p f = case f of + Fields.Field n _ -> fmap (Maybe.fromMaybe f) . MaybeT.runMaybeT $ do + Monad.guard $ Set.member (Name.value n) relevantFieldNames + 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 (FilePath.stripExtension "hs") fs + 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" + ] + +-- | This was added in @transformers-0.6.0.0@. See +-- . +hoistMaybe :: (Applicative f) => Maybe a -> MaybeT.MaybeT f a +hoistMaybe = MaybeT.MaybeT . pure diff --git a/source/library/CabalGild/Action/Format.hs b/source/library/CabalGild/Action/Format.hs deleted file mode 100644 --- a/source/library/CabalGild/Action/Format.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE TypeApplications #-} - -module CabalGild.Action.Format where - -import CabalGild.Compat.Cabal () -import qualified CabalGild.Extra.FieldLine as FieldLine -import qualified CabalGild.Extra.Name as Name -import qualified CabalGild.Extra.String as String -import qualified CabalGild.Type.SomeParsecParser as SPP -import qualified Data.Functor.Identity as Identity -import qualified Data.Map as Map -import qualified Distribution.CabalSpecVersion as CabalSpecVersion -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.Types.Dependency as Dependency -import qualified Distribution.Types.ExeDependency as ExeDependency -import qualified Distribution.Types.ForeignLibOption as ForeignLibOption -import qualified Distribution.Types.LegacyExeDependency as LegacyExeDependency -import qualified Distribution.Types.Mixin as Mixin -import qualified Distribution.Types.ModuleReexport as ModuleReexport -import qualified Distribution.Types.PkgconfigDependency as PkgconfigDependency -import qualified Language.Haskell.Extension as Extension -import qualified Text.PrettyPrint as PrettyPrint - --- | A wrapper around 'fields' to allow this to be composed with other actions. -run :: - (Applicative m, Monoid cs) => - CabalSpecVersion.CabalSpecVersion -> - ([Fields.Field cs], cs) -> - m ([Fields.Field cs], cs) -run csv (fs, cs) = pure (fields csv fs, cs) - --- | A wrapper around 'field'. -fields :: - (Monoid cs) => - CabalSpecVersion.CabalSpecVersion -> - [Fields.Field cs] -> - [Fields.Field cs] -fields = fmap . field - --- | Formats the given field, if applicable. Otherwise returns the field as is. --- If the field is a section, the fields within the section will be recursively --- formatted. -field :: - (Monoid cs) => - CabalSpecVersion.CabalSpecVersion -> - Fields.Field cs -> - Fields.Field cs -field csv f = case f of - Fields.Field n fls -> case Map.lookup (Name.value n) parsers of - Nothing -> f - Just spp -> Fields.Field n $ fieldLines csv fls spp - Fields.Section n sas fs -> Fields.Section n sas $ fields csv fs - --- | Attempts to parse the given field lines using the given parser. If parsing --- fails, the field lines will be returned as is. Comments within the field --- lines will be preserved but "float" up to the top. -fieldLines :: - (Monoid cs) => - CabalSpecVersion.CabalSpecVersion -> - [Fields.FieldLine cs] -> - SPP.SomeParsecParser -> - [Fields.FieldLine cs] -fieldLines csv fls SPP.SomeParsecParser {SPP.parsec = parsec, SPP.pretty = pretty} = - case Parsec.runParsecParser' csv parsec "" $ FieldLine.toFieldLineStream fls of - Left _ -> fls - Right r -> - fmap (\(c, l) -> Fields.FieldLine c $ String.toUtf8 l) - . zip (foldMap FieldLine.annotation fls : repeat mempty) - . lines - . PrettyPrint.renderStyle style - $ pretty csv r - --- | This style attempts to force everything to be on its own line. -style :: PrettyPrint.Style -style = - PrettyPrint.Style - { PrettyPrint.mode = PrettyPrint.PageMode, - PrettyPrint.lineLength = 0, - PrettyPrint.ribbonsPerLine = 1 - } - --- | A map from field names to parsers. This determines which parser should be --- used for which field. And consequently this determines which fields will be --- formatted. --- --- Perhaps instead of being keyed on 'Fields.FieldName', this should be keyed --- on a path (list of field names) instead. That's because a field like --- @build-depends@ only really makes sense within a section like @library@. --- Fortunately field names are unique enough that this hasn't been a problem --- yet. -parsers :: Map.Map Fields.FieldName SPP.SomeParsecParser -parsers = - let (=:) :: String -> SPP.SomeParsecParser -> (Fields.FieldName, SPP.SomeParsecParser) - (=:) = (,) . String.toUtf8 - in Map.fromList - [ "asm-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "asm-sources" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, - "autogen-includes" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, - "autogen-modules" =: SPP.set @Newtypes.VCat @(Newtypes.MQuoted ModuleName.ModuleName), - "build-depends" =: SPP.set @Newtypes.CommaVCat @(Identity.Identity Dependency.Dependency), - "build-tool-depends" =: SPP.set @Newtypes.CommaFSep @(Identity.Identity ExeDependency.ExeDependency), - "build-tools" =: SPP.set @Newtypes.CommaFSep @(Identity.Identity LegacyExeDependency.LegacyExeDependency), - "c-sources" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, - "cc-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "cmm-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "cmm-sources" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, - "code-generators" =: SPP.list @Newtypes.CommaFSep @Newtypes.Token, - "cpp-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "cxx-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "cxx-sources" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, - "data-files" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, - "default-extensions" =: SPP.set @Newtypes.FSep @(Newtypes.MQuoted Extension.Extension), - "exposed-modules" =: SPP.set @Newtypes.VCat @(Newtypes.MQuoted ModuleName.ModuleName), - "extensions" =: SPP.set @Newtypes.FSep @(Newtypes.MQuoted Extension.Extension), - "extra-bundled-libraries" =: SPP.set @Newtypes.VCat @Newtypes.Token, - "extra-doc-files" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, - "extra-dynamic-library-flavours" =: SPP.set @Newtypes.VCat @Newtypes.Token, - "extra-framework-dirs" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, - "extra-ghci-libraries" =: SPP.set @Newtypes.VCat @Newtypes.Token, - "extra-lib-dirs-static" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, - "extra-lib-dirs" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, - "extra-libraries-static" =: SPP.set @Newtypes.VCat @Newtypes.Token, - "extra-libraries" =: SPP.set @Newtypes.VCat @Newtypes.Token, - "extra-library-flavours" =: SPP.set @Newtypes.VCat @Newtypes.Token, - "extra-source-files" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, - "extra-tmp-files" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, - "frameworks" =: SPP.set @Newtypes.FSep @Newtypes.Token, - "ghc-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "ghc-prof-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "ghc-shared-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "ghcjs-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "ghcjs-prof-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "ghcjs-shared-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "hs-source-dirs" =: SPP.list @Newtypes.FSep @Newtypes.FilePathNT, - "hsc2hs-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "include-dirs" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, - "includes" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, - "install-includes" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, - "js-sources" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, - "ld-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', - "license-files" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, - "mixins" =: SPP.set @Newtypes.CommaVCat @(Identity.Identity Mixin.Mixin), - "options" =: SPP.set @Newtypes.FSep @(Identity.Identity ForeignLibOption.ForeignLibOption), - "other-extensions" =: SPP.set @Newtypes.FSep @(Newtypes.MQuoted Extension.Extension), - "other-languages" =: SPP.set @Newtypes.FSep @(Newtypes.MQuoted Extension.Language), - "other-modules" =: SPP.set @Newtypes.VCat @(Newtypes.MQuoted ModuleName.ModuleName), - "pkgconfig-depends" =: SPP.set @Newtypes.CommaFSep @(Identity.Identity PkgconfigDependency.PkgconfigDependency), - "reexported-modules" =: SPP.set @Newtypes.CommaVCat @(Identity.Identity ModuleReexport.ModuleReexport), - "setup-depends" =: SPP.set @Newtypes.CommaVCat @(Identity.Identity Dependency.Dependency), - "signatures" =: SPP.set @Newtypes.VCat @(Newtypes.MQuoted ModuleName.ModuleName), - "tested-with" =: SPP.set @Newtypes.FSep @Newtypes.TestedWith, - "virtual-modules" =: SPP.set @Newtypes.VCat @(Newtypes.MQuoted ModuleName.ModuleName) - ] diff --git a/source/library/CabalGild/Action/FormatFields.hs b/source/library/CabalGild/Action/FormatFields.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Action/FormatFields.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE TypeApplications #-} + +module CabalGild.Action.FormatFields where + +import CabalGild.Compat.Cabal () +import qualified CabalGild.Extra.FieldLine as FieldLine +import qualified CabalGild.Extra.Name as Name +import qualified CabalGild.Extra.String as String +import qualified CabalGild.Type.SomeParsecParser as SPP +import qualified Data.Functor.Identity as Identity +import qualified Data.Map as Map +import qualified Distribution.CabalSpecVersion as CabalSpecVersion +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.Types.Dependency as Dependency +import qualified Distribution.Types.ExeDependency as ExeDependency +import qualified Distribution.Types.ForeignLibOption as ForeignLibOption +import qualified Distribution.Types.LegacyExeDependency as LegacyExeDependency +import qualified Distribution.Types.Mixin as Mixin +import qualified Distribution.Types.ModuleReexport as ModuleReexport +import qualified Distribution.Types.PkgconfigDependency as PkgconfigDependency +import qualified Language.Haskell.Extension as Extension +import qualified Text.PrettyPrint as PrettyPrint + +-- | A wrapper around 'fields' to allow this to be composed with other actions. +run :: + (Applicative m, Monoid cs) => + CabalSpecVersion.CabalSpecVersion -> + ([Fields.Field cs], cs) -> + m ([Fields.Field cs], cs) +run csv (fs, cs) = pure (fields csv fs, cs) + +-- | A wrapper around 'field'. +fields :: + (Monoid cs) => + CabalSpecVersion.CabalSpecVersion -> + [Fields.Field cs] -> + [Fields.Field cs] +fields = fmap . field + +-- | Formats the given field, if applicable. Otherwise returns the field as is. +-- If the field is a section, the fields within the section will be recursively +-- formatted. +field :: + (Monoid cs) => + CabalSpecVersion.CabalSpecVersion -> + Fields.Field cs -> + Fields.Field cs +field csv f = case f of + Fields.Field n fls -> case Map.lookup (Name.value n) parsers of + Nothing -> f + Just spp -> Fields.Field n $ fieldLines csv fls spp + Fields.Section n sas fs -> Fields.Section n sas $ fields csv fs + +-- | Attempts to parse the given field lines using the given parser. If parsing +-- fails, the field lines will be returned as is. Comments within the field +-- lines will be preserved but "float" up to the top. +fieldLines :: + (Monoid cs) => + CabalSpecVersion.CabalSpecVersion -> + [Fields.FieldLine cs] -> + SPP.SomeParsecParser -> + [Fields.FieldLine cs] +fieldLines csv fls SPP.SomeParsecParser {SPP.parsec = parsec, SPP.pretty = pretty} = + case Parsec.runParsecParser' csv parsec "" $ FieldLine.toFieldLineStream fls of + Left _ -> fls + Right r -> + fmap (\(c, l) -> Fields.FieldLine c $ String.toUtf8 l) + . zip (foldMap FieldLine.annotation fls : repeat mempty) + . lines + . PrettyPrint.renderStyle style + $ pretty csv r + +-- | This style attempts to force everything to be on its own line. +style :: PrettyPrint.Style +style = + PrettyPrint.Style + { PrettyPrint.mode = PrettyPrint.PageMode, + PrettyPrint.lineLength = 0, + PrettyPrint.ribbonsPerLine = 1 + } + +-- | A map from field names to parsers. This determines which parser should be +-- used for which field. And consequently this determines which fields will be +-- formatted. +-- +-- Perhaps instead of being keyed on 'Fields.FieldName', this should be keyed +-- on a path (list of field names) instead. That's because a field like +-- @build-depends@ only really makes sense within a section like @library@. +-- Fortunately field names are unique enough that this hasn't been a problem +-- yet. +parsers :: Map.Map Fields.FieldName SPP.SomeParsecParser +parsers = + let (=:) :: String -> SPP.SomeParsecParser -> (Fields.FieldName, SPP.SomeParsecParser) + (=:) = (,) . String.toUtf8 + in Map.fromList + [ "asm-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "asm-sources" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, + "autogen-includes" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, + "autogen-modules" =: SPP.set @Newtypes.VCat @(Newtypes.MQuoted ModuleName.ModuleName), + "build-depends" =: SPP.set @Newtypes.CommaVCat @(Identity.Identity Dependency.Dependency), + "build-tool-depends" =: SPP.set @Newtypes.CommaFSep @(Identity.Identity ExeDependency.ExeDependency), + "build-tools" =: SPP.set @Newtypes.CommaFSep @(Identity.Identity LegacyExeDependency.LegacyExeDependency), + "c-sources" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, + "cc-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "cmm-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "cmm-sources" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, + "code-generators" =: SPP.list @Newtypes.CommaFSep @Newtypes.Token, + "cpp-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "cxx-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "cxx-sources" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, + "data-files" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, + "default-extensions" =: SPP.set @Newtypes.FSep @(Newtypes.MQuoted Extension.Extension), + "exposed-modules" =: SPP.set @Newtypes.VCat @(Newtypes.MQuoted ModuleName.ModuleName), + "extensions" =: SPP.set @Newtypes.FSep @(Newtypes.MQuoted Extension.Extension), + "extra-bundled-libraries" =: SPP.set @Newtypes.VCat @Newtypes.Token, + "extra-doc-files" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, + "extra-dynamic-library-flavours" =: SPP.set @Newtypes.VCat @Newtypes.Token, + "extra-framework-dirs" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, + "extra-ghci-libraries" =: SPP.set @Newtypes.VCat @Newtypes.Token, + "extra-lib-dirs-static" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, + "extra-lib-dirs" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, + "extra-libraries-static" =: SPP.set @Newtypes.VCat @Newtypes.Token, + "extra-libraries" =: SPP.set @Newtypes.VCat @Newtypes.Token, + "extra-library-flavours" =: SPP.set @Newtypes.VCat @Newtypes.Token, + "extra-source-files" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, + "extra-tmp-files" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, + "frameworks" =: SPP.set @Newtypes.FSep @Newtypes.Token, + "ghc-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "ghc-prof-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "ghc-shared-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "ghcjs-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "ghcjs-prof-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "ghcjs-shared-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "hs-source-dirs" =: SPP.list @Newtypes.FSep @Newtypes.FilePathNT, + "hsc2hs-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "include-dirs" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, + "includes" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, + "install-includes" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, + "js-sources" =: SPP.set @Newtypes.VCat @Newtypes.FilePathNT, + "ld-options" =: SPP.list @Newtypes.NoCommaFSep @Newtypes.Token', + "license-files" =: SPP.set @Newtypes.FSep @Newtypes.FilePathNT, + "mixins" =: SPP.set @Newtypes.CommaVCat @(Identity.Identity Mixin.Mixin), + "options" =: SPP.set @Newtypes.FSep @(Identity.Identity ForeignLibOption.ForeignLibOption), + "other-extensions" =: SPP.set @Newtypes.FSep @(Newtypes.MQuoted Extension.Extension), + "other-languages" =: SPP.set @Newtypes.FSep @(Newtypes.MQuoted Extension.Language), + "other-modules" =: SPP.set @Newtypes.VCat @(Newtypes.MQuoted ModuleName.ModuleName), + "pkgconfig-depends" =: SPP.set @Newtypes.CommaFSep @(Identity.Identity PkgconfigDependency.PkgconfigDependency), + "reexported-modules" =: SPP.set @Newtypes.CommaVCat @(Identity.Identity ModuleReexport.ModuleReexport), + "setup-depends" =: SPP.set @Newtypes.CommaVCat @(Identity.Identity Dependency.Dependency), + "signatures" =: SPP.set @Newtypes.VCat @(Newtypes.MQuoted ModuleName.ModuleName), + "tested-with" =: SPP.set @Newtypes.FSep @Newtypes.TestedWith, + "virtual-modules" =: SPP.set @Newtypes.VCat @(Newtypes.MQuoted ModuleName.ModuleName) + ] diff --git a/source/library/CabalGild/Action/ReflowText.hs b/source/library/CabalGild/Action/ReflowText.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Action/ReflowText.hs @@ -0,0 +1,129 @@ +module CabalGild.Action.ReflowText where + +import qualified CabalGild.Extra.Field as Field +import qualified CabalGild.Extra.FieldLine as FieldLine +import qualified CabalGild.Extra.List as List +import qualified CabalGild.Extra.Name as Name +import qualified CabalGild.Extra.String as String +import qualified CabalGild.Type.Comment as Comment +import qualified Data.ByteString as ByteString +import qualified Data.Set as Set +import qualified Distribution.CabalSpecVersion as CabalSpecVersion +import qualified Distribution.Fields as Fields +import qualified Distribution.Parsec.Position as Position + +-- | A wrapper around 'fields' to allow this to be composed with other actions. +run :: + (Applicative m) => + CabalSpecVersion.CabalSpecVersion -> + ([Fields.Field (Position.Position, [Comment.Comment Position.Position])], cs) -> + m ([Fields.Field (Position.Position, [Comment.Comment Position.Position])], cs) +run csv (fs, cs) = pure (fields csv fs, cs) + +-- | Reflows the free text field values if the Cabal spec version is recent +-- enough (at least @3.0@). +-- +-- Note that this requires comments to be already attached. That's because +-- comments should not be attached to blank lines, which this function will +-- insert. +fields :: + CabalSpecVersion.CabalSpecVersion -> + [Fields.Field (Position.Position, [Comment.Comment Position.Position])] -> + [Fields.Field (Position.Position, [Comment.Comment Position.Position])] +fields csv fs = + if csv >= CabalSpecVersion.CabalSpecV3_0 + then fmap field fs + else fs + +-- | Reflows the free text field value if applicable. Otherwise returns the +-- field as is. If the field is a section, the fields within the section will +-- be recursively reflowed. +field :: + Fields.Field (Position.Position, [Comment.Comment Position.Position]) -> + Fields.Field (Position.Position, [Comment.Comment Position.Position]) +field f = case f of + Fields.Field n fls -> + if Set.member (Name.value n) relevantFieldNames && List.compareLength fls 1 == GT + then Fields.Field n $ fieldLines f fls + else f + Fields.Section n sas fs -> Fields.Section n sas $ fmap field fs + +-- | The names of the fields that should be reflowed. +relevantFieldNames :: Set.Set Fields.FieldName +relevantFieldNames = + Set.fromList $ + fmap + String.toUtf8 + [ "description" + ] + +-- | Reflows the field lines for the given field. This is just a wrapper around +-- 'fixRows' and 'fixCols'. +fieldLines :: + Fields.Field (Position.Position, [Comment.Comment Position.Position]) -> + [Fields.FieldLine (Position.Position, [Comment.Comment Position.Position])] -> + [Fields.FieldLine (Position.Position, [Comment.Comment Position.Position])] +fieldLines f = fixRows . fixCols f + +-- | Inserts blank lines between field lines if necessary. +fixRows :: + [Fields.FieldLine (Position.Position, [Comment.Comment Position.Position])] -> + [Fields.FieldLine (Position.Position, [Comment.Comment Position.Position])] +fixRows fls = case fls of + x : y : zs -> + x + : fmap rowToFieldLine [fieldLineToLastRow x + 1 .. fieldLineToFirstRow y - 1] + <> fixRows (y : zs) + _ -> fls + +-- | Reindents field lines by finding the least indented line and adjusting the +-- other lines relative to that one. Note that if the first field line is on +-- the same line as the field itself, it will never be reindented. +fixCols :: + Fields.Field (Position.Position, [Comment.Comment Position.Position]) -> + [Fields.FieldLine (Position.Position, [Comment.Comment Position.Position])] -> + [Fields.FieldLine (Position.Position, [Comment.Comment Position.Position])] +fixCols f fls = case fls of + [] -> fls + x : xs -> + let col = foldr (min . fieldLineToCol) (fieldLineToCol x) xs + in if fieldToRow f == fieldLineToFirstRow x + then x : fmap (reindent col) xs + else fmap (reindent col) fls + +-- | Extracts the column number from a field line. +fieldLineToCol :: Fields.FieldLine (Position.Position, cs) -> Int +fieldLineToCol = Position.positionCol . fst . FieldLine.annotation + +-- | Extracts the /first/ row number from a field line, which might belong to +-- one of its comments. +fieldLineToFirstRow :: + Fields.FieldLine (Position.Position, [Comment.Comment Position.Position]) -> + Int +fieldLineToFirstRow = + Position.positionRow + . uncurry (foldr (min . Comment.annotation)) + . FieldLine.annotation + +-- | Extracts the /last/ row number from a field line, which will not belong to +-- any of its comments. +fieldLineToLastRow :: Fields.FieldLine (Position.Position, cs) -> Int +fieldLineToLastRow = Position.positionRow . fst . FieldLine.annotation + +-- | Extracts the row number from a field. +fieldToRow :: Fields.Field (Position.Position, cs) -> Int +fieldToRow = Position.positionRow . fst . Name.annotation . Field.name + +-- | Reindents the field line using the given column number. +reindent :: + Int -> + Fields.FieldLine (Position.Position, cs) -> + Fields.FieldLine (Position.Position, cs) +reindent col (Fields.FieldLine (p, cs) b) = + Fields.FieldLine (p, cs) $ ByteString.replicate (Position.positionCol p - col) 0x20 <> b + +-- | Creates a blank field line at the given row number. +rowToFieldLine :: + Int -> + Fields.FieldLine (Position.Position, [c]) +rowToFieldLine r = Fields.FieldLine (Position.Position r 1, []) ByteString.empty diff --git a/source/library/CabalGild/Action/Reindent.hs b/source/library/CabalGild/Action/Reindent.hs deleted file mode 100644 --- a/source/library/CabalGild/Action/Reindent.hs +++ /dev/null @@ -1,129 +0,0 @@ -module CabalGild.Action.Reindent where - -import qualified CabalGild.Extra.Field as Field -import qualified CabalGild.Extra.FieldLine as FieldLine -import qualified CabalGild.Extra.List as List -import qualified CabalGild.Extra.Name as Name -import qualified CabalGild.Extra.String as String -import qualified CabalGild.Type.Comment as Comment -import qualified Data.ByteString as ByteString -import qualified Data.Set as Set -import qualified Distribution.CabalSpecVersion as CabalSpecVersion -import qualified Distribution.Fields as Fields -import qualified Distribution.Parsec.Position as Position - --- | A wrapper around 'fields' to allow this to be composed with other actions. -run :: - (Applicative m) => - CabalSpecVersion.CabalSpecVersion -> - ([Fields.Field (Position.Position, [Comment.Comment Position.Position])], cs) -> - m ([Fields.Field (Position.Position, [Comment.Comment Position.Position])], cs) -run csv (fs, cs) = pure (fields csv fs, cs) - --- | Reindents the free text field values if the Cabal spec version is recent --- enough (at least @3.0@). --- --- Note that this requires comments to be already attached. That's because --- comments should not be attached to blank lines, which this function will --- insert. -fields :: - CabalSpecVersion.CabalSpecVersion -> - [Fields.Field (Position.Position, [Comment.Comment Position.Position])] -> - [Fields.Field (Position.Position, [Comment.Comment Position.Position])] -fields csv fs = - if csv >= CabalSpecVersion.CabalSpecV3_0 - then fmap field fs - else fs - --- | Reindents the free text field value if applicable. Otherwise returns the --- field as is. If the field is a section, the fields within the section will --- be recursively reindented. -field :: - Fields.Field (Position.Position, [Comment.Comment Position.Position]) -> - Fields.Field (Position.Position, [Comment.Comment Position.Position]) -field f = case f of - Fields.Field n fls -> - if Set.member (Name.value n) relevantFieldNames && List.compareLength fls 1 == GT - then Fields.Field n $ fieldLines f fls - else f - Fields.Section n sas fs -> Fields.Section n sas $ fmap field fs - --- | The names of the fields that should be reindented. -relevantFieldNames :: Set.Set Fields.FieldName -relevantFieldNames = - Set.fromList $ - fmap - String.toUtf8 - [ "description" - ] - --- | Reindents the field lines for the given field. This is just a wrapper --- around 'fixRows' and 'fixCols'. -fieldLines :: - Fields.Field (Position.Position, [Comment.Comment Position.Position]) -> - [Fields.FieldLine (Position.Position, [Comment.Comment Position.Position])] -> - [Fields.FieldLine (Position.Position, [Comment.Comment Position.Position])] -fieldLines f = fixRows . fixCols f - --- | Inserts blank lines between field lines if necessary. -fixRows :: - [Fields.FieldLine (Position.Position, [Comment.Comment Position.Position])] -> - [Fields.FieldLine (Position.Position, [Comment.Comment Position.Position])] -fixRows fls = case fls of - x : y : zs -> - x - : fmap rowToFieldLine [fieldLineToLastRow x + 1 .. fieldLineToFirstRow y - 1] - <> fixRows (y : zs) - _ -> fls - --- | Reindents field lines by finding the least indented line and adjusting the --- other lines relative to that one. Note that if the first field line is on --- the same line as the field itself, it will never be reindented. -fixCols :: - Fields.Field (Position.Position, [Comment.Comment Position.Position]) -> - [Fields.FieldLine (Position.Position, [Comment.Comment Position.Position])] -> - [Fields.FieldLine (Position.Position, [Comment.Comment Position.Position])] -fixCols f fls = case fls of - [] -> fls - x : xs -> - let col = foldr (min . fieldLineToCol) (fieldLineToCol x) xs - in if fieldToRow f == fieldLineToFirstRow x - then x : fmap (reindent col) xs - else fmap (reindent col) fls - --- | Extracts the column number from a field line. -fieldLineToCol :: Fields.FieldLine (Position.Position, cs) -> Int -fieldLineToCol = Position.positionCol . fst . FieldLine.annotation - --- | Extracts the /first/ row number from a field line, which might belong to --- one of its comments. -fieldLineToFirstRow :: - Fields.FieldLine (Position.Position, [Comment.Comment Position.Position]) -> - Int -fieldLineToFirstRow = - Position.positionRow - . uncurry (foldr (min . Comment.annotation)) - . FieldLine.annotation - --- | Extracts the /last/ row number from a field line, which will not belong to --- any of its comments. -fieldLineToLastRow :: Fields.FieldLine (Position.Position, cs) -> Int -fieldLineToLastRow = Position.positionRow . fst . FieldLine.annotation - --- | Extracts the row number from a field. -fieldToRow :: Fields.Field (Position.Position, cs) -> Int -fieldToRow = Position.positionRow . fst . Name.annotation . Field.name - --- | Reindents the field line using the given column number. -reindent :: - Int -> - Fields.FieldLine (Position.Position, cs) -> - Fields.FieldLine (Position.Position, cs) -reindent col (Fields.FieldLine (p, cs) b) = - Fields.FieldLine (p, cs) $ ByteString.replicate (Position.positionCol p - col) 0x20 <> b - --- | Creates a blank field line at the given row number. -rowToFieldLine :: - Int -> - Fields.FieldLine (Position.Position, [c]) -rowToFieldLine r = Fields.FieldLine (Position.Position r 1, []) ByteString.empty diff --git a/source/library/CabalGild/Main.hs b/source/library/CabalGild/Main.hs --- a/source/library/CabalGild/Main.hs +++ b/source/library/CabalGild/Main.hs @@ -2,11 +2,11 @@ module CabalGild.Main where import qualified CabalGild.Action.AttachComments as AttachComments -import qualified CabalGild.Action.Discover as Discover +import qualified CabalGild.Action.EvaluatePragmas as EvaluatePragmas import qualified CabalGild.Action.ExtractComments as ExtractComments -import qualified CabalGild.Action.Format as Format +import qualified CabalGild.Action.FormatFields as FormatFields import qualified CabalGild.Action.GetCabalVersion as GetCabalVersion -import qualified CabalGild.Action.Reindent as Reindent +import qualified CabalGild.Action.ReflowText as ReflowText import qualified CabalGild.Action.RemovePositions as RemovePositions import qualified CabalGild.Action.Render as Render import qualified CabalGild.Class.MonadLog as MonadLog @@ -20,6 +20,8 @@ import qualified CabalGild.Type.Mode as Mode import qualified Control.Monad as Monad import qualified Control.Monad.Catch as Exception +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Latin1 import qualified Data.Maybe as Maybe import qualified Data.Version as Version import qualified Distribution.Fields as Fields @@ -89,16 +91,25 @@ comments = ExtractComments.fromByteString input output <- ( AttachComments.run - Monad.>=> Reindent.run csv + Monad.>=> ReflowText.run csv Monad.>=> RemovePositions.run - Monad.>=> Discover.run (Maybe.fromMaybe (Config.stdin config) $ Config.input config) - Monad.>=> Format.run csv + Monad.>=> EvaluatePragmas.run (Maybe.fromMaybe (Config.stdin config) $ Config.input config) + Monad.>=> FormatFields.run csv Monad.>=> Render.run ) (fields, comments) case Config.mode config of - Mode.Check -> - Monad.when (output /= input) $ + Mode.Check -> do + -- The input might have CRLF ("\r\n", 0x0d 0x0a) line endings, but the + -- output will always have LF line endings. For the purposes of the check + -- command, we'll consider the input formatted if it only differs from + -- the output in line endings. + let outputLines = Latin1.lines output + stripCR x = case ByteString.unsnoc x of + Just (y, 0x0d) -> y + _ -> x + inputLines = stripCR <$> Latin1.lines input + Monad.when (outputLines /= inputLines) $ Exception.throwM CheckFailure.CheckFailure Mode.Format -> MonadWrite.write (Config.output config) output 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 @@ -81,6 +81,16 @@ w `Hspec.shouldBe` [] s `Hspec.shouldBe` Map.empty + Hspec.it "succeeds when checking CRLF input" $ do + let (a, s, w) = + runTest + (Gild.mainWith "" ["--mode", "check"]) + (Map.singleton Nothing (String.toUtf8 "pass: yes\r\n"), Map.empty) + Map.empty + a `Hspec.shouldBe` Right () + w `Hspec.shouldBe` [] + s `Hspec.shouldBe` Map.empty + Hspec.it "succeeds with empty input" $ do expectGilded ""