From 92c3e02cb0c6250e74a968ea9aeffb4027a5ca2c Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Fri, 2 Jun 2023 19:06:25 +0200 Subject: [PATCH] Apply formatter --- Cabal/src/Distribution/Simple/InstallDirs.hs | 5 +- .../src/Distribution/Client/ProjectConfig.hs | 49 ++++--- .../Client/ProjectConfig/FieldGrammar.hs | 75 +++++------ .../Distribution/Client/ProjectConfig/Lens.hs | 87 +++++++------ .../Client/ProjectConfig/Parsec.hs | 120 +++++++++--------- .../src/Distribution/Client/Utils/Parsec.hs | 20 +-- .../ProjectConfig/ParsecTests.hs | 82 ++++++------ 7 files changed, 230 insertions(+), 208 deletions(-) diff --git a/Cabal/src/Distribution/Simple/InstallDirs.hs b/Cabal/src/Distribution/Simple/InstallDirs.hs index ad23588f418..951f0a7d41f 100644 --- a/Cabal/src/Distribution/Simple/InstallDirs.hs +++ b/Cabal/src/Distribution/Simple/InstallDirs.hs @@ -52,12 +52,9 @@ import Distribution.Compat.Prelude import Prelude () import Distribution.Compat.Environment (lookupEnv) -import Distribution.Pretty -import Distribution.Package -import Distribution.Parsec -import Distribution.System import Distribution.Compiler import Distribution.Package +import Distribution.Parsec import Distribution.Pretty import Distribution.Simple.InstallDirs.Internal import Distribution.System diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 89d319ef39b..58a8f5ac8b1 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -747,32 +747,39 @@ readProjectFileSkeleton extensionDescription = do exists <- liftIO $ doesFileExist extensionFile if exists - then do monitorFiles [monitorFileHashed extensionFile] - pcs <- liftIO $ readExtensionFile verbosity extensionFile - monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs) - pure pcs - else do monitorFiles [monitorNonExistentFile extensionFile] - return mempty - where - extensionFile = distProjectFile extensionName - readExtensionFile = readAndParseFile Parsec.parseProjectSkeleton + then do + monitorFiles [monitorFileHashed extensionFile] + pcs <- liftIO $ readExtensionFile verbosity extensionFile + monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs) + pure pcs + else do + monitorFiles [monitorNonExistentFile extensionFile] + return mempty + where + extensionFile = distProjectFile extensionName + readExtensionFile = readAndParseFile Parsec.parseProjectSkeleton -- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty. --- readProjectFileSkeletonLegacy :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton -readProjectFileSkeletonLegacy verbosity httpTransport DistDirLayout{distProjectFile, distDownloadSrcDirectory} - extensionName extensionDescription = do +readProjectFileSkeletonLegacy + verbosity + httpTransport + DistDirLayout{distProjectFile, distDownloadSrcDirectory} + extensionName + extensionDescription = do exists <- liftIO $ doesFileExist extensionFile if exists - then do monitorFiles [monitorFileHashed extensionFile] - pcs <- liftIO readExtensionFile - monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs) - pure pcs - else do monitorFiles [monitorNonExistentFile extensionFile] - return mempty - where - extensionFile = distProjectFile extensionName - readExtensionFile = + then do + monitorFiles [monitorFileHashed extensionFile] + pcs <- liftIO readExtensionFile + monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs) + pure pcs + else do + monitorFiles [monitorNonExistentFile extensionFile] + return mempty + where + extensionFile = distProjectFile extensionName + readExtensionFile = reportParseResult verbosity extensionDescription extensionFile =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] extensionFile =<< BS.readFile extensionFile diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index ccd73231247..2957269197e 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -1,53 +1,54 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} + -- | 'ProjectConfig' Field descriptions -module Distribution.Client.ProjectConfig.FieldGrammar ( - projectConfigFieldGrammar +module Distribution.Client.ProjectConfig.FieldGrammar + ( projectConfigFieldGrammar ) where -import Distribution.Compat.Prelude import qualified Distribution.Client.ProjectConfig.Lens as L import Distribution.Client.ProjectConfig.Types (ProjectConfig (..), ProjectConfigBuildOnly (..)) +import Distribution.Client.Utils.Parsec +import Distribution.Compat.Prelude import Distribution.FieldGrammar import Distribution.Simple.Flag import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) import Distribution.Verbosity -import Distribution.Client.Utils.Parsec - projectConfigFieldGrammar :: ParsecFieldGrammar' ProjectConfig -projectConfigFieldGrammar = ProjectConfig - <$> monoidalFieldAla "packages" (alaList' FSep Token') L.projectPackages - <*> monoidalFieldAla "optional-packages" (alaList' FSep Token') L.projectPackagesOptional - <*> pure mempty -- source-repository-package stanza - <*> monoidalFieldAla "extra-packages" formatPackagesNamedList L.projectPackagesNamed - <*> blurFieldGrammar L.projectConfigBuildOnly projectConfigBuildOnlyFieldGrammar - <*> pure mempty - <*> pure mempty - <*> pure mempty - <*> pure mempty - <*> pure mempty +projectConfigFieldGrammar = + ProjectConfig + <$> monoidalFieldAla "packages" (alaList' FSep Token') L.projectPackages + <*> monoidalFieldAla "optional-packages" (alaList' FSep Token') L.projectPackagesOptional + <*> pure mempty -- source-repository-package stanza + <*> monoidalFieldAla "extra-packages" formatPackagesNamedList L.projectPackagesNamed + <*> blurFieldGrammar L.projectConfigBuildOnly projectConfigBuildOnlyFieldGrammar + <*> pure mempty + <*> pure mempty + <*> pure mempty + <*> pure mempty + <*> pure mempty formatPackagesNamedList :: [PackageVersionConstraint] -> List CommaVCat (Identity PackageVersionConstraint) PackageVersionConstraint formatPackagesNamedList = alaList CommaVCat projectConfigBuildOnlyFieldGrammar :: ParsecFieldGrammar' ProjectConfigBuildOnly -projectConfigBuildOnlyFieldGrammar = ProjectConfigBuildOnly - <$> optionalFieldDef "verbose" L.projectConfigVerbosity (pure normal) - <*> pure (toFlag False) -- cli flag: projectConfigDryRun - <*> pure (toFlag False) -- cli flag: projectConfigOnlyDeps - <*> pure (toFlag False) -- cli flag: projectConfigOnlyDownload - <*> monoidalFieldAla "build-summary" (alaNubList VCat) L.projectConfigSummaryFile - <*> undefined - <*> undefined - <*> undefined - <*> undefined - <*> undefined - <*> undefined - <*> undefined - <*> undefined - <*> undefined - <*> undefined - <*> undefined - <*> undefined - <*> undefined - +projectConfigBuildOnlyFieldGrammar = + ProjectConfigBuildOnly + <$> optionalFieldDef "verbose" L.projectConfigVerbosity (pure normal) + <*> pure (toFlag False) -- cli flag: projectConfigDryRun + <*> pure (toFlag False) -- cli flag: projectConfigOnlyDeps + <*> pure (toFlag False) -- cli flag: projectConfigOnlyDownload + <*> monoidalFieldAla "build-summary" (alaNubList VCat) L.projectConfigSummaryFile + <*> undefined + <*> undefined + <*> undefined + <*> undefined + <*> undefined + <*> undefined + <*> undefined + <*> undefined + <*> undefined + <*> undefined + <*> undefined + <*> undefined + <*> undefined diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index 30fa73da557..53081a497c0 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -1,70 +1,83 @@ module Distribution.Client.ProjectConfig.Lens where -import Distribution.Compat.Prelude -import Distribution.Client.ProjectConfig.Types (ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigShared, ProjectConfigProvenance, PackageConfig, MapMappend) -import Distribution.Compat.Lens -import Distribution.Client.Types.SourceRepo (SourceRepoList) +import Distribution.Client.ProjectConfig.Types (MapMappend, PackageConfig, ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance, ProjectConfigShared) import qualified Distribution.Client.ProjectConfig.Types as T +import Distribution.Client.Types.SourceRepo (SourceRepoList) +import Distribution.Compat.Lens +import Distribution.Compat.Prelude import Distribution.Package - ( PackageName, PackageId, UnitId ) + ( PackageId + , PackageName + , UnitId + ) +import Distribution.Simple.InstallDirs + ( InstallDirs + , PathTemplate + ) import Distribution.Simple.Setup - ( Flag, HaddockTarget(..), TestShowDetails(..), DumpBuildInfo (..) ) + ( DumpBuildInfo (..) + , Flag + , HaddockTarget (..) + , TestShowDetails (..) + ) import Distribution.Types.PackageVersionConstraint - ( PackageVersionConstraint ) -import Distribution.Verbosity -import Distribution.Simple.InstallDirs - ( PathTemplate, InstallDirs ) + ( PackageVersionConstraint + ) import Distribution.Utils.NubList - ( NubList, toNubList, fromNubList ) + ( NubList + , fromNubList + , toNubList + ) +import Distribution.Verbosity projectPackages :: Lens' ProjectConfig [String] -projectPackages f s = fmap (\x -> s { T.projectPackages = x }) (f (T.projectPackages s)) -{-# INLINABLE projectPackages #-} +projectPackages f s = fmap (\x -> s{T.projectPackages = x}) (f (T.projectPackages s)) +{-# INLINEABLE projectPackages #-} projectPackagesOptional :: Lens' ProjectConfig [String] -projectPackagesOptional f s = fmap (\x -> s { T.projectPackagesOptional = x }) (f (T.projectPackagesOptional s)) -{-# INLINABLE projectPackagesOptional #-} +projectPackagesOptional f s = fmap (\x -> s{T.projectPackagesOptional = x}) (f (T.projectPackagesOptional s)) +{-# INLINEABLE projectPackagesOptional #-} projectPackagesRepo :: Lens' ProjectConfig [SourceRepoList] -projectPackagesRepo f s = fmap (\x -> s { T.projectPackagesRepo = x }) (f (T.projectPackagesRepo s)) -{-# INLINABLE projectPackagesRepo #-} +projectPackagesRepo f s = fmap (\x -> s{T.projectPackagesRepo = x}) (f (T.projectPackagesRepo s)) +{-# INLINEABLE projectPackagesRepo #-} projectPackagesNamed :: Lens' ProjectConfig [PackageVersionConstraint] -projectPackagesNamed f s = fmap (\x -> s { T.projectPackagesNamed = x }) (f (T.projectPackagesNamed s)) -{-# INLINABLE projectPackagesNamed #-} +projectPackagesNamed f s = fmap (\x -> s{T.projectPackagesNamed = x}) (f (T.projectPackagesNamed s)) +{-# INLINEABLE projectPackagesNamed #-} projectConfigBuildOnly :: Lens' ProjectConfig ProjectConfigBuildOnly -projectConfigBuildOnly f s = fmap (\x -> s { T.projectConfigBuildOnly = x }) (f (T.projectConfigBuildOnly s)) -{-# INLINABLE projectConfigBuildOnly #-} +projectConfigBuildOnly f s = fmap (\x -> s{T.projectConfigBuildOnly = x}) (f (T.projectConfigBuildOnly s)) +{-# INLINEABLE projectConfigBuildOnly #-} projectConfigShared :: Lens' ProjectConfig ProjectConfigShared -projectConfigShared f s = fmap (\x -> s { T.projectConfigShared = x }) (f (T.projectConfigShared s)) -{-# INLINABLE projectConfigShared #-} +projectConfigShared f s = fmap (\x -> s{T.projectConfigShared = x}) (f (T.projectConfigShared s)) +{-# INLINEABLE projectConfigShared #-} projectConfigProvenance :: Lens' ProjectConfig (Set ProjectConfigProvenance) -projectConfigProvenance f s = fmap (\x -> s { T.projectConfigProvenance = x }) (f (T.projectConfigProvenance s)) -{-# INLINABLE projectConfigProvenance #-} +projectConfigProvenance f s = fmap (\x -> s{T.projectConfigProvenance = x}) (f (T.projectConfigProvenance s)) +{-# INLINEABLE projectConfigProvenance #-} projectConfigAllPackages :: Lens' ProjectConfig PackageConfig -projectConfigAllPackages f s = fmap (\x -> s { T.projectConfigAllPackages = x }) (f (T.projectConfigAllPackages s)) -{-# INLINABLE projectConfigAllPackages #-} +projectConfigAllPackages f s = fmap (\x -> s{T.projectConfigAllPackages = x}) (f (T.projectConfigAllPackages s)) +{-# INLINEABLE projectConfigAllPackages #-} projectConfigLocalPackages :: Lens' ProjectConfig PackageConfig -projectConfigLocalPackages f s = fmap (\x -> s { T.projectConfigLocalPackages = x }) (f (T.projectConfigLocalPackages s)) -{-# INLINABLE projectConfigLocalPackages #-} +projectConfigLocalPackages f s = fmap (\x -> s{T.projectConfigLocalPackages = x}) (f (T.projectConfigLocalPackages s)) +{-# INLINEABLE projectConfigLocalPackages #-} projectConfigSpecificPackage :: Lens' ProjectConfig (MapMappend PackageName PackageConfig) -projectConfigSpecificPackage f s = fmap (\x -> s { T.projectConfigSpecificPackage = x }) (f (T.projectConfigSpecificPackage s)) -{-# INLINABLE projectConfigSpecificPackage #-} +projectConfigSpecificPackage f s = fmap (\x -> s{T.projectConfigSpecificPackage = x}) (f (T.projectConfigSpecificPackage s)) +{-# INLINEABLE projectConfigSpecificPackage #-} projectConfigVerbosity :: Lens' ProjectConfigBuildOnly (Flag Verbosity) -projectConfigVerbosity f s = fmap (\x -> s { T.projectConfigVerbosity = x }) (f (T.projectConfigVerbosity s)) -{-# INLINABLE projectConfigVerbosity #-} +projectConfigVerbosity f s = fmap (\x -> s{T.projectConfigVerbosity = x}) (f (T.projectConfigVerbosity s)) +{-# INLINEABLE projectConfigVerbosity #-} projectConfigSummaryFile :: Lens' ProjectConfigBuildOnly (NubList PathTemplate) -projectConfigSummaryFile f s = fmap (\x -> s { T.projectConfigSummaryFile = x }) (f (T.projectConfigSummaryFile s)) -{-# INLINABLE projectConfigSummaryFile #-} +projectConfigSummaryFile f s = fmap (\x -> s{T.projectConfigSummaryFile = x}) (f (T.projectConfigSummaryFile s)) +{-# INLINEABLE projectConfigSummaryFile #-} projectConfigSummaryFile' :: Lens' ProjectConfigBuildOnly [PathTemplate] -projectConfigSummaryFile' f s = fmap (\x -> s { T.projectConfigSummaryFile = toNubList x }) (f (fromNubList $ T.projectConfigSummaryFile s)) -{-# INLINABLE projectConfigSummaryFile' #-} +projectConfigSummaryFile' f s = fmap (\x -> s{T.projectConfigSummaryFile = toNubList x}) (f (fromNubList $ T.projectConfigSummaryFile s)) +{-# INLINEABLE projectConfigSummaryFile' #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 3cd8f719b5c..ae0b20ef17d 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -1,62 +1,64 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -- | Parsing project configuration. - -module Distribution.Client.ProjectConfig.Parsec ( - -- * Package configuration - parseProjectSkeleton, - ProjectConfigSkeleton, - ProjectConfig (..), - - -- ** Parsing - ParseResult, - runParseResult +module Distribution.Client.ProjectConfig.Parsec + ( -- * Package configuration + parseProjectSkeleton + , ProjectConfigSkeleton + , ProjectConfig (..) + + -- ** Parsing + , ParseResult + , runParseResult ) where -import Control.Monad.State.Strict (StateT, execStateT, lift, modify) +import Control.Monad.State.Strict (StateT, execStateT, lift, modify) import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.Compat.Prelude import Distribution.FieldGrammar + -- TODO #6101 .Legacy -> ProjectConfigSkeleton should probably be moved here import Distribution.Client.ProjectConfig.FieldGrammar (projectConfigFieldGrammar) -import Distribution.Client.ProjectConfig.Legacy (ProjectConfigSkeleton, ProjectConfigImport) +import Distribution.Client.ProjectConfig.Legacy (ProjectConfigImport, ProjectConfigSkeleton) import qualified Distribution.Client.ProjectConfig.Lens as L import Distribution.Client.ProjectConfig.Types (ProjectConfig (..)) -import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList) -import Distribution.Fields.ConfVar (parseConditionConfVar) +import Distribution.Client.Types.SourceRepo (SourceRepoList, sourceRepositoryPackageGrammar) +import Distribution.Fields.ConfVar (parseConditionConfVar) import Distribution.Fields.ParseResult + -- AST type -import Distribution.Fields (Field, readFields', Name (..)) -import Distribution.Fields.LexerMonad (LexWarning, toPWarnings) -import Distribution.PackageDescription.Quirks (patchQuirks) -import Distribution.Parsec (parsec, simpleParsecBS) -import Distribution.Parsec.Position (Position (..), zeroPos) -import Distribution.Parsec.Warning (PWarnType (..)) -import Distribution.Types.CondTree (CondTree (..), CondBranch (..)) -import Distribution.Types.ConfVar (ConfVar (..)) -import Distribution.Utils.Generic (breakMaybe, fromUTF8BS, toUTF8BS, unfoldrM, validateUTF8) - -import qualified Data.ByteString as BS -import qualified Text.Parsec as P +import Distribution.Fields (Field, Name (..), readFields') +import Distribution.Fields.LexerMonad (LexWarning, toPWarnings) +import Distribution.PackageDescription.Quirks (patchQuirks) +import Distribution.Parsec (parsec, simpleParsecBS) +import Distribution.Parsec.Position (Position (..), zeroPos) +import Distribution.Parsec.Warning (PWarnType (..)) +import Distribution.Types.CondTree (CondBranch (..), CondTree (..)) +import Distribution.Types.ConfVar (ConfVar (..)) +import Distribution.Utils.Generic (breakMaybe, fromUTF8BS, toUTF8BS, unfoldrM, validateUTF8) + +import qualified Data.ByteString as BS +import qualified Text.Parsec as P -- | Preprocess file and start parsing parseProjectSkeleton :: BS.ByteString -> ParseResult ProjectConfigSkeleton parseProjectSkeleton bs = do - case readFields' bs' of - Right (fs, lexWarnings) -> do - parseWarnings (toPWarnings lexWarnings) - for_ invalidUtf8 $ \pos -> - parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos - parseCondTree fs - Left perr -> parseFatalFailure pos (show perr) where - ppos = P.errorPos perr - pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) + case readFields' bs' of + Right (fs, lexWarnings) -> do + parseWarnings (toPWarnings lexWarnings) + for_ invalidUtf8 $ \pos -> + parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos + parseCondTree fs + Left perr -> parseFatalFailure pos (show perr) + where + ppos = P.errorPos perr + pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) where invalidUtf8 = validateUTF8 bs bs' = case invalidUtf8 of - Nothing -> bs - Just _ -> toUTF8BS (fromUTF8BS bs) + Nothing -> bs + Just _ -> toUTF8BS (fromUTF8BS bs) -- List of conditional blocks newtype Conditional ann = Conditional [Section ann] @@ -69,27 +71,27 @@ partitionConditionals :: [[Section ann]] -> ([Section ann], [Conditional ann]) partitionConditionals sections = (concat sections, []) parseCondTree - :: [Field Position] - -> ParseResult ProjectConfigSkeleton + :: [Field Position] + -> ParseResult ProjectConfigSkeleton parseCondTree fields0 = do - -- sections are groups of sections between fields - let (fs, sectionGroups) = partitionFields fields0 - (sections, conditionals) = partitionConditionals sectionGroups - msg = show sectionGroups - imports <- parseImports fs - config <- parseFieldGrammar cabalSpecLatest fs projectConfigFieldGrammar - config' <- view stateConfig <$> execStateT (goSections sections) (SectionS config) - let configSkeleton = CondNode config' imports [] - -- TODO parse conditionals - return configSkeleton + -- sections are groups of sections between fields + let (fs, sectionGroups) = partitionFields fields0 + (sections, conditionals) = partitionConditionals sectionGroups + msg = show sectionGroups + imports <- parseImports fs + config <- parseFieldGrammar cabalSpecLatest fs projectConfigFieldGrammar + config' <- view stateConfig <$> execStateT (goSections sections) (SectionS config) + let configSkeleton = CondNode config' imports [] + -- TODO parse conditionals + return configSkeleton -- Monad in which sections are parsed type SectionParser = StateT SectionS ParseResult -- | State of section parser newtype SectionS = SectionS - { _stateConfig :: ProjectConfig - } + { _stateConfig :: ProjectConfig + } stateConfig :: Lens' SectionS ProjectConfig stateConfig f (SectionS cfg) = SectionS <$> f cfg @@ -100,13 +102,13 @@ goSections = traverse_ parseSection parseSection :: Section Position -> SectionParser () parseSection (MkSection (Name pos name) args secFields) - | name == "source-repository-package" = do - let (fields, secs) = partitionFields secFields - srp <- lift $ parseFieldGrammar cabalSpecLatest fields sourceRepositoryPackageGrammar - stateConfig . L.projectPackagesRepo %= (++ [srp]) - unless (null secs) (warnInvalidSubsection pos name) - | otherwise = do - warnInvalidSubsection pos name + | name == "source-repository-package" = do + let (fields, secs) = partitionFields secFields + srp <- lift $ parseFieldGrammar cabalSpecLatest fields sourceRepositoryPackageGrammar + stateConfig . L.projectPackagesRepo %= (++ [srp]) + unless (null secs) (warnInvalidSubsection pos name) + | otherwise = do + warnInvalidSubsection pos name warnInvalidSubsection pos name = lift $ parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name diff --git a/cabal-install/src/Distribution/Client/Utils/Parsec.hs b/cabal-install/src/Distribution/Client/Utils/Parsec.hs index 39c00841ec9..52bca6d79e1 100644 --- a/cabal-install/src/Distribution/Client/Utils/Parsec.hs +++ b/cabal-install/src/Distribution/Client/Utils/Parsec.hs @@ -1,15 +1,17 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Distribution.Client.Utils.Parsec ( renderParseError - -- ** NubList + + -- ** NubList , alaNubList - , alaNubList' - , NubList' + , alaNubList' + , NubList' ) where -import Distribution.Compat.Newtype import Distribution.Client.Compat.Prelude +import Distribution.Compat.Newtype import System.FilePath (normalise) import Prelude () @@ -19,8 +21,8 @@ import qualified Data.ByteString.Char8 as BS8 import Distribution.FieldGrammar.Newtypes import Distribution.Parsec (PError (..), PWarning (..), Position (..), showPos, zeroPos) import Distribution.Simple.Utils (fromUTF8BS) -import qualified Distribution.Utils.NubList as NubList import Distribution.Utils.NubList (NubList (..)) +import qualified Distribution.Utils.NubList as NubList -- | Render parse error highlighting the part of the input file. renderParseError @@ -117,7 +119,7 @@ advance n z@(Zipper xs ys) -- | Like 'List', but for 'NubList'. -- -- @since 3.2.0.0 -newtype NubList' sep b a = NubList' { _getNubList :: NubList a } +newtype NubList' sep b a = NubList' {_getNubList :: NubList a} -- | 'alaNubList' and 'alaNubList'' are simply 'NubList'' constructor, with additional phantom -- arguments to constrain the resulting type @@ -144,7 +146,7 @@ alaNubList' _ _ = NubList' instance Newtype (NubList a) (NubList' sep wrapper a) instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (NubList' sep b a) where - parsec = pack . NubList.toNubList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec + parsec = pack . NubList.toNubList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec instance (Newtype a b, Sep sep, Pretty b) => Pretty (NubList' sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NubList.fromNubList . unpack + pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NubList.fromNubList . unpack diff --git a/cabal-install/tests/IntegrationTests2/ProjectConfig/ParsecTests.hs b/cabal-install/tests/IntegrationTests2/ProjectConfig/ParsecTests.hs index 04a1d72d9e1..58fa3f55a69 100644 --- a/cabal-install/tests/IntegrationTests2/ProjectConfig/ParsecTests.hs +++ b/cabal-install/tests/IntegrationTests2/ProjectConfig/ParsecTests.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} -- | Integration Tests related to parsing of ProjectConfigs module IntegrationTests2.ProjectConfig.ParsecTests (parserTests) where @@ -32,11 +32,11 @@ import Test.Tasty.HUnit -- - golden tests for warnings and errors parserTests :: [TestTree] parserTests = - [ testCase "read packages" testPackages, - testCase "read optional-packages" testOptionalPackages, - testCase "read extra-packages" testExtraPackages, - testCase "read source-repository-package" testSourceRepoList, - testCase "read project-config-build-only" testProjectConfigBuildOnly + [ testCase "read packages" testPackages + , testCase "read optional-packages" testOptionalPackages + , testCase "read extra-packages" testExtraPackages + , testCase "read source-repository-package" testSourceRepoList + , testCase "read project-config-build-only" testProjectConfigBuildOnly ] testPackages :: Assertion @@ -57,20 +57,20 @@ testSourceRepoList :: Assertion testSourceRepoList = do let expected = [ SourceRepositoryPackage - { srpType = KnownRepoType Git, - srpLocation = "https://example.com/Project.git", - srpTag = Just "1234", - srpBranch = Nothing, - srpSubdir = [], - srpCommand = [] - }, - SourceRepositoryPackage - { srpType = KnownRepoType Git, - srpLocation = "https://example.com/example-dir/", - srpTag = Just "12345", - srpBranch = Nothing, - srpSubdir = ["subproject"], - srpCommand = [] + { srpType = KnownRepoType Git + , srpLocation = "https://example.com/Project.git" + , srpTag = Just "1234" + , srpBranch = Nothing + , srpSubdir = [] + , srpCommand = [] + } + , SourceRepositoryPackage + { srpType = KnownRepoType Git + , srpLocation = "https://example.com/example-dir/" + , srpTag = Just "12345" + , srpBranch = Nothing + , srpSubdir = ["subproject"] + , srpCommand = [] } ] (config, legacy) <- readConfigDefault "source-repository-packages" @@ -79,36 +79,36 @@ testSourceRepoList = do testExtraPackages :: Assertion testExtraPackages = do let expected = - [ PackageVersionConstraint (mkPackageName "a") (OrLaterVersion (mkVersion [0])), - PackageVersionConstraint (mkPackageName "b") (IntersectVersionRanges (OrLaterVersion (mkVersion [0, 7, 3])) (EarlierVersion (mkVersion [0, 9]))) + [ PackageVersionConstraint (mkPackageName "a") (OrLaterVersion (mkVersion [0])) + , PackageVersionConstraint (mkPackageName "b") (IntersectVersionRanges (OrLaterVersion (mkVersion [0, 7, 3])) (EarlierVersion (mkVersion [0, 9]))) ] (config, legacy) <- readConfigDefault "extra-packages" assertConfig expected config legacy (projectPackagesNamed . condTreeData) testProjectConfigBuildOnly :: Assertion testProjectConfigBuildOnly = do - let expected = ProjectConfigBuildOnly {..} + let expected = ProjectConfigBuildOnly{..} (config, legacy) <- readConfigDefault "project-config-build-only" assertConfig expected config legacy (projectConfigBuildOnly . condTreeData) where - projectConfigVerbosity = toFlag (toEnum 2) - projectConfigDryRun = toFlag False -- cli only - projectConfigOnlyDeps = toFlag False -- cli only - projectConfigOnlyDownload = toFlag False -- cli only - projectConfigSummaryFile = toNubList [toPathTemplate "summaryFile"] - projectConfigLogFile = toFlag $ toPathTemplate "myLog.log" -- TODO could be build-log - projectConfigBuildReports = toFlag NoReports -- TODO maybe cli only? - projectConfigReportPlanningFailure = toFlag True - projectConfigSymlinkBinDir = toFlag "some-bindir" - projectConfigNumJobs = toFlag $ Just 4 - projectConfigKeepGoing = toFlag True -- cli only - projectConfigOfflineMode = toFlag True - projectConfigKeepTempFiles = toFlag True - projectConfigHttpTransport = toFlag "wget" - projectConfigIgnoreExpiry = toFlag True - projectConfigCacheDir = toFlag "some-cache-dir" - projectConfigLogsDir = toFlag "logs-directory" - projectConfigClientInstallFlags = mempty -- TODO are these actually cli only? + projectConfigVerbosity = toFlag (toEnum 2) + projectConfigDryRun = toFlag False -- cli only + projectConfigOnlyDeps = toFlag False -- cli only + projectConfigOnlyDownload = toFlag False -- cli only + projectConfigSummaryFile = toNubList [toPathTemplate "summaryFile"] + projectConfigLogFile = toFlag $ toPathTemplate "myLog.log" -- TODO could be build-log + projectConfigBuildReports = toFlag NoReports -- TODO maybe cli only? + projectConfigReportPlanningFailure = toFlag True + projectConfigSymlinkBinDir = toFlag "some-bindir" + projectConfigNumJobs = toFlag $ Just 4 + projectConfigKeepGoing = toFlag True -- cli only + projectConfigOfflineMode = toFlag True + projectConfigKeepTempFiles = toFlag True + projectConfigHttpTransport = toFlag "wget" + projectConfigIgnoreExpiry = toFlag True + projectConfigCacheDir = toFlag "some-cache-dir" + projectConfigLogsDir = toFlag "logs-directory" + projectConfigClientInstallFlags = mempty -- TODO are these actually cli only? readConfigDefault :: FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton) readConfigDefault rootFp = readConfig rootFp "cabal.project"