{-# 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,
    withGlobalConfig,
    withProjectOrGlobalConfig,
    writeProjectLocalExtraConfig,
    writeProjectLocalFreezeConfig,
    writeProjectConfigFile,
    commandLineFlagsToProjectConfig,

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

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

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

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

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

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

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

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

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

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

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


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

-- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific
-- 'PackageName'. This returns the configuration that applies to all local
-- packages plus any package-specific configuration for this package.
--
lookupLocalPackageConfig
  :: (Semigroup a, Monoid a)
  => (PackageConfig -> a) -> ProjectConfig -> PackageName
  -> a
lookupLocalPackageConfig :: forall a.
(Semigroup a, Monoid a) =>
(PackageConfig -> a) -> ProjectConfig -> PackageName -> a
lookupLocalPackageConfig PackageConfig -> a
field ProjectConfig {
                           PackageConfig
projectConfigLocalPackages :: PackageConfig
projectConfigLocalPackages :: ProjectConfig -> PackageConfig
projectConfigLocalPackages,
                           MapMappend PackageName PackageConfig
projectConfigSpecificPackage :: MapMappend PackageName PackageConfig
projectConfigSpecificPackage :: ProjectConfig -> 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 :: forall a.
Verbosity -> BuildTimeSettings -> (RepoContext -> IO a) -> IO a
projectConfigWithBuilderRepoContext Verbosity
verbosity BuildTimeSettings{Bool
Int
String
[String]
[PathTemplate]
[LocalRepo]
[RemoteRepo]
Maybe String
Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
Verbosity
ReportLevel
buildSettingDryRun :: Bool
buildSettingOnlyDeps :: Bool
buildSettingOnlyDownload :: Bool
buildSettingSummaryFile :: [PathTemplate]
buildSettingLogFile :: Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
buildSettingLogVerbosity :: Verbosity
buildSettingBuildReports :: ReportLevel
buildSettingReportPlanningFailure :: Bool
buildSettingSymlinkBinDir :: [String]
buildSettingNumJobs :: Int
buildSettingKeepGoing :: Bool
buildSettingOfflineMode :: Bool
buildSettingKeepTempFiles :: Bool
buildSettingRemoteRepos :: [RemoteRepo]
buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingCacheDir :: String
buildSettingHttpTransport :: Maybe String
buildSettingIgnoreExpiry :: Bool
buildSettingProgPathExtra :: [String]
buildSettingHaddockOpen :: Bool
buildSettingHaddockOpen :: BuildTimeSettings -> Bool
buildSettingProgPathExtra :: BuildTimeSettings -> [String]
buildSettingIgnoreExpiry :: BuildTimeSettings -> Bool
buildSettingHttpTransport :: BuildTimeSettings -> Maybe String
buildSettingCacheDir :: BuildTimeSettings -> String
buildSettingLocalNoIndexRepos :: BuildTimeSettings -> [LocalRepo]
buildSettingRemoteRepos :: BuildTimeSettings -> [RemoteRepo]
buildSettingKeepTempFiles :: BuildTimeSettings -> Bool
buildSettingOfflineMode :: BuildTimeSettings -> Bool
buildSettingKeepGoing :: BuildTimeSettings -> Bool
buildSettingNumJobs :: BuildTimeSettings -> Int
buildSettingSymlinkBinDir :: BuildTimeSettings -> [String]
buildSettingReportPlanningFailure :: BuildTimeSettings -> Bool
buildSettingBuildReports :: BuildTimeSettings -> ReportLevel
buildSettingLogVerbosity :: BuildTimeSettings -> Verbosity
buildSettingLogFile :: BuildTimeSettings
-> Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
buildSettingSummaryFile :: BuildTimeSettings -> [PathTemplate]
buildSettingOnlyDownload :: BuildTimeSettings -> Bool
buildSettingOnlyDeps :: BuildTimeSettings -> Bool
buildSettingDryRun :: BuildTimeSettings -> Bool
..} =
    Verbosity
-> [RemoteRepo]
-> [LocalRepo]
-> String
-> Maybe String
-> Maybe Bool
-> [String]
-> (RepoContext -> IO a)
-> IO a
forall a.
Verbosity
-> [RemoteRepo]
-> [LocalRepo]
-> String
-> Maybe String
-> Maybe Bool
-> [String]
-> (RepoContext -> IO a)
-> IO a
withRepoContext'
      Verbosity
verbosity
      [RemoteRepo]
buildSettingRemoteRepos
      [LocalRepo]
buildSettingLocalNoIndexRepos
      String
buildSettingCacheDir
      Maybe String
buildSettingHttpTransport
      (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
buildSettingIgnoreExpiry)
      [String]
buildSettingProgPathExtra


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


-- | Resolve the project configuration, with all its optional fields, into
-- 'SolverSettings' with no optional fields (by applying defaults).
--
resolveSolverSettings :: ProjectConfig -> SolverSettings
resolveSolverSettings :: ProjectConfig -> SolverSettings
resolveSolverSettings ProjectConfig{
                        ProjectConfigShared
projectConfigShared :: ProjectConfigShared
projectConfigShared :: ProjectConfig -> ProjectConfigShared
projectConfigShared,
                        PackageConfig
projectConfigLocalPackages :: ProjectConfig -> PackageConfig
projectConfigLocalPackages :: PackageConfig
projectConfigLocalPackages,
                        MapMappend PackageName PackageConfig
projectConfigSpecificPackage :: ProjectConfig -> MapMappend PackageName PackageConfig
projectConfigSpecificPackage :: MapMappend PackageName PackageConfig
projectConfigSpecificPackage
                      } =
    SolverSettings {[(UserConstraint, ConstraintSource)]
[PackageVersionConstraint]
[LocalRepo]
[RemoteRepo]
Maybe Int
Maybe Version
Maybe TotalIndexState
Maybe ActiveRepos
Map PackageName FlagAssignment
OnlyConstrained
AllowBootLibInstalls
StrongFlags
PreferOldest
IndependentGoals
MinimizeConflictSet
FineGrainedConflicts
CountConflicts
ReorderGoals
FlagAssignment
PreSolver
AllowOlder
AllowNewer
solverSettingRemoteRepos :: [RemoteRepo]
solverSettingLocalNoIndexRepos :: [LocalRepo]
solverSettingConstraints :: [(UserConstraint, ConstraintSource)]
solverSettingPreferences :: [PackageVersionConstraint]
solverSettingFlagAssignment :: FlagAssignment
solverSettingFlagAssignments :: Map PackageName FlagAssignment
solverSettingCabalVersion :: Maybe Version
solverSettingSolver :: PreSolver
solverSettingAllowOlder :: AllowOlder
solverSettingAllowNewer :: AllowNewer
solverSettingMaxBackjumps :: Maybe Int
solverSettingReorderGoals :: ReorderGoals
solverSettingCountConflicts :: CountConflicts
solverSettingFineGrainedConflicts :: FineGrainedConflicts
solverSettingMinimizeConflictSet :: MinimizeConflictSet
solverSettingStrongFlags :: StrongFlags
solverSettingAllowBootLibInstalls :: AllowBootLibInstalls
solverSettingOnlyConstrained :: OnlyConstrained
solverSettingIndexState :: Maybe TotalIndexState
solverSettingActiveRepos :: Maybe ActiveRepos
solverSettingIndependentGoals :: IndependentGoals
solverSettingPreferOldest :: PreferOldest
solverSettingPreferOldest :: PreferOldest
solverSettingIndependentGoals :: IndependentGoals
solverSettingActiveRepos :: Maybe ActiveRepos
solverSettingIndexState :: Maybe TotalIndexState
solverSettingOnlyConstrained :: OnlyConstrained
solverSettingAllowBootLibInstalls :: AllowBootLibInstalls
solverSettingStrongFlags :: StrongFlags
solverSettingMinimizeConflictSet :: MinimizeConflictSet
solverSettingFineGrainedConflicts :: FineGrainedConflicts
solverSettingCountConflicts :: CountConflicts
solverSettingReorderGoals :: ReorderGoals
solverSettingMaxBackjumps :: Maybe Int
solverSettingAllowNewer :: AllowNewer
solverSettingAllowOlder :: AllowOlder
solverSettingSolver :: PreSolver
solverSettingCabalVersion :: Maybe Version
solverSettingFlagAssignments :: Map PackageName FlagAssignment
solverSettingFlagAssignment :: FlagAssignment
solverSettingPreferences :: [PackageVersionConstraint]
solverSettingConstraints :: [(UserConstraint, ConstraintSource)]
solverSettingLocalNoIndexRepos :: [LocalRepo]
solverSettingRemoteRepos :: [RemoteRepo]
..}
  where
    --TODO: [required eventually] some of these settings need validation, e.g.
    -- the flag assignments need checking.
    solverSettingRemoteRepos :: [RemoteRepo]
solverSettingRemoteRepos       = 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 a b. (a -> b) -> Map PackageName a -> Map PackageName b
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
    solverSettingPreferOldest :: PreferOldest
solverSettingPreferOldest      = Flag PreferOldest -> PreferOldest
forall a. WithCallStack (Flag a -> a)
fromFlag Flag PreferOldest
projectConfigPreferOldest
  --solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs
  --solverSettingReinstall         = fromFlag projectConfigReinstall
  --solverSettingAvoidReinstalls   = fromFlag projectConfigAvoidReinstalls
  --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall
  --solverSettingUpgradeDeps       = fromFlag projectConfigUpgradeDeps

    ProjectConfigShared {[Maybe PackageDB]
[(UserConstraint, ConstraintSource)]
[PackageVersionConstraint]
Maybe AllowOlder
Maybe AllowNewer
Flag Bool
Flag Int
Flag String
Flag OnlyConstrained
Flag AllowBootLibInstalls
Flag StrongFlags
Flag PreferOldest
Flag IndependentGoals
Flag MinimizeConflictSet
Flag FineGrainedConflicts
Flag CountConflicts
Flag ReorderGoals
Flag CompilerFlavor
Flag Version
Flag PreSolver
Flag PathTemplate
Flag TotalIndexState
Flag ActiveRepos
Flag WriteGhcEnvironmentFilesPolicy
NubList String
NubList LocalRepo
NubList RemoteRepo
InstallDirs (Flag PathTemplate)
projectConfigProgPathExtra :: ProjectConfigShared -> NubList String
projectConfigPreferOldest :: ProjectConfigShared -> Flag PreferOldest
projectConfigIndependentGoals :: ProjectConfigShared -> Flag IndependentGoals
projectConfigPerComponent :: ProjectConfigShared -> Flag Bool
projectConfigOnlyConstrained :: ProjectConfigShared -> Flag OnlyConstrained
projectConfigAllowBootLibInstalls :: ProjectConfigShared -> Flag AllowBootLibInstalls
projectConfigStrongFlags :: ProjectConfigShared -> Flag StrongFlags
projectConfigMinimizeConflictSet :: ProjectConfigShared -> Flag MinimizeConflictSet
projectConfigFineGrainedConflicts :: ProjectConfigShared -> Flag FineGrainedConflicts
projectConfigCountConflicts :: ProjectConfigShared -> Flag CountConflicts
projectConfigReorderGoals :: ProjectConfigShared -> Flag ReorderGoals
projectConfigMaxBackjumps :: ProjectConfigShared -> Flag Int
projectConfigWriteGhcEnvironmentFilesPolicy :: ProjectConfigShared -> Flag WriteGhcEnvironmentFilesPolicy
projectConfigAllowNewer :: ProjectConfigShared -> Maybe AllowNewer
projectConfigAllowOlder :: ProjectConfigShared -> Maybe AllowOlder
projectConfigSolver :: ProjectConfigShared -> Flag PreSolver
projectConfigCabalVersion :: ProjectConfigShared -> Flag Version
projectConfigPreferences :: ProjectConfigShared -> [PackageVersionConstraint]
projectConfigConstraints :: ProjectConfigShared -> [(UserConstraint, ConstraintSource)]
projectConfigStoreDir :: ProjectConfigShared -> Flag String
projectConfigIndexState :: ProjectConfigShared -> Flag TotalIndexState
projectConfigActiveRepos :: ProjectConfigShared -> Flag ActiveRepos
projectConfigLocalNoIndexRepos :: ProjectConfigShared -> NubList LocalRepo
projectConfigRemoteRepos :: ProjectConfigShared -> NubList RemoteRepo
projectConfigPackageDBs :: ProjectConfigShared -> [Maybe PackageDB]
projectConfigInstallDirs :: ProjectConfigShared -> InstallDirs (Flag PathTemplate)
projectConfigHaddockIndex :: ProjectConfigShared -> Flag PathTemplate
projectConfigHcPkg :: ProjectConfigShared -> Flag String
projectConfigHcPath :: ProjectConfigShared -> Flag String
projectConfigHcFlavor :: ProjectConfigShared -> Flag CompilerFlavor
projectConfigIgnoreProject :: ProjectConfigShared -> Flag Bool
projectConfigProjectFile :: ProjectConfigShared -> Flag String
projectConfigConfigFile :: ProjectConfigShared -> Flag String
projectConfigDistDir :: ProjectConfigShared -> Flag String
projectConfigRemoteRepos :: NubList RemoteRepo
projectConfigLocalNoIndexRepos :: NubList LocalRepo
projectConfigConstraints :: [(UserConstraint, ConstraintSource)]
projectConfigPreferences :: [PackageVersionConstraint]
projectConfigCabalVersion :: Flag Version
projectConfigSolver :: Flag PreSolver
projectConfigAllowOlder :: Maybe AllowOlder
projectConfigAllowNewer :: Maybe AllowNewer
projectConfigMaxBackjumps :: Flag Int
projectConfigReorderGoals :: Flag ReorderGoals
projectConfigCountConflicts :: Flag CountConflicts
projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts
projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet
projectConfigStrongFlags :: Flag StrongFlags
projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls
projectConfigOnlyConstrained :: Flag OnlyConstrained
projectConfigIndexState :: Flag TotalIndexState
projectConfigActiveRepos :: Flag ActiveRepos
projectConfigIndependentGoals :: Flag IndependentGoals
projectConfigPreferOldest :: Flag PreferOldest
projectConfigDistDir :: Flag String
projectConfigConfigFile :: Flag String
projectConfigProjectFile :: Flag String
projectConfigIgnoreProject :: Flag Bool
projectConfigHcFlavor :: Flag CompilerFlavor
projectConfigHcPath :: Flag String
projectConfigHcPkg :: Flag String
projectConfigHaddockIndex :: Flag PathTemplate
projectConfigInstallDirs :: InstallDirs (Flag PathTemplate)
projectConfigPackageDBs :: [Maybe PackageDB]
projectConfigStoreDir :: Flag String
projectConfigWriteGhcEnvironmentFilesPolicy :: Flag WriteGhcEnvironmentFilesPolicy
projectConfigPerComponent :: Flag Bool
projectConfigProgPathExtra :: NubList String
..} = 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 defaultSolver,
       projectConfigAllowOlder        = Just (AllowOlder mempty),
       projectConfigAllowNewer        = Just (AllowNewer mempty),
       projectConfigMaxBackjumps      = Flag defaultMaxBackjumps,
       projectConfigReorderGoals      = Flag (ReorderGoals False),
       projectConfigCountConflicts    = Flag (CountConflicts True),
       projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True),
       projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False),
       projectConfigStrongFlags       = Flag (StrongFlags False),
       projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False),
       projectConfigOnlyConstrained   = Flag OnlyConstrainedNone,
       projectConfigIndependentGoals  = Flag (IndependentGoals False),
       projectConfigPreferOldest      = Flag (PreferOldest False)
     --projectConfigShadowPkgs        = Flag False,
     --projectConfigReinstall         = Flag False,
     --projectConfigAvoidReinstalls   = Flag False,
     --projectConfigOverrideReinstall = Flag False,
     --projectConfigUpgradeDeps       = Flag False
    }


-- | Resolve the project configuration, with all its optional fields, into
-- 'BuildTimeSettings' with no optional fields (by applying defaults).
--
resolveBuildTimeSettings :: Verbosity
                         -> CabalDirLayout
                         -> ProjectConfig
                         -> BuildTimeSettings
resolveBuildTimeSettings :: Verbosity -> CabalDirLayout -> ProjectConfig -> BuildTimeSettings
resolveBuildTimeSettings Verbosity
verbosity
                         CabalDirLayout {
                           String
cabalLogsDirectory :: String
cabalLogsDirectory :: CabalDirLayout -> String
cabalLogsDirectory
                         }
                         ProjectConfig {
                           projectConfigShared :: ProjectConfig -> ProjectConfigShared
projectConfigShared = ProjectConfigShared {
                             NubList RemoteRepo
projectConfigRemoteRepos :: ProjectConfigShared -> NubList RemoteRepo
projectConfigRemoteRepos :: NubList RemoteRepo
projectConfigRemoteRepos,
                             NubList LocalRepo
projectConfigLocalNoIndexRepos :: ProjectConfigShared -> NubList LocalRepo
projectConfigLocalNoIndexRepos :: NubList LocalRepo
projectConfigLocalNoIndexRepos,
                             NubList String
projectConfigProgPathExtra :: ProjectConfigShared -> NubList String
projectConfigProgPathExtra :: NubList String
projectConfigProgPathExtra
                           },
                           ProjectConfigBuildOnly
projectConfigBuildOnly :: ProjectConfigBuildOnly
projectConfigBuildOnly :: ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly
                         } =
    BuildTimeSettings {Bool
Int
String
[String]
[PathTemplate]
[LocalRepo]
[RemoteRepo]
Maybe String
Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
Verbosity
ReportLevel
buildSettingHaddockOpen :: Bool
buildSettingProgPathExtra :: [String]
buildSettingIgnoreExpiry :: Bool
buildSettingHttpTransport :: Maybe String
buildSettingCacheDir :: String
buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingRemoteRepos :: [RemoteRepo]
buildSettingKeepTempFiles :: Bool
buildSettingOfflineMode :: Bool
buildSettingKeepGoing :: Bool
buildSettingNumJobs :: Int
buildSettingSymlinkBinDir :: [String]
buildSettingReportPlanningFailure :: Bool
buildSettingBuildReports :: ReportLevel
buildSettingLogVerbosity :: Verbosity
buildSettingLogFile :: Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
buildSettingSummaryFile :: [PathTemplate]
buildSettingOnlyDownload :: Bool
buildSettingOnlyDeps :: Bool
buildSettingDryRun :: Bool
buildSettingDryRun :: Bool
buildSettingOnlyDeps :: Bool
buildSettingOnlyDownload :: Bool
buildSettingSummaryFile :: [PathTemplate]
buildSettingBuildReports :: ReportLevel
buildSettingSymlinkBinDir :: [String]
buildSettingNumJobs :: Int
buildSettingKeepGoing :: Bool
buildSettingOfflineMode :: Bool
buildSettingKeepTempFiles :: Bool
buildSettingRemoteRepos :: [RemoteRepo]
buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingCacheDir :: String
buildSettingHttpTransport :: Maybe String
buildSettingIgnoreExpiry :: Bool
buildSettingReportPlanningFailure :: Bool
buildSettingProgPathExtra :: [String]
buildSettingHaddockOpen :: Bool
buildSettingLogFile :: Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
buildSettingLogVerbosity :: Verbosity
..}
  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 :: [String]
buildSettingSymlinkBinDir = Flag String -> [String]
forall a. Flag a -> [a]
flagToList  Flag String
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 :: String
buildSettingCacheDir      = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag    Flag String
projectConfigCacheDir
    buildSettingHttpTransport :: Maybe String
buildSettingHttpTransport = Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe Flag String
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 :: [String]
buildSettingProgPathExtra = NubList String -> [String]
forall a. NubList a -> [a]
fromNubList NubList String
projectConfigProgPathExtra
    buildSettingHaddockOpen :: Bool
buildSettingHaddockOpen   = Bool
False

    ProjectConfigBuildOnly{Flag Bool
Flag String
Flag (Maybe Int)
Flag Verbosity
Flag ReportLevel
Flag PathTemplate
NubList PathTemplate
ClientInstallFlags
projectConfigClientInstallFlags :: ProjectConfigBuildOnly -> ClientInstallFlags
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag String
projectConfigCacheDir :: ProjectConfigBuildOnly -> Flag String
projectConfigIgnoreExpiry :: ProjectConfigBuildOnly -> Flag Bool
projectConfigHttpTransport :: ProjectConfigBuildOnly -> Flag String
projectConfigKeepTempFiles :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOfflineMode :: ProjectConfigBuildOnly -> Flag Bool
projectConfigKeepGoing :: ProjectConfigBuildOnly -> Flag Bool
projectConfigNumJobs :: ProjectConfigBuildOnly -> Flag (Maybe Int)
projectConfigSymlinkBinDir :: ProjectConfigBuildOnly -> Flag String
projectConfigReportPlanningFailure :: ProjectConfigBuildOnly -> Flag Bool
projectConfigBuildReports :: ProjectConfigBuildOnly -> Flag ReportLevel
projectConfigLogFile :: ProjectConfigBuildOnly -> Flag PathTemplate
projectConfigSummaryFile :: ProjectConfigBuildOnly -> NubList PathTemplate
projectConfigOnlyDownload :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOnlyDeps :: ProjectConfigBuildOnly -> Flag Bool
projectConfigDryRun :: ProjectConfigBuildOnly -> Flag Bool
projectConfigVerbosity :: ProjectConfigBuildOnly -> Flag Verbosity
projectConfigDryRun :: Flag Bool
projectConfigOnlyDeps :: Flag Bool
projectConfigOnlyDownload :: Flag Bool
projectConfigSummaryFile :: NubList PathTemplate
projectConfigBuildReports :: Flag ReportLevel
projectConfigSymlinkBinDir :: Flag String
projectConfigNumJobs :: Flag (Maybe Int)
projectConfigKeepGoing :: Flag Bool
projectConfigOfflineMode :: Flag Bool
projectConfigKeepTempFiles :: Flag Bool
projectConfigCacheDir :: Flag String
projectConfigHttpTransport :: Flag String
projectConfigIgnoreExpiry :: Flag Bool
projectConfigReportPlanningFailure :: Flag Bool
projectConfigVerbosity :: Flag Verbosity
projectConfigLogFile :: Flag PathTemplate
projectConfigLogsDir :: Flag String
projectConfigClientInstallFlags :: ClientInstallFlags
..} = 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                = toFlag False,
      projectConfigOnlyDeps              = toFlag False,
      projectConfigOnlyDownload          = toFlag False,
      projectConfigBuildReports          = toFlag NoReports,
      projectConfigReportPlanningFailure = toFlag False,
      projectConfigKeepGoing             = toFlag False,
      projectConfigOfflineMode           = toFlag False,
      projectConfigKeepTempFiles         = toFlag False,
      projectConfigIgnoreExpiry          = toFlag False
    }

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

    defaultTemplate :: PathTemplate
defaultTemplate = String -> PathTemplate
toPathTemplate (String -> PathTemplate) -> String -> PathTemplate
forall a b. (a -> b) -> a -> b
$
                        String
cabalLogsDirectory String -> String -> String
</>
                        String
"$compiler" String -> String -> String
</> String
"$libname" String -> String -> String
<.> String
"log"
    givenTemplate :: Maybe PathTemplate
givenTemplate   = 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 -> String
substLogFileName PathTemplate
template Compiler
compiler Platform
platform PackageId
pkgid UnitId
uid =
        PathTemplate -> String
fromPathTemplate (PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env PathTemplate
template)
      where
        env :: PathTemplateEnv
env = PackageId -> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv
                PackageId
pkgid UnitId
uid (Compiler -> CompilerInfo
compilerInfo Compiler
compiler) Platform
platform

    -- If the user has specified --remote-build-reporting=detailed or
    -- --build-log, use more verbose logging.
    --
    buildSettingLogVerbosity :: Verbosity
    buildSettingLogVerbosity :: Verbosity
buildSettingLogVerbosity
      | Bool
overrideVerbosity = (Verbosity -> Verbosity) -> Verbosity -> Verbosity
modifyVerbosity (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 String
-> Maybe String -> IO (Either BadProjectRoot ProjectRoot)
findProjectRoot Maybe String
_ (Just String
projectFile)
  | String -> Bool
isAbsolute String
projectFile = do
    Bool
exists <- String -> IO Bool
doesFileExist String
projectFile
    if Bool
exists
      then do String
projectFile' <- String -> IO String
canonicalizePath String
projectFile
              let projectRoot :: ProjectRoot
projectRoot = String -> String -> ProjectRoot
ProjectRootExplicit (String -> String
takeDirectory String
projectFile')
                                                    (String -> String
takeFileName String
projectFile')
              Either BadProjectRoot ProjectRoot
-> IO (Either BadProjectRoot ProjectRoot)
forall a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BadProjectRoot -> Either BadProjectRoot ProjectRoot
forall a b. a -> Either a b
Left (String -> BadProjectRoot
BadProjectRootExplicitFile String
projectFile))

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

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

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

instance Show BadProjectRoot where
  show = renderBadProjectRoot
#endif

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

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

withGlobalConfig
    :: Verbosity                  -- ^ verbosity
    -> Flag FilePath              -- ^ @--cabal-config@
    -> (ProjectConfig -> IO a)    -- ^ with global
    -> IO a
withGlobalConfig :: forall a.
Verbosity -> Flag String -> (ProjectConfig -> IO a) -> IO a
withGlobalConfig Verbosity
verbosity Flag String
gcf ProjectConfig -> IO a
with = do
    ProjectConfig
globalConfig <- String -> Rebuild ProjectConfig -> IO ProjectConfig
forall a. String -> Rebuild a -> IO a
runRebuild String
"" (Rebuild ProjectConfig -> IO ProjectConfig)
-> Rebuild ProjectConfig -> IO ProjectConfig
forall a b. (a -> b) -> a -> b
$ Verbosity -> Flag String -> Rebuild ProjectConfig
readGlobalConfig Verbosity
verbosity Flag String
gcf
    ProjectConfig -> IO a
with ProjectConfig
globalConfig

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

withProjectOrGlobalConfig'
    :: Verbosity
    -> Flag FilePath
    -> IO a
    -> (ProjectConfig -> IO a)
    -> IO a
withProjectOrGlobalConfig' :: forall a.
Verbosity -> Flag String -> IO a -> (ProjectConfig -> IO a) -> IO a
withProjectOrGlobalConfig' Verbosity
verbosity Flag String
globalConfigFlag IO a
with ProjectConfig -> IO a
without = do
  ProjectConfig
globalConfig <- String -> Rebuild ProjectConfig -> IO ProjectConfig
forall a. String -> Rebuild a -> IO a
runRebuild String
"" (Rebuild ProjectConfig -> IO ProjectConfig)
-> Rebuild ProjectConfig -> IO ProjectConfig
forall a b. (a -> b) -> a -> b
$ Verbosity -> Flag String -> Rebuild ProjectConfig
readGlobalConfig Verbosity
verbosity Flag String
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 String
_) = 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 String
"") -> 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 String
-> DistDirLayout
-> Rebuild ProjectConfigSkeleton
readProjectConfig Verbosity
verbosity HttpTransport
httpTransport Flag Bool
ignoreProjectFlag Flag String
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 String -> Rebuild ProjectConfig
readGlobalConfig Verbosity
verbosity Flag String
configFileFlag
    ProjectConfigSkeleton
local  <- Verbosity
-> HttpTransport -> DistDirLayout -> Rebuild ProjectConfigSkeleton
readProjectLocalConfigOrDefault Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout
    ProjectConfigSkeleton
freeze <- Verbosity
-> HttpTransport -> DistDirLayout -> Rebuild ProjectConfigSkeleton
readProjectLocalFreezeConfig    Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout
    ProjectConfigSkeleton
extra  <- Verbosity
-> HttpTransport -> DistDirLayout -> Rebuild ProjectConfigSkeleton
readProjectLocalExtraConfig     Verbosity
verbosity HttpTransport
httpTransport DistDirLayout
distDirLayout
    if Flag Bool
ignoreProjectFlag 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 a. a -> Rebuild a
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 a. a -> Rebuild a
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 = ["./"]
      }

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

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

      projectConfigProvenance = Set.singleton Implicit
    }

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

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

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

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

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


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


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


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


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

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


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

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


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

instance Show BadPackageLocations where
  show = renderBadPackageLocations
#endif

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

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

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

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

      -- The configuration is implicit, render bad package locations
      -- using possibly specialized error messages.
    | 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 -> String) -> String
renderErrors BadPackageLocation -> String
renderImplicitBadPackageLocation

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

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

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

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

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

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

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

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

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

    [ProjectPackageLocation]
requiredPkgs <- Bool -> [String] -> Rebuild [ProjectPackageLocation]
findPackageLocations Bool
True    [String]
projectPackages
    [ProjectPackageLocation]
optionalPkgs <- Bool -> [String] -> Rebuild [ProjectPackageLocation]
findPackageLocations Bool
False   [String]
projectPackagesOptional
    let repoPkgs :: [ProjectPackageLocation]
repoPkgs  = (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 a. a -> Rebuild a
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 -> [String] -> Rebuild [ProjectPackageLocation]
findPackageLocations Bool
required [String]
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
<$> (String
 -> Rebuild (Either BadPackageLocation [ProjectPackageLocation]))
-> [String]
-> Rebuild [Either BadPackageLocation [ProjectPackageLocation]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Bool
-> String
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
findPackageLocation Bool
required) [String]
pkglocstr
      Bool -> Rebuild () -> Rebuild ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([BadPackageLocation] -> Bool
forall a. [a] -> 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 a. IO a -> Rebuild a
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 a. a -> Rebuild a
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
-> String
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
findPackageLocation _required :: Bool
_required@Bool
True String
pkglocstr =
      -- strategy: try first as a file:// or http(s):// URL.
      -- then as a file glob (usually encompassing single file)
      -- finally as a single file, for files that fail to parse as globs
                    String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsUriPackage String
pkglocstr
      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` String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsFileGlobPackage String
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` String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsSingleFilePackage String
pkglocstr
      Rebuild
  (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
-> (Maybe (Either BadPackageLocation [ProjectPackageLocation])
    -> Rebuild (Either BadPackageLocation [ProjectPackageLocation]))
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
forall a b. Rebuild a -> (a -> Rebuild b) -> Rebuild b
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 a. a -> Rebuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (BadPackageLocation
-> Either BadPackageLocation [ProjectPackageLocation]
forall a b. a -> Either a b
Left (String -> BadPackageLocation
BadLocUnrecognised String
pkglocstr))) Either BadPackageLocation [ProjectPackageLocation]
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
forall a. a -> Rebuild a
forall (m :: * -> *) a. Monad m => a -> m a
return


    findPackageLocation _required :: Bool
_required@Bool
False String
pkglocstr = do
      -- just globs for optional case
      Maybe (Either BadPackageLocation [ProjectPackageLocation])
res <- String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsFileGlobPackage String
pkglocstr
      case Maybe (Either BadPackageLocation [ProjectPackageLocation])
res of
        Maybe (Either BadPackageLocation [ProjectPackageLocation])
Nothing              -> Either BadPackageLocation [ProjectPackageLocation]
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
forall a. a -> Rebuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (BadPackageLocation
-> Either BadPackageLocation [ProjectPackageLocation]
forall a b. a -> Either a b
Left (String -> BadPackageLocation
BadLocUnrecognised String
pkglocstr))
        Just (Left BadPackageLocation
_)        -> Either BadPackageLocation [ProjectPackageLocation]
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
forall a. a -> Rebuild a
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 a. a -> Rebuild a
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 :: String
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
checkIsUriPackage String
pkglocstr =
      case String -> Maybe URI
parseAbsoluteURI String
pkglocstr of
        Just uri :: URI
uri@URI {
            uriScheme :: URI -> String
uriScheme    = String
scheme,
            uriAuthority :: URI -> Maybe URIAuth
uriAuthority = Just URIAuth { uriRegName :: URIAuth -> String
uriRegName = String
host },
            uriPath :: URI -> String
uriPath      = String
path,
            uriQuery :: URI -> String
uriQuery     = String
query,
            uriFragment :: URI -> String
uriFragment  = String
frag
          }
          | Bool
recognisedScheme Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
host) ->
            Maybe (Either BadPackageLocation [ProjectPackageLocation])
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
forall a. a -> Rebuild a
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]))

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

          | Bool -> Bool
not Bool
recognisedScheme Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
host) ->
            Maybe (Either BadPackageLocation [ProjectPackageLocation])
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
forall a. a -> Rebuild a
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 (String -> BadPackageLocation
BadLocUnexpectedUriScheme String
pkglocstr)))

          | Bool
recognisedScheme Bool -> Bool -> Bool
&& String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
host ->
            Maybe (Either BadPackageLocation [ProjectPackageLocation])
-> Rebuild
     (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
forall a. a -> Rebuild a
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 (String -> BadPackageLocation
BadLocUnrecognisedUri String
pkglocstr)))
          where
            recognisedScheme :: Bool
recognisedScheme = String
scheme String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"http:" Bool -> Bool -> Bool
|| String
scheme String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"https:"
                            Bool -> Bool -> Bool
|| String
scheme String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"file:"

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


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

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

            [String]
_  -> 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
<$>
                                     (String
 -> Rebuild (Either BadPackageLocationMatch ProjectPackageLocation))
-> [String]
-> Rebuild [Either BadPackageLocationMatch ProjectPackageLocation]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String
-> Rebuild (Either BadPackageLocationMatch ProjectPackageLocation)
checkFilePackageMatch [String]
matches
              Either BadPackageLocation [ProjectPackageLocation]
-> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
forall a. a -> Rebuild a
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 String -> Bool
forall a. Maybe a -> Bool
isJust (FilePathGlob -> Maybe String
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 (String -> [BadPackageLocationMatch] -> BadPackageLocation
BadLocGlobBadMatches String
pkglocstr [BadPackageLocationMatch]
failures)
                ([BadPackageLocationMatch], [ProjectPackageLocation])
_       -> [ProjectPackageLocation]
-> Either BadPackageLocation [ProjectPackageLocation]
forall a b. b -> Either a b
Right [ProjectPackageLocation]
pkglocs


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

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

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

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

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

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


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


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


--TODO: [code cleanup] use sufficiently recent transformers package
mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
mplusMaybeT :: forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
mplusMaybeT m (Maybe a)
ma m (Maybe a)
mb = do
  Maybe a
mx <- m (Maybe a)
ma
  case Maybe a
mx of
    Maybe a
Nothing -> m (Maybe a)
mb
    Just a
x  -> Maybe a -> m (Maybe a)
forall a. a -> m 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)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
        [ Verbosity
-> String
-> String
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readSourcePackageLocalDirectory Verbosity
verbosity String
dir String
cabalFile
        | ProjectPackageLocation
location <- [ProjectPackageLocation]
pkgLocations
        , (String
dir, String
cabalFile) <- ProjectPackageLocation -> [(String, String)]
projectPackageLocal ProjectPackageLocation
location ]

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

    [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
pkgsRemoteTarball <- do
      Rebuild HttpTransport
getTransport <- 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 -> [String] -> Maybe String -> IO HttpTransport
configureTransport Verbosity
verbosity [String]
progPathExtra
                                         Maybe String
preferredHttpTransport
      [Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [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 a. a -> Rebuild a
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 -> [(String, String)]
projectPackageLocal (ProjectPackageLocalDirectory String
dir String
file) = [(String
dir, String
file)]
    projectPackageLocal (ProjectPackageLocalCabalFile     String
file) = [(String
dir, String
file)]
                                                where dir :: String
dir = String -> String
takeDirectory String
file
    projectPackageLocal ProjectPackageLocation
_ = []

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

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


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

-- | A helper for 'fetchAndReadSourcePackages' to handle the case of
-- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir
-- and after that handle it like the local tarball case.
--
fetchAndReadSourcePackageRemoteTarball
  :: Verbosity
  -> DistDirLayout
  -> Rebuild HttpTransport
  -> URI
  -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
fetchAndReadSourcePackageRemoteTarball :: Verbosity
-> DistDirLayout
-> Rebuild HttpTransport
-> URI
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
fetchAndReadSourcePackageRemoteTarball Verbosity
verbosity
                                       DistDirLayout {
                                         String
distDownloadSrcDirectory :: DistDirLayout -> String
distDownloadSrcDirectory :: String
distDownloadSrcDirectory
                                       }
                                       Rebuild HttpTransport
getTransport
                                       URI
tarballUri =
    -- The tarball download is expensive so we use another layer of file
    -- monitor to avoid it whenever possible.
    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 a. IO a -> Rebuild a
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 -> String -> IO ()
notice Verbosity
verbosity (String
"Downloading " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
tarballUri)
        Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True
                                        String
distDownloadSrcDirectory
        DownloadResult
_ <- HttpTransport -> Verbosity -> URI -> String -> IO DownloadResult
downloadURI HttpTransport
transport Verbosity
verbosity URI
tarballUri String
tarballFile
        () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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


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

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

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

    let progPathExtra :: [String]
progPathExtra = NubList String -> [String]
forall a. NubList a -> [a]
fromNubList NubList String
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 (String -> VCS Program
forall a. HasCallStack => String -> a
error (String -> VCS Program) -> String -> VCS Program
forall a b. (a -> b) -> a -> b
$ String
"Unknown VCS: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RepoType -> String
forall a. Pretty a => a -> String
prettyShow RepoType
repoType) RepoType
repoType Map RepoType (VCS Program)
knownVCSs in
                          Verbosity -> [String] -> VCS Program -> IO (VCS ConfiguredProgram)
configureVCS Verbosity
verbosity [String]
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)
forall (f :: * -> *) a. Applicative f => [f a] -> f [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
-> String
-> [SourceRepoList]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
syncRepoGroupAndReadSourcePackages VCS ConfiguredProgram
vcs' String
pathStem [SourceRepoList]
repoGroup'
      | repoGroup :: [(SourceRepoList, RepoType)]
repoGroup@((SourceRepoList
primaryRepo, RepoType
repoType):[(SourceRepoList, RepoType)]
_) <- Map (RepoType, String) [(SourceRepoList, RepoType)]
-> [[(SourceRepoList, RepoType)]]
forall k a. Map k a -> [a]
Map.elems Map (RepoType, String) [(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 :: String
pathStem = String
distDownloadSrcDirectory
                   String -> String -> String
</> SourceRepoList -> String
localFileNameForRemoteRepo SourceRepoList
primaryRepo
            monitor :: FileMonitor
                         [SourceRepoList]
                         [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
            monitor :: FileMonitor
  [SourceRepoList]
  [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
monitor  = String
-> FileMonitor
     [SourceRepoList]
     [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
forall a b. Eq a => String -> FileMonitor a b
newFileMonitor (String
pathStem String -> String -> String
<.> String
"cache")
      ]
  where
    syncRepoGroupAndReadSourcePackages
      :: VCS ConfiguredProgram
      -> FilePath
      -> [SourceRepoList]
      -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
    syncRepoGroupAndReadSourcePackages :: VCS ConfiguredProgram
-> String
-> [SourceRepoList]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
syncRepoGroupAndReadSourcePackages VCS ConfiguredProgram
vcs String
pathStem [SourceRepoList]
repoGroup = do
        IO () -> Rebuild ()
forall a. IO a -> Rebuild a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rebuild ()) -> IO () -> Rebuild ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
False
                                                 String
distDownloadSrcDirectory

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

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

        -- 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)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
          [ SourceRepositoryPackage Maybe
-> String
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readPackageFromSourceRepo SourceRepositoryPackage Maybe
repoWithSubdir String
repoPath
          | (SourceRepositoryPackage Proxy
_, NonEmpty (SourceRepositoryPackage Maybe)
reposWithSubdir, String
repoPath) <- [(SourceRepositoryPackage Proxy,
  NonEmpty (SourceRepositoryPackage Maybe), String)]
repoGroupWithPaths
          , SourceRepositoryPackage Maybe
repoWithSubdir <- 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), String)]
repoGroupWithPaths =
          ((SourceRepositoryPackage Proxy,
  NonEmpty (SourceRepositoryPackage Maybe))
 -> String
 -> (SourceRepositoryPackage Proxy,
     NonEmpty (SourceRepositoryPackage Maybe), String))
-> [(SourceRepositoryPackage Proxy,
     NonEmpty (SourceRepositoryPackage Maybe))]
-> [String]
-> [(SourceRepositoryPackage Proxy,
     NonEmpty (SourceRepositoryPackage Maybe), String)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(SourceRepositoryPackage Proxy
x, NonEmpty (SourceRepositoryPackage Maybe)
y) String
z -> (SourceRepositoryPackage Proxy
x,NonEmpty (SourceRepositoryPackage Maybe)
y,String
z))
                  ([(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 }, SourceRepositoryPackage Maybe
repo)
                      | SourceRepositoryPackage Maybe
repo <- (SourceRepoList -> [SourceRepositoryPackage Maybe])
-> [SourceRepoList] -> [SourceRepositoryPackage Maybe]
forall m a. Monoid m => (a -> m) -> [a] -> m
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
                      ])
                  [String]
repoPaths

        mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)]
        mapGroup :: forall k v. Ord k => [(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 a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
v))

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

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

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

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

            let location :: PackageLocation String
location = SourceRepositoryPackage Maybe -> String -> PackageLocation String
forall local.
SourceRepositoryPackage Maybe -> local -> PackageLocation local
RemoteSourceRepoPackage SourceRepositoryPackage Maybe
repo String
tarballPath
            PackageSpecifier (SourcePackage UnresolvedPkgLoc)
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
forall a. a -> Rebuild a
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 String
-> GenericPackageDescription
-> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage PackageLocation String
location GenericPackageDescription
gpd

    reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a
    reportSourceRepoProblems :: forall a. [(SourceRepoList, SourceRepoProblem)] -> Rebuild a
reportSourceRepoProblems = IO a -> Rebuild a
forall a. 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 -> String -> IO a
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO a)
-> ([(SourceRepoList, SourceRepoProblem)] -> String)
-> [(SourceRepoList, SourceRepoProblem)]
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SourceRepoList, SourceRepoProblem)] -> String
renderSourceRepoProblems

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


-- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an
-- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package
-- from a given location.
--
mkSpecificSourcePackage :: PackageLocation FilePath
                        -> GenericPackageDescription
                        -> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage :: PackageLocation String
-> GenericPackageDescription
-> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage PackageLocation String
location GenericPackageDescription
pkg =
    SourcePackage UnresolvedPkgLoc
-> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage SourcePackage
      { srcpkgPackageId :: PackageId
srcpkgPackageId     = GenericPackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
pkg
      , srcpkgDescription :: GenericPackageDescription
srcpkgDescription   = GenericPackageDescription
pkg
      , srcpkgSource :: UnresolvedPkgLoc
srcpkgSource        = (String -> Maybe String)
-> PackageLocation String -> UnresolvedPkgLoc
forall a b. (a -> b) -> PackageLocation a -> PackageLocation b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just PackageLocation String
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 -> String -> String
showsPrec Int
d (CabalFileParseError String
fp ByteString
_ NonEmpty PError
es Maybe Version
mv [PWarning]
ws) = Bool -> (String -> String) -> String -> String
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
        ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
showString String
"CabalFileParseError"
        (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 String
fp
        (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 (String
"" :: String)
        (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> NonEmpty PError -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 NonEmpty PError
es
        (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Version -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 Maybe Version
mv
        (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [PWarning] -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
11 [PWarning]
ws

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

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

-- | Wrapper for the @.cabal@ file parser. It reports warnings on higher
-- verbosity levels and throws 'CabalFileParseError' on failure.
--
readSourcePackageCabalFile :: Verbosity
                           -> FilePath
                           -> BS.ByteString
                           -> IO GenericPackageDescription
readSourcePackageCabalFile :: Verbosity -> String -> ByteString -> IO GenericPackageDescription
readSourcePackageCabalFile Verbosity
verbosity String
pkgfilename ByteString
content =
    case 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warnings) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> String -> IO ()
info Verbosity
verbosity ([PWarning] -> String
formatWarnings [PWarning]
warnings)
        GenericPackageDescription -> IO GenericPackageDescription
forall a. a -> IO a
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
$ String
-> ByteString
-> NonEmpty PError
-> Maybe Version
-> [PWarning]
-> CabalFileParseError
CabalFileParseError String
pkgfilename ByteString
content NonEmpty PError
errors Maybe Version
mspecVersion [PWarning]
warnings
  where
    formatWarnings :: [PWarning] -> String
formatWarnings [PWarning]
warnings =
        String
"The package description file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pkgfilename
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has warnings: "
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((PWarning -> String) -> [PWarning] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PWarning -> String
showPWarning String
pkgfilename) [PWarning]
warnings)


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

instance Exception CabalFileSearchFailure


-- | Find the @.cabal@ file within a tarball file and return it by value.
--
-- Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception.
--
extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString)
extractTarballPackageCabalFile :: String -> IO (String, ByteString)
extractTarballPackageCabalFile String
tarballFile =
    String
-> IOMode
-> (Handle -> IO (String, ByteString))
-> IO (String, ByteString)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
tarballFile IOMode
ReadMode ((Handle -> IO (String, ByteString)) -> IO (String, ByteString))
-> (Handle -> IO (String, ByteString)) -> IO (String, ByteString)
forall a b. (a -> b) -> a -> b
$ \Handle
hnd -> do
      ByteString
content <- Handle -> IO ByteString
LBS.hGetContents Handle
hnd
      case String
-> ByteString
-> Either
     (Either FormatError CabalFileSearchFailure) (String, ByteString)
extractTarballPackageCabalFilePure String
tarballFile ByteString
content of
        Left (Left  FormatError
e) -> FormatError -> IO (String, ByteString)
forall e a. Exception e => e -> IO a
throwIO FormatError
e
        Left (Right CabalFileSearchFailure
e) -> CabalFileSearchFailure -> IO (String, ByteString)
forall e a. Exception e => e -> IO a
throwIO CabalFileSearchFailure
e
        Right (String
fileName, ByteString
fileContent) ->
          (,) String
fileName (ByteString -> (String, ByteString))
-> IO ByteString -> IO (String, 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 :: String
-> ByteString
-> Either
     (Either FormatError CabalFileSearchFailure) (String, ByteString)
extractTarballPackageCabalFilePure String
tarballFile =
      Either
  (FormatError, Map TarPath (GenEntry TarPath LinkTarget))
  (Map TarPath (GenEntry TarPath LinkTarget))
-> Either
     (Either FormatError CabalFileSearchFailure) (String, ByteString)
forall {a} {b} {k} {linkTarget}.
Either (a, b) (Map k (GenEntry TarPath linkTarget))
-> Either (Either a CabalFileSearchFailure) (String, ByteString)
check
    (Either
   (FormatError, Map TarPath (GenEntry TarPath LinkTarget))
   (Map TarPath (GenEntry TarPath LinkTarget))
 -> Either
      (Either FormatError CabalFileSearchFailure) (String, ByteString))
-> (ByteString
    -> Either
         (FormatError, Map TarPath (GenEntry TarPath LinkTarget))
         (Map TarPath (GenEntry TarPath LinkTarget)))
-> ByteString
-> Either
     (Either FormatError CabalFileSearchFailure) (String, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenEntries TarPath LinkTarget FormatError
-> Either
     (FormatError, Map TarPath (GenEntry TarPath LinkTarget))
     (Map TarPath (GenEntry TarPath LinkTarget))
forall {linkTarget} {e}.
GenEntries TarPath linkTarget e
-> Either
     (e, Map TarPath (GenEntry TarPath linkTarget))
     (Map TarPath (GenEntry TarPath linkTarget))
accumEntryMap
    (GenEntries TarPath LinkTarget FormatError
 -> Either
      (FormatError, Map TarPath (GenEntry TarPath LinkTarget))
      (Map TarPath (GenEntry TarPath LinkTarget)))
-> (ByteString -> GenEntries TarPath LinkTarget FormatError)
-> ByteString
-> Either
     (FormatError, Map TarPath (GenEntry TarPath LinkTarget))
     (Map TarPath (GenEntry TarPath LinkTarget))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenEntry TarPath LinkTarget -> Bool)
-> GenEntries TarPath LinkTarget FormatError
-> GenEntries TarPath LinkTarget FormatError
forall e.
(GenEntry TarPath LinkTarget -> Bool) -> Entries e -> Entries e
Tar.filterEntries GenEntry TarPath LinkTarget -> Bool
forall {linkTarget}. GenEntry TarPath linkTarget -> Bool
isCabalFile
    (GenEntries TarPath LinkTarget FormatError
 -> GenEntries TarPath LinkTarget FormatError)
-> (ByteString -> GenEntries TarPath LinkTarget FormatError)
-> ByteString
-> GenEntries TarPath LinkTarget FormatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> GenEntries TarPath LinkTarget FormatError
Tar.read
    (ByteString -> GenEntries TarPath LinkTarget FormatError)
-> (ByteString -> ByteString)
-> ByteString
-> GenEntries TarPath LinkTarget FormatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZipUtils.maybeDecompress
  where
    accumEntryMap :: GenEntries TarPath linkTarget e
-> Either
     (e, Map TarPath (GenEntry TarPath linkTarget))
     (Map TarPath (GenEntry TarPath linkTarget))
accumEntryMap = (Map TarPath (GenEntry TarPath linkTarget)
 -> GenEntry TarPath linkTarget
 -> Map TarPath (GenEntry TarPath linkTarget))
-> Map TarPath (GenEntry TarPath linkTarget)
-> GenEntries TarPath linkTarget e
-> Either
     (e, Map TarPath (GenEntry TarPath linkTarget))
     (Map TarPath (GenEntry TarPath linkTarget))
forall a tarPath linkTarget e.
(a -> GenEntry tarPath linkTarget -> a)
-> a -> GenEntries tarPath linkTarget e -> Either (e, a) a
Tar.foldlEntries
                      (\Map TarPath (GenEntry TarPath linkTarget)
m GenEntry TarPath linkTarget
e -> TarPath
-> GenEntry TarPath linkTarget
-> Map TarPath (GenEntry TarPath linkTarget)
-> Map TarPath (GenEntry TarPath linkTarget)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (GenEntry TarPath linkTarget -> TarPath
forall tarPath linkTarget. GenEntry tarPath linkTarget -> tarPath
Tar.entryTarPath GenEntry TarPath linkTarget
e) GenEntry TarPath linkTarget
e Map TarPath (GenEntry TarPath linkTarget)
m)
                      Map TarPath (GenEntry TarPath linkTarget)
forall k a. Map k a
Map.empty

    check :: Either (a, b) (Map k (GenEntry TarPath linkTarget))
-> Either (Either a CabalFileSearchFailure) (String, ByteString)
check (Left (a
e, b
_m)) = Either a CabalFileSearchFailure
-> Either (Either a CabalFileSearchFailure) (String, 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 (GenEntry TarPath linkTarget)
m) = case Map k (GenEntry TarPath linkTarget)
-> [GenEntry TarPath linkTarget]
forall k a. Map k a -> [a]
Map.elems Map k (GenEntry TarPath linkTarget)
m of
        []     -> Either a CabalFileSearchFailure
-> Either (Either a CabalFileSearchFailure) (String, 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
$ String -> CabalFileSearchFailure
NoCabalFileFound String
tarballFile)
        [GenEntry TarPath linkTarget
file] -> case GenEntry TarPath linkTarget -> GenEntryContent linkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
Tar.entryContent GenEntry TarPath linkTarget
file of
          Tar.NormalFile ByteString
content FileSize
_ -> (String, ByteString)
-> Either (Either a CabalFileSearchFailure) (String, ByteString)
forall a b. b -> Either a b
Right (GenEntry TarPath linkTarget -> String
forall linkTarget. GenEntry TarPath linkTarget -> String
Tar.entryPath GenEntry TarPath linkTarget
file, ByteString
content)
          GenEntryContent linkTarget
_                        -> Either a CabalFileSearchFailure
-> Either (Either a CabalFileSearchFailure) (String, 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
$ String -> CabalFileSearchFailure
NoCabalFileFound String
tarballFile)
        [GenEntry TarPath linkTarget]
_files -> Either a CabalFileSearchFailure
-> Either (Either a CabalFileSearchFailure) (String, 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
$ String -> CabalFileSearchFailure
MultipleCabalFilesFound String
tarballFile)

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


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

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


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

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


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


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


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

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

instance Show BadPerPackageCompilerPaths where
  show = renderBadPerPackageCompilerPaths
#endif

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

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

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