{-# 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, 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 :: (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
 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a -> (PackageConfig -> a) -> Maybe PackageConfig -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
forall a. Monoid a => a
mempty PackageConfig -> a
field
          (PackageName -> Map PackageName PackageConfig -> Maybe PackageConfig
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgname (MapMappend PackageName PackageConfig
-> Map PackageName PackageConfig
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 :: Verbosity -> BuildTimeSettings -> (RepoContext -> IO a) -> IO a
projectConfigWithBuilderRepoContext Verbosity
verbosity BuildTimeSettings{Bool
Int
FilePath
[FilePath]
[PathTemplate]
[LocalRepo]
[RemoteRepo]
Maybe FilePath
Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
Verbosity
ReportLevel
buildSettingHaddockOpen :: BuildTimeSettings -> Bool
buildSettingProgPathExtra :: BuildTimeSettings -> [FilePath]
buildSettingIgnoreExpiry :: BuildTimeSettings -> Bool
buildSettingHttpTransport :: BuildTimeSettings -> Maybe FilePath
buildSettingCacheDir :: BuildTimeSettings -> FilePath
buildSettingLocalNoIndexRepos :: BuildTimeSettings -> [LocalRepo]
buildSettingRemoteRepos :: BuildTimeSettings -> [RemoteRepo]
buildSettingKeepTempFiles :: BuildTimeSettings -> Bool
buildSettingOfflineMode :: BuildTimeSettings -> Bool
buildSettingKeepGoing :: BuildTimeSettings -> Bool
buildSettingNumJobs :: BuildTimeSettings -> Int
buildSettingSymlinkBinDir :: BuildTimeSettings -> [FilePath]
buildSettingReportPlanningFailure :: BuildTimeSettings -> Bool
buildSettingBuildReports :: BuildTimeSettings -> ReportLevel
buildSettingLogVerbosity :: BuildTimeSettings -> Verbosity
buildSettingLogFile :: BuildTimeSettings
-> Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
buildSettingSummaryFile :: BuildTimeSettings -> [PathTemplate]
buildSettingOnlyDownload :: BuildTimeSettings -> Bool
buildSettingOnlyDeps :: BuildTimeSettings -> Bool
buildSettingDryRun :: BuildTimeSettings -> Bool
buildSettingHaddockOpen :: Bool
buildSettingProgPathExtra :: [FilePath]
buildSettingIgnoreExpiry :: Bool
buildSettingHttpTransport :: Maybe FilePath
buildSettingCacheDir :: FilePath
buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingRemoteRepos :: [RemoteRepo]
buildSettingKeepTempFiles :: Bool
buildSettingOfflineMode :: Bool
buildSettingKeepGoing :: Bool
buildSettingNumJobs :: Int
buildSettingSymlinkBinDir :: [FilePath]
buildSettingReportPlanningFailure :: Bool
buildSettingBuildReports :: ReportLevel
buildSettingLogVerbosity :: Verbosity
buildSettingLogFile :: Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
buildSettingSummaryFile :: [PathTemplate]
buildSettingOnlyDownload :: Bool
buildSettingOnlyDeps :: Bool
buildSettingDryRun :: Bool
..} =
    Verbosity
-> [RemoteRepo]
-> [LocalRepo]
-> FilePath
-> Maybe FilePath
-> Maybe Bool
-> [FilePath]
-> (RepoContext -> IO a)
-> IO a
forall a.
Verbosity
-> [RemoteRepo]
-> [LocalRepo]
-> FilePath
-> Maybe FilePath
-> Maybe Bool
-> [FilePath]
-> (RepoContext -> IO a)
-> IO a
withRepoContext'
      Verbosity
verbosity
      [RemoteRepo]
buildSettingRemoteRepos
      [LocalRepo]
buildSettingLocalNoIndexRepos
      FilePath
buildSettingCacheDir
      Maybe FilePath
buildSettingHttpTransport
      (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
buildSettingIgnoreExpiry)
      [FilePath]
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 :: Verbosity
-> ProjectConfigShared
-> ProjectConfigBuildOnly
-> (RepoContext -> IO a)
-> IO a
projectConfigWithSolverRepoContext Verbosity
verbosity
                                   ProjectConfigShared{[Maybe PackageDB]
[(UserConstraint, ConstraintSource)]
[PackageVersionConstraint]
Maybe AllowOlder
Maybe AllowNewer
NubList FilePath
NubList LocalRepo
NubList RemoteRepo
Flag Bool
Flag Int
Flag FilePath
Flag CompilerFlavor
Flag PathTemplate
Flag Version
Flag ReorderGoals
Flag CountConflicts
Flag FineGrainedConflicts
Flag MinimizeConflictSet
Flag IndependentGoals
Flag StrongFlags
Flag AllowBootLibInstalls
Flag OnlyConstrained
Flag PreSolver
Flag TotalIndexState
Flag ActiveRepos
Flag WriteGhcEnvironmentFilesPolicy
projectConfigProgPathExtra :: ProjectConfigShared -> NubList FilePath
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 FilePath
projectConfigIndexState :: ProjectConfigShared -> Flag TotalIndexState
projectConfigActiveRepos :: ProjectConfigShared -> Flag ActiveRepos
projectConfigLocalNoIndexRepos :: ProjectConfigShared -> NubList LocalRepo
projectConfigRemoteRepos :: ProjectConfigShared -> NubList RemoteRepo
projectConfigPackageDBs :: ProjectConfigShared -> [Maybe PackageDB]
projectConfigHaddockIndex :: ProjectConfigShared -> Flag PathTemplate
projectConfigHcPkg :: ProjectConfigShared -> Flag FilePath
projectConfigHcPath :: ProjectConfigShared -> Flag FilePath
projectConfigHcFlavor :: ProjectConfigShared -> Flag CompilerFlavor
projectConfigIgnoreProject :: ProjectConfigShared -> Flag Bool
projectConfigProjectFile :: ProjectConfigShared -> Flag FilePath
projectConfigConfigFile :: ProjectConfigShared -> Flag FilePath
projectConfigDistDir :: ProjectConfigShared -> Flag FilePath
projectConfigProgPathExtra :: NubList FilePath
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 FilePath
projectConfigIndexState :: Flag TotalIndexState
projectConfigActiveRepos :: Flag ActiveRepos
projectConfigLocalNoIndexRepos :: NubList LocalRepo
projectConfigRemoteRepos :: NubList RemoteRepo
projectConfigPackageDBs :: [Maybe PackageDB]
projectConfigHaddockIndex :: Flag PathTemplate
projectConfigHcPkg :: Flag FilePath
projectConfigHcPath :: Flag FilePath
projectConfigHcFlavor :: Flag CompilerFlavor
projectConfigIgnoreProject :: Flag Bool
projectConfigProjectFile :: Flag FilePath
projectConfigConfigFile :: Flag FilePath
projectConfigDistDir :: Flag FilePath
..}
                                   ProjectConfigBuildOnly{NubList PathTemplate
Flag Bool
Flag FilePath
Flag (Maybe Int)
Flag Verbosity
Flag PathTemplate
Flag ReportLevel
ClientInstallFlags
projectConfigClientInstallFlags :: ProjectConfigBuildOnly -> ClientInstallFlags
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag FilePath
projectConfigCacheDir :: ProjectConfigBuildOnly -> Flag FilePath
projectConfigIgnoreExpiry :: ProjectConfigBuildOnly -> Flag Bool
projectConfigHttpTransport :: ProjectConfigBuildOnly -> Flag FilePath
projectConfigKeepTempFiles :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOfflineMode :: ProjectConfigBuildOnly -> Flag Bool
projectConfigKeepGoing :: ProjectConfigBuildOnly -> Flag Bool
projectConfigNumJobs :: ProjectConfigBuildOnly -> Flag (Maybe Int)
projectConfigSymlinkBinDir :: ProjectConfigBuildOnly -> Flag FilePath
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 FilePath
projectConfigCacheDir :: Flag FilePath
projectConfigIgnoreExpiry :: Flag Bool
projectConfigHttpTransport :: Flag FilePath
projectConfigKeepTempFiles :: Flag Bool
projectConfigOfflineMode :: Flag Bool
projectConfigKeepGoing :: Flag Bool
projectConfigNumJobs :: Flag (Maybe Int)
projectConfigSymlinkBinDir :: Flag FilePath
projectConfigReportPlanningFailure :: Flag Bool
projectConfigBuildReports :: Flag ReportLevel
projectConfigLogFile :: Flag PathTemplate
projectConfigSummaryFile :: NubList PathTemplate
projectConfigOnlyDownload :: Flag Bool
projectConfigOnlyDeps :: Flag Bool
projectConfigDryRun :: Flag Bool
projectConfigVerbosity :: Flag Verbosity
..} =
    Verbosity
-> [RemoteRepo]
-> [LocalRepo]
-> FilePath
-> Maybe FilePath
-> Maybe Bool
-> [FilePath]
-> (RepoContext -> IO a)
-> IO a
forall a.
Verbosity
-> [RemoteRepo]
-> [LocalRepo]
-> FilePath
-> Maybe FilePath
-> Maybe Bool
-> [FilePath]
-> (RepoContext -> IO a)
-> IO a
withRepoContext'
      Verbosity
verbosity
      (NubList RemoteRepo -> [RemoteRepo]
forall a. NubList a -> [a]
fromNubList NubList RemoteRepo
projectConfigRemoteRepos)
      (NubList LocalRepo -> [LocalRepo]
forall a. NubList a -> [a]
fromNubList NubList LocalRepo
projectConfigLocalNoIndexRepos)
      (FilePath -> Flag FilePath -> FilePath
forall a. a -> Flag a -> a
fromFlagOrDefault
                   (FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error
                    FilePath
"projectConfigWithSolverRepoContext: projectConfigCacheDir")
                   Flag FilePath
projectConfigCacheDir)
      (Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigHttpTransport)
      (Flag Bool -> Maybe Bool
forall a. Flag a -> Maybe a
flagToMaybe Flag Bool
projectConfigIgnoreExpiry)
      (NubList FilePath -> [FilePath]
forall a. NubList a -> [a]
fromNubList NubList FilePath
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 :: [RemoteRepo]
-> [LocalRepo]
-> [(UserConstraint, ConstraintSource)]
-> [PackageVersionConstraint]
-> FlagAssignment
-> Map PackageName FlagAssignment
-> Maybe Version
-> PreSolver
-> AllowOlder
-> AllowNewer
-> Maybe Int
-> ReorderGoals
-> CountConflicts
-> FineGrainedConflicts
-> MinimizeConflictSet
-> StrongFlags
-> AllowBootLibInstalls
-> OnlyConstrained
-> Maybe TotalIndexState
-> Maybe ActiveRepos
-> IndependentGoals
-> SolverSettings
SolverSettings {[(UserConstraint, ConstraintSource)]
[PackageVersionConstraint]
[LocalRepo]
[RemoteRepo]
Maybe Int
Maybe Version
Maybe TotalIndexState
Maybe ActiveRepos
Map PackageName FlagAssignment
FlagAssignment
ReorderGoals
CountConflicts
FineGrainedConflicts
MinimizeConflictSet
IndependentGoals
StrongFlags
AllowBootLibInstalls
OnlyConstrained
PreSolver
AllowOlder
AllowNewer
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]
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       = NubList RemoteRepo -> [RemoteRepo]
forall a. NubList a -> [a]
fromNubList NubList RemoteRepo
projectConfigRemoteRepos
    solverSettingLocalNoIndexRepos :: [LocalRepo]
solverSettingLocalNoIndexRepos = NubList LocalRepo -> [LocalRepo]
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   = (PackageConfig -> FlagAssignment)
-> Map PackageName PackageConfig -> Map PackageName FlagAssignment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageConfig -> FlagAssignment
packageConfigFlagAssignment
                                          (MapMappend PackageName PackageConfig
-> Map PackageName PackageConfig
forall k v. MapMappend k v -> Map k v
getMapMappend MapMappend PackageName PackageConfig
projectConfigSpecificPackage)
    solverSettingCabalVersion :: Maybe Version
solverSettingCabalVersion      = Flag Version -> Maybe Version
forall a. Flag a -> Maybe a
flagToMaybe Flag Version
projectConfigCabalVersion
    solverSettingSolver :: PreSolver
solverSettingSolver            = Flag PreSolver -> PreSolver
forall a. WithCallStack (Flag a -> a)
fromFlag Flag PreSolver
projectConfigSolver
    solverSettingAllowOlder :: AllowOlder
solverSettingAllowOlder        = AllowOlder -> Maybe AllowOlder -> AllowOlder
forall a. a -> Maybe a -> a
fromMaybe AllowOlder
forall a. Monoid a => a
mempty Maybe AllowOlder
projectConfigAllowOlder
    solverSettingAllowNewer :: AllowNewer
solverSettingAllowNewer        = AllowNewer -> Maybe AllowNewer -> AllowNewer
forall a. a -> Maybe a -> a
fromMaybe AllowNewer
forall a. Monoid a => a
mempty Maybe AllowNewer
projectConfigAllowNewer
    solverSettingMaxBackjumps :: Maybe Int
solverSettingMaxBackjumps      = case Flag Int -> Int
forall a. WithCallStack (Flag a -> a)
fromFlag Flag Int
projectConfigMaxBackjumps of
                                       Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0     -> Maybe Int
forall a. Maybe a
Nothing
                                         | Bool
otherwise -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
    solverSettingReorderGoals :: ReorderGoals
solverSettingReorderGoals      = Flag ReorderGoals -> ReorderGoals
forall a. WithCallStack (Flag a -> a)
fromFlag Flag ReorderGoals
projectConfigReorderGoals
    solverSettingCountConflicts :: CountConflicts
solverSettingCountConflicts    = Flag CountConflicts -> CountConflicts
forall a. WithCallStack (Flag a -> a)
fromFlag Flag CountConflicts
projectConfigCountConflicts
    solverSettingFineGrainedConflicts :: FineGrainedConflicts
solverSettingFineGrainedConflicts = Flag FineGrainedConflicts -> FineGrainedConflicts
forall a. WithCallStack (Flag a -> a)
fromFlag Flag FineGrainedConflicts
projectConfigFineGrainedConflicts
    solverSettingMinimizeConflictSet :: MinimizeConflictSet
solverSettingMinimizeConflictSet = Flag MinimizeConflictSet -> MinimizeConflictSet
forall a. WithCallStack (Flag a -> a)
fromFlag Flag MinimizeConflictSet
projectConfigMinimizeConflictSet
    solverSettingStrongFlags :: StrongFlags
solverSettingStrongFlags       = Flag StrongFlags -> StrongFlags
forall a. WithCallStack (Flag a -> a)
fromFlag Flag StrongFlags
projectConfigStrongFlags
    solverSettingAllowBootLibInstalls :: AllowBootLibInstalls
solverSettingAllowBootLibInstalls = Flag AllowBootLibInstalls -> AllowBootLibInstalls
forall a. WithCallStack (Flag a -> a)
fromFlag Flag AllowBootLibInstalls
projectConfigAllowBootLibInstalls
    solverSettingOnlyConstrained :: OnlyConstrained
solverSettingOnlyConstrained   = Flag OnlyConstrained -> OnlyConstrained
forall a. WithCallStack (Flag a -> a)
fromFlag Flag OnlyConstrained
projectConfigOnlyConstrained
    solverSettingIndexState :: Maybe TotalIndexState
solverSettingIndexState        = Flag TotalIndexState -> Maybe TotalIndexState
forall a. Flag a -> Maybe a
flagToMaybe Flag TotalIndexState
projectConfigIndexState
    solverSettingActiveRepos :: Maybe ActiveRepos
solverSettingActiveRepos       = Flag ActiveRepos -> Maybe ActiveRepos
forall a. Flag a -> Maybe a
flagToMaybe Flag ActiveRepos
projectConfigActiveRepos
    solverSettingIndependentGoals :: IndependentGoals
solverSettingIndependentGoals  = Flag IndependentGoals -> IndependentGoals
forall a. WithCallStack (Flag a -> a)
fromFlag Flag IndependentGoals
projectConfigIndependentGoals
  --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 FilePath
NubList LocalRepo
NubList RemoteRepo
Flag Bool
Flag Int
Flag FilePath
Flag CompilerFlavor
Flag PathTemplate
Flag Version
Flag ReorderGoals
Flag CountConflicts
Flag FineGrainedConflicts
Flag MinimizeConflictSet
Flag IndependentGoals
Flag StrongFlags
Flag AllowBootLibInstalls
Flag OnlyConstrained
Flag PreSolver
Flag TotalIndexState
Flag ActiveRepos
Flag WriteGhcEnvironmentFilesPolicy
projectConfigProgPathExtra :: NubList FilePath
projectConfigPerComponent :: Flag Bool
projectConfigWriteGhcEnvironmentFilesPolicy :: Flag WriteGhcEnvironmentFilesPolicy
projectConfigStoreDir :: Flag FilePath
projectConfigPackageDBs :: [Maybe PackageDB]
projectConfigHaddockIndex :: Flag PathTemplate
projectConfigHcPkg :: Flag FilePath
projectConfigHcPath :: Flag FilePath
projectConfigHcFlavor :: Flag CompilerFlavor
projectConfigIgnoreProject :: Flag Bool
projectConfigProjectFile :: Flag FilePath
projectConfigConfigFile :: Flag FilePath
projectConfigDistDir :: Flag FilePath
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 FilePath
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 FilePath
projectConfigIndexState :: ProjectConfigShared -> Flag TotalIndexState
projectConfigActiveRepos :: ProjectConfigShared -> Flag ActiveRepos
projectConfigLocalNoIndexRepos :: ProjectConfigShared -> NubList LocalRepo
projectConfigRemoteRepos :: ProjectConfigShared -> NubList RemoteRepo
projectConfigPackageDBs :: ProjectConfigShared -> [Maybe PackageDB]
projectConfigHaddockIndex :: ProjectConfigShared -> Flag PathTemplate
projectConfigHcPkg :: ProjectConfigShared -> Flag FilePath
projectConfigHcPath :: ProjectConfigShared -> Flag FilePath
projectConfigHcFlavor :: ProjectConfigShared -> Flag CompilerFlavor
projectConfigIgnoreProject :: ProjectConfigShared -> Flag Bool
projectConfigProjectFile :: ProjectConfigShared -> Flag FilePath
projectConfigConfigFile :: ProjectConfigShared -> Flag FilePath
projectConfigDistDir :: ProjectConfigShared -> Flag FilePath
..} = ProjectConfigShared
defaults ProjectConfigShared -> ProjectConfigShared -> ProjectConfigShared
forall a. Semigroup a => a -> a -> a
<> ProjectConfigShared
projectConfigShared

    defaults :: ProjectConfigShared
defaults = ProjectConfigShared
forall a. Monoid a => a
mempty {
       projectConfigSolver :: Flag PreSolver
projectConfigSolver            = PreSolver -> Flag PreSolver
forall a. a -> Flag a
Flag PreSolver
defaultSolver,
       projectConfigAllowOlder :: Maybe AllowOlder
projectConfigAllowOlder        = AllowOlder -> Maybe AllowOlder
forall a. a -> Maybe a
Just (RelaxDeps -> AllowOlder
AllowOlder RelaxDeps
forall a. Monoid a => a
mempty),
       projectConfigAllowNewer :: Maybe AllowNewer
projectConfigAllowNewer        = AllowNewer -> Maybe AllowNewer
forall a. a -> Maybe a
Just (RelaxDeps -> AllowNewer
AllowNewer RelaxDeps
forall a. Monoid a => a
mempty),
       projectConfigMaxBackjumps :: Flag Int
projectConfigMaxBackjumps      = Int -> Flag Int
forall a. a -> Flag a
Flag Int
defaultMaxBackjumps,
       projectConfigReorderGoals :: Flag ReorderGoals
projectConfigReorderGoals      = ReorderGoals -> Flag ReorderGoals
forall a. a -> Flag a
Flag (Bool -> ReorderGoals
ReorderGoals Bool
False),
       projectConfigCountConflicts :: Flag CountConflicts
projectConfigCountConflicts    = CountConflicts -> Flag CountConflicts
forall a. a -> Flag a
Flag (Bool -> CountConflicts
CountConflicts Bool
True),
       projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts
projectConfigFineGrainedConflicts = FineGrainedConflicts -> Flag FineGrainedConflicts
forall a. a -> Flag a
Flag (Bool -> FineGrainedConflicts
FineGrainedConflicts Bool
True),
       projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet
projectConfigMinimizeConflictSet = MinimizeConflictSet -> Flag MinimizeConflictSet
forall a. a -> Flag a
Flag (Bool -> MinimizeConflictSet
MinimizeConflictSet Bool
False),
       projectConfigStrongFlags :: Flag StrongFlags
projectConfigStrongFlags       = StrongFlags -> Flag StrongFlags
forall a. a -> Flag a
Flag (Bool -> StrongFlags
StrongFlags Bool
False),
       projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls
projectConfigAllowBootLibInstalls = AllowBootLibInstalls -> Flag AllowBootLibInstalls
forall a. a -> Flag a
Flag (Bool -> AllowBootLibInstalls
AllowBootLibInstalls Bool
False),
       projectConfigOnlyConstrained :: Flag OnlyConstrained
projectConfigOnlyConstrained   = OnlyConstrained -> Flag OnlyConstrained
forall a. a -> Flag a
Flag OnlyConstrained
OnlyConstrainedNone,
       projectConfigIndependentGoals :: Flag IndependentGoals
projectConfigIndependentGoals  = IndependentGoals -> Flag IndependentGoals
forall a. a -> Flag a
Flag (Bool -> IndependentGoals
IndependentGoals 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 {
                           FilePath
cabalLogsDirectory :: CabalDirLayout -> FilePath
cabalLogsDirectory :: FilePath
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 FilePath
projectConfigProgPathExtra :: NubList FilePath
projectConfigProgPathExtra :: ProjectConfigShared -> NubList FilePath
projectConfigProgPathExtra
                           },
                           ProjectConfigBuildOnly
projectConfigBuildOnly :: ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly :: ProjectConfigBuildOnly
projectConfigBuildOnly
                         } =
    BuildTimeSettings :: Bool
-> Bool
-> Bool
-> [PathTemplate]
-> Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
-> Verbosity
-> ReportLevel
-> Bool
-> [FilePath]
-> Int
-> Bool
-> Bool
-> Bool
-> [RemoteRepo]
-> [LocalRepo]
-> FilePath
-> Maybe FilePath
-> Bool
-> [FilePath]
-> Bool
-> BuildTimeSettings
BuildTimeSettings {Bool
Int
FilePath
[FilePath]
[PathTemplate]
[LocalRepo]
[RemoteRepo]
Maybe FilePath
Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
Verbosity
ReportLevel
buildSettingLogVerbosity :: Verbosity
buildSettingLogFile :: Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
buildSettingHaddockOpen :: Bool
buildSettingProgPathExtra :: [FilePath]
buildSettingReportPlanningFailure :: Bool
buildSettingIgnoreExpiry :: Bool
buildSettingHttpTransport :: Maybe FilePath
buildSettingCacheDir :: FilePath
buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingRemoteRepos :: [RemoteRepo]
buildSettingKeepTempFiles :: Bool
buildSettingOfflineMode :: Bool
buildSettingKeepGoing :: Bool
buildSettingNumJobs :: Int
buildSettingSymlinkBinDir :: [FilePath]
buildSettingBuildReports :: ReportLevel
buildSettingSummaryFile :: [PathTemplate]
buildSettingOnlyDownload :: Bool
buildSettingOnlyDeps :: Bool
buildSettingDryRun :: Bool
buildSettingHaddockOpen :: Bool
buildSettingProgPathExtra :: [FilePath]
buildSettingIgnoreExpiry :: Bool
buildSettingHttpTransport :: Maybe FilePath
buildSettingCacheDir :: FilePath
buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingRemoteRepos :: [RemoteRepo]
buildSettingKeepTempFiles :: Bool
buildSettingOfflineMode :: Bool
buildSettingKeepGoing :: Bool
buildSettingNumJobs :: Int
buildSettingSymlinkBinDir :: [FilePath]
buildSettingReportPlanningFailure :: Bool
buildSettingBuildReports :: ReportLevel
buildSettingLogVerbosity :: Verbosity
buildSettingLogFile :: Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
buildSettingSummaryFile :: [PathTemplate]
buildSettingOnlyDownload :: Bool
buildSettingOnlyDeps :: Bool
buildSettingDryRun :: Bool
..}
  where
    buildSettingDryRun :: Bool
buildSettingDryRun        = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigDryRun
    buildSettingOnlyDeps :: Bool
buildSettingOnlyDeps      = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigOnlyDeps
    buildSettingOnlyDownload :: Bool
buildSettingOnlyDownload  = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigOnlyDownload
    buildSettingSummaryFile :: [PathTemplate]
buildSettingSummaryFile   = NubList PathTemplate -> [PathTemplate]
forall a. NubList a -> [a]
fromNubList NubList PathTemplate
projectConfigSummaryFile
    --buildSettingLogFile       -- defined below, more complicated
    --buildSettingLogVerbosity  -- defined below, more complicated
    buildSettingBuildReports :: ReportLevel
buildSettingBuildReports  = Flag ReportLevel -> ReportLevel
forall a. WithCallStack (Flag a -> a)
fromFlag    Flag ReportLevel
projectConfigBuildReports
    buildSettingSymlinkBinDir :: [FilePath]
buildSettingSymlinkBinDir = Flag FilePath -> [FilePath]
forall a. Flag a -> [a]
flagToList  Flag FilePath
projectConfigSymlinkBinDir
    buildSettingNumJobs :: Int
buildSettingNumJobs       = Flag (Maybe Int) -> Int
determineNumJobs Flag (Maybe Int)
projectConfigNumJobs
    buildSettingKeepGoing :: Bool
buildSettingKeepGoing     = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigKeepGoing
    buildSettingOfflineMode :: Bool
buildSettingOfflineMode   = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigOfflineMode
    buildSettingKeepTempFiles :: Bool
buildSettingKeepTempFiles = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigKeepTempFiles
    buildSettingRemoteRepos :: [RemoteRepo]
buildSettingRemoteRepos   = NubList RemoteRepo -> [RemoteRepo]
forall a. NubList a -> [a]
fromNubList NubList RemoteRepo
projectConfigRemoteRepos
    buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingLocalNoIndexRepos = NubList LocalRepo -> [LocalRepo]
forall a. NubList a -> [a]
fromNubList NubList LocalRepo
projectConfigLocalNoIndexRepos
    buildSettingCacheDir :: FilePath
buildSettingCacheDir      = Flag FilePath -> FilePath
forall a. WithCallStack (Flag a -> a)
fromFlag    Flag FilePath
projectConfigCacheDir
    buildSettingHttpTransport :: Maybe FilePath
buildSettingHttpTransport = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigHttpTransport
    buildSettingIgnoreExpiry :: Bool
buildSettingIgnoreExpiry  = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag    Flag Bool
projectConfigIgnoreExpiry
    buildSettingReportPlanningFailure :: Bool
buildSettingReportPlanningFailure
                              = Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag Flag Bool
projectConfigReportPlanningFailure
    buildSettingProgPathExtra :: [FilePath]
buildSettingProgPathExtra = NubList FilePath -> [FilePath]
forall a. NubList a -> [a]
fromNubList NubList FilePath
projectConfigProgPathExtra
    buildSettingHaddockOpen :: Bool
buildSettingHaddockOpen   = Bool
False

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

    defaults :: ProjectConfigBuildOnly
defaults = ProjectConfigBuildOnly
forall a. Monoid a => a
mempty {
      projectConfigDryRun :: Flag Bool
projectConfigDryRun                = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False,
      projectConfigOnlyDeps :: Flag Bool
projectConfigOnlyDeps              = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False,
      projectConfigOnlyDownload :: Flag Bool
projectConfigOnlyDownload          = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False,
      projectConfigBuildReports :: Flag ReportLevel
projectConfigBuildReports          = ReportLevel -> Flag ReportLevel
forall a. a -> Flag a
toFlag ReportLevel
NoReports,
      projectConfigReportPlanningFailure :: Flag Bool
projectConfigReportPlanningFailure = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False,
      projectConfigKeepGoing :: Flag Bool
projectConfigKeepGoing             = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False,
      projectConfigOfflineMode :: Flag Bool
projectConfigOfflineMode           = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False,
      projectConfigKeepTempFiles :: Flag Bool
projectConfigKeepTempFiles         = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False,
      projectConfigIgnoreExpiry :: Flag Bool
projectConfigIgnoreExpiry          = Bool -> Flag Bool
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 -> FilePath)
buildSettingLogFile
      | Bool
useDefaultTemplate = (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
-> Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
forall a. a -> Maybe a
Just (PathTemplate
-> Compiler -> Platform -> PackageId -> UnitId -> FilePath
substLogFileName PathTemplate
defaultTemplate)
      | Bool
otherwise          = (PathTemplate
 -> Compiler -> Platform -> PackageId -> UnitId -> FilePath)
-> Maybe PathTemplate
-> Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap  PathTemplate
-> Compiler -> Platform -> PackageId -> UnitId -> FilePath
substLogFileName Maybe PathTemplate
givenTemplate

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

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

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

    substLogFileName :: PathTemplate
                     -> Compiler -> Platform
                     -> PackageId -> UnitId -> FilePath
    substLogFileName :: PathTemplate
-> Compiler -> Platform -> PackageId -> UnitId -> FilePath
substLogFileName PathTemplate
template Compiler
compiler Platform
platform PackageId
pkgid UnitId
uid =
        PathTemplate -> FilePath
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 (Verbosity -> Verbosity -> Verbosity
forall a. Ord a => a -> a -> a
max Verbosity
verbose) Verbosity
verbosity
      | Bool
otherwise         = Verbosity
verbosity

    overrideVerbosity :: Bool
    overrideVerbosity :: Bool
overrideVerbosity
      | ReportLevel
buildSettingBuildReports ReportLevel -> ReportLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ReportLevel
DetailedReports = Bool
True
      | Maybe PathTemplate -> Bool
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 FilePath
-> Maybe FilePath -> IO (Either BadProjectRoot ProjectRoot)
findProjectRoot Maybe FilePath
_ (Just FilePath
projectFile)
  | FilePath -> Bool
isAbsolute FilePath
projectFile = do
    Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
projectFile
    if Bool
exists
      then do FilePath
projectFile' <- FilePath -> IO FilePath
canonicalizePath FilePath
projectFile
              let projectRoot :: ProjectRoot
projectRoot = FilePath -> FilePath -> ProjectRoot
ProjectRootExplicit (FilePath -> FilePath
takeDirectory FilePath
projectFile')
                                                    (FilePath -> FilePath
takeFileName FilePath
projectFile')
              Either BadProjectRoot ProjectRoot
-> IO (Either BadProjectRoot ProjectRoot)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectRoot -> Either BadProjectRoot ProjectRoot
forall a b. b -> Either a b
Right ProjectRoot
projectRoot)
      else Either BadProjectRoot ProjectRoot
-> IO (Either BadProjectRoot ProjectRoot)
forall (m :: * -> *) a. Monad m => a -> m a
return (BadProjectRoot -> Either BadProjectRoot ProjectRoot
forall a b. a -> Either a b
Left (FilePath -> BadProjectRoot
BadProjectRootExplicitFile FilePath
projectFile))

findProjectRoot Maybe FilePath
mstartdir Maybe FilePath
mprojectFile = do
    FilePath
startdir <- IO FilePath
-> (FilePath -> IO FilePath) -> Maybe FilePath -> IO FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO FilePath
getCurrentDirectory FilePath -> IO FilePath
canonicalizePath Maybe FilePath
mstartdir
    FilePath
homedir  <- IO FilePath
getHomeDirectory
    FilePath -> FilePath -> IO (Either BadProjectRoot ProjectRoot)
probe FilePath
startdir FilePath
homedir
  where
    projectFileName :: String
    projectFileName :: FilePath
projectFileName = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"cabal.project" Maybe FilePath
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 :: FilePath -> FilePath -> IO (Either BadProjectRoot ProjectRoot)
probe FilePath
startdir FilePath
homedir = FilePath -> IO (Either BadProjectRoot ProjectRoot)
go FilePath
startdir
      where
        go :: FilePath -> IO (Either BadProjectRoot ProjectRoot)
        go :: FilePath -> IO (Either BadProjectRoot ProjectRoot)
go FilePath
dir | FilePath -> Bool
isDrive FilePath
dir Bool -> Bool -> Bool
|| FilePath
dir FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
homedir =
          case Maybe FilePath
mprojectFile of
            Maybe FilePath
Nothing   -> Either BadProjectRoot ProjectRoot
-> IO (Either BadProjectRoot ProjectRoot)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectRoot -> Either BadProjectRoot ProjectRoot
forall a b. b -> Either a b
Right (FilePath -> ProjectRoot
ProjectRootImplicit FilePath
startdir))
            Just FilePath
file -> Either BadProjectRoot ProjectRoot
-> IO (Either BadProjectRoot ProjectRoot)
forall (m :: * -> *) a. Monad m => a -> m a
return (BadProjectRoot -> Either BadProjectRoot ProjectRoot
forall a b. a -> Either a b
Left (FilePath -> BadProjectRoot
BadProjectRootExplicitFile FilePath
file))
        go FilePath
dir = do
          Bool
exists <- FilePath -> IO Bool
doesFileExist (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
projectFileName)
          if Bool
exists
            then Either BadProjectRoot ProjectRoot
-> IO (Either BadProjectRoot ProjectRoot)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectRoot -> Either BadProjectRoot ProjectRoot
forall a b. b -> Either a b
Right (FilePath -> FilePath -> ProjectRoot
ProjectRootExplicit FilePath
dir FilePath
projectFileName))
            else FilePath -> IO (Either BadProjectRoot ProjectRoot)
go (FilePath -> FilePath
takeDirectory FilePath
dir)

-- | Errors returned by 'findProjectRoot'.
--
data BadProjectRoot = BadProjectRootExplicitFile FilePath
#if MIN_VERSION_base(4,8,0)
  deriving (Int -> BadProjectRoot -> FilePath -> FilePath
[BadProjectRoot] -> FilePath -> FilePath
BadProjectRoot -> FilePath
(Int -> BadProjectRoot -> FilePath -> FilePath)
-> (BadProjectRoot -> FilePath)
-> ([BadProjectRoot] -> FilePath -> FilePath)
-> Show BadProjectRoot
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [BadProjectRoot] -> FilePath -> FilePath
$cshowList :: [BadProjectRoot] -> FilePath -> FilePath
show :: BadProjectRoot -> FilePath
$cshow :: BadProjectRoot -> FilePath
showsPrec :: Int -> BadProjectRoot -> FilePath -> FilePath
$cshowsPrec :: Int -> BadProjectRoot -> FilePath -> FilePath
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 -> FilePath
displayException = BadProjectRoot -> FilePath
renderBadProjectRoot
#endif

renderBadProjectRoot :: BadProjectRoot -> String
renderBadProjectRoot :: BadProjectRoot -> FilePath
renderBadProjectRoot (BadProjectRootExplicitFile FilePath
projectFile) =
    FilePath
"The given project file '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
projectFile FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' 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 projet
    -> IO a
withProjectOrGlobalConfig :: Verbosity
-> Flag Bool
-> Flag FilePath
-> IO a
-> (ProjectConfig -> IO a)
-> IO a
withProjectOrGlobalConfig Verbosity
verbosity (Flag Bool
True) Flag FilePath
gcf IO a
_with ProjectConfig -> IO a
without = do
    ProjectConfig
globalConfig <- FilePath -> Rebuild ProjectConfig -> IO ProjectConfig
forall a. FilePath -> Rebuild a -> IO a
runRebuild FilePath
"" (Rebuild ProjectConfig -> IO ProjectConfig)
-> Rebuild ProjectConfig -> IO ProjectConfig
forall a b. (a -> b) -> a -> b
$ Verbosity -> Flag FilePath -> Rebuild ProjectConfig
readGlobalConfig Verbosity
verbosity Flag FilePath
gcf
    ProjectConfig -> IO a
without ProjectConfig
globalConfig
withProjectOrGlobalConfig Verbosity
verbosity Flag Bool
_ignorePrj  Flag FilePath
gcf  IO a
with ProjectConfig -> IO a
without =
    Verbosity
-> Flag FilePath -> IO a -> (ProjectConfig -> IO a) -> IO a
forall a.
Verbosity
-> Flag FilePath -> IO a -> (ProjectConfig -> IO a) -> IO a
withProjectOrGlobalConfig' Verbosity
verbosity Flag FilePath
gcf IO a
with ProjectConfig -> IO a
without

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

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

  IO a -> (BadProjectRoot -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
res'
    ((BadProjectRoot -> IO a) -> IO a)
-> (BadProjectRoot -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \case
      (BadProjectRootExplicitFile FilePath
"") -> ProjectConfig -> IO a
without ProjectConfig
globalConfig
      BadProjectRoot
err -> BadProjectRoot -> IO a
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 FilePath
-> DistDirLayout
-> Rebuild ProjectConfigSkeleton
readProjectConfig Verbosity
verbosity HttpTransport
httpTransport Flag Bool
ignoreProjectFlag Flag FilePath
configFileFlag DistDirLayout
distDirLayout = do
    ProjectConfigSkeleton
global <- ProjectConfig -> ProjectConfigSkeleton
singletonProjectConfigSkeleton (ProjectConfig -> ProjectConfigSkeleton)
-> Rebuild ProjectConfig -> Rebuild ProjectConfigSkeleton
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> Flag FilePath -> Rebuild ProjectConfig
readGlobalConfig Verbosity
verbosity Flag FilePath
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 Flag Bool -> Flag Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True then ProjectConfigSkeleton -> Rebuild ProjectConfigSkeleton
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectConfigSkeleton
global ProjectConfigSkeleton
-> ProjectConfigSkeleton -> ProjectConfigSkeleton
forall a. Semigroup a => a -> a -> a
<> (ProjectConfig -> ProjectConfigSkeleton
singletonProjectConfigSkeleton ProjectConfig
defaultProject))
    else ProjectConfigSkeleton -> Rebuild ProjectConfigSkeleton
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectConfigSkeleton
global ProjectConfigSkeleton
-> ProjectConfigSkeleton -> ProjectConfigSkeleton
forall a. Semigroup a => a -> a -> a
<> ProjectConfigSkeleton
local ProjectConfigSkeleton
-> ProjectConfigSkeleton -> ProjectConfigSkeleton
forall a. Semigroup a => a -> a -> a
<> ProjectConfigSkeleton
freeze ProjectConfigSkeleton
-> ProjectConfigSkeleton -> ProjectConfigSkeleton
forall a. Semigroup a => a -> a -> a
<> ProjectConfigSkeleton
extra)
    where
      defaultProject :: ProjectConfig
      defaultProject :: ProjectConfig
defaultProject = ProjectConfig
forall a. Monoid a => a
mempty {
        projectPackages :: [FilePath]
projectPackages = [FilePath
"./"]
      }

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

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

      projectConfigProvenance :: Set ProjectConfigProvenance
projectConfigProvenance = ProjectConfigProvenance -> Set 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
-> FilePath
-> FilePath
-> Rebuild ProjectConfigSkeleton
readProjectFileSkeleton Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout FilePath
"local"
                             FilePath
"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
-> FilePath
-> FilePath
-> Rebuild ProjectConfigSkeleton
readProjectFileSkeleton Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout FilePath
"freeze"
                             FilePath
"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
-> FilePath
-> FilePath
-> Rebuild ProjectConfigSkeleton
readProjectFileSkeleton Verbosity
verbosity HttpTransport
httpTransport DistDirLayout{FilePath -> FilePath
distProjectFile :: FilePath -> FilePath
distProjectFile :: DistDirLayout -> FilePath -> FilePath
distProjectFile, FilePath
distDownloadSrcDirectory :: DistDirLayout -> FilePath
distDownloadSrcDirectory :: FilePath
distDownloadSrcDirectory}
                         FilePath
extensionName FilePath
extensionDescription = do
    Bool
exists <- IO Bool -> Rebuild Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Rebuild Bool) -> IO Bool -> Rebuild Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
extensionFile
    if Bool
exists
      then do [MonitorFilePath] -> Rebuild ()
monitorFiles [FilePath -> MonitorFilePath
monitorFileHashed FilePath
extensionFile]
              ProjectConfigSkeleton
pcs <- IO ProjectConfigSkeleton -> Rebuild ProjectConfigSkeleton
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ProjectConfigSkeleton
readExtensionFile
              [MonitorFilePath] -> Rebuild ()
monitorFiles ([MonitorFilePath] -> Rebuild ())
-> [MonitorFilePath] -> Rebuild ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> MonitorFilePath) -> [FilePath] -> [MonitorFilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> MonitorFilePath
monitorFileHashed (ProjectConfigSkeleton -> [FilePath]
projectSkeletonImports ProjectConfigSkeleton
pcs)
              ProjectConfigSkeleton -> Rebuild ProjectConfigSkeleton
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectConfigSkeleton
pcs
      else do [MonitorFilePath] -> Rebuild ()
monitorFiles [FilePath -> MonitorFilePath
monitorNonExistentFile FilePath
extensionFile]
              ProjectConfigSkeleton -> Rebuild ProjectConfigSkeleton
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectConfigSkeleton
forall a. Monoid a => a
mempty
  where
    extensionFile :: FilePath
extensionFile = FilePath -> FilePath
distProjectFile FilePath
extensionName

    readExtensionFile :: IO ProjectConfigSkeleton
readExtensionFile =
          Verbosity
-> FilePath
-> FilePath
-> ParseResult ProjectConfigSkeleton
-> IO ProjectConfigSkeleton
reportParseResult Verbosity
verbosity FilePath
extensionDescription FilePath
extensionFile
      (ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton)
-> IO (ParseResult ProjectConfigSkeleton)
-> IO ProjectConfigSkeleton
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath
-> HttpTransport
-> Verbosity
-> [FilePath]
-> FilePath
-> ByteString
-> IO (ParseResult ProjectConfigSkeleton)
parseProjectSkeleton FilePath
distDownloadSrcDirectory HttpTransport
httpTransport Verbosity
verbosity [] FilePath
extensionFile
      (ByteString -> IO (ParseResult ProjectConfigSkeleton))
-> IO ByteString -> IO (ParseResult ProjectConfigSkeleton)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO ByteString
BS.readFile FilePath
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 -> FilePath
showProjectConfig =
    LegacyProjectConfig -> FilePath
showLegacyProjectConfig (LegacyProjectConfig -> FilePath)
-> (ProjectConfig -> LegacyProjectConfig)
-> ProjectConfig
-> FilePath
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{FilePath -> FilePath
distProjectFile :: FilePath -> FilePath
distProjectFile :: DistDirLayout -> FilePath -> FilePath
distProjectFile} =
    FilePath -> ProjectConfig -> IO ()
writeProjectConfigFile (FilePath -> FilePath
distProjectFile FilePath
"local")


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


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


-- | Read the user's @~/.cabal/config@ file.
--
readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig
readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig
readGlobalConfig Verbosity
verbosity Flag FilePath
configFileFlag = do
    SavedConfig
config     <- IO SavedConfig -> Rebuild SavedConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Verbosity -> Flag FilePath -> IO SavedConfig
loadConfig Verbosity
verbosity Flag FilePath
configFileFlag)
    FilePath
configFile <- IO FilePath -> Rebuild FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Flag FilePath -> IO FilePath
getConfigFilePath Flag FilePath
configFileFlag)
    [MonitorFilePath] -> Rebuild ()
monitorFiles [FilePath -> MonitorFilePath
monitorFileHashed FilePath
configFile]
    ProjectConfig -> Rebuild ProjectConfig
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
-> FilePath
-> FilePath
-> ParseResult ProjectConfigSkeleton
-> IO ProjectConfigSkeleton
reportParseResult Verbosity
verbosity FilePath
_filetype FilePath
filename (OldParser.ParseOk [PWarning]
warnings ProjectConfigSkeleton
x) = do
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PWarning] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warnings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      let msg :: FilePath
msg = [FilePath] -> FilePath
unlines ((PWarning -> FilePath) -> [PWarning] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> PWarning -> FilePath
OldParser.showPWarning (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
filename FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: ProjectConfigSkeleton -> [FilePath]
projectSkeletonImports ProjectConfigSkeleton
x)) [PWarning]
warnings)
       in Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity FilePath
msg
   ProjectConfigSkeleton -> IO ProjectConfigSkeleton
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectConfigSkeleton
x
reportParseResult Verbosity
verbosity FilePath
filetype FilePath
filename (OldParser.ParseFailed PError
err) =
    let (Maybe Int
line, FilePath
msg) = PError -> (Maybe Int, FilePath)
OldParser.locatedErrorMsg PError
err
     in Verbosity -> FilePath -> IO ProjectConfigSkeleton
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ProjectConfigSkeleton)
-> FilePath -> IO ProjectConfigSkeleton
forall a b. (a -> b) -> a -> b
$ FilePath
"Error parsing " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
filetype FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
filename
           FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> (Int -> FilePath) -> Maybe Int -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (\Int
n -> Char
':' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n) Maybe Int
line FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
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 -> FilePath -> FilePath
[ProjectPackageLocation] -> FilePath -> FilePath
ProjectPackageLocation -> FilePath
(Int -> ProjectPackageLocation -> FilePath -> FilePath)
-> (ProjectPackageLocation -> FilePath)
-> ([ProjectPackageLocation] -> FilePath -> FilePath)
-> Show ProjectPackageLocation
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [ProjectPackageLocation] -> FilePath -> FilePath
$cshowList :: [ProjectPackageLocation] -> FilePath -> FilePath
show :: ProjectPackageLocation -> FilePath
$cshow :: ProjectPackageLocation -> FilePath
showsPrec :: Int -> ProjectPackageLocation -> FilePath -> FilePath
$cshowsPrec :: Int -> ProjectPackageLocation -> FilePath -> FilePath
Show


-- | Exception thrown by 'findProjectPackages'.
--
data BadPackageLocations
   = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation]
#if MIN_VERSION_base(4,8,0)
  deriving (Int -> BadPackageLocations -> FilePath -> FilePath
[BadPackageLocations] -> FilePath -> FilePath
BadPackageLocations -> FilePath
(Int -> BadPackageLocations -> FilePath -> FilePath)
-> (BadPackageLocations -> FilePath)
-> ([BadPackageLocations] -> FilePath -> FilePath)
-> Show BadPackageLocations
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [BadPackageLocations] -> FilePath -> FilePath
$cshowList :: [BadPackageLocations] -> FilePath -> FilePath
show :: BadPackageLocations -> FilePath
$cshow :: BadPackageLocations -> FilePath
showsPrec :: Int -> BadPackageLocations -> FilePath -> FilePath
$cshowsPrec :: Int -> BadPackageLocations -> FilePath -> FilePath
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 -> FilePath
displayException = BadPackageLocations -> FilePath
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 -> FilePath -> FilePath
[BadPackageLocation] -> FilePath -> FilePath
BadPackageLocation -> FilePath
(Int -> BadPackageLocation -> FilePath -> FilePath)
-> (BadPackageLocation -> FilePath)
-> ([BadPackageLocation] -> FilePath -> FilePath)
-> Show BadPackageLocation
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [BadPackageLocation] -> FilePath -> FilePath
$cshowList :: [BadPackageLocation] -> FilePath -> FilePath
show :: BadPackageLocation -> FilePath
$cshow :: BadPackageLocation -> FilePath
showsPrec :: Int -> BadPackageLocation -> FilePath -> FilePath
$cshowsPrec :: Int -> BadPackageLocation -> FilePath -> FilePath
Show

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

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

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

      -- The configuration contains both implicit and explicit provenance.
      -- This should not occur, and a message is output to assist debugging.
    | ProjectConfigProvenance
Implicit ProjectConfigProvenance -> Set ProjectConfigProvenance -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ProjectConfigProvenance
provenance =
           FilePath
"Warning: both implicit and explicit configuration is present."
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
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 = FilePath
renderExplicit
  where
    renderErrors :: (BadPackageLocation -> FilePath) -> FilePath
renderErrors BadPackageLocation -> FilePath
f = [FilePath] -> FilePath
unlines ((BadPackageLocation -> FilePath)
-> [BadPackageLocation] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map BadPackageLocation -> FilePath
f [BadPackageLocation]
bpls)

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

    getExplicit :: ProjectConfigProvenance -> Maybe FilePath
getExplicit (Explicit FilePath
path) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
path
    getExplicit ProjectConfigProvenance
Implicit        = Maybe FilePath
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 -> FilePath
renderImplicitBadPackageLocation BadPackageLocation
bpl = case BadPackageLocation
bpl of
    BadLocGlobEmptyMatch FilePath
pkglocstr ->
        FilePath
"No cabal.project file or cabal file matching the default glob '"
     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pkglocstr FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' was found.\n"
     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Please create a package description file <pkgname>.cabal "
     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"or a cabal.project file referencing the packages you "
     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"want to build."
    BadPackageLocation
_ -> BadPackageLocation -> FilePath
renderBadPackageLocation BadPackageLocation
bpl

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

renderBadPackageLocationMatch :: BadPackageLocationMatch -> String
renderBadPackageLocationMatch :: BadPackageLocationMatch -> FilePath
renderBadPackageLocationMatch BadPackageLocationMatch
bplm = case BadPackageLocationMatch
bplm of
    BadLocUnexpectedFile FilePath
pkglocstr ->
        FilePath
"The package location '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pkglocstr FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' is not recognised. The "
     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"supported file targets are .cabal files, .tar.gz tarballs or package "
     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"directories (i.e. directories containing a .cabal file)."
    BadLocNonexistantFile FilePath
pkglocstr ->
        FilePath
"The package location '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pkglocstr FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' does not exist."
    BadLocDirNoCabalFile FilePath
pkglocstr ->
        FilePath
"The package directory '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pkglocstr FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' does not contain any "
     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".cabal file."
    BadLocDirManyCabalFiles FilePath
pkglocstr ->
        FilePath
"The package directory '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pkglocstr FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' contains multiple "
     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".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{FilePath
distProjectRootDirectory :: DistDirLayout -> FilePath
distProjectRootDirectory :: FilePath
distProjectRootDirectory}
                    ProjectConfig{[FilePath]
[PackageVersionConstraint]
[SourceRepoList]
Set ProjectConfigProvenance
MapMappend PackageName PackageConfig
PackageConfig
ProjectConfigShared
ProjectConfigBuildOnly
projectConfigAllPackages :: ProjectConfig -> PackageConfig
projectPackagesNamed :: ProjectConfig -> [PackageVersionConstraint]
projectPackagesRepo :: ProjectConfig -> [SourceRepoList]
projectPackagesOptional :: ProjectConfig -> [FilePath]
projectConfigSpecificPackage :: MapMappend PackageName PackageConfig
projectConfigLocalPackages :: PackageConfig
projectConfigAllPackages :: PackageConfig
projectConfigProvenance :: Set ProjectConfigProvenance
projectConfigShared :: ProjectConfigShared
projectConfigBuildOnly :: ProjectConfigBuildOnly
projectPackagesNamed :: [PackageVersionConstraint]
projectPackagesRepo :: [SourceRepoList]
projectPackagesOptional :: [FilePath]
projectPackages :: [FilePath]
projectConfigProvenance :: ProjectConfig -> Set ProjectConfigProvenance
projectPackages :: ProjectConfig -> [FilePath]
projectConfigBuildOnly :: ProjectConfig -> ProjectConfigBuildOnly
projectConfigShared :: ProjectConfig -> ProjectConfigShared
projectConfigSpecificPackage :: ProjectConfig -> MapMappend PackageName PackageConfig
projectConfigLocalPackages :: ProjectConfig -> PackageConfig
..} = do

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

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


    findPackageLocation :: Bool -> String
                        -> Rebuild (Either BadPackageLocation
                                          [ProjectPackageLocation])
    findPackageLocation :: Bool
-> FilePath
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
findPackageLocation _required :: Bool
_required@Bool
True FilePath
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
                    FilePath
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsUriPackage FilePath
pkglocstr
      Rebuild
  (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
`mplusMaybeT` FilePath
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsFileGlobPackage FilePath
pkglocstr
      Rebuild
  (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
`mplusMaybeT` FilePath
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsSingleFilePackage FilePath
pkglocstr
      Rebuild
  (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
-> (Maybe (Either BadPackageLocation [ProjectPackageLocation])
    -> Rebuild (Either BadPackageLocation [ProjectPackageLocation]))
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Rebuild (Either BadPackageLocation [ProjectPackageLocation])
-> (Either BadPackageLocation [ProjectPackageLocation]
    -> Rebuild (Either BadPackageLocation [ProjectPackageLocation]))
-> Maybe (Either BadPackageLocation [ProjectPackageLocation])
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either BadPackageLocation [ProjectPackageLocation]
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
forall (m :: * -> *) a. Monad m => a -> m a
return (BadPackageLocation
-> Either BadPackageLocation [ProjectPackageLocation]
forall a b. a -> Either a b
Left (FilePath -> BadPackageLocation
BadLocUnrecognised FilePath
pkglocstr))) Either BadPackageLocation [ProjectPackageLocation]
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
forall (m :: * -> *) a. Monad m => a -> m a
return


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


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

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

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

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

        Maybe URI
_ -> Maybe (Either BadPackageLocation [ProjectPackageLocation])
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either BadPackageLocation [ProjectPackageLocation])
forall a. Maybe a
Nothing


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

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

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


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


    checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch
                                                       ProjectPackageLocation)
    checkFilePackageMatch :: FilePath
-> Rebuild (Either BadPackageLocationMatch ProjectPackageLocation)
checkFilePackageMatch FilePath
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 :: FilePath
abspath = FilePath
distProjectRootDirectory FilePath -> FilePath -> FilePath
</> FilePath
pkglocstr
      Bool
isFile <- IO Bool -> Rebuild Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Rebuild Bool) -> IO Bool -> Rebuild Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
abspath
      Bool
isDir  <- IO Bool -> Rebuild Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Rebuild Bool) -> IO Bool -> Rebuild Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
abspath
      Bool
parentDirExists <- case FilePath -> FilePath
takeDirectory FilePath
abspath of
                           []  -> Bool -> Rebuild Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           FilePath
dir -> IO Bool -> Rebuild Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Rebuild Bool) -> IO Bool -> Rebuild Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
dir
      case () of
        ()
_ | Bool
isDir
         -> do [FilePath]
matches <- FilePathGlob -> Rebuild [FilePath]
matchFileGlob (FilePath -> FilePathGlob
globStarDotCabal FilePath
pkglocstr)
               case [FilePath]
matches of
                 [FilePath
cabalFile]
                     -> Either BadPackageLocationMatch ProjectPackageLocation
-> Rebuild (Either BadPackageLocationMatch ProjectPackageLocation)
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectPackageLocation
-> Either BadPackageLocationMatch ProjectPackageLocation
forall a b. b -> Either a b
Right (FilePath -> FilePath -> ProjectPackageLocation
ProjectPackageLocalDirectory
                                         FilePath
pkglocstr FilePath
cabalFile))
                 []  -> Either BadPackageLocationMatch ProjectPackageLocation
-> Rebuild (Either BadPackageLocationMatch ProjectPackageLocation)
forall (m :: * -> *) a. Monad m => a -> m a
return (BadPackageLocationMatch
-> Either BadPackageLocationMatch ProjectPackageLocation
forall a b. a -> Either a b
Left (FilePath -> BadPackageLocationMatch
BadLocDirNoCabalFile FilePath
pkglocstr))
                 [FilePath]
_   -> Either BadPackageLocationMatch ProjectPackageLocation
-> Rebuild (Either BadPackageLocationMatch ProjectPackageLocation)
forall (m :: * -> *) a. Monad m => a -> m a
return (BadPackageLocationMatch
-> Either BadPackageLocationMatch ProjectPackageLocation
forall a b. a -> Either a b
Left (FilePath -> BadPackageLocationMatch
BadLocDirManyCabalFiles FilePath
pkglocstr))

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

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

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

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

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


    extensionIsTarGz :: FilePath -> Bool
extensionIsTarGz FilePath
f = FilePath -> FilePath
takeExtension FilePath
f                 FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".gz"
                      Bool -> Bool -> Bool
&& FilePath -> FilePath
takeExtension (FilePath -> FilePath
dropExtension FilePath
f) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".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 :: FilePath -> FilePathGlob
globStarDotCabal FilePath
dir =
    FilePathRoot -> FilePathGlobRel -> FilePathGlob
FilePathGlob
      (if FilePath -> Bool
isAbsolute FilePath
dir then FilePath -> FilePathRoot
FilePathRoot FilePath
root else FilePathRoot
FilePathRelative)
      ((FilePath -> FilePathGlobRel -> FilePathGlobRel)
-> FilePathGlobRel -> [FilePath] -> FilePathGlobRel
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\FilePath
d -> Glob -> FilePathGlobRel -> FilePathGlobRel
GlobDir [FilePath -> GlobPiece
Literal FilePath
d])
             (Glob -> FilePathGlobRel
GlobFile [GlobPiece
WildCard, FilePath -> GlobPiece
Literal FilePath
".cabal"]) [FilePath]
dirComponents)
  where
    (FilePath
root, [FilePath]
dirComponents) = (FilePath -> [FilePath])
-> (FilePath, FilePath) -> (FilePath, [FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> [FilePath]
splitDirectories (FilePath -> (FilePath, FilePath)
splitDrive FilePath
dir)


--TODO: [code cleanup] use sufficiently recent transformers package
mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
mplusMaybeT :: 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  -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
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 <-
      [Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
        [ Verbosity
-> FilePath
-> FilePath
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readSourcePackageLocalDirectory Verbosity
verbosity FilePath
dir FilePath
cabalFile
        | ProjectPackageLocation
location <- [ProjectPackageLocation]
pkgLocations
        , (FilePath
dir, FilePath
cabalFile) <- ProjectPackageLocation -> [(FilePath, FilePath)]
projectPackageLocal ProjectPackageLocation
location ]

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

    [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgsRemoteTarball <- do
      Rebuild HttpTransport
getTransport <- IO HttpTransport -> Rebuild (Rebuild HttpTransport)
forall a. IO a -> Rebuild (Rebuild a)
delayInitSharedResource (IO HttpTransport -> Rebuild (Rebuild HttpTransport))
-> IO HttpTransport -> Rebuild (Rebuild HttpTransport)
forall a b. (a -> b) -> a -> b
$
                      Verbosity -> [FilePath] -> Maybe FilePath -> IO HttpTransport
configureTransport Verbosity
verbosity [FilePath]
progPathExtra
                                         Maybe FilePath
preferredHttpTransport
      [Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
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 =
          [ PackageName -> [PackageProperty] -> PackageSpecifier pkg
forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgname [VersionRange -> PackageProperty
PackagePropertyVersion VersionRange
verrange]
          | ProjectPackageNamed (PackageVersionConstraint PackageName
pkgname VersionRange
verrange) <- [ProjectPackageLocation]
pkgLocations ]

    [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
 -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)])
-> [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
forall a b. (a -> b) -> a -> b
$ [[PackageSpecifier (SourcePackage UnresolvedPkgLoc)]]
-> [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
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
      , [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
forall pkg. [PackageSpecifier pkg]
pkgsNamed
      ]
  where
    projectPackageLocal :: ProjectPackageLocation -> [(FilePath, FilePath)]
projectPackageLocal (ProjectPackageLocalDirectory FilePath
dir FilePath
file) = [(FilePath
dir, FilePath
file)]
    projectPackageLocal (ProjectPackageLocalCabalFile     FilePath
file) = [(FilePath
dir, FilePath
file)]
                                                where dir :: FilePath
dir = FilePath -> FilePath
takeDirectory FilePath
file
    projectPackageLocal ProjectPackageLocation
_ = []

    progPathExtra :: [FilePath]
progPathExtra = NubList FilePath -> [FilePath]
forall a. NubList a -> [a]
fromNubList (ProjectConfigShared -> NubList FilePath
projectConfigProgPathExtra ProjectConfigShared
projectConfigShared)
    preferredHttpTransport :: Maybe FilePath
preferredHttpTransport =
      Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (ProjectConfigBuildOnly -> Flag FilePath
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
-> FilePath
-> FilePath
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readSourcePackageLocalDirectory Verbosity
verbosity FilePath
dir FilePath
cabalFile = do
    [MonitorFilePath] -> Rebuild ()
monitorFiles [FilePath -> MonitorFilePath
monitorFileHashed FilePath
cabalFile]
    FilePath
root <- Rebuild FilePath
askRoot
    let location :: PackageLocation local
location = FilePath -> PackageLocation local
forall local. FilePath -> PackageLocation local
LocalUnpackedPackage (FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
dir)
    IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
 -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)))
-> IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall a b. (a -> b) -> a -> b
$ (GenericPackageDescription
 -> PackageSpecifier (SourcePackage UnresolvedPkgLoc))
-> IO GenericPackageDescription
-> IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PackageLocation FilePath
-> GenericPackageDescription
-> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage PackageLocation FilePath
forall local. PackageLocation local
location)
           (IO GenericPackageDescription
 -> IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc)))
-> (ByteString -> IO GenericPackageDescription)
-> ByteString
-> IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> FilePath -> ByteString -> IO GenericPackageDescription
readSourcePackageCabalFile Verbosity
verbosity FilePath
cabalFile
         (ByteString
 -> IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc)))
-> IO ByteString
-> IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO ByteString
BS.readFile (FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
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
-> FilePath
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readSourcePackageLocalTarball Verbosity
verbosity FilePath
tarballFile = do
    [MonitorFilePath] -> Rebuild ()
monitorFiles [FilePath -> MonitorFilePath
monitorFile FilePath
tarballFile]
    FilePath
root <- Rebuild FilePath
askRoot
    let location :: PackageLocation local
location = FilePath -> PackageLocation local
forall local. FilePath -> PackageLocation local
LocalTarballPackage (FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
tarballFile)
    IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
 -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)))
-> IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall a b. (a -> b) -> a -> b
$ (GenericPackageDescription
 -> PackageSpecifier (SourcePackage UnresolvedPkgLoc))
-> IO GenericPackageDescription
-> IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PackageLocation FilePath
-> GenericPackageDescription
-> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage PackageLocation FilePath
forall local. PackageLocation local
location)
           (IO GenericPackageDescription
 -> IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc)))
-> ((FilePath, ByteString) -> IO GenericPackageDescription)
-> (FilePath, ByteString)
-> IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> ByteString -> IO GenericPackageDescription)
-> (FilePath, ByteString) -> IO GenericPackageDescription
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Verbosity -> FilePath -> ByteString -> IO GenericPackageDescription
readSourcePackageCabalFile Verbosity
verbosity)
         ((FilePath, ByteString)
 -> IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc)))
-> IO (FilePath, ByteString)
-> IO (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO (FilePath, ByteString)
extractTarballPackageCabalFile (FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
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 {
                                         FilePath
distDownloadSrcDirectory :: FilePath
distDownloadSrcDirectory :: DistDirLayout -> FilePath
distDownloadSrcDirectory
                                       }
                                       Rebuild HttpTransport
getTransport
                                       URI
tarballUri =
    -- The tarball download is expensive so we use another layer of file
    -- monitor to avoid it whenever possible.
    Verbosity
-> FileMonitor
     URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
-> URI
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
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 (Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
 -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)))
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall a b. (a -> b) -> a -> b
$ do

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

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

    monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
    monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
monitor = FilePath
-> FileMonitor
     URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall a b. Eq a => FilePath -> FileMonitor a b
newFileMonitor (FilePath
tarballStem FilePath -> FilePath -> FilePath
<.> FilePath
"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{FilePath
distDownloadSrcDirectory :: FilePath
distDownloadSrcDirectory :: DistDirLayout -> FilePath
distDownloadSrcDirectory}
                                     ProjectConfigShared {
                                       NubList FilePath
projectConfigProgPathExtra :: NubList FilePath
projectConfigProgPathExtra :: ProjectConfigShared -> NubList FilePath
projectConfigProgPathExtra
                                     }
                                    [SourceRepoList]
repos = do

    [(SourceRepoList, FilePath, RepoType, VCS Program)]
repos' <- ([(SourceRepoList, SourceRepoProblem)]
 -> Rebuild [(SourceRepoList, FilePath, RepoType, VCS Program)])
-> ([(SourceRepoList, FilePath, RepoType, VCS Program)]
    -> Rebuild [(SourceRepoList, FilePath, RepoType, VCS Program)])
-> Either
     [(SourceRepoList, SourceRepoProblem)]
     [(SourceRepoList, FilePath, RepoType, VCS Program)]
-> Rebuild [(SourceRepoList, FilePath, RepoType, VCS Program)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [(SourceRepoList, SourceRepoProblem)]
-> Rebuild [(SourceRepoList, FilePath, RepoType, VCS Program)]
forall a. [(SourceRepoList, SourceRepoProblem)] -> Rebuild a
reportSourceRepoProblems [(SourceRepoList, FilePath, RepoType, VCS Program)]
-> Rebuild [(SourceRepoList, FilePath, RepoType, VCS Program)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   [(SourceRepoList, SourceRepoProblem)]
   [(SourceRepoList, FilePath, RepoType, VCS Program)]
 -> Rebuild [(SourceRepoList, FilePath, RepoType, VCS Program)])
-> Either
     [(SourceRepoList, SourceRepoProblem)]
     [(SourceRepoList, FilePath, RepoType, VCS Program)]
-> Rebuild [(SourceRepoList, FilePath, RepoType, VCS Program)]
forall a b. (a -> b) -> a -> b
$
              [SourceRepoList]
-> Either
     [(SourceRepoList, SourceRepoProblem)]
     [(SourceRepoList, FilePath, RepoType, VCS Program)]
forall (f :: * -> *).
[SourceRepositoryPackage f]
-> Either
     [(SourceRepositoryPackage f, SourceRepoProblem)]
     [(SourceRepositoryPackage f, FilePath, 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, FilePath) [(SourceRepoList, RepoType)]
reposByLocation = ([(SourceRepoList, RepoType)]
 -> [(SourceRepoList, RepoType)] -> [(SourceRepoList, RepoType)])
-> [((RepoType, FilePath), [(SourceRepoList, RepoType)])]
-> Map (RepoType, FilePath) [(SourceRepoList, RepoType)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [(SourceRepoList, RepoType)]
-> [(SourceRepoList, RepoType)] -> [(SourceRepoList, RepoType)]
forall a. [a] -> [a] -> [a]
(++)
                            [ ((RepoType
rtype, FilePath
rloc), [(SourceRepoList
repo, VCS Program -> RepoType
forall program. VCS program -> RepoType
vcsRepoType VCS Program
vcs)])
                            | (SourceRepoList
repo, FilePath
rloc, RepoType
rtype, VCS Program
vcs) <- [(SourceRepoList, FilePath, RepoType, VCS Program)]
repos' ]

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

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

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

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

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

        mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)]
        mapGroup :: [(k, v)] -> [(k, NonEmpty v)]
mapGroup = Map k (NonEmpty v) -> [(k, NonEmpty v)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map k (NonEmpty v) -> [(k, NonEmpty v)])
-> ([(k, v)] -> Map k (NonEmpty v))
-> [(k, v)]
-> [(k, NonEmpty v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty v -> NonEmpty v -> NonEmpty v)
-> [(k, NonEmpty v)] -> Map k (NonEmpty v)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith NonEmpty v -> NonEmpty v -> NonEmpty v
forall a. Semigroup a => a -> a -> a
(<>) ([(k, NonEmpty v)] -> Map k (NonEmpty v))
-> ([(k, v)] -> [(k, NonEmpty v)])
-> [(k, v)]
-> Map k (NonEmpty v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> (k, NonEmpty v)) -> [(k, v)] -> [(k, NonEmpty v)]
forall a b. (a -> b) -> [a] -> [b]
map (\(k
k, v
v) -> (k
k, v -> NonEmpty v
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 :: [FilePath]
repoPaths = FilePath
pathStem
                  FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [ FilePath
pathStem FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (Int
i :: Int) | Int
i <- [Int
2..] ]

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

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

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

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

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

    renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String
    renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> FilePath
renderSourceRepoProblems = [FilePath] -> FilePath
unlines ([FilePath] -> FilePath)
-> ([(SourceRepoList, SourceRepoProblem)] -> [FilePath])
-> [(SourceRepoList, SourceRepoProblem)]
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SourceRepoList, SourceRepoProblem) -> FilePath)
-> [(SourceRepoList, SourceRepoProblem)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (SourceRepoList, SourceRepoProblem) -> FilePath
forall a. Show a => a -> FilePath
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 FilePath
-> GenericPackageDescription
-> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage PackageLocation FilePath
location GenericPackageDescription
pkg =
    SourcePackage UnresolvedPkgLoc
-> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage SourcePackage :: forall loc.
PackageId
-> GenericPackageDescription
-> loc
-> PackageDescriptionOverride
-> SourcePackage loc
SourcePackage
      { srcpkgPackageId :: PackageId
srcpkgPackageId     = GenericPackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
pkg
      , srcpkgDescription :: GenericPackageDescription
srcpkgDescription   = GenericPackageDescription
pkg
      , srcpkgSource :: UnresolvedPkgLoc
srcpkgSource        = (FilePath -> Maybe FilePath)
-> PackageLocation FilePath -> UnresolvedPkgLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just PackageLocation FilePath
location
      , srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgDescrOverride = PackageDescriptionOverride
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 -> FilePath -> FilePath
showsPrec Int
d (CabalFileParseError FilePath
fp ByteString
_ NonEmpty PError
es Maybe Version
mv [PWarning]
ws) = Bool -> (FilePath -> FilePath) -> FilePath -> FilePath
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
        ((FilePath -> FilePath) -> FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
showString FilePath
"CabalFileParseError"
        (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> FilePath -> FilePath
showChar Char
' ' (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> FilePath -> FilePath
forall a. Show a => Int -> a -> FilePath -> FilePath
showsPrec Int
11 FilePath
fp
        (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> FilePath -> FilePath
showChar Char
' ' (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> FilePath -> FilePath
forall a. Show a => Int -> a -> FilePath -> FilePath
showsPrec Int
11 (FilePath
"" :: String)
        (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> FilePath -> FilePath
showChar Char
' ' (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> NonEmpty PError -> FilePath -> FilePath
forall a. Show a => Int -> a -> FilePath -> FilePath
showsPrec Int
11 NonEmpty PError
es
        (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> FilePath -> FilePath
showChar Char
' ' (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Version -> FilePath -> FilePath
forall a. Show a => Int -> a -> FilePath -> FilePath
showsPrec Int
11 Maybe Version
mv
        (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> FilePath -> FilePath
showChar Char
' ' (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [PWarning] -> FilePath -> FilePath
forall a. Show a => Int -> a -> FilePath -> FilePath
showsPrec Int
11 [PWarning]
ws

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

renderCabalFileParseError :: CabalFileParseError -> String
renderCabalFileParseError :: CabalFileParseError -> FilePath
renderCabalFileParseError (CabalFileParseError FilePath
filePath ByteString
contents NonEmpty PError
errors Maybe Version
_ [PWarning]
warnings) =
    FilePath -> ByteString -> NonEmpty PError -> [PWarning] -> FilePath
renderParseError FilePath
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 -> FilePath -> ByteString -> IO GenericPackageDescription
readSourcePackageCabalFile Verbosity
verbosity FilePath
pkgfilename ByteString
content =
    case ParseResult GenericPackageDescription
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
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
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PWarning] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warnings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> FilePath -> IO ()
info Verbosity
verbosity ([PWarning] -> FilePath
formatWarnings [PWarning]
warnings)
        GenericPackageDescription -> IO GenericPackageDescription
forall (m :: * -> *) a. Monad m => a -> m a
return GenericPackageDescription
pkg

      ([PWarning]
warnings, Left (Maybe Version
mspecVersion, NonEmpty PError
errors)) ->
        CabalFileParseError -> IO GenericPackageDescription
forall e a. Exception e => e -> IO a
throwIO (CabalFileParseError -> IO GenericPackageDescription)
-> CabalFileParseError -> IO GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ FilePath
-> ByteString
-> NonEmpty PError
-> Maybe Version
-> [PWarning]
-> CabalFileParseError
CabalFileParseError FilePath
pkgfilename ByteString
content NonEmpty PError
errors Maybe Version
mspecVersion [PWarning]
warnings
  where
    formatWarnings :: [PWarning] -> FilePath
formatWarnings [PWarning]
warnings =
        FilePath
"The package description file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pkgfilename
     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" has warnings: "
     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unlines ((PWarning -> FilePath) -> [PWarning] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> PWarning -> FilePath
showPWarning FilePath
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 -> FilePath -> FilePath
[CabalFileSearchFailure] -> FilePath -> FilePath
CabalFileSearchFailure -> FilePath
(Int -> CabalFileSearchFailure -> FilePath -> FilePath)
-> (CabalFileSearchFailure -> FilePath)
-> ([CabalFileSearchFailure] -> FilePath -> FilePath)
-> Show CabalFileSearchFailure
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [CabalFileSearchFailure] -> FilePath -> FilePath
$cshowList :: [CabalFileSearchFailure] -> FilePath -> FilePath
show :: CabalFileSearchFailure -> FilePath
$cshow :: CabalFileSearchFailure -> FilePath
showsPrec :: Int -> CabalFileSearchFailure -> FilePath -> FilePath
$cshowsPrec :: Int -> CabalFileSearchFailure -> FilePath -> FilePath
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 :: FilePath -> IO (FilePath, ByteString)
extractTarballPackageCabalFile FilePath
tarballFile =
    FilePath
-> IOMode
-> (Handle -> IO (FilePath, ByteString))
-> IO (FilePath, ByteString)
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
tarballFile IOMode
ReadMode ((Handle -> IO (FilePath, ByteString))
 -> IO (FilePath, ByteString))
-> (Handle -> IO (FilePath, ByteString))
-> IO (FilePath, ByteString)
forall a b. (a -> b) -> a -> b
$ \Handle
hnd -> do
      ByteString
content <- Handle -> IO ByteString
LBS.hGetContents Handle
hnd
      case FilePath
-> ByteString
-> Either
     (Either FormatError CabalFileSearchFailure) (FilePath, ByteString)
extractTarballPackageCabalFilePure FilePath
tarballFile ByteString
content of
        Left (Left  FormatError
e) -> FormatError -> IO (FilePath, ByteString)
forall e a. Exception e => e -> IO a
throwIO FormatError
e
        Left (Right CabalFileSearchFailure
e) -> CabalFileSearchFailure -> IO (FilePath, ByteString)
forall e a. Exception e => e -> IO a
throwIO CabalFileSearchFailure
e
        Right (FilePath
fileName, ByteString
fileContent) ->
          (,) FilePath
fileName (ByteString -> (FilePath, ByteString))
-> IO ByteString -> IO (FilePath, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO ByteString
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 :: FilePath
-> ByteString
-> Either
     (Either FormatError CabalFileSearchFailure) (FilePath, ByteString)
extractTarballPackageCabalFilePure FilePath
tarballFile =
      Either (FormatError, Map TarPath Entry) (Map TarPath Entry)
-> Either
     (Either FormatError CabalFileSearchFailure) (FilePath, ByteString)
forall a b k.
Either (a, b) (Map k Entry)
-> Either (Either a CabalFileSearchFailure) (FilePath, ByteString)
check
    (Either (FormatError, Map TarPath Entry) (Map TarPath Entry)
 -> Either
      (Either FormatError CabalFileSearchFailure) (FilePath, ByteString))
-> (ByteString
    -> Either (FormatError, Map TarPath Entry) (Map TarPath Entry))
-> ByteString
-> Either
     (Either FormatError CabalFileSearchFailure) (FilePath, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entries FormatError
-> Either (FormatError, Map TarPath Entry) (Map TarPath Entry)
forall e.
Entries e -> Either (e, Map TarPath Entry) (Map TarPath Entry)
accumEntryMap
    (Entries FormatError
 -> Either (FormatError, Map TarPath Entry) (Map TarPath Entry))
-> (ByteString -> Entries FormatError)
-> ByteString
-> Either (FormatError, Map TarPath Entry) (Map TarPath Entry)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entry -> Bool) -> Entries FormatError -> Entries FormatError
forall e. (Entry -> Bool) -> Entries e -> Entries e
Tar.filterEntries Entry -> Bool
isCabalFile
    (Entries FormatError -> Entries FormatError)
-> (ByteString -> Entries FormatError)
-> ByteString
-> Entries FormatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read
    (ByteString -> Entries FormatError)
-> (ByteString -> ByteString) -> ByteString -> Entries FormatError
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 = (Map TarPath Entry -> Entry -> Map TarPath Entry)
-> Map TarPath Entry
-> Entries e
-> Either (e, Map TarPath Entry) (Map TarPath Entry)
forall a e. (a -> Entry -> a) -> a -> Entries e -> Either (e, a) a
Tar.foldlEntries
                      (\Map TarPath Entry
m Entry
e -> TarPath -> Entry -> Map TarPath Entry -> Map TarPath Entry
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)
                      Map TarPath Entry
forall k a. Map k a
Map.empty

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

    isCabalFile :: Entry -> Bool
isCabalFile Entry
e = case FilePath -> [FilePath]
splitPath (Entry -> FilePath
Tar.entryPath Entry
e) of
      [     FilePath
_dir, FilePath
file] -> FilePath -> FilePath
takeExtension FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal"
      [FilePath
".", FilePath
_dir, FilePath
file] -> FilePath -> FilePath
takeExtension FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal"
      [FilePath]
_                 -> 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 -> FilePath
localFileNameForRemoteTarball URI
uri =
    URI -> FilePath
mangleName URI
uri
 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++  Word -> FilePath -> FilePath
forall a. (Integral a, Show a) => a -> FilePath -> FilePath
showHex Word
locationHash FilePath
""
  where
    mangleName :: URI -> FilePath
mangleName = Int -> FilePath -> FilePath
truncateString Int
10 (FilePath -> FilePath) -> (URI -> FilePath) -> URI -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
dropExtension (FilePath -> FilePath) -> (URI -> FilePath) -> URI -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
dropExtension
               (FilePath -> FilePath) -> (URI -> FilePath) -> URI -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeFileName (FilePath -> FilePath) -> (URI -> FilePath) -> URI -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
dropTrailingPathSeparator (FilePath -> FilePath) -> (URI -> FilePath) -> URI -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> FilePath
uriPath

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


-- | 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 -> FilePath
localFileNameForRemoteRepo SourceRepositoryPackage {RepoType
srpType :: forall (f :: * -> *). SourceRepositoryPackage f -> RepoType
srpType :: RepoType
srpType, FilePath
srpLocation :: forall (f :: * -> *). SourceRepositoryPackage f -> FilePath
srpLocation :: FilePath
srpLocation} =
    FilePath -> FilePath
mangleName FilePath
srpLocation FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Word -> FilePath -> FilePath
forall a. (Integral a, Show a) => a -> FilePath -> FilePath
showHex Word
locationHash FilePath
""
  where
    mangleName :: FilePath -> FilePath
mangleName = Int -> FilePath -> FilePath
truncateString Int
10 (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
dropExtension
               (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeFileName (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
dropTrailingPathSeparator

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


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


-- 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 -> FilePath -> FilePath
[BadPerPackageCompilerPaths] -> FilePath -> FilePath
BadPerPackageCompilerPaths -> FilePath
(Int -> BadPerPackageCompilerPaths -> FilePath -> FilePath)
-> (BadPerPackageCompilerPaths -> FilePath)
-> ([BadPerPackageCompilerPaths] -> FilePath -> FilePath)
-> Show BadPerPackageCompilerPaths
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [BadPerPackageCompilerPaths] -> FilePath -> FilePath
$cshowList :: [BadPerPackageCompilerPaths] -> FilePath -> FilePath
show :: BadPerPackageCompilerPaths -> FilePath
$cshow :: BadPerPackageCompilerPaths -> FilePath
showsPrec :: Int -> BadPerPackageCompilerPaths -> FilePath -> FilePath
$cshowsPrec :: Int -> BadPerPackageCompilerPaths -> FilePath -> FilePath
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 -> FilePath
displayException = BadPerPackageCompilerPaths -> FilePath
renderBadPerPackageCompilerPaths
#endif
--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc

renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String
renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> FilePath
renderBadPerPackageCompilerPaths
  (BadPerPackageCompilerPaths ((PackageName
pkgname, FilePath
progname) : [(PackageName, FilePath)]
_)) =
    FilePath
"The path to the compiler program (or programs used by the compiler) "
 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"cannot be specified on a per-package basis in the cabal.project file "
 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"(i.e. setting the '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
progname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-location' for package '"
 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageName
pkgname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'). All packages have to use the same compiler, so "
 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"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
_ = FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error FilePath
"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, FilePath
progname)
         | let compProgNames :: Set FilePath
compProgNames = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList ((ConfiguredProgram -> FilePath)
-> [ConfiguredProgram] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ConfiguredProgram -> FilePath
programId [ConfiguredProgram]
compilerPrograms)
         ,  (PackageName
pkgname, PackageConfig
pkgconf) <- Map PackageName PackageConfig -> [(PackageName, PackageConfig)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName PackageConfig
packagesConfig
         , FilePath
progname <- Map FilePath FilePath -> [FilePath]
forall k a. Map k a -> [k]
Map.keys (MapLast FilePath FilePath -> Map FilePath FilePath
forall k v. MapLast k v -> Map k v
getMapLast (PackageConfig -> MapLast FilePath FilePath
packageConfigProgramPaths PackageConfig
pkgconf))
         , FilePath
progname FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
compProgNames ] of
      [] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [(PackageName, FilePath)]
ps -> BadPerPackageCompilerPaths -> IO ()
forall e a. Exception e => e -> IO a
throwIO ([(PackageName, FilePath)] -> BadPerPackageCompilerPaths
BadPerPackageCompilerPaths [(PackageName, FilePath)]
ps)