Extended project files (conditionals and imports) (#7783)

* initial parser pass

* first compiling pass

* get more stuff sort of working

* conditional parsing actually works

* error cleanup and downloads

* thread through http transport

* fix merge

* better errors and use extended project parsing uniformly

* elif support, maybe?

* fix outdated cmd, add tests, docs

* fix docs

* use legacyReadFields parser

* changelog

* cyclical import detection

* fix shadowing

* add missing file

* finish merge

* fix outstanding merge issue

* use existing config available when checking for compiler for package flags

* review comments

* add missing test file

* Update pr-7783

Co-authored-by: Gershom Bazerman <[email protected]>
Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>

Author: gbaz

Cabal-syntax/src/Distribution/Fields/ConfVar.hs

@@ -1,22 +1,30 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Distribution.Fields.ConfVar (parseConditionConfVar) where
+module Distribution.Fields.ConfVar (parseConditionConfVar, parseConditionConfVarFromClause) where
 
 import Distribution.Compat.CharParsing     (char, integral)
 import Distribution.Compat.Prelude
-import Distribution.Fields.Field           (SectionArg (..))
+import Distribution.Fields.Field           (SectionArg (..), Field(..))
 import Distribution.Fields.ParseResult
 import Distribution.Parsec                 (Parsec (..), Position (..), runParsecParser)
 import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
 import Distribution.Types.Condition
 import Distribution.Types.ConfVar          (ConfVar (..))
+import Distribution.Fields.Parser          (readFields)
 import Distribution.Version
        (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion,
        mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges,
        withinVersion)
 import Prelude ()
 
 import qualified Text.Parsec       as P
+import qualified Text.Parsec.Pos   as P
 import qualified Text.Parsec.Error as P
+import qualified Data.ByteString.Char8          as B8
+
+parseConditionConfVarFromClause :: B8.ByteString -> Either P.ParseError (Condition ConfVar)
+parseConditionConfVarFromClause x = readFields x >>= \r -> case r of
+                                       (Section _ xs _ : _ ) -> P.runParser (parser <* P.eof) () "<condition>" xs
+                                       _ -> Left $ P.newErrorMessage (P.Message "No fields in clause") (P.initialPos "<condition>")
 
 -- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec
 -- based outline parser.

Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs

@@ -32,6 +32,7 @@ module Distribution.PackageDescription.Configuration (
     transformAllBuildInfos,
     transformAllBuildDepends,
     transformAllBuildDependsN,
+    simplifyWithSysParams
   ) where
 
 import Distribution.Compat.Prelude

Cabal-syntax/src/Distribution/Types/CondTree.hs

@@ -68,6 +68,13 @@ instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a)
 instance (Structured v, Structured c, Structured a) => Structured (CondTree v c a)
 instance (NFData v, NFData c, NFData a) => NFData (CondTree v c a) where rnf = genericRnf
 
+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 (Semigroup a, Semigroup c, Monoid a, Monoid c) => Monoid (CondTree v c a) where
+   mappend = (<>)
+   mempty = CondNode mempty mempty mempty
+
 -- | A 'CondBranch' represents a conditional branch, e.g., @if
 -- flag(foo)@ on some syntax @a@.  It also has an optional false
 -- branch.
@@ -191,4 +198,4 @@ foldCondTree e u mergeInclusive mergeExclusive = goTree
     goTree :: CondTree v c a -> b
     goTree (CondNode a c ifs) = u (c, a) `mergeInclusive` foldl goBranch e ifs
     goBranch :: b -> CondBranch v c a -> b
-    goBranch acc (CondBranch _ t mt) = mergeInclusive acc (maybe (goTree t) (mergeExclusive (goTree t) . goTree) mt)
+    goBranch acc (CondBranch _ t mt) = mergeInclusive acc (maybe (goTree t) (mergeExclusive (goTree t) . goTree) mt)

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,8 +131,12 @@ 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)
+            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)

cabal-install/src/Distribution/Client/CmdOutdated.hs

@@ -29,9 +29,8 @@ 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.ProjectFlags
     ( projectFlagsOptions, ProjectFlags(..), defaultProjectFlags
     , removeIgnoreProjectOption )
@@ -40,8 +39,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
@@ -65,7 +62,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 +83,9 @@ import Distribution.Simple.PackageDescription
 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,18 +220,23 @@ 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 $
         "--project-file must only be used with --v2-freeze-file."
 
     sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext
+    (comp, platform, _progdb) <- configCompilerAux' configFlags
     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 comp platform mprojectFile
+                else do
+                  depsFromPkgDesc verbosity comp platform
     debug verbosity $ "Dependencies loaded: "
       ++ intercalate ", " (map prettyShow deps)
     let outdatedDeps = listOutdated deps sourcePkgDb
@@ -293,14 +298,15 @@ 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 -> Compiler -> Platform -> Maybe FilePath -> IO [PackageVersionConstraint]
+depsFromNewFreezeFile verbosity httpTransport compiler (Platform arch os) 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
+                      pure $ instantiateProjectConfigSkeleton os arch (compilerInfo compiler) mempty pcs
   let ucnstrs = map fst . projectConfigConstraints . projectConfigShared
                 $ projectConfig
       deps    = userConstraintsToDependencies ucnstrs

cabal-install/src/Distribution/Client/ParseUtils.hs

@@ -369,4 +369,3 @@ parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str =
 --
 showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc
 showConfig = ppFieldsAndSections
-

cabal-install/src/Distribution/Client/ProjectConfig.hs

@@ -29,7 +29,6 @@ module Distribution.Client.ProjectConfig (
     readGlobalConfig,
     readProjectLocalExtraConfig,
     readProjectLocalFreezeConfig,
-    parseProjectConfig,
     reportParseResult,
     showProjectConfig,
     withProjectOrGlobalConfig,
@@ -504,31 +503,33 @@ withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do
 -- file if any, plus other global config.
 --
 readProjectConfig :: Verbosity
+                  -> HttpTransport
                   -> Flag FilePath
                   -> DistDirLayout
-                  -> Rebuild ProjectConfig
-readProjectConfig verbosity configFileFlag distDirLayout = do
-    global <- readGlobalConfig                verbosity configFileFlag
-    local  <- readProjectLocalConfigOrDefault verbosity distDirLayout
-    freeze <- readProjectLocalFreezeConfig    verbosity distDirLayout
-    extra  <- readProjectLocalExtraConfig     verbosity distDirLayout
+                  -> Rebuild ProjectConfigSkeleton
+readProjectConfig verbosity httpTransport configFileFlag distDirLayout = do
+    global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag
+    local  <- readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout
+    freeze <- readProjectLocalFreezeConfig    verbosity httpTransport distDirLayout
+    extra  <- readProjectLocalExtraConfig     verbosity httpTransport distDirLayout
     return (global <> local <> freeze <> extra)
 
 
 -- | Reads an explicit @cabal.project@ file in the given project root dir,
 -- or returns the default project config for an implicitly defined project.
 --
 readProjectLocalConfigOrDefault :: Verbosity
+                                -> HttpTransport
                                 -> DistDirLayout
-                                -> Rebuild ProjectConfig
-readProjectLocalConfigOrDefault verbosity distDirLayout = do
+                                -> Rebuild ProjectConfigSkeleton
+readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do
   usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile
   if usesExplicitProjectRoot
     then do
-      readProjectFile verbosity distDirLayout "" "project file"
+      readProjectFileSkeleton verbosity httpTransport distDirLayout "" "project file"
     else do
       monitorFiles [monitorNonExistentFile projectFile]
-      return defaultImplicitProjectConfig
+      return (singletonProjectConfigSkeleton defaultImplicitProjectConfig)
 
   where
     projectFile :: FilePath
@@ -547,66 +548,43 @@ readProjectLocalConfigOrDefault verbosity 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 config file in the given project root dir, or returns empty.
+-- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty.
 --
-readProjectFile :: Verbosity
-                -> DistDirLayout
-                -> String
-                -> String
-                -> Rebuild ProjectConfig
-readProjectFile verbosity DistDirLayout{distProjectFile}
+readProjectFileSkeleton :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton
+readProjectFileSkeleton verbosity httpTransport DistDirLayout{distProjectFile, distDownloadSrcDirectory}
                          extensionName extensionDescription = do
     exists <- liftIO $ doesFileExist extensionFile
     if exists
       then do monitorFiles [monitorFileHashed extensionFile]
-              addProjectFileProvenance <$> liftIO readExtensionFile
+              pcs <- liftIO readExtensionFile
+              monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs)
+              pure pcs
       else do monitorFiles [monitorNonExistentFile extensionFile]
               return mempty
   where
-    extensionFile :: FilePath
     extensionFile = distProjectFile extensionName
 
-    readExtensionFile :: IO ProjectConfig
     readExtensionFile =
           reportParseResult verbosity extensionDescription extensionFile
-        . (parseProjectConfig extensionFile)
+      =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] 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
@@ -647,12 +625,12 @@ readGlobalConfig verbosity configFileFlag = do
     monitorFiles [monitorFileHashed configFile]
     return (convertLegacyGlobalConfig config)
 
-reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult a -> IO a
+reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton
 reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do
-    unless (null warnings) $
-      let msg = unlines (map (OldParser.showPWarning filename) warnings)
+   unless (null warnings) $
+      let msg = unlines (map (OldParser.showPWarning (intercalate ", " $ filename : projectSkeletonImports x)) warnings)
        in warn verbosity msg
-    return x
+   return x
 reportParseResult verbosity filetype filename (OldParser.ParseFailed err) =
     let (line, msg) = OldParser.locatedErrorMsg err
      in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename