better errors and use extended project parsing uniformly

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
 

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

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

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

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.
-
 -}
 
 ------------------------------------------------------------------

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,