{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

-- | Handling project configuration.
module Distribution.Client.ProjectConfig
  ( -- * Types for project config
    ProjectConfig (..)
  , ProjectConfigToParse (..)
  , ProjectConfigBuildOnly (..)
  , ProjectConfigShared (..)
  , ProjectConfigProvenance (..)
  , PackageConfig (..)
  , MapLast (..)
  , MapMappend (..)

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

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

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

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

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

import Distribution.Client.Compat.Prelude
import Text.PrettyPrint (nest, render, text, vcat)
import Prelude ()

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

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

import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SourcePackage

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

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

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

import Network.URI
  ( URI (..)
  , URIAuth (..)
  , parseAbsoluteURI
  , uriToString
  )
import System.Directory
  ( canonicalizePath
  , doesDirectoryExist
  , doesFileExist
  , doesPathExist
  , getCurrentDirectory
  , getDirectoryContents
  , getHomeDirectory
  , pathIsSymbolicLink
  )
import System.FilePath hiding (combine)
import System.IO
  ( IOMode (ReadMode)
  , withBinaryFile
  )

import Distribution.Solver.Types.ProjectConfigPath

----------------------------------------
-- 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
String
[String]
[PathTemplate]
[LocalRepo]
[RemoteRepo]
Maybe String
Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
ParStratInstall
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 :: ParStratInstall
buildSettingKeepGoing :: Bool
buildSettingOfflineMode :: Bool
buildSettingKeepTempFiles :: Bool
buildSettingRemoteRepos :: [RemoteRepo]
buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingCacheDir :: String
buildSettingHttpTransport :: Maybe String
buildSettingIgnoreExpiry :: Bool
buildSettingProgPathExtra :: [String]
buildSettingHaddockOpen :: Bool
buildSettingDryRun :: BuildTimeSettings -> Bool
buildSettingOnlyDeps :: BuildTimeSettings -> Bool
buildSettingOnlyDownload :: BuildTimeSettings -> Bool
buildSettingSummaryFile :: BuildTimeSettings -> [PathTemplate]
buildSettingLogFile :: BuildTimeSettings
-> Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
buildSettingLogVerbosity :: BuildTimeSettings -> Verbosity
buildSettingBuildReports :: BuildTimeSettings -> ReportLevel
buildSettingReportPlanningFailure :: BuildTimeSettings -> Bool
buildSettingSymlinkBinDir :: BuildTimeSettings -> [String]
buildSettingNumJobs :: BuildTimeSettings -> ParStratInstall
buildSettingKeepGoing :: BuildTimeSettings -> Bool
buildSettingOfflineMode :: BuildTimeSettings -> Bool
buildSettingKeepTempFiles :: BuildTimeSettings -> Bool
buildSettingRemoteRepos :: BuildTimeSettings -> [RemoteRepo]
buildSettingLocalNoIndexRepos :: BuildTimeSettings -> [LocalRepo]
buildSettingCacheDir :: BuildTimeSettings -> String
buildSettingHttpTransport :: BuildTimeSettings -> Maybe String
buildSettingIgnoreExpiry :: BuildTimeSettings -> Bool
buildSettingProgPathExtra :: BuildTimeSettings -> [String]
buildSettingHaddockOpen :: 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 PackageDBCWD]
[(UserConstraint, ConstraintSource)]
[PackageVersionConstraint]
Maybe AllowOlder
Maybe AllowNewer
Flag Bool
Flag Int
Flag String
Flag Version
Flag PathTemplate
Flag CompilerFlavor
Flag OnlyConstrained
Flag AllowBootLibInstalls
Flag StrongFlags
Flag PreferOldest
Flag IndependentGoals
Flag MinimizeConflictSet
Flag FineGrainedConflicts
Flag CountConflicts
Flag ReorderGoals
Flag PreSolver
Flag TotalIndexState
Flag ActiveRepos
Flag WriteGhcEnvironmentFilesPolicy
InstallDirs (Flag PathTemplate)
NubList String
NubList LocalRepo
NubList RemoteRepo
projectConfigDistDir :: Flag String
projectConfigConfigFile :: Flag String
projectConfigProjectDir :: 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 PackageDBCWD]
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
projectConfigMultiRepl :: Flag Bool
projectConfigDistDir :: ProjectConfigShared -> Flag String
projectConfigConfigFile :: ProjectConfigShared -> Flag String
projectConfigProjectDir :: ProjectConfigShared -> Flag String
projectConfigProjectFile :: ProjectConfigShared -> Flag String
projectConfigIgnoreProject :: ProjectConfigShared -> Flag Bool
projectConfigHcFlavor :: ProjectConfigShared -> Flag CompilerFlavor
projectConfigHcPath :: ProjectConfigShared -> Flag String
projectConfigHcPkg :: ProjectConfigShared -> Flag String
projectConfigHaddockIndex :: ProjectConfigShared -> Flag PathTemplate
projectConfigInstallDirs :: ProjectConfigShared -> InstallDirs (Flag PathTemplate)
projectConfigPackageDBs :: ProjectConfigShared -> [Maybe PackageDBCWD]
projectConfigRemoteRepos :: ProjectConfigShared -> NubList RemoteRepo
projectConfigLocalNoIndexRepos :: ProjectConfigShared -> NubList LocalRepo
projectConfigActiveRepos :: ProjectConfigShared -> Flag ActiveRepos
projectConfigIndexState :: ProjectConfigShared -> Flag TotalIndexState
projectConfigStoreDir :: ProjectConfigShared -> Flag String
projectConfigConstraints :: ProjectConfigShared -> [(UserConstraint, ConstraintSource)]
projectConfigPreferences :: ProjectConfigShared -> [PackageVersionConstraint]
projectConfigCabalVersion :: ProjectConfigShared -> Flag Version
projectConfigSolver :: ProjectConfigShared -> Flag PreSolver
projectConfigAllowOlder :: ProjectConfigShared -> Maybe AllowOlder
projectConfigAllowNewer :: ProjectConfigShared -> Maybe AllowNewer
projectConfigWriteGhcEnvironmentFilesPolicy :: ProjectConfigShared -> Flag WriteGhcEnvironmentFilesPolicy
projectConfigMaxBackjumps :: ProjectConfigShared -> Flag Int
projectConfigReorderGoals :: ProjectConfigShared -> Flag ReorderGoals
projectConfigCountConflicts :: ProjectConfigShared -> Flag CountConflicts
projectConfigFineGrainedConflicts :: ProjectConfigShared -> Flag FineGrainedConflicts
projectConfigMinimizeConflictSet :: ProjectConfigShared -> Flag MinimizeConflictSet
projectConfigStrongFlags :: ProjectConfigShared -> Flag StrongFlags
projectConfigAllowBootLibInstalls :: ProjectConfigShared -> Flag AllowBootLibInstalls
projectConfigOnlyConstrained :: ProjectConfigShared -> Flag OnlyConstrained
projectConfigPerComponent :: ProjectConfigShared -> Flag Bool
projectConfigIndependentGoals :: ProjectConfigShared -> Flag IndependentGoals
projectConfigPreferOldest :: ProjectConfigShared -> Flag PreferOldest
projectConfigProgPathExtra :: ProjectConfigShared -> NubList String
projectConfigMultiRepl :: ProjectConfigShared -> Flag Bool
..}
  ProjectConfigBuildOnly{Flag Bool
Flag String
Flag (Maybe Int)
Flag PathTemplate
Flag Verbosity
Flag ReportLevel
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)
projectConfigUseSemaphore :: Flag Bool
projectConfigKeepGoing :: Flag Bool
projectConfigOfflineMode :: Flag Bool
projectConfigKeepTempFiles :: Flag Bool
projectConfigHttpTransport :: Flag String
projectConfigIgnoreExpiry :: Flag Bool
projectConfigCacheDir :: Flag String
projectConfigLogsDir :: Flag String
projectConfigClientInstallFlags :: ClientInstallFlags
projectConfigVerbosity :: ProjectConfigBuildOnly -> Flag Verbosity
projectConfigDryRun :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOnlyDeps :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOnlyDownload :: ProjectConfigBuildOnly -> Flag Bool
projectConfigSummaryFile :: ProjectConfigBuildOnly -> NubList PathTemplate
projectConfigLogFile :: ProjectConfigBuildOnly -> Flag PathTemplate
projectConfigBuildReports :: ProjectConfigBuildOnly -> Flag ReportLevel
projectConfigReportPlanningFailure :: ProjectConfigBuildOnly -> Flag Bool
projectConfigSymlinkBinDir :: ProjectConfigBuildOnly -> Flag String
projectConfigNumJobs :: ProjectConfigBuildOnly -> Flag (Maybe Int)
projectConfigUseSemaphore :: ProjectConfigBuildOnly -> Flag Bool
projectConfigKeepGoing :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOfflineMode :: ProjectConfigBuildOnly -> Flag Bool
projectConfigKeepTempFiles :: ProjectConfigBuildOnly -> Flag Bool
projectConfigHttpTransport :: ProjectConfigBuildOnly -> Flag String
projectConfigIgnoreExpiry :: ProjectConfigBuildOnly -> Flag Bool
projectConfigCacheDir :: ProjectConfigBuildOnly -> Flag String
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag String
projectConfigClientInstallFlags :: ProjectConfigBuildOnly -> ClientInstallFlags
..} =
    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
FlagAssignment
OnlyConstrained
AllowBootLibInstalls
StrongFlags
PreferOldest
IndependentGoals
MinimizeConflictSet
FineGrainedConflicts
CountConflicts
ReorderGoals
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
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
..}
    where
      -- TODO: [required eventually] some of these settings need validation, e.g.
      -- the flag assignments need checking.
      cabalPkgname :: PackageName
cabalPkgname = String -> PackageName
mkPackageName String
"Cabal"

      profilingDynamicConstraint :: (UserConstraint, ConstraintSource)
profilingDynamicConstraint =
        ( UserConstraintScope -> PackageProperty -> UserConstraint
UserConstraint
            (PackageName -> UserConstraintScope
UserAnySetupQualifier PackageName
cabalPkgname)
            (VersionRange -> PackageProperty
PackagePropertyVersion (VersionRange -> PackageProperty)
-> VersionRange -> PackageProperty
forall a b. (a -> b) -> a -> b
$ Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
3, Int
13, Int
0]))
        , ConstraintSource
ConstraintSourceProfiledDynamic
        )

      profDynEnabledGlobally :: Bool
profDynEnabledGlobally = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (PackageConfig -> Flag Bool
packageConfigProfShared PackageConfig
projectConfigLocalPackages)

      profDynEnabledAnyLocally :: Bool
profDynEnabledAnyLocally =
        [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
          [ Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (PackageConfig -> Flag Bool
packageConfigProfShared PackageConfig
ppc)
          | (PackageName
_, PackageConfig
ppc) <- Map PackageName PackageConfig -> [(PackageName, PackageConfig)]
forall k a. Map k a -> [(k, a)]
Map.toList (MapMappend PackageName PackageConfig
-> Map PackageName PackageConfig
forall k v. MapMappend k v -> Map k v
getMapMappend MapMappend PackageName PackageConfig
projectConfigSpecificPackage)
          ]

      -- Add a setup.Cabal >= 3.13 constraint if prof+dyn is enabled globally
      -- or any package in the project enables it.
      -- Ideally we'd apply this constraint only on the closure of packages requiring prof+dyn,
      -- but that would require another solver run for marginal advantages that
      -- will further shrink as 3.13 is adopted.
      solverCabalLibConstraints :: [(UserConstraint, ConstraintSource)]
solverCabalLibConstraints =
        [(UserConstraint, ConstraintSource)
profilingDynamicConstraint | Bool
profDynEnabledGlobally Bool -> Bool -> Bool
|| Bool
profDynEnabledAnyLocally]

      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)]
solverCabalLibConstraints [(UserConstraint, ConstraintSource)]
-> [(UserConstraint, ConstraintSource)]
-> [(UserConstraint, ConstraintSource)]
forall a. [a] -> [a] -> [a]
++ [(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 PackageDBCWD]
[(UserConstraint, ConstraintSource)]
[PackageVersionConstraint]
Maybe AllowOlder
Maybe AllowNewer
Flag Bool
Flag Int
Flag String
Flag Version
Flag PathTemplate
Flag CompilerFlavor
Flag OnlyConstrained
Flag AllowBootLibInstalls
Flag StrongFlags
Flag PreferOldest
Flag IndependentGoals
Flag MinimizeConflictSet
Flag FineGrainedConflicts
Flag CountConflicts
Flag ReorderGoals
Flag PreSolver
Flag TotalIndexState
Flag ActiveRepos
Flag WriteGhcEnvironmentFilesPolicy
InstallDirs (Flag PathTemplate)
NubList String
NubList LocalRepo
NubList RemoteRepo
projectConfigDistDir :: ProjectConfigShared -> Flag String
projectConfigConfigFile :: ProjectConfigShared -> Flag String
projectConfigProjectDir :: ProjectConfigShared -> Flag String
projectConfigProjectFile :: ProjectConfigShared -> Flag String
projectConfigIgnoreProject :: ProjectConfigShared -> Flag Bool
projectConfigHcFlavor :: ProjectConfigShared -> Flag CompilerFlavor
projectConfigHcPath :: ProjectConfigShared -> Flag String
projectConfigHcPkg :: ProjectConfigShared -> Flag String
projectConfigHaddockIndex :: ProjectConfigShared -> Flag PathTemplate
projectConfigInstallDirs :: ProjectConfigShared -> InstallDirs (Flag PathTemplate)
projectConfigPackageDBs :: ProjectConfigShared -> [Maybe PackageDBCWD]
projectConfigRemoteRepos :: ProjectConfigShared -> NubList RemoteRepo
projectConfigLocalNoIndexRepos :: ProjectConfigShared -> NubList LocalRepo
projectConfigActiveRepos :: ProjectConfigShared -> Flag ActiveRepos
projectConfigIndexState :: ProjectConfigShared -> Flag TotalIndexState
projectConfigStoreDir :: ProjectConfigShared -> Flag String
projectConfigConstraints :: ProjectConfigShared -> [(UserConstraint, ConstraintSource)]
projectConfigPreferences :: ProjectConfigShared -> [PackageVersionConstraint]
projectConfigCabalVersion :: ProjectConfigShared -> Flag Version
projectConfigSolver :: ProjectConfigShared -> Flag PreSolver
projectConfigAllowOlder :: ProjectConfigShared -> Maybe AllowOlder
projectConfigAllowNewer :: ProjectConfigShared -> Maybe AllowNewer
projectConfigWriteGhcEnvironmentFilesPolicy :: ProjectConfigShared -> Flag WriteGhcEnvironmentFilesPolicy
projectConfigMaxBackjumps :: ProjectConfigShared -> Flag Int
projectConfigReorderGoals :: ProjectConfigShared -> Flag ReorderGoals
projectConfigCountConflicts :: ProjectConfigShared -> Flag CountConflicts
projectConfigFineGrainedConflicts :: ProjectConfigShared -> Flag FineGrainedConflicts
projectConfigMinimizeConflictSet :: ProjectConfigShared -> Flag MinimizeConflictSet
projectConfigStrongFlags :: ProjectConfigShared -> Flag StrongFlags
projectConfigAllowBootLibInstalls :: ProjectConfigShared -> Flag AllowBootLibInstalls
projectConfigOnlyConstrained :: ProjectConfigShared -> Flag OnlyConstrained
projectConfigPerComponent :: ProjectConfigShared -> Flag Bool
projectConfigIndependentGoals :: ProjectConfigShared -> Flag IndependentGoals
projectConfigPreferOldest :: ProjectConfigShared -> Flag PreferOldest
projectConfigProgPathExtra :: ProjectConfigShared -> NubList String
projectConfigMultiRepl :: ProjectConfigShared -> Flag Bool
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
projectConfigProjectDir :: 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 PackageDBCWD]
projectConfigStoreDir :: Flag String
projectConfigWriteGhcEnvironmentFilesPolicy :: Flag WriteGhcEnvironmentFilesPolicy
projectConfigPerComponent :: Flag Bool
projectConfigProgPathExtra :: NubList String
projectConfigMultiRepl :: Flag Bool
..} = 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
String
[String]
[PathTemplate]
[LocalRepo]
[RemoteRepo]
Maybe String
Maybe (Compiler -> Platform -> PackageId -> UnitId -> String)
ParStratInstall
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 :: ParStratInstall
buildSettingKeepGoing :: Bool
buildSettingOfflineMode :: Bool
buildSettingKeepTempFiles :: Bool
buildSettingRemoteRepos :: [RemoteRepo]
buildSettingLocalNoIndexRepos :: [LocalRepo]
buildSettingCacheDir :: String
buildSettingHttpTransport :: Maybe String
buildSettingIgnoreExpiry :: Bool
buildSettingProgPathExtra :: [String]
buildSettingHaddockOpen :: Bool
buildSettingDryRun :: Bool
buildSettingOnlyDeps :: Bool
buildSettingOnlyDownload :: Bool
buildSettingSummaryFile :: [PathTemplate]
buildSettingBuildReports :: ReportLevel
buildSettingSymlinkBinDir :: [String]
buildSettingNumJobs :: ParStratInstall
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 :: ParStratInstall
buildSettingNumJobs =
        if Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag Flag Bool
projectConfigUseSemaphore
          then Int -> ParStratInstall
forall sem. sem -> ParStratX sem
UseSem (Flag (Maybe Int) -> Int
determineNumJobs Flag (Maybe Int)
projectConfigNumJobs)
          else case (Flag (Maybe Int) -> Int
determineNumJobs Flag (Maybe Int)
projectConfigNumJobs) of
            Int
1 -> ParStratInstall
forall sem. ParStratX sem
Serial
            Int
n -> Maybe Int -> ParStratInstall
forall sem. Maybe Int -> ParStratX sem
NumJobs (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n)
      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 PathTemplate
Flag Verbosity
Flag ReportLevel
NubList PathTemplate
ClientInstallFlags
projectConfigVerbosity :: ProjectConfigBuildOnly -> Flag Verbosity
projectConfigDryRun :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOnlyDeps :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOnlyDownload :: ProjectConfigBuildOnly -> Flag Bool
projectConfigSummaryFile :: ProjectConfigBuildOnly -> NubList PathTemplate
projectConfigLogFile :: ProjectConfigBuildOnly -> Flag PathTemplate
projectConfigBuildReports :: ProjectConfigBuildOnly -> Flag ReportLevel
projectConfigReportPlanningFailure :: ProjectConfigBuildOnly -> Flag Bool
projectConfigSymlinkBinDir :: ProjectConfigBuildOnly -> Flag String
projectConfigNumJobs :: ProjectConfigBuildOnly -> Flag (Maybe Int)
projectConfigUseSemaphore :: ProjectConfigBuildOnly -> Flag Bool
projectConfigKeepGoing :: ProjectConfigBuildOnly -> Flag Bool
projectConfigOfflineMode :: ProjectConfigBuildOnly -> Flag Bool
projectConfigKeepTempFiles :: ProjectConfigBuildOnly -> Flag Bool
projectConfigHttpTransport :: ProjectConfigBuildOnly -> Flag String
projectConfigIgnoreExpiry :: ProjectConfigBuildOnly -> Flag Bool
projectConfigCacheDir :: ProjectConfigBuildOnly -> Flag String
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag String
projectConfigClientInstallFlags :: ProjectConfigBuildOnly -> ClientInstallFlags
projectConfigDryRun :: Flag Bool
projectConfigOnlyDeps :: Flag Bool
projectConfigOnlyDownload :: Flag Bool
projectConfigSummaryFile :: NubList PathTemplate
projectConfigBuildReports :: Flag ReportLevel
projectConfigSymlinkBinDir :: Flag String
projectConfigUseSemaphore :: Flag Bool
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
        | ParStratInstall -> Bool
forall n. ParStratX n -> Bool
isParallelBuild ParStratInstall
buildSettingNumJobs = Bool
True
        | Bool
otherwise = Bool
False

      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
        | ParStratInstall -> Bool
forall n. ParStratX n -> Bool
isParallelBuild ParStratInstall
buildSettingNumJobs = Bool
False
        | Bool
otherwise = Bool
False

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

-- | Get @ProjectRootUsability@ of a given file
getProjectRootUsability :: FilePath -> IO ProjectRootUsability
getProjectRootUsability :: String -> IO ProjectRootUsability
getProjectRootUsability String
filePath = do
  Bool
exists <- String -> IO Bool
doesFileExist String
filePath
  if Bool
exists
    then ProjectRootUsability -> IO ProjectRootUsability
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectRootUsability
ProjectRootUsabilityPresentAndUsable
    else do
      let isUsableAction :: IO Bool
isUsableAction =
            forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle @IOException
              -- NOTE: if any IOException is raised, we assume the file does not exist.
              -- That is what happen when we call @pathIsSymbolicLink@ on a @FilePath@ that does not exist.
              (IO Bool -> IOException -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> IOException -> IO Bool)
-> IO Bool -> IOException -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
              (Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> IO Bool -> IO (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
pathIsSymbolicLink String
filePath IO (Bool -> Bool) -> IO Bool -> IO Bool
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO Bool
doesPathExist String
filePath)
      Bool
isUnusable <- IO Bool
isUsableAction
      if Bool
isUnusable
        then ProjectRootUsability -> IO ProjectRootUsability
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectRootUsability
ProjectRootUsabilityPresentAndUnusable
        else ProjectRootUsability -> IO ProjectRootUsability
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectRootUsability
ProjectRootUsabilityNotPresent

-- | Find the root of this project.
--
-- The project directory will be one of the following:
--   1. @mprojectDir@ when present
--   2. The first directory containing @mprojectFile@/@cabal.project@, starting from the current directory
--      and recursively checking parent directories
--   3. The current directory
findProjectRoot
  :: Verbosity
  -> Maybe FilePath
  -- ^ Explicit project directory
  -> Maybe FilePath
  -- ^ Explicit project file
  -> IO (Either BadProjectRoot ProjectRoot)
findProjectRoot :: Verbosity
-> Maybe String
-> Maybe String
-> IO (Either BadProjectRoot ProjectRoot)
findProjectRoot Verbosity
verbosity Maybe String
mprojectDir Maybe String
mprojectFile = do
  case Maybe String
mprojectDir of
    Maybe String
Nothing
      | Just String
file <- Maybe String
mprojectFile
      , String -> Bool
isAbsolute String
file -> do
          Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"Specifying an absolute path to the project file is deprecated."
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Use --project-dir to set the project's directory."

          String -> IO ProjectRootUsability
getProjectRootUsability String
file IO ProjectRootUsability
-> (ProjectRootUsability -> IO (Either BadProjectRoot ProjectRoot))
-> IO (Either BadProjectRoot ProjectRoot)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            ProjectRootUsability
ProjectRootUsabilityPresentAndUsable ->
              (String -> String -> IO (Either BadProjectRoot ProjectRoot))
-> (String, String) -> IO (Either BadProjectRoot ProjectRoot)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> IO (Either BadProjectRoot ProjectRoot)
forall {f :: * -> *} {a}.
Applicative f =>
String -> String -> f (Either a ProjectRoot)
projectRoot
                ((String, String) -> IO (Either BadProjectRoot ProjectRoot))
-> IO (String, String) -> IO (Either BadProjectRoot ProjectRoot)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> String) -> (String, String) -> (String, String)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> String
dropTrailingPathSeparator ((String, String) -> (String, String))
-> (String -> (String, String)) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, String)
splitFileName (String -> (String, String)) -> IO String -> IO (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
canonicalizePath String
file
            ProjectRootUsability
ProjectRootUsabilityNotPresent ->
              BadProjectRoot -> IO (Either BadProjectRoot ProjectRoot)
forall {a} {b}. a -> IO (Either a b)
left (String -> BadProjectRoot
BadProjectRootExplicitFileNotFound String
file)
            ProjectRootUsability
ProjectRootUsabilityPresentAndUnusable ->
              BadProjectRoot -> IO (Either BadProjectRoot ProjectRoot)
forall {a} {b}. a -> IO (Either a b)
left (String -> BadProjectRoot
BadProjectRootFileBroken String
file)
      | Bool
otherwise -> Maybe String -> IO (Either BadProjectRoot ProjectRoot)
probeProjectRoot Maybe String
mprojectFile
    Just String
dir ->
      String -> IO Bool
doesDirectoryExist String
dir IO Bool
-> (Bool -> IO (Either BadProjectRoot ProjectRoot))
-> IO (Either BadProjectRoot ProjectRoot)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> BadProjectRoot -> IO (Either BadProjectRoot ProjectRoot)
forall {a} {b}. a -> IO (Either a b)
left (String -> BadProjectRoot
BadProjectRootDirNotFound String
dir)
        Bool
True -> do
          String
projectDir <- String -> IO String
canonicalizePath String
dir

          case Maybe String
mprojectFile of
            Maybe String
Nothing -> Either BadProjectRoot ProjectRoot
-> IO (Either BadProjectRoot ProjectRoot)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BadProjectRoot ProjectRoot
 -> IO (Either BadProjectRoot ProjectRoot))
-> Either BadProjectRoot ProjectRoot
-> IO (Either BadProjectRoot ProjectRoot)
forall a b. (a -> b) -> a -> b
$ ProjectRoot -> Either BadProjectRoot ProjectRoot
forall a b. b -> Either a b
Right (String -> String -> ProjectRoot
ProjectRootExplicit String
projectDir String
defaultProjectFile)
            Just String
projectFile
              | String -> Bool
isAbsolute String
projectFile ->
                  String -> IO ProjectRootUsability
getProjectRootUsability String
projectFile IO ProjectRootUsability
-> (ProjectRootUsability -> IO (Either BadProjectRoot ProjectRoot))
-> IO (Either BadProjectRoot ProjectRoot)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    ProjectRootUsability
ProjectRootUsabilityNotPresent ->
                      BadProjectRoot -> IO (Either BadProjectRoot ProjectRoot)
forall {a} {b}. a -> IO (Either a b)
left (String -> BadProjectRoot
BadProjectRootAbsoluteFileNotFound String
projectFile)
                    ProjectRootUsability
ProjectRootUsabilityPresentAndUsable ->
                      ProjectRoot -> Either BadProjectRoot ProjectRoot
forall a b. b -> Either a b
Right (ProjectRoot -> Either BadProjectRoot ProjectRoot)
-> (String -> ProjectRoot)
-> String
-> Either BadProjectRoot ProjectRoot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ProjectRoot
ProjectRootExplicitAbsolute String
dir (String -> Either BadProjectRoot ProjectRoot)
-> IO String -> IO (Either BadProjectRoot ProjectRoot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
canonicalizePath String
projectFile
                    ProjectRootUsability
ProjectRootUsabilityPresentAndUnusable ->
                      BadProjectRoot -> IO (Either BadProjectRoot ProjectRoot)
forall {a} {b}. a -> IO (Either a b)
left (String -> BadProjectRoot
BadProjectRootFileBroken String
projectFile)
              | Bool
otherwise ->
                  String -> IO ProjectRootUsability
getProjectRootUsability (String
projectDir String -> String -> String
</> String
projectFile) IO ProjectRootUsability
-> (ProjectRootUsability -> IO (Either BadProjectRoot ProjectRoot))
-> IO (Either BadProjectRoot ProjectRoot)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    ProjectRootUsability
ProjectRootUsabilityNotPresent ->
                      BadProjectRoot -> IO (Either BadProjectRoot ProjectRoot)
forall {a} {b}. a -> IO (Either a b)
left (String -> String -> BadProjectRoot
BadProjectRootDirFileNotFound String
dir String
projectFile)
                    ProjectRootUsability
ProjectRootUsabilityPresentAndUsable ->
                      String -> String -> IO (Either BadProjectRoot ProjectRoot)
forall {f :: * -> *} {a}.
Applicative f =>
String -> String -> f (Either a ProjectRoot)
projectRoot String
projectDir String
projectFile
                    ProjectRootUsability
ProjectRootUsabilityPresentAndUnusable ->
                      BadProjectRoot -> IO (Either BadProjectRoot ProjectRoot)
forall {a} {b}. a -> IO (Either a b)
left (String -> BadProjectRoot
BadProjectRootFileBroken String
projectFile)
  where
    left :: a -> IO (Either a b)
left = Either a b -> IO (Either a b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b -> IO (Either a b))
-> (a -> Either a b) -> a -> IO (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left

    projectRoot :: String -> String -> f (Either a ProjectRoot)
projectRoot String
projectDir String
projectFile =
      Either a ProjectRoot -> f (Either a ProjectRoot)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a ProjectRoot -> f (Either a ProjectRoot))
-> Either a ProjectRoot -> f (Either a ProjectRoot)
forall a b. (a -> b) -> a -> b
$ ProjectRoot -> Either a ProjectRoot
forall a b. b -> Either a b
Right (String -> String -> ProjectRoot
ProjectRootExplicit String
projectDir String
projectFile)

probeProjectRoot :: Maybe FilePath -> IO (Either BadProjectRoot ProjectRoot)
probeProjectRoot :: Maybe String -> IO (Either BadProjectRoot ProjectRoot)
probeProjectRoot Maybe String
mprojectFile = do
  String
startdir <- IO String
System.Directory.getCurrentDirectory
  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
defaultProjectFile 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
BadProjectRootExplicitFileNotFound String
file))
        go String
dir = do
          String -> IO ProjectRootUsability
getProjectRootUsability (String
dir String -> String -> String
</> String
projectFileName) IO ProjectRootUsability
-> (ProjectRootUsability -> IO (Either BadProjectRoot ProjectRoot))
-> IO (Either BadProjectRoot ProjectRoot)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            ProjectRootUsability
ProjectRootUsabilityNotPresent ->
              String -> IO (Either BadProjectRoot ProjectRoot)
go (String -> String
takeDirectory String
dir)
            ProjectRootUsability
ProjectRootUsabilityPresentAndUsable ->
              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 -> Either BadProjectRoot ProjectRoot)
-> ProjectRoot -> Either BadProjectRoot ProjectRoot
forall a b. (a -> b) -> a -> b
$ String -> String -> ProjectRoot
ProjectRootExplicit String
dir String
projectFileName)
            ProjectRootUsability
ProjectRootUsabilityPresentAndUnusable ->
              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 (BadProjectRoot -> Either BadProjectRoot ProjectRoot)
-> BadProjectRoot -> Either BadProjectRoot ProjectRoot
forall a b. (a -> b) -> a -> b
$ String -> BadProjectRoot
BadProjectRootFileBroken String
projectFileName)

-- | Errors returned by 'findProjectRoot'.
data BadProjectRoot
  = BadProjectRootExplicitFileNotFound FilePath
  | BadProjectRootDirNotFound FilePath
  | BadProjectRootAbsoluteFileNotFound FilePath
  | BadProjectRootDirFileNotFound FilePath FilePath
  | BadProjectRootFileBroken FilePath
  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, BadProjectRoot -> BadProjectRoot -> Bool
(BadProjectRoot -> BadProjectRoot -> Bool)
-> (BadProjectRoot -> BadProjectRoot -> Bool) -> Eq BadProjectRoot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BadProjectRoot -> BadProjectRoot -> Bool
== :: BadProjectRoot -> BadProjectRoot -> Bool
$c/= :: BadProjectRoot -> BadProjectRoot -> Bool
/= :: BadProjectRoot -> BadProjectRoot -> Bool
Eq)

instance Exception BadProjectRoot where
  displayException :: BadProjectRoot -> String
displayException = BadProjectRoot -> String
renderBadProjectRoot

renderBadProjectRoot :: BadProjectRoot -> String
renderBadProjectRoot :: BadProjectRoot -> String
renderBadProjectRoot = \case
  BadProjectRootExplicitFileNotFound 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."
  BadProjectRootDirNotFound String
dir ->
    String
"The given project directory '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' does not exist."
  BadProjectRootAbsoluteFileNotFound String
file ->
    String
"The given project file '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
file String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' does not exist."
  BadProjectRootDirFileNotFound String
dir String
file ->
    String
"The given project directory/file combination '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dir String -> String -> String
</> String
file String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' does not exist."
  BadProjectRootFileBroken String
file ->
    String
"The given project file '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
file String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' is broken. Is it a broken symbolic link?"

-- | State of the project file, encodes if the file can be used
data ProjectRootUsability
  = -- | The file is present and can be used
    ProjectRootUsabilityPresentAndUsable
  | -- | The file is present but can't be used (e.g. broken symlink)
    ProjectRootUsabilityPresentAndUnusable
  | -- | The file is not present
    ProjectRootUsabilityNotPresent
  deriving (ProjectRootUsability -> ProjectRootUsability -> Bool
(ProjectRootUsability -> ProjectRootUsability -> Bool)
-> (ProjectRootUsability -> ProjectRootUsability -> Bool)
-> Eq ProjectRootUsability
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProjectRootUsability -> ProjectRootUsability -> Bool
== :: ProjectRootUsability -> ProjectRootUsability -> Bool
$c/= :: ProjectRootUsability -> ProjectRootUsability -> Bool
/= :: ProjectRootUsability -> ProjectRootUsability -> Bool
Eq, Int -> ProjectRootUsability -> String -> String
[ProjectRootUsability] -> String -> String
ProjectRootUsability -> String
(Int -> ProjectRootUsability -> String -> String)
-> (ProjectRootUsability -> String)
-> ([ProjectRootUsability] -> String -> String)
-> Show ProjectRootUsability
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ProjectRootUsability -> String -> String
showsPrec :: Int -> ProjectRootUsability -> String -> String
$cshow :: ProjectRootUsability -> String
show :: ProjectRootUsability -> String
$cshowList :: [ProjectRootUsability] -> String -> String
showList :: [ProjectRootUsability] -> String -> String
Show)

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
  :: Flag Bool
  -- ^ whether to ignore local project (--ignore-project flag)
  -> IO a
  -- ^ continuation with project
  -> IO a
  -- ^ continuation without project
  -> IO a
withProjectOrGlobalConfig :: forall a. Flag Bool -> IO a -> IO a -> IO a
withProjectOrGlobalConfig (Flag Bool
True) IO a
_with IO a
without = do
  IO a
without
withProjectOrGlobalConfig Flag Bool
_ignorePrj IO a
with IO a
without =
  IO a -> IO a -> IO a
forall a. IO a -> IO a -> IO a
withProjectOrGlobalConfig' IO a
with IO a
without

withProjectOrGlobalConfig'
  :: IO a
  -- ^ continuation with project
  -> IO a
  -- ^ continuation without project
  -> IO a
withProjectOrGlobalConfig' :: forall a. IO a -> IO a -> IO a
withProjectOrGlobalConfig' IO a
with IO a
without = do
  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 -> do
            IO a
without
      BadPackageLocations
err -> BadPackageLocations -> IO a
forall e a. Exception e => e -> IO a
throwIO BadPackageLocations
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
_ (Flag Bool
True) Flag String
configFileFlag 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 -> 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
defaultImplicitProjectConfig)
readProjectConfig Verbosity
verbosity HttpTransport
httpTransport Flag Bool
_ 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
  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)

-- | 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
  let projectFile :: String
projectFile = DistDirLayout -> String -> String
distProjectFile DistDirLayout
distDirLayout String
""
  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)

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 (ProjectConfigPath -> String
projectConfigPathRoot (ProjectConfigPath -> String) -> [ProjectConfigPath] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProjectConfigSkeleton -> [ProjectConfigPath]
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
-> String
-> HttpTransport
-> Verbosity
-> ProjectConfigToParse
-> IO (ParseResult ProjectConfigSkeleton)
parseProject String
extensionFile String
distDownloadSrcDirectory HttpTransport
httpTransport Verbosity
verbosity (ProjectConfigToParse -> IO (ParseResult ProjectConfigSkeleton))
-> (ByteString -> ProjectConfigToParse)
-> ByteString
-> IO (ParseResult ProjectConfigSkeleton)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ProjectConfigToParse
ProjectConfigToParse
          (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]
: (ProjectConfigPath -> String
projectConfigPathRoot (ProjectConfigPath -> String) -> [ProjectConfigPath] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProjectConfigSkeleton -> [ProjectConfigPath]
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
      errLineNo :: String
errLineNo = 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
   in Verbosity -> CabalInstallException -> IO ProjectConfigSkeleton
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ProjectConfigSkeleton)
-> CabalInstallException -> IO ProjectConfigSkeleton
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> CabalInstallException
ReportParseResult String
filetype String
filename String
errLineNo 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]
  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)

instance Exception BadPackageLocations where
  displayException :: BadPackageLocations -> String
displayException = BadPackageLocations -> String
renderBadPackageLocations

-- 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 from:\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
render (Int -> Doc -> Doc
nest Int
2 (Doc -> Doc)
-> ([ProjectConfigPath] -> Doc) -> [ProjectConfigPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ProjectConfigPath] -> Doc
docProjectConfigPaths ([ProjectConfigPath] -> Doc) -> [ProjectConfigPath] -> Doc
forall a b. (a -> b) -> a -> b
$ (ProjectConfigProvenance -> Maybe ProjectConfigPath)
-> [ProjectConfigProvenance] -> [ProjectConfigPath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ProjectConfigProvenance -> Maybe ProjectConfigPath
getExplicit (Set ProjectConfigProvenance -> [ProjectConfigProvenance]
forall a. Set a -> [a]
Set.toList Set ProjectConfigProvenance
provenance))
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nThe following errors occurred:\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
render (Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ((String -> Doc
text String
"-" Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> Doc) -> [String] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BadPackageLocation -> String) -> [BadPackageLocation] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map BadPackageLocation -> String
renderBadPackageLocation [BadPackageLocation]
bpls))

    getExplicit :: ProjectConfigProvenance -> Maybe ProjectConfigPath
getExplicit (Explicit ProjectConfigPath
path) = ProjectConfigPath -> Maybe ProjectConfigPath
forall a. a -> Maybe a
Just ProjectConfigPath
path
    getExplicit ProjectConfigProvenance
Implicit = Maybe ProjectConfigPath
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)."

-- | Determines the location of all packages mentioned in the project configuration.
--
-- 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
projectPackagesOptional :: ProjectConfig -> [String]
projectPackagesRepo :: ProjectConfig -> [SourceRepoList]
projectPackagesNamed :: ProjectConfig -> [PackageVersionConstraint]
projectConfigAllPackages :: ProjectConfig -> PackageConfig
..} = do
    [ProjectPackageLocation]
requiredPkgs <- Bool -> [String] -> Rebuild [ProjectPackageLocation]
findPackageLocations Bool
True [String]
projectPackages
    [ProjectPackageLocation]
optionalPkgs <- Bool -> [String] -> Rebuild [ProjectPackageLocation]
findPackageLocations Bool
False [String]
projectPackagesOptional
    let repoPkgs :: [ProjectPackageLocation]
repoPkgs = (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 RootedGlob
forall a. Parsec a => String -> Maybe a
simpleParsec String
pkglocstr of
          Maybe RootedGlob
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 RootedGlob
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 <- RootedGlob -> Rebuild [String]
matchFileGlob RootedGlob
glob
            case [String]
matches of
              []
                | Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (RootedGlob -> Maybe String
isTrivialRootedGlob RootedGlob
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 (RootedGlob -> Maybe String
isTrivialRootedGlob RootedGlob
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 <- RootedGlob -> Rebuild [String]
matchFileGlob (String -> RootedGlob
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 -> RootedGlob
globStarDotCabal :: String -> RootedGlob
globStarDotCabal String
dir =
  FilePathRoot -> Glob -> RootedGlob
RootedGlob
    (if String -> Bool
isAbsolute String
dir then String -> FilePathRoot
FilePathRoot String
root else FilePathRoot
FilePathRelative)
    ( (String -> Glob -> Glob) -> Glob -> [String] -> Glob
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 -> GlobPieces -> Glob -> Glob
GlobDir [String -> GlobPiece
Literal String
d])
        (GlobPieces -> Glob
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
-> Bool
-> [SourceRepoList]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
syncAndReadSourcePackagesRemoteRepos
        Verbosity
verbosity
        DistDirLayout
distDirLayout
        ProjectConfigShared
projectConfigShared
        (Flag Bool -> Bool
forall a. WithCallStack (Flag a -> a)
fromFlag (ProjectConfigBuildOnly -> Flag Bool
projectConfigOfflineMode ProjectConfigBuildOnly
projectConfigBuildOnly))
        [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
  -> Bool
  -> [SourceRepoList]
  -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
syncAndReadSourcePackagesRemoteRepos :: Verbosity
-> DistDirLayout
-> ProjectConfigShared
-> Bool
-> [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
    }
  Bool
offlineMode
  [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.
        -- Do not sync source repositories when `--offline` flag applied.
        if Bool -> Bool
not Bool
offlineMode
          then
            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
              ]
          else do
            IO () -> Rebuild ()
forall a. IO a -> Rebuild a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rebuild ()) -> (String -> IO ()) -> String -> Rebuild ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> Rebuild ()) -> String -> Rebuild ()
forall a b. (a -> b) -> a -> b
$ String
"--offline was specified, skipping sync of repositories:"
            IO () -> Rebuild ()
forall a. IO a -> Rebuild a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Rebuild ())
-> (((SourceRepositoryPackage Proxy,
      NonEmpty (SourceRepositoryPackage Maybe), String)
     -> IO ())
    -> IO ())
-> ((SourceRepositoryPackage Proxy,
     NonEmpty (SourceRepositoryPackage Maybe), String)
    -> IO ())
-> Rebuild ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SourceRepositoryPackage Proxy,
  NonEmpty (SourceRepositoryPackage Maybe), String)]
-> ((SourceRepositoryPackage Proxy,
     NonEmpty (SourceRepositoryPackage Maybe), String)
    -> IO ())
-> IO ()
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)
  -> IO ())
 -> Rebuild ())
-> ((SourceRepositoryPackage Proxy,
     NonEmpty (SourceRepositoryPackage Maybe), String)
    -> IO ())
-> Rebuild ()
forall a b. (a -> b) -> a -> b
$ \(SourceRepositoryPackage Proxy
repo, NonEmpty (SourceRepositoryPackage Maybe)
_, String
_) -> Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SourceRepositoryPackage Proxy -> String
forall (f :: * -> *). SourceRepositoryPackage f -> String
srpLocation SourceRepositoryPackage Proxy
repo

        -- 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 -> CabalInstallException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO a)
-> ([(SourceRepoList, SourceRepoProblem)] -> CabalInstallException)
-> [(SourceRepoList, SourceRepoProblem)]
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CabalInstallException
ReportSourceRepoProblems (String -> CabalInstallException)
-> ([(SourceRepoList, SourceRepoProblem)] -> String)
-> [(SourceRepoList, SourceRepoProblem)]
-> CabalInstallException
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

-- | 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 where
  displayException :: CabalFileParseError -> String
displayException = CabalFileParseError -> String
renderCabalFileParseError

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)

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]
++ HashValue -> String
showHashValue HashValue
locationHash
  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 :: HashValue
    locationHash :: HashValue
locationHash = ByteString -> HashValue
hashValue (String -> ByteString
toUTF8LBS ((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 :: forall (f :: * -> *). SourceRepositoryPackage f -> String
srpLocation :: String
srpLocation} =
  String -> String
mangleName String
srpLocation String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HashValue -> String
showHashValue HashValue
locationHash
  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 :: HashValue
    locationHash :: HashValue
locationHash =
      ByteString -> HashValue
hashValue (ByteString -> HashValue) -> ByteString -> HashValue
forall a b. (a -> b) -> a -> b
$
        [ByteString] -> ByteString
LBS.fromChunks [String -> ByteString
toUTF8BS String
srpLocation, String -> ByteString
toUTF8BS (RepoType -> String
forall a. Show a => a -> String
show RepoType
srpType)]

-- | 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
n Int -> 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)]
  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)

instance Exception BadPerPackageCompilerPaths where
  displayException :: BadPerPackageCompilerPaths -> String
displayException = BadPerPackageCompilerPaths -> String
renderBadPerPackageCompilerPaths

-- 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)

-- | Filter out non-top-level project configs.
onlyTopLevelProvenance :: Set ProjectConfigProvenance -> Set ProjectConfigProvenance
onlyTopLevelProvenance :: Set ProjectConfigProvenance -> Set ProjectConfigProvenance
onlyTopLevelProvenance = (ProjectConfigProvenance -> Bool)
-> Set ProjectConfigProvenance -> Set ProjectConfigProvenance
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((ProjectConfigProvenance -> Bool)
 -> Set ProjectConfigProvenance -> Set ProjectConfigProvenance)
-> (ProjectConfigProvenance -> Bool)
-> Set ProjectConfigProvenance
-> Set ProjectConfigProvenance
forall a b. (a -> b) -> a -> b
$ \case
  ProjectConfigProvenance
Implicit -> Bool
False
  Explicit ProjectConfigPath
ps -> ProjectConfigPath -> Bool
isTopLevelConfigPath ProjectConfigPath
ps