{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE RecordWildCards    #-}

-- | Handling project configuration.
--
module Distribution.Client.ProjectConfig (

    -- * Types for project config
    ProjectConfig(..),
    ProjectConfigBuildOnly(..),
    ProjectConfigShared(..),
    ProjectConfigProvenance(..),
    PackageConfig(..),
    MapLast(..),
    MapMappend(..),

    -- * Project root
    findProjectRoot,
    ProjectRoot(..),
    BadProjectRoot(..),

    -- * Project config files
    readProjectConfig,
    readGlobalConfig,
    readProjectLocalExtraConfig,
    readProjectLocalFreezeConfig,
    reportParseResult,
    showProjectConfig,
    withProjectOrGlobalConfig,
    writeProjectLocalExtraConfig,
    writeProjectLocalFreezeConfig,
    writeProjectConfigFile,
    commandLineFlagsToProjectConfig,

    -- * Packages within projects
    ProjectPackageLocation(..),
    BadPackageLocations(..),
    BadPackageLocation(..),
    BadPackageLocationMatch(..),
    findProjectPackages,
    fetchAndReadSourcePackages,

    -- * Resolving configuration
    lookupLocalPackageConfig,
    projectConfigWithBuilderRepoContext,
    projectConfigWithSolverRepoContext,
    SolverSettings(..),
    resolveSolverSettings,
    BuildTimeSettings(..),
    resolveBuildTimeSettings,

    -- * Checking configuration
    checkBadPerPackageCompilerPaths,
    BadPerPackageCompilerPaths(..)
  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude

import Distribution.Client.ProjectConfig.Types
import Distribution.Client.ProjectConfig.Legacy
import Distribution.Client.RebuildMonad
import Distribution.Client.Glob
         ( isTrivialFilePathGlob )
import Distribution.Client.VCS
         ( validateSourceRepos, SourceRepoProblem(..)
         , VCS(..), knownVCSs, configureVCS, syncSourceRepos )

import Distribution.Client.Types
import Distribution.Client.DistDirLayout
         ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..) )
import Distribution.Client.GlobalFlags
         ( RepoContext(..), withRepoContext' )
import Distribution.Client.BuildReports.Types
         ( ReportLevel(..) )
import Distribution.Client.Config
         ( loadConfig, getConfigFilePath )
import Distribution.Client.HttpUtils
         ( HttpTransport, configureTransport, transportCheckHttps
         , downloadURI )
import Distribution.Client.Utils.Parsec (renderParseError)

import Distribution.Solver.Types.SourcePackage
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.PackageConstraint
         ( PackageProperty(..) )

import Distribution.Package
         ( PackageName, PackageId, UnitId, packageId )
import Distribution.Types.PackageVersionConstraint
         ( PackageVersionConstraint(..) )
import Distribution.System
         ( Platform )
import Distribution.Types.GenericPackageDescription
         ( GenericPackageDescription )
import Distribution.PackageDescription.Parsec
         ( parseGenericPackageDescription )
import Distribution.Fields
         ( runParseResult, PError, PWarning, showPWarning)
import Distribution.Types.SourceRepo
         ( RepoType(..) )
import Distribution.Client.Types.SourceRepo
         ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut )
import Distribution.Simple.Compiler
         ( Compiler, compilerInfo )
import Distribution.Simple.Program
         ( ConfiguredProgram(..) )
import Distribution.Simple.Setup
         ( Flag(Flag), toFlag, flagToMaybe, flagToList
         , fromFlag, fromFlagOrDefault )
import Distribution.Client.Setup
         ( defaultSolver, defaultMaxBackjumps )
import Distribution.Simple.InstallDirs
         ( PathTemplate, fromPathTemplate
         , toPathTemplate, substPathTemplate, initialPathTemplateEnv )
import Distribution.Simple.Utils
         ( die', warn, notice, info, createDirectoryIfMissingVerbose, maybeExit, rawSystemIOWithEnv )
import Distribution.Client.Utils
         ( determineNumJobs )
import Distribution.Utils.NubList
         ( fromNubList )
import Distribution.Verbosity
         ( modifyVerbosity, verbose )
import Distribution.Version
         ( Version )
import qualified Distribution.Deprecated.ParseUtils as OldParser
         ( ParseResult(..), locatedErrorMsg, showPWarning )
import Distribution.Client.SrcDist
         ( packageDirToSdist )

import qualified Codec.Archive.Tar       as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Distribution.Client.Tar as Tar
import qualified Distribution.Client.GZipUtils as GZipUtils

import Control.Monad.Trans (liftIO)
import qualified Data.ByteString       as BS
import qualified Data.ByteString.Lazy  as LBS
import qualified Data.Map as Map
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as Set
import qualified Data.Hashable as Hashable
import Numeric (showHex)

import System.FilePath hiding (combine)
import System.IO
         ( withBinaryFile, IOMode(ReadMode) )
import System.Directory
import Network.URI
         ( URI(..), URIAuth(..), parseAbsoluteURI, uriToString )


----------------------------------------
-- Resolving configuration to settings
--

-- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific
-- 'PackageName'. This returns the configuration that applies to all local
-- packages plus any package-specific configuration for this package.
--
lookupLocalPackageConfig
  :: (Semigroup a, Monoid a)
  => (PackageConfig -> a) -> ProjectConfig -> PackageName
  -> a
lookupLocalPackageConfig :: forall a.
(Semigroup a, Monoid a) =>
(PackageConfig -> a) -> ProjectConfig -> PackageName -> a
lookupLocalPackageConfig PackageConfig -> a
field ProjectConfig {
                           PackageConfig
projectConfigLocalPackages :: ProjectConfig -> PackageConfig
projectConfigLocalPackages :: PackageConfig
projectConfigLocalPackages,
                           MapMappend PackageName PackageConfig
projectConfigSpecificPackage :: ProjectConfig -> MapMappend PackageName PackageConfig
projectConfigSpecificPackage :: MapMappend PackageName PackageConfig
projectConfigSpecificPackage
                         } PackageName
pkgname =
    PackageConfig -> a
field PackageConfig
projectConfigLocalPackages
 forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty PackageConfig -> a
field
          (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgname (forall k v. MapMappend k v -> Map k v
getMapMappend MapMappend PackageName PackageConfig
projectConfigSpecificPackage))


-- | Use a 'RepoContext' based on the 'BuildTimeSettings'.
--
projectConfigWithBuilderRepoContext :: Verbosity
                                    -> BuildTimeSettings
                                    -> (RepoContext -> IO a) -> IO a
projectConfigWithBuilderRepoContext :: forall a.
Verbosity -> BuildTimeSettings -> (RepoContext -> IO a) -> IO a
projectConfigWithBuilderRepoContext Verbosity
verbosity BuildTimeSettings{Bool
Int
String
[String]
[PathTemplate]
[LocalRepo]
[RemoteRepo]
Maybe String
Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
Verbosity
ReportLevel
buildSettingHaddockOpen :: BuildTimeSettings -> Bool
buildSettingProgPathExtra :: BuildTimeSettings -> [String]
buildSettingIgnoreExpiry :: BuildTimeSettings -> Bool
buildSettingHttpTransport :: BuildTimeSettings -> Maybe String
buildSettingCacheDir :: BuildTimeSettings -> String
buildSettingLocalNoIndexRepos :: BuildTimeSettings -> [LocalRepo]
buildSettingRemoteRepos :: BuildTimeSettings -> [RemoteRepo]
buildSettingKeepTempFiles :: BuildTimeSettings -> Bool
buildSettingOfflineMode :: BuildTimeSettings -> Bool
buildSettingKeepGoing :: BuildTimeSettings -> Bool
buildSettingNumJobs :: BuildTimeSettings -> Int
buildSettingSymlinkBinDir :: BuildTimeSettings -> [String]
buildSettingReportPlanningFailure :: BuildTimeSettings -> Bool
buildSettingBuildReports :: BuildTimeSettings -> ReportLevel
buildSettingLogVerbosity :: BuildTimeSettings -> Verbosity
buildSettingLogFile :: BuildTimeSettings
-> Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
buildSettingSummaryFile :: BuildTimeSettings -> [PathTemplate]
buildSettingOnlyDownload :: BuildTimeSettings -> Bool
buildSettingOnlyDeps :: BuildTimeSettings -> Bool
buildSettingDryRun :: BuildTimeSettings -> Bool
buildSettingHaddockOpen :: Bool
buildSettingProgPathExtra :: [String]
buildSettingIgnoreExpiry :: Bool
buildSettingHttpTransport :: Maybe String
buildSettingCacheDir :: String
buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingRemoteRepos :: [RemoteRepo]
buildSettingKeepTempFiles :: Bool
buildSettingOfflineMode :: Bool
buildSettingKeepGoing :: Bool
buildSettingNumJobs :: Int
buildSettingSymlinkBinDir :: [String]
buildSettingReportPlanningFailure :: Bool
buildSettingBuildReports :: ReportLevel
buildSettingLogVerbosity :: Verbosity
buildSettingLogFile :: Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
buildSettingSummaryFile :: [PathTemplate]
buildSettingOnlyDownload :: Bool
buildSettingOnlyDeps :: Bool
buildSettingDryRun :: Bool
..} =
    forall a.
Verbosity
-> [RemoteRepo]
-> [LocalRepo]
-> String
-> Maybe String
-> Maybe Bool
-> [String]
-> (RepoContext -> IO a)
-> IO a
withRepoContext'
      Verbosity
verbosity
      [RemoteRepo]
buildSettingRemoteRepos
      [LocalRepo]
buildSettingLocalNoIndexRepos
      String
buildSettingCacheDir
      Maybe String
buildSettingHttpTransport
      (forall a. a -> Maybe a
Just Bool
buildSettingIgnoreExpiry)
      [String]
buildSettingProgPathExtra


-- | Use a 'RepoContext', but only for the solver. The solver does not use the
-- full facilities of the 'RepoContext' so we can get away with making one
-- that doesn't have an http transport. And that avoids having to have access
-- to the 'BuildTimeSettings'
--
projectConfigWithSolverRepoContext
  :: Verbosity -> ProjectConfigShared -> ProjectConfigBuildOnly
  -> (RepoContext -> IO a)
  -> IO a
projectConfigWithSolverRepoContext :: forall a.
Verbosity
-> ProjectConfigShared
-> ProjectConfigBuildOnly
-> (RepoContext -> IO a)
-> IO a
projectConfigWithSolverRepoContext Verbosity
verbosity
                                   ProjectConfigShared{[Maybe PackageDB]
[(UserConstraint, ConstraintSource)]
[PackageVersionConstraint]
Maybe AllowOlder
Maybe AllowNewer
NubList String
NubList LocalRepo
NubList RemoteRepo
InstallDirs (Flag PathTemplate)
Flag Bool
Flag Int
Flag String
Flag CompilerFlavor
Flag PathTemplate
Flag Version
Flag ReorderGoals
Flag CountConflicts
Flag FineGrainedConflicts
Flag MinimizeConflictSet
Flag IndependentGoals
Flag PreferOldest
Flag StrongFlags
Flag AllowBootLibInstalls
Flag OnlyConstrained
Flag PreSolver
Flag TotalIndexState
Flag ActiveRepos
Flag WriteGhcEnvironmentFilesPolicy
projectConfigProgPathExtra :: ProjectConfigShared -> NubList String
projectConfigPreferOldest :: ProjectConfigShared -> Flag PreferOldest
projectConfigIndependentGoals :: ProjectConfigShared -> Flag IndependentGoals
projectConfigPerComponent :: ProjectConfigShared -> Flag Bool
projectConfigOnlyConstrained :: ProjectConfigShared -> Flag OnlyConstrained
projectConfigAllowBootLibInstalls :: ProjectConfigShared -> Flag AllowBootLibInstalls
projectConfigStrongFlags :: ProjectConfigShared -> Flag StrongFlags
projectConfigMinimizeConflictSet :: ProjectConfigShared -> Flag MinimizeConflictSet
projectConfigFineGrainedConflicts :: ProjectConfigShared -> Flag FineGrainedConflicts
projectConfigCountConflicts :: ProjectConfigShared -> Flag CountConflicts
projectConfigReorderGoals :: ProjectConfigShared -> Flag ReorderGoals
projectConfigMaxBackjumps :: ProjectConfigShared -> Flag Int
projectConfigWriteGhcEnvironmentFilesPolicy :: ProjectConfigShared -> Flag WriteGhcEnvironmentFilesPolicy
projectConfigAllowNewer :: ProjectConfigShared -> Maybe AllowNewer
projectConfigAllowOlder :: ProjectConfigShared -> Maybe AllowOlder
projectConfigSolver :: ProjectConfigShared -> Flag PreSolver
projectConfigCabalVersion :: ProjectConfigShared -> Flag Version
projectConfigPreferences :: ProjectConfigShared -> [PackageVersionConstraint]
projectConfigConstraints :: ProjectConfigShared -> [(UserConstraint, ConstraintSource)]
projectConfigStoreDir :: ProjectConfigShared -> Flag String
projectConfigIndexState :: ProjectConfigShared -> Flag TotalIndexState
projectConfigActiveRepos :: ProjectConfigShared -> Flag ActiveRepos
projectConfigLocalNoIndexRepos :: ProjectConfigShared -> NubList LocalRepo
projectConfigRemoteRepos :: ProjectConfigShared -> NubList RemoteRepo
projectConfigPackageDBs :: ProjectConfigShared -> [Maybe PackageDB]
projectConfigInstallDirs :: ProjectConfigShared -> InstallDirs (Flag PathTemplate)
projectConfigHaddockIndex :: ProjectConfigShared -> Flag PathTemplate
projectConfigHcPkg :: ProjectConfigShared -> Flag String
projectConfigHcPath :: ProjectConfigShared -> Flag String
projectConfigHcFlavor :: ProjectConfigShared -> Flag CompilerFlavor
projectConfigIgnoreProject :: ProjectConfigShared -> Flag Bool
projectConfigProjectFile :: ProjectConfigShared -> Flag String
projectConfigConfigFile :: ProjectConfigShared -> Flag String
projectConfigDistDir :: ProjectConfigShared -> Flag String
projectConfigProgPathExtra :: NubList String
projectConfigPreferOldest :: Flag PreferOldest
projectConfigIndependentGoals :: Flag IndependentGoals
projectConfigPerComponent :: Flag Bool
projectConfigOnlyConstrained :: Flag OnlyConstrained
projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls
projectConfigStrongFlags :: Flag StrongFlags
projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet
projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts
projectConfigCountConflicts :: Flag CountConflicts
projectConfigReorderGoals :: Flag ReorderGoals
projectConfigMaxBackjumps :: Flag Int
projectConfigWriteGhcEnvironmentFilesPolicy :: Flag WriteGhcEnvironmentFilesPolicy
projectConfigAllowNewer :: Maybe AllowNewer
projectConfigAllowOlder :: Maybe AllowOlder
projectConfigSolver :: Flag PreSolver
projectConfigCabalVersion :: Flag Version
projectConfigPreferences :: [PackageVersionConstraint]
projectConfigConstraints :: [(UserConstraint, ConstraintSource)]
projectConfigStoreDir :: Flag String
projectConfigIndexState :: Flag TotalIndexState
projectConfigActiveRepos :: Flag ActiveRepos
projectConfigLocalNoIndexRepos :: NubList LocalRepo
projectConfigRemoteRepos :: NubList RemoteRepo
projectConfigPackageDBs :: [Maybe PackageDB]
projectConfigInstallDirs :: InstallDirs (Flag PathTemplate)
projectConfigHaddockIndex :: Flag PathTemplate
projectConfigHcPkg :: Flag String
projectConfigHcPath :: Flag String
projectConfigHcFlavor :: Flag CompilerFlavor
projectConfigIgnoreProject :: Flag Bool
projectConfigProjectFile :: Flag String
projectConfigConfigFile :: Flag String
projectConfigDistDir :: Flag String
..}
                                   ProjectConfigBuildOnly{NubList PathTemplate
Flag Bool
Flag String
Flag (Maybe Int)
Flag Verbosity
Flag PathTemplate
Flag ReportLevel
ClientInstallFlags
projectConfigClientInstallFlags :: ProjectConfigBuildOnly -> ClientInstallFlags
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag String
projectConfigCacheDir :: ProjectConfigBuildOnly -> Flag String
projectConfigIgnoreExpiry :: ProjectConfigBuildOnly -> Flag Bool
projectConfigHttpTransport :: ProjectConfigBuildOnly -> Flag String
projectConfigKeepTempFiles :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOfflineMode :: ProjectConfigBuildOnly -> Flag Bool
projectConfigKeepGoing :: ProjectConfigBuildOnly -> Flag Bool
projectConfigNumJobs :: ProjectConfigBuildOnly -> Flag (Maybe Int)
projectConfigSymlinkBinDir :: ProjectConfigBuildOnly -> Flag String
projectConfigReportPlanningFailure :: ProjectConfigBuildOnly -> Flag Bool
projectConfigBuildReports :: ProjectConfigBuildOnly -> Flag ReportLevel
projectConfigLogFile :: ProjectConfigBuildOnly -> Flag PathTemplate
projectConfigSummaryFile :: ProjectConfigBuildOnly -> NubList PathTemplate
projectConfigOnlyDownload :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOnlyDeps :: ProjectConfigBuildOnly -> Flag Bool
projectConfigDryRun :: ProjectConfigBuildOnly -> Flag Bool
projectConfigVerbosity :: ProjectConfigBuildOnly -> Flag Verbosity
projectConfigClientInstallFlags :: ClientInstallFlags
projectConfigLogsDir :: Flag String
projectConfigCacheDir :: Flag String
projectConfigIgnoreExpiry :: Flag Bool
projectConfigHttpTransport :: Flag String
projectConfigKeepTempFiles :: Flag Bool
projectConfigOfflineMode :: Flag Bool
projectConfigKeepGoing :: Flag Bool
projectConfigNumJobs :: Flag (Maybe Int)
projectConfigSymlinkBinDir :: Flag String
projectConfigReportPlanningFailure :: Flag Bool
projectConfigBuildReports :: Flag ReportLevel
projectConfigLogFile :: Flag PathTemplate
projectConfigSummaryFile :: NubList PathTemplate
projectConfigOnlyDownload :: Flag Bool
projectConfigOnlyDeps :: Flag Bool
projectConfigDryRun :: Flag Bool
projectConfigVerbosity :: Flag Verbosity
..} =
    forall a.
Verbosity
-> [RemoteRepo]
-> [LocalRepo]
-> String
-> Maybe String
-> Maybe Bool
-> [String]
-> (RepoContext -> IO a)
-> IO a
withRepoContext'
      Verbosity
verbosity
      (forall a. NubList a -> [a]
fromNubList NubList RemoteRepo
projectConfigRemoteRepos)
      (forall a. NubList a -> [a]
fromNubList NubList LocalRepo
projectConfigLocalNoIndexRepos)
      (forall a. a -> Flag a -> a
fromFlagOrDefault
                   (forall a. HasCallStack => String -> a
error
                    String
"projectConfigWithSolverRepoContext: projectConfigCacheDir")
                   Flag String
projectConfigCacheDir)
      (forall a. Flag a -> Maybe a
flagToMaybe Flag String
projectConfigHttpTransport)
      (forall a. Flag a -> Maybe a
flagToMaybe Flag Bool
projectConfigIgnoreExpiry)
      (forall a. NubList a -> [a]
fromNubList NubList String
projectConfigProgPathExtra)


-- | Resolve the project configuration, with all its optional fields, into
-- 'SolverSettings' with no optional fields (by applying defaults).
--
resolveSolverSettings :: ProjectConfig -> SolverSettings
resolveSolverSettings :: ProjectConfig -> SolverSettings
resolveSolverSettings ProjectConfig{
                        ProjectConfigShared
projectConfigShared :: ProjectConfig -> ProjectConfigShared
projectConfigShared :: ProjectConfigShared
projectConfigShared,
                        PackageConfig
projectConfigLocalPackages :: PackageConfig
projectConfigLocalPackages :: ProjectConfig -> PackageConfig
projectConfigLocalPackages,
                        MapMappend PackageName PackageConfig
projectConfigSpecificPackage :: MapMappend PackageName PackageConfig
projectConfigSpecificPackage :: ProjectConfig -> MapMappend PackageName PackageConfig
projectConfigSpecificPackage
                      } =
    SolverSettings {[(UserConstraint, ConstraintSource)]
[PackageVersionConstraint]
[LocalRepo]
[RemoteRepo]
Maybe Int
Maybe Version
Maybe TotalIndexState
Maybe ActiveRepos
Map PackageName FlagAssignment
FlagAssignment
ReorderGoals
CountConflicts
FineGrainedConflicts
MinimizeConflictSet
IndependentGoals
PreferOldest
StrongFlags
AllowBootLibInstalls
OnlyConstrained
PreSolver
AllowOlder
AllowNewer
solverSettingPreferOldest :: PreferOldest
solverSettingIndependentGoals :: IndependentGoals
solverSettingActiveRepos :: Maybe ActiveRepos
solverSettingIndexState :: Maybe TotalIndexState
solverSettingOnlyConstrained :: OnlyConstrained
solverSettingAllowBootLibInstalls :: AllowBootLibInstalls
solverSettingStrongFlags :: StrongFlags
solverSettingMinimizeConflictSet :: MinimizeConflictSet
solverSettingFineGrainedConflicts :: FineGrainedConflicts
solverSettingCountConflicts :: CountConflicts
solverSettingReorderGoals :: ReorderGoals
solverSettingMaxBackjumps :: Maybe Int
solverSettingAllowNewer :: AllowNewer
solverSettingAllowOlder :: AllowOlder
solverSettingSolver :: PreSolver
solverSettingCabalVersion :: Maybe Version
solverSettingFlagAssignments :: Map PackageName FlagAssignment
solverSettingFlagAssignment :: FlagAssignment
solverSettingPreferences :: [PackageVersionConstraint]
solverSettingConstraints :: [(UserConstraint, ConstraintSource)]
solverSettingLocalNoIndexRepos :: [LocalRepo]
solverSettingRemoteRepos :: [RemoteRepo]
solverSettingPreferOldest :: PreferOldest
solverSettingIndependentGoals :: IndependentGoals
solverSettingActiveRepos :: Maybe ActiveRepos
solverSettingIndexState :: Maybe TotalIndexState
solverSettingOnlyConstrained :: OnlyConstrained
solverSettingAllowBootLibInstalls :: AllowBootLibInstalls
solverSettingStrongFlags :: StrongFlags
solverSettingMinimizeConflictSet :: MinimizeConflictSet
solverSettingFineGrainedConflicts :: FineGrainedConflicts
solverSettingCountConflicts :: CountConflicts
solverSettingReorderGoals :: ReorderGoals
solverSettingMaxBackjumps :: Maybe Int
solverSettingAllowNewer :: AllowNewer
solverSettingAllowOlder :: AllowOlder
solverSettingSolver :: PreSolver
solverSettingCabalVersion :: Maybe Version
solverSettingFlagAssignments :: Map PackageName FlagAssignment
solverSettingFlagAssignment :: FlagAssignment
solverSettingPreferences :: [PackageVersionConstraint]
solverSettingConstraints :: [(UserConstraint, ConstraintSource)]
solverSettingLocalNoIndexRepos :: [LocalRepo]
solverSettingRemoteRepos :: [RemoteRepo]
..}
  where
    --TODO: [required eventually] some of these settings need validation, e.g.
    -- the flag assignments need checking.
    solverSettingRemoteRepos :: [RemoteRepo]
solverSettingRemoteRepos       = forall a. NubList a -> [a]
fromNubList NubList RemoteRepo
projectConfigRemoteRepos
    solverSettingLocalNoIndexRepos :: [LocalRepo]
solverSettingLocalNoIndexRepos = forall a. NubList a -> [a]
fromNubList NubList LocalRepo
projectConfigLocalNoIndexRepos
    solverSettingConstraints :: [(UserConstraint, ConstraintSource)]
solverSettingConstraints       = [(UserConstraint, ConstraintSource)]
projectConfigConstraints
    solverSettingPreferences :: [PackageVersionConstraint]
solverSettingPreferences       = [PackageVersionConstraint]
projectConfigPreferences
    solverSettingFlagAssignment :: FlagAssignment
solverSettingFlagAssignment    = PackageConfig -> FlagAssignment
packageConfigFlagAssignment PackageConfig
projectConfigLocalPackages
    solverSettingFlagAssignments :: Map PackageName FlagAssignment
solverSettingFlagAssignments   = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageConfig -> FlagAssignment
packageConfigFlagAssignment
                                          (forall k v. MapMappend k v -> Map k v
getMapMappend MapMappend PackageName PackageConfig
projectConfigSpecificPackage)
    solverSettingCabalVersion :: Maybe Version
solverSettingCabalVersion      = forall a. Flag a -> Maybe a
flagToMaybe Flag Version
projectConfigCabalVersion
    solverSettingSolver :: PreSolver
solverSettingSolver            = forall a. WithCallStack (Flag a -> a)
fromFlag Flag PreSolver
projectConfigSolver
    solverSettingAllowOlder :: AllowOlder
solverSettingAllowOlder        = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe AllowOlder
projectConfigAllowOlder
    solverSettingAllowNewer :: AllowNewer
solverSettingAllowNewer        = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe AllowNewer
projectConfigAllowNewer
    solverSettingMaxBackjumps :: Maybe Int
solverSettingMaxBackjumps      = case forall a. WithCallStack (Flag a -> a)
fromFlag Flag Int
projectConfigMaxBackjumps of
                                       Int
n | Int
n forall a. Ord a => a -> a -> Bool
< Int
0     -> forall a. Maybe a
Nothing
                                         | Bool
otherwise -> forall a. a -> Maybe a
Just Int
n
    solverSettingReorderGoals :: ReorderGoals
solverSettingReorderGoals      = forall a. WithCallStack (Flag a -> a)
fromFlag Flag ReorderGoals
projectConfigReorderGoals
    solverSettingCountConflicts :: CountConflicts
solverSettingCountConflicts    = forall a. WithCallStack (Flag a -> a)
fromFlag Flag CountConflicts
projectConfigCountConflicts
    solverSettingFineGrainedConflicts :: FineGrainedConflicts
solverSettingFineGrainedConflicts = forall a. WithCallStack (Flag a -> a)
fromFlag Flag FineGrainedConflicts
projectConfigFineGrainedConflicts
    solverSettingMinimizeConflictSet :: MinimizeConflictSet
solverSettingMinimizeConflictSet = forall a. WithCallStack (Flag a -> a)
fromFlag Flag MinimizeConflictSet
projectConfigMinimizeConflictSet
    solverSettingStrongFlags :: StrongFlags
solverSettingStrongFlags       = forall a. WithCallStack (Flag a -> a)
fromFlag Flag StrongFlags
projectConfigStrongFlags
    solverSettingAllowBootLibInstalls :: AllowBootLibInstalls
solverSettingAllowBootLibInstalls = forall a. WithCallStack (Flag a -> a)
fromFlag Flag AllowBootLibInstalls
projectConfigAllowBootLibInstalls
    solverSettingOnlyConstrained :: OnlyConstrained
solverSettingOnlyConstrained   = forall a. WithCallStack (Flag a -> a)
fromFlag Flag OnlyConstrained
projectConfigOnlyConstrained
    solverSettingIndexState :: Maybe TotalIndexState
solverSettingIndexState        = forall a. Flag a -> Maybe a
flagToMaybe Flag TotalIndexState
projectConfigIndexState
    solverSettingActiveRepos :: Maybe ActiveRepos
solverSettingActiveRepos       = forall a. Flag a -> Maybe a
flagToMaybe Flag ActiveRepos
projectConfigActiveRepos
    solverSettingIndependentGoals :: IndependentGoals
solverSettingIndependentGoals  = forall a. WithCallStack (Flag a -> a)
fromFlag Flag IndependentGoals
projectConfigIndependentGoals
    solverSettingPreferOldest :: PreferOldest
solverSettingPreferOldest      = forall a. WithCallStack (Flag a -> a)
fromFlag Flag PreferOldest
projectConfigPreferOldest
  --solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs
  --solverSettingReinstall         = fromFlag projectConfigReinstall
  --solverSettingAvoidReinstalls   = fromFlag projectConfigAvoidReinstalls
  --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall
  --solverSettingUpgradeDeps       = fromFlag projectConfigUpgradeDeps

    ProjectConfigShared {[Maybe PackageDB]
[(UserConstraint, ConstraintSource)]
[PackageVersionConstraint]
Maybe AllowOlder
Maybe AllowNewer
NubList String
NubList LocalRepo
NubList RemoteRepo
InstallDirs (Flag PathTemplate)
Flag Bool
Flag Int
Flag String
Flag CompilerFlavor
Flag PathTemplate
Flag Version
Flag ReorderGoals
Flag CountConflicts
Flag FineGrainedConflicts
Flag MinimizeConflictSet
Flag IndependentGoals
Flag PreferOldest
Flag StrongFlags
Flag AllowBootLibInstalls
Flag OnlyConstrained
Flag PreSolver
Flag TotalIndexState
Flag ActiveRepos
Flag WriteGhcEnvironmentFilesPolicy
projectConfigProgPathExtra :: NubList String
projectConfigPerComponent :: Flag Bool
projectConfigWriteGhcEnvironmentFilesPolicy :: Flag WriteGhcEnvironmentFilesPolicy
projectConfigStoreDir :: Flag String
projectConfigPackageDBs :: [Maybe PackageDB]
projectConfigInstallDirs :: InstallDirs (Flag PathTemplate)
projectConfigHaddockIndex :: Flag PathTemplate
projectConfigHcPkg :: Flag String
projectConfigHcPath :: Flag String
projectConfigHcFlavor :: Flag CompilerFlavor
projectConfigIgnoreProject :: Flag Bool
projectConfigProjectFile :: Flag String
projectConfigConfigFile :: Flag String
projectConfigDistDir :: Flag String
projectConfigPreferOldest :: Flag PreferOldest
projectConfigIndependentGoals :: Flag IndependentGoals
projectConfigActiveRepos :: Flag ActiveRepos
projectConfigIndexState :: Flag TotalIndexState
projectConfigOnlyConstrained :: Flag OnlyConstrained
projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls
projectConfigStrongFlags :: Flag StrongFlags
projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet
projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts
projectConfigCountConflicts :: Flag CountConflicts
projectConfigReorderGoals :: Flag ReorderGoals
projectConfigMaxBackjumps :: Flag Int
projectConfigAllowNewer :: Maybe AllowNewer
projectConfigAllowOlder :: Maybe AllowOlder
projectConfigSolver :: Flag PreSolver
projectConfigCabalVersion :: Flag Version
projectConfigPreferences :: [PackageVersionConstraint]
projectConfigConstraints :: [(UserConstraint, ConstraintSource)]
projectConfigLocalNoIndexRepos :: NubList LocalRepo
projectConfigRemoteRepos :: NubList RemoteRepo
projectConfigProgPathExtra :: ProjectConfigShared -> NubList String
projectConfigPreferOldest :: ProjectConfigShared -> Flag PreferOldest
projectConfigIndependentGoals :: ProjectConfigShared -> Flag IndependentGoals
projectConfigPerComponent :: ProjectConfigShared -> Flag Bool
projectConfigOnlyConstrained :: ProjectConfigShared -> Flag OnlyConstrained
projectConfigAllowBootLibInstalls :: ProjectConfigShared -> Flag AllowBootLibInstalls
projectConfigStrongFlags :: ProjectConfigShared -> Flag StrongFlags
projectConfigMinimizeConflictSet :: ProjectConfigShared -> Flag MinimizeConflictSet
projectConfigFineGrainedConflicts :: ProjectConfigShared -> Flag FineGrainedConflicts
projectConfigCountConflicts :: ProjectConfigShared -> Flag CountConflicts
projectConfigReorderGoals :: ProjectConfigShared -> Flag ReorderGoals
projectConfigMaxBackjumps :: ProjectConfigShared -> Flag Int
projectConfigWriteGhcEnvironmentFilesPolicy :: ProjectConfigShared -> Flag WriteGhcEnvironmentFilesPolicy
projectConfigAllowNewer :: ProjectConfigShared -> Maybe AllowNewer
projectConfigAllowOlder :: ProjectConfigShared -> Maybe AllowOlder
projectConfigSolver :: ProjectConfigShared -> Flag PreSolver
projectConfigCabalVersion :: ProjectConfigShared -> Flag Version
projectConfigPreferences :: ProjectConfigShared -> [PackageVersionConstraint]
projectConfigConstraints :: ProjectConfigShared -> [(UserConstraint, ConstraintSource)]
projectConfigStoreDir :: ProjectConfigShared -> Flag String
projectConfigIndexState :: ProjectConfigShared -> Flag TotalIndexState
projectConfigActiveRepos :: ProjectConfigShared -> Flag ActiveRepos
projectConfigLocalNoIndexRepos :: ProjectConfigShared -> NubList LocalRepo
projectConfigRemoteRepos :: ProjectConfigShared -> NubList RemoteRepo
projectConfigPackageDBs :: ProjectConfigShared -> [Maybe PackageDB]
projectConfigInstallDirs :: ProjectConfigShared -> InstallDirs (Flag PathTemplate)
projectConfigHaddockIndex :: ProjectConfigShared -> Flag PathTemplate
projectConfigHcPkg :: ProjectConfigShared -> Flag String
projectConfigHcPath :: ProjectConfigShared -> Flag String
projectConfigHcFlavor :: ProjectConfigShared -> Flag CompilerFlavor
projectConfigIgnoreProject :: ProjectConfigShared -> Flag Bool
projectConfigProjectFile :: ProjectConfigShared -> Flag String
projectConfigConfigFile :: ProjectConfigShared -> Flag String
projectConfigDistDir :: ProjectConfigShared -> Flag String
..} = ProjectConfigShared
defaults forall a. Semigroup a => a -> a -> a
<> ProjectConfigShared
projectConfigShared

    defaults :: ProjectConfigShared
defaults = forall a. Monoid a => a
mempty {
       projectConfigSolver :: Flag PreSolver
projectConfigSolver            = forall a. a -> Flag a
Flag PreSolver
defaultSolver,
       projectConfigAllowOlder :: Maybe AllowOlder
projectConfigAllowOlder        = forall a. a -> Maybe a
Just (RelaxDeps -> AllowOlder
AllowOlder forall a. Monoid a => a
mempty),
       projectConfigAllowNewer :: Maybe AllowNewer
projectConfigAllowNewer        = forall a. a -> Maybe a
Just (RelaxDeps -> AllowNewer
AllowNewer forall a. Monoid a => a
mempty),
       projectConfigMaxBackjumps :: Flag Int
projectConfigMaxBackjumps      = forall a. a -> Flag a
Flag Int
defaultMaxBackjumps,
       projectConfigReorderGoals :: Flag ReorderGoals
projectConfigReorderGoals      = forall a. a -> Flag a
Flag (Bool -> ReorderGoals
ReorderGoals Bool
False),
       projectConfigCountConflicts :: Flag CountConflicts
projectConfigCountConflicts    = forall a. a -> Flag a
Flag (Bool -> CountConflicts
CountConflicts Bool
True),
       projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts
projectConfigFineGrainedConflicts = forall a. a -> Flag a
Flag (Bool -> FineGrainedConflicts
FineGrainedConflicts Bool
True),
       projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet
projectConfigMinimizeConflictSet = forall a. a -> Flag a
Flag (Bool -> MinimizeConflictSet
MinimizeConflictSet Bool
False),
       projectConfigStrongFlags :: Flag StrongFlags
projectConfigStrongFlags       = forall a. a -> Flag a
Flag (Bool -> StrongFlags
StrongFlags Bool
False),
       projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls
projectConfigAllowBootLibInstalls = forall a. a -> Flag a
Flag (Bool -> AllowBootLibInstalls
AllowBootLibInstalls Bool
False),
       projectConfigOnlyConstrained :: Flag OnlyConstrained
projectConfigOnlyConstrained   = forall a. a -> Flag a
Flag OnlyConstrained
OnlyConstrainedNone,
       projectConfigIndependentGoals :: Flag IndependentGoals
projectConfigIndependentGoals  = forall a. a -> Flag a
Flag (Bool -> IndependentGoals
IndependentGoals Bool
False),
       projectConfigPreferOldest :: Flag PreferOldest
projectConfigPreferOldest      = forall a. a -> Flag a
Flag (Bool -> PreferOldest
PreferOldest Bool
False)
     --projectConfigShadowPkgs        = Flag False,
     --projectConfigReinstall         = Flag False,
     --projectConfigAvoidReinstalls   = Flag False,
     --projectConfigOverrideReinstall = Flag False,
     --projectConfigUpgradeDeps       = Flag False
    }


-- | Resolve the project configuration, with all its optional fields, into
-- 'BuildTimeSettings' with no optional fields (by applying defaults).
--
resolveBuildTimeSettings :: Verbosity
                         -> CabalDirLayout
                         -> ProjectConfig
                         -> BuildTimeSettings
resolveBuildTimeSettings :: Verbosity -> CabalDirLayout -> ProjectConfig -> BuildTimeSettings
resolveBuildTimeSettings Verbosity
verbosity
                         CabalDirLayout {
                           String
cabalLogsDirectory :: CabalDirLayout -> String
cabalLogsDirectory :: String
cabalLogsDirectory
                         }
                         ProjectConfig {
                           projectConfigShared :: ProjectConfig -> ProjectConfigShared
projectConfigShared = ProjectConfigShared {
                             NubList RemoteRepo
projectConfigRemoteRepos :: NubList RemoteRepo
projectConfigRemoteRepos :: ProjectConfigShared -> NubList RemoteRepo
projectConfigRemoteRepos,
                             NubList LocalRepo
projectConfigLocalNoIndexRepos :: NubList LocalRepo
projectConfigLocalNoIndexRepos :: ProjectConfigShared -> NubList LocalRepo
projectConfigLocalNoIndexRepos,
                             NubList String
projectConfigProgPathExtra :: NubList String
projectConfigProgPathExtra :: ProjectConfigShared -> NubList String
projectConfigProgPathExtra
                           },
                           ProjectConfigBuildOnly
projectConfigBuildOnly :: ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly :: ProjectConfigBuildOnly
projectConfigBuildOnly
                         } =
    BuildTimeSettings {Bool
Int
String
[String]
[PathTemplate]
[LocalRepo]
[RemoteRepo]
Maybe String
Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
Verbosity
ReportLevel
buildSettingLogVerbosity :: Verbosity
buildSettingLogFile :: Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
buildSettingHaddockOpen :: Bool
buildSettingProgPathExtra :: [String]
buildSettingReportPlanningFailure :: Bool
buildSettingIgnoreExpiry :: Bool
buildSettingHttpTransport :: Maybe String
buildSettingCacheDir :: String
buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingRemoteRepos :: [RemoteRepo]
buildSettingKeepTempFiles :: Bool
buildSettingOfflineMode :: Bool
buildSettingKeepGoing :: Bool
buildSettingNumJobs :: Int
buildSettingSymlinkBinDir :: [String]
buildSettingBuildReports :: ReportLevel
buildSettingSummaryFile :: [PathTemplate]
buildSettingOnlyDownload :: Bool
buildSettingOnlyDeps :: Bool
buildSettingDryRun :: Bool
buildSettingHaddockOpen :: Bool
buildSettingProgPathExtra :: [String]
buildSettingIgnoreExpiry :: Bool
buildSettingHttpTransport :: Maybe String
buildSettingCacheDir :: String
buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingRemoteRepos :: [RemoteRepo]
buildSettingKeepTempFiles :: Bool
buildSettingOfflineMode :: Bool
buildSettingKeepGoing :: Bool
buildSettingNumJobs :: Int
buildSettingSymlinkBinDir :: [String]
buildSettingReportPlanningFailure :: Bool
buildSettingBuildReports :: ReportLevel
buildSettingLogVerbosity :: Verbosity
buildSettingLogFile :: Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
buildSettingSummaryFile :: [PathTemplate]
buildSettingOnlyDownload :: Bool
buildSettingOnlyDeps :: Bool
buildSettingDryRun :: Bool
..}
  where
    buildSettingDryRun :: Bool
buildSettingDryRun        = forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigDryRun
    buildSettingOnlyDeps :: Bool
buildSettingOnlyDeps      = forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigOnlyDeps
    buildSettingOnlyDownload :: Bool
buildSettingOnlyDownload  = forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigOnlyDownload
    buildSettingSummaryFile :: [PathTemplate]
buildSettingSummaryFile   = forall a. NubList a -> [a]
fromNubList NubList PathTemplate
projectConfigSummaryFile
    --buildSettingLogFile       -- defined below, more complicated
    --buildSettingLogVerbosity  -- defined below, more complicated
    buildSettingBuildReports :: ReportLevel
buildSettingBuildReports  = forall a. WithCallStack (Flag a -> a)
fromFlag    Flag ReportLevel
projectConfigBuildReports
    buildSettingSymlinkBinDir :: [String]
buildSettingSymlinkBinDir = forall a. Flag a -> [a]
flagToList  Flag String
projectConfigSymlinkBinDir
    buildSettingNumJobs :: Int
buildSettingNumJobs       = Flag (Maybe Int) -> Int
determineNumJobs Flag (Maybe Int)
projectConfigNumJobs
    buildSettingKeepGoing :: Bool
buildSettingKeepGoing     = forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigKeepGoing
    buildSettingOfflineMode :: Bool
buildSettingOfflineMode   = forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigOfflineMode
    buildSettingKeepTempFiles :: Bool
buildSettingKeepTempFiles = forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigKeepTempFiles
    buildSettingRemoteRepos :: [RemoteRepo]
buildSettingRemoteRepos   = forall a. NubList a -> [a]
fromNubList NubList RemoteRepo
projectConfigRemoteRepos
    buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingLocalNoIndexRepos = forall a. NubList a -> [a]
fromNubList NubList LocalRepo
projectConfigLocalNoIndexRepos
    buildSettingCacheDir :: String
buildSettingCacheDir      = forall a. WithCallStack (Flag a -> a)
fromFlag    Flag String
projectConfigCacheDir
    buildSettingHttpTransport :: Maybe String
buildSettingHttpTransport = forall a. Flag a -> Maybe a
flagToMaybe Flag String
projectConfigHttpTransport
    buildSettingIgnoreExpiry :: Bool
buildSettingIgnoreExpiry  = forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigIgnoreExpiry
    buildSettingReportPlanningFailure :: Bool
buildSettingReportPlanningFailure
                              = forall a. WithCallStack (Flag a -> a)
fromFlag Flag Bool
projectConfigReportPlanningFailure
    buildSettingProgPathExtra :: [String]
buildSettingProgPathExtra = forall a. NubList a -> [a]
fromNubList NubList String
projectConfigProgPathExtra
    buildSettingHaddockOpen :: Bool
buildSettingHaddockOpen   = Bool
False

    ProjectConfigBuildOnly{NubList PathTemplate
Flag Bool
Flag String
Flag (Maybe Int)
Flag Verbosity
Flag PathTemplate
Flag ReportLevel
ClientInstallFlags
projectConfigClientInstallFlags :: ClientInstallFlags
projectConfigLogsDir :: Flag String
projectConfigLogFile :: Flag PathTemplate
projectConfigVerbosity :: Flag Verbosity
projectConfigReportPlanningFailure :: Flag Bool
projectConfigIgnoreExpiry :: Flag Bool
projectConfigHttpTransport :: Flag String
projectConfigCacheDir :: Flag String
projectConfigKeepTempFiles :: Flag Bool
projectConfigOfflineMode :: Flag Bool
projectConfigKeepGoing :: Flag Bool
projectConfigNumJobs :: Flag (Maybe Int)
projectConfigSymlinkBinDir :: Flag String
projectConfigBuildReports :: Flag ReportLevel
projectConfigSummaryFile :: NubList PathTemplate
projectConfigOnlyDownload :: Flag Bool
projectConfigOnlyDeps :: Flag Bool
projectConfigDryRun :: Flag Bool
projectConfigClientInstallFlags :: ProjectConfigBuildOnly -> ClientInstallFlags
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag String
projectConfigCacheDir :: ProjectConfigBuildOnly -> Flag String
projectConfigIgnoreExpiry :: ProjectConfigBuildOnly -> Flag Bool
projectConfigHttpTransport :: ProjectConfigBuildOnly -> Flag String
projectConfigKeepTempFiles :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOfflineMode :: ProjectConfigBuildOnly -> Flag Bool
projectConfigKeepGoing :: ProjectConfigBuildOnly -> Flag Bool
projectConfigNumJobs :: ProjectConfigBuildOnly -> Flag (Maybe Int)
projectConfigSymlinkBinDir :: ProjectConfigBuildOnly -> Flag String
projectConfigReportPlanningFailure :: ProjectConfigBuildOnly -> Flag Bool
projectConfigBuildReports :: ProjectConfigBuildOnly -> Flag ReportLevel
projectConfigLogFile :: ProjectConfigBuildOnly -> Flag PathTemplate
projectConfigSummaryFile :: ProjectConfigBuildOnly -> NubList PathTemplate
projectConfigOnlyDownload :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOnlyDeps :: ProjectConfigBuildOnly -> Flag Bool
projectConfigDryRun :: ProjectConfigBuildOnly -> Flag Bool
projectConfigVerbosity :: ProjectConfigBuildOnly -> Flag Verbosity
..} = ProjectConfigBuildOnly
defaults
                              forall a. Semigroup a => a -> a -> a
<> ProjectConfigBuildOnly
projectConfigBuildOnly

    defaults :: ProjectConfigBuildOnly
defaults = forall a. Monoid a => a
mempty {
      projectConfigDryRun :: Flag Bool
projectConfigDryRun                = forall a. a -> Flag a
toFlag Bool
False,
      projectConfigOnlyDeps :: Flag Bool
projectConfigOnlyDeps              = forall a. a -> Flag a
toFlag Bool
False,
      projectConfigOnlyDownload :: Flag Bool
projectConfigOnlyDownload          = forall a. a -> Flag a
toFlag Bool
False,
      projectConfigBuildReports :: Flag ReportLevel
projectConfigBuildReports          = forall a. a -> Flag a
toFlag ReportLevel
NoReports,
      projectConfigReportPlanningFailure :: Flag Bool
projectConfigReportPlanningFailure = forall a. a -> Flag a
toFlag Bool
False,
      projectConfigKeepGoing :: Flag Bool
projectConfigKeepGoing             = forall a. a -> Flag a
toFlag Bool
False,
      projectConfigOfflineMode :: Flag Bool
projectConfigOfflineMode           = forall a. a -> Flag a
toFlag Bool
False,
      projectConfigKeepTempFiles :: Flag Bool
projectConfigKeepTempFiles         = forall a. a -> Flag a
toFlag Bool
False,
      projectConfigIgnoreExpiry :: Flag Bool
projectConfigIgnoreExpiry          = forall a. a -> Flag a
toFlag Bool
False
    }

    -- The logging logic: what log file to use and what verbosity.
    --
    -- If the user has specified --remote-build-reporting=detailed, use the
    -- default log file location. If the --build-log option is set, use the
    -- provided location. Otherwise don't use logging, unless building in
    -- parallel (in which case the default location is used).
    --
    buildSettingLogFile :: Maybe (Compiler -> Platform
                               -> PackageId -> UnitId -> FilePath)
    buildSettingLogFile :: Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
buildSettingLogFile
      | Bool
useDefaultTemplate = forall a. a -> Maybe a
Just (PathTemplate
-> Compiler -> Platform -> PackageId -> UnitId -> String
substLogFileName PathTemplate
defaultTemplate)
      | Bool
otherwise          = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap  PathTemplate
-> Compiler -> Platform -> PackageId -> UnitId -> String
substLogFileName Maybe PathTemplate
givenTemplate

    defaultTemplate :: PathTemplate
defaultTemplate = String -> PathTemplate
toPathTemplate forall a b. (a -> b) -> a -> b
$
                        String
cabalLogsDirectory String -> String -> String
</>
                        String
"$compiler" String -> String -> String
</> String
"$libname" String -> String -> String
<.> String
"log"
    givenTemplate :: Maybe PathTemplate
givenTemplate   = forall a. Flag a -> Maybe a
flagToMaybe Flag PathTemplate
projectConfigLogFile

    useDefaultTemplate :: Bool
useDefaultTemplate
      | ReportLevel
buildSettingBuildReports forall a. Eq a => a -> a -> Bool
== ReportLevel
DetailedReports = Bool
True
      | forall a. Maybe a -> Bool
isJust Maybe PathTemplate
givenTemplate                        = Bool
False
      | Bool
isParallelBuild                             = Bool
True
      | Bool
otherwise                                   = Bool
False

    isParallelBuild :: Bool
isParallelBuild = Int
buildSettingNumJobs forall a. Ord a => a -> a -> Bool
>= Int
2

    substLogFileName :: PathTemplate
                     -> Compiler -> Platform
                     -> PackageId -> UnitId -> FilePath
    substLogFileName :: PathTemplate
-> Compiler -> Platform -> PackageId -> UnitId -> String
substLogFileName PathTemplate
template Compiler
compiler Platform
platform PackageId
pkgid UnitId
uid =
        PathTemplate -> String
fromPathTemplate (PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env PathTemplate
template)
      where
        env :: PathTemplateEnv
env = PackageId -> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv
                PackageId
pkgid UnitId
uid (Compiler -> CompilerInfo
compilerInfo Compiler
compiler) Platform
platform

    -- If the user has specified --remote-build-reporting=detailed or
    -- --build-log, use more verbose logging.
    --
    buildSettingLogVerbosity :: Verbosity
    buildSettingLogVerbosity :: Verbosity
buildSettingLogVerbosity
      | Bool
overrideVerbosity = (Verbosity -> Verbosity) -> Verbosity -> Verbosity
modifyVerbosity (forall a. Ord a => a -> a -> a
max Verbosity
verbose) Verbosity
verbosity
      | Bool
otherwise         = Verbosity
verbosity

    overrideVerbosity :: Bool
    overrideVerbosity :: Bool
overrideVerbosity
      | ReportLevel
buildSettingBuildReports forall a. Eq a => a -> a -> Bool
== ReportLevel
DetailedReports = Bool
True
      | forall a. Maybe a -> Bool
isJust Maybe PathTemplate
givenTemplate                        = Bool
True
      | Bool
isParallelBuild                             = Bool
False
      | Bool
otherwise                                   = Bool
False


---------------------------------------------
-- Reading and writing project config files
--

-- | Find the root of this project.
--
-- Searches for an explicit @cabal.project@ file, in the current directory or
-- parent directories. If no project file is found then the current dir is the
-- project root (and the project will use an implicit config).
--
findProjectRoot :: Maybe FilePath -- ^ starting directory, or current directory
                -> Maybe FilePath -- ^ @cabal.project@ file name override
                -> IO (Either BadProjectRoot ProjectRoot)
findProjectRoot :: Maybe String
-> Maybe String -> IO (Either BadProjectRoot ProjectRoot)
findProjectRoot Maybe String
_ (Just String
projectFile)
  | String -> Bool
isAbsolute String
projectFile = do
    Bool
exists <- String -> IO Bool
doesFileExist String
projectFile
    if Bool
exists
      then do String
projectFile' <- String -> IO String
canonicalizePath String
projectFile
              let projectRoot :: ProjectRoot
projectRoot = String -> String -> ProjectRoot
ProjectRootExplicit (String -> String
takeDirectory String
projectFile')
                                                    (String -> String
takeFileName String
projectFile')
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ProjectRoot
projectRoot)
      else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (String -> BadProjectRoot
BadProjectRootExplicitFile String
projectFile))

findProjectRoot Maybe String
mstartdir Maybe String
mprojectFile = do
    String
startdir <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO String
getCurrentDirectory String -> IO String
canonicalizePath Maybe String
mstartdir
    String
homedir  <- IO String
getHomeDirectory
    String -> String -> IO (Either BadProjectRoot ProjectRoot)
probe String
startdir String
homedir
  where
    projectFileName :: String
    projectFileName :: String
projectFileName = forall a. a -> Maybe a -> a
fromMaybe String
"cabal.project" Maybe String
mprojectFile

    -- Search upwards. If we get to the users home dir or the filesystem root,
    -- then use the current dir
    probe :: FilePath -> String -> IO (Either BadProjectRoot ProjectRoot)
    probe :: String -> String -> IO (Either BadProjectRoot ProjectRoot)
probe String
startdir String
homedir = String -> IO (Either BadProjectRoot ProjectRoot)
go String
startdir
      where
        go :: FilePath -> IO (Either BadProjectRoot ProjectRoot)
        go :: String -> IO (Either BadProjectRoot ProjectRoot)
go String
dir | String -> Bool
isDrive String
dir Bool -> Bool -> Bool
|| String
dir forall a. Eq a => a -> a -> Bool
== String
homedir =
          case Maybe String
mprojectFile of
            Maybe String
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (String -> ProjectRoot
ProjectRootImplicit String
startdir))
            Just String
file -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (String -> BadProjectRoot
BadProjectRootExplicitFile String
file))
        go String
dir = do
          Bool
exists <- String -> IO Bool
doesFileExist (String
dir String -> String -> String
</> String
projectFileName)
          if Bool
exists
            then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (String -> String -> ProjectRoot
ProjectRootExplicit String
dir String
projectFileName))
            else String -> IO (Either BadProjectRoot ProjectRoot)
go (String -> String
takeDirectory String
dir)

-- | Errors returned by 'findProjectRoot'.
--
data BadProjectRoot = BadProjectRootExplicitFile FilePath
#if MIN_VERSION_base(4,8,0)
  deriving (Int -> BadProjectRoot -> String -> String
[BadProjectRoot] -> String -> String
BadProjectRoot -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [BadProjectRoot] -> String -> String
$cshowList :: [BadProjectRoot] -> String -> String
show :: BadProjectRoot -> String
$cshow :: BadProjectRoot -> String
showsPrec :: Int -> BadProjectRoot -> String -> String
$cshowsPrec :: Int -> BadProjectRoot -> String -> String
Show, Typeable)
#else
  deriving (Typeable)

instance Show BadProjectRoot where
  show = renderBadProjectRoot
#endif

instance Exception BadProjectRoot where
#if MIN_VERSION_base(4,8,0)
  displayException :: BadProjectRoot -> String
displayException = BadProjectRoot -> String
renderBadProjectRoot
#endif

renderBadProjectRoot :: BadProjectRoot -> String
renderBadProjectRoot :: BadProjectRoot -> String
renderBadProjectRoot (BadProjectRootExplicitFile String
projectFile) =
    String
"The given project file '" forall a. [a] -> [a] -> [a]
++ String
projectFile forall a. [a] -> [a] -> [a]
++ String
"' does not exist."

withProjectOrGlobalConfig
    :: Verbosity                  -- ^ verbosity
    -> Flag Bool                  -- ^ whether to ignore local project (--ignore-project flag)
    -> Flag FilePath              -- ^ @--cabal-config@
    -> IO a                       -- ^ with project
    -> (ProjectConfig -> IO a)    -- ^ without project
    -> IO a
withProjectOrGlobalConfig :: forall a.
Verbosity
-> Flag Bool
-> Flag String
-> IO a
-> (ProjectConfig -> IO a)
-> IO a
withProjectOrGlobalConfig Verbosity
verbosity (Flag Bool
True) Flag String
gcf IO a
_with ProjectConfig -> IO a
without = do
    ProjectConfig
globalConfig <- forall a. String -> Rebuild a -> IO a
runRebuild String
"" forall a b. (a -> b) -> a -> b
$ Verbosity -> Flag String -> Rebuild ProjectConfig
readGlobalConfig Verbosity
verbosity Flag String
gcf
    ProjectConfig -> IO a
without ProjectConfig
globalConfig
withProjectOrGlobalConfig Verbosity
verbosity Flag Bool
_ignorePrj  Flag String
gcf  IO a
with ProjectConfig -> IO a
without =
    forall a.
Verbosity -> Flag String -> IO a -> (ProjectConfig -> IO a) -> IO a
withProjectOrGlobalConfig' Verbosity
verbosity Flag String
gcf IO a
with ProjectConfig -> IO a
without

withProjectOrGlobalConfig'
    :: Verbosity
    -> Flag FilePath
    -> IO a
    -> (ProjectConfig -> IO a)
    -> IO a
withProjectOrGlobalConfig' :: forall a.
Verbosity -> Flag String -> IO a -> (ProjectConfig -> IO a) -> IO a
withProjectOrGlobalConfig' Verbosity
verbosity Flag String
globalConfigFlag IO a
with ProjectConfig -> IO a
without = do
  ProjectConfig
globalConfig <- forall a. String -> Rebuild a -> IO a
runRebuild String
"" forall a b. (a -> b) -> a -> b
$ Verbosity -> Flag String -> Rebuild ProjectConfig
readGlobalConfig Verbosity
verbosity Flag String
globalConfigFlag

  let
    res' :: IO a
res' = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
with
      forall a b. (a -> b) -> a -> b
$ \case
        (BadPackageLocations Set ProjectConfigProvenance
prov [BadPackageLocation]
locs)
          | Set ProjectConfigProvenance
prov forall a. Eq a => a -> a -> Bool
== forall a. a -> Set a
Set.singleton ProjectConfigProvenance
Implicit
          , let
            isGlobErr :: BadPackageLocation -> Bool
isGlobErr (BadLocGlobEmptyMatch String
_) = Bool
True
            isGlobErr BadPackageLocation
_ = Bool
False
          , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any BadPackageLocation -> Bool
isGlobErr [BadPackageLocation]
locs ->
            ProjectConfig -> IO a
without ProjectConfig
globalConfig
        BadPackageLocations
err -> forall e a. Exception e => e -> IO a
throwIO BadPackageLocations
err

  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
res'
    forall a b. (a -> b) -> a -> b
$ \case
      (BadProjectRootExplicitFile String
"") -> ProjectConfig -> IO a
without ProjectConfig
globalConfig
      BadProjectRoot
err -> forall e a. Exception e => e -> IO a
throwIO BadProjectRoot
err

-- | Read all the config relevant for a project. This includes the project
-- file if any, plus other global config.
--
readProjectConfig :: Verbosity
                  -> HttpTransport
                  -> Flag Bool -- ^ @--ignore-project@
                  -> Flag FilePath
                  -> DistDirLayout
                  -> Rebuild ProjectConfigSkeleton
readProjectConfig :: Verbosity
-> HttpTransport
-> Flag Bool
-> Flag String
-> DistDirLayout
-> Rebuild ProjectConfigSkeleton
readProjectConfig Verbosity
verbosity HttpTransport
httpTransport Flag Bool
ignoreProjectFlag Flag String
configFileFlag DistDirLayout
distDirLayout = do
    ProjectConfigSkeleton
global <- ProjectConfig -> ProjectConfigSkeleton
singletonProjectConfigSkeleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> Flag String -> Rebuild ProjectConfig
readGlobalConfig Verbosity
verbosity Flag String
configFileFlag
    ProjectConfigSkeleton
local  <- Verbosity
-> HttpTransport -> DistDirLayout -> Rebuild ProjectConfigSkeleton
readProjectLocalConfigOrDefault Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout
    ProjectConfigSkeleton
freeze <- Verbosity
-> HttpTransport -> DistDirLayout -> Rebuild ProjectConfigSkeleton
readProjectLocalFreezeConfig    Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout
    ProjectConfigSkeleton
extra  <- Verbosity
-> HttpTransport -> DistDirLayout -> Rebuild ProjectConfigSkeleton
readProjectLocalExtraConfig     Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout
    if Flag Bool
ignoreProjectFlag forall a. Eq a => a -> a -> Bool
== forall a. a -> Flag a
Flag Bool
True then forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectConfigSkeleton
global forall a. Semigroup a => a -> a -> a
<> (ProjectConfig -> ProjectConfigSkeleton
singletonProjectConfigSkeleton ProjectConfig
defaultProject))
    else forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectConfigSkeleton
global forall a. Semigroup a => a -> a -> a
<> ProjectConfigSkeleton
local forall a. Semigroup a => a -> a -> a
<> ProjectConfigSkeleton
freeze forall a. Semigroup a => a -> a -> a
<> ProjectConfigSkeleton
extra)
    where
      defaultProject :: ProjectConfig
      defaultProject :: ProjectConfig
defaultProject = forall a. Monoid a => a
mempty {
        projectPackages :: [String]
projectPackages = [String
"./"]
      }

-- | 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 ProjectConfigSkeleton
readProjectLocalConfigOrDefault :: Verbosity
-> HttpTransport -> DistDirLayout -> Rebuild ProjectConfigSkeleton
readProjectLocalConfigOrDefault Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout = do
  Bool
usesExplicitProjectRoot <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
projectFile
  if Bool
usesExplicitProjectRoot
    then do
      Verbosity
-> HttpTransport
-> DistDirLayout
-> String
-> String
-> Rebuild ProjectConfigSkeleton
readProjectFileSkeleton Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout String
"" String
"project file"
    else do
      [MonitorFilePath] -> Rebuild ()
monitorFiles [String -> MonitorFilePath
monitorNonExistentFile String
projectFile]
      forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectConfig -> ProjectConfigSkeleton
singletonProjectConfigSkeleton ProjectConfig
defaultImplicitProjectConfig)

  where
    projectFile :: FilePath
    projectFile :: String
projectFile = DistDirLayout -> String -> String
distProjectFile DistDirLayout
distDirLayout String
""
    defaultImplicitProjectConfig :: ProjectConfig
    defaultImplicitProjectConfig :: ProjectConfig
defaultImplicitProjectConfig = forall a. Monoid a => a
mempty {
      -- We expect a package in the current directory.
      projectPackages :: [String]
projectPackages         = [ String
"./*.cabal" ],

      projectConfigProvenance :: Set ProjectConfigProvenance
projectConfigProvenance = forall a. a -> Set a
Set.singleton ProjectConfigProvenance
Implicit
    }

-- | Reads a @cabal.project.local@ file in the given project root dir,
-- or returns empty. This file gets written by @cabal configure@, or in
-- principle can be edited manually or by other tools.
--
readProjectLocalExtraConfig :: Verbosity -> HttpTransport -> DistDirLayout
                            -> Rebuild ProjectConfigSkeleton
readProjectLocalExtraConfig :: Verbosity
-> HttpTransport -> DistDirLayout -> Rebuild ProjectConfigSkeleton
readProjectLocalExtraConfig Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout =
    Verbosity
-> HttpTransport
-> DistDirLayout
-> String
-> String
-> Rebuild ProjectConfigSkeleton
readProjectFileSkeleton Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout String
"local"
                             String
"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 -> HttpTransport ->DistDirLayout
                             -> Rebuild ProjectConfigSkeleton
readProjectLocalFreezeConfig :: Verbosity
-> HttpTransport -> DistDirLayout -> Rebuild ProjectConfigSkeleton
readProjectLocalFreezeConfig Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout =
    Verbosity
-> HttpTransport
-> DistDirLayout
-> String
-> String
-> Rebuild ProjectConfigSkeleton
readProjectFileSkeleton Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout String
"freeze"
                             String
"project freeze file"

-- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty.
--
readProjectFileSkeleton :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton
readProjectFileSkeleton :: Verbosity
-> HttpTransport
-> DistDirLayout
-> String
-> String
-> Rebuild ProjectConfigSkeleton
readProjectFileSkeleton Verbosity
verbosity HttpTransport
httpTransport DistDirLayout{String -> String
distProjectFile :: String -> String
distProjectFile :: DistDirLayout -> String -> String
distProjectFile, String
distDownloadSrcDirectory :: DistDirLayout -> String
distDownloadSrcDirectory :: String
distDownloadSrcDirectory}
                         String
extensionName String
extensionDescription = do
    Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
extensionFile
    if Bool
exists
      then do [MonitorFilePath] -> Rebuild ()
monitorFiles [String -> MonitorFilePath
monitorFileHashed String
extensionFile]
              ProjectConfigSkeleton
pcs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectConfigSkeleton
readExtensionFile
              [MonitorFilePath] -> Rebuild ()
monitorFiles forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> MonitorFilePath
monitorFileHashed (ProjectConfigSkeleton -> [String]
projectSkeletonImports ProjectConfigSkeleton
pcs)
              forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectConfigSkeleton
pcs
      else do [MonitorFilePath] -> Rebuild ()
monitorFiles [String -> MonitorFilePath
monitorNonExistentFile String
extensionFile]
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
  where
    extensionFile :: String
extensionFile = String -> String
distProjectFile String
extensionName

    readExtensionFile :: IO ProjectConfigSkeleton
readExtensionFile =
          Verbosity
-> String
-> String
-> ParseResult ProjectConfigSkeleton
-> IO ProjectConfigSkeleton
reportParseResult Verbosity
verbosity String
extensionDescription String
extensionFile
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String
-> HttpTransport
-> Verbosity
-> [String]
-> String
-> ByteString
-> IO (ParseResult ProjectConfigSkeleton)
parseProjectSkeleton String
distDownloadSrcDirectory HttpTransport
httpTransport Verbosity
verbosity [] String
extensionFile
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
BS.readFile String
extensionFile

-- | Render the 'ProjectConfig' format.
--
-- For the moment this is implemented in terms of a pretty printer for the
-- legacy configuration types, plus a conversion.
--
showProjectConfig :: ProjectConfig -> String
showProjectConfig :: ProjectConfig -> String
showProjectConfig =
    LegacyProjectConfig -> String
showLegacyProjectConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfig -> LegacyProjectConfig
convertToLegacyProjectConfig


-- | Write a @cabal.project.local@ file in the given project root dir.
--
writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO ()
writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO ()
writeProjectLocalExtraConfig DistDirLayout{String -> String
distProjectFile :: String -> String
distProjectFile :: DistDirLayout -> String -> String
distProjectFile} =
    String -> ProjectConfig -> IO ()
writeProjectConfigFile (String -> String
distProjectFile String
"local")


-- | Write a @cabal.project.freeze@ file in the given project root dir.
--
writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO ()
writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO ()
writeProjectLocalFreezeConfig DistDirLayout{String -> String
distProjectFile :: String -> String
distProjectFile :: DistDirLayout -> String -> String
distProjectFile} =
    String -> ProjectConfig -> IO ()
writeProjectConfigFile (String -> String
distProjectFile String
"freeze")


-- | Write in the @cabal.project@ format to the given file.
--
writeProjectConfigFile :: FilePath -> ProjectConfig -> IO ()
writeProjectConfigFile :: String -> ProjectConfig -> IO ()
writeProjectConfigFile String
file =
    String -> String -> IO ()
writeFile String
file forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfig -> String
showProjectConfig


-- | Read the user's cabal-install config file.
--
readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig
readGlobalConfig :: Verbosity -> Flag String -> Rebuild ProjectConfig
readGlobalConfig Verbosity
verbosity Flag String
configFileFlag = do
    SavedConfig
config     <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Verbosity -> Flag String -> IO SavedConfig
loadConfig Verbosity
verbosity Flag String
configFileFlag)
    String
configFile <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Flag String -> IO String
getConfigFilePath Flag String
configFileFlag)
    [MonitorFilePath] -> Rebuild ()
monitorFiles [String -> MonitorFilePath
monitorFileHashed String
configFile]
    forall (m :: * -> *) a. Monad m => a -> m a
return (SavedConfig -> ProjectConfig
convertLegacyGlobalConfig SavedConfig
config)

reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton
reportParseResult :: Verbosity
-> String
-> String
-> ParseResult ProjectConfigSkeleton
-> IO ProjectConfigSkeleton
reportParseResult Verbosity
verbosity String
_filetype String
filename (OldParser.ParseOk [PWarning]
warnings ProjectConfigSkeleton
x) = do
   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warnings) forall a b. (a -> b) -> a -> b
$
      let msg :: String
msg = [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (String -> PWarning -> String
OldParser.showPWarning (forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall a b. (a -> b) -> a -> b
$ String
filename forall a. a -> [a] -> [a]
: ProjectConfigSkeleton -> [String]
projectSkeletonImports ProjectConfigSkeleton
x)) [PWarning]
warnings)
       in Verbosity -> String -> IO ()
warn Verbosity
verbosity String
msg
   forall (m :: * -> *) a. Monad m => a -> m a
return ProjectConfigSkeleton
x
reportParseResult Verbosity
verbosity String
filetype String
filename (OldParser.ParseFailed PError
err) =
    let (Maybe Int
line, String
msg) = PError -> (Maybe Int, String)
OldParser.locatedErrorMsg PError
err
     in forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Error parsing " forall a. [a] -> [a] -> [a]
++ String
filetype forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
filename
           forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\Int
n -> Char
':' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Int
n) Maybe Int
line forall a. [a] -> [a] -> [a]
++ String
":\n" forall a. [a] -> [a] -> [a]
++ String
msg


---------------------------------------------
-- Finding packages in the project
--

-- | The location of a package as part of a project. Local file paths are
-- either absolute (if the user specified it as such) or they are relative
-- to the project root.
--
data ProjectPackageLocation =
     ProjectPackageLocalCabalFile FilePath
   | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file
   | ProjectPackageLocalTarball   FilePath
   | ProjectPackageRemoteTarball  URI
   | ProjectPackageRemoteRepo     SourceRepoList
   | ProjectPackageNamed          PackageVersionConstraint
  deriving Int -> ProjectPackageLocation -> String -> String
[ProjectPackageLocation] -> String -> String
ProjectPackageLocation -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ProjectPackageLocation] -> String -> String
$cshowList :: [ProjectPackageLocation] -> String -> String
show :: ProjectPackageLocation -> String
$cshow :: ProjectPackageLocation -> String
showsPrec :: Int -> ProjectPackageLocation -> String -> String
$cshowsPrec :: Int -> ProjectPackageLocation -> String -> String
Show


-- | Exception thrown by 'findProjectPackages'.
--
data BadPackageLocations
   = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation]
#if MIN_VERSION_base(4,8,0)
  deriving (Int -> BadPackageLocations -> String -> String
[BadPackageLocations] -> String -> String
BadPackageLocations -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [BadPackageLocations] -> String -> String
$cshowList :: [BadPackageLocations] -> String -> String
show :: BadPackageLocations -> String
$cshow :: BadPackageLocations -> String
showsPrec :: Int -> BadPackageLocations -> String -> String
$cshowsPrec :: Int -> BadPackageLocations -> String -> String
Show, Typeable)
#else
  deriving (Typeable)

instance Show BadPackageLocations where
  show = renderBadPackageLocations
#endif

instance Exception BadPackageLocations where
#if MIN_VERSION_base(4,8,0)
  displayException :: BadPackageLocations -> String
displayException = BadPackageLocations -> String
renderBadPackageLocations
#endif
--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc

data BadPackageLocation
   = BadPackageLocationFile    BadPackageLocationMatch
   | BadLocGlobEmptyMatch      String
   | BadLocGlobBadMatches      String [BadPackageLocationMatch]
   | BadLocUnexpectedUriScheme String
   | BadLocUnrecognisedUri     String
   | BadLocUnrecognised        String
  deriving Int -> BadPackageLocation -> String -> String
[BadPackageLocation] -> String -> String
BadPackageLocation -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [BadPackageLocation] -> String -> String
$cshowList :: [BadPackageLocation] -> String -> String
show :: BadPackageLocation -> String
$cshow :: BadPackageLocation -> String
showsPrec :: Int -> BadPackageLocation -> String -> String
$cshowsPrec :: Int -> BadPackageLocation -> String -> String
Show

data BadPackageLocationMatch
   = BadLocUnexpectedFile      String
   | BadLocNonexistantFile     String
   | BadLocDirNoCabalFile      String
   | BadLocDirManyCabalFiles   String
  deriving Int -> BadPackageLocationMatch -> String -> String
[BadPackageLocationMatch] -> String -> String
BadPackageLocationMatch -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [BadPackageLocationMatch] -> String -> String
$cshowList :: [BadPackageLocationMatch] -> String -> String
show :: BadPackageLocationMatch -> String
$cshow :: BadPackageLocationMatch -> String
showsPrec :: Int -> BadPackageLocationMatch -> String -> String
$cshowsPrec :: Int -> BadPackageLocationMatch -> String -> String
Show

renderBadPackageLocations :: BadPackageLocations -> String
renderBadPackageLocations :: BadPackageLocations -> String
renderBadPackageLocations (BadPackageLocations Set ProjectConfigProvenance
provenance [BadPackageLocation]
bpls)
      -- There is no provenance information,
      -- render standard bad package error information.
    | forall a. Set a -> Bool
Set.null Set ProjectConfigProvenance
provenance = (BadPackageLocation -> String) -> String
renderErrors BadPackageLocation -> String
renderBadPackageLocation

      -- The configuration is implicit, render bad package locations
      -- using possibly specialized error messages.
    | forall a. a -> Set a
Set.singleton ProjectConfigProvenance
Implicit forall a. Eq a => a -> a -> Bool
== Set ProjectConfigProvenance
provenance =
        (BadPackageLocation -> String) -> String
renderErrors BadPackageLocation -> String
renderImplicitBadPackageLocation

      -- The configuration contains both implicit and explicit provenance.
      -- This should not occur, and a message is output to assist debugging.
    | ProjectConfigProvenance
Implicit forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ProjectConfigProvenance
provenance =
           String
"Warning: both implicit and explicit configuration is present."
        forall a. [a] -> [a] -> [a]
++ String
renderExplicit

      -- The configuration was read from one or more explicit path(s),
      -- list the locations and render the bad package error information.
      -- The intent is to supersede this with the relevant location information
      -- per package error.
    | Bool
otherwise = String
renderExplicit
  where
    renderErrors :: (BadPackageLocation -> String) -> String
renderErrors BadPackageLocation -> String
f = [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map BadPackageLocation -> String
f [BadPackageLocation]
bpls)

    renderExplicit :: String
renderExplicit =
           String
"When using configuration(s) from "
        forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ProjectConfigProvenance -> Maybe String
getExplicit (forall a. Set a -> [a]
Set.toList Set ProjectConfigProvenance
provenance))
        forall a. [a] -> [a] -> [a]
++ String
", the following errors occurred:\n"
        forall a. [a] -> [a] -> [a]
++ (BadPackageLocation -> String) -> String
renderErrors BadPackageLocation -> String
renderBadPackageLocation

    getExplicit :: ProjectConfigProvenance -> Maybe String
getExplicit (Explicit String
path) = forall a. a -> Maybe a
Just String
path
    getExplicit ProjectConfigProvenance
Implicit        = forall a. Maybe a
Nothing

--TODO: [nice to have] keep track of the config file (and src loc) packages
-- were listed, to use in error messages

-- | Render bad package location error information for the implicit
-- @cabal.project@ configuration.
--
-- TODO: This is currently not fully realized, with only one of the implicit
-- cases handled. More cases should be added with informative help text
-- about the issues related specifically when having no project configuration
-- is present.
renderImplicitBadPackageLocation :: BadPackageLocation -> String
renderImplicitBadPackageLocation :: BadPackageLocation -> String
renderImplicitBadPackageLocation BadPackageLocation
bpl = case BadPackageLocation
bpl of
    BadLocGlobEmptyMatch String
pkglocstr ->
        String
"No cabal.project file or cabal file matching the default glob '"
     forall a. [a] -> [a] -> [a]
++ String
pkglocstr forall a. [a] -> [a] -> [a]
++ String
"' was found.\n"
     forall a. [a] -> [a] -> [a]
++ String
"Please create a package description file <pkgname>.cabal "
     forall a. [a] -> [a] -> [a]
++ String
"or a cabal.project file referencing the packages you "
     forall a. [a] -> [a] -> [a]
++ String
"want to build."
    BadPackageLocation
_ -> BadPackageLocation -> String
renderBadPackageLocation BadPackageLocation
bpl

renderBadPackageLocation :: BadPackageLocation -> String
renderBadPackageLocation :: BadPackageLocation -> String
renderBadPackageLocation BadPackageLocation
bpl = case BadPackageLocation
bpl of
    BadPackageLocationFile BadPackageLocationMatch
badmatch ->
        BadPackageLocationMatch -> String
renderBadPackageLocationMatch BadPackageLocationMatch
badmatch
    BadLocGlobEmptyMatch String
pkglocstr ->
        String
"The package location glob '" forall a. [a] -> [a] -> [a]
++ String
pkglocstr
     forall a. [a] -> [a] -> [a]
++ String
"' does not match any files or directories."
    BadLocGlobBadMatches String
pkglocstr [BadPackageLocationMatch]
failures ->
        String
"The package location glob '" forall a. [a] -> [a] -> [a]
++ String
pkglocstr forall a. [a] -> [a] -> [a]
++ String
"' does not match any "
     forall a. [a] -> [a] -> [a]
++ String
"recognised forms of package. "
     forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Char
' 'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. BadPackageLocationMatch -> String
renderBadPackageLocationMatch) [BadPackageLocationMatch]
failures
    BadLocUnexpectedUriScheme String
pkglocstr ->
        String
"The package location URI '" forall a. [a] -> [a] -> [a]
++ String
pkglocstr forall a. [a] -> [a] -> [a]
++ String
"' does not use a "
     forall a. [a] -> [a] -> [a]
++ String
"supported URI scheme. The supported URI schemes are http, https and "
     forall a. [a] -> [a] -> [a]
++ String
"file."
    BadLocUnrecognisedUri String
pkglocstr ->
        String
"The package location URI '" forall a. [a] -> [a] -> [a]
++ String
pkglocstr forall a. [a] -> [a] -> [a]
++ String
"' does not appear to "
     forall a. [a] -> [a] -> [a]
++ String
"be a valid absolute URI."
    BadLocUnrecognised String
pkglocstr ->
        String
"The package location syntax '" forall a. [a] -> [a] -> [a]
++ String
pkglocstr forall a. [a] -> [a] -> [a]
++ String
"' is not recognised."

renderBadPackageLocationMatch :: BadPackageLocationMatch -> String
renderBadPackageLocationMatch :: BadPackageLocationMatch -> String
renderBadPackageLocationMatch BadPackageLocationMatch
bplm = case BadPackageLocationMatch
bplm of
    BadLocUnexpectedFile String
pkglocstr ->
        String
"The package location '" forall a. [a] -> [a] -> [a]
++ String
pkglocstr forall a. [a] -> [a] -> [a]
++ String
"' is not recognised. The "
     forall a. [a] -> [a] -> [a]
++ String
"supported file targets are .cabal files, .tar.gz tarballs or package "
     forall a. [a] -> [a] -> [a]
++ String
"directories (i.e. directories containing a .cabal file)."
    BadLocNonexistantFile String
pkglocstr ->
        String
"The package location '" forall a. [a] -> [a] -> [a]
++ String
pkglocstr forall a. [a] -> [a] -> [a]
++ String
"' does not exist."
    BadLocDirNoCabalFile String
pkglocstr ->
        String
"The package directory '" forall a. [a] -> [a] -> [a]
++ String
pkglocstr forall a. [a] -> [a] -> [a]
++ String
"' does not contain any "
     forall a. [a] -> [a] -> [a]
++ String
".cabal file."
    BadLocDirManyCabalFiles String
pkglocstr ->
        String
"The package directory '" forall a. [a] -> [a] -> [a]
++ String
pkglocstr forall a. [a] -> [a] -> [a]
++ String
"' contains multiple "
     forall a. [a] -> [a] -> [a]
++ String
".cabal files (which is not currently supported)."

-- | Given the project config,
--
-- Throws 'BadPackageLocations'.
--
findProjectPackages :: DistDirLayout -> ProjectConfig
                    -> Rebuild [ProjectPackageLocation]
findProjectPackages :: DistDirLayout -> ProjectConfig -> Rebuild [ProjectPackageLocation]
findProjectPackages DistDirLayout{String
distProjectRootDirectory :: DistDirLayout -> String
distProjectRootDirectory :: String
distProjectRootDirectory}
                    ProjectConfig{[String]
[PackageVersionConstraint]
[SourceRepoList]
Set ProjectConfigProvenance
MapMappend PackageName PackageConfig
PackageConfig
ProjectConfigShared
ProjectConfigBuildOnly
projectConfigAllPackages :: ProjectConfig -> PackageConfig
projectPackagesNamed :: ProjectConfig -> [PackageVersionConstraint]
projectPackagesRepo :: ProjectConfig -> [SourceRepoList]
projectPackagesOptional :: ProjectConfig -> [String]
projectConfigSpecificPackage :: MapMappend PackageName PackageConfig
projectConfigLocalPackages :: PackageConfig
projectConfigAllPackages :: PackageConfig
projectConfigProvenance :: Set ProjectConfigProvenance
projectConfigShared :: ProjectConfigShared
projectConfigBuildOnly :: ProjectConfigBuildOnly
projectPackagesNamed :: [PackageVersionConstraint]
projectPackagesRepo :: [SourceRepoList]
projectPackagesOptional :: [String]
projectPackages :: [String]
projectConfigProvenance :: ProjectConfig -> Set ProjectConfigProvenance
projectPackages :: ProjectConfig -> [String]
projectConfigBuildOnly :: ProjectConfig -> ProjectConfigBuildOnly
projectConfigShared :: ProjectConfig -> ProjectConfigShared
projectConfigSpecificPackage :: ProjectConfig -> MapMappend PackageName PackageConfig
projectConfigLocalPackages :: ProjectConfig -> PackageConfig
..} = do

    [ProjectPackageLocation]
requiredPkgs <- Bool -> [String] -> Rebuild [ProjectPackageLocation]
findPackageLocations Bool
True    [String]
projectPackages
    [ProjectPackageLocation]
optionalPkgs <- Bool -> [String] -> Rebuild [ProjectPackageLocation]
findPackageLocations Bool
False   [String]
projectPackagesOptional
    let repoPkgs :: [ProjectPackageLocation]
repoPkgs  = forall a b. (a -> b) -> [a] -> [b]
map SourceRepoList -> ProjectPackageLocation
ProjectPackageRemoteRepo [SourceRepoList]
projectPackagesRepo
        namedPkgs :: [ProjectPackageLocation]
namedPkgs = forall a b. (a -> b) -> [a] -> [b]
map PackageVersionConstraint -> ProjectPackageLocation
ProjectPackageNamed      [PackageVersionConstraint]
projectPackagesNamed

    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ProjectPackageLocation]
requiredPkgs, [ProjectPackageLocation]
optionalPkgs, [ProjectPackageLocation]
repoPkgs, [ProjectPackageLocation]
namedPkgs])
  where
    findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation]
    findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation]
findPackageLocations Bool
required [String]
pkglocstr = do
      ([BadPackageLocation]
problems, [[ProjectPackageLocation]]
pkglocs) <-
        forall a b. [Either a b] -> ([a], [b])
partitionEithers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Bool
-> String
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
findPackageLocation Bool
required) [String]
pkglocstr
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BadPackageLocation]
problems) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Set ProjectConfigProvenance
-> [BadPackageLocation] -> BadPackageLocations
BadPackageLocations Set ProjectConfigProvenance
projectConfigProvenance [BadPackageLocation]
problems
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ProjectPackageLocation]]
pkglocs)


    findPackageLocation :: Bool -> String
                        -> Rebuild (Either BadPackageLocation
                                          [ProjectPackageLocation])
    findPackageLocation :: Bool
-> String
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
findPackageLocation _required :: Bool
_required@Bool
True String
pkglocstr =
      -- strategy: try first as a file:// or http(s):// URL.
      -- then as a file glob (usually encompassing single file)
      -- finally as a single file, for files that fail to parse as globs
                    String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsUriPackage String
pkglocstr
      forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
`mplusMaybeT` String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsFileGlobPackage String
pkglocstr
      forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
`mplusMaybeT` String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsSingleFilePackage String
pkglocstr
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (String -> BadPackageLocation
BadLocUnrecognised String
pkglocstr))) forall (m :: * -> *) a. Monad m => a -> m a
return


    findPackageLocation _required :: Bool
_required@Bool
False String
pkglocstr = do
      -- just globs for optional case
      Maybe (Either BadPackageLocation [ProjectPackageLocation])
res <- String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsFileGlobPackage String
pkglocstr
      case Maybe (Either BadPackageLocation [ProjectPackageLocation])
res of
        Maybe (Either BadPackageLocation [ProjectPackageLocation])
Nothing              -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (String -> BadPackageLocation
BadLocUnrecognised String
pkglocstr))
        Just (Left BadPackageLocation
_)        -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right []) -- it's optional
        Just (Right [ProjectPackageLocation]
pkglocs) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right [ProjectPackageLocation]
pkglocs)


    checkIsUriPackage, checkIsFileGlobPackage, checkIsSingleFilePackage
      :: String -> Rebuild (Maybe (Either BadPackageLocation
                                         [ProjectPackageLocation]))
    checkIsUriPackage :: String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsUriPackage String
pkglocstr =
      case String -> Maybe URI
parseAbsoluteURI String
pkglocstr of
        Just uri :: URI
uri@URI {
            uriScheme :: URI -> String
uriScheme    = String
scheme,
            uriAuthority :: URI -> Maybe URIAuth
uriAuthority = Just URIAuth { uriRegName :: URIAuth -> String
uriRegName = String
host },
            uriPath :: URI -> String
uriPath      = String
path,
            uriQuery :: URI -> String
uriQuery     = String
query,
            uriFragment :: URI -> String
uriFragment  = String
frag
          }
          | Bool
recognisedScheme Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
host) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right [URI -> ProjectPackageLocation
ProjectPackageRemoteTarball URI
uri]))

          | String
scheme forall a. Eq a => a -> a -> Bool
== String
"file:" Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
host Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
query Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
frag ->
            String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsSingleFilePackage String
path

          | Bool -> Bool
not Bool
recognisedScheme Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
host) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left (String -> BadPackageLocation
BadLocUnexpectedUriScheme String
pkglocstr)))

          | Bool
recognisedScheme Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
host ->
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left (String -> BadPackageLocation
BadLocUnrecognisedUri String
pkglocstr)))
          where
            recognisedScheme :: Bool
recognisedScheme = String
scheme forall a. Eq a => a -> a -> Bool
== String
"http:" Bool -> Bool -> Bool
|| String
scheme forall a. Eq a => a -> a -> Bool
== String
"https:"
                            Bool -> Bool -> Bool
|| String
scheme forall a. Eq a => a -> a -> Bool
== String
"file:"

        Maybe URI
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing


    checkIsFileGlobPackage :: String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsFileGlobPackage String
pkglocstr =
      case forall a. Parsec a => String -> Maybe a
simpleParsec String
pkglocstr of
        Maybe FilePathGlob
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just FilePathGlob
glob -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
          [String]
matches <- FilePathGlob -> Rebuild [String]
matchFileGlob FilePathGlob
glob
          case [String]
matches of
            [] | forall a. Maybe a -> Bool
isJust (FilePathGlob -> Maybe String
isTrivialFilePathGlob FilePathGlob
glob)
               -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (BadPackageLocationMatch -> BadPackageLocation
BadPackageLocationFile
                                  (String -> BadPackageLocationMatch
BadLocNonexistantFile String
pkglocstr)))

            [] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (String -> BadPackageLocation
BadLocGlobEmptyMatch String
pkglocstr))

            [String]
_  -> do
              ([BadPackageLocationMatch]
failures, [ProjectPackageLocation]
pkglocs) <- forall a b. [Either a b] -> ([a], [b])
partitionEithers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                     forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String
-> Rebuild (Either BadPackageLocationMatch ProjectPackageLocation)
checkFilePackageMatch [String]
matches
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! case ([BadPackageLocationMatch]
failures, [ProjectPackageLocation]
pkglocs) of
                ([BadPackageLocationMatch
failure], []) | forall a. Maybe a -> Bool
isJust (FilePathGlob -> Maybe String
isTrivialFilePathGlob FilePathGlob
glob)
                        -> forall a b. a -> Either a b
Left (BadPackageLocationMatch -> BadPackageLocation
BadPackageLocationFile BadPackageLocationMatch
failure)
                ([BadPackageLocationMatch]
_, []) -> forall a b. a -> Either a b
Left (String -> [BadPackageLocationMatch] -> BadPackageLocation
BadLocGlobBadMatches String
pkglocstr [BadPackageLocationMatch]
failures)
                ([BadPackageLocationMatch], [ProjectPackageLocation])
_       -> forall a b. b -> Either a b
Right [ProjectPackageLocation]
pkglocs


    checkIsSingleFilePackage :: String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsSingleFilePackage String
pkglocstr = do
      let filename :: String
filename = String
distProjectRootDirectory String -> String -> String
</> String
pkglocstr
      Bool
isFile <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
filename
      Bool
isDir  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
filename
      if Bool
isFile Bool -> Bool -> Bool
|| Bool
isDir
        then String
-> Rebuild (Either BadPackageLocationMatch ProjectPackageLocation)
checkFilePackageMatch String
pkglocstr
         forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left  forall b c a. (b -> c) -> (a -> b) -> a -> c
. BadPackageLocationMatch -> BadPackageLocation
BadPackageLocationFile)
                    (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ProjectPackageLocation
x->[ProjectPackageLocation
x]))
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing


    checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch
                                                       ProjectPackageLocation)
    checkFilePackageMatch :: String
-> Rebuild (Either BadPackageLocationMatch ProjectPackageLocation)
checkFilePackageMatch String
pkglocstr = do
      -- The pkglocstr may be absolute or may be relative to the project root.
      -- Either way, </> does the right thing here. We return relative paths if
      -- they were relative in the first place.
      let abspath :: String
abspath = String
distProjectRootDirectory String -> String -> String
</> String
pkglocstr
      Bool
isFile <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
abspath
      Bool
isDir  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
abspath
      Bool
parentDirExists <- case String -> String
takeDirectory String
abspath of
                           []  -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           String
dir -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
dir
      case () of
        ()
_ | Bool
isDir
         -> do [String]
matches <- FilePathGlob -> Rebuild [String]
matchFileGlob (String -> FilePathGlob
globStarDotCabal String
pkglocstr)
               case [String]
matches of
                 [String
cabalFile]
                     -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (String -> String -> ProjectPackageLocation
ProjectPackageLocalDirectory
                                         String
pkglocstr String
cabalFile))
                 []  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (String -> BadPackageLocationMatch
BadLocDirNoCabalFile String
pkglocstr))
                 [String]
_   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (String -> BadPackageLocationMatch
BadLocDirManyCabalFiles String
pkglocstr))

          | String -> Bool
extensionIsTarGz String
pkglocstr
         -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (String -> ProjectPackageLocation
ProjectPackageLocalTarball String
pkglocstr))

          | String -> String
takeExtension String
pkglocstr forall a. Eq a => a -> a -> Bool
== String
".cabal"
         -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (String -> ProjectPackageLocation
ProjectPackageLocalCabalFile String
pkglocstr))

          | Bool
isFile
         -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (String -> BadPackageLocationMatch
BadLocUnexpectedFile String
pkglocstr))

          | Bool
parentDirExists
         -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (String -> BadPackageLocationMatch
BadLocNonexistantFile String
pkglocstr))

          | Bool
otherwise
         -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (String -> BadPackageLocationMatch
BadLocUnexpectedFile String
pkglocstr))


    extensionIsTarGz :: String -> Bool
extensionIsTarGz String
f = String -> String
takeExtension String
f                 forall a. Eq a => a -> a -> Bool
== String
".gz"
                      Bool -> Bool -> Bool
&& String -> String
takeExtension (String -> String
dropExtension String
f) forall a. Eq a => a -> a -> Bool
== String
".tar"


-- | A glob to find all the cabal files in a directory.
--
-- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@.
-- The directory part can be either absolute or relative.
--
globStarDotCabal :: FilePath -> FilePathGlob
globStarDotCabal :: String -> FilePathGlob
globStarDotCabal String
dir =
    FilePathRoot -> FilePathGlobRel -> FilePathGlob
FilePathGlob
      (if String -> Bool
isAbsolute String
dir then String -> FilePathRoot
FilePathRoot String
root else FilePathRoot
FilePathRelative)
      (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String
d -> Glob -> FilePathGlobRel -> FilePathGlobRel
GlobDir [String -> GlobPiece
Literal String
d])
             (Glob -> FilePathGlobRel
GlobFile [GlobPiece
WildCard, String -> GlobPiece
Literal String
".cabal"]) [String]
dirComponents)
  where
    (String
root, [String]
dirComponents) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [String]
splitDirectories (String -> (String, String)
splitDrive String
dir)


--TODO: [code cleanup] use sufficiently recent transformers package
mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
mplusMaybeT :: forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
mplusMaybeT m (Maybe a)
ma m (Maybe a)
mb = do
  Maybe a
mx <- m (Maybe a)
ma
  case Maybe a
mx of
    Maybe a
Nothing -> m (Maybe a)
mb
    Just a
x  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x)


-------------------------------------------------
-- Fetching and reading packages in the project
--

-- | Read the @.cabal@ files for a set of packages. For remote tarballs and
-- VCS source repos this also fetches them if needed.
--
-- Note here is where we convert from project-root relative paths to absolute
-- paths.
--
fetchAndReadSourcePackages
  :: Verbosity
  -> DistDirLayout
  -> ProjectConfigShared
  -> ProjectConfigBuildOnly
  -> [ProjectPackageLocation]
  -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
fetchAndReadSourcePackages :: Verbosity
-> DistDirLayout
-> ProjectConfigShared
-> ProjectConfigBuildOnly
-> [ProjectPackageLocation]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
fetchAndReadSourcePackages Verbosity
verbosity DistDirLayout
distDirLayout
                           ProjectConfigShared
projectConfigShared
                           ProjectConfigBuildOnly
projectConfigBuildOnly
                           [ProjectPackageLocation]
pkgLocations = do

    [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgsLocalDirectory <-
      forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
        [ Verbosity
-> String
-> String
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readSourcePackageLocalDirectory Verbosity
verbosity String
dir String
cabalFile
        | ProjectPackageLocation
location <- [ProjectPackageLocation]
pkgLocations
        , (String
dir, String
cabalFile) <- ProjectPackageLocation -> [(String, String)]
projectPackageLocal ProjectPackageLocation
location ]

    [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgsLocalTarball <-
      forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
        [ Verbosity
-> String
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readSourcePackageLocalTarball Verbosity
verbosity String
path
        | ProjectPackageLocalTarball String
path <- [ProjectPackageLocation]
pkgLocations ]

    [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgsRemoteTarball <- do
      Rebuild HttpTransport
getTransport <- forall a. IO a -> Rebuild (Rebuild a)
delayInitSharedResource forall a b. (a -> b) -> a -> b
$
                      Verbosity -> [String] -> Maybe String -> IO HttpTransport
configureTransport Verbosity
verbosity [String]
progPathExtra
                                         Maybe String
preferredHttpTransport
      forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
        [ Verbosity
-> DistDirLayout
-> Rebuild HttpTransport
-> URI
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
fetchAndReadSourcePackageRemoteTarball Verbosity
verbosity DistDirLayout
distDirLayout
                                                 Rebuild HttpTransport
getTransport URI
uri
        | ProjectPackageRemoteTarball URI
uri <- [ProjectPackageLocation]
pkgLocations ]

    [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgsRemoteRepo <-
      Verbosity
-> DistDirLayout
-> ProjectConfigShared
-> [SourceRepoList]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
syncAndReadSourcePackagesRemoteRepos
        Verbosity
verbosity DistDirLayout
distDirLayout
        ProjectConfigShared
projectConfigShared
        [ SourceRepoList
repo | ProjectPackageRemoteRepo SourceRepoList
repo <- [ProjectPackageLocation]
pkgLocations ]

    let pkgsNamed :: [PackageSpecifier pkg]
pkgsNamed =
          [ forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgname [VersionRange -> PackageProperty
PackagePropertyVersion VersionRange
verrange]
          | ProjectPackageNamed (PackageVersionConstraint PackageName
pkgname VersionRange
verrange) <- [ProjectPackageLocation]
pkgLocations ]

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgsLocalDirectory
      , [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgsLocalTarball
      , [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgsRemoteTarball
      , [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgsRemoteRepo
      , forall {pkg}. [PackageSpecifier pkg]
pkgsNamed
      ]
  where
    projectPackageLocal :: ProjectPackageLocation -> [(String, String)]
projectPackageLocal (ProjectPackageLocalDirectory String
dir String
file) = [(String
dir, String
file)]
    projectPackageLocal (ProjectPackageLocalCabalFile     String
file) = [(String
dir, String
file)]
                                                where dir :: String
dir = String -> String
takeDirectory String
file
    projectPackageLocal ProjectPackageLocation
_ = []

    progPathExtra :: [String]
progPathExtra = forall a. NubList a -> [a]
fromNubList (ProjectConfigShared -> NubList String
projectConfigProgPathExtra ProjectConfigShared
projectConfigShared)
    preferredHttpTransport :: Maybe String
preferredHttpTransport =
      forall a. Flag a -> Maybe a
flagToMaybe (ProjectConfigBuildOnly -> Flag String
projectConfigHttpTransport ProjectConfigBuildOnly
projectConfigBuildOnly)

-- | A helper for 'fetchAndReadSourcePackages' to handle the case of
-- 'ProjectPackageLocalDirectory' and 'ProjectPackageLocalCabalFile'.
-- We simply read the @.cabal@ file.
--
readSourcePackageLocalDirectory
  :: Verbosity
  -> FilePath  -- ^ The package directory
  -> FilePath  -- ^ The package @.cabal@ file
  -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readSourcePackageLocalDirectory :: Verbosity
-> String
-> String
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readSourcePackageLocalDirectory Verbosity
verbosity String
dir String
cabalFile = do
    [MonitorFilePath] -> Rebuild ()
monitorFiles [String -> MonitorFilePath
monitorFileHashed String
cabalFile]
    String
root <- Rebuild String
askRoot
    let location :: PackageLocation local
location = forall local. String -> PackageLocation local
LocalUnpackedPackage (String
root String -> String -> String
</> String
dir)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PackageLocation String
-> GenericPackageDescription
-> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage forall {local}. PackageLocation local
location)
           forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> ByteString -> IO GenericPackageDescription
readSourcePackageCabalFile Verbosity
verbosity String
cabalFile
         forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
BS.readFile (String
root String -> String -> String
</> String
cabalFile)


-- | A helper for 'fetchAndReadSourcePackages' to handle the case of
-- 'ProjectPackageLocalTarball'. We scan through the @.tar.gz@ file to find
-- the @.cabal@ file and read that.
--
readSourcePackageLocalTarball
  :: Verbosity
  -> FilePath
  -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readSourcePackageLocalTarball :: Verbosity
-> String
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readSourcePackageLocalTarball Verbosity
verbosity String
tarballFile = do
    [MonitorFilePath] -> Rebuild ()
monitorFiles [String -> MonitorFilePath
monitorFile String
tarballFile]
    String
root <- Rebuild String
askRoot
    let location :: PackageLocation local
location = forall local. String -> PackageLocation local
LocalTarballPackage (String
root String -> String -> String
</> String
tarballFile)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PackageLocation String
-> GenericPackageDescription
-> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage forall {local}. PackageLocation local
location)
           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Verbosity -> String -> ByteString -> IO GenericPackageDescription
readSourcePackageCabalFile Verbosity
verbosity)
         forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (String, ByteString)
extractTarballPackageCabalFile (String
root String -> String -> String
</> String
tarballFile)

-- | A helper for 'fetchAndReadSourcePackages' to handle the case of
-- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir
-- and after that handle it like the local tarball case.
--
fetchAndReadSourcePackageRemoteTarball
  :: Verbosity
  -> DistDirLayout
  -> Rebuild HttpTransport
  -> URI
  -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
fetchAndReadSourcePackageRemoteTarball :: Verbosity
-> DistDirLayout
-> Rebuild HttpTransport
-> URI
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
fetchAndReadSourcePackageRemoteTarball Verbosity
verbosity
                                       DistDirLayout {
                                         String
distDownloadSrcDirectory :: String
distDownloadSrcDirectory :: DistDirLayout -> String
distDownloadSrcDirectory
                                       }
                                       Rebuild HttpTransport
getTransport
                                       URI
tarballUri =
    -- The tarball download is expensive so we use another layer of file
    -- monitor to avoid it whenever possible.
    forall a b.
(Binary a, Structured a, Binary b, Structured b) =>
Verbosity -> FileMonitor a b -> a -> Rebuild b -> Rebuild b
rerunIfChanged Verbosity
verbosity FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
monitor URI
tarballUri forall a b. (a -> b) -> a -> b
$ do

      -- Download
      HttpTransport
transport <- Rebuild HttpTransport
getTransport
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Verbosity -> HttpTransport -> URI -> IO ()
transportCheckHttps Verbosity
verbosity HttpTransport
transport URI
tarballUri
        Verbosity -> String -> IO ()
notice Verbosity
verbosity (String
"Downloading " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show URI
tarballUri)
        Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True
                                        String
distDownloadSrcDirectory
        DownloadResult
_ <- HttpTransport -> Verbosity -> URI -> String -> IO DownloadResult
downloadURI HttpTransport
transport Verbosity
verbosity URI
tarballUri String
tarballFile
        forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- Read
      [MonitorFilePath] -> Rebuild ()
monitorFiles [String -> MonitorFilePath
monitorFile String
tarballFile]
      let location :: PackageLocation String
location = forall local. URI -> local -> PackageLocation local
RemoteTarballPackage URI
tarballUri String
tarballFile
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PackageLocation String
-> GenericPackageDescription
-> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage PackageLocation String
location)
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Verbosity -> String -> ByteString -> IO GenericPackageDescription
readSourcePackageCabalFile Verbosity
verbosity)
           forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (String, ByteString)
extractTarballPackageCabalFile String
tarballFile
  where
    tarballStem :: FilePath
    tarballStem :: String
tarballStem = String
distDownloadSrcDirectory
              String -> String -> String
</> URI -> String
localFileNameForRemoteTarball URI
tarballUri
    tarballFile :: FilePath
    tarballFile :: String
tarballFile = String
tarballStem String -> String -> String
<.> String
"tar.gz"

    monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
    monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
monitor = forall a b. Eq a => String -> FileMonitor a b
newFileMonitor (String
tarballStem String -> String -> String
<.> String
"cache")


-- | A helper for 'fetchAndReadSourcePackages' to handle all the cases of
-- 'ProjectPackageRemoteRepo'.
--
syncAndReadSourcePackagesRemoteRepos
  :: Verbosity
  -> DistDirLayout
  -> ProjectConfigShared
  -> [SourceRepoList]
  -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
syncAndReadSourcePackagesRemoteRepos :: Verbosity
-> DistDirLayout
-> ProjectConfigShared
-> [SourceRepoList]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
syncAndReadSourcePackagesRemoteRepos Verbosity
verbosity
                                     DistDirLayout{String
distDownloadSrcDirectory :: String
distDownloadSrcDirectory :: DistDirLayout -> String
distDownloadSrcDirectory}
                                     ProjectConfigShared {
                                       NubList String
projectConfigProgPathExtra :: NubList String
projectConfigProgPathExtra :: ProjectConfigShared -> NubList String
projectConfigProgPathExtra
                                     }
                                    [SourceRepoList]
repos = do

    [(SourceRepoList, String, RepoType, VCS Program)]
repos' <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. [(SourceRepoList, SourceRepoProblem)] -> Rebuild a
reportSourceRepoProblems forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
              forall (f :: * -> *).
[SourceRepositoryPackage f]
-> Either
     [(SourceRepositoryPackage f, SourceRepoProblem)]
     [(SourceRepositoryPackage f, String, RepoType, VCS Program)]
validateSourceRepos [SourceRepoList]
repos

    -- All 'SourceRepo's grouped by referring to the "same" remote repo
    -- instance. So same location but can differ in commit/tag/branch/subdir.
    let reposByLocation :: Map (RepoType, String)
                               [(SourceRepoList, RepoType)]
        reposByLocation :: Map (RepoType, String) [(SourceRepoList, RepoType)]
reposByLocation = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++)
                            [ ((RepoType
rtype, String
rloc), [(SourceRepoList
repo, forall program. VCS program -> RepoType
vcsRepoType VCS Program
vcs)])
                            | (SourceRepoList
repo, String
rloc, RepoType
rtype, VCS Program
vcs) <- [(SourceRepoList, String, RepoType, VCS Program)]
repos' ]

    --TODO: pass progPathExtra on to 'configureVCS'
    let _progPathExtra :: [String]
_progPathExtra = forall a. NubList a -> [a]
fromNubList NubList String
projectConfigProgPathExtra
    RepoType -> Rebuild (VCS ConfiguredProgram)
getConfiguredVCS <- forall k v. Ord k => (k -> IO v) -> Rebuild (k -> Rebuild v)
delayInitSharedResources forall a b. (a -> b) -> a -> b
$ \RepoType
repoType ->
                          let vcs :: VCS Program
vcs = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unknown VCS: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow RepoType
repoType) RepoType
repoType Map RepoType (VCS Program)
knownVCSs in
                          Verbosity -> VCS Program -> IO (VCS ConfiguredProgram)
configureVCS Verbosity
verbosity {-progPathExtra-} VCS Program
vcs

    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
      [ forall a b.
(Binary a, Structured a, Binary b, Structured b) =>
Verbosity -> FileMonitor a b -> a -> Rebuild b -> Rebuild b
rerunIfChanged Verbosity
verbosity FileMonitor
  [SourceRepoList]
  [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
monitor [SourceRepoList]
repoGroup' forall a b. (a -> b) -> a -> b
$ do
          VCS ConfiguredProgram
vcs' <- RepoType -> Rebuild (VCS ConfiguredProgram)
getConfiguredVCS RepoType
repoType
          VCS ConfiguredProgram
-> String
-> [SourceRepoList]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
syncRepoGroupAndReadSourcePackages VCS ConfiguredProgram
vcs' String
pathStem [SourceRepoList]
repoGroup'
      | repoGroup :: [(SourceRepoList, RepoType)]
repoGroup@((SourceRepoList
primaryRepo, RepoType
repoType):[(SourceRepoList, RepoType)]
_) <- forall k a. Map k a -> [a]
Map.elems Map (RepoType, String) [(SourceRepoList, RepoType)]
reposByLocation
      , let repoGroup' :: [SourceRepoList]
repoGroup' = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(SourceRepoList, RepoType)]
repoGroup
            pathStem :: String
pathStem = String
distDownloadSrcDirectory
                   String -> String -> String
</> SourceRepoList -> String
localFileNameForRemoteRepo SourceRepoList
primaryRepo
            monitor :: FileMonitor
                         [SourceRepoList]
                         [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
            monitor :: FileMonitor
  [SourceRepoList]
  [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
monitor  = forall a b. Eq a => String -> FileMonitor a b
newFileMonitor (String
pathStem String -> String -> String
<.> String
"cache")
      ]
  where
    syncRepoGroupAndReadSourcePackages
      :: VCS ConfiguredProgram
      -> FilePath
      -> [SourceRepoList]
      -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
    syncRepoGroupAndReadSourcePackages :: VCS ConfiguredProgram
-> String
-> [SourceRepoList]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
syncRepoGroupAndReadSourcePackages VCS ConfiguredProgram
vcs String
pathStem [SourceRepoList]
repoGroup = do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
False
                                                 String
distDownloadSrcDirectory

        -- For syncing we don't care about different 'SourceRepo' values that
        -- are just different subdirs in the same repo.
        forall (f :: * -> *).
Verbosity
-> VCS ConfiguredProgram
-> [(SourceRepositoryPackage f, String)]
-> Rebuild ()
syncSourceRepos Verbosity
verbosity VCS ConfiguredProgram
vcs
          [ (SourceRepositoryPackage Proxy
repo, String
repoPath)
          | (SourceRepositoryPackage Proxy
repo, NonEmpty (SourceRepositoryPackage Maybe)
_, String
repoPath) <- [(SourceRepositoryPackage Proxy,
  NonEmpty (SourceRepositoryPackage Maybe), String)]
repoGroupWithPaths ]

        -- Run post-checkout-command if it is specified
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(SourceRepositoryPackage Proxy,
  NonEmpty (SourceRepositoryPackage Maybe), String)]
repoGroupWithPaths forall a b. (a -> b) -> a -> b
$ \(SourceRepositoryPackage Proxy
repo, NonEmpty (SourceRepositoryPackage Maybe)
_, String
repoPath) ->
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (forall (f :: * -> *). SourceRepositoryPackage f -> [String]
srpCommand SourceRepositoryPackage Proxy
repo)) forall a b. (a -> b) -> a -> b
$ \(String
cmd :| [String]
args) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                IO ExitCode -> IO ()
maybeExit forall a b. (a -> b) -> a -> b
$ Verbosity
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> Maybe Handle
-> Maybe Handle
-> Maybe Handle
-> IO ExitCode
rawSystemIOWithEnv Verbosity
verbosity String
cmd [String]
args (forall a. a -> Maybe a
Just String
repoPath) forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing

        -- But for reading we go through each 'SourceRepo' including its subdir
        -- value and have to know which path each one ended up in.
        forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
          [ SourceRepositoryPackage Maybe
-> String
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readPackageFromSourceRepo SourceRepositoryPackage Maybe
repoWithSubdir String
repoPath
          | (SourceRepositoryPackage Proxy
_, NonEmpty (SourceRepositoryPackage Maybe)
reposWithSubdir, String
repoPath) <- [(SourceRepositoryPackage Proxy,
  NonEmpty (SourceRepositoryPackage Maybe), String)]
repoGroupWithPaths
          , SourceRepositoryPackage Maybe
repoWithSubdir <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty (SourceRepositoryPackage Maybe)
reposWithSubdir ]
      where
        -- So to do both things above, we pair them up here.
        repoGroupWithPaths
          :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)]
        repoGroupWithPaths :: [(SourceRepositoryPackage Proxy,
  NonEmpty (SourceRepositoryPackage Maybe), String)]
repoGroupWithPaths =
          forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(SourceRepositoryPackage Proxy
x, NonEmpty (SourceRepositoryPackage Maybe)
y) String
z -> (SourceRepositoryPackage Proxy
x,NonEmpty (SourceRepositoryPackage Maybe)
y,String
z))
                  (forall k v. Ord k => [(k, v)] -> [(k, NonEmpty v)]
mapGroup
                      [ (SourceRepositoryPackage Maybe
repo { srpSubdir :: Proxy String
srpSubdir = forall {k} (t :: k). Proxy t
Proxy }, SourceRepositoryPackage Maybe
repo)
                      | SourceRepositoryPackage Maybe
repo <- forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. NonEmpty a -> [a]
NE.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceRepoList -> NonEmpty (SourceRepositoryPackage Maybe)
srpFanOut) [SourceRepoList]
repoGroup
                      ])
                  [String]
repoPaths

        mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)]
        mapGroup :: forall k v. Ord k => [(k, v)] -> [(k, NonEmpty v)]
mapGroup = forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Semigroup a => a -> a -> a
(<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(k
k, v
v) -> (k
k, forall (f :: * -> *) a. Applicative f => a -> f a
pure v
v))

        -- The repos in a group are given distinct names by simple enumeration
        -- foo, foo-2, foo-3 etc
        repoPaths :: [FilePath]
        repoPaths :: [String]
repoPaths = String
pathStem
                  forall a. a -> [a] -> [a]
: [ String
pathStem forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
i :: Int) | Int
i <- [Int
2..] ]

    readPackageFromSourceRepo
        :: SourceRepositoryPackage Maybe
        -> FilePath
        -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
    readPackageFromSourceRepo :: SourceRepositoryPackage Maybe
-> String
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readPackageFromSourceRepo SourceRepositoryPackage Maybe
repo String
repoPath = do
        let packageDir :: FilePath
            packageDir :: String
packageDir = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
repoPath (String
repoPath String -> String -> String
</>) (forall (f :: * -> *). SourceRepositoryPackage f -> f String
srpSubdir SourceRepositoryPackage Maybe
repo)

        [String]
entries <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO [String]
getDirectoryContents String
packageDir
        --TODO: dcoutts 2018-06-23: wrap exceptions
        case forall a. (a -> Bool) -> [a] -> [a]
filter (\String
e -> String -> String
takeExtension String
e forall a. Eq a => a -> a -> Bool
== String
".cabal") [String]
entries of
          []       -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> CabalFileSearchFailure
NoCabalFileFound String
packageDir
          (String
_:String
_:[String]
_)  -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> CabalFileSearchFailure
MultipleCabalFilesFound String
packageDir
          [String
cabalFileName] -> do
            let cabalFilePath :: String
cabalFilePath = String
packageDir String -> String -> String
</> String
cabalFileName
            [MonitorFilePath] -> Rebuild ()
monitorFiles [String -> MonitorFilePath
monitorFileHashed String
cabalFilePath]
            GenericPackageDescription
gpd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> ByteString -> IO GenericPackageDescription
readSourcePackageCabalFile Verbosity
verbosity String
cabalFilePath forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
BS.readFile String
cabalFilePath

            -- write sdist tarball, to repoPath-pgkid
            ByteString
tarball <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Verbosity -> GenericPackageDescription -> String -> IO ByteString
packageDirToSdist Verbosity
verbosity GenericPackageDescription
gpd String
packageDir
            let tarballPath :: String
tarballPath = String
repoPath forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow (forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
gpd) forall a. [a] -> [a] -> [a]
++ String
".tar.gz"
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
LBS.writeFile String
tarballPath ByteString
tarball

            let location :: PackageLocation String
location = forall local.
SourceRepositoryPackage Maybe -> local -> PackageLocation local
RemoteSourceRepoPackage SourceRepositoryPackage Maybe
repo String
tarballPath
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PackageLocation String
-> GenericPackageDescription
-> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage PackageLocation String
location GenericPackageDescription
gpd

    reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a
    reportSourceRepoProblems :: forall a. [(SourceRepoList, SourceRepoProblem)] -> Rebuild a
reportSourceRepoProblems = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SourceRepoList, SourceRepoProblem)] -> String
renderSourceRepoProblems

    renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String
    renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String
renderSourceRepoProblems = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show -- "TODO: the repo problems"


-- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an
-- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package
-- from a given location.
--
mkSpecificSourcePackage :: PackageLocation FilePath
                        -> GenericPackageDescription
                        -> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage :: PackageLocation String
-> GenericPackageDescription
-> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage PackageLocation String
location GenericPackageDescription
pkg =
    forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage SourcePackage
      { srcpkgPackageId :: PackageId
srcpkgPackageId     = forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
pkg
      , srcpkgDescription :: GenericPackageDescription
srcpkgDescription   = GenericPackageDescription
pkg
      , srcpkgSource :: UnresolvedPkgLoc
srcpkgSource        = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just PackageLocation String
location
      , srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgDescrOverride = forall a. Maybe a
Nothing
      }


-- | Errors reported upon failing to parse a @.cabal@ file.
--
data CabalFileParseError = CabalFileParseError
    FilePath           -- ^ @.cabal@ file path
    BS.ByteString      -- ^ @.cabal@ file contents
    (NonEmpty PError)  -- ^ errors
    (Maybe Version)    -- ^ We might discover the spec version the package needs
    [PWarning]         -- ^ warnings
  deriving (Typeable)

-- | Manual instance which skips file contents
instance Show CabalFileParseError where
    showsPrec :: Int -> CabalFileParseError -> String -> String
showsPrec Int
d (CabalFileParseError String
fp ByteString
_ NonEmpty PError
es Maybe Version
mv [PWarning]
ws) = Bool -> (String -> String) -> String -> String
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10)
        forall a b. (a -> b) -> a -> b
$ String -> String -> String
showString String
"CabalFileParseError"
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 String
fp
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 (String
"" :: String)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 NonEmpty PError
es
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 Maybe Version
mv
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 [PWarning]
ws

instance Exception CabalFileParseError
#if MIN_VERSION_base(4,8,0)
  where
  displayException :: CabalFileParseError -> String
displayException = CabalFileParseError -> String
renderCabalFileParseError
#endif

renderCabalFileParseError :: CabalFileParseError -> String
renderCabalFileParseError :: CabalFileParseError -> String
renderCabalFileParseError (CabalFileParseError String
filePath ByteString
contents NonEmpty PError
errors Maybe Version
_ [PWarning]
warnings) =
    String -> ByteString -> NonEmpty PError -> [PWarning] -> String
renderParseError String
filePath ByteString
contents NonEmpty PError
errors [PWarning]
warnings

-- | Wrapper for the @.cabal@ file parser. It reports warnings on higher
-- verbosity levels and throws 'CabalFileParseError' on failure.
--
readSourcePackageCabalFile :: Verbosity
                           -> FilePath
                           -> BS.ByteString
                           -> IO GenericPackageDescription
readSourcePackageCabalFile :: Verbosity -> String -> ByteString -> IO GenericPackageDescription
readSourcePackageCabalFile Verbosity
verbosity String
pkgfilename ByteString
content =
    case forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult (ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription ByteString
content) of
      ([PWarning]
warnings, Right GenericPackageDescription
pkg) -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warnings) forall a b. (a -> b) -> a -> b
$
          Verbosity -> String -> IO ()
info Verbosity
verbosity ([PWarning] -> String
formatWarnings [PWarning]
warnings)
        forall (m :: * -> *) a. Monad m => a -> m a
return GenericPackageDescription
pkg

      ([PWarning]
warnings, Left (Maybe Version
mspecVersion, NonEmpty PError
errors)) ->
        forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String
-> ByteString
-> NonEmpty PError
-> Maybe Version
-> [PWarning]
-> CabalFileParseError
CabalFileParseError String
pkgfilename ByteString
content NonEmpty PError
errors Maybe Version
mspecVersion [PWarning]
warnings
  where
    formatWarnings :: [PWarning] -> String
formatWarnings [PWarning]
warnings =
        String
"The package description file " forall a. [a] -> [a] -> [a]
++ String
pkgfilename
     forall a. [a] -> [a] -> [a]
++ String
" has warnings: "
     forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (String -> PWarning -> String
showPWarning String
pkgfilename) [PWarning]
warnings)


-- | When looking for a package's @.cabal@ file we can find none, or several,
-- both of which are failures.
--
data CabalFileSearchFailure
   = NoCabalFileFound FilePath
   | MultipleCabalFilesFound FilePath
  deriving (Int -> CabalFileSearchFailure -> String -> String
[CabalFileSearchFailure] -> String -> String
CabalFileSearchFailure -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CabalFileSearchFailure] -> String -> String
$cshowList :: [CabalFileSearchFailure] -> String -> String
show :: CabalFileSearchFailure -> String
$cshow :: CabalFileSearchFailure -> String
showsPrec :: Int -> CabalFileSearchFailure -> String -> String
$cshowsPrec :: Int -> CabalFileSearchFailure -> String -> String
Show, Typeable)

instance Exception CabalFileSearchFailure


-- | Find the @.cabal@ file within a tarball file and return it by value.
--
-- Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception.
--
extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString)
extractTarballPackageCabalFile :: String -> IO (String, ByteString)
extractTarballPackageCabalFile String
tarballFile =
    forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
tarballFile IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
hnd -> do
      ByteString
content <- Handle -> IO ByteString
LBS.hGetContents Handle
hnd
      case String
-> ByteString
-> Either
     (Either FormatError CabalFileSearchFailure) (String, ByteString)
extractTarballPackageCabalFilePure String
tarballFile ByteString
content of
        Left (Left  FormatError
e) -> forall e a. Exception e => e -> IO a
throwIO FormatError
e
        Left (Right CabalFileSearchFailure
e) -> forall e a. Exception e => e -> IO a
throwIO CabalFileSearchFailure
e
        Right (String
fileName, ByteString
fileContent) ->
          (,) String
fileName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO a
evaluate (ByteString -> ByteString
LBS.toStrict ByteString
fileContent)


-- | Scan through a tar file stream and collect the @.cabal@ file, or fail.
--
extractTarballPackageCabalFilePure :: FilePath
                                   -> LBS.ByteString
                                   -> Either (Either Tar.FormatError
                                                     CabalFileSearchFailure)
                                             (FilePath, LBS.ByteString)
extractTarballPackageCabalFilePure :: String
-> ByteString
-> Either
     (Either FormatError CabalFileSearchFailure) (String, ByteString)
extractTarballPackageCabalFilePure String
tarballFile =
      forall {a} {b} {k}.
Either (a, b) (Map k Entry)
-> Either (Either a CabalFileSearchFailure) (String, ByteString)
check
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {e}.
Entries e -> Either (e, Map TarPath Entry) (Map TarPath Entry)
accumEntryMap
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. (Entry -> Bool) -> Entries e -> Entries e
Tar.filterEntries Entry -> Bool
isCabalFile
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZipUtils.maybeDecompress
  where
    accumEntryMap :: Entries e -> Either (e, Map TarPath Entry) (Map TarPath Entry)
accumEntryMap = forall a e. (a -> Entry -> a) -> a -> Entries e -> Either (e, a) a
Tar.foldlEntries
                      (\Map TarPath Entry
m Entry
e -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Entry -> TarPath
Tar.entryTarPath Entry
e) Entry
e Map TarPath Entry
m)
                      forall k a. Map k a
Map.empty

    check :: Either (a, b) (Map k Entry)
-> Either (Either a CabalFileSearchFailure) (String, ByteString)
check (Left (a
e, b
_m)) = forall a b. a -> Either a b
Left (forall a b. a -> Either a b
Left a
e)
    check (Right Map k Entry
m) = case forall k a. Map k a -> [a]
Map.elems Map k Entry
m of
        []     -> forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> CabalFileSearchFailure
NoCabalFileFound String
tarballFile)
        [Entry
file] -> case Entry -> EntryContent
Tar.entryContent Entry
file of
          Tar.NormalFile ByteString
content FileSize
_ -> forall a b. b -> Either a b
Right (Entry -> String
Tar.entryPath Entry
file, ByteString
content)
          EntryContent
_                        -> forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> CabalFileSearchFailure
NoCabalFileFound String
tarballFile)
        [Entry]
_files -> forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> CabalFileSearchFailure
MultipleCabalFilesFound String
tarballFile)

    isCabalFile :: Entry -> Bool
isCabalFile Entry
e = case String -> [String]
splitPath (Entry -> String
Tar.entryPath Entry
e) of
      [     String
_dir, String
file] -> String -> String
takeExtension String
file forall a. Eq a => a -> a -> Bool
== String
".cabal"
      [String
".", String
_dir, String
file] -> String -> String
takeExtension String
file forall a. Eq a => a -> a -> Bool
== String
".cabal"
      [String]
_                 -> Bool
False


-- | The name to use for a local file for a remote tarball 'SourceRepo'.
-- This is deterministic based on the remote tarball URI, and is intended
-- to produce non-clashing file names for different tarballs.
--
localFileNameForRemoteTarball :: URI -> FilePath
localFileNameForRemoteTarball :: URI -> String
localFileNameForRemoteTarball URI
uri =
    URI -> String
mangleName URI
uri
 forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++  forall a. (Integral a, Show a) => a -> String -> String
showHex Word
locationHash String
""
  where
    mangleName :: URI -> String
mangleName = Int -> String -> String
truncateString Int
10 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropExtension forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropExtension
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeFileName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropTrailingPathSeparator forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
uriPath

    locationHash :: Word
    locationHash :: Word
locationHash = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Hashable a => a -> Int
Hashable.hash ((String -> String) -> URI -> String -> String
uriToString forall a. a -> a
id URI
uri String
""))


-- | The name to use for a local file or dir for a remote 'SourceRepo'.
-- This is deterministic based on the source repo identity details, and
-- intended to produce non-clashing file names for different repos.
--
localFileNameForRemoteRepo :: SourceRepoList -> FilePath
localFileNameForRemoteRepo :: SourceRepoList -> String
localFileNameForRemoteRepo SourceRepositoryPackage {RepoType
srpType :: forall (f :: * -> *). SourceRepositoryPackage f -> RepoType
srpType :: RepoType
srpType, String
srpLocation :: forall (f :: * -> *). SourceRepositoryPackage f -> String
srpLocation :: String
srpLocation} =
    String -> String
mangleName String
srpLocation forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++ forall a. (Integral a, Show a) => a -> String -> String
showHex Word
locationHash String
""
  where
    mangleName :: String -> String
mangleName = Int -> String -> String
truncateString Int
10 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropExtension
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeFileName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropTrailingPathSeparator

    -- just the parts that make up the "identity" of the repo
    locationHash :: Word
    locationHash :: Word
locationHash =
      forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Hashable a => a -> Int
Hashable.hash (forall a. Show a => a -> String
show RepoType
srpType, String
srpLocation))


-- | Truncate a string, with a visual indication that it is truncated.
truncateString :: Int -> String -> String
truncateString :: Int -> String -> String
truncateString Int
n String
s | forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Ord a => a -> a -> Bool
<= Int
n = String
s
                   | Bool
otherwise     = forall a. Int -> [a] -> [a]
take (Int
nforall a. Num a => a -> a -> a
-Int
1) String
s forall a. [a] -> [a] -> [a]
++ String
"_"


-- TODO: add something like this, here or in the project planning
-- Based on the package location, which packages will be built inplace in the
-- build tree vs placed in the store. This has various implications on what we
-- can do with the package, e.g. can we run tests, ghci etc.
--
-- packageIsLocalToProject :: ProjectPackageLocation -> Bool


---------------------------------------------
-- Checking configuration sanity
--

data BadPerPackageCompilerPaths
   = BadPerPackageCompilerPaths [(PackageName, String)]
#if MIN_VERSION_base(4,8,0)
  deriving (Int -> BadPerPackageCompilerPaths -> String -> String
[BadPerPackageCompilerPaths] -> String -> String
BadPerPackageCompilerPaths -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [BadPerPackageCompilerPaths] -> String -> String
$cshowList :: [BadPerPackageCompilerPaths] -> String -> String
show :: BadPerPackageCompilerPaths -> String
$cshow :: BadPerPackageCompilerPaths -> String
showsPrec :: Int -> BadPerPackageCompilerPaths -> String -> String
$cshowsPrec :: Int -> BadPerPackageCompilerPaths -> String -> String
Show, Typeable)
#else
  deriving (Typeable)

instance Show BadPerPackageCompilerPaths where
  show = renderBadPerPackageCompilerPaths
#endif

instance Exception BadPerPackageCompilerPaths where
#if MIN_VERSION_base(4,8,0)
  displayException :: BadPerPackageCompilerPaths -> String
displayException = BadPerPackageCompilerPaths -> String
renderBadPerPackageCompilerPaths
#endif
--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc

renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String
renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String
renderBadPerPackageCompilerPaths
  (BadPerPackageCompilerPaths ((PackageName
pkgname, String
progname) : [(PackageName, String)]
_)) =
    String
"The path to the compiler program (or programs used by the compiler) "
 forall a. [a] -> [a] -> [a]
++ String
"cannot be specified on a per-package basis in the cabal.project file "
 forall a. [a] -> [a] -> [a]
++ String
"(i.e. setting the '" forall a. [a] -> [a] -> [a]
++ String
progname forall a. [a] -> [a] -> [a]
++ String
"-location' for package '"
 forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow PackageName
pkgname forall a. [a] -> [a] -> [a]
++ String
"'). All packages have to use the same compiler, so "
 forall a. [a] -> [a] -> [a]
++ String
"specify the path in a global 'program-locations' section."
 --TODO: [nice to have] better format control so we can pretty-print the
 -- offending part of the project file. Currently the line wrapping breaks any
 -- formatting.
renderBadPerPackageCompilerPaths BadPerPackageCompilerPaths
_ = forall a. HasCallStack => String -> a
error String
"renderBadPerPackageCompilerPaths"

-- | The project configuration is not allowed to specify program locations for
-- programs used by the compiler as these have to be the same for each set of
-- packages.
--
-- We cannot check this until we know which programs the compiler uses, which
-- in principle is not until we've configured the compiler.
--
-- Throws 'BadPerPackageCompilerPaths'
--
checkBadPerPackageCompilerPaths :: [ConfiguredProgram]
                                -> Map PackageName PackageConfig
                                -> IO ()
checkBadPerPackageCompilerPaths :: [ConfiguredProgram] -> Map PackageName PackageConfig -> IO ()
checkBadPerPackageCompilerPaths [ConfiguredProgram]
compilerPrograms Map PackageName PackageConfig
packagesConfig =
    case [ (PackageName
pkgname, String
progname)
         | let compProgNames :: Set String
compProgNames = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map ConfiguredProgram -> String
programId [ConfiguredProgram]
compilerPrograms)
         ,  (PackageName
pkgname, PackageConfig
pkgconf) <- forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName PackageConfig
packagesConfig
         , String
progname <- forall k a. Map k a -> [k]
Map.keys (forall k v. MapLast k v -> Map k v
getMapLast (PackageConfig -> MapLast String String
packageConfigProgramPaths PackageConfig
pkgconf))
         , String
progname forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
compProgNames ] of
      [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [(PackageName, String)]
ps -> forall e a. Exception e => e -> IO a
throwIO ([(PackageName, String)] -> BadPerPackageCompilerPaths
BadPerPackageCompilerPaths [(PackageName, String)]
ps)