From 27d67570702295199fa3d0eaa85259a93df2dd7a Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Tue, 9 Apr 2024 15:24:15 +0200 Subject: [PATCH] Add ProjectConfigPath to Parsec Parser --- .../src/Distribution/Client/ProjectConfig.hs | 4 +- .../Client/ProjectConfig/FieldGrammar.hs | 5 +- .../Client/ProjectConfig/Legacy.hs | 1 - .../Client/ProjectConfig/Parsec.hs | 94 ++++++++++++++----- .../ProjectConfig/Parsec/cabal.test.hs | 6 +- 5 files changed, 82 insertions(+), 28 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 5ce9f0fdded..4f6c50cc93a 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -762,7 +762,7 @@ readProjectFileSkeleton then do monitorFiles [monitorFileHashed extensionFile] pcs <- liftIO $ readExtensionFile verbosity extensionFile - monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs) + monitorFiles $ map monitorFileHashed (projectConfigPathRoot <$> projectSkeletonImports pcs) unless (legacyPcs == pcs) (error (show callStack ++ "\nParsec: " ++ show pcs ++ "\nLegacy: " ++ show legacyPcs)) pure pcs else do @@ -771,7 +771,7 @@ readProjectFileSkeleton where extensionFile = distProjectFile extensionName readExtensionFile :: Verbosity -> FilePath -> IO ProjectConfigSkeleton - readExtensionFile verbosity' file = readAndParseFile (\bs -> Parsec.parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity' [] extensionFile bs) verbosity' file + readExtensionFile verbosity' file = readAndParseFile (Parsec.parseProject extensionFile distDownloadSrcDirectory httpTransport verbosity' . ProjectConfigToParse) verbosity' file readAndParseFile :: (BS.ByteString -> IO (Parsec.ParseResult a)) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index 6823698e0b5..5f77afffb60 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -16,6 +16,7 @@ import Distribution.Compat.Prelude import Distribution.FieldGrammar import Distribution.Simple.Flag import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) +import Distribution.Solver.Types.ProjectConfigPath import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) -- TODO check usages of monoidalField: "Field which can be define multiple times, and the results are mappended." @@ -24,7 +25,7 @@ import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (.. -- TODO check if ^^^ availableSince can be used in some of the fields (see FieldGrammar of PackageDescription) -- TODO ParsecFieldGrammar' is a Grammar implementation, we should just use abstract FieldGrammar here -projectConfigFieldGrammar :: FilePath -> [String] -> ParsecFieldGrammar' ProjectConfig +projectConfigFieldGrammar :: ProjectConfigPath -> [String] -> ParsecFieldGrammar' ProjectConfig projectConfigFieldGrammar source knownPrograms = ProjectConfig <$> monoidalFieldAla "packages" (alaList' FSep Token) L.projectPackages @@ -69,7 +70,7 @@ projectConfigBuildOnlyFieldGrammar = <*> monoidalFieldAla "logs-dir" (alaFlag FilePathNT) L.projectConfigLogsDir <*> pure mempty -projectConfigSharedFieldGrammar :: FilePath -> ParsecFieldGrammar' ProjectConfigShared +projectConfigSharedFieldGrammar :: ProjectConfigPath -> ParsecFieldGrammar' ProjectConfigShared projectConfigSharedFieldGrammar source = ProjectConfigShared <$> optionalFieldDefAla "builddir" (alaFlag FilePathNT) L.projectConfigDistDir mempty -- TODO builddir is not documented diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 6224ac32280..fe2e86d8ccc 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -15,7 +15,6 @@ module Distribution.Client.ProjectConfig.Legacy , instantiateProjectConfigSkeletonWithCompiler , singletonProjectConfigSkeleton , projectSkeletonImports - , ProjectConfigImport -- * Project config in terms of legacy types , LegacyProjectConfig diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index a69b0108a62..3a71314c1ca 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -4,6 +4,7 @@ module Distribution.Client.ProjectConfig.Parsec ( -- * Package configuration parseProjectSkeleton + , parseProject , ProjectConfigSkeleton , ProjectConfig (..) @@ -23,17 +24,18 @@ import Distribution.Compat.Prelude import Distribution.FieldGrammar import Distribution.FieldGrammar.Parsec (NamelessField (..), namelessFieldAnn) import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) -import Distribution.Simple.Utils (warn) +import Distribution.Simple.Utils (debug, warn) import Distribution.Verbosity -- TODO #6101 .Legacy -> ProjectConfigSkeleton should probably be moved here import Distribution.Client.ProjectConfig.FieldGrammar (packageConfigFieldGrammar, projectConfigFieldGrammar) -import Distribution.Client.ProjectConfig.Legacy (ProjectConfigImport, ProjectConfigSkeleton) +import Distribution.Client.ProjectConfig.Legacy (ProjectConfigSkeleton) import qualified Distribution.Client.ProjectConfig.Lens as L -import Distribution.Client.ProjectConfig.Types (MapLast (..), MapMappend (..), PackageConfig (..), ProjectConfig (..), ProjectConfigShared (..)) +import Distribution.Client.ProjectConfig.Types (MapLast (..), MapMappend (..), PackageConfig (..), ProjectConfig (..), ProjectConfigShared (..), ProjectConfigToParse (..)) import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar) import Distribution.Fields.ConfVar (parseConditionConfVar) import Distribution.Fields.ParseResult +import Distribution.Solver.Types.ProjectConfigPath -- AST type import Distribution.Fields (Field (..), FieldLine (..), FieldName, Name (..), SectionArg (..), readFields', showPWarning) @@ -50,10 +52,12 @@ import Distribution.Types.PackageName (PackageName) import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS, validateUTF8) import qualified Data.ByteString as BS +import Data.Coerce (coerce) import qualified Distribution.Compat.CharParsing as P -import System.Directory (createDirectoryIfMissing) -import System.FilePath (isAbsolute, isPathSeparator, makeValid, takeDirectory, ()) +import System.Directory (createDirectoryIfMissing, makeAbsolute) +import System.FilePath (isAbsolute, isPathSeparator, makeValid, splitFileName, ()) import qualified Text.Parsec +import Text.PrettyPrint (render) singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton singletonProjectConfigSkeleton x = CondNode x mempty mempty @@ -76,19 +80,55 @@ readPreprocessFields bs = do Nothing -> bs Just _ -> toUTF8BS (fromUTF8BS bs) -parseProjectSkeleton :: FilePath -> HttpTransport -> Verbosity -> [ProjectConfigImport] -> FilePath -> BS.ByteString -> IO (ParseResult ProjectConfigSkeleton) -parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (sanityWalkPCS False =<<) <$> liftPR (go []) (readPreprocessFields bs) -- (ParseUtils.readFields bs) +-- | Parses a project from its root config file, typically cabal.project. +parseProject + :: FilePath + -- ^ The root of the project configuration, typically cabal.project + -> FilePath + -> HttpTransport + -> Verbosity + -> ProjectConfigToParse + -- ^ The contents of the file to parse + -> IO (ParseResult ProjectConfigSkeleton) +parseProject rootPath cacheDir httpTransport verbosity configToParse = do + let (dir, projectFileName) = splitFileName rootPath + projectDir <- makeAbsolute dir + projectPath <- canonicalizeConfigPath projectDir (ProjectConfigPath $ projectFileName :| []) + parseProjectSkeleton cacheDir httpTransport verbosity projectDir projectPath configToParse + +parseProjectSkeleton + :: FilePath + -> HttpTransport + -> Verbosity + -> FilePath + -- ^ The directory of the project configuration, typically the directory of cabal.project + -> ProjectConfigPath + -- ^ The path of the file being parsed, either the root or an import + -> ProjectConfigToParse + -- ^ The contents of the file to parse + -> IO (ParseResult ProjectConfigSkeleton) +parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (ProjectConfigToParse bs) = (sanityWalkPCS False =<<) <$> liftPR (go []) (readPreprocessFields bs) -- (ParseUtils.readFields bs) where go :: [Field Position] -> [Field Position] -> IO (ParseResult ProjectConfigSkeleton) go acc (x : xs) = case x of (Field (Name pos name) importLines) | name == "import" -> do liftPR ( \importLoc -> do - if (importLoc `elem` seenImports) - then pure $ parseFatalFailure pos ("cyclical import of " ++ importLoc) + let importLocPath = importLoc `consProjectConfigPath` source + + -- Once we canonicalize the import path, we can check for cyclical imports + normLocPath <- canonicalizeConfigPath projectDir importLocPath + + debug verbosity $ "\nimport path, normalized\n=======================\n" ++ render (docProjectConfigPath normLocPath) + + if isCyclicConfigPath normLocPath + then pure $ parseFatalFailure pos (render $ cyclicalImportMsg normLocPath) else do - let fs = fmap (\z -> CondNode z [importLoc] mempty) $ fieldsToConfig (reverse acc) - importParseResult <- parseProjectSkeleton cacheDir httpTransport verbosity (importLoc : seenImports) importLoc =<< fetchImportConfig importLoc + normSource <- canonicalizeConfigPath projectDir source + let fs = (\z -> CondNode z [normLocPath] mempty) <$> fieldsToConfig normSource (reverse acc) + + importParseResult <- parseProjectSkeleton cacheDir httpTransport verbosity projectDir importLocPath . ProjectConfigToParse =<< fetchImportConfig normLocPath + -- As PError and PWarning do not store the filepath where they occurred, we need to print them here where we still have this information let (warnings, result) = runParseResult importParseResult traverse_ (warn verbosity . showPWarning importLoc) warnings @@ -104,7 +144,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (s (parseImport pos importLines) (Section (Name _pos name) args xs') | name == "if" -> do subpcs <- go [] xs' - let fs = fmap singletonProjectConfigSkeleton $ fieldsToConfig (reverse acc) + let fs = fmap singletonProjectConfigSkeleton $ fieldsToConfig source (reverse acc) (elseClauses, rest) <- parseElseClauses xs let condNode = (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) @@ -113,7 +153,9 @@ parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (s <*> elseClauses pure . fmap mconcat . sequence $ [fs, condNode, rest] _ -> go (x : acc) xs - go acc [] = pure . fmap singletonProjectConfigSkeleton . fieldsToConfig $ reverse acc + go acc [] = do + normSource <- canonicalizeConfigPath projectDir source + pure . fmap singletonProjectConfigSkeleton . fieldsToConfig normSource $ reverse acc parseElseClauses :: [Field Position] -> IO (ParseResult (Maybe ProjectConfigSkeleton), ParseResult ProjectConfigSkeleton) parseElseClauses x = case x of @@ -132,20 +174,30 @@ parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (s pure (Just <$> condNode, rest) _ -> (\r -> (pure Nothing, r)) <$> go [] x - parseImport :: Position -> [FieldLine Position] -> ParseResult (ProjectConfigImport) + parseImport :: Position -> [FieldLine Position] -> ParseResult FilePath parseImport pos lines' = runFieldParser pos (P.many P.anyChar) cabalSpec lines' -- TODO emit unrecognized field warning on unknown fields, legacy parser does this - fieldsToConfig :: [Field Position] -> ParseResult ProjectConfig - fieldsToConfig xs = do + -- We want a normalized path for @fieldsToConfig@. This eventually surfaces + -- in solver rejection messages and build messages "this build was affected + -- by the following (project) config files" so we want all paths shown there + -- to be relative to the directory of the project, not relative to the file + -- they were imported from. + fieldsToConfig :: ProjectConfigPath -> [Field Position] -> ParseResult ProjectConfig + fieldsToConfig sourceConfigPath xs = do let (fs, sectionGroups) = partitionFields xs sections = concat sectionGroups - config <- parseFieldGrammar cabalSpec fs (projectConfigFieldGrammar source (knownProgramNames programDb)) + config <- parseFieldGrammar cabalSpec fs (projectConfigFieldGrammar sourceConfigPath (knownProgramNames programDb)) config' <- view stateConfig <$> execStateT (goSections programDb sections) (SectionS config) return config' - fetchImportConfig :: ProjectConfigImport -> IO BS.ByteString - fetchImportConfig pci = case parseURI pci of + fetchImportConfig :: ProjectConfigPath -> IO BS.ByteString + fetchImportConfig (ProjectConfigPath (pci :| _)) = do + debug verbosity $ "fetching import: " ++ pci + fetch pci + + fetch :: FilePath -> IO BS.ByteString + fetch pci = case parseURI pci of Just uri -> do let fp = cacheDir map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri) createDirectoryIfMissing True cacheDir @@ -153,7 +205,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (s BS.readFile fp Nothing -> BS.readFile $ - if isAbsolute pci then pci else takeDirectory source pci + if isAbsolute pci then pci else coerce projectDir pci modifiesCompiler :: ProjectConfig -> Bool modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg @@ -165,7 +217,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (s | underConditional && modifiesCompiler d = parseFatalFailure zeroPos "Cannot set compiler in a conditional clause of a cabal project file" | otherwise = mapM_ sanityWalkBranch comps >> pure t - sanityWalkBranch :: CondBranch ConfVar [ProjectConfigImport] ProjectConfig -> ParseResult () + sanityWalkBranch :: CondBranch ConfVar [ProjectConfigPath] ProjectConfig -> ParseResult () sanityWalkBranch (CondBranch _c t f) = traverse (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure () programDb = defaultProgramDb diff --git a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs index a5b7125760a..bc18326c88e 100644 --- a/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectConfig/Parsec/cabal.test.hs @@ -3,6 +3,7 @@ import qualified Data.ByteString as BS import Data.Either +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set @@ -26,6 +27,7 @@ import Distribution.Simple.Flag import Distribution.Simple.InstallDirs (toPathTemplate) import Distribution.Simple.Setup (DumpBuildInfo (..), Flag, HaddockTarget (..), TestShowDetails (..)) import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) +import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath (..)) import Distribution.Solver.Types.Settings (AllowBootLibInstalls (..), CountConflicts (..), FineGrainedConflicts (..), MinimizeConflictSet (..), OnlyConstrained (..), PreferOldest (..), ReorderGoals (..), StrongFlags (..)) import Distribution.Types.CondTree (CondTree (..)) import Distribution.Types.Flag (FlagAssignment (..), FlagName, mkFlagAssignment) @@ -165,7 +167,7 @@ testProjectConfigShared = do let bar = fromRight (error "error parsing bar") $ readUserConstraint "bar == 2.1" barFlags = fromRight (error "error parsing bar flags") $ readUserConstraint "bar +foo -baz" - source = ConstraintSourceProjectConfig projectFileFp + source = ConstraintSourceProjectConfig $ ProjectConfigPath $ "cabal.project" :| [] in [(bar, source), (barFlags, source)] projectConfigPreferences = [PackageVersionConstraint (mkPackageName "foo") (ThisVersion (mkVersion [0, 9])), PackageVersionConstraint (mkPackageName "baz") (LaterVersion (mkVersion [2, 0]))] @@ -193,7 +195,7 @@ testProjectConfigProvenance = do let rootFp = "empty" testDir <- testDirInfo rootFp "cabal.project" let - expected = Set.singleton (Explicit (testDirProjectConfigFp testDir)) + expected = Set.singleton (Explicit (ProjectConfigPath $ "cabal.project" :| [])) (config, legacy) <- readConfigDefault rootFp assertConfig expected config legacy (projectConfigProvenance . condTreeData)