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.1.4.0 +version: 1.2.0.0 source-repository head type: git @@ -72,66 +72,67 @@ -- cabal-gild: discover source/library exposed-modules: - CabalGild.Action.AttachComments - CabalGild.Action.EvaluatePragmas - CabalGild.Action.ExtractComments - CabalGild.Action.FormatFields - CabalGild.Action.GetCabalVersion - CabalGild.Action.ReflowText - CabalGild.Action.RemovePositions - CabalGild.Action.Render - CabalGild.Action.StripBlanks - CabalGild.Class.MonadLog - CabalGild.Class.MonadRead - CabalGild.Class.MonadWalk - CabalGild.Class.MonadWrite - CabalGild.Exception.CheckFailure - CabalGild.Exception.InvalidLeniency - CabalGild.Exception.InvalidMode - CabalGild.Exception.InvalidOption - CabalGild.Exception.ParseError - CabalGild.Exception.SpecifiedCrlfWithFormatMode - CabalGild.Exception.SpecifiedOutputWithCheckMode - CabalGild.Exception.SpecifiedStdinWithFileInput - CabalGild.Exception.UnexpectedArgument - CabalGild.Exception.UnknownOption - CabalGild.Extra.ByteString - CabalGild.Extra.Either - CabalGild.Extra.Field - CabalGild.Extra.FieldLine - CabalGild.Extra.List - CabalGild.Extra.ModuleName - CabalGild.Extra.Name - CabalGild.Extra.SectionArg - CabalGild.Extra.String - CabalGild.Main - CabalGild.Type.Block - CabalGild.Type.Chunk - CabalGild.Type.Comment - CabalGild.Type.Config - CabalGild.Type.Context - CabalGild.Type.Dependency - CabalGild.Type.ExeDependency - CabalGild.Type.Extension - CabalGild.Type.Flag - CabalGild.Type.ForeignLibOption - CabalGild.Type.Input - CabalGild.Type.Language - CabalGild.Type.LegacyExeDependency - CabalGild.Type.Leniency - CabalGild.Type.Line - CabalGild.Type.List - CabalGild.Type.Mode - CabalGild.Type.ModuleReexport - CabalGild.Type.Optional - CabalGild.Type.Output - CabalGild.Type.PkgconfigDependency - CabalGild.Type.PkgconfigVersionRange - CabalGild.Type.Pragma - CabalGild.Type.Set - CabalGild.Type.SomeParsecParser - CabalGild.Type.TestedWith - CabalGild.Type.VersionRange + CabalGild + CabalGild.Unstable.Action.AttachComments + CabalGild.Unstable.Action.EvaluatePragmas + CabalGild.Unstable.Action.ExtractComments + CabalGild.Unstable.Action.FormatFields + CabalGild.Unstable.Action.GetCabalVersion + CabalGild.Unstable.Action.ReflowText + CabalGild.Unstable.Action.Render + CabalGild.Unstable.Action.StripBlanks + CabalGild.Unstable.Class.MonadLog + CabalGild.Unstable.Class.MonadRead + CabalGild.Unstable.Class.MonadWalk + CabalGild.Unstable.Class.MonadWrite + CabalGild.Unstable.Exception.CheckFailure + CabalGild.Unstable.Exception.InvalidLeniency + CabalGild.Unstable.Exception.InvalidMode + CabalGild.Unstable.Exception.InvalidOption + CabalGild.Unstable.Exception.ParseError + CabalGild.Unstable.Exception.SpecifiedCrlfWithFormatMode + CabalGild.Unstable.Exception.SpecifiedOutputWithCheckMode + CabalGild.Unstable.Exception.SpecifiedStdinWithFileInput + CabalGild.Unstable.Exception.UnexpectedArgument + CabalGild.Unstable.Exception.UnknownOption + CabalGild.Unstable.Extra.ByteString + CabalGild.Unstable.Extra.Either + CabalGild.Unstable.Extra.Field + CabalGild.Unstable.Extra.FieldLine + CabalGild.Unstable.Extra.List + CabalGild.Unstable.Extra.ModuleName + CabalGild.Unstable.Extra.Name + CabalGild.Unstable.Extra.SectionArg + CabalGild.Unstable.Extra.String + CabalGild.Unstable.Main + CabalGild.Unstable.Type.Block + CabalGild.Unstable.Type.Chunk + CabalGild.Unstable.Type.Comment + CabalGild.Unstable.Type.Config + CabalGild.Unstable.Type.Context + CabalGild.Unstable.Type.Dependency + CabalGild.Unstable.Type.ExeDependency + CabalGild.Unstable.Type.Extension + CabalGild.Unstable.Type.Flag + CabalGild.Unstable.Type.ForeignLibOption + CabalGild.Unstable.Type.Input + CabalGild.Unstable.Type.Language + CabalGild.Unstable.Type.LegacyExeDependency + CabalGild.Unstable.Type.Leniency + CabalGild.Unstable.Type.Line + CabalGild.Unstable.Type.List + CabalGild.Unstable.Type.Mixin + CabalGild.Unstable.Type.Mode + CabalGild.Unstable.Type.ModuleReexport + CabalGild.Unstable.Type.Optional + CabalGild.Unstable.Type.Output + CabalGild.Unstable.Type.PkgconfigDependency + CabalGild.Unstable.Type.PkgconfigVersionRange + CabalGild.Unstable.Type.Pragma + CabalGild.Unstable.Type.Set + CabalGild.Unstable.Type.SomeParsecParser + CabalGild.Unstable.Type.TestedWith + CabalGild.Unstable.Type.VersionRange hs-source-dirs: source/library other-modules: Paths_cabal_gild diff --git a/source/executable/Main.hs b/source/executable/Main.hs --- a/source/executable/Main.hs +++ b/source/executable/Main.hs @@ -1,4 +1,4 @@ -import qualified CabalGild.Main +import qualified CabalGild main :: IO () -main = CabalGild.Main.defaultMain +main = CabalGild.defaultMain diff --git a/source/library/CabalGild.hs b/source/library/CabalGild.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild.hs @@ -0,0 +1,8 @@ +module CabalGild + ( CabalGild.Unstable.Main.defaultMain, + CabalGild.Unstable.Main.mainWith, + CabalGild.Unstable.Main.format, + ) +where + +import qualified CabalGild.Unstable.Main diff --git a/source/library/CabalGild/Action/AttachComments.hs b/source/library/CabalGild/Action/AttachComments.hs deleted file mode 100644 --- a/source/library/CabalGild/Action/AttachComments.hs +++ /dev/null @@ -1,89 +0,0 @@ -module CabalGild.Action.AttachComments where - -import qualified CabalGild.Type.Comment as Comment -import qualified Control.Monad.Trans.State as StateT -import qualified Distribution.Fields as Fields - --- | High level wrapper around 'field' that makes this action easier to compose --- with other actions. -run :: - (Applicative m, Ord p) => - ([Fields.Field p], [Comment.Comment p]) -> - m ([Fields.Field (p, [Comment.Comment p])], [Comment.Comment p]) -run (fs, cs) = pure $ StateT.runState (traverse field fs) cs - --- | Attaches comments to a single field. It is assumed that both the fields --- and comments are already sorted by their position @p@. This precondition is --- not checked. Note that comments actually end up attached to the field's --- name. That's because the 'Field.Field' type doesn't have any annotations --- directly on it. -field :: - (Ord p) => - Fields.Field p -> - StateT.State [Comment.Comment p] (Fields.Field (p, [Comment.Comment p])) -field f = case f of - Fields.Field n fls -> - Fields.Field - <$> name n - <*> traverse fieldLine fls - Fields.Section n sas fs -> - Fields.Section - <$> name n - <*> traverse sectionArg sas - <*> traverse field fs - --- | Attaches comments to a name. Note that this could be a field name or a --- section name. -name :: - (Ord p) => - Fields.Name p -> - StateT.State [Comment.Comment p] (Fields.Name (p, [Comment.Comment p])) -name (Fields.Name p fn) = - Fields.Name - <$> toPosition p - <*> pure fn - --- | Attach comments to a field line. -fieldLine :: - (Ord p) => - Fields.FieldLine p -> - StateT.State [Comment.Comment p] (Fields.FieldLine (p, [Comment.Comment p])) -fieldLine (Fields.FieldLine p bs) = - Fields.FieldLine - <$> toPosition p - <*> pure bs - --- | Attaches comments to a section argument. Note that section arguments --- cannot actually have comments attached. That's because section arguments --- must be on -- the same line as the section name, so all comments will end up --- attached to the name. -sectionArg :: - (Ord p) => - Fields.SectionArg p -> - StateT.State [Comment.Comment p] (Fields.SectionArg (p, [Comment.Comment p])) -sectionArg sa = case sa of - Fields.SecArgName p bs -> - Fields.SecArgName - <$> toPosition p - <*> pure bs - Fields.SecArgStr p bs -> - Fields.SecArgStr - <$> toPosition p - <*> pure bs - Fields.SecArgOther p bs -> - Fields.SecArgOther - <$> toPosition p - <*> pure bs - --- | Attaches comments to a position. This is the workhorse of the module. --- Comments are attached when their position is less than or equal to the given --- position. The comments are removed from the state as they are attached. -toPosition :: - (Ord p) => - p -> - StateT.State [Comment.Comment p] (p, [Comment.Comment p]) -toPosition p = do - cs <- StateT.get - let (xs, ys) = span ((<= p) . Comment.annotation) cs - StateT.put ys - pure (p, xs) diff --git a/source/library/CabalGild/Action/EvaluatePragmas.hs b/source/library/CabalGild/Action/EvaluatePragmas.hs deleted file mode 100644 --- a/source/library/CabalGild/Action/EvaluatePragmas.hs +++ /dev/null @@ -1,120 +0,0 @@ -module CabalGild.Action.EvaluatePragmas where - -import qualified CabalGild.Class.MonadWalk as MonadWalk -import qualified CabalGild.Extra.FieldLine as FieldLine -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.List.NonEmpty as NonEmpty -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.FilePath as FilePath - --- | High level wrapper around 'field' 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) = (,) <$> 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. --- --- 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 fls -> fmap (Maybe.fromMaybe f) . MaybeT.runMaybeT $ do - Monad.guard $ Set.member (Name.value n) relevantFieldNames - comment <- hoistMaybe . Utils.safeLast $ Name.annotation n - pragma <- hoistMaybe . Parsec.simpleParsecBS $ Comment.value comment - case pragma of - Pragma.Discover ds -> do - let root = FilePath.takeDirectory p - directories = - FilePath.dropTrailingPathSeparator - . FilePath.normalise - . FilePath.combine root - <$> NonEmpty.toList ds - files <- Trans.lift . fmap mconcat $ traverse MonadWalk.walk directories - let comments = concatMap FieldLine.annotation fls - fieldLines = - zipWith ModuleName.toFieldLine (comments : repeat []) - . Maybe.mapMaybe (toModuleName directories) - $ Maybe.mapMaybe (stripAnyExtension extensions) files - -- This isn't great, but the comments have to go /somewhere/. - name = - if null fieldLines - then Lens.over Name.annotationLens (comments <>) n - else n - pure $ Fields.Field name fieldLines - Fields.Section n sas fs -> Fields.Section n sas <$> traverse (field p) fs - --- | These are the names of the fields that can have this action applied to --- them. -relevantFieldNames :: Set.Set Fields.FieldName -relevantFieldNames = - Set.fromList $ - fmap - String.toUtf8 - [ "exposed-modules", - "other-modules", - "signatures" - ] - --- | Attempts to strip any of the given extensions from the file path. If any --- of them succeed, the result is returned. Otherwise 'Nothing' is returned. -stripAnyExtension :: Set.Set String -> FilePath -> Maybe String -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. --- --- -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 --- . -hoistMaybe :: (Applicative f) => Maybe a -> MaybeT.MaybeT f a -hoistMaybe = MaybeT.MaybeT . pure diff --git a/source/library/CabalGild/Action/ExtractComments.hs b/source/library/CabalGild/Action/ExtractComments.hs deleted file mode 100644 --- a/source/library/CabalGild/Action/ExtractComments.hs +++ /dev/null @@ -1,49 +0,0 @@ -module CabalGild.Action.ExtractComments where - -import qualified CabalGild.Type.Comment as Comment -import qualified Control.Applicative as Applicative -import qualified Control.Monad as Monad -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Char8 as Latin1 -import qualified Data.ByteString.Internal as ByteStringInternal -import qualified Data.Maybe as Maybe -import qualified Data.Word as Word -import qualified Distribution.Parsec.Position as Position - --- | Extracts comments from the given byte string. This is a wrapper around --- 'fromLine', where lines are split using 'Latin1.lines'. -fromByteString :: ByteString.ByteString -> [Comment.Comment Position.Position] -fromByteString = - Maybe.mapMaybe (uncurry fromLine) - . zip [1 ..] - . Latin1.lines - --- | Extracts a comment from the given line. If the line does not contain a --- comment, the result will be 'Alternative.empty'. -fromLine :: - (Applicative.Alternative m, Monad m) => - Int -> - ByteString.ByteString -> - m (Comment.Comment Position.Position) -fromLine row line = do - let (before, after) = breakComment line - rest <- - maybe Applicative.empty pure $ - ByteString.stripPrefix Comment.delimiter after - Monad.guard $ ByteString.all isBlank before - pure - Comment.Comment - { Comment.annotation = Position.Position row $ 1 + ByteString.length before, - Comment.value = ByteString.dropWhileEnd isBlank rest - } - --- | Breaks a byte string into two parts: the part before the comment delimiter --- and the part after. If there is no comment, the part after will be empty. -breakComment :: ByteString.ByteString -> (ByteString.ByteString, ByteString.ByteString) -breakComment = ByteString.breakSubstring Comment.delimiter - --- | Returns true if the given byte is a blank character. Currently this is a --- wrapper around 'ByteStringInternal.isSpaceWord8'. Perhaps it should only --- check for spaces and tabs though. -isBlank :: Word.Word8 -> Bool -isBlank = ByteStringInternal.isSpaceWord8 diff --git a/source/library/CabalGild/Action/FormatFields.hs b/source/library/CabalGild/Action/FormatFields.hs deleted file mode 100644 --- a/source/library/CabalGild/Action/FormatFields.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE TypeApplications #-} - -module CabalGild.Action.FormatFields where - -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.Dependency as Dependency -import qualified CabalGild.Type.ExeDependency as ExeDependency -import qualified CabalGild.Type.Extension as Extension -import qualified CabalGild.Type.ForeignLibOption as ForeignLibOption -import qualified CabalGild.Type.Language as Language -import qualified CabalGild.Type.LegacyExeDependency as LegacyExeDependency -import qualified CabalGild.Type.ModuleReexport as ModuleReexport -import qualified CabalGild.Type.PkgconfigDependency as PkgconfigDependency -import qualified CabalGild.Type.SomeParsecParser as SPP -import qualified CabalGild.Type.TestedWith as TestedWith -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.Mixin as Mixin -import qualified Text.PrettyPrint as PrettyPrint - --- | A wrapper around 'field' 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 (fmap (field csv) fs, cs) - --- | 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 $ fmap (field 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 Language.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 @(Identity.Identity TestedWith.TestedWith), - "virtual-modules" =: SPP.set @Newtypes.VCat @(Newtypes.MQuoted ModuleName.ModuleName) - ] diff --git a/source/library/CabalGild/Action/GetCabalVersion.hs b/source/library/CabalGild/Action/GetCabalVersion.hs deleted file mode 100644 --- a/source/library/CabalGild/Action/GetCabalVersion.hs +++ /dev/null @@ -1,40 +0,0 @@ -module CabalGild.Action.GetCabalVersion where - -import qualified CabalGild.Extra.Either as Either -import qualified CabalGild.Extra.FieldLine as FieldLine -import qualified CabalGild.Extra.Name as Name -import qualified CabalGild.Extra.String as String -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import qualified Distribution.CabalSpecVersion as CabalSpecVersion -import qualified Distribution.FieldGrammar.Newtypes as Newtypes -import qualified Distribution.Fields as Fields -import qualified Distribution.Parsec as Parsec - --- | Gets the Cabal spec version from a list of fields. If multiple fields --- define the version, the first one is used. -fromFields :: [Fields.Field a] -> CabalSpecVersion.CabalSpecVersion -fromFields fs = Maybe.fromMaybe CabalSpecVersion.CabalSpecV1_0 $ do - f <- List.find isCabalVersion fs - fls <- getFieldLines f - Newtypes.getSpecVersion <$> fromFieldLines fls - --- | Returns true if the field is named @cabal-version@. -isCabalVersion :: Fields.Field a -> Bool -isCabalVersion f = case f of - Fields.Field n _ -> Name.value n == String.toUtf8 "cabal-version" - Fields.Section {} -> False - --- | Gets the field lines from a field. If the field is a section, this returns --- 'Nothing'. -getFieldLines :: Fields.Field a -> Maybe [Fields.FieldLine a] -getFieldLines f = case f of - Fields.Field _ fls -> Just fls - Fields.Section {} -> Nothing - --- | Attempts to parse the given field lines as a Cabal spec version. -fromFieldLines :: [Fields.FieldLine a] -> Maybe Newtypes.SpecVersion -fromFieldLines = - Either.hush - . Parsec.runParsecParser Parsec.parsec "" - . FieldLine.toFieldLineStream diff --git a/source/library/CabalGild/Action/ReflowText.hs b/source/library/CabalGild/Action/ReflowText.hs deleted file mode 100644 --- a/source/library/CabalGild/Action/ReflowText.hs +++ /dev/null @@ -1,129 +0,0 @@ -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/RemovePositions.hs b/source/library/CabalGild/Action/RemovePositions.hs deleted file mode 100644 --- a/source/library/CabalGild/Action/RemovePositions.hs +++ /dev/null @@ -1,64 +0,0 @@ -module CabalGild.Action.RemovePositions where - -import qualified CabalGild.Type.Comment as Comment -import qualified Distribution.Fields as Fields - --- | A wrapper around 'field' to allow this to be composed with other actions. -run :: - (Applicative m) => - ([Fields.Field (p, [Comment.Comment p])], [Comment.Comment p]) -> - m ([Fields.Field [Comment.Comment ()]], [Comment.Comment ()]) -run (fs, cs) = pure (fmap field fs, comments cs) - --- | Removes the positions from a field and its comments. -field :: - Fields.Field (p, [Comment.Comment p]) -> - Fields.Field [Comment.Comment ()] -field f = case f of - Fields.Field n fls -> Fields.Field (name n) $ fieldLines fls - Fields.Section n sas fs -> Fields.Section (name n) (sectionArgs sas) $ fmap field fs - --- | Removes the positions from a name and its comments. -name :: - Fields.Name (p, [Comment.Comment p]) -> - Fields.Name [Comment.Comment ()] -name (Fields.Name (_, cs) x) = Fields.Name (comments cs) x - --- | Removes the positions from field lines and their comments. -fieldLines :: - [Fields.FieldLine (p, [Comment.Comment p])] -> - [Fields.FieldLine [Comment.Comment ()]] -fieldLines = fmap fieldLine - --- | Removes the positions from a field line and its comments. -fieldLine :: - Fields.FieldLine (p, [Comment.Comment p]) -> - Fields.FieldLine [Comment.Comment ()] -fieldLine (Fields.FieldLine (_, cs) x) = Fields.FieldLine (comments cs) x - --- | Removes the positions from some section arguments and their comments. -sectionArgs :: - [Fields.SectionArg (p, [Comment.Comment p])] -> - [Fields.SectionArg [Comment.Comment ()]] -sectionArgs = fmap sectionArg - --- | Removes the positions from a section argument and its comments. -sectionArg :: - Fields.SectionArg (p, [Comment.Comment p]) -> - Fields.SectionArg [Comment.Comment ()] -sectionArg sa = case sa of - Fields.SecArgName (_, cs) x -> Fields.SecArgName (comments cs) x - Fields.SecArgStr (_, cs) x -> Fields.SecArgStr (comments cs) x - Fields.SecArgOther (_, cs) x -> Fields.SecArgOther (comments cs) x - --- | Removes the positions from some comments. -comments :: - [Comment.Comment p] -> - [Comment.Comment ()] -comments = fmap comment - --- | Removes the position from a comment. -comment :: - Comment.Comment p -> - Comment.Comment () -comment c = c {Comment.annotation = ()} diff --git a/source/library/CabalGild/Action/Render.hs b/source/library/CabalGild/Action/Render.hs deleted file mode 100644 --- a/source/library/CabalGild/Action/Render.hs +++ /dev/null @@ -1,134 +0,0 @@ -module CabalGild.Action.Render where - -import qualified CabalGild.Extra.FieldLine as FieldLine -import qualified CabalGild.Extra.Name as Name -import qualified CabalGild.Extra.SectionArg as SectionArg -import qualified CabalGild.Type.Block as Block -import qualified CabalGild.Type.Chunk as Chunk -import qualified CabalGild.Type.Comment as Comment -import qualified CabalGild.Type.Line as Line -import qualified Data.ByteString as ByteString -import qualified Distribution.Compat.Lens as Lens -import qualified Distribution.Fields as Fields - --- | A wrapper around 'toByteString' to allow this to be composed with other --- actions. -run :: - (Applicative m) => - ([Fields.Field [Comment.Comment a]], [Comment.Comment a]) -> - m ByteString.ByteString -run = pure . uncurry toByteString - --- | Renders the given fields and comments to a byte string. -toByteString :: - [Fields.Field [Comment.Comment a]] -> - [Comment.Comment a] -> - ByteString.ByteString -toByteString fs cs = - let i = 0 :: Int - in Block.toByteString - . Lens.set Block.lineBeforeLens False - . Lens.set Block.lineAfterLens True - $ fields i fs <> comments i cs - --- | Renders the given fields to a block at the given indentation level. -fields :: Int -> [Fields.Field [Comment.Comment a]] -> Block.Block -fields = foldMap . field - --- | Renders the given field to a block at the given indentation level. --- --- If a field only has one line and no comments, then it can be rendered all on --- one line. -field :: Int -> Fields.Field [Comment.Comment a] -> Block.Block -field i f = case f of - Fields.Field n fls -> case fls of - [fl] - | null $ FieldLine.annotation fl -> - comments i (Name.annotation n) - <> ( Block.fromLine - . Lens.over Line.chunkLens (mappend $ name n <> Chunk.colon) - $ fieldLine i fl - ) - _ -> - Lens.set Block.lineAfterLens True $ - comments i (Name.annotation n) - <> Block.fromLine - Line.Line - { Line.indent = i, - Line.chunk = name n <> Chunk.colon - } - <> fieldLines (i + 1) fls - Fields.Section n sas fs -> - Lens.set Block.lineBeforeLens (not $ Name.isElif n || Name.isElse n) - . Lens.set Block.lineAfterLens (not $ Name.isIf n || Name.isElif n) - $ comments i (Name.annotation n) - <> comments i (concatMap SectionArg.annotation sas) - <> Block.fromLine - Line.Line - { Line.indent = i, - Line.chunk = Lens.set Chunk.spaceAfterLens True (name n) <> sectionArgs sas - } - <> Lens.set Block.lineBeforeLens False (fields (i + 1) fs) - --- | Renders the given name to a chunk. -name :: Fields.Name a -> Chunk.Chunk -name = Chunk.fromByteString . Name.value - --- | Renders the given field lines to a block at the given indentation level. -fieldLines :: Int -> [Fields.FieldLine [Comment.Comment a]] -> Block.Block -fieldLines = foldMap . fieldLineC - --- | Renders the given field line and its comments to a block at the given --- indentation level. -fieldLineC :: Int -> Fields.FieldLine [Comment.Comment a] -> Block.Block -fieldLineC i fl = - comments i (FieldLine.annotation fl) - <> Block.fromLine (fieldLine i fl) - --- | Renders the given field line to a line at the given indentation level. -fieldLine :: Int -> Fields.FieldLine a -> Line.Line -fieldLine i = - Line.Line i - . Lens.set Chunk.spaceBeforeLens True - . Chunk.fromByteString - . FieldLine.value - --- | Renders the given section arguments to a chunk. Note that comments are --- ignored. In practice this isn't a problem because section arguments can't --- have comments attached anyway. -sectionArgs :: [Fields.SectionArg a] -> Chunk.Chunk -sectionArgs = Lens.set Chunk.spaceBeforeLens True . foldMap sectionArg - --- | Renders the given section argument to a chunk. -sectionArg :: Fields.SectionArg a -> Chunk.Chunk -sectionArg sa = case sa of - Fields.SecArgName _ bs -> - Lens.set Chunk.spaceBeforeLens True - . Lens.set Chunk.spaceAfterLens True - $ Chunk.fromByteString bs - Fields.SecArgStr _ bs -> - Lens.set Chunk.spaceBeforeLens True - . Lens.set Chunk.spaceAfterLens True - . Chunk.fromByteString - . flip ByteString.snoc 0x22 - $ ByteString.cons 0x22 bs - Fields.SecArgOther _ bs -> - let b = - bs /= ByteString.singleton 0x21 -- ! - && bs /= ByteString.singleton 0x28 -- ( - && bs /= ByteString.singleton 0x29 -- ) - in Lens.set Chunk.spaceBeforeLens b - . Lens.set Chunk.spaceAfterLens b - $ Chunk.fromByteString bs - --- | Renders the given comments to a block at the given indentation level. -comments :: Int -> [Comment.Comment a] -> Block.Block -comments i cs = mempty {Block.lines = fmap (comment i) cs} - --- | Renders the given comment to a line at the given indentation level. -comment :: Int -> Comment.Comment a -> Line.Line -comment i = - Line.Line i - . Chunk.fromByteString - . mappend Comment.delimiter - . Comment.value diff --git a/source/library/CabalGild/Action/StripBlanks.hs b/source/library/CabalGild/Action/StripBlanks.hs deleted file mode 100644 --- a/source/library/CabalGild/Action/StripBlanks.hs +++ /dev/null @@ -1,41 +0,0 @@ -module CabalGild.Action.StripBlanks where - -import qualified Data.ByteString.Char8 as Latin1 -import qualified Distribution.Fields as Fields - --- | High level wrapper around 'field' that makes this action easier to compose --- with other actions. -run :: - (Applicative m) => - ([Fields.Field a], cs) -> - m ([Fields.Field a], cs) -run (fs, cs) = pure (fmap field fs, cs) - --- | Strips blank space from the field recursively. In practice there should --- not be any leading or trailing blank space to begin with. However the legacy --- curly bracket syntax can introduce trailing blank space. For example with --- @s { f : x }@ the field value will have a trailing space (@"x "@). -field :: Fields.Field a -> Fields.Field a -field f = case f of - Fields.Field n fls -> - Fields.Field (name n) (fmap fieldLine fls) - Fields.Section n sas fs -> - Fields.Section (name n) (fmap sectionArg sas) (fmap field fs) - --- | Strips blank space from the field's name. -name :: Fields.Name a -> Fields.Name a -name (Fields.Name a bs) = Fields.Name a (Latin1.strip bs) - --- | Strips blank space from the field line. -fieldLine :: Fields.FieldLine a -> Fields.FieldLine a -fieldLine (Fields.FieldLine a bs) = Fields.FieldLine a (Latin1.strip bs) - --- | Strips blank space from the section argument. -sectionArg :: Fields.SectionArg a -> Fields.SectionArg a -sectionArg sa = case sa of - Fields.SecArgName a bs -> - Fields.SecArgName a (Latin1.strip bs) - Fields.SecArgStr a bs -> - Fields.SecArgStr a (Latin1.strip bs) - Fields.SecArgOther a bs -> - Fields.SecArgOther a (Latin1.strip bs) diff --git a/source/library/CabalGild/Class/MonadLog.hs b/source/library/CabalGild/Class/MonadLog.hs deleted file mode 100644 --- a/source/library/CabalGild/Class/MonadLog.hs +++ /dev/null @@ -1,10 +0,0 @@ -module CabalGild.Class.MonadLog where - --- | A 'Monad' that can also log messages. -class (Monad m) => MonadLog m where - -- | Logs the given message followed by a newline. - logLn :: String -> m () - --- | Uses 'putStrLn'. -instance MonadLog IO where - logLn = putStrLn diff --git a/source/library/CabalGild/Class/MonadRead.hs b/source/library/CabalGild/Class/MonadRead.hs deleted file mode 100644 --- a/source/library/CabalGild/Class/MonadRead.hs +++ /dev/null @@ -1,16 +0,0 @@ -module CabalGild.Class.MonadRead where - -import qualified CabalGild.Type.Input as Input -import qualified Data.ByteString as ByteString - --- | A 'Monad' that can also read input, either from standard input (STDIN) or --- from a file. -class (Monad m) => MonadRead m where - -- | Reads input from the given 'Input.Input'. - read :: Input.Input -> m ByteString.ByteString - --- | Uses 'ByteString.getContents' or 'ByteString.readFile'. -instance MonadRead IO where - read i = case i of - Input.Stdin -> ByteString.getContents - Input.File f -> ByteString.readFile f diff --git a/source/library/CabalGild/Class/MonadWalk.hs b/source/library/CabalGild/Class/MonadWalk.hs deleted file mode 100644 --- a/source/library/CabalGild/Class/MonadWalk.hs +++ /dev/null @@ -1,28 +0,0 @@ -module CabalGild.Class.MonadWalk where - -import qualified System.Directory as Directory -import qualified System.FilePath as FilePath - --- | A 'Monad' that can also walk the file system. -class (Monad m) => MonadWalk m where - -- | Lists all files in the given directory and its subdirectories - -- recursively. - walk :: FilePath -> m [FilePath] - --- | Uses 'listDirectoryRecursively'. -instance MonadWalk IO where - walk = listDirectoryRecursively - --- | Lists all files in the given directory and its subdirectories recursively. --- The order is not guaranteed and may change between different calls. It's --- also not specified if the results are breadth-first or depth-first. -listDirectoryRecursively :: FilePath -> IO [FilePath] -listDirectoryRecursively d = do - es <- Directory.listDirectory d - let f e = do - let p = FilePath.combine d e - b <- Directory.doesDirectoryExist p - if b - then listDirectoryRecursively p - else pure [p] - mconcat <$> traverse f es diff --git a/source/library/CabalGild/Class/MonadWrite.hs b/source/library/CabalGild/Class/MonadWrite.hs deleted file mode 100644 --- a/source/library/CabalGild/Class/MonadWrite.hs +++ /dev/null @@ -1,16 +0,0 @@ -module CabalGild.Class.MonadWrite where - -import qualified CabalGild.Type.Output as Output -import qualified Data.ByteString as ByteString - --- | A 'Monad' that can also write output, either to standard output (STDOUT) --- or to a file. -class (Monad m) => MonadWrite m where - -- | Writes output to the given 'Output.Output'. - write :: Output.Output -> ByteString.ByteString -> m () - --- | Uses 'ByteString.putStr' or 'ByteString.writeFile'. -instance MonadWrite IO where - write o = case o of - Output.Stdout -> ByteString.putStr - Output.File f -> ByteString.writeFile f diff --git a/source/library/CabalGild/Exception/CheckFailure.hs b/source/library/CabalGild/Exception/CheckFailure.hs deleted file mode 100644 --- a/source/library/CabalGild/Exception/CheckFailure.hs +++ /dev/null @@ -1,11 +0,0 @@ -module CabalGild.Exception.CheckFailure where - -import qualified Control.Monad.Catch as Exception - --- | This exception is thrown when the input is not formatted correctly. -data CheckFailure - = CheckFailure - deriving (Eq, Show) - -instance Exception.Exception CheckFailure where - displayException = const "input is not formatted" diff --git a/source/library/CabalGild/Exception/InvalidLeniency.hs b/source/library/CabalGild/Exception/InvalidLeniency.hs deleted file mode 100644 --- a/source/library/CabalGild/Exception/InvalidLeniency.hs +++ /dev/null @@ -1,16 +0,0 @@ -module CabalGild.Exception.InvalidLeniency where - -import qualified Control.Monad.Catch as Exception - --- | This exception is thrown when the given --- 'CabalGild.Type.Leniency.Leniency' is invalid. -newtype InvalidLeniency - = InvalidLeniency String - deriving (Eq, Show) - -instance Exception.Exception InvalidLeniency where - displayException (InvalidLeniency s) = "invalid leniency: " <> s - --- | Constructs an 'InvalidLeniency' from the given 'String'. -fromString :: String -> InvalidLeniency -fromString = InvalidLeniency diff --git a/source/library/CabalGild/Exception/InvalidMode.hs b/source/library/CabalGild/Exception/InvalidMode.hs deleted file mode 100644 --- a/source/library/CabalGild/Exception/InvalidMode.hs +++ /dev/null @@ -1,16 +0,0 @@ -module CabalGild.Exception.InvalidMode where - -import qualified Control.Monad.Catch as Exception - --- | This exception is thrown when the given 'CabalGild.Type.Mode.Mode' is --- invalid. -newtype InvalidMode - = InvalidMode String - deriving (Eq, Show) - -instance Exception.Exception InvalidMode where - displayException (InvalidMode s) = "invalid mode: " <> s - --- | Constructs an 'InvalidMode' from the given 'String'. -fromString :: String -> InvalidMode -fromString = InvalidMode diff --git a/source/library/CabalGild/Exception/InvalidOption.hs b/source/library/CabalGild/Exception/InvalidOption.hs deleted file mode 100644 --- a/source/library/CabalGild/Exception/InvalidOption.hs +++ /dev/null @@ -1,17 +0,0 @@ -module CabalGild.Exception.InvalidOption where - -import qualified Control.Monad.Catch as Exception -import qualified Data.Char as Char -import qualified Data.List as List - --- | This exception is thrown when a command line option is invalid. -newtype InvalidOption - = InvalidOption String - deriving (Eq, Show) - -instance Exception.Exception InvalidOption where - displayException (InvalidOption s) = "invalid option: " <> s - --- | Constructs an 'InvalidOption' from the given 'String'. -fromString :: String -> InvalidOption -fromString = InvalidOption . List.dropWhileEnd Char.isSpace diff --git a/source/library/CabalGild/Exception/ParseError.hs b/source/library/CabalGild/Exception/ParseError.hs deleted file mode 100644 --- a/source/library/CabalGild/Exception/ParseError.hs +++ /dev/null @@ -1,15 +0,0 @@ -module CabalGild.Exception.ParseError where - -import qualified Control.Monad.Catch as Exception -import qualified Text.Parsec.Error as Parsec - --- | This type only exists to add an 'Exception.Exception' instance to the --- 'Parsec.ParseError' type. That instance was added in @parsec-3.1.17.0@. See: --- . -newtype ParseError = ParseError - { unwrap :: Parsec.ParseError - } - deriving (Eq, Show) - -instance Exception.Exception ParseError where - displayException = mappend "parse error: " . show . unwrap diff --git a/source/library/CabalGild/Exception/SpecifiedCrlfWithFormatMode.hs b/source/library/CabalGild/Exception/SpecifiedCrlfWithFormatMode.hs deleted file mode 100644 --- a/source/library/CabalGild/Exception/SpecifiedCrlfWithFormatMode.hs +++ /dev/null @@ -1,13 +0,0 @@ -module CabalGild.Exception.SpecifiedCrlfWithFormatMode where - -import qualified Control.Monad.Catch as Exception - --- | This exception is thrown when the user specifies the CRLF leniency while --- using the format mode. In other words, when @--mode=format@ and --- @--crlf=anything@. -data SpecifiedCrlfWithFormatMode - = SpecifiedCrlfWithFormatMode - deriving (Eq, Show) - -instance Exception.Exception SpecifiedCrlfWithFormatMode where - displayException = const "cannot use --crlf when --mode is format" diff --git a/source/library/CabalGild/Exception/SpecifiedOutputWithCheckMode.hs b/source/library/CabalGild/Exception/SpecifiedOutputWithCheckMode.hs deleted file mode 100644 --- a/source/library/CabalGild/Exception/SpecifiedOutputWithCheckMode.hs +++ /dev/null @@ -1,12 +0,0 @@ -module CabalGild.Exception.SpecifiedOutputWithCheckMode where - -import qualified Control.Monad.Catch as Exception - --- | This exception is thrown when the user specifies the output while using --- the check mode. In other words, when @--mode=check@ and @--output=anything@. -data SpecifiedOutputWithCheckMode - = SpecifiedOutputWithCheckMode - deriving (Eq, Show) - -instance Exception.Exception SpecifiedOutputWithCheckMode where - displayException = const "cannot use --output when --mode is check" diff --git a/source/library/CabalGild/Exception/SpecifiedStdinWithFileInput.hs b/source/library/CabalGild/Exception/SpecifiedStdinWithFileInput.hs deleted file mode 100644 --- a/source/library/CabalGild/Exception/SpecifiedStdinWithFileInput.hs +++ /dev/null @@ -1,13 +0,0 @@ -module CabalGild.Exception.SpecifiedStdinWithFileInput where - -import qualified Control.Monad.Catch as Exception - --- | This exception is thrown when the user specifies the STDIN name while --- using an input file. In other words, when @--input=file@ and --- @--stdin=anything@. -data SpecifiedStdinWithFileInput - = SpecifiedStdinWithFileInput - deriving (Eq, Show) - -instance Exception.Exception SpecifiedStdinWithFileInput where - displayException = const "cannot use --stdin when --input is a file" diff --git a/source/library/CabalGild/Exception/UnexpectedArgument.hs b/source/library/CabalGild/Exception/UnexpectedArgument.hs deleted file mode 100644 --- a/source/library/CabalGild/Exception/UnexpectedArgument.hs +++ /dev/null @@ -1,16 +0,0 @@ -module CabalGild.Exception.UnexpectedArgument where - -import qualified Control.Monad.Catch as Exception - --- | This exception is thrown when an unexpected command line argument is --- encountered. -newtype UnexpectedArgument - = UnexpectedArgument String - deriving (Eq, Show) - -instance Exception.Exception UnexpectedArgument where - displayException (UnexpectedArgument s) = "unexpected argument: " <> s - --- | Constructs an 'UnexpectedArgument' from the given 'String'. -fromString :: String -> UnexpectedArgument -fromString = UnexpectedArgument diff --git a/source/library/CabalGild/Exception/UnknownOption.hs b/source/library/CabalGild/Exception/UnknownOption.hs deleted file mode 100644 --- a/source/library/CabalGild/Exception/UnknownOption.hs +++ /dev/null @@ -1,15 +0,0 @@ -module CabalGild.Exception.UnknownOption where - -import qualified Control.Monad.Catch as Exception - --- | This exception is thrown when a command line option is not known. -newtype UnknownOption - = UnknownOption String - deriving (Eq, Show) - -instance Exception.Exception UnknownOption where - displayException (UnknownOption s) = "unknown option: " <> s - --- | Constructs an 'UnknownOption' from the given 'String'. -fromString :: String -> UnknownOption -fromString = UnknownOption diff --git a/source/library/CabalGild/Extra/ByteString.hs b/source/library/CabalGild/Extra/ByteString.hs deleted file mode 100644 --- a/source/library/CabalGild/Extra/ByteString.hs +++ /dev/null @@ -1,32 +0,0 @@ -module CabalGild.Extra.ByteString where - -import qualified Data.ByteString as ByteString - --- | Calling @replace needle replacement haystack@ will replace every --- non-overlapping occurrence of @needle@ in @haystack@ with @replacement@. --- --- -replace :: - ByteString.ByteString -> - ByteString.ByteString -> - ByteString.ByteString -> - ByteString.ByteString -replace needle replacement = ByteString.intercalate replacement . splitOn needle - --- | Calling @splitOn needle haystack@ will split @haystack@ into a list of --- substrings using @needle@ as the delimiter. --- --- -splitOn :: - ByteString.ByteString -> - ByteString.ByteString -> - [ByteString.ByteString] -splitOn needle = - let split = ByteString.breakSubstring needle - go haystack = - let (before, after) = split haystack - in before - : if ByteString.null after - then [] - else go (ByteString.drop (ByteString.length needle) after) - in go diff --git a/source/library/CabalGild/Extra/Either.hs b/source/library/CabalGild/Extra/Either.hs deleted file mode 100644 --- a/source/library/CabalGild/Extra/Either.hs +++ /dev/null @@ -1,5 +0,0 @@ -module CabalGild.Extra.Either where - --- | Converts an 'Either' to a 'Maybe'. -hush :: Either x a -> Maybe a -hush = either (const Nothing) Just diff --git a/source/library/CabalGild/Extra/Field.hs b/source/library/CabalGild/Extra/Field.hs deleted file mode 100644 --- a/source/library/CabalGild/Extra/Field.hs +++ /dev/null @@ -1,9 +0,0 @@ -module CabalGild.Extra.Field where - -import qualified Distribution.Fields as Fields - --- | Extracts the name of a 'Fields.Field'. -name :: Fields.Field a -> Fields.Name a -name f = case f of - Fields.Field n _ -> n - Fields.Section n _ _ -> n diff --git a/source/library/CabalGild/Extra/FieldLine.hs b/source/library/CabalGild/Extra/FieldLine.hs deleted file mode 100644 --- a/source/library/CabalGild/Extra/FieldLine.hs +++ /dev/null @@ -1,21 +0,0 @@ -module CabalGild.Extra.FieldLine where - -import qualified Data.ByteString as ByteString -import qualified Distribution.Fields as Fields -import qualified Distribution.Parsec.FieldLineStream as FieldLineStream - --- | Extracts the annotation of a 'Fields.FieldLine'. -annotation :: Fields.FieldLine a -> a -annotation (Fields.FieldLine x _) = x - --- | Extracts the value of a 'Fields.FieldLine'. -value :: Fields.FieldLine a -> ByteString.ByteString -value (Fields.FieldLine _ x) = x - --- | Converts a list of 'Fields.FieldLine's into a --- 'FieldLineStream.FieldLineStream'. -toFieldLineStream :: [Fields.FieldLine a] -> FieldLineStream.FieldLineStream -toFieldLineStream fls = case fls of - [] -> FieldLineStream.FLSLast ByteString.empty - [x] -> FieldLineStream.FLSLast $ value x - x : xs -> FieldLineStream.FLSCons (value x) $ toFieldLineStream xs diff --git a/source/library/CabalGild/Extra/List.hs b/source/library/CabalGild/Extra/List.hs deleted file mode 100644 --- a/source/library/CabalGild/Extra/List.hs +++ /dev/null @@ -1,12 +0,0 @@ -module CabalGild.Extra.List where - --- | Compares the length of the given list to the given integer. This is --- equivalent to @compare (length xs) n@, but it can be more efficient if @n@ --- is less than @length xs@. -compareLength :: [a] -> Int -> Ordering -compareLength xs n = - if n < 0 - then GT - else case xs of - [] -> compare 0 n - _ : ys -> compareLength ys $ n - 1 diff --git a/source/library/CabalGild/Extra/ModuleName.hs b/source/library/CabalGild/Extra/ModuleName.hs deleted file mode 100644 --- a/source/library/CabalGild/Extra/ModuleName.hs +++ /dev/null @@ -1,17 +0,0 @@ -module CabalGild.Extra.ModuleName where - -import qualified CabalGild.Extra.String as String -import qualified Data.List as List -import qualified Distribution.Fields as Fields -import qualified Distribution.ModuleName as ModuleName -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified System.FilePath as FilePath - --- | Parses a 'FilePath' as a 'ModuleName.ModuleName'. -fromFilePath :: FilePath -> Maybe ModuleName.ModuleName -fromFilePath = Parsec.simpleParsec . List.intercalate "." . FilePath.splitDirectories - --- | Converts a 'ModuleName.ModuleName' into a 'Fields.FieldLine'. -toFieldLine :: a -> ModuleName.ModuleName -> Fields.FieldLine a -toFieldLine a = Fields.FieldLine a . String.toUtf8 . Pretty.prettyShow diff --git a/source/library/CabalGild/Extra/Name.hs b/source/library/CabalGild/Extra/Name.hs deleted file mode 100644 --- a/source/library/CabalGild/Extra/Name.hs +++ /dev/null @@ -1,29 +0,0 @@ -module CabalGild.Extra.Name where - -import qualified CabalGild.Extra.String as String -import qualified Distribution.Compat.Lens as Lens -import qualified Distribution.Fields as Fields - --- | Extracts the annotation from the given 'Fields.Name'. -annotation :: Fields.Name a -> a -annotation (Fields.Name x _) = x - --- | A lens for the 'annotation'. -annotationLens :: Lens.Lens' (Fields.Name a) a -annotationLens f s = fmap (\a -> Fields.Name a $ value s) . f $ annotation s - --- | Extracts the value from the given 'Fields.Name'. -value :: Fields.Name a -> Fields.FieldName -value (Fields.Name _ x) = x - --- | Returns true when the name is @"if"@, false otherwise. -isIf :: Fields.Name a -> Bool -isIf = (== String.toUtf8 "if") . value - --- | Returns true when the name is @"elif"@, false otherwise. -isElif :: Fields.Name a -> Bool -isElif = (== String.toUtf8 "elif") . value - --- | Returns true when the name is @"else"@, false otherwise. -isElse :: Fields.Name a -> Bool -isElse = (== String.toUtf8 "else") . value diff --git a/source/library/CabalGild/Extra/SectionArg.hs b/source/library/CabalGild/Extra/SectionArg.hs deleted file mode 100644 --- a/source/library/CabalGild/Extra/SectionArg.hs +++ /dev/null @@ -1,10 +0,0 @@ -module CabalGild.Extra.SectionArg where - -import qualified Distribution.Fields as Fields - --- | Extracts the annotation from the given 'Fields.SectionArg'. -annotation :: Fields.SectionArg a -> a -annotation sa = case sa of - Fields.SecArgName x _ -> x - Fields.SecArgStr x _ -> x - Fields.SecArgOther x _ -> x diff --git a/source/library/CabalGild/Extra/String.hs b/source/library/CabalGild/Extra/String.hs deleted file mode 100644 --- a/source/library/CabalGild/Extra/String.hs +++ /dev/null @@ -1,9 +0,0 @@ -module CabalGild.Extra.String where - -import qualified Data.ByteString as ByteString -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Encoding - --- | Converts the given 'String' into a UTF-8 encoded 'ByteString.ByteString'. -toUtf8 :: String -> ByteString.ByteString -toUtf8 = Encoding.encodeUtf8 . Text.pack diff --git a/source/library/CabalGild/Main.hs b/source/library/CabalGild/Main.hs deleted file mode 100644 --- a/source/library/CabalGild/Main.hs +++ /dev/null @@ -1,106 +0,0 @@ --- | This module defines the main entry point for the application. -module CabalGild.Main where - -import qualified CabalGild.Action.AttachComments as AttachComments -import qualified CabalGild.Action.EvaluatePragmas as EvaluatePragmas -import qualified CabalGild.Action.ExtractComments as ExtractComments -import qualified CabalGild.Action.FormatFields as FormatFields -import qualified CabalGild.Action.GetCabalVersion as GetCabalVersion -import qualified CabalGild.Action.ReflowText as ReflowText -import qualified CabalGild.Action.RemovePositions as RemovePositions -import qualified CabalGild.Action.Render as Render -import qualified CabalGild.Action.StripBlanks as StripBlanks -import qualified CabalGild.Class.MonadLog as MonadLog -import qualified CabalGild.Class.MonadRead as MonadRead -import qualified CabalGild.Class.MonadWalk as MonadWalk -import qualified CabalGild.Class.MonadWrite as MonadWrite -import qualified CabalGild.Exception.CheckFailure as CheckFailure -import qualified CabalGild.Exception.ParseError as ParseError -import qualified CabalGild.Extra.ByteString as ByteString -import qualified CabalGild.Type.Config as Config -import qualified CabalGild.Type.Context as Context -import qualified CabalGild.Type.Flag as Flag -import qualified CabalGild.Type.Leniency as Leniency -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 Distribution.Fields as Fields -import qualified System.Environment as Environment -import qualified System.Exit as Exit -import qualified System.IO as IO - --- | This is the main entry point for the application. It gets the command line --- arguments and then hands things off to 'mainWith'. If any exceptions are --- thrown, they will be handled by 'onException'. -defaultMain :: IO () -defaultMain = Exception.handle onException $ do - arguments <- Environment.getArgs - mainWith arguments - --- | If the exception was an 'Exit.ExitCode', simply exit with that code. --- Otherwise handle exceptions by printing them to STDERR using --- 'Exception.displayException' instead of 'show'. Then exit with a failing --- status code. -onException :: Exception.SomeException -> IO a -onException e = case Exception.fromException e of - Just exitCode -> Exit.exitWith exitCode - Nothing -> do - IO.hPutStrLn IO.stderr $ Exception.displayException e - Exit.exitFailure - --- | The actual logic for the command line application. This is written using --- constraints so that it can be run in pure code if so desired. But most often --- this will be run in 'IO'. -mainWith :: - ( MonadLog.MonadLog m, - MonadRead.MonadRead m, - Exception.MonadThrow m, - MonadWalk.MonadWalk m, - MonadWrite.MonadWrite m - ) => - [String] -> - m () -mainWith arguments = do - flags <- Flag.fromArguments arguments - config <- Config.fromFlags flags - context <- Context.fromConfig config - - input <- MonadRead.read $ Context.input context - output <- format (Context.stdin context) input - - case Context.mode context of - Mode.Check -> do - let formatted = case Context.crlf context of - Leniency.Lenient -> - let lf = ByteString.singleton 0x0a - crlf = ByteString.cons 0x0d lf - in output == ByteString.replace crlf lf input - Leniency.Strict -> output == input - Monad.unless formatted $ Exception.throwM CheckFailure.CheckFailure - Mode.Format -> MonadWrite.write (Context.output context) output - --- | Formats the given input using the provided file path as the apparent --- source file (see 'Context.stdin'). An exception will be thrown if the input --- is invalid. The 'MonadWalk.MonadWalk' constraint is used to discover modules --- on the file system. Typically @m@ will be 'IO'. -format :: - (Exception.MonadThrow m, MonadWalk.MonadWalk m) => - FilePath -> - ByteString.ByteString -> - m ByteString.ByteString -format filePath input = do - fields <- - either (Exception.throwM . ParseError.ParseError) pure $ - Fields.readFields input - let csv = GetCabalVersion.fromFields fields - comments = ExtractComments.fromByteString input - ( StripBlanks.run - Monad.>=> AttachComments.run - Monad.>=> ReflowText.run csv - Monad.>=> RemovePositions.run - Monad.>=> EvaluatePragmas.run filePath - Monad.>=> FormatFields.run csv - Monad.>=> Render.run - ) - (fields, comments) diff --git a/source/library/CabalGild/Type/Block.hs b/source/library/CabalGild/Type/Block.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Block.hs +++ /dev/null @@ -1,73 +0,0 @@ --- | This module defines the 'Block' data type. -module CabalGild.Type.Block where - -import qualified CabalGild.Type.Line as Line -import qualified Data.ByteString as ByteString -import qualified Distribution.Compat.Lens as Lens -import Prelude hiding (lines) - --- | A block of text, which is made up of multiple lines and can have blank --- lines before and/or after it. -data Block = Block - { -- | Does this block have a blank line before it? - lineBefore :: Bool, - lines :: [Line.Line], - -- | Does this block have a blank line after it? - lineAfter :: Bool - } - deriving (Eq, Show) - --- | Joins two blocks together by adding a blank line between them if --- necessary. (A blank line is necessary if /either/ block needs a space.) If --- either block is empty, the other block is returned. -instance Semigroup Block where - x <> y = - let s = [Line.empty | lineAfter x || lineBefore y] - z = - Block - { lineBefore = lineBefore x, - lines = lines x <> s <> lines y, - lineAfter = lineAfter y - } - in if isEmpty x then y else if isEmpty y then x else z - --- | The empty block has no lines and also no blank lines before or after. -instance Monoid Block where - mempty = - Block - { lineBefore = False, - lines = [], - lineAfter = False - } - --- | Converts a single line into a block without blank lines before or after. -fromLine :: Line.Line -> Block -fromLine l = mempty {lines = [l]} - --- | Returns 'True' if the block has no lines. -isEmpty :: Block -> Bool -isEmpty = null . lines - --- | A lens for the 'lineAfter' field. -lineAfterLens :: Lens.Lens' Block Bool -lineAfterLens f s = fmap (\a -> s {lineAfter = a}) . f $ lineAfter s - --- | A lens for the 'lineBefore' field. -lineBeforeLens :: Lens.Lens' Block Bool -lineBeforeLens f s = fmap (\a -> s {lineBefore = a}) . f $ lineBefore s - --- | Converts a block into a 'ByteString.ByteString' by joining the lines --- together with newline characters. Note that unline 'unlines', there will be --- no trailing newline unless 'lineAfter' is 'True'. -toByteString :: Block -> ByteString.ByteString -toByteString b = - if isEmpty b - then ByteString.empty - else - ByteString.intercalate (ByteString.singleton 0x0a) - . fmap Line.toByteString - $ concat - [ [Line.empty | lineBefore b], - lines b, - [Line.empty | lineAfter b] - ] diff --git a/source/library/CabalGild/Type/Chunk.hs b/source/library/CabalGild/Type/Chunk.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Chunk.hs +++ /dev/null @@ -1,62 +0,0 @@ --- | This module defines the 'Chunk' data type. -module CabalGild.Type.Chunk where - -import qualified Data.ByteString as ByteString -import qualified Distribution.Compat.Lens as Lens - --- | A chunk of text, which is made up of a byte string and can have blank --- spaces before and/or after it. -data Chunk = Chunk - { -- | Does this chunk have a blank space before it? - spaceBefore :: Bool, - value :: ByteString.ByteString, - -- | Does this chunk have a blank space after it? - spaceAfter :: Bool - } - deriving (Eq, Show) - --- | Joins two chunks together by adding a blank space between them if --- necessary. (A blank space is necessary if /both/ chunks need a space.) If --- either chunk is empty, the other chunk is returned. -instance Semigroup Chunk where - x <> y = - let s = - if spaceAfter x && spaceBefore y - then ByteString.singleton 0x20 - else ByteString.empty - z = - Chunk - { spaceBefore = spaceBefore x, - value = value x <> s <> value y, - spaceAfter = spaceAfter y - } - in if isEmpty x then y else if isEmpty y then x else z - --- | The empty chunk has no value and also no blank spaces before or after. -instance Monoid Chunk where - mempty = - Chunk - { spaceBefore = False, - value = ByteString.empty, - spaceAfter = False - } - --- | A colon with a space after. -colon :: Chunk -colon = Lens.set spaceAfterLens True . fromByteString $ ByteString.singleton 0x3a - --- | Converts a byte string into a chunk without blank spaces before or after. -fromByteString :: ByteString.ByteString -> Chunk -fromByteString bs = mempty {value = bs} - --- | Returns 'True' if the chunk's byte string is empty. -isEmpty :: Chunk -> Bool -isEmpty = ByteString.null . value - --- | A lens for the 'spaceAfter' field. -spaceAfterLens :: Lens.Lens' Chunk Bool -spaceAfterLens f s = fmap (\a -> s {spaceAfter = a}) . f $ spaceAfter s - --- | A lens for the 'spaceBefore' field. -spaceBeforeLens :: Lens.Lens' Chunk Bool -spaceBeforeLens f s = fmap (\a -> s {spaceBefore = a}) . f $ spaceBefore s diff --git a/source/library/CabalGild/Type/Comment.hs b/source/library/CabalGild/Type/Comment.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Comment.hs +++ /dev/null @@ -1,18 +0,0 @@ --- | This module defines the 'Comment' data type. -module CabalGild.Type.Comment where - -import qualified CabalGild.Extra.String as String -import qualified Data.ByteString as ByteString - --- | A comment with corresponding annotation. Leading blank space is preserved, --- but trailing blank space is not. -data Comment a = Comment - { annotation :: a, - -- | Does /not/ include the 'delimiter'. - value :: ByteString.ByteString - } - deriving (Eq, Show) - --- | The start of a comment, which is @--@. -delimiter :: ByteString.ByteString -delimiter = String.toUtf8 "--" diff --git a/source/library/CabalGild/Type/Config.hs b/source/library/CabalGild/Type/Config.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Config.hs +++ /dev/null @@ -1,63 +0,0 @@ --- | This module defines the 'Config' data type. -module CabalGild.Type.Config where - -import qualified CabalGild.Type.Flag as Flag -import qualified CabalGild.Type.Input as Input -import qualified CabalGild.Type.Leniency as Leniency -import qualified CabalGild.Type.Mode as Mode -import qualified CabalGild.Type.Optional as Optional -import qualified CabalGild.Type.Output as Output -import qualified Control.Monad as Monad -import qualified Control.Monad.Catch as Exception - --- | This data type represents the configuration for the command line utility. --- Each field typically corresponds to a flag. -data Config = Config - { crlf :: Optional.Optional Leniency.Leniency, - help :: Optional.Optional Bool, - input :: Optional.Optional Input.Input, - mode :: Optional.Optional Mode.Mode, - output :: Optional.Optional Output.Output, - stdin :: Optional.Optional FilePath, - version :: Optional.Optional Bool - } - deriving (Eq, Show) - --- | The default config. -initial :: Config -initial = - Config - { crlf = Optional.Default, - help = Optional.Default, - input = Optional.Default, - mode = Optional.Default, - output = Optional.Default, - stdin = Optional.Default, - version = Optional.Default - } - --- | Applies a flag to the config, returning the new config. -applyFlag :: (Exception.MonadThrow m) => Config -> Flag.Flag -> m Config -applyFlag config flag = case flag of - Flag.CRLF s -> do - l <- Leniency.fromString s - pure config {crlf = Optional.Specific l} - Flag.Help b -> pure config {help = Optional.Specific b} - Flag.Input s -> pure config {input = Optional.Specific $ Input.fromString s} - Flag.IO s -> - pure - config - { input = Optional.Specific $ Input.fromString s, - output = Optional.Specific $ Output.fromString s - } - Flag.Mode s -> do - m <- Mode.fromString s - pure config {mode = Optional.Specific m} - Flag.Output s -> pure config {output = Optional.Specific $ Output.fromString s} - Flag.Stdin s -> pure config {stdin = Optional.Specific s} - Flag.Version b -> pure config {version = Optional.Specific b} - --- | Converts a list of flags into a config by starting with 'initial' and --- repeatedly calling 'applyFlag'. -fromFlags :: (Exception.MonadThrow m) => [Flag.Flag] -> m Config -fromFlags = Monad.foldM applyFlag initial diff --git a/source/library/CabalGild/Type/Context.hs b/source/library/CabalGild/Type/Context.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Context.hs +++ /dev/null @@ -1,87 +0,0 @@ -module CabalGild.Type.Context where - -import qualified CabalGild.Class.MonadLog as MonadLog -import qualified CabalGild.Exception.SpecifiedCrlfWithFormatMode as SpecifiedCrlfWithFormatMode -import qualified CabalGild.Exception.SpecifiedOutputWithCheckMode as SpecifiedOutputWithCheckMode -import qualified CabalGild.Exception.SpecifiedStdinWithFileInput as SpecifiedStdinWithFileInput -import qualified CabalGild.Type.Config as Config -import qualified CabalGild.Type.Flag as Flag -import qualified CabalGild.Type.Input as Input -import qualified CabalGild.Type.Leniency as Leniency -import qualified CabalGild.Type.Mode as Mode -import qualified CabalGild.Type.Optional as Optional -import qualified CabalGild.Type.Output as Output -import qualified Control.Monad as Monad -import qualified Control.Monad.Catch as Exception -import qualified Data.Char as Char -import qualified Data.List as List -import qualified Data.Version as Version -import qualified Paths_cabal_gild as This -import qualified System.Console.GetOpt as GetOpt -import qualified System.Exit as Exit - --- | Represents the context necessary to run the program. This is essentially a --- simplified 'Config.Config'. -data Context = Context - { crlf :: Leniency.Leniency, - input :: Input.Input, - mode :: Mode.Mode, - output :: Output.Output, - stdin :: FilePath - } - deriving (Eq, Show) - --- | Creates a 'Context' from a 'Config.Config'. If the help or version was --- requested, then this will throw an 'Exit.ExitSuccess'. Otherwise this makes --- sure the config is valid before returning the context. -fromConfig :: - (MonadLog.MonadLog m, Exception.MonadThrow m) => - Config.Config -> - m Context -fromConfig config = do - let version = Version.showVersion This.version - - Monad.when (Optional.withDefault False $ Config.help config) $ do - let header = - unlines - [ "cabal-gild version " <> version, - "", - "" - ] - MonadLog.logLn - . List.dropWhileEnd Char.isSpace - $ GetOpt.usageInfo header Flag.options - Exception.throwM Exit.ExitSuccess - - Monad.when (Optional.withDefault False $ Config.version config) $ do - MonadLog.logLn version - Exception.throwM Exit.ExitSuccess - - case (Config.input config, Config.stdin config) of - (Optional.Specific (Input.File _), Optional.Specific _) -> - Exception.throwM SpecifiedStdinWithFileInput.SpecifiedStdinWithFileInput - _ -> pure () - - case (Config.mode config, Config.output config) of - (Optional.Specific Mode.Check, Optional.Specific _) -> - Exception.throwM SpecifiedOutputWithCheckMode.SpecifiedOutputWithCheckMode - _ -> pure () - - case Config.crlf config of - Optional.Specific _ - | Config.mode config /= Optional.Specific Mode.Check -> - Exception.throwM SpecifiedCrlfWithFormatMode.SpecifiedCrlfWithFormatMode - _ -> pure () - - let theInput = Optional.withDefault Input.Stdin $ Config.input config - filePath = case theInput of - Input.Stdin -> "." - Input.File f -> f - pure - Context - { crlf = Optional.withDefault Leniency.Lenient $ Config.crlf config, - input = theInput, - mode = Optional.withDefault Mode.Format $ Config.mode config, - output = Optional.withDefault Output.Stdout $ Config.output config, - stdin = Optional.withDefault filePath $ Config.stdin config - } diff --git a/source/library/CabalGild/Type/Dependency.hs b/source/library/CabalGild/Type/Dependency.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Dependency.hs +++ /dev/null @@ -1,26 +0,0 @@ -module CabalGild.Type.Dependency where - -import qualified CabalGild.Type.VersionRange as VersionRange -import qualified Data.Ord as Ord -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified Distribution.Types.Dependency as Dependency - --- | This type exists to provide an 'Ord' instance for --- 'Dependency.Dependency', which was added in @Cabal-syntax-3.10.1.0@. -newtype Dependency = Dependency - { unwrap :: Dependency.Dependency - } - deriving (Eq, Show) - -instance Ord Dependency where - compare = - Ord.comparing $ - (\(Dependency.Dependency pn vr lns) -> (pn, VersionRange.fromVersionRange vr, lns)) - . unwrap - -instance Parsec.Parsec Dependency where - parsec = Dependency <$> Parsec.parsec - -instance Pretty.Pretty Dependency where - pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Type/ExeDependency.hs b/source/library/CabalGild/Type/ExeDependency.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/ExeDependency.hs +++ /dev/null @@ -1,26 +0,0 @@ -module CabalGild.Type.ExeDependency where - -import qualified CabalGild.Type.VersionRange as VersionRange -import qualified Data.Ord as Ord -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified Distribution.Types.ExeDependency as ExeDependency - --- | This type exists to provide an 'Ord' instance for --- 'ExeDependency.ExeDependency', which was added in @Cabal-syntax-3.10.1.0@. -newtype ExeDependency = ExeDependency - { unwrap :: ExeDependency.ExeDependency - } - deriving (Eq, Show) - -instance Ord ExeDependency where - compare = - Ord.comparing $ - (\(ExeDependency.ExeDependency pn ucn vr) -> (pn, ucn, VersionRange.fromVersionRange vr)) - . unwrap - -instance Parsec.Parsec ExeDependency where - parsec = ExeDependency <$> Parsec.parsec - -instance Pretty.Pretty ExeDependency where - pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Type/Extension.hs b/source/library/CabalGild/Type/Extension.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Extension.hs +++ /dev/null @@ -1,23 +0,0 @@ -module CabalGild.Type.Extension where - -import qualified Data.Ord as Ord -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified Language.Haskell.Extension as Extension - --- | This type exists to provide a different 'Ord' instance for --- 'Extension.Extension'. The instance provided by @Cabal-syntax@ sorts things --- in a surprising order. This one sorts things alphabetically. -newtype Extension = Extension - { unwrap :: Extension.Extension - } - deriving (Eq, Show) - -instance Ord Extension where - compare = Ord.comparing Pretty.prettyShow - -instance Parsec.Parsec Extension where - parsec = Extension <$> Parsec.parsec - -instance Pretty.Pretty Extension where - pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Type/Flag.hs b/source/library/CabalGild/Type/Flag.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Flag.hs +++ /dev/null @@ -1,88 +0,0 @@ -module CabalGild.Type.Flag where - -import qualified CabalGild.Exception.InvalidOption as InvalidOption -import qualified CabalGild.Exception.UnexpectedArgument as UnexpectedArgument -import qualified CabalGild.Exception.UnknownOption as UnknownOption -import qualified Control.Monad.Catch as Exception -import qualified Data.Foldable as Foldable -import qualified System.Console.GetOpt as GetOpt - --- | A flag, which represents a command line option. The values associated with --- the flags are typically not parsed. These just handle the structure of --- command line options. -data Flag - = CRLF String - | Help Bool - | Input String - | IO String - | Mode String - | Output String - | Stdin String - | Version Bool - deriving (Eq, Show) - --- | The command line options the correspond to the flags. -options :: [GetOpt.OptDescr Flag] -options = - [ GetOpt.Option - ['h', '?'] - ["help"] - (GetOpt.NoArg $ Help True) - "Shows this help message.", - GetOpt.Option - [] - ["no-help"] - (GetOpt.NoArg $ Help False) - "", - GetOpt.Option - ['v'] - ["version"] - (GetOpt.NoArg $ Version True) - "Shows the version number.", - GetOpt.Option - [] - ["no-version"] - (GetOpt.NoArg $ Version False) - "", - GetOpt.Option - [] - ["crlf"] - (GetOpt.ReqArg CRLF "LENIENCY") - "Sets the CRLF handling mode. Must be either 'lenient' or 'strict'.\nDefault: 'lenient'", - GetOpt.Option - ['i'] - ["input"] - (GetOpt.ReqArg Input "FILE") - "Sets the input file. Use '-' for standard input (STDIN).\nDefault: '-'", - GetOpt.Option - [] - ["io"] - (GetOpt.ReqArg IO "FILE") - "Shortcut for setting both the input and output files.", - GetOpt.Option - ['m'] - ["mode"] - (GetOpt.ReqArg Mode "MODE") - "Sets the mode. Must be either 'check' or 'format'.\nDefault: 'format'", - GetOpt.Option - ['o'] - ["output"] - (GetOpt.ReqArg Output "FILE") - "Sets the output file. Use '-' for standard output (STDOUT).\nDefault: '-'", - GetOpt.Option - ['s'] - ["stdin"] - (GetOpt.ReqArg Stdin "FILE") - "Sets the path to the input file when using STDIN.\nDefault: '.'" - ] - --- | Converts a list of command line arguments into a list of flags. If there --- are any unexpected arguments, invalid options, or unknown options, an --- exception will be thrown. -fromArguments :: (Exception.MonadThrow m) => [String] -> m [Flag] -fromArguments arguments = do - let (flgs, args, opts, errs) = GetOpt.getOpt' GetOpt.Permute options arguments - Foldable.traverse_ (Exception.throwM . UnexpectedArgument.fromString) args - Foldable.traverse_ (Exception.throwM . InvalidOption.fromString) errs - Foldable.traverse_ (Exception.throwM . UnknownOption.fromString) opts - pure flgs diff --git a/source/library/CabalGild/Type/ForeignLibOption.hs b/source/library/CabalGild/Type/ForeignLibOption.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/ForeignLibOption.hs +++ /dev/null @@ -1,23 +0,0 @@ -module CabalGild.Type.ForeignLibOption where - -import qualified Data.Ord as Ord -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified Distribution.Types.ForeignLibOption as ForeignLibOption - --- | This type exists to provide an 'Ord' instance for --- 'ForeignLibOption.ForeignLibOption', which was added in --- @Cabal-syntax-3.10.1.0@. -newtype ForeignLibOption = ForeignLibOption - { unwrap :: ForeignLibOption.ForeignLibOption - } - deriving (Eq, Show) - -instance Ord ForeignLibOption where - compare = Ord.comparing Pretty.prettyShow - -instance Parsec.Parsec ForeignLibOption where - parsec = ForeignLibOption <$> Parsec.parsec - -instance Pretty.Pretty ForeignLibOption where - pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Type/Input.hs b/source/library/CabalGild/Type/Input.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Input.hs +++ /dev/null @@ -1,15 +0,0 @@ -module CabalGild.Type.Input where - --- | Represents an input stream, which can either be standard input (STDIN) or --- a file. -data Input - = Stdin - | File FilePath - deriving (Eq, Ord, Show) - --- | Converts a string into an input. The string @"-"@ will be converted into --- 'Stdin', and any other string will be converted into 'File'. -fromString :: String -> Input -fromString s = case s of - "-" -> Stdin - _ -> File s diff --git a/source/library/CabalGild/Type/Language.hs b/source/library/CabalGild/Type/Language.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Language.hs +++ /dev/null @@ -1,22 +0,0 @@ -module CabalGild.Type.Language where - -import qualified Data.Ord as Ord -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified Language.Haskell.Extension as Extension - --- | This type exists to provide an 'Ord' instance for --- 'Language.Language', which was added in @Cabal-syntax-3.10.1.0@. -newtype Language = Language - { unwrap :: Extension.Language - } - deriving (Eq, Show) - -instance Ord Language where - compare = Ord.comparing Pretty.prettyShow - -instance Parsec.Parsec Language where - parsec = Language <$> Parsec.parsec - -instance Pretty.Pretty Language where - pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Type/LegacyExeDependency.hs b/source/library/CabalGild/Type/LegacyExeDependency.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/LegacyExeDependency.hs +++ /dev/null @@ -1,27 +0,0 @@ -module CabalGild.Type.LegacyExeDependency where - -import qualified CabalGild.Type.VersionRange as VersionRange -import qualified Data.Ord as Ord -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified Distribution.Types.LegacyExeDependency as LegacyExeDependency - --- | This type exists to provide an 'Ord' instance for --- 'LegacyExeDependency.LegacyExeDependency', which was added in --- @Cabal-syntax-3.10.1.0@. -newtype LegacyExeDependency = LegacyExeDependency - { unwrap :: LegacyExeDependency.LegacyExeDependency - } - deriving (Eq, Show) - -instance Ord LegacyExeDependency where - compare = - Ord.comparing $ - (\(LegacyExeDependency.LegacyExeDependency s vr) -> (s, VersionRange.fromVersionRange vr)) - . unwrap - -instance Parsec.Parsec LegacyExeDependency where - parsec = LegacyExeDependency <$> Parsec.parsec - -instance Pretty.Pretty LegacyExeDependency where - pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Type/Leniency.hs b/source/library/CabalGild/Type/Leniency.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Leniency.hs +++ /dev/null @@ -1,18 +0,0 @@ -module CabalGild.Type.Leniency where - -import qualified CabalGild.Exception.InvalidLeniency as InvalidLeniency -import qualified Control.Monad.Catch as Exception - --- | Represents the leniency of a setting. In other words, should something be --- lenient\/permissive or strict\/pedantic? -data Leniency - = Lenient - | Strict - deriving (Eq, Show) - --- | Attempts to parse a string as a 'Leniency'. -fromString :: (Exception.MonadThrow m) => String -> m Leniency -fromString s = case s of - "lenient" -> pure Lenient - "strict" -> pure Strict - _ -> Exception.throwM $ InvalidLeniency.fromString s diff --git a/source/library/CabalGild/Type/Line.hs b/source/library/CabalGild/Type/Line.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Line.hs +++ /dev/null @@ -1,39 +0,0 @@ -module CabalGild.Type.Line where - -import qualified CabalGild.Type.Chunk as Chunk -import qualified Data.ByteString as ByteString -import qualified Distribution.Compat.Lens as Lens - --- | A line of text, which is made up of a chunk and an indent level. -data Line = Line - { -- | Number of times the chunk should be indented. - indent :: Int, - chunk :: Chunk.Chunk - } - deriving (Eq, Show) - --- | A lens for the 'chunk' field. -chunkLens :: Lens.Lens' Line Chunk.Chunk -chunkLens f s = fmap (\a -> s {chunk = a}) . f $ chunk s - --- | An empty line, which is an empty chunk with no indentation. -empty :: Line -empty = - Line - { indent = 0, - chunk = mempty - } - --- | Returns 'True' if the line's chunk is empty. -isEmpty :: Line -> Bool -isEmpty = Chunk.isEmpty . chunk - --- | Converts a line to a 'ByteString' by indenting the chunk. -toByteString :: Line -> ByteString.ByteString -toByteString l = - if isEmpty l - then ByteString.empty - else - mappend (ByteString.replicate (2 * indent l) 0x20) - . Chunk.value - $ chunk l diff --git a/source/library/CabalGild/Type/List.hs b/source/library/CabalGild/Type/List.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/List.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module CabalGild.Type.List where - -import qualified CabalGild.Extra.List as List -import qualified Data.Proxy as Proxy -import qualified Distribution.CabalSpecVersion as CabalSpecVersion -import qualified Distribution.Compat.Newtype as Newtype -import qualified Distribution.FieldGrammar.Newtypes as Newtypes -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified Text.PrettyPrint as PrettyPrint - --- | A thin wrapper around 'Newtypes.List'. This is used to define custom --- instances of 'Pretty.Pretty' that use trailing commas when the Cabal spec --- version is recent enough (at least @2.2@). -newtype List s b a = List - { unwrap :: Newtypes.List s b a - } - -instance Newtype.Newtype [a] (List s b a) where - pack = List . Newtype.pack - unpack = Newtype.unpack . unwrap - -instance - ( Newtype.Newtype a b, - Parsec.Parsec b, - Newtypes.Sep s - ) => - Parsec.Parsec (List s b a) - where - parsec = List <$> Parsec.parsec - -instance - ( Newtype.Newtype a b, - Pretty.Pretty b, - Newtypes.Sep s - ) => - Pretty.Pretty (List s b a) - where - pretty = Pretty.prettyVersioned CabalSpecVersion.CabalSpecV1_0 - prettyVersioned v = - Newtypes.prettySep (Proxy.Proxy @s) - . fmap (Pretty.prettyVersioned @b v . Newtype.pack) - . Newtype.unpack - --- | Overlaps the more general instance in order to use trailing commas when --- possible. -instance - {-# OVERLAPPING #-} - ( Newtype.Newtype a b, - Pretty.Pretty b - ) => - Pretty.Pretty (List Newtypes.CommaFSep b a) - where - pretty = Pretty.prettyVersioned CabalSpecVersion.CabalSpecV1_0 - prettyVersioned v = - ( \xs -> - if List.compareLength xs 1 == GT && v >= CabalSpecVersion.CabalSpecV2_2 - then PrettyPrint.fsep $ fmap (<> PrettyPrint.comma) xs - else Newtypes.prettySep (Proxy.Proxy @Newtypes.CommaFSep) xs - ) - . fmap (Pretty.prettyVersioned @b v . Newtype.pack) - . Newtype.unpack diff --git a/source/library/CabalGild/Type/Mode.hs b/source/library/CabalGild/Type/Mode.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Mode.hs +++ /dev/null @@ -1,19 +0,0 @@ -module CabalGild.Type.Mode where - -import qualified CabalGild.Exception.InvalidMode as InvalidMode -import qualified Control.Monad.Catch as Exception - --- | Represents the mode of the command line utility. -data Mode - = -- | Just determine if the input is already formatted. - Check - | -- | Format the input. - Format - deriving (Eq, Show) - --- | Attempts to parse a string as a mode. -fromString :: (Exception.MonadThrow m) => String -> m Mode -fromString s = case s of - "check" -> pure Check - "format" -> pure Format - _ -> Exception.throwM $ InvalidMode.fromString s diff --git a/source/library/CabalGild/Type/ModuleReexport.hs b/source/library/CabalGild/Type/ModuleReexport.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/ModuleReexport.hs +++ /dev/null @@ -1,25 +0,0 @@ -module CabalGild.Type.ModuleReexport where - -import qualified Data.Ord as Ord -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified Distribution.Types.ModuleReexport as ModuleReexport - --- | This type exists to provide an 'Ord' instance for --- 'ModuleReexport.ModuleReexport', which was added in @Cabal-syntax-3.10.1.0@. -newtype ModuleReexport = ModuleReexport - { unwrap :: ModuleReexport.ModuleReexport - } - deriving (Eq, Show) - -instance Ord ModuleReexport where - compare = - Ord.comparing $ - (\(ModuleReexport.ModuleReexport mpn mn1 mn2) -> (mpn, mn1, mn2)) - . unwrap - -instance Parsec.Parsec ModuleReexport where - parsec = ModuleReexport <$> Parsec.parsec - -instance Pretty.Pretty ModuleReexport where - pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Type/Optional.hs b/source/library/CabalGild/Type/Optional.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Optional.hs +++ /dev/null @@ -1,20 +0,0 @@ -module CabalGild.Type.Optional where - --- | Represents a value that may or may not be present. Isomorphic to 'Maybe'. --- Useful to distinguish between a value not being given and a value happening --- to be the same as the default. -data Optional a - = Default - | Specific a - deriving (Eq, Show) - --- | Uses the provided default value if the optional is 'Default', otherwise --- gets the value out of the 'Specific'. Similar to 'Data.Maybe.fromMaybe'. -withDefault :: a -> Optional a -> a -withDefault = flip optional id - --- | Basic destructor, similar to 'maybe'. -optional :: b -> (a -> b) -> Optional a -> b -optional b f o = case o of - Default -> b - Specific s -> f s diff --git a/source/library/CabalGild/Type/Output.hs b/source/library/CabalGild/Type/Output.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Output.hs +++ /dev/null @@ -1,15 +0,0 @@ -module CabalGild.Type.Output where - --- | Represents an output stream, which can either be standard output --- (STDOUT) or a file. -data Output - = Stdout - | File FilePath - deriving (Eq, Ord, Show) - --- | Converts a string into an output. The string @"-"@ will be converted into --- 'Stdout', and any other string will be converted into 'File'. -fromString :: String -> Output -fromString s = case s of - "-" -> Stdout - _ -> File s diff --git a/source/library/CabalGild/Type/PkgconfigDependency.hs b/source/library/CabalGild/Type/PkgconfigDependency.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/PkgconfigDependency.hs +++ /dev/null @@ -1,27 +0,0 @@ -module CabalGild.Type.PkgconfigDependency where - -import qualified CabalGild.Type.PkgconfigVersionRange as PkgconfigVersionRange -import qualified Data.Ord as Ord -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified Distribution.Types.PkgconfigDependency as PkgconfigDependency - --- | This type exists to provide an 'Ord' instance for --- 'PkgconfigDependency.PkgconfigDependency', which was added in --- @Cabal-syntax-3.10.1.0@. -newtype PkgconfigDependency = PkgconfigDependency - { unwrap :: PkgconfigDependency.PkgconfigDependency - } - deriving (Eq, Show) - -instance Ord PkgconfigDependency where - compare = - Ord.comparing $ - (\(PkgconfigDependency.PkgconfigDependency pn pvr) -> (pn, PkgconfigVersionRange.PkgconfigVersionRange pvr)) - . unwrap - -instance Parsec.Parsec PkgconfigDependency where - parsec = PkgconfigDependency <$> Parsec.parsec - -instance Pretty.Pretty PkgconfigDependency where - pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Type/PkgconfigVersionRange.hs b/source/library/CabalGild/Type/PkgconfigVersionRange.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/PkgconfigVersionRange.hs +++ /dev/null @@ -1,27 +0,0 @@ -module CabalGild.Type.PkgconfigVersionRange where - -import qualified CabalGild.Type.VersionRange as VersionRange -import qualified Data.Ord as Ord -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified Distribution.Types.PkgconfigVersionRange as PkgconfigVersionRange - --- | This type exists to provide an 'Ord' instance for --- 'PkgconfigVersionRange.PkgconfigVersionRange', which was added in --- @Cabal-syntax-3.10.1.0@. -newtype PkgconfigVersionRange = PkgconfigVersionRange - { unwrap :: PkgconfigVersionRange.PkgconfigVersionRange - } - deriving (Eq, Show) - -instance Ord PkgconfigVersionRange where - compare = - Ord.comparing $ - VersionRange.fromPkgconfigVersionRange - . unwrap - -instance Parsec.Parsec PkgconfigVersionRange where - parsec = PkgconfigVersionRange <$> Parsec.parsec - -instance Pretty.Pretty PkgconfigVersionRange where - pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Type/Pragma.hs b/source/library/CabalGild/Type/Pragma.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Pragma.hs +++ /dev/null @@ -1,24 +0,0 @@ -module CabalGild.Type.Pragma where - -import qualified Control.Monad as Monad -import qualified Data.List.NonEmpty as NonEmpty -import qualified Distribution.Compat.CharParsing as CharParsing -import qualified Distribution.FieldGrammar.Newtypes as Newtypes -import qualified Distribution.Parsec as Parsec - --- | A pragma, which is a special comment used to customize behavior. -newtype Pragma - = -- | Discover modules within the given directory. - Discover (NonEmpty.NonEmpty FilePath) - deriving (Eq, Show) - -instance Parsec.Parsec Pragma where - parsec = do - CharParsing.spaces - Monad.void $ CharParsing.string "cabal-gild:" - CharParsing.spaces - Monad.void $ CharParsing.string "discover" - CharParsing.skipSpaces1 - Discover - . fmap Newtypes.getFilePathNT - <$> CharParsing.sepByNonEmpty Parsec.parsec CharParsing.skipSpaces1 diff --git a/source/library/CabalGild/Type/Set.hs b/source/library/CabalGild/Type/Set.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/Set.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module CabalGild.Type.Set where - -import qualified CabalGild.Extra.List as List -import qualified Data.Proxy as Proxy -import qualified Data.Set as Set -import qualified Distribution.CabalSpecVersion as CabalSpecVersion -import qualified Distribution.Compat.Newtype as Newtype -import qualified Distribution.FieldGrammar.Newtypes as Newtypes -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified Text.PrettyPrint as PrettyPrint - --- | A thin wrapper around 'Newtypes.Set''. This is used to define custom --- instances of 'Pretty.Pretty' that use trailing commas when the Cabal spec --- version is recent enough (at least @2.2@). -newtype Set s b a = Set - { unwrap :: Newtypes.Set' s b a - } - -instance Newtype.Newtype (Set.Set a) (Set s b a) where - pack = Set . Newtype.pack - unpack = Newtype.unpack . unwrap - -instance - ( Newtype.Newtype a b, - Ord a, - Parsec.Parsec b, - Newtypes.Sep s - ) => - Parsec.Parsec (Set s b a) - where - parsec = Set <$> Parsec.parsec - -instance - ( Newtype.Newtype a b, - Pretty.Pretty b, - Newtypes.Sep s - ) => - Pretty.Pretty (Set s b a) - where - pretty = Pretty.prettyVersioned CabalSpecVersion.CabalSpecV1_0 - prettyVersioned v = - Newtypes.prettySep (Proxy.Proxy @s) - . fmap (Pretty.prettyVersioned @b v . Newtype.pack) - . Set.toAscList - . Newtype.unpack - --- | Overlaps the more general instance in order to use trailing commas when --- possible. -instance - {-# OVERLAPPING #-} - ( Newtype.Newtype a b, - Pretty.Pretty b - ) => - Pretty.Pretty (Set Newtypes.CommaFSep b a) - where - pretty = Pretty.prettyVersioned CabalSpecVersion.CabalSpecV1_0 - prettyVersioned v = - ( \xs -> - if List.compareLength xs 1 == GT && v >= CabalSpecVersion.CabalSpecV2_2 - then PrettyPrint.fsep $ fmap (<> PrettyPrint.comma) xs - else Newtypes.prettySep (Proxy.Proxy @Newtypes.CommaFSep) xs - ) - . fmap (Pretty.prettyVersioned @b v . Newtype.pack) - . Set.toAscList - . Newtype.unpack - --- | Overlaps the more general instance in order to use trailing commas when --- possible. -instance - {-# OVERLAPPING #-} - ( Newtype.Newtype a b, - Pretty.Pretty b - ) => - Pretty.Pretty (Set Newtypes.CommaVCat b a) - where - pretty = Pretty.prettyVersioned CabalSpecVersion.CabalSpecV1_0 - prettyVersioned v = - ( \xs -> - if List.compareLength xs 1 == GT && v >= CabalSpecVersion.CabalSpecV2_2 - then PrettyPrint.vcat $ fmap (<> PrettyPrint.comma) xs - else Newtypes.prettySep (Proxy.Proxy @Newtypes.CommaVCat) xs - ) - . fmap (Pretty.prettyVersioned @b v . Newtype.pack) - . Set.toAscList - . Newtype.unpack diff --git a/source/library/CabalGild/Type/SomeParsecParser.hs b/source/library/CabalGild/Type/SomeParsecParser.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/SomeParsecParser.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module CabalGild.Type.SomeParsecParser where - -import qualified CabalGild.Type.List as List -import qualified CabalGild.Type.Set as Set -import qualified Distribution.CabalSpecVersion as CabalSpecVersion -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty -import qualified Text.PrettyPrint as PrettyPrint - --- | This type bundles up a parser and a pretty printer for some type. --- Typically they will just be monomorphic versions of 'Parsec.parsec' and --- 'Pretty.prettyVersioned'. -data SomeParsecParser - = forall a. - SomeParsecParser - { parsec :: Parsec.ParsecParser a, - pretty :: CabalSpecVersion.CabalSpecVersion -> a -> PrettyPrint.Doc - } - --- | Creates a new parser for the given 'List.List' of values. -list :: - forall s b a. - (Parsec.Parsec (List.List s b a), Pretty.Pretty (List.List s b a)) => - SomeParsecParser -list = - SomeParsecParser - { parsec = Parsec.parsec @(List.List s b a), - pretty = Pretty.prettyVersioned - } - --- | Creates a new parser for the given 'Set.Set' of values. -set :: - forall s b a. - (Parsec.Parsec (Set.Set s b a), Pretty.Pretty (Set.Set s b a)) => - SomeParsecParser -set = - SomeParsecParser - { parsec = Parsec.parsec @(Set.Set s b a), - pretty = Pretty.prettyVersioned - } diff --git a/source/library/CabalGild/Type/TestedWith.hs b/source/library/CabalGild/Type/TestedWith.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/TestedWith.hs +++ /dev/null @@ -1,32 +0,0 @@ -module CabalGild.Type.TestedWith where - -import qualified CabalGild.Type.VersionRange as VersionRange -import qualified Data.Ord as Ord -import qualified Distribution.FieldGrammar.Newtypes as Newtypes -import qualified Distribution.Parsec as Parsec -import qualified Distribution.Pretty as Pretty - --- | This type exists to provide an 'Ord' instance for 'Newtypes.TestedWith', --- which was added in @Cabal-syntax-3.10.1.0@. -newtype TestedWith = TestedWith - { unwrap :: Newtypes.TestedWith - } - -instance Eq TestedWith where - x == y = compare x y == EQ - -instance Ord TestedWith where - compare = - Ord.comparing $ - fmap VersionRange.fromVersionRange - . Newtypes.getTestedWith - . unwrap - -instance Parsec.Parsec TestedWith where - parsec = TestedWith <$> Parsec.parsec - -instance Pretty.Pretty TestedWith where - pretty = Pretty.pretty . unwrap - -instance Show TestedWith where - show = show . Newtypes.getTestedWith . unwrap diff --git a/source/library/CabalGild/Type/VersionRange.hs b/source/library/CabalGild/Type/VersionRange.hs deleted file mode 100644 --- a/source/library/CabalGild/Type/VersionRange.hs +++ /dev/null @@ -1,40 +0,0 @@ -module CabalGild.Type.VersionRange where - -import qualified Distribution.Types.PkgconfigVersion as PkgconfigVersion -import qualified Distribution.Types.PkgconfigVersionRange as PkgconfigVersionRange -import qualified Distribution.Types.Version as Version -import qualified Distribution.Types.VersionRange as VersionRange - --- | This type exists to provide an 'Ord' instance for --- 'VersionRange.VersionRange', which was added in @Cabal-syntax-3.10.1.0@. -data VersionRange a - = Any - | This a - | Later a - | Earlier a - | Union (VersionRange a) (VersionRange a) - | Intersect (VersionRange a) (VersionRange a) - deriving (Eq, Ord, Show) - -fromPkgconfigVersionRange :: - PkgconfigVersionRange.PkgconfigVersionRange -> - VersionRange PkgconfigVersion.PkgconfigVersion -fromPkgconfigVersionRange x = case x of - PkgconfigVersionRange.PcAnyVersion -> Any - PkgconfigVersionRange.PcThisVersion v -> This v - PkgconfigVersionRange.PcLaterVersion v -> Later v - PkgconfigVersionRange.PcEarlierVersion v -> Earlier v - PkgconfigVersionRange.PcOrLaterVersion v -> Union (Later v) (This v) - PkgconfigVersionRange.PcOrEarlierVersion v -> Union (Earlier v) (This v) - PkgconfigVersionRange.PcUnionVersionRanges v w -> Union (fromPkgconfigVersionRange v) (fromPkgconfigVersionRange w) - PkgconfigVersionRange.PcIntersectVersionRanges v w -> Intersect (fromPkgconfigVersionRange v) (fromPkgconfigVersionRange w) - -fromVersionRange :: VersionRange.VersionRange -> VersionRange Version.Version -fromVersionRange = - VersionRange.foldVersionRange - Any - This - Later - Earlier - Union - Intersect diff --git a/source/library/CabalGild/Unstable/Action/AttachComments.hs b/source/library/CabalGild/Unstable/Action/AttachComments.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Action/AttachComments.hs @@ -0,0 +1,89 @@ +module CabalGild.Unstable.Action.AttachComments where + +import qualified CabalGild.Unstable.Type.Comment as Comment +import qualified Control.Monad.Trans.State as StateT +import qualified Distribution.Fields as Fields + +-- | High level wrapper around 'field' that makes this action easier to compose +-- with other actions. +run :: + (Applicative m, Ord p) => + ([Fields.Field p], [Comment.Comment p]) -> + m ([Fields.Field (p, [Comment.Comment p])], [Comment.Comment p]) +run (fs, cs) = pure $ StateT.runState (traverse field fs) cs + +-- | Attaches comments to a single field. It is assumed that both the fields +-- and comments are already sorted by their position @p@. This precondition is +-- not checked. Note that comments actually end up attached to the field's +-- name. That's because the 'Field.Field' type doesn't have any annotations +-- directly on it. +field :: + (Ord p) => + Fields.Field p -> + StateT.State [Comment.Comment p] (Fields.Field (p, [Comment.Comment p])) +field f = case f of + Fields.Field n fls -> + Fields.Field + <$> name n + <*> traverse fieldLine fls + Fields.Section n sas fs -> + Fields.Section + <$> name n + <*> traverse sectionArg sas + <*> traverse field fs + +-- | Attaches comments to a name. Note that this could be a field name or a +-- section name. +name :: + (Ord p) => + Fields.Name p -> + StateT.State [Comment.Comment p] (Fields.Name (p, [Comment.Comment p])) +name (Fields.Name p fn) = + Fields.Name + <$> toPosition p + <*> pure fn + +-- | Attach comments to a field line. +fieldLine :: + (Ord p) => + Fields.FieldLine p -> + StateT.State [Comment.Comment p] (Fields.FieldLine (p, [Comment.Comment p])) +fieldLine (Fields.FieldLine p bs) = + Fields.FieldLine + <$> toPosition p + <*> pure bs + +-- | Attaches comments to a section argument. Note that section arguments +-- cannot actually have comments attached. That's because section arguments +-- must be on -- the same line as the section name, so all comments will end up +-- attached to the name. +sectionArg :: + (Ord p) => + Fields.SectionArg p -> + StateT.State [Comment.Comment p] (Fields.SectionArg (p, [Comment.Comment p])) +sectionArg sa = case sa of + Fields.SecArgName p bs -> + Fields.SecArgName + <$> toPosition p + <*> pure bs + Fields.SecArgStr p bs -> + Fields.SecArgStr + <$> toPosition p + <*> pure bs + Fields.SecArgOther p bs -> + Fields.SecArgOther + <$> toPosition p + <*> pure bs + +-- | Attaches comments to a position. This is the workhorse of the module. +-- Comments are attached when their position is less than or equal to the given +-- position. The comments are removed from the state as they are attached. +toPosition :: + (Ord p) => + p -> + StateT.State [Comment.Comment p] (p, [Comment.Comment p]) +toPosition p = do + cs <- StateT.get + let (xs, ys) = span ((<= p) . Comment.annotation) cs + StateT.put ys + pure (p, xs) diff --git a/source/library/CabalGild/Unstable/Action/EvaluatePragmas.hs b/source/library/CabalGild/Unstable/Action/EvaluatePragmas.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Action/EvaluatePragmas.hs @@ -0,0 +1,123 @@ +module CabalGild.Unstable.Action.EvaluatePragmas where + +import qualified CabalGild.Unstable.Class.MonadWalk as MonadWalk +import qualified CabalGild.Unstable.Extra.FieldLine as FieldLine +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.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.List.NonEmpty as NonEmpty +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.FilePath as FilePath + +-- | High level wrapper around 'field' that makes this action easier to compose +-- with other actions. +run :: + (MonadWalk.MonadWalk m) => + FilePath -> + ([Fields.Field (p, [Comment.Comment q])], cs) -> + m ([Fields.Field (p, [Comment.Comment 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. +-- +-- 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 (p, [Comment.Comment q]) -> + m (Fields.Field (p, [Comment.Comment q])) +field p f = case f of + Fields.Field n fls -> fmap (Maybe.fromMaybe f) . MaybeT.runMaybeT $ do + Monad.guard $ Set.member (Name.value n) relevantFieldNames + comment <- hoistMaybe . Utils.safeLast . snd $ Name.annotation n + pragma <- hoistMaybe . Parsec.simpleParsecBS $ Comment.value comment + case pragma of + Pragma.Discover ds -> do + let root = FilePath.takeDirectory p + directories = + FilePath.dropTrailingPathSeparator + . FilePath.normalise + . FilePath.combine root + <$> NonEmpty.toList ds + files <- Trans.lift . fmap mconcat $ traverse MonadWalk.walk directories + let comments = concatMap (snd . FieldLine.annotation) fls + position = + maybe (fst $ Name.annotation n) (fst . FieldLine.annotation) $ + Maybe.listToMaybe fls + fieldLines = + zipWith ModuleName.toFieldLine ((,) position <$> comments : repeat []) + . Maybe.mapMaybe (toModuleName directories) + $ Maybe.mapMaybe (stripAnyExtension extensions) 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 + Fields.Section n sas fs -> Fields.Section n sas <$> traverse (field p) fs + +-- | These are the names of the fields that can have this action applied to +-- them. +relevantFieldNames :: Set.Set Fields.FieldName +relevantFieldNames = + Set.fromList $ + fmap + String.toUtf8 + [ "exposed-modules", + "other-modules", + "signatures" + ] + +-- | Attempts to strip any of the given extensions from the file path. If any +-- of them succeed, the result is returned. Otherwise 'Nothing' is returned. +stripAnyExtension :: Set.Set String -> FilePath -> Maybe String +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. +-- +-- +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 +-- . +hoistMaybe :: (Applicative f) => Maybe a -> MaybeT.MaybeT f a +hoistMaybe = MaybeT.MaybeT . pure diff --git a/source/library/CabalGild/Unstable/Action/ExtractComments.hs b/source/library/CabalGild/Unstable/Action/ExtractComments.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Action/ExtractComments.hs @@ -0,0 +1,49 @@ +module CabalGild.Unstable.Action.ExtractComments where + +import qualified CabalGild.Unstable.Type.Comment as Comment +import qualified Control.Applicative as Applicative +import qualified Control.Monad as Monad +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as Latin1 +import qualified Data.ByteString.Internal as ByteStringInternal +import qualified Data.Maybe as Maybe +import qualified Data.Word as Word +import qualified Distribution.Parsec.Position as Position + +-- | Extracts comments from the given byte string. This is a wrapper around +-- 'fromLine', where lines are split using 'Latin1.lines'. +fromByteString :: ByteString.ByteString -> [Comment.Comment Position.Position] +fromByteString = + Maybe.mapMaybe (uncurry fromLine) + . zip [1 ..] + . Latin1.lines + +-- | Extracts a comment from the given line. If the line does not contain a +-- comment, the result will be 'Alternative.empty'. +fromLine :: + (Applicative.Alternative m, Monad m) => + Int -> + ByteString.ByteString -> + m (Comment.Comment Position.Position) +fromLine row line = do + let (before, after) = breakComment line + rest <- + maybe Applicative.empty pure $ + ByteString.stripPrefix Comment.delimiter after + Monad.guard $ ByteString.all isBlank before + pure + Comment.Comment + { Comment.annotation = Position.Position row $ 1 + ByteString.length before, + Comment.value = ByteString.dropWhileEnd isBlank rest + } + +-- | Breaks a byte string into two parts: the part before the comment delimiter +-- and the part after. If there is no comment, the part after will be empty. +breakComment :: ByteString.ByteString -> (ByteString.ByteString, ByteString.ByteString) +breakComment = ByteString.breakSubstring Comment.delimiter + +-- | Returns true if the given byte is a blank character. Currently this is a +-- wrapper around 'ByteStringInternal.isSpaceWord8'. Perhaps it should only +-- check for spaces and tabs though. +isBlank :: Word.Word8 -> Bool +isBlank = ByteStringInternal.isSpaceWord8 diff --git a/source/library/CabalGild/Unstable/Action/FormatFields.hs b/source/library/CabalGild/Unstable/Action/FormatFields.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Action/FormatFields.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE TypeApplications #-} + +module CabalGild.Unstable.Action.FormatFields where + +import qualified CabalGild.Unstable.Extra.FieldLine as FieldLine +import qualified CabalGild.Unstable.Extra.Name as Name +import qualified CabalGild.Unstable.Extra.String as String +import qualified CabalGild.Unstable.Type.Dependency as Dependency +import qualified CabalGild.Unstable.Type.ExeDependency as ExeDependency +import qualified CabalGild.Unstable.Type.Extension as Extension +import qualified CabalGild.Unstable.Type.ForeignLibOption as ForeignLibOption +import qualified CabalGild.Unstable.Type.Language as Language +import qualified CabalGild.Unstable.Type.LegacyExeDependency as LegacyExeDependency +import qualified CabalGild.Unstable.Type.Mixin as Mixin +import qualified CabalGild.Unstable.Type.ModuleReexport as ModuleReexport +import qualified CabalGild.Unstable.Type.PkgconfigDependency as PkgconfigDependency +import qualified CabalGild.Unstable.Type.SomeParsecParser as SPP +import qualified CabalGild.Unstable.Type.TestedWith as TestedWith +import qualified Data.Functor.Identity as Identity +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +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 Text.PrettyPrint as PrettyPrint + +-- | A wrapper around 'field' to allow this to be composed with other actions. +run :: + (Applicative m) => + CabalSpecVersion.CabalSpecVersion -> + ([Fields.Field (p, [c])], [c]) -> + m ([Fields.Field (p, [c])], [c]) +run csv (fs, cs) = pure (fmap (field csv) fs, cs) + +-- | 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 :: + CabalSpecVersion.CabalSpecVersion -> + Fields.Field (p, [c]) -> + Fields.Field (p, [c]) +field csv f = case f of + Fields.Field n fls -> case Map.lookup (Name.value n) parsers of + Nothing -> f + Just spp -> + let position = + maybe (fst $ Name.annotation n) (fst . FieldLine.annotation) $ + Maybe.listToMaybe fls + in Fields.Field n $ fieldLines csv position fls spp + Fields.Section n sas fs -> Fields.Section n sas $ fmap (field 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 :: + CabalSpecVersion.CabalSpecVersion -> + p -> + [Fields.FieldLine (p, [c])] -> + SPP.SomeParsecParser -> + [Fields.FieldLine (p, [c])] +fieldLines csv position 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 ((,) position <$> concatMap (snd . FieldLine.annotation) fls : repeat []) + . 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 Language.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 @(Identity.Identity TestedWith.TestedWith), + "virtual-modules" =: SPP.set @Newtypes.VCat @(Newtypes.MQuoted ModuleName.ModuleName) + ] diff --git a/source/library/CabalGild/Unstable/Action/GetCabalVersion.hs b/source/library/CabalGild/Unstable/Action/GetCabalVersion.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Action/GetCabalVersion.hs @@ -0,0 +1,40 @@ +module CabalGild.Unstable.Action.GetCabalVersion where + +import qualified CabalGild.Unstable.Extra.Either as Either +import qualified CabalGild.Unstable.Extra.FieldLine as FieldLine +import qualified CabalGild.Unstable.Extra.Name as Name +import qualified CabalGild.Unstable.Extra.String as String +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import qualified Distribution.CabalSpecVersion as CabalSpecVersion +import qualified Distribution.FieldGrammar.Newtypes as Newtypes +import qualified Distribution.Fields as Fields +import qualified Distribution.Parsec as Parsec + +-- | Gets the Cabal spec version from a list of fields. If multiple fields +-- define the version, the first one is used. +fromFields :: [Fields.Field a] -> CabalSpecVersion.CabalSpecVersion +fromFields fs = Maybe.fromMaybe CabalSpecVersion.CabalSpecV1_0 $ do + f <- List.find isCabalVersion fs + fls <- getFieldLines f + Newtypes.getSpecVersion <$> fromFieldLines fls + +-- | Returns true if the field is named @cabal-version@. +isCabalVersion :: Fields.Field a -> Bool +isCabalVersion f = case f of + Fields.Field n _ -> Name.value n == String.toUtf8 "cabal-version" + Fields.Section {} -> False + +-- | Gets the field lines from a field. If the field is a section, this returns +-- 'Nothing'. +getFieldLines :: Fields.Field a -> Maybe [Fields.FieldLine a] +getFieldLines f = case f of + Fields.Field _ fls -> Just fls + Fields.Section {} -> Nothing + +-- | Attempts to parse the given field lines as a Cabal spec version. +fromFieldLines :: [Fields.FieldLine a] -> Maybe Newtypes.SpecVersion +fromFieldLines = + Either.hush + . Parsec.runParsecParser Parsec.parsec "" + . FieldLine.toFieldLineStream diff --git a/source/library/CabalGild/Unstable/Action/ReflowText.hs b/source/library/CabalGild/Unstable/Action/ReflowText.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Action/ReflowText.hs @@ -0,0 +1,129 @@ +module CabalGild.Unstable.Action.ReflowText where + +import qualified CabalGild.Unstable.Extra.Field as Field +import qualified CabalGild.Unstable.Extra.FieldLine as FieldLine +import qualified CabalGild.Unstable.Extra.List as List +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 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/Unstable/Action/Render.hs b/source/library/CabalGild/Unstable/Action/Render.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Action/Render.hs @@ -0,0 +1,141 @@ +module CabalGild.Unstable.Action.Render where + +import qualified CabalGild.Unstable.Extra.FieldLine as FieldLine +import qualified CabalGild.Unstable.Extra.Name as Name +import qualified CabalGild.Unstable.Extra.SectionArg as SectionArg +import qualified CabalGild.Unstable.Type.Block as Block +import qualified CabalGild.Unstable.Type.Chunk as Chunk +import qualified CabalGild.Unstable.Type.Comment as Comment +import qualified CabalGild.Unstable.Type.Line as Line +import qualified Data.ByteString as ByteString +import qualified Data.Function as Function +import qualified Distribution.Compat.Lens as Lens +import qualified Distribution.Fields as Fields +import qualified Distribution.Parsec.Position as Position + +-- | A wrapper around 'toByteString' to allow this to be composed with other +-- actions. +run :: + (Applicative m) => + ([Fields.Field (Position.Position, [Comment.Comment p])], [Comment.Comment p]) -> + m ByteString.ByteString +run = pure . uncurry toByteString + +-- | Renders the given fields and comments to a byte string. +toByteString :: + [Fields.Field (Position.Position, [Comment.Comment p])] -> + [Comment.Comment p] -> + ByteString.ByteString +toByteString fs cs = + let i = 0 :: Int + in Block.toByteString + . Lens.set Block.lineBeforeLens False + . Lens.set Block.lineAfterLens True + $ fields i fs <> comments i cs + +-- | Renders the given fields to a block at the given indentation level. +fields :: Int -> [Fields.Field (Position.Position, [Comment.Comment p])] -> Block.Block +fields = foldMap . field + +-- | Renders the given field to a block at the given indentation level. +-- +-- If a field only has one line and no comments, then it can be rendered all on +-- one line. +field :: Int -> Fields.Field (Position.Position, [Comment.Comment p]) -> Block.Block +field i f = case f of + Fields.Field n fls -> case fls of + [fl] + | null . snd $ FieldLine.annotation fl, + sameRow (Name.annotation n) (FieldLine.annotation fl) -> + comments i (snd $ Name.annotation n) + <> ( Block.fromLine + . Lens.over Line.chunkLens (mappend $ name n <> Chunk.colon) + $ fieldLine i fl + ) + _ -> + Lens.set Block.lineAfterLens True $ + comments i (snd $ Name.annotation n) + <> Block.fromLine + Line.Line + { Line.indent = i, + Line.chunk = name n <> Chunk.colon + } + <> fieldLines (i + 1) fls + Fields.Section n sas fs -> + Lens.set Block.lineBeforeLens (not $ Name.isElif n || Name.isElse n) + . Lens.set Block.lineAfterLens (not $ Name.isIf n || Name.isElif n) + $ comments i (snd $ Name.annotation n) + <> comments i (concatMap (snd . SectionArg.annotation) sas) + <> Block.fromLine + Line.Line + { Line.indent = i, + Line.chunk = Lens.set Chunk.spaceAfterLens True (name n) <> sectionArgs sas + } + <> Lens.set Block.lineBeforeLens False (fields (i + 1) fs) + +-- | Returns true if the two positions are on the same row. +sameRow :: (Position.Position, cs) -> (Position.Position, cs) -> Bool +sameRow = Function.on (==) $ Position.positionRow . fst + +-- | Renders the given name to a chunk. +name :: Fields.Name a -> Chunk.Chunk +name = Chunk.fromByteString . Name.value + +-- | Renders the given field lines to a block at the given indentation level. +fieldLines :: Int -> [Fields.FieldLine (p, [Comment.Comment q])] -> Block.Block +fieldLines = foldMap . fieldLineC + +-- | Renders the given field line and its comments to a block at the given +-- indentation level. +fieldLineC :: Int -> Fields.FieldLine (p, [Comment.Comment q]) -> Block.Block +fieldLineC i fl = + comments i (snd $ FieldLine.annotation fl) + <> Block.fromLine (fieldLine i fl) + +-- | Renders the given field line to a line at the given indentation level. +fieldLine :: Int -> Fields.FieldLine a -> Line.Line +fieldLine i = + Line.Line i + . Lens.set Chunk.spaceBeforeLens True + . Chunk.fromByteString + . FieldLine.value + +-- | Renders the given section arguments to a chunk. Note that comments are +-- ignored. In practice this isn't a problem because section arguments can't +-- have comments attached anyway. +sectionArgs :: [Fields.SectionArg a] -> Chunk.Chunk +sectionArgs = Lens.set Chunk.spaceBeforeLens True . foldMap sectionArg + +-- | Renders the given section argument to a chunk. +sectionArg :: Fields.SectionArg a -> Chunk.Chunk +sectionArg sa = case sa of + Fields.SecArgName _ bs -> + Lens.set Chunk.spaceBeforeLens True + . Lens.set Chunk.spaceAfterLens True + $ Chunk.fromByteString bs + Fields.SecArgStr _ bs -> + Lens.set Chunk.spaceBeforeLens True + . Lens.set Chunk.spaceAfterLens True + . Chunk.fromByteString + . flip ByteString.snoc 0x22 + $ ByteString.cons 0x22 bs + Fields.SecArgOther _ bs -> + let b = + bs /= ByteString.singleton 0x21 -- ! + && bs /= ByteString.singleton 0x28 -- ( + && bs /= ByteString.singleton 0x29 -- ) + in Lens.set Chunk.spaceBeforeLens b + . Lens.set Chunk.spaceAfterLens b + $ Chunk.fromByteString bs + +-- | Renders the given comments to a block at the given indentation level. +comments :: Int -> [Comment.Comment a] -> Block.Block +comments i cs = mempty {Block.lines = fmap (comment i) cs} + +-- | Renders the given comment to a line at the given indentation level. +comment :: Int -> Comment.Comment a -> Line.Line +comment i = + Line.Line i + . Chunk.fromByteString + . mappend Comment.delimiter + . Comment.value diff --git a/source/library/CabalGild/Unstable/Action/StripBlanks.hs b/source/library/CabalGild/Unstable/Action/StripBlanks.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Action/StripBlanks.hs @@ -0,0 +1,41 @@ +module CabalGild.Unstable.Action.StripBlanks where + +import qualified Data.ByteString.Char8 as Latin1 +import qualified Distribution.Fields as Fields + +-- | High level wrapper around 'field' that makes this action easier to compose +-- with other actions. +run :: + (Applicative m) => + ([Fields.Field a], cs) -> + m ([Fields.Field a], cs) +run (fs, cs) = pure (fmap field fs, cs) + +-- | Strips blank space from the field recursively. In practice there should +-- not be any leading or trailing blank space to begin with. However the legacy +-- curly bracket syntax can introduce trailing blank space. For example with +-- @s { f : x }@ the field value will have a trailing space (@"x "@). +field :: Fields.Field a -> Fields.Field a +field f = case f of + Fields.Field n fls -> + Fields.Field (name n) (fmap fieldLine fls) + Fields.Section n sas fs -> + Fields.Section (name n) (fmap sectionArg sas) (fmap field fs) + +-- | Strips blank space from the field's name. +name :: Fields.Name a -> Fields.Name a +name (Fields.Name a bs) = Fields.Name a (Latin1.strip bs) + +-- | Strips blank space from the field line. +fieldLine :: Fields.FieldLine a -> Fields.FieldLine a +fieldLine (Fields.FieldLine a bs) = Fields.FieldLine a (Latin1.strip bs) + +-- | Strips blank space from the section argument. +sectionArg :: Fields.SectionArg a -> Fields.SectionArg a +sectionArg sa = case sa of + Fields.SecArgName a bs -> + Fields.SecArgName a (Latin1.strip bs) + Fields.SecArgStr a bs -> + Fields.SecArgStr a (Latin1.strip bs) + Fields.SecArgOther a bs -> + Fields.SecArgOther a (Latin1.strip bs) diff --git a/source/library/CabalGild/Unstable/Class/MonadLog.hs b/source/library/CabalGild/Unstable/Class/MonadLog.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Class/MonadLog.hs @@ -0,0 +1,10 @@ +module CabalGild.Unstable.Class.MonadLog where + +-- | A 'Monad' that can also log messages. +class (Monad m) => MonadLog m where + -- | Logs the given message followed by a newline. + logLn :: String -> m () + +-- | Uses 'putStrLn'. +instance MonadLog IO where + logLn = putStrLn diff --git a/source/library/CabalGild/Unstable/Class/MonadRead.hs b/source/library/CabalGild/Unstable/Class/MonadRead.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Class/MonadRead.hs @@ -0,0 +1,16 @@ +module CabalGild.Unstable.Class.MonadRead where + +import qualified CabalGild.Unstable.Type.Input as Input +import qualified Data.ByteString as ByteString + +-- | A 'Monad' that can also read input, either from standard input (STDIN) or +-- from a file. +class (Monad m) => MonadRead m where + -- | Reads input from the given 'Input.Input'. + read :: Input.Input -> m ByteString.ByteString + +-- | Uses 'ByteString.getContents' or 'ByteString.readFile'. +instance MonadRead IO where + read i = case i of + Input.Stdin -> ByteString.getContents + Input.File f -> ByteString.readFile f diff --git a/source/library/CabalGild/Unstable/Class/MonadWalk.hs b/source/library/CabalGild/Unstable/Class/MonadWalk.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Class/MonadWalk.hs @@ -0,0 +1,28 @@ +module CabalGild.Unstable.Class.MonadWalk where + +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath + +-- | A 'Monad' that can also walk the file system. +class (Monad m) => MonadWalk m where + -- | Lists all files in the given directory and its subdirectories + -- recursively. + walk :: FilePath -> m [FilePath] + +-- | Uses 'listDirectoryRecursively'. +instance MonadWalk IO where + walk = listDirectoryRecursively + +-- | Lists all files in the given directory and its subdirectories recursively. +-- The order is not guaranteed and may change between different calls. It's +-- also not specified if the results are breadth-first or depth-first. +listDirectoryRecursively :: FilePath -> IO [FilePath] +listDirectoryRecursively d = do + es <- Directory.listDirectory d + let f e = do + let p = FilePath.combine d e + b <- Directory.doesDirectoryExist p + if b + then listDirectoryRecursively p + else pure [p] + mconcat <$> traverse f es diff --git a/source/library/CabalGild/Unstable/Class/MonadWrite.hs b/source/library/CabalGild/Unstable/Class/MonadWrite.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Class/MonadWrite.hs @@ -0,0 +1,16 @@ +module CabalGild.Unstable.Class.MonadWrite where + +import qualified CabalGild.Unstable.Type.Output as Output +import qualified Data.ByteString as ByteString + +-- | A 'Monad' that can also write output, either to standard output (STDOUT) +-- or to a file. +class (Monad m) => MonadWrite m where + -- | Writes output to the given 'Output.Output'. + write :: Output.Output -> ByteString.ByteString -> m () + +-- | Uses 'ByteString.putStr' or 'ByteString.writeFile'. +instance MonadWrite IO where + write o = case o of + Output.Stdout -> ByteString.putStr + Output.File f -> ByteString.writeFile f diff --git a/source/library/CabalGild/Unstable/Exception/CheckFailure.hs b/source/library/CabalGild/Unstable/Exception/CheckFailure.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Exception/CheckFailure.hs @@ -0,0 +1,11 @@ +module CabalGild.Unstable.Exception.CheckFailure where + +import qualified Control.Monad.Catch as Exception + +-- | This exception is thrown when the input is not formatted correctly. +data CheckFailure + = CheckFailure + deriving (Eq, Show) + +instance Exception.Exception CheckFailure where + displayException = const "input is not formatted" diff --git a/source/library/CabalGild/Unstable/Exception/InvalidLeniency.hs b/source/library/CabalGild/Unstable/Exception/InvalidLeniency.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Exception/InvalidLeniency.hs @@ -0,0 +1,16 @@ +module CabalGild.Unstable.Exception.InvalidLeniency where + +import qualified Control.Monad.Catch as Exception + +-- | This exception is thrown when the given +-- 'CabalGild.Type.Leniency.Leniency' is invalid. +newtype InvalidLeniency + = InvalidLeniency String + deriving (Eq, Show) + +instance Exception.Exception InvalidLeniency where + displayException (InvalidLeniency s) = "invalid leniency: " <> s + +-- | Constructs an 'InvalidLeniency' from the given 'String'. +fromString :: String -> InvalidLeniency +fromString = InvalidLeniency diff --git a/source/library/CabalGild/Unstable/Exception/InvalidMode.hs b/source/library/CabalGild/Unstable/Exception/InvalidMode.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Exception/InvalidMode.hs @@ -0,0 +1,16 @@ +module CabalGild.Unstable.Exception.InvalidMode where + +import qualified Control.Monad.Catch as Exception + +-- | This exception is thrown when the given 'CabalGild.Type.Mode.Mode' is +-- invalid. +newtype InvalidMode + = InvalidMode String + deriving (Eq, Show) + +instance Exception.Exception InvalidMode where + displayException (InvalidMode s) = "invalid mode: " <> s + +-- | Constructs an 'InvalidMode' from the given 'String'. +fromString :: String -> InvalidMode +fromString = InvalidMode diff --git a/source/library/CabalGild/Unstable/Exception/InvalidOption.hs b/source/library/CabalGild/Unstable/Exception/InvalidOption.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Exception/InvalidOption.hs @@ -0,0 +1,17 @@ +module CabalGild.Unstable.Exception.InvalidOption where + +import qualified Control.Monad.Catch as Exception +import qualified Data.Char as Char +import qualified Data.List as List + +-- | This exception is thrown when a command line option is invalid. +newtype InvalidOption + = InvalidOption String + deriving (Eq, Show) + +instance Exception.Exception InvalidOption where + displayException (InvalidOption s) = "invalid option: " <> s + +-- | Constructs an 'InvalidOption' from the given 'String'. +fromString :: String -> InvalidOption +fromString = InvalidOption . List.dropWhileEnd Char.isSpace diff --git a/source/library/CabalGild/Unstable/Exception/ParseError.hs b/source/library/CabalGild/Unstable/Exception/ParseError.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Exception/ParseError.hs @@ -0,0 +1,15 @@ +module CabalGild.Unstable.Exception.ParseError where + +import qualified Control.Monad.Catch as Exception +import qualified Text.Parsec.Error as Parsec + +-- | This type only exists to add an 'Exception.Exception' instance to the +-- 'Parsec.ParseError' type. That instance was added in @parsec-3.1.17.0@. See: +-- . +newtype ParseError = ParseError + { unwrap :: Parsec.ParseError + } + deriving (Eq, Show) + +instance Exception.Exception ParseError where + displayException = mappend "parse error: " . show . unwrap diff --git a/source/library/CabalGild/Unstable/Exception/SpecifiedCrlfWithFormatMode.hs b/source/library/CabalGild/Unstable/Exception/SpecifiedCrlfWithFormatMode.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Exception/SpecifiedCrlfWithFormatMode.hs @@ -0,0 +1,13 @@ +module CabalGild.Unstable.Exception.SpecifiedCrlfWithFormatMode where + +import qualified Control.Monad.Catch as Exception + +-- | This exception is thrown when the user specifies the CRLF leniency while +-- using the format mode. In other words, when @--mode=format@ and +-- @--crlf=anything@. +data SpecifiedCrlfWithFormatMode + = SpecifiedCrlfWithFormatMode + deriving (Eq, Show) + +instance Exception.Exception SpecifiedCrlfWithFormatMode where + displayException = const "cannot use --crlf when --mode is format" diff --git a/source/library/CabalGild/Unstable/Exception/SpecifiedOutputWithCheckMode.hs b/source/library/CabalGild/Unstable/Exception/SpecifiedOutputWithCheckMode.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Exception/SpecifiedOutputWithCheckMode.hs @@ -0,0 +1,12 @@ +module CabalGild.Unstable.Exception.SpecifiedOutputWithCheckMode where + +import qualified Control.Monad.Catch as Exception + +-- | This exception is thrown when the user specifies the output while using +-- the check mode. In other words, when @--mode=check@ and @--output=anything@. +data SpecifiedOutputWithCheckMode + = SpecifiedOutputWithCheckMode + deriving (Eq, Show) + +instance Exception.Exception SpecifiedOutputWithCheckMode where + displayException = const "cannot use --output when --mode is check" diff --git a/source/library/CabalGild/Unstable/Exception/SpecifiedStdinWithFileInput.hs b/source/library/CabalGild/Unstable/Exception/SpecifiedStdinWithFileInput.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Exception/SpecifiedStdinWithFileInput.hs @@ -0,0 +1,13 @@ +module CabalGild.Unstable.Exception.SpecifiedStdinWithFileInput where + +import qualified Control.Monad.Catch as Exception + +-- | This exception is thrown when the user specifies the STDIN name while +-- using an input file. In other words, when @--input=file@ and +-- @--stdin=anything@. +data SpecifiedStdinWithFileInput + = SpecifiedStdinWithFileInput + deriving (Eq, Show) + +instance Exception.Exception SpecifiedStdinWithFileInput where + displayException = const "cannot use --stdin when --input is a file" diff --git a/source/library/CabalGild/Unstable/Exception/UnexpectedArgument.hs b/source/library/CabalGild/Unstable/Exception/UnexpectedArgument.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Exception/UnexpectedArgument.hs @@ -0,0 +1,16 @@ +module CabalGild.Unstable.Exception.UnexpectedArgument where + +import qualified Control.Monad.Catch as Exception + +-- | This exception is thrown when an unexpected command line argument is +-- encountered. +newtype UnexpectedArgument + = UnexpectedArgument String + deriving (Eq, Show) + +instance Exception.Exception UnexpectedArgument where + displayException (UnexpectedArgument s) = "unexpected argument: " <> s + +-- | Constructs an 'UnexpectedArgument' from the given 'String'. +fromString :: String -> UnexpectedArgument +fromString = UnexpectedArgument diff --git a/source/library/CabalGild/Unstable/Exception/UnknownOption.hs b/source/library/CabalGild/Unstable/Exception/UnknownOption.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Exception/UnknownOption.hs @@ -0,0 +1,15 @@ +module CabalGild.Unstable.Exception.UnknownOption where + +import qualified Control.Monad.Catch as Exception + +-- | This exception is thrown when a command line option is not known. +newtype UnknownOption + = UnknownOption String + deriving (Eq, Show) + +instance Exception.Exception UnknownOption where + displayException (UnknownOption s) = "unknown option: " <> s + +-- | Constructs an 'UnknownOption' from the given 'String'. +fromString :: String -> UnknownOption +fromString = UnknownOption diff --git a/source/library/CabalGild/Unstable/Extra/ByteString.hs b/source/library/CabalGild/Unstable/Extra/ByteString.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Extra/ByteString.hs @@ -0,0 +1,32 @@ +module CabalGild.Unstable.Extra.ByteString where + +import qualified Data.ByteString as ByteString + +-- | Calling @replace needle replacement haystack@ will replace every +-- non-overlapping occurrence of @needle@ in @haystack@ with @replacement@. +-- +-- +replace :: + ByteString.ByteString -> + ByteString.ByteString -> + ByteString.ByteString -> + ByteString.ByteString +replace needle replacement = ByteString.intercalate replacement . splitOn needle + +-- | Calling @splitOn needle haystack@ will split @haystack@ into a list of +-- substrings using @needle@ as the delimiter. +-- +-- +splitOn :: + ByteString.ByteString -> + ByteString.ByteString -> + [ByteString.ByteString] +splitOn needle = + let split = ByteString.breakSubstring needle + go haystack = + let (before, after) = split haystack + in before + : if ByteString.null after + then [] + else go (ByteString.drop (ByteString.length needle) after) + in go diff --git a/source/library/CabalGild/Unstable/Extra/Either.hs b/source/library/CabalGild/Unstable/Extra/Either.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Extra/Either.hs @@ -0,0 +1,5 @@ +module CabalGild.Unstable.Extra.Either where + +-- | Converts an 'Either' to a 'Maybe'. +hush :: Either x a -> Maybe a +hush = either (const Nothing) Just diff --git a/source/library/CabalGild/Unstable/Extra/Field.hs b/source/library/CabalGild/Unstable/Extra/Field.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Extra/Field.hs @@ -0,0 +1,9 @@ +module CabalGild.Unstable.Extra.Field where + +import qualified Distribution.Fields as Fields + +-- | Extracts the name of a 'Fields.Field'. +name :: Fields.Field a -> Fields.Name a +name f = case f of + Fields.Field n _ -> n + Fields.Section n _ _ -> n diff --git a/source/library/CabalGild/Unstable/Extra/FieldLine.hs b/source/library/CabalGild/Unstable/Extra/FieldLine.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Extra/FieldLine.hs @@ -0,0 +1,21 @@ +module CabalGild.Unstable.Extra.FieldLine where + +import qualified Data.ByteString as ByteString +import qualified Distribution.Fields as Fields +import qualified Distribution.Parsec.FieldLineStream as FieldLineStream + +-- | Extracts the annotation of a 'Fields.FieldLine'. +annotation :: Fields.FieldLine a -> a +annotation (Fields.FieldLine x _) = x + +-- | Extracts the value of a 'Fields.FieldLine'. +value :: Fields.FieldLine a -> ByteString.ByteString +value (Fields.FieldLine _ x) = x + +-- | Converts a list of 'Fields.FieldLine's into a +-- 'FieldLineStream.FieldLineStream'. +toFieldLineStream :: [Fields.FieldLine a] -> FieldLineStream.FieldLineStream +toFieldLineStream fls = case fls of + [] -> FieldLineStream.FLSLast ByteString.empty + [x] -> FieldLineStream.FLSLast $ value x + x : xs -> FieldLineStream.FLSCons (value x) $ toFieldLineStream xs diff --git a/source/library/CabalGild/Unstable/Extra/List.hs b/source/library/CabalGild/Unstable/Extra/List.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Extra/List.hs @@ -0,0 +1,12 @@ +module CabalGild.Unstable.Extra.List where + +-- | Compares the length of the given list to the given integer. This is +-- equivalent to @compare (length xs) n@, but it can be more efficient if @n@ +-- is less than @length xs@. +compareLength :: [a] -> Int -> Ordering +compareLength xs n = + if n < 0 + then GT + else case xs of + [] -> compare 0 n + _ : ys -> compareLength ys $ n - 1 diff --git a/source/library/CabalGild/Unstable/Extra/ModuleName.hs b/source/library/CabalGild/Unstable/Extra/ModuleName.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Extra/ModuleName.hs @@ -0,0 +1,17 @@ +module CabalGild.Unstable.Extra.ModuleName where + +import qualified CabalGild.Unstable.Extra.String as String +import qualified Data.List as List +import qualified Distribution.Fields as Fields +import qualified Distribution.ModuleName as ModuleName +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified System.FilePath as FilePath + +-- | Parses a 'FilePath' as a 'ModuleName.ModuleName'. +fromFilePath :: FilePath -> Maybe ModuleName.ModuleName +fromFilePath = Parsec.simpleParsec . List.intercalate "." . FilePath.splitDirectories + +-- | Converts a 'ModuleName.ModuleName' into a 'Fields.FieldLine'. +toFieldLine :: a -> ModuleName.ModuleName -> Fields.FieldLine a +toFieldLine a = Fields.FieldLine a . String.toUtf8 . Pretty.prettyShow diff --git a/source/library/CabalGild/Unstable/Extra/Name.hs b/source/library/CabalGild/Unstable/Extra/Name.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Extra/Name.hs @@ -0,0 +1,29 @@ +module CabalGild.Unstable.Extra.Name where + +import qualified CabalGild.Unstable.Extra.String as String +import qualified Distribution.Compat.Lens as Lens +import qualified Distribution.Fields as Fields + +-- | Extracts the annotation from the given 'Fields.Name'. +annotation :: Fields.Name a -> a +annotation (Fields.Name x _) = x + +-- | A lens for the 'annotation'. +annotationLens :: Lens.Lens' (Fields.Name a) a +annotationLens f s = fmap (\a -> Fields.Name a $ value s) . f $ annotation s + +-- | Extracts the value from the given 'Fields.Name'. +value :: Fields.Name a -> Fields.FieldName +value (Fields.Name _ x) = x + +-- | Returns true when the name is @"if"@, false otherwise. +isIf :: Fields.Name a -> Bool +isIf = (== String.toUtf8 "if") . value + +-- | Returns true when the name is @"elif"@, false otherwise. +isElif :: Fields.Name a -> Bool +isElif = (== String.toUtf8 "elif") . value + +-- | Returns true when the name is @"else"@, false otherwise. +isElse :: Fields.Name a -> Bool +isElse = (== String.toUtf8 "else") . value diff --git a/source/library/CabalGild/Unstable/Extra/SectionArg.hs b/source/library/CabalGild/Unstable/Extra/SectionArg.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Extra/SectionArg.hs @@ -0,0 +1,10 @@ +module CabalGild.Unstable.Extra.SectionArg where + +import qualified Distribution.Fields as Fields + +-- | Extracts the annotation from the given 'Fields.SectionArg'. +annotation :: Fields.SectionArg a -> a +annotation sa = case sa of + Fields.SecArgName x _ -> x + Fields.SecArgStr x _ -> x + Fields.SecArgOther x _ -> x diff --git a/source/library/CabalGild/Unstable/Extra/String.hs b/source/library/CabalGild/Unstable/Extra/String.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Extra/String.hs @@ -0,0 +1,9 @@ +module CabalGild.Unstable.Extra.String where + +import qualified Data.ByteString as ByteString +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Encoding + +-- | Converts the given 'String' into a UTF-8 encoded 'ByteString.ByteString'. +toUtf8 :: String -> ByteString.ByteString +toUtf8 = Encoding.encodeUtf8 . Text.pack diff --git a/source/library/CabalGild/Unstable/Main.hs b/source/library/CabalGild/Unstable/Main.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Main.hs @@ -0,0 +1,115 @@ +-- | This module defines the main entry point for the application. +module CabalGild.Unstable.Main where + +import qualified CabalGild.Unstable.Action.AttachComments as AttachComments +import qualified CabalGild.Unstable.Action.EvaluatePragmas as EvaluatePragmas +import qualified CabalGild.Unstable.Action.ExtractComments as ExtractComments +import qualified CabalGild.Unstable.Action.FormatFields as FormatFields +import qualified CabalGild.Unstable.Action.GetCabalVersion as GetCabalVersion +import qualified CabalGild.Unstable.Action.ReflowText as ReflowText +import qualified CabalGild.Unstable.Action.Render as Render +import qualified CabalGild.Unstable.Action.StripBlanks as StripBlanks +import qualified CabalGild.Unstable.Class.MonadLog as MonadLog +import qualified CabalGild.Unstable.Class.MonadRead as MonadRead +import qualified CabalGild.Unstable.Class.MonadWalk as MonadWalk +import qualified CabalGild.Unstable.Class.MonadWrite as MonadWrite +import qualified CabalGild.Unstable.Exception.CheckFailure as CheckFailure +import qualified CabalGild.Unstable.Exception.ParseError as ParseError +import qualified CabalGild.Unstable.Extra.ByteString as ByteString +import qualified CabalGild.Unstable.Type.Config as Config +import qualified CabalGild.Unstable.Type.Context as Context +import qualified CabalGild.Unstable.Type.Flag as Flag +import qualified CabalGild.Unstable.Type.Input as Input +import qualified CabalGild.Unstable.Type.Leniency as Leniency +import qualified CabalGild.Unstable.Type.Mode as Mode +import qualified CabalGild.Unstable.Type.Output as Output +import qualified Control.Monad as Monad +import qualified Control.Monad.Catch as Exception +import qualified Data.ByteString as ByteString +import qualified Distribution.Fields as Fields +import qualified System.Environment as Environment +import qualified System.Exit as Exit +import qualified System.IO as IO + +-- | This is the main entry point for the application. It gets the command line +-- arguments and then hands things off to 'mainWith'. If any exceptions are +-- thrown, they will be handled by 'onException'. +defaultMain :: IO () +defaultMain = Exception.handle onException $ do + arguments <- Environment.getArgs + mainWith arguments + +-- | If the exception was an 'Exit.ExitCode', simply exit with that code. +-- Otherwise handle exceptions by printing them to STDERR using +-- 'Exception.displayException' instead of 'show'. Then exit with a failing +-- status code. +onException :: Exception.SomeException -> IO a +onException e = case Exception.fromException e of + Just exitCode -> Exit.exitWith exitCode + Nothing -> do + IO.hPutStrLn IO.stderr $ Exception.displayException e + Exit.exitFailure + +-- | The actual logic for the command line application. This is written using +-- constraints so that it can be run in pure code if so desired. But most often +-- this will be run in 'IO'. +mainWith :: + ( MonadLog.MonadLog m, + MonadRead.MonadRead m, + Exception.MonadThrow m, + MonadWalk.MonadWalk m, + MonadWrite.MonadWrite m + ) => + [String] -> + m () +mainWith arguments = do + flags <- Flag.fromArguments arguments + config <- Config.fromFlags flags + context <- Context.fromConfig config + + input <- MonadRead.read $ Context.input context + output <- format (Context.stdin context) input + + let formatted = check (Context.crlf context) input output + case Context.mode context of + Mode.Check -> Monad.unless formatted $ Exception.throwM CheckFailure.CheckFailure + Mode.Format -> case (Context.input context, Context.output context) of + (Input.File i, Output.File o) | formatted, i == o -> pure () + (_, o) -> MonadWrite.write o output + +-- | Formats the given input using the provided file path as the apparent +-- source file (see 'Context.stdin'). An exception will be thrown if the input +-- is invalid. The 'MonadWalk.MonadWalk' constraint is used to discover modules +-- on the file system. Typically @m@ will be 'IO'. +format :: + (Exception.MonadThrow m, MonadWalk.MonadWalk m) => + FilePath -> + ByteString.ByteString -> + m ByteString.ByteString +format filePath input = do + fields <- + either (Exception.throwM . ParseError.ParseError) pure $ + Fields.readFields input + let csv = GetCabalVersion.fromFields fields + comments = ExtractComments.fromByteString input + ( StripBlanks.run + Monad.>=> AttachComments.run + Monad.>=> ReflowText.run csv + Monad.>=> EvaluatePragmas.run filePath + Monad.>=> FormatFields.run csv + Monad.>=> Render.run + ) + (fields, comments) + +-- | Returns true if the output is formatted correctly, false otherwise. +check :: + Leniency.Leniency -> + ByteString.ByteString -> + ByteString.ByteString -> + Bool +check leniency input output = case leniency of + Leniency.Lenient -> + let lf = ByteString.singleton 0x0a + crlf = ByteString.cons 0x0d lf + in output == ByteString.replace crlf lf input + Leniency.Strict -> output == input diff --git a/source/library/CabalGild/Unstable/Type/Block.hs b/source/library/CabalGild/Unstable/Type/Block.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Block.hs @@ -0,0 +1,73 @@ +-- | This module defines the 'Block' data type. +module CabalGild.Unstable.Type.Block where + +import qualified CabalGild.Unstable.Type.Line as Line +import qualified Data.ByteString as ByteString +import qualified Distribution.Compat.Lens as Lens +import Prelude hiding (lines) + +-- | A block of text, which is made up of multiple lines and can have blank +-- lines before and/or after it. +data Block = Block + { -- | Does this block have a blank line before it? + lineBefore :: Bool, + lines :: [Line.Line], + -- | Does this block have a blank line after it? + lineAfter :: Bool + } + deriving (Eq, Show) + +-- | Joins two blocks together by adding a blank line between them if +-- necessary. (A blank line is necessary if /either/ block needs a space.) If +-- either block is empty, the other block is returned. +instance Semigroup Block where + x <> y = + let s = [Line.empty | lineAfter x || lineBefore y] + z = + Block + { lineBefore = lineBefore x, + lines = lines x <> s <> lines y, + lineAfter = lineAfter y + } + in if isEmpty x then y else if isEmpty y then x else z + +-- | The empty block has no lines and also no blank lines before or after. +instance Monoid Block where + mempty = + Block + { lineBefore = False, + lines = [], + lineAfter = False + } + +-- | Converts a single line into a block without blank lines before or after. +fromLine :: Line.Line -> Block +fromLine l = mempty {lines = [l]} + +-- | Returns 'True' if the block has no lines. +isEmpty :: Block -> Bool +isEmpty = null . lines + +-- | A lens for the 'lineAfter' field. +lineAfterLens :: Lens.Lens' Block Bool +lineAfterLens f s = fmap (\a -> s {lineAfter = a}) . f $ lineAfter s + +-- | A lens for the 'lineBefore' field. +lineBeforeLens :: Lens.Lens' Block Bool +lineBeforeLens f s = fmap (\a -> s {lineBefore = a}) . f $ lineBefore s + +-- | Converts a block into a 'ByteString.ByteString' by joining the lines +-- together with newline characters. Note that unline 'unlines', there will be +-- no trailing newline unless 'lineAfter' is 'True'. +toByteString :: Block -> ByteString.ByteString +toByteString b = + if isEmpty b + then ByteString.empty + else + ByteString.intercalate (ByteString.singleton 0x0a) + . fmap Line.toByteString + $ concat + [ [Line.empty | lineBefore b], + lines b, + [Line.empty | lineAfter b] + ] diff --git a/source/library/CabalGild/Unstable/Type/Chunk.hs b/source/library/CabalGild/Unstable/Type/Chunk.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Chunk.hs @@ -0,0 +1,62 @@ +-- | This module defines the 'Chunk' data type. +module CabalGild.Unstable.Type.Chunk where + +import qualified Data.ByteString as ByteString +import qualified Distribution.Compat.Lens as Lens + +-- | A chunk of text, which is made up of a byte string and can have blank +-- spaces before and/or after it. +data Chunk = Chunk + { -- | Does this chunk have a blank space before it? + spaceBefore :: Bool, + value :: ByteString.ByteString, + -- | Does this chunk have a blank space after it? + spaceAfter :: Bool + } + deriving (Eq, Show) + +-- | Joins two chunks together by adding a blank space between them if +-- necessary. (A blank space is necessary if /both/ chunks need a space.) If +-- either chunk is empty, the other chunk is returned. +instance Semigroup Chunk where + x <> y = + let s = + if spaceAfter x && spaceBefore y + then ByteString.singleton 0x20 + else ByteString.empty + z = + Chunk + { spaceBefore = spaceBefore x, + value = value x <> s <> value y, + spaceAfter = spaceAfter y + } + in if isEmpty x then y else if isEmpty y then x else z + +-- | The empty chunk has no value and also no blank spaces before or after. +instance Monoid Chunk where + mempty = + Chunk + { spaceBefore = False, + value = ByteString.empty, + spaceAfter = False + } + +-- | A colon with a space after. +colon :: Chunk +colon = Lens.set spaceAfterLens True . fromByteString $ ByteString.singleton 0x3a + +-- | Converts a byte string into a chunk without blank spaces before or after. +fromByteString :: ByteString.ByteString -> Chunk +fromByteString bs = mempty {value = bs} + +-- | Returns 'True' if the chunk's byte string is empty. +isEmpty :: Chunk -> Bool +isEmpty = ByteString.null . value + +-- | A lens for the 'spaceAfter' field. +spaceAfterLens :: Lens.Lens' Chunk Bool +spaceAfterLens f s = fmap (\a -> s {spaceAfter = a}) . f $ spaceAfter s + +-- | A lens for the 'spaceBefore' field. +spaceBeforeLens :: Lens.Lens' Chunk Bool +spaceBeforeLens f s = fmap (\a -> s {spaceBefore = a}) . f $ spaceBefore s diff --git a/source/library/CabalGild/Unstable/Type/Comment.hs b/source/library/CabalGild/Unstable/Type/Comment.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Comment.hs @@ -0,0 +1,18 @@ +-- | This module defines the 'Comment' data type. +module CabalGild.Unstable.Type.Comment where + +import qualified CabalGild.Unstable.Extra.String as String +import qualified Data.ByteString as ByteString + +-- | A comment with corresponding annotation. Leading blank space is preserved, +-- but trailing blank space is not. +data Comment a = Comment + { annotation :: a, + -- | Does /not/ include the 'delimiter'. + value :: ByteString.ByteString + } + deriving (Eq, Show) + +-- | The start of a comment, which is @--@. +delimiter :: ByteString.ByteString +delimiter = String.toUtf8 "--" diff --git a/source/library/CabalGild/Unstable/Type/Config.hs b/source/library/CabalGild/Unstable/Type/Config.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Config.hs @@ -0,0 +1,63 @@ +-- | This module defines the 'Config' data type. +module CabalGild.Unstable.Type.Config where + +import qualified CabalGild.Unstable.Type.Flag as Flag +import qualified CabalGild.Unstable.Type.Input as Input +import qualified CabalGild.Unstable.Type.Leniency as Leniency +import qualified CabalGild.Unstable.Type.Mode as Mode +import qualified CabalGild.Unstable.Type.Optional as Optional +import qualified CabalGild.Unstable.Type.Output as Output +import qualified Control.Monad as Monad +import qualified Control.Monad.Catch as Exception + +-- | This data type represents the configuration for the command line utility. +-- Each field typically corresponds to a flag. +data Config = Config + { crlf :: Optional.Optional Leniency.Leniency, + help :: Optional.Optional Bool, + input :: Optional.Optional Input.Input, + mode :: Optional.Optional Mode.Mode, + output :: Optional.Optional Output.Output, + stdin :: Optional.Optional FilePath, + version :: Optional.Optional Bool + } + deriving (Eq, Show) + +-- | The default config. +initial :: Config +initial = + Config + { crlf = Optional.Default, + help = Optional.Default, + input = Optional.Default, + mode = Optional.Default, + output = Optional.Default, + stdin = Optional.Default, + version = Optional.Default + } + +-- | Applies a flag to the config, returning the new config. +applyFlag :: (Exception.MonadThrow m) => Config -> Flag.Flag -> m Config +applyFlag config flag = case flag of + Flag.CRLF s -> do + l <- Leniency.fromString s + pure config {crlf = Optional.Specific l} + Flag.Help b -> pure config {help = Optional.Specific b} + Flag.Input s -> pure config {input = Optional.Specific $ Input.fromString s} + Flag.IO s -> + pure + config + { input = Optional.Specific $ Input.fromString s, + output = Optional.Specific $ Output.fromString s + } + Flag.Mode s -> do + m <- Mode.fromString s + pure config {mode = Optional.Specific m} + Flag.Output s -> pure config {output = Optional.Specific $ Output.fromString s} + Flag.Stdin s -> pure config {stdin = Optional.Specific s} + Flag.Version b -> pure config {version = Optional.Specific b} + +-- | Converts a list of flags into a config by starting with 'initial' and +-- repeatedly calling 'applyFlag'. +fromFlags :: (Exception.MonadThrow m) => [Flag.Flag] -> m Config +fromFlags = Monad.foldM applyFlag initial diff --git a/source/library/CabalGild/Unstable/Type/Context.hs b/source/library/CabalGild/Unstable/Type/Context.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Context.hs @@ -0,0 +1,87 @@ +module CabalGild.Unstable.Type.Context where + +import qualified CabalGild.Unstable.Class.MonadLog as MonadLog +import qualified CabalGild.Unstable.Exception.SpecifiedCrlfWithFormatMode as SpecifiedCrlfWithFormatMode +import qualified CabalGild.Unstable.Exception.SpecifiedOutputWithCheckMode as SpecifiedOutputWithCheckMode +import qualified CabalGild.Unstable.Exception.SpecifiedStdinWithFileInput as SpecifiedStdinWithFileInput +import qualified CabalGild.Unstable.Type.Config as Config +import qualified CabalGild.Unstable.Type.Flag as Flag +import qualified CabalGild.Unstable.Type.Input as Input +import qualified CabalGild.Unstable.Type.Leniency as Leniency +import qualified CabalGild.Unstable.Type.Mode as Mode +import qualified CabalGild.Unstable.Type.Optional as Optional +import qualified CabalGild.Unstable.Type.Output as Output +import qualified Control.Monad as Monad +import qualified Control.Monad.Catch as Exception +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Version as Version +import qualified Paths_cabal_gild as This +import qualified System.Console.GetOpt as GetOpt +import qualified System.Exit as Exit + +-- | Represents the context necessary to run the program. This is essentially a +-- simplified 'Config.Config'. +data Context = Context + { crlf :: Leniency.Leniency, + input :: Input.Input, + mode :: Mode.Mode, + output :: Output.Output, + stdin :: FilePath + } + deriving (Eq, Show) + +-- | Creates a 'Context' from a 'Config.Config'. If the help or version was +-- requested, then this will throw an 'Exit.ExitSuccess'. Otherwise this makes +-- sure the config is valid before returning the context. +fromConfig :: + (MonadLog.MonadLog m, Exception.MonadThrow m) => + Config.Config -> + m Context +fromConfig config = do + let version = Version.showVersion This.version + + Monad.when (Optional.withDefault False $ Config.help config) $ do + let header = + unlines + [ "cabal-gild version " <> version, + "", + "" + ] + MonadLog.logLn + . List.dropWhileEnd Char.isSpace + $ GetOpt.usageInfo header Flag.options + Exception.throwM Exit.ExitSuccess + + Monad.when (Optional.withDefault False $ Config.version config) $ do + MonadLog.logLn version + Exception.throwM Exit.ExitSuccess + + case (Config.input config, Config.stdin config) of + (Optional.Specific (Input.File _), Optional.Specific _) -> + Exception.throwM SpecifiedStdinWithFileInput.SpecifiedStdinWithFileInput + _ -> pure () + + case (Config.mode config, Config.output config) of + (Optional.Specific Mode.Check, Optional.Specific _) -> + Exception.throwM SpecifiedOutputWithCheckMode.SpecifiedOutputWithCheckMode + _ -> pure () + + case Config.crlf config of + Optional.Specific _ + | Config.mode config /= Optional.Specific Mode.Check -> + Exception.throwM SpecifiedCrlfWithFormatMode.SpecifiedCrlfWithFormatMode + _ -> pure () + + let theInput = Optional.withDefault Input.Stdin $ Config.input config + filePath = case theInput of + Input.Stdin -> "." + Input.File f -> f + pure + Context + { crlf = Optional.withDefault Leniency.Lenient $ Config.crlf config, + input = theInput, + mode = Optional.withDefault Mode.Format $ Config.mode config, + output = Optional.withDefault Output.Stdout $ Config.output config, + stdin = Optional.withDefault filePath $ Config.stdin config + } diff --git a/source/library/CabalGild/Unstable/Type/Dependency.hs b/source/library/CabalGild/Unstable/Type/Dependency.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Dependency.hs @@ -0,0 +1,26 @@ +module CabalGild.Unstable.Type.Dependency where + +import qualified CabalGild.Unstable.Type.VersionRange as VersionRange +import qualified Data.Ord as Ord +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Distribution.Types.Dependency as Dependency + +-- | This type exists to provide an 'Ord' instance for +-- 'Dependency.Dependency', which was added in @Cabal-syntax-3.10.1.0@. +newtype Dependency = Dependency + { unwrap :: Dependency.Dependency + } + deriving (Eq, Show) + +instance Ord Dependency where + compare = + Ord.comparing $ + (\(Dependency.Dependency pn vr lns) -> (pn, VersionRange.fromVersionRange vr, lns)) + . unwrap + +instance Parsec.Parsec Dependency where + parsec = Dependency <$> Parsec.parsec + +instance Pretty.Pretty Dependency where + pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Unstable/Type/ExeDependency.hs b/source/library/CabalGild/Unstable/Type/ExeDependency.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/ExeDependency.hs @@ -0,0 +1,26 @@ +module CabalGild.Unstable.Type.ExeDependency where + +import qualified CabalGild.Unstable.Type.VersionRange as VersionRange +import qualified Data.Ord as Ord +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Distribution.Types.ExeDependency as ExeDependency + +-- | This type exists to provide an 'Ord' instance for +-- 'ExeDependency.ExeDependency', which was added in @Cabal-syntax-3.10.1.0@. +newtype ExeDependency = ExeDependency + { unwrap :: ExeDependency.ExeDependency + } + deriving (Eq, Show) + +instance Ord ExeDependency where + compare = + Ord.comparing $ + (\(ExeDependency.ExeDependency pn ucn vr) -> (pn, ucn, VersionRange.fromVersionRange vr)) + . unwrap + +instance Parsec.Parsec ExeDependency where + parsec = ExeDependency <$> Parsec.parsec + +instance Pretty.Pretty ExeDependency where + pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Unstable/Type/Extension.hs b/source/library/CabalGild/Unstable/Type/Extension.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Extension.hs @@ -0,0 +1,23 @@ +module CabalGild.Unstable.Type.Extension where + +import qualified Data.Ord as Ord +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Language.Haskell.Extension as Extension + +-- | This type exists to provide a different 'Ord' instance for +-- 'Extension.Extension'. The instance provided by @Cabal-syntax@ sorts things +-- in a surprising order. This one sorts things alphabetically. +newtype Extension = Extension + { unwrap :: Extension.Extension + } + deriving (Eq, Show) + +instance Ord Extension where + compare = Ord.comparing Pretty.prettyShow + +instance Parsec.Parsec Extension where + parsec = Extension <$> Parsec.parsec + +instance Pretty.Pretty Extension where + pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Unstable/Type/Flag.hs b/source/library/CabalGild/Unstable/Type/Flag.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Flag.hs @@ -0,0 +1,88 @@ +module CabalGild.Unstable.Type.Flag where + +import qualified CabalGild.Unstable.Exception.InvalidOption as InvalidOption +import qualified CabalGild.Unstable.Exception.UnexpectedArgument as UnexpectedArgument +import qualified CabalGild.Unstable.Exception.UnknownOption as UnknownOption +import qualified Control.Monad.Catch as Exception +import qualified Data.Foldable as Foldable +import qualified System.Console.GetOpt as GetOpt + +-- | A flag, which represents a command line option. The values associated with +-- the flags are typically not parsed. These just handle the structure of +-- command line options. +data Flag + = CRLF String + | Help Bool + | Input String + | IO String + | Mode String + | Output String + | Stdin String + | Version Bool + deriving (Eq, Show) + +-- | The command line options the correspond to the flags. +options :: [GetOpt.OptDescr Flag] +options = + [ GetOpt.Option + ['h', '?'] + ["help"] + (GetOpt.NoArg $ Help True) + "Shows this help message.", + GetOpt.Option + [] + ["no-help"] + (GetOpt.NoArg $ Help False) + "", + GetOpt.Option + ['v'] + ["version"] + (GetOpt.NoArg $ Version True) + "Shows the version number.", + GetOpt.Option + [] + ["no-version"] + (GetOpt.NoArg $ Version False) + "", + GetOpt.Option + [] + ["crlf"] + (GetOpt.ReqArg CRLF "LENIENCY") + "Sets the CRLF handling mode. Must be either 'lenient' or 'strict'.\nDefault: 'lenient'", + GetOpt.Option + ['i'] + ["input"] + (GetOpt.ReqArg Input "FILE") + "Sets the input file. Use '-' for standard input (STDIN).\nDefault: '-'", + GetOpt.Option + [] + ["io"] + (GetOpt.ReqArg IO "FILE") + "Shortcut for setting both the input and output files.", + GetOpt.Option + ['m'] + ["mode"] + (GetOpt.ReqArg Mode "MODE") + "Sets the mode. Must be either 'check' or 'format'.\nDefault: 'format'", + GetOpt.Option + ['o'] + ["output"] + (GetOpt.ReqArg Output "FILE") + "Sets the output file. Use '-' for standard output (STDOUT).\nDefault: '-'", + GetOpt.Option + ['s'] + ["stdin"] + (GetOpt.ReqArg Stdin "FILE") + "Sets the path to the input file when using STDIN.\nDefault: '.'" + ] + +-- | Converts a list of command line arguments into a list of flags. If there +-- are any unexpected arguments, invalid options, or unknown options, an +-- exception will be thrown. +fromArguments :: (Exception.MonadThrow m) => [String] -> m [Flag] +fromArguments arguments = do + let (flgs, args, opts, errs) = GetOpt.getOpt' GetOpt.Permute options arguments + Foldable.traverse_ (Exception.throwM . UnexpectedArgument.fromString) args + Foldable.traverse_ (Exception.throwM . InvalidOption.fromString) errs + Foldable.traverse_ (Exception.throwM . UnknownOption.fromString) opts + pure flgs diff --git a/source/library/CabalGild/Unstable/Type/ForeignLibOption.hs b/source/library/CabalGild/Unstable/Type/ForeignLibOption.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/ForeignLibOption.hs @@ -0,0 +1,23 @@ +module CabalGild.Unstable.Type.ForeignLibOption where + +import qualified Data.Ord as Ord +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Distribution.Types.ForeignLibOption as ForeignLibOption + +-- | This type exists to provide an 'Ord' instance for +-- 'ForeignLibOption.ForeignLibOption', which was added in +-- @Cabal-syntax-3.10.1.0@. +newtype ForeignLibOption = ForeignLibOption + { unwrap :: ForeignLibOption.ForeignLibOption + } + deriving (Eq, Show) + +instance Ord ForeignLibOption where + compare = Ord.comparing Pretty.prettyShow + +instance Parsec.Parsec ForeignLibOption where + parsec = ForeignLibOption <$> Parsec.parsec + +instance Pretty.Pretty ForeignLibOption where + pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Unstable/Type/Input.hs b/source/library/CabalGild/Unstable/Type/Input.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Input.hs @@ -0,0 +1,15 @@ +module CabalGild.Unstable.Type.Input where + +-- | Represents an input stream, which can either be standard input (STDIN) or +-- a file. +data Input + = Stdin + | File FilePath + deriving (Eq, Ord, Show) + +-- | Converts a string into an input. The string @"-"@ will be converted into +-- 'Stdin', and any other string will be converted into 'File'. +fromString :: String -> Input +fromString s = case s of + "-" -> Stdin + _ -> File s diff --git a/source/library/CabalGild/Unstable/Type/Language.hs b/source/library/CabalGild/Unstable/Type/Language.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Language.hs @@ -0,0 +1,22 @@ +module CabalGild.Unstable.Type.Language where + +import qualified Data.Ord as Ord +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Language.Haskell.Extension as Extension + +-- | This type exists to provide an 'Ord' instance for +-- 'Language.Language', which was added in @Cabal-syntax-3.10.1.0@. +newtype Language = Language + { unwrap :: Extension.Language + } + deriving (Eq, Show) + +instance Ord Language where + compare = Ord.comparing Pretty.prettyShow + +instance Parsec.Parsec Language where + parsec = Language <$> Parsec.parsec + +instance Pretty.Pretty Language where + pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Unstable/Type/LegacyExeDependency.hs b/source/library/CabalGild/Unstable/Type/LegacyExeDependency.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/LegacyExeDependency.hs @@ -0,0 +1,27 @@ +module CabalGild.Unstable.Type.LegacyExeDependency where + +import qualified CabalGild.Unstable.Type.VersionRange as VersionRange +import qualified Data.Ord as Ord +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Distribution.Types.LegacyExeDependency as LegacyExeDependency + +-- | This type exists to provide an 'Ord' instance for +-- 'LegacyExeDependency.LegacyExeDependency', which was added in +-- @Cabal-syntax-3.10.1.0@. +newtype LegacyExeDependency = LegacyExeDependency + { unwrap :: LegacyExeDependency.LegacyExeDependency + } + deriving (Eq, Show) + +instance Ord LegacyExeDependency where + compare = + Ord.comparing $ + (\(LegacyExeDependency.LegacyExeDependency s vr) -> (s, VersionRange.fromVersionRange vr)) + . unwrap + +instance Parsec.Parsec LegacyExeDependency where + parsec = LegacyExeDependency <$> Parsec.parsec + +instance Pretty.Pretty LegacyExeDependency where + pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Unstable/Type/Leniency.hs b/source/library/CabalGild/Unstable/Type/Leniency.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Leniency.hs @@ -0,0 +1,18 @@ +module CabalGild.Unstable.Type.Leniency where + +import qualified CabalGild.Unstable.Exception.InvalidLeniency as InvalidLeniency +import qualified Control.Monad.Catch as Exception + +-- | Represents the leniency of a setting. In other words, should something be +-- lenient\/permissive or strict\/pedantic? +data Leniency + = Lenient + | Strict + deriving (Eq, Show) + +-- | Attempts to parse a string as a 'Leniency'. +fromString :: (Exception.MonadThrow m) => String -> m Leniency +fromString s = case s of + "lenient" -> pure Lenient + "strict" -> pure Strict + _ -> Exception.throwM $ InvalidLeniency.fromString s diff --git a/source/library/CabalGild/Unstable/Type/Line.hs b/source/library/CabalGild/Unstable/Type/Line.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Line.hs @@ -0,0 +1,39 @@ +module CabalGild.Unstable.Type.Line where + +import qualified CabalGild.Unstable.Type.Chunk as Chunk +import qualified Data.ByteString as ByteString +import qualified Distribution.Compat.Lens as Lens + +-- | A line of text, which is made up of a chunk and an indent level. +data Line = Line + { -- | Number of times the chunk should be indented. + indent :: Int, + chunk :: Chunk.Chunk + } + deriving (Eq, Show) + +-- | A lens for the 'chunk' field. +chunkLens :: Lens.Lens' Line Chunk.Chunk +chunkLens f s = fmap (\a -> s {chunk = a}) . f $ chunk s + +-- | An empty line, which is an empty chunk with no indentation. +empty :: Line +empty = + Line + { indent = 0, + chunk = mempty + } + +-- | Returns 'True' if the line's chunk is empty. +isEmpty :: Line -> Bool +isEmpty = Chunk.isEmpty . chunk + +-- | Converts a line to a 'ByteString' by indenting the chunk. +toByteString :: Line -> ByteString.ByteString +toByteString l = + if isEmpty l + then ByteString.empty + else + mappend (ByteString.replicate (2 * indent l) 0x20) + . Chunk.value + $ chunk l diff --git a/source/library/CabalGild/Unstable/Type/List.hs b/source/library/CabalGild/Unstable/Type/List.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/List.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module CabalGild.Unstable.Type.List where + +import qualified CabalGild.Unstable.Extra.List as List +import qualified Data.Proxy as Proxy +import qualified Distribution.CabalSpecVersion as CabalSpecVersion +import qualified Distribution.Compat.Newtype as Newtype +import qualified Distribution.FieldGrammar.Newtypes as Newtypes +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Text.PrettyPrint as PrettyPrint + +-- | A thin wrapper around 'Newtypes.List'. This is used to define custom +-- instances of 'Pretty.Pretty' that use trailing commas when the Cabal spec +-- version is recent enough (at least @2.2@). +newtype List s b a = List + { unwrap :: Newtypes.List s b a + } + +instance Newtype.Newtype [a] (List s b a) where + pack = List . Newtype.pack + unpack = Newtype.unpack . unwrap + +instance + ( Newtype.Newtype a b, + Parsec.Parsec b, + Newtypes.Sep s + ) => + Parsec.Parsec (List s b a) + where + parsec = List <$> Parsec.parsec + +instance + ( Newtype.Newtype a b, + Pretty.Pretty b, + Newtypes.Sep s + ) => + Pretty.Pretty (List s b a) + where + pretty = Pretty.prettyVersioned CabalSpecVersion.CabalSpecV1_0 + prettyVersioned v = + Newtypes.prettySep (Proxy.Proxy @s) + . fmap (Pretty.prettyVersioned @b v . Newtype.pack) + . Newtype.unpack + +-- | Overlaps the more general instance in order to use trailing commas when +-- possible. +instance + {-# OVERLAPPING #-} + ( Newtype.Newtype a b, + Pretty.Pretty b + ) => + Pretty.Pretty (List Newtypes.CommaFSep b a) + where + pretty = Pretty.prettyVersioned CabalSpecVersion.CabalSpecV1_0 + prettyVersioned v = + ( \xs -> + if List.compareLength xs 1 == GT && v >= CabalSpecVersion.CabalSpecV2_2 + then PrettyPrint.fsep $ fmap (<> PrettyPrint.comma) xs + else Newtypes.prettySep (Proxy.Proxy @Newtypes.CommaFSep) xs + ) + . fmap (Pretty.prettyVersioned @b v . Newtype.pack) + . Newtype.unpack diff --git a/source/library/CabalGild/Unstable/Type/Mixin.hs b/source/library/CabalGild/Unstable/Type/Mixin.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Mixin.hs @@ -0,0 +1,46 @@ +module CabalGild.Unstable.Type.Mixin where + +import qualified Data.List as List +import qualified Data.Ord as Ord +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Distribution.Types.IncludeRenaming as IncludeRenaming +import qualified Distribution.Types.Mixin as Mixin +import qualified Distribution.Types.ModuleRenaming as ModuleRenaming + +-- | This is a wrapper around 'Mixin.Mixin' that sorts the nested module names +-- when parsing. +newtype Mixin = Mixin + { unwrap :: Mixin.Mixin + } + deriving (Eq, Show) + +instance Ord Mixin where + compare = Ord.comparing unwrap + +instance Parsec.Parsec Mixin where + parsec = Mixin . sortMixin <$> Parsec.parsec + +instance Pretty.Pretty Mixin where + pretty = Pretty.pretty . unwrap + +sortMixin :: Mixin.Mixin -> Mixin.Mixin +sortMixin x = + Mixin.Mixin + { Mixin.mixinPackageName = Mixin.mixinPackageName x, + Mixin.mixinLibraryName = Mixin.mixinLibraryName x, + Mixin.mixinIncludeRenaming = sortIncludeRenaming $ Mixin.mixinIncludeRenaming x + } + +sortIncludeRenaming :: IncludeRenaming.IncludeRenaming -> IncludeRenaming.IncludeRenaming +sortIncludeRenaming x = + IncludeRenaming.IncludeRenaming + { IncludeRenaming.includeProvidesRn = sortModuleRenaming $ IncludeRenaming.includeProvidesRn x, + IncludeRenaming.includeRequiresRn = sortModuleRenaming $ IncludeRenaming.includeRequiresRn x + } + +sortModuleRenaming :: ModuleRenaming.ModuleRenaming -> ModuleRenaming.ModuleRenaming +sortModuleRenaming x = case x of + ModuleRenaming.DefaultRenaming -> ModuleRenaming.DefaultRenaming + ModuleRenaming.HidingRenaming ys -> ModuleRenaming.HidingRenaming $ List.sort ys + ModuleRenaming.ModuleRenaming ys -> ModuleRenaming.ModuleRenaming $ List.sort ys diff --git a/source/library/CabalGild/Unstable/Type/Mode.hs b/source/library/CabalGild/Unstable/Type/Mode.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Mode.hs @@ -0,0 +1,19 @@ +module CabalGild.Unstable.Type.Mode where + +import qualified CabalGild.Unstable.Exception.InvalidMode as InvalidMode +import qualified Control.Monad.Catch as Exception + +-- | Represents the mode of the command line utility. +data Mode + = -- | Just determine if the input is already formatted. + Check + | -- | Format the input. + Format + deriving (Eq, Show) + +-- | Attempts to parse a string as a mode. +fromString :: (Exception.MonadThrow m) => String -> m Mode +fromString s = case s of + "check" -> pure Check + "format" -> pure Format + _ -> Exception.throwM $ InvalidMode.fromString s diff --git a/source/library/CabalGild/Unstable/Type/ModuleReexport.hs b/source/library/CabalGild/Unstable/Type/ModuleReexport.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/ModuleReexport.hs @@ -0,0 +1,25 @@ +module CabalGild.Unstable.Type.ModuleReexport where + +import qualified Data.Ord as Ord +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Distribution.Types.ModuleReexport as ModuleReexport + +-- | This type exists to provide an 'Ord' instance for +-- 'ModuleReexport.ModuleReexport', which was added in @Cabal-syntax-3.10.1.0@. +newtype ModuleReexport = ModuleReexport + { unwrap :: ModuleReexport.ModuleReexport + } + deriving (Eq, Show) + +instance Ord ModuleReexport where + compare = + Ord.comparing $ + (\(ModuleReexport.ModuleReexport mpn mn1 mn2) -> (mpn, mn1, mn2)) + . unwrap + +instance Parsec.Parsec ModuleReexport where + parsec = ModuleReexport <$> Parsec.parsec + +instance Pretty.Pretty ModuleReexport where + pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Unstable/Type/Optional.hs b/source/library/CabalGild/Unstable/Type/Optional.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Optional.hs @@ -0,0 +1,20 @@ +module CabalGild.Unstable.Type.Optional where + +-- | Represents a value that may or may not be present. Isomorphic to 'Maybe'. +-- Useful to distinguish between a value not being given and a value happening +-- to be the same as the default. +data Optional a + = Default + | Specific a + deriving (Eq, Show) + +-- | Uses the provided default value if the optional is 'Default', otherwise +-- gets the value out of the 'Specific'. Similar to 'Data.Maybe.fromMaybe'. +withDefault :: a -> Optional a -> a +withDefault = flip optional id + +-- | Basic destructor, similar to 'maybe'. +optional :: b -> (a -> b) -> Optional a -> b +optional b f o = case o of + Default -> b + Specific s -> f s diff --git a/source/library/CabalGild/Unstable/Type/Output.hs b/source/library/CabalGild/Unstable/Type/Output.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Output.hs @@ -0,0 +1,15 @@ +module CabalGild.Unstable.Type.Output where + +-- | Represents an output stream, which can either be standard output +-- (STDOUT) or a file. +data Output + = Stdout + | File FilePath + deriving (Eq, Ord, Show) + +-- | Converts a string into an output. The string @"-"@ will be converted into +-- 'Stdout', and any other string will be converted into 'File'. +fromString :: String -> Output +fromString s = case s of + "-" -> Stdout + _ -> File s diff --git a/source/library/CabalGild/Unstable/Type/PkgconfigDependency.hs b/source/library/CabalGild/Unstable/Type/PkgconfigDependency.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/PkgconfigDependency.hs @@ -0,0 +1,27 @@ +module CabalGild.Unstable.Type.PkgconfigDependency where + +import qualified CabalGild.Unstable.Type.PkgconfigVersionRange as PkgconfigVersionRange +import qualified Data.Ord as Ord +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Distribution.Types.PkgconfigDependency as PkgconfigDependency + +-- | This type exists to provide an 'Ord' instance for +-- 'PkgconfigDependency.PkgconfigDependency', which was added in +-- @Cabal-syntax-3.10.1.0@. +newtype PkgconfigDependency = PkgconfigDependency + { unwrap :: PkgconfigDependency.PkgconfigDependency + } + deriving (Eq, Show) + +instance Ord PkgconfigDependency where + compare = + Ord.comparing $ + (\(PkgconfigDependency.PkgconfigDependency pn pvr) -> (pn, PkgconfigVersionRange.PkgconfigVersionRange pvr)) + . unwrap + +instance Parsec.Parsec PkgconfigDependency where + parsec = PkgconfigDependency <$> Parsec.parsec + +instance Pretty.Pretty PkgconfigDependency where + pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Unstable/Type/PkgconfigVersionRange.hs b/source/library/CabalGild/Unstable/Type/PkgconfigVersionRange.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/PkgconfigVersionRange.hs @@ -0,0 +1,27 @@ +module CabalGild.Unstable.Type.PkgconfigVersionRange where + +import qualified CabalGild.Unstable.Type.VersionRange as VersionRange +import qualified Data.Ord as Ord +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Distribution.Types.PkgconfigVersionRange as PkgconfigVersionRange + +-- | This type exists to provide an 'Ord' instance for +-- 'PkgconfigVersionRange.PkgconfigVersionRange', which was added in +-- @Cabal-syntax-3.10.1.0@. +newtype PkgconfigVersionRange = PkgconfigVersionRange + { unwrap :: PkgconfigVersionRange.PkgconfigVersionRange + } + deriving (Eq, Show) + +instance Ord PkgconfigVersionRange where + compare = + Ord.comparing $ + VersionRange.fromPkgconfigVersionRange + . unwrap + +instance Parsec.Parsec PkgconfigVersionRange where + parsec = PkgconfigVersionRange <$> Parsec.parsec + +instance Pretty.Pretty PkgconfigVersionRange where + pretty = Pretty.pretty . unwrap diff --git a/source/library/CabalGild/Unstable/Type/Pragma.hs b/source/library/CabalGild/Unstable/Type/Pragma.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Pragma.hs @@ -0,0 +1,24 @@ +module CabalGild.Unstable.Type.Pragma where + +import qualified Control.Monad as Monad +import qualified Data.List.NonEmpty as NonEmpty +import qualified Distribution.Compat.CharParsing as CharParsing +import qualified Distribution.FieldGrammar.Newtypes as Newtypes +import qualified Distribution.Parsec as Parsec + +-- | A pragma, which is a special comment used to customize behavior. +newtype Pragma + = -- | Discover modules within the given directory. + Discover (NonEmpty.NonEmpty FilePath) + deriving (Eq, Show) + +instance Parsec.Parsec Pragma where + parsec = do + CharParsing.spaces + Monad.void $ CharParsing.string "cabal-gild:" + CharParsing.spaces + Monad.void $ CharParsing.string "discover" + CharParsing.skipSpaces1 + Discover + . fmap Newtypes.getFilePathNT + <$> CharParsing.sepByNonEmpty Parsec.parsec CharParsing.skipSpaces1 diff --git a/source/library/CabalGild/Unstable/Type/Set.hs b/source/library/CabalGild/Unstable/Type/Set.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/Set.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module CabalGild.Unstable.Type.Set where + +import qualified CabalGild.Unstable.Extra.List as List +import qualified Data.Proxy as Proxy +import qualified Data.Set as Set +import qualified Distribution.CabalSpecVersion as CabalSpecVersion +import qualified Distribution.Compat.Newtype as Newtype +import qualified Distribution.FieldGrammar.Newtypes as Newtypes +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Text.PrettyPrint as PrettyPrint + +-- | A thin wrapper around 'Newtypes.Set''. This is used to define custom +-- instances of 'Pretty.Pretty' that use trailing commas when the Cabal spec +-- version is recent enough (at least @2.2@). +newtype Set s b a = Set + { unwrap :: Newtypes.Set' s b a + } + +instance Newtype.Newtype (Set.Set a) (Set s b a) where + pack = Set . Newtype.pack + unpack = Newtype.unpack . unwrap + +instance + ( Newtype.Newtype a b, + Ord a, + Parsec.Parsec b, + Newtypes.Sep s + ) => + Parsec.Parsec (Set s b a) + where + parsec = Set <$> Parsec.parsec + +instance + ( Newtype.Newtype a b, + Pretty.Pretty b, + Newtypes.Sep s + ) => + Pretty.Pretty (Set s b a) + where + pretty = Pretty.prettyVersioned CabalSpecVersion.CabalSpecV1_0 + prettyVersioned v = + Newtypes.prettySep (Proxy.Proxy @s) + . fmap (Pretty.prettyVersioned @b v . Newtype.pack) + . Set.toAscList + . Newtype.unpack + +-- | Overlaps the more general instance in order to use trailing commas when +-- possible. +instance + {-# OVERLAPPING #-} + ( Newtype.Newtype a b, + Pretty.Pretty b + ) => + Pretty.Pretty (Set Newtypes.CommaFSep b a) + where + pretty = Pretty.prettyVersioned CabalSpecVersion.CabalSpecV1_0 + prettyVersioned v = + ( \xs -> + if List.compareLength xs 1 == GT && v >= CabalSpecVersion.CabalSpecV2_2 + then PrettyPrint.fsep $ fmap (<> PrettyPrint.comma) xs + else Newtypes.prettySep (Proxy.Proxy @Newtypes.CommaFSep) xs + ) + . fmap (Pretty.prettyVersioned @b v . Newtype.pack) + . Set.toAscList + . Newtype.unpack + +-- | Overlaps the more general instance in order to use trailing commas when +-- possible. +instance + {-# OVERLAPPING #-} + ( Newtype.Newtype a b, + Pretty.Pretty b + ) => + Pretty.Pretty (Set Newtypes.CommaVCat b a) + where + pretty = Pretty.prettyVersioned CabalSpecVersion.CabalSpecV1_0 + prettyVersioned v = + ( \xs -> + if List.compareLength xs 1 == GT && v >= CabalSpecVersion.CabalSpecV2_2 + then PrettyPrint.vcat $ fmap (<> PrettyPrint.comma) xs + else Newtypes.prettySep (Proxy.Proxy @Newtypes.CommaVCat) xs + ) + . fmap (Pretty.prettyVersioned @b v . Newtype.pack) + . Set.toAscList + . Newtype.unpack diff --git a/source/library/CabalGild/Unstable/Type/SomeParsecParser.hs b/source/library/CabalGild/Unstable/Type/SomeParsecParser.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/SomeParsecParser.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module CabalGild.Unstable.Type.SomeParsecParser where + +import qualified CabalGild.Unstable.Type.List as List +import qualified CabalGild.Unstable.Type.Set as Set +import qualified Distribution.CabalSpecVersion as CabalSpecVersion +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty +import qualified Text.PrettyPrint as PrettyPrint + +-- | This type bundles up a parser and a pretty printer for some type. +-- Typically they will just be monomorphic versions of 'Parsec.parsec' and +-- 'Pretty.prettyVersioned'. +data SomeParsecParser + = forall a. + SomeParsecParser + { parsec :: Parsec.ParsecParser a, + pretty :: CabalSpecVersion.CabalSpecVersion -> a -> PrettyPrint.Doc + } + +-- | Creates a new parser for the given 'List.List' of values. +list :: + forall s b a. + (Parsec.Parsec (List.List s b a), Pretty.Pretty (List.List s b a)) => + SomeParsecParser +list = + SomeParsecParser + { parsec = Parsec.parsec @(List.List s b a), + pretty = Pretty.prettyVersioned + } + +-- | Creates a new parser for the given 'Set.Set' of values. +set :: + forall s b a. + (Parsec.Parsec (Set.Set s b a), Pretty.Pretty (Set.Set s b a)) => + SomeParsecParser +set = + SomeParsecParser + { parsec = Parsec.parsec @(Set.Set s b a), + pretty = Pretty.prettyVersioned + } diff --git a/source/library/CabalGild/Unstable/Type/TestedWith.hs b/source/library/CabalGild/Unstable/Type/TestedWith.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/TestedWith.hs @@ -0,0 +1,32 @@ +module CabalGild.Unstable.Type.TestedWith where + +import qualified CabalGild.Unstable.Type.VersionRange as VersionRange +import qualified Data.Ord as Ord +import qualified Distribution.FieldGrammar.Newtypes as Newtypes +import qualified Distribution.Parsec as Parsec +import qualified Distribution.Pretty as Pretty + +-- | This type exists to provide an 'Ord' instance for 'Newtypes.TestedWith', +-- which was added in @Cabal-syntax-3.10.1.0@. +newtype TestedWith = TestedWith + { unwrap :: Newtypes.TestedWith + } + +instance Eq TestedWith where + x == y = compare x y == EQ + +instance Ord TestedWith where + compare = + Ord.comparing $ + fmap VersionRange.fromVersionRange + . Newtypes.getTestedWith + . unwrap + +instance Parsec.Parsec TestedWith where + parsec = TestedWith <$> Parsec.parsec + +instance Pretty.Pretty TestedWith where + pretty = Pretty.pretty . unwrap + +instance Show TestedWith where + show = show . Newtypes.getTestedWith . unwrap diff --git a/source/library/CabalGild/Unstable/Type/VersionRange.hs b/source/library/CabalGild/Unstable/Type/VersionRange.hs new file mode 100644 --- /dev/null +++ b/source/library/CabalGild/Unstable/Type/VersionRange.hs @@ -0,0 +1,40 @@ +module CabalGild.Unstable.Type.VersionRange where + +import qualified Distribution.Types.PkgconfigVersion as PkgconfigVersion +import qualified Distribution.Types.PkgconfigVersionRange as PkgconfigVersionRange +import qualified Distribution.Types.Version as Version +import qualified Distribution.Types.VersionRange as VersionRange + +-- | This type exists to provide an 'Ord' instance for +-- 'VersionRange.VersionRange', which was added in @Cabal-syntax-3.10.1.0@. +data VersionRange a + = Any + | This a + | Later a + | Earlier a + | Union (VersionRange a) (VersionRange a) + | Intersect (VersionRange a) (VersionRange a) + deriving (Eq, Ord, Show) + +fromPkgconfigVersionRange :: + PkgconfigVersionRange.PkgconfigVersionRange -> + VersionRange PkgconfigVersion.PkgconfigVersion +fromPkgconfigVersionRange x = case x of + PkgconfigVersionRange.PcAnyVersion -> Any + PkgconfigVersionRange.PcThisVersion v -> This v + PkgconfigVersionRange.PcLaterVersion v -> Later v + PkgconfigVersionRange.PcEarlierVersion v -> Earlier v + PkgconfigVersionRange.PcOrLaterVersion v -> Union (Later v) (This v) + PkgconfigVersionRange.PcOrEarlierVersion v -> Union (Earlier v) (This v) + PkgconfigVersionRange.PcUnionVersionRanges v w -> Union (fromPkgconfigVersionRange v) (fromPkgconfigVersionRange w) + PkgconfigVersionRange.PcIntersectVersionRanges v w -> Intersect (fromPkgconfigVersionRange v) (fromPkgconfigVersionRange w) + +fromVersionRange :: VersionRange.VersionRange -> VersionRange Version.Version +fromVersionRange = + VersionRange.foldVersionRange + Any + This + Later + Earlier + Union + Intersect 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 @@ -1,25 +1,26 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -import qualified CabalGild.Class.MonadLog as MonadLog -import qualified CabalGild.Class.MonadRead as MonadRead -import qualified CabalGild.Class.MonadWalk as MonadWalk -import qualified CabalGild.Class.MonadWrite as MonadWrite -import qualified CabalGild.Exception.CheckFailure as CheckFailure -import qualified CabalGild.Exception.SpecifiedCrlfWithFormatMode as SpecifiedCrlfWithFormatMode -import qualified CabalGild.Exception.SpecifiedOutputWithCheckMode as SpecifiedOutputWithCheckMode -import qualified CabalGild.Exception.SpecifiedStdinWithFileInput as SpecifiedStdinWithFileInput -import qualified CabalGild.Extra.String as String -import qualified CabalGild.Main as Gild -import qualified CabalGild.Type.Input as Input -import qualified CabalGild.Type.Output as Output +import qualified CabalGild.Unstable.Class.MonadLog as MonadLog +import qualified CabalGild.Unstable.Class.MonadRead as MonadRead +import qualified CabalGild.Unstable.Class.MonadWalk as MonadWalk +import qualified CabalGild.Unstable.Class.MonadWrite as MonadWrite +import qualified CabalGild.Unstable.Exception.CheckFailure as CheckFailure +import qualified CabalGild.Unstable.Exception.SpecifiedCrlfWithFormatMode as SpecifiedCrlfWithFormatMode +import qualified CabalGild.Unstable.Exception.SpecifiedOutputWithCheckMode as SpecifiedOutputWithCheckMode +import qualified CabalGild.Unstable.Exception.SpecifiedStdinWithFileInput as SpecifiedStdinWithFileInput +import qualified CabalGild.Unstable.Extra.String as String +import qualified CabalGild.Unstable.Main as Gild +import qualified CabalGild.Unstable.Type.Input as Input +import qualified CabalGild.Unstable.Type.Output as Output import qualified Control.Monad.Catch as Exception import qualified Control.Monad.Trans.Class as Trans import qualified Control.Monad.Trans.Except as ExceptT import qualified Control.Monad.Trans.RWS as RWST import qualified Data.ByteString as ByteString -import qualified Data.Function as Function +import qualified Data.Either as Either import qualified Data.Functor.Identity as Identity import qualified Data.Map as Map +import qualified Data.Maybe as Maybe import qualified GHC.Stack as Stack import qualified System.Exit as Exit import qualified System.FilePath as FilePath @@ -28,125 +29,167 @@ main :: IO () main = Hspec.hspec . Hspec.parallel . Hspec.describe "cabal-gild" $ do Hspec.it "shows the help" $ do - let (a, s, w) = - runTest - (Gild.mainWith ["--help"]) - (Map.empty, Map.empty) - Map.empty - a `Hspec.shouldBe` Left (Problem $ Exception.toException Exit.ExitSuccess) - w `Hspec.shouldNotSatisfy` null + let (a, s, w) = runGild ["--help"] [] [] + a `shouldBeFailure` Exit.ExitSuccess + w `Hspec.shouldNotBe` [] s `Hspec.shouldBe` Map.empty Hspec.it "shows the version" $ do - let (a, s, w) = - runTest - (Gild.mainWith ["--version"]) - (Map.empty, Map.empty) - Map.empty - a `Hspec.shouldBe` Left (Problem $ Exception.toException Exit.ExitSuccess) - w `Hspec.shouldNotSatisfy` null + let (a, s, w) = runGild ["--version"] [] [] + a `shouldBeFailure` Exit.ExitSuccess + w `Hspec.shouldNotBe` [] s `Hspec.shouldBe` Map.empty Hspec.it "reads from an input file" $ do let (a, s, w) = - runTest - (Gild.mainWith ["--input", "input.cabal"]) - (Map.singleton (Input.File "input.cabal") (String.toUtf8 ""), Map.empty) - Map.empty - a `Hspec.shouldBe` Right () + runGild + ["--input", "input.cabal"] + [(Input.File "input.cabal", String.toUtf8 "")] + [] + a `Hspec.shouldSatisfy` Either.isRight w `Hspec.shouldBe` [] - s `Hspec.shouldSatisfy` Map.member Output.Stdout + s `Hspec.shouldBe` Map.singleton Output.Stdout (String.toUtf8 "") Hspec.it "writes to an output file" $ do let (a, s, w) = - runTest - (Gild.mainWith ["--output", "output.cabal"]) - (Map.singleton Input.Stdin (String.toUtf8 ""), Map.empty) - Map.empty - a `Hspec.shouldBe` Right () + runGild + ["--output", "output.cabal"] + [(Input.Stdin, String.toUtf8 "")] + [] + a `Hspec.shouldSatisfy` Either.isRight w `Hspec.shouldBe` [] - s `Hspec.shouldSatisfy` Map.member (Output.File "output.cabal") + s `Hspec.shouldBe` Map.singleton (Output.File "output.cabal") (String.toUtf8 "") Hspec.it "succeeds when checking formatted input" $ do let (a, s, w) = - runTest - (Gild.mainWith ["--mode", "check"]) - (Map.singleton Input.Stdin (String.toUtf8 "pass: yes\n"), Map.empty) - Map.empty - a `Hspec.shouldBe` Right () + runGild + ["--mode", "check"] + [(Input.Stdin, String.toUtf8 "pass: yes\n")] + [] + a `Hspec.shouldSatisfy` Either.isRight w `Hspec.shouldBe` [] s `Hspec.shouldBe` Map.empty Hspec.it "fails when checking unformatted input" $ do let (a, s, w) = - runTest - (Gild.mainWith ["--mode", "check"]) - (Map.singleton Input.Stdin (String.toUtf8 "pass: no"), Map.empty) - Map.empty - a `Hspec.shouldBe` Left (Problem $ Exception.toException CheckFailure.CheckFailure) + runGild + ["--mode", "check"] + [(Input.Stdin, String.toUtf8 "pass: no")] + [] + a `shouldBeFailure` CheckFailure.CheckFailure w `Hspec.shouldBe` [] s `Hspec.shouldBe` Map.empty Hspec.it "succeeds when checking CRLF input leniently" $ do let (a, s, w) = - runTest - (Gild.mainWith ["--mode", "check"]) - (Map.singleton Input.Stdin (String.toUtf8 "pass: yes\r\n"), Map.empty) - Map.empty - a `Hspec.shouldBe` Right () + runGild + ["--mode", "check"] + [(Input.Stdin, String.toUtf8 "pass: yes\r\n")] + [] + a `Hspec.shouldSatisfy` Either.isRight w `Hspec.shouldBe` [] s `Hspec.shouldBe` Map.empty Hspec.it "fails when checking CRLF input strictly" $ do let (a, s, w) = - runTest - (Gild.mainWith ["--crlf", "strict", "--mode", "check"]) - (Map.singleton Input.Stdin (String.toUtf8 "pass: no\r\n"), Map.empty) - Map.empty - a `Hspec.shouldBe` Left (Problem $ Exception.toException CheckFailure.CheckFailure) + runGild + ["--crlf", "strict", "--mode", "check"] + [(Input.Stdin, String.toUtf8 "pass: no\r\n")] + [] + a `shouldBeFailure` CheckFailure.CheckFailure w `Hspec.shouldBe` [] s `Hspec.shouldBe` Map.empty Hspec.it "fails when --stdin is given with an input file" $ do let (a, s, w) = - runTest - (Gild.mainWith ["--input", "f", "--stdin", "g"]) - (Map.empty, Map.empty) - Map.empty - a `Hspec.shouldBe` Left (Problem $ Exception.toException SpecifiedStdinWithFileInput.SpecifiedStdinWithFileInput) + runGild + ["--input", "f", "--stdin", "g"] + [] + [] + a `shouldBeFailure` SpecifiedStdinWithFileInput.SpecifiedStdinWithFileInput w `Hspec.shouldBe` [] s `Hspec.shouldBe` Map.empty Hspec.it "fails when --output is given with check mode" $ do let (a, s, w) = - runTest - (Gild.mainWith ["--mode", "check", "--output", "-"]) - (Map.empty, Map.empty) - Map.empty - a `Hspec.shouldBe` Left (Problem $ Exception.toException SpecifiedOutputWithCheckMode.SpecifiedOutputWithCheckMode) + runGild + ["--mode", "check", "--output", "-"] + [] + [] + a `shouldBeFailure` SpecifiedOutputWithCheckMode.SpecifiedOutputWithCheckMode w `Hspec.shouldBe` [] s `Hspec.shouldBe` Map.empty + Hspec.it "does not overwrite output when input is formatted" $ do + let (a, s, w) = + runGild + ["--io", "io.cabal"] + [(Input.File "io.cabal", String.toUtf8 "")] + [] + a `Hspec.shouldSatisfy` Either.isRight + w `Hspec.shouldBe` [] + s `Hspec.shouldBe` Map.empty + + Hspec.it "writes to stdout when input is formatted" $ do + let (a, s, w) = + runGild + ["--input", "p.cabal"] + [(Input.File "p.cabal", String.toUtf8 "")] + [] + a `Hspec.shouldSatisfy` Either.isRight + w `Hspec.shouldBe` [] + s `Hspec.shouldBe` Map.singleton Output.Stdout (String.toUtf8 "") + + Hspec.it "writes to output when input is formatted" $ do + let (a, s, w) = + runGild + ["--input", "p.cabal", "--output", "q.cabal"] + [(Input.File "p.cabal", String.toUtf8 "")] + [] + a `Hspec.shouldSatisfy` Either.isRight + w `Hspec.shouldBe` [] + s `Hspec.shouldBe` Map.singleton (Output.File "q.cabal") (String.toUtf8 "") + + Hspec.it "writes to output when stdin is formatted" $ do + let (a, s, w) = + runGild + ["--output", "q.cabal"] + [(Input.Stdin, String.toUtf8 "")] + [] + a `Hspec.shouldSatisfy` Either.isRight + w `Hspec.shouldBe` [] + s `Hspec.shouldBe` Map.singleton (Output.File "q.cabal") (String.toUtf8 "") + Hspec.it "sets input and output simultaneously" $ do let (a, s, w) = - runTest - (Gild.mainWith ["--io", "io.cabal"]) - (Map.singleton (Input.File "io.cabal") (String.toUtf8 ""), Map.empty) - Map.empty - a `Hspec.shouldBe` Right () + runGild + ["--io", "io.cabal"] + [(Input.File "io.cabal", String.toUtf8 "f:a")] + [] + a `Hspec.shouldSatisfy` Either.isRight w `Hspec.shouldBe` [] - s `Hspec.shouldSatisfy` Map.member (Output.File "io.cabal") + s `Hspec.shouldBe` Map.singleton (Output.File "io.cabal") (String.toUtf8 "f: a\n") Hspec.it "fails when --crlf is given with format mode" $ do let (a, s, w) = - runTest - (Gild.mainWith ["--crlf", "strict"]) - (Map.empty, Map.empty) - Map.empty - a `Hspec.shouldBe` Left (Problem $ Exception.toException SpecifiedCrlfWithFormatMode.SpecifiedCrlfWithFormatMode) + runGild + ["--crlf", "strict"] + [] + [] + a `shouldBeFailure` SpecifiedCrlfWithFormatMode.SpecifiedCrlfWithFormatMode w `Hspec.shouldBe` [] s `Hspec.shouldBe` Map.empty + Hspec.it "uses --stdin for discovery" $ do + let (a, s, w) = + runGild + ["--stdin", "d/p.cabal"] + [(Input.Stdin, String.toUtf8 "library\n -- cabal-gild: discover .\n exposed-modules:")] + [("d", ["M.hs"])] + a `Hspec.shouldSatisfy` Either.isRight + w `Hspec.shouldBe` [] + s `Hspec.shouldBe` Map.singleton Output.Stdout (String.toUtf8 "library\n -- cabal-gild: discover .\n exposed-modules: M\n") + Hspec.it "succeeds with empty input" $ do expectGilded "" @@ -347,7 +390,7 @@ Hspec.it "formats a comment after a field's value" $ do expectGilded "f:\n 1\n -- c" - "f: 1\n-- c\n" + "f:\n 1\n\n-- c\n" Hspec.it "formats a comment after a field with multiple values" $ do expectGilded @@ -669,6 +712,11 @@ "cabal-version: 2.2\nlibrary\n build-depends: p" "cabal-version: 2.2\n\nlibrary\n build-depends: p\n" + Hspec.it "sorts sub-libraries in build-depends" $ do + expectGilded + "cabal-version: 3.0\nlibrary\n build-depends: p:{b,a}" + "cabal-version: 3.0\n\nlibrary\n build-depends: p:{a, b}\n" + Hspec.it "removes duplicate options" $ do -- This is kind of silly because there's only one possible foreign library -- option. @@ -796,6 +844,26 @@ "library\n mixins: q (M, N as O), p" "library\n mixins:\n p,\n q (M, N as O)\n" + Hspec.it "sorts hiding in mixins" $ do + expectGilded + "library\n mixins: p hiding (N, M)" + "library\n mixins: p hiding (M, N)\n" + + Hspec.it "sorts modules in mixins" $ do + expectGilded + "library\n mixins: p (N, M)" + "library\n mixins: p (M, N)\n" + + Hspec.it "sorts hiding in mixins requires" $ do + expectGilded + "library\n mixins: p requires hiding (N, M)" + "library\n mixins: p requires hiding (M, N)\n" + + Hspec.it "sorts modules in mixins requires" $ do + expectGilded + "library\n mixins: p requires (N, M)" + "library\n mixins: p requires (M, N)\n" + Hspec.it "does not sort ghc-options" $ do expectGilded "library\n ghc-options: b a" @@ -831,6 +899,11 @@ "custom-setup\n setup-depends: b, a" "custom-setup\n setup-depends:\n a,\n b\n" + Hspec.it "sorts sub-libraries in setup-depends" $ do + expectGilded + "cabal-version: 3.0\ncustom-setup\n setup-depends: p:{b,a}" + "cabal-version: 3.0\n\ncustom-setup\n setup-depends: p:{a, b}\n" + Hspec.it "discovers an exposed module" $ do expectDiscover [(".", ["M.hs"])] @@ -1026,66 +1099,85 @@ "library\nelif p\n a" "library\n\nelif p\n a\n" + Hspec.it "keeps output on multiple lines" $ do + expectGilded + "f:\n a" + "f:\n a\n" + + Hspec.it "keeps output on multiple lines for formatted fields" $ do + expectGilded + "library\n build-depends:\n base<5" + "library\n build-depends:\n base <5\n" + + Hspec.it "keeps output on multiple lines for pragmas" $ do + expectDiscover + [(".", ["M.hs"])] + "library\n -- cabal-gild: discover .\n exposed-modules:\n ..." + "library\n -- cabal-gild: discover .\n exposed-modules:\n M\n" + +shouldBeFailure :: + (Stack.HasCallStack, Eq e, Exception.Exception e, Show a) => + Either Exception.SomeException a -> + e -> + Hspec.Expectation +shouldBeFailure result expected = case result of + Left exception -> case Exception.fromException exception of + Just actual -> actual `Hspec.shouldBe` expected + x -> x `Hspec.shouldSatisfy` Maybe.isJust + x -> x `Hspec.shouldSatisfy` Either.isLeft + expectGilded :: (Stack.HasCallStack) => String -> String -> Hspec.Expectation -expectGilded input expected = do - let (a, s, w) = - runTest - (Gild.mainWith []) - (Map.singleton Input.Stdin $ String.toUtf8 input, Map.empty) - Map.empty - a `Hspec.shouldBe` Right () - w `Hspec.shouldBe` [] - actual <- case Map.toList s of - [(Output.Stdout, x)] -> pure x - _ -> fail $ "impossible: " <> show s - actual `Hspec.shouldBe` String.toUtf8 expected - -- After formatting, the output should not change if we format it again. - expectStable actual +expectGilded = expectDiscover [] -expectStable :: (Stack.HasCallStack) => ByteString.ByteString -> Hspec.Expectation -expectStable input = do - let (a, s, w) = - runTest - (Gild.mainWith []) - (Map.singleton Input.Stdin input, Map.empty) - Map.empty - a `Hspec.shouldBe` Right () +expectStable :: + (Stack.HasCallStack) => + [(FilePath, [FilePath])] -> + ByteString.ByteString -> + Hspec.Expectation +expectStable files input = do + let (a, s, w) = runGild [] [(Input.Stdin, input)] files + a `Hspec.shouldSatisfy` Either.isRight w `Hspec.shouldBe` [] output <- case Map.toList s of [(Output.Stdout, x)] -> pure x _ -> fail $ "impossible: " <> show s output `Hspec.shouldBe` input -expectDiscover :: [(FilePath, [FilePath])] -> String -> String -> Hspec.Expectation +expectDiscover :: + (Stack.HasCallStack) => + [(FilePath, [FilePath])] -> + String -> + String -> + Hspec.Expectation expectDiscover files input expected = do - let (a, s, w) = - runTest - (Gild.mainWith []) - ( Map.singleton Input.Stdin $ String.toUtf8 input, - Map.fromList $ fmap (\(d, fs) -> (d, FilePath.combine d <$> fs)) files - ) - Map.empty - a `Hspec.shouldBe` Right () + let (a, s, w) = runGild [] [(Input.Stdin, String.toUtf8 input)] files + a `Hspec.shouldSatisfy` Either.isRight w `Hspec.shouldBe` [] actual <- case Map.toList s of [(Output.Stdout, x)] -> pure x _ -> fail $ "impossible: " <> show s actual `Hspec.shouldBe` String.toUtf8 expected - -newtype Problem = Problem - { unProblem :: Exception.SomeException - } - deriving (Show) + expectStable files actual -instance Eq Problem where - (==) = Function.on (==) show +runGild :: + [String] -> + [(Input.Input, ByteString.ByteString)] -> + [(FilePath, [FilePath])] -> + (Either E (), S, W) +runGild arguments inputs files = + runTest + (Gild.mainWith arguments) + ( Map.fromList inputs, + Map.mapWithKey (\d fs -> FilePath.combine d <$> fs) $ Map.fromList files + ) + Map.empty type Test = TestT Identity.Identity runTest :: Test a -> R -> S -> (Either E a, S, W) runTest t r = Identity.runIdentity . RWST.runRWST (ExceptT.runExceptT $ runTestT t) r -type E = Problem +type E = Exception.SomeException type R = (Map.Map Input.Input ByteString.ByteString, Map.Map FilePath [FilePath]) @@ -1109,7 +1201,7 @@ Just x -> pure x instance (Monad m) => Exception.MonadThrow (TestT m) where - throwM = TestT . ExceptT.throwE . Problem . Exception.toException + throwM = TestT . ExceptT.throwE . Exception.toException instance (Monad m) => MonadWalk.MonadWalk (TestT m) where walk p = do