From ec3763fc871e4bb16140cbc418ba72e637981813 Mon Sep 17 00:00:00 2001 From: Gershom Bazerman Date: Wed, 5 Jan 2022 15:59:03 -0500 Subject: [PATCH] better errors and use extended project parsing uniformly --- Cabal/src/Distribution/Types/CondTree.hs | 2 +- .../src/Distribution/Client/CmdConfigure.hs | 17 +++-- .../src/Distribution/Client/CmdOutdated.hs | 38 +++++++---- .../src/Distribution/Client/ProjectConfig.hs | 64 ++++--------------- .../Client/ProjectConfig/Legacy.hs | 31 +++++---- .../Distribution/Client/ProjectPlanning.hs | 1 + 6 files changed, 71 insertions(+), 82 deletions(-) diff --git a/Cabal/src/Distribution/Types/CondTree.hs b/Cabal/src/Distribution/Types/CondTree.hs index 442e4b48b8c..8f1d17a8163 100644 --- a/Cabal/src/Distribution/Types/CondTree.hs +++ b/Cabal/src/Distribution/Types/CondTree.hs @@ -71,7 +71,7 @@ instance (NFData v, NFData c, NFData a) => NFData (CondTree v c a) where rnf = g instance (Semigroup a, Semigroup c) => Semigroup (CondTree v c a) where (CondNode a c bs) <> (CondNode a' c' bs') = CondNode (a <> a') (c <> c') (bs <> bs') -instance (Monoid a, Monoid c) => Monoid (CondTree v c a) where +instance (Semigroup a, Semigroup c, Monoid a, Monoid c) => Monoid (CondTree v c a) where mappend = (<>) mempty = CondNode mempty mempty mempty diff --git a/cabal-install/src/Distribution/Client/CmdConfigure.hs b/cabal-install/src/Distribution/Client/CmdConfigure.hs index f734f15c668..cfe4741d0bd 100644 --- a/cabal-install/src/Distribution/Client/CmdConfigure.hs +++ b/cabal-install/src/Distribution/Client/CmdConfigure.hs @@ -30,12 +30,17 @@ import Distribution.Verbosity import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Utils - ( wrapText, notice ) + ( wrapText, notice, die' ) import Distribution.Client.DistDirLayout ( DistDirLayout(..) ) import Distribution.Client.RebuildMonad (runRebuild) import Distribution.Client.ProjectConfig.Types +import Distribution.Client.HttpUtils +import Distribution.Utils.NubList + ( fromNubList ) +import Distribution.Types.CondTree + ( CondTree (..) ) configureCommand :: CommandUI (NixStyleFlags ()) configureCommand = CommandUI { @@ -126,9 +131,13 @@ configureAction' flags@NixStyleFlags {..} _extraArgs globalFlags = do -- If the flag @configAppend@ is set to true, append and do not overwrite if exists && appends then do - conf <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ - readProjectLocalExtraConfig v (distDirLayout baseCtx) - return (baseCtx, conf <> cliConfig) -- TODO ugh. maybe don't have extra configs have conditions, only main configs + httpTransport <- configureTransport v + (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) + (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) + (CondNode conf imps bs) <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ + readProjectLocalExtraConfig v httpTransport (distDirLayout baseCtx) + when (not (null imps && null bs)) $ die' v "local project file has conditional and/or import logic, unable to perform and automatic in-place update" + return (baseCtx, conf <> cliConfig) else return (baseCtx, cliConfig) where diff --git a/cabal-install/src/Distribution/Client/CmdOutdated.hs b/cabal-install/src/Distribution/Client/CmdOutdated.hs index b2b817a00ce..d09fdabe900 100644 --- a/cabal-install/src/Distribution/Client/CmdOutdated.hs +++ b/cabal-install/src/Distribution/Client/CmdOutdated.hs @@ -29,9 +29,10 @@ import Distribution.Client.DistDirLayout ( defaultDistDirLayout , DistDirLayout(distProjectRootDirectory, distProjectFile) ) import Distribution.Client.ProjectConfig - ( ProjectConfig(projectConfigShared), - ProjectConfigShared(projectConfigConstraints), findProjectRoot, - readProjectLocalFreezeConfig ) +import Distribution.Client.ProjectConfig.Legacy + ( instantiateProjectConfigSkeleton ) +import Distribution.Client.ProjectPlanning + ( configureCompiler ) import Distribution.Client.ProjectFlags ( projectFlagsOptions, ProjectFlags(..), defaultProjectFlags , removeIgnoreProjectOption ) @@ -40,8 +41,6 @@ import Distribution.Client.RebuildMonad import Distribution.Client.Sandbox ( loadConfigOrSandboxConfig ) import Distribution.Client.Setup - ( withRepoContext, GlobalFlags, configCompilerAux' - , ConfigExFlags(configExConstraints) ) import Distribution.Client.Targets ( userToPackageConstraint, UserConstraint ) import Distribution.Client.Types.SourcePackageDb as SourcePackageDb @@ -55,7 +54,7 @@ import Distribution.Utils.Generic import Distribution.Package ( PackageName, packageVersion ) import Distribution.PackageDescription - ( allBuildDepends ) + ( allBuildDepends, ignoreConditions ) import Distribution.PackageDescription.Configuration ( finalizePD ) import Distribution.Simple.Compiler @@ -65,7 +64,7 @@ import Distribution.Simple.Setup import Distribution.Simple.Utils ( die', notice, debug, tryFindPackageDesc ) import Distribution.System - ( Platform ) + ( Platform (..) ) import Distribution.Types.ComponentRequestedSpec ( ComponentRequestedSpec(..) ) import Distribution.Types.Dependency @@ -86,6 +85,10 @@ import Distribution.Simple.Command import qualified Distribution.Compat.CharParsing as P import Distribution.ReadE ( parsecToReadE ) +import Distribution.Client.HttpUtils +import Distribution.Utils.NubList + ( fromNubList ) + import qualified Data.Set as S import System.Directory @@ -220,7 +223,6 @@ outdatedAction (ProjectFlags{flagProjectFileName}, OutdatedFlags{..}) _targetStr config <- loadConfigOrSandboxConfig verbosity globalFlags let globalFlags' = savedGlobalFlags config `mappend` globalFlags configFlags = savedConfigureFlags config - (comp, platform, _progdb) <- configCompilerAux' configFlags withRepoContext verbosity globalFlags' $ \repoContext -> do when (not newFreezeFile && isJust mprojectFile) $ die' verbosity $ @@ -230,8 +232,14 @@ outdatedAction (ProjectFlags{flagProjectFileName}, OutdatedFlags{..}) _targetStr deps <- if freezeFile then depsFromFreezeFile verbosity else if newFreezeFile - then depsFromNewFreezeFile verbosity mprojectFile - else depsFromPkgDesc verbosity comp platform + then do + httpTransport <- configureTransport verbosity + (fromNubList . globalProgPathExtra $ globalFlags) + (flagToMaybe . globalHttpTransport $ globalFlags) + depsFromNewFreezeFile verbosity httpTransport mprojectFile + else do + (comp, platform, _progdb) <- configCompilerAux' configFlags + depsFromPkgDesc verbosity comp platform debug verbosity $ "Dependencies loaded: " ++ intercalate ", " (map prettyShow deps) let outdatedDeps = listOutdated deps sourcePkgDb @@ -293,14 +301,16 @@ depsFromFreezeFile verbosity = do return deps -- | Read the list of dependencies from the new-style freeze file. -depsFromNewFreezeFile :: Verbosity -> Maybe FilePath -> IO [PackageVersionConstraint] -depsFromNewFreezeFile verbosity mprojectFile = do +depsFromNewFreezeFile :: Verbosity -> HttpTransport -> Maybe FilePath -> IO [PackageVersionConstraint] +depsFromNewFreezeFile verbosity httpTransport mprojectFile = do projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile let distDirLayout = defaultDistDirLayout projectRoot {- TODO: Support dist dir override -} Nothing - projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ - readProjectLocalFreezeConfig verbosity distDirLayout + projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ do + pcs <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout + (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst $ ignoreConditions pcs) + pure $ instantiateProjectConfigSkeleton os arch (compilerInfo compiler) mempty pcs let ucnstrs = map fst . projectConfigConstraints . projectConfigShared $ projectConfig deps = userConstraintsToDependencies ucnstrs diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index f879c61d5e8..c1811902c3d 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -507,10 +507,10 @@ readProjectConfig :: Verbosity -> DistDirLayout -> Rebuild ProjectConfigSkeleton readProjectConfig verbosity httpTransport configFileFlag distDirLayout = do - global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag + global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag local <- readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout - freeze <- singletonProjectConfigSkeleton <$> readProjectLocalFreezeConfig verbosity distDirLayout - extra <- singletonProjectConfigSkeleton <$> readProjectLocalExtraConfig verbosity distDirLayout + freeze <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout + extra <- readProjectLocalExtraConfig verbosity httpTransport distDirLayout return (global <> local <> freeze <> extra) @@ -547,20 +547,20 @@ readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do -- or returns empty. This file gets written by @cabal configure@, or in -- principle can be edited manually or by other tools. -- -readProjectLocalExtraConfig :: Verbosity -> DistDirLayout - -> Rebuild ProjectConfig -readProjectLocalExtraConfig verbosity distDirLayout = - readProjectFile verbosity distDirLayout "local" +readProjectLocalExtraConfig :: Verbosity -> HttpTransport -> DistDirLayout + -> Rebuild ProjectConfigSkeleton +readProjectLocalExtraConfig verbosity httpTransport distDirLayout = + readProjectFileSkeleton verbosity httpTransport distDirLayout "local" "project local configuration file" -- | Reads a @cabal.project.freeze@ file in the given project root dir, -- or returns empty. This file gets written by @cabal freeze@, or in -- principle can be edited manually or by other tools. -- -readProjectLocalFreezeConfig :: Verbosity -> DistDirLayout - -> Rebuild ProjectConfig -readProjectLocalFreezeConfig verbosity distDirLayout = - readProjectFile verbosity distDirLayout "freeze" +readProjectLocalFreezeConfig :: Verbosity -> HttpTransport ->DistDirLayout + -> Rebuild ProjectConfigSkeleton +readProjectLocalFreezeConfig verbosity httpTransport distDirLayout = + readProjectFileSkeleton verbosity httpTransport distDirLayout "freeze" "project freeze file" -- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty. @@ -571,7 +571,9 @@ readProjectFileSkeleton verbosity httpTransport DistDirLayout{distProjectFile, d exists <- liftIO $ doesFileExist extensionFile if exists then do monitorFiles [monitorFileHashed extensionFile] - liftIO readExtensionFile + pcs <- liftIO readExtensionFile + monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs) + pure pcs else do monitorFiles [monitorNonExistentFile extensionFile] return mempty where @@ -582,44 +584,6 @@ readProjectFileSkeleton verbosity httpTransport DistDirLayout{distProjectFile, d =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity extensionFile =<< BS.readFile extensionFile --- | Reads a named config file in the given project root dir, or returns empty. --- -readProjectFile :: Verbosity -> DistDirLayout -> String -> String -> Rebuild ProjectConfig -readProjectFile verbosity DistDirLayout{distProjectFile} - extensionName extensionDescription = do - exists <- liftIO $ doesFileExist extensionFile - if exists - then do monitorFiles [monitorFileHashed extensionFile] - addProjectFileProvenance <$> liftIO readExtensionFile - else do monitorFiles [monitorNonExistentFile extensionFile] - return mempty - where - extensionFile :: FilePath - extensionFile = distProjectFile extensionName - - readExtensionFile :: IO ProjectConfig - readExtensionFile = - reportParseResult verbosity extensionDescription extensionFile - . (parseProjectConfig extensionFile) - =<< BS.readFile extensionFile - - addProjectFileProvenance :: ProjectConfig -> ProjectConfig - addProjectFileProvenance config = - config { - projectConfigProvenance = Set.insert (Explicit extensionFile) (projectConfigProvenance config) - } - - --- | Parse the 'ProjectConfig' format. --- --- For the moment this is implemented in terms of parsers for legacy --- configuration types, plus a conversion. --- -parseProjectConfig :: FilePath -> BS.ByteString -> OldParser.ParseResult ProjectConfig -parseProjectConfig source content = - convertLegacyProjectConfig <$> - (parseLegacyProjectConfig source content) - -- | Render the 'ProjectConfig' format. -- -- For the moment this is implemented in terms of a pretty printer for the diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 96d8d26feca..7d3d084beb5 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -9,6 +9,7 @@ module Distribution.Client.ProjectConfig.Legacy ( parseProjectSkeleton, instantiateProjectConfigSkeleton, singletonProjectConfigSkeleton, + projectSkeletonImports, -- * Project config in terms of legacy types LegacyProjectConfig, @@ -43,14 +44,17 @@ import Distribution.Client.CmdInstall.ClientInstallFlags ( ClientInstallFlags(..), defaultClientInstallFlags , clientInstallOptions ) +import Distribution.Compat.Lens (view) + import Distribution.Solver.Types.ConstraintSource import Distribution.FieldGrammar import Distribution.Package import Distribution.Types.SourceRepo (RepoType) -import Distribution.Types.CondTree (CondTree (..), CondBranch (..), condIfThen, condIfThenElse, mapTreeConds) +import Distribution.Types.CondTree + ( CondTree (..), CondBranch (..), condIfThen, condIfThenElse, mapTreeConds, traverseCondTreeC ) import Distribution.PackageDescription - ( dispFlagAssignment, Condition (..), ConfVar (..), FlagAssignment) + ( dispFlagAssignment, Condition (..), ConfVar (..), FlagAssignment ) import Distribution.PackageDescription.Configuration (simplifyWithSysParams) import Distribution.Simple.Compiler ( OptimisationLevel(..), DebugInfoLevel(..), CompilerInfo(..) ) @@ -113,7 +117,8 @@ import Network.URI (URI (..), parseURI) import Distribution.Fields.ConfVar (parseConditionConfVarFromClause) import Distribution.Client.HttpUtils -import System.FilePath (()) +import System.FilePath ((), isPathSeparator) +import System.Directory (createDirectoryIfMissing) @@ -147,6 +152,9 @@ instantiateProjectConfigSkeleton os arch impl _flags skel = go $ mapTreeConds (f (Lit False) -> maybe ([]) ((:[]) . go) mf _ -> error $ "unable to process condition: " ++ show cnd -- TODO it would be nice if there were a pretty printer +projectSkeletonImports :: ProjectConfigSkeleton -> [ProjectConfigImport] +projectSkeletonImports = view traverseCondTreeC + -- NOTE a nice refactor would be to use readFields directly to get a tree structure. parseProjectSkeleton :: FilePath -> HttpTransport -> Verbosity -> FilePath -> BS.ByteString -> IO (ParseResult ProjectConfigSkeleton) parseProjectSkeleton cacheDir httpTransport verbosity source bs = (>>= sanityWalkPCS False) . runInnerParsers <$> linesToNode (BS.lines bs) @@ -192,24 +200,24 @@ parseProjectSkeleton cacheDir httpTransport verbosity source bs = (>>= sanityWal runBranchConditionParser :: CondBranch BS.ByteString [ProjectConfigImport] ProjectConfig -> ParseResult (CondBranch ConfVar [ProjectConfigImport] ProjectConfig) runBranchConditionParser (CondBranch (Var b) t f) = do - c <- adaptParseError $ parseConditionConfVarFromClause b -- nb this loses the source line location, can't win 'em all, sigh. A full refactor of parsers is the "right" way to fix this. + c <- adaptParseError $ parseConditionConfVarFromClause b -- nb this loses the source line location, can't win 'em all, sigh. A full refactor of parsers is the "right" way to fix this. We could also pack bytestrings for conditionals with line locations CondBranch c <$> runConditionParsers t <*> traverse runConditionParsers f runBranchConditionParser (CondBranch x _ _) = error $ "internal cabal invariant error in parsing branch conditions: " ++ show x adaptParseError :: Either P.ParseError a -> ParseResult a adaptParseError (Right x) = pure x - adaptParseError (Left e) = parseFail $ ParseUtils.NoParse (show e) (P.sourceLine $ P.errorPos e) + adaptParseError (Left e) = parseFail $ ParseUtils.FromString (show e) (Just . P.sourceLine $ P.errorPos e) addProvenance x = x {projectConfigProvenance = Set.singleton (Explicit source)} modifiesCompiler :: ProjectConfig -> Bool modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg where - isSet f = f (projectConfigShared pc) == NoFlag + isSet f = f (projectConfigShared pc) /= NoFlag sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectConfigSkeleton sanityWalkPCS underConditional t@(CondNode d _c comps) - | underConditional && modifiesCompiler d = parseFail $ ParseUtils.NoParse "Cannot set compiler in a conditional clause of a cabal project file" 0 + | underConditional && modifiesCompiler d = parseFail $ ParseUtils.FromString "Cannot set compiler in a conditional clause of a cabal project file" Nothing | otherwise = mapM_ sanityWalkBranch comps >> pure t sanityWalkBranch:: CondBranch ConfVar [ProjectConfigImport] ProjectConfig -> ParseResult () @@ -218,19 +226,16 @@ parseProjectSkeleton cacheDir httpTransport verbosity source bs = (>>= sanityWal fetchImportConfig :: ProjectConfigImport -> IO BS.ByteString fetchImportConfig pci = case parseURI pci of Just uri -> do - let fp = cacheDir show uri + let fp = cacheDir map (\x -> if isPathSeparator x then 'X' else x) (show uri) -- TODO can we do better? + createDirectoryIfMissing True cacheDir _ <- downloadURI httpTransport verbosity uri fp BS.readFile fp Nothing -> BS.readFile pci {- --- todo add extra files to file change monitor --- TODO handle importing legacy freeze as well +-- TODO elif -- TODO handle merge semantics for constraints specially - --- TODO somehow handle .local specially to avoid reconfig issues. - -} ------------------------------------------------------------------ diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 628dc7e9f40..3f05be33487 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -40,6 +40,7 @@ module Distribution.Client.ProjectPlanning ( -- * Utils required for building pkgHasEphemeralBuildTargets, elabBuildTargetWholeComponents, + configureCompiler, -- * Setup.hs CLI flags for building setupHsScriptOptions,