{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

-- | Dealing with Cabal.


module Stack.Package
  (readDotBuildinfo
  ,resolvePackage
  ,packageFromPackageDescription
  ,Package(..)
  ,PackageDescriptionPair(..)
  ,GetPackageFiles(..)
  ,GetPackageOpts(..)
  ,PackageConfig(..)
  ,buildLogPath
  ,PackageException (..)
  ,resolvePackageDescription
  ,packageDependencies
  ,applyForceCustomBuild
  ) where

import           Data.List (find, isPrefixOf, unzip)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import           Distribution.CabalSpecVersion
import           Distribution.Compiler
import           Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as Cabal
import           Distribution.Package hiding (Package, packageName, packageVersion, PackageIdentifier)
import           Distribution.PackageDescription hiding (FlagName)
#if !MIN_VERSION_Cabal(3,8,1)
import           Distribution.PackageDescription.Parsec
#endif
import           Distribution.Pretty (prettyShow)
import           Distribution.Simple.Glob (matchDirFileGlob)
#if MIN_VERSION_Cabal(3,8,1)
import           Distribution.Simple.PackageDescription (readHookedBuildInfo)
#endif
import           Distribution.System (OS (..), Arch, Platform (..))
import           Distribution.Text (display)
import qualified Distribution.Types.CondTree as Cabal
import qualified Distribution.Types.ExeDependency as Cabal
import qualified Distribution.Types.LegacyExeDependency as Cabal
import           Distribution.Types.MungedPackageName
import qualified Distribution.Types.UnqualComponentName as Cabal
import           Distribution.Utils.Path (getSymbolicPath)
import           Distribution.Verbosity (silent)
import           Distribution.Version (mkVersion, orLaterVersion, anyVersion)
import qualified HiFileParser as Iface
import           Path as FL hiding (replaceExtension)
import           Path.Extra
import           Path.IO hiding (findFiles)
import           Stack.Build.Installed
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Prelude hiding (Display (..))
import           Stack.Types.Compiler
import           Stack.Types.Config
import           Stack.Types.GhcPkgId
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.Version
import qualified System.Directory as D (doesFileExist)
import           System.FilePath (replaceExtension)
import qualified System.FilePath as FilePath
import           System.IO.Error
import           RIO.Process
import           RIO.PrettyPrint
import qualified RIO.PrettyPrint as PP (Style (Module))

data Ctx = Ctx { Ctx -> Path Abs File
ctxFile :: !(Path Abs File)
               , Ctx -> Path Abs Dir
ctxDistDir :: !(Path Abs Dir)
               , Ctx -> BuildConfig
ctxBuildConfig :: !BuildConfig
               , Ctx -> Version
ctxCabalVer :: !Version
               }

instance HasPlatform Ctx
instance HasGHCVariant Ctx
instance HasLogFunc Ctx where
    logFuncL :: Lens' Ctx LogFunc
logFuncL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasLogFunc env => Lens' env LogFunc
logFuncL
instance HasRunner Ctx where
    runnerL :: Lens' Ctx Runner
runnerL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasRunner env => Lens' env Runner
runnerL
instance HasStylesUpdate Ctx where
  stylesUpdateL :: Lens' Ctx StylesUpdate
stylesUpdateL = forall env. HasRunner env => Lens' env Runner
runnerLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasStylesUpdate env => Lens' env StylesUpdate
stylesUpdateL
instance HasTerm Ctx where
  useColorL :: Lens' Ctx Bool
useColorL = forall env. HasRunner env => Lens' env Runner
runnerLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasTerm env => Lens' env Bool
useColorL
  termWidthL :: Lens' Ctx Int
termWidthL = forall env. HasRunner env => Lens' env Runner
runnerLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasTerm env => Lens' env Int
termWidthL
instance HasConfig Ctx
instance HasPantryConfig Ctx where
    pantryConfigL :: Lens' Ctx PantryConfig
pantryConfigL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
instance HasProcessContext Ctx where
    processContextL :: Lens' Ctx ProcessContext
processContextL = forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
instance HasBuildConfig Ctx where
    buildConfigL :: Lens' Ctx BuildConfig
buildConfigL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Ctx -> BuildConfig
ctxBuildConfig (\Ctx
x BuildConfig
y -> Ctx
x { ctxBuildConfig :: BuildConfig
ctxBuildConfig = BuildConfig
y })

-- | Read @<package>.buildinfo@ ancillary files produced by some Setup.hs hooks.

-- The file includes Cabal file syntax to be merged into the package description

-- derived from the package's .cabal file.

--

-- NOTE: not to be confused with BuildInfo, an Stack-internal datatype.

readDotBuildinfo :: MonadIO m
                 => Path Abs File
                 -> m HookedBuildInfo
readDotBuildinfo :: forall (m :: * -> *).
MonadIO m =>
Path Abs File -> m HookedBuildInfo
readDotBuildinfo Path Abs File
buildinfofp =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO HookedBuildInfo
readHookedBuildInfo Verbosity
silent (forall b t. Path b t -> String
toFilePath Path Abs File
buildinfofp)

-- | Resolve a parsed cabal file into a 'Package', which contains all of

-- the info needed for stack to build the 'Package' given the current

-- configuration.

resolvePackage :: PackageConfig
               -> GenericPackageDescription
               -> Package
resolvePackage :: PackageConfig -> GenericPackageDescription -> Package
resolvePackage PackageConfig
packageConfig GenericPackageDescription
gpkg =
    PackageConfig -> [PackageFlag] -> PackageDescriptionPair -> Package
packageFromPackageDescription
        PackageConfig
packageConfig
        (GenericPackageDescription -> [PackageFlag]
genPackageFlags GenericPackageDescription
gpkg)
        (PackageConfig
-> GenericPackageDescription -> PackageDescriptionPair
resolvePackageDescription PackageConfig
packageConfig GenericPackageDescription
gpkg)

packageFromPackageDescription :: PackageConfig
                              -> [PackageFlag]
                              -> PackageDescriptionPair
                              -> Package
packageFromPackageDescription :: PackageConfig -> [PackageFlag] -> PackageDescriptionPair -> Package
packageFromPackageDescription PackageConfig
packageConfig [PackageFlag]
pkgFlags (PackageDescriptionPair PackageDescription
pkgNoMod PackageDescription
pkg) =
    Package
    { packageName :: PackageName
packageName = PackageName
name
    , packageVersion :: Version
packageVersion = PackageIdentifier -> Version
pkgVersion PackageIdentifier
pkgId
    , packageLicense :: Either License License
packageLicense = PackageDescription -> Either License License
licenseRaw PackageDescription
pkg
    , packageDeps :: Map PackageName DepValue
packageDeps = Map PackageName DepValue
deps
    , packageFiles :: GetPackageFiles
packageFiles = GetPackageFiles
pkgFiles
    , packageUnknownTools :: Set ExeName
packageUnknownTools = Set ExeName
unknownTools
    , packageGhcOptions :: [Text]
packageGhcOptions = PackageConfig -> [Text]
packageConfigGhcOptions PackageConfig
packageConfig
    , packageCabalConfigOpts :: [Text]
packageCabalConfigOpts = PackageConfig -> [Text]
packageConfigCabalConfigOpts PackageConfig
packageConfig
    , packageFlags :: Map FlagName Bool
packageFlags = PackageConfig -> Map FlagName Bool
packageConfigFlags PackageConfig
packageConfig
    , packageDefaultFlags :: Map FlagName Bool
packageDefaultFlags = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      [(PackageFlag -> FlagName
flagName PackageFlag
flag, PackageFlag -> Bool
flagDefault PackageFlag
flag) | PackageFlag
flag <- [PackageFlag]
pkgFlags]
    , packageAllDeps :: Set PackageName
packageAllDeps = forall a. Ord a => [a] -> Set a
S.fromList (forall k a. Map k a -> [k]
M.keys Map PackageName DepValue
deps)
    , packageLibraries :: PackageLibraries
packageLibraries =
        let mlib :: Maybe Library
mlib = do
              Library
lib <- PackageDescription -> Maybe Library
library PackageDescription
pkg
              forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ BuildInfo -> Bool
buildable forall a b. (a -> b) -> a -> b
$ Library -> BuildInfo
libBuildInfo Library
lib
              forall a. a -> Maybe a
Just Library
lib
         in
          case Maybe Library
mlib of
            Maybe Library
Nothing -> PackageLibraries
NoLibraries
            Just Library
_ -> Set Text -> PackageLibraries
HasLibraries Set Text
foreignLibNames
    , packageInternalLibraries :: Set Text
packageInternalLibraries = Set Text
subLibNames
    , packageTests :: Map Text TestSuiteInterface
packageTests = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      [(String -> Text
T.pack (UnqualComponentName -> String
Cabal.unUnqualComponentName forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
testName TestSuite
t), TestSuite -> TestSuiteInterface
testInterface TestSuite
t)
          | TestSuite
t <- PackageDescription -> [TestSuite]
testSuites PackageDescription
pkgNoMod
          , BuildInfo -> Bool
buildable (TestSuite -> BuildInfo
testBuildInfo TestSuite
t)
      ]
    , packageBenchmarks :: Set Text
packageBenchmarks = forall a. Ord a => [a] -> Set a
S.fromList
      [String -> Text
T.pack (UnqualComponentName -> String
Cabal.unUnqualComponentName forall a b. (a -> b) -> a -> b
$ Benchmark -> UnqualComponentName
benchmarkName Benchmark
b)
          | Benchmark
b <- PackageDescription -> [Benchmark]
benchmarks PackageDescription
pkgNoMod
          , BuildInfo -> Bool
buildable (Benchmark -> BuildInfo
benchmarkBuildInfo Benchmark
b)
      ]
        -- Same comment about buildable applies here too.

    , packageExes :: Set Text
packageExes = forall a. Ord a => [a] -> Set a
S.fromList
      [String -> Text
T.pack (UnqualComponentName -> String
Cabal.unUnqualComponentName forall a b. (a -> b) -> a -> b
$ Executable -> UnqualComponentName
exeName Executable
biBuildInfo)
        | Executable
biBuildInfo <- PackageDescription -> [Executable]
executables PackageDescription
pkg
                                    , BuildInfo -> Bool
buildable (Executable -> BuildInfo
buildInfo Executable
biBuildInfo)]
    -- This is an action used to collect info needed for "stack ghci".

    -- This info isn't usually needed, so computation of it is deferred.

    , packageOpts :: GetPackageOpts
packageOpts = (forall env.
 HasEnvConfig env =>
 InstallMap
 -> InstalledMap
 -> [PackageName]
 -> [PackageName]
 -> Path Abs File
 -> RIO
      env
      (Map NamedComponent (Map ModuleName (Path Abs File)),
       Map NamedComponent [DotCabalPath],
       Map NamedComponent BuildInfoOpts))
-> GetPackageOpts
GetPackageOpts forall a b. (a -> b) -> a -> b
$
      \InstallMap
installMap InstalledMap
installedMap [PackageName]
omitPkgs [PackageName]
addPkgs Path Abs File
cabalfp ->
           do (Map NamedComponent (Map ModuleName (Path Abs File))
componentsModules,Map NamedComponent [DotCabalPath]
componentFiles,Set (Path Abs File)
_,[PackageWarning]
_) <- GetPackageFiles
-> forall env.
   HasEnvConfig env =>
   Path Abs File
   -> RIO
        env
        (Map NamedComponent (Map ModuleName (Path Abs File)),
         Map NamedComponent [DotCabalPath], Set (Path Abs File),
         [PackageWarning])
getPackageFiles GetPackageFiles
pkgFiles Path Abs File
cabalfp
              let internals :: [Text]
internals = forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Set NamedComponent -> Set Text
internalLibComponents forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
M.keysSet Map NamedComponent (Map ModuleName (Path Abs File))
componentsModules
              [PackageName]
excludedInternals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [Text]
internals
              [PackageName]
mungedInternals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). MonadThrow m => String -> m PackageName
parsePackageNameThrowing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                       Text -> Text
toInternalPackageMungedName) [Text]
internals
              Map NamedComponent BuildInfoOpts
componentsOpts <-
                  forall env (m :: * -> *).
(HasEnvConfig env, MonadThrow m, MonadReader env m, MonadIO m) =>
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Path Abs File
-> PackageDescription
-> Map NamedComponent [DotCabalPath]
-> m (Map NamedComponent BuildInfoOpts)
generatePkgDescOpts InstallMap
installMap InstalledMap
installedMap
                  ([PackageName]
excludedInternals forall a. [a] -> [a] -> [a]
++ [PackageName]
omitPkgs) ([PackageName]
mungedInternals forall a. [a] -> [a] -> [a]
++ [PackageName]
addPkgs)
                  Path Abs File
cabalfp PackageDescription
pkg Map NamedComponent [DotCabalPath]
componentFiles
              forall (m :: * -> *) a. Monad m => a -> m a
return (Map NamedComponent (Map ModuleName (Path Abs File))
componentsModules,Map NamedComponent [DotCabalPath]
componentFiles,Map NamedComponent BuildInfoOpts
componentsOpts)
    , packageHasExposedModules :: Bool
packageHasExposedModules = forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          Bool
False
          (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> [ModuleName]
exposedModules)
          (PackageDescription -> Maybe Library
library PackageDescription
pkg)
    , packageBuildType :: BuildType
packageBuildType = PackageDescription -> BuildType
buildType PackageDescription
pkg
    , packageSetupDeps :: Maybe (Map PackageName VersionRange)
packageSetupDeps = Maybe (Map PackageName VersionRange)
msetupDeps
    , packageCabalSpec :: CabalSpecVersion
packageCabalSpec = PackageDescription -> CabalSpecVersion
specVersion PackageDescription
pkg
    }
  where
    extraLibNames :: Set Text
extraLibNames = forall a. Ord a => Set a -> Set a -> Set a
S.union Set Text
subLibNames Set Text
foreignLibNames

    subLibNames :: Set Text
subLibNames
      = forall a. Ord a => [a] -> Set a
S.fromList
      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> String
Cabal.unUnqualComponentName)
      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (LibraryName -> Maybe UnqualComponentName
libraryNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> LibraryName
libName) -- this is a design bug in the Cabal API: this should statically be known to exist

      forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (BuildInfo -> Bool
buildable forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> BuildInfo
libBuildInfo)
      forall a b. (a -> b) -> a -> b
$ PackageDescription -> [Library]
subLibraries PackageDescription
pkg

    foreignLibNames :: Set Text
foreignLibNames
      = forall a. Ord a => [a] -> Set a
S.fromList
      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> String
Cabal.unUnqualComponentName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignLib -> UnqualComponentName
foreignLibName)
      forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (BuildInfo -> Bool
buildable forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignLib -> BuildInfo
foreignLibBuildInfo)
      forall a b. (a -> b) -> a -> b
$ PackageDescription -> [ForeignLib]
foreignLibs PackageDescription
pkg

    toInternalPackageMungedName :: Text -> Text
toInternalPackageMungedName
      = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> String
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> LibraryName -> MungedPackageName
MungedPackageName (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe UnqualComponentName -> LibraryName
maybeToLibraryName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnqualComponentName
Cabal.mkUnqualComponentName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

    -- Gets all of the modules, files, build files, and data files that

    -- constitute the package. This is primarily used for dirtiness

    -- checking during build, as well as use by "stack ghci"

    pkgFiles :: GetPackageFiles
pkgFiles = (forall env.
 HasEnvConfig env =>
 Path Abs File
 -> RIO
      env
      (Map NamedComponent (Map ModuleName (Path Abs File)),
       Map NamedComponent [DotCabalPath], Set (Path Abs File),
       [PackageWarning]))
-> GetPackageFiles
GetPackageFiles forall a b. (a -> b) -> a -> b
$
        \Path Abs File
cabalfp -> forall env (m :: * -> *) a.
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m,
 MonadUnliftIO m) =>
StyleDoc -> m a -> m a
debugBracket (StyleDoc
"getPackageFiles" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalfp) forall a b. (a -> b) -> a -> b
$ do
             let pkgDir :: Path Abs Dir
pkgDir = forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp
             Path Abs Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
             BuildConfig
bc <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL
             Version
cabalVer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasCompiler env => SimpleGetter env Version
cabalVersionL
             (Map NamedComponent (Map ModuleName (Path Abs File))
componentModules,Map NamedComponent [DotCabalPath]
componentFiles,Set (Path Abs File)
dataFiles',[PackageWarning]
warnings) <-
                 forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO
                     (Path Abs File -> Path Abs Dir -> BuildConfig -> Version -> Ctx
Ctx Path Abs File
cabalfp Path Abs Dir
distDir BuildConfig
bc Version
cabalVer)
                     (PackageDescription
-> RIO
     Ctx
     (Map NamedComponent (Map ModuleName (Path Abs File)),
      Map NamedComponent [DotCabalPath], Set (Path Abs File),
      [PackageWarning])
packageDescModulesAndFiles PackageDescription
pkg)
             Set (Path Abs File)
setupFiles <-
                 if PackageDescription -> BuildType
buildType PackageDescription
pkg forall a. Eq a => a -> a -> Bool
== BuildType
Custom
                 then do
                     let setupHsPath :: Path Abs File
setupHsPath = Path Abs Dir
pkgDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileSetupHs
                         setupLhsPath :: Path Abs File
setupLhsPath = Path Abs Dir
pkgDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileSetupLhs
                     Bool
setupHsExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
setupHsPath
                     if Bool
setupHsExists then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Set a
S.singleton Path Abs File
setupHsPath) else do
                         Bool
setupLhsExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
setupLhsPath
                         if Bool
setupLhsExists then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Set a
S.singleton Path Abs File
setupLhsPath) else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Set a
S.empty
                 else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Set a
S.empty
             Set (Path Abs File)
buildFiles <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Ord a => a -> Set a -> Set a
S.insert Path Abs File
cabalfp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => Set a -> Set a -> Set a
S.union Set (Path Abs File)
setupFiles) forall a b. (a -> b) -> a -> b
$ do
                 let hpackPath :: Path Abs File
hpackPath = Path Abs Dir
pkgDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileHpackPackageConfig
                 Bool
hpackExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
hpackPath
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
hpackExists then forall a. a -> Set a
S.singleton Path Abs File
hpackPath else forall a. Set a
S.empty
             forall (m :: * -> *) a. Monad m => a -> m a
return (Map NamedComponent (Map ModuleName (Path Abs File))
componentModules, Map NamedComponent [DotCabalPath]
componentFiles, Set (Path Abs File)
buildFiles forall a. Semigroup a => a -> a -> a
<> Set (Path Abs File)
dataFiles', [PackageWarning]
warnings)
    pkgId :: PackageIdentifier
pkgId = PackageDescription -> PackageIdentifier
package PackageDescription
pkg
    name :: PackageName
name = PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId

    (Set ExeName
unknownTools, Map PackageName DepValue
knownTools) = PackageDescription -> (Set ExeName, Map PackageName DepValue)
packageDescTools PackageDescription
pkg

    deps :: Map PackageName DepValue
deps = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Bool
isMe) (forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith forall a. Semigroup a => a -> a -> a
(<>)
        [ VersionRange -> DepValue
asLibrary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageConfig -> PackageDescription -> Map PackageName VersionRange
packageDependencies PackageConfig
packageConfig PackageDescription
pkg
        -- We include all custom-setup deps - if present - in the

        -- package deps themselves. Stack always works with the

        -- invariant that there will be a single installed package

        -- relating to a package name, and this applies at the setup

        -- dependency level as well.

        , VersionRange -> DepValue
asLibrary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> Maybe a -> a
fromMaybe forall k a. Map k a
M.empty Maybe (Map PackageName VersionRange)
msetupDeps
        , Map PackageName DepValue
knownTools
        ])
    msetupDeps :: Maybe (Map PackageName VersionRange)
msetupDeps = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Dependency -> PackageName
depPkgName forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Dependency -> VersionRange
depVerRange) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetupBuildInfo -> [Dependency]
setupDepends)
        (PackageDescription -> Maybe SetupBuildInfo
setupBuildInfo PackageDescription
pkg)

    asLibrary :: VersionRange -> DepValue
asLibrary VersionRange
range = DepValue
      { dvVersionRange :: VersionRange
dvVersionRange = VersionRange
range
      , dvType :: DepType
dvType = DepType
AsLibrary
      }

    -- Is the package dependency mentioned here me: either the package

    -- name itself, or the name of one of the sub libraries

    isMe :: PackageName -> Bool
isMe PackageName
name' = PackageName
name' forall a. Eq a => a -> a -> Bool
== PackageName
name Bool -> Bool -> Bool
|| forall a. IsString a => String -> a
fromString (PackageName -> String
packageNameString PackageName
name') forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
extraLibNames

-- | Generate GHC options for the package's components, and a list of

-- options which apply generally to the package, not one specific

-- component.

generatePkgDescOpts
    :: (HasEnvConfig env, MonadThrow m, MonadReader env m, MonadIO m)
    => InstallMap
    -> InstalledMap
    -> [PackageName] -- ^ Packages to omit from the "-package" / "-package-id" flags

    -> [PackageName] -- ^ Packages to add to the "-package" flags

    -> Path Abs File
    -> PackageDescription
    -> Map NamedComponent [DotCabalPath]
    -> m (Map NamedComponent BuildInfoOpts)
generatePkgDescOpts :: forall env (m :: * -> *).
(HasEnvConfig env, MonadThrow m, MonadReader env m, MonadIO m) =>
InstallMap
-> InstalledMap
-> [PackageName]
-> [PackageName]
-> Path Abs File
-> PackageDescription
-> Map NamedComponent [DotCabalPath]
-> m (Map NamedComponent BuildInfoOpts)
generatePkgDescOpts InstallMap
installMap InstalledMap
installedMap [PackageName]
omitPkgs [PackageName]
addPkgs Path Abs File
cabalfp PackageDescription
pkg Map NamedComponent [DotCabalPath]
componentPaths = do
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    Version
cabalVer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasCompiler env => SimpleGetter env Version
cabalVersionL
    Path Abs Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
cabalDir
    let generate :: NamedComponent -> BuildInfo -> (NamedComponent, BuildInfoOpts)
generate NamedComponent
namedComponent BuildInfo
binfo =
            ( NamedComponent
namedComponent
            , BioInput -> BuildInfoOpts
generateBuildInfoOpts BioInput
                { biInstallMap :: InstallMap
biInstallMap = InstallMap
installMap
                , biInstalledMap :: InstalledMap
biInstalledMap = InstalledMap
installedMap
                , biCabalDir :: Path Abs Dir
biCabalDir = Path Abs Dir
cabalDir
                , biDistDir :: Path Abs Dir
biDistDir = Path Abs Dir
distDir
                , biOmitPackages :: [PackageName]
biOmitPackages = [PackageName]
omitPkgs
                , biAddPackages :: [PackageName]
biAddPackages = [PackageName]
addPkgs
                , biBuildInfo :: BuildInfo
biBuildInfo = BuildInfo
binfo
                , biDotCabalPaths :: [DotCabalPath]
biDotCabalPaths = forall a. a -> Maybe a -> a
fromMaybe [] (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup NamedComponent
namedComponent Map NamedComponent [DotCabalPath]
componentPaths)
                , biConfigLibDirs :: [String]
biConfigLibDirs = Config -> [String]
configExtraLibDirs Config
config
                , biConfigIncludeDirs :: [String]
biConfigIncludeDirs = Config -> [String]
configExtraIncludeDirs Config
config
                , biComponentName :: NamedComponent
biComponentName = NamedComponent
namedComponent
                , biCabalVersion :: Version
biCabalVersion = Version
cabalVer
                }
            )
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
              (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                   [ forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                         []
                         (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> BuildInfo -> (NamedComponent, BuildInfoOpts)
generate NamedComponent
CLib forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> BuildInfo
libBuildInfo)
                         (PackageDescription -> Maybe Library
library PackageDescription
pkg)
                   , forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                         (\Library
sublib -> do
                            let maybeLib :: Maybe NamedComponent
maybeLib = Text -> NamedComponent
CInternalLib forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> String
Cabal.unUnqualComponentName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LibraryName -> Maybe UnqualComponentName
libraryNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> LibraryName
libName) Library
sublib
                            forall a b c. (a -> b -> c) -> b -> a -> c
flip NamedComponent -> BuildInfo -> (NamedComponent, BuildInfoOpts)
generate  (Library -> BuildInfo
libBuildInfo Library
sublib) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe NamedComponent
maybeLib
                          )
                         (PackageDescription -> [Library]
subLibraries PackageDescription
pkg)
                   , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                         (\Executable
exe ->
                               NamedComponent -> BuildInfo -> (NamedComponent, BuildInfoOpts)
generate
                                    (Text -> NamedComponent
CExe (String -> Text
T.pack (UnqualComponentName -> String
Cabal.unUnqualComponentName (Executable -> UnqualComponentName
exeName Executable
exe))))
                                    (Executable -> BuildInfo
buildInfo Executable
exe))
                         (PackageDescription -> [Executable]
executables PackageDescription
pkg)
                   , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                         (\Benchmark
bench ->
                               NamedComponent -> BuildInfo -> (NamedComponent, BuildInfoOpts)
generate
                                    (Text -> NamedComponent
CBench (String -> Text
T.pack (UnqualComponentName -> String
Cabal.unUnqualComponentName (Benchmark -> UnqualComponentName
benchmarkName Benchmark
bench))))
                                    (Benchmark -> BuildInfo
benchmarkBuildInfo Benchmark
bench))
                         (PackageDescription -> [Benchmark]
benchmarks PackageDescription
pkg)
                   , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                         (\TestSuite
test ->
                               NamedComponent -> BuildInfo -> (NamedComponent, BuildInfoOpts)
generate
                                    (Text -> NamedComponent
CTest (String -> Text
T.pack (UnqualComponentName -> String
Cabal.unUnqualComponentName (TestSuite -> UnqualComponentName
testName TestSuite
test))))
                                    (TestSuite -> BuildInfo
testBuildInfo TestSuite
test))
                         (PackageDescription -> [TestSuite]
testSuites PackageDescription
pkg)]))
  where
    cabalDir :: Path Abs Dir
cabalDir = forall b t. Path b t -> Path b Dir
parent Path Abs File
cabalfp

-- | Input to 'generateBuildInfoOpts'

data BioInput = BioInput
    { BioInput -> InstallMap
biInstallMap :: !InstallMap
    , BioInput -> InstalledMap
biInstalledMap :: !InstalledMap
    , BioInput -> Path Abs Dir
biCabalDir :: !(Path Abs Dir)
    , BioInput -> Path Abs Dir
biDistDir :: !(Path Abs Dir)
    , BioInput -> [PackageName]
biOmitPackages :: ![PackageName]
    , BioInput -> [PackageName]
biAddPackages :: ![PackageName]
    , BioInput -> BuildInfo
biBuildInfo :: !BuildInfo
    , BioInput -> [DotCabalPath]
biDotCabalPaths :: ![DotCabalPath]
    , BioInput -> [String]
biConfigLibDirs :: ![FilePath]
    , BioInput -> [String]
biConfigIncludeDirs :: ![FilePath]
    , BioInput -> NamedComponent
biComponentName :: !NamedComponent
    , BioInput -> Version
biCabalVersion :: !Version
    }

-- | Generate GHC options for the target. Since Cabal also figures out

-- these options, currently this is only used for invoking GHCI (via

-- stack ghci).

generateBuildInfoOpts :: BioInput -> BuildInfoOpts
generateBuildInfoOpts :: BioInput -> BuildInfoOpts
generateBuildInfoOpts BioInput {[String]
[PackageName]
[DotCabalPath]
InstallMap
InstalledMap
Version
Path Abs Dir
BuildInfo
NamedComponent
biCabalVersion :: Version
biComponentName :: NamedComponent
biConfigIncludeDirs :: [String]
biConfigLibDirs :: [String]
biDotCabalPaths :: [DotCabalPath]
biBuildInfo :: BuildInfo
biAddPackages :: [PackageName]
biOmitPackages :: [PackageName]
biDistDir :: Path Abs Dir
biCabalDir :: Path Abs Dir
biInstalledMap :: InstalledMap
biInstallMap :: InstallMap
biCabalVersion :: BioInput -> Version
biComponentName :: BioInput -> NamedComponent
biConfigIncludeDirs :: BioInput -> [String]
biConfigLibDirs :: BioInput -> [String]
biDotCabalPaths :: BioInput -> [DotCabalPath]
biBuildInfo :: BioInput -> BuildInfo
biAddPackages :: BioInput -> [PackageName]
biOmitPackages :: BioInput -> [PackageName]
biDistDir :: BioInput -> Path Abs Dir
biCabalDir :: BioInput -> Path Abs Dir
biInstalledMap :: BioInput -> InstalledMap
biInstallMap :: BioInput -> InstallMap
..} =
    BuildInfoOpts
        { bioOpts :: [String]
bioOpts = [String]
ghcOpts forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"-optP" forall a. Semigroup a => a -> a -> a
<>) (BuildInfo -> [String]
cppOptions BuildInfo
biBuildInfo)
        -- NOTE for future changes: Due to this use of nubOrd (and other uses

        -- downstream), these generated options must not rely on multiple

        -- argument sequences.  For example, ["--main-is", "Foo.hs", "--main-

        -- is", "Bar.hs"] would potentially break due to the duplicate

        -- "--main-is" being removed.

        --

        -- See https://github.com/commercialhaskell/stack/issues/1255

        , bioOneWordOpts :: [String]
bioOneWordOpts = forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [[String]
extOpts, [String]
srcOpts, [String]
includeOpts, [String]
libOpts, [String]
fworks, [String]
cObjectFiles]
        , bioPackageFlags :: [String]
bioPackageFlags = [String]
deps
        , bioCabalMacros :: Path Abs File
bioCabalMacros = Path Abs Dir
componentAutogen forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileCabalMacrosH
        }
  where
    cObjectFiles :: [String]
cObjectFiles =
        forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b t. Path b t -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                  forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir
-> NamedComponent
-> Path Abs Dir
-> Path Abs File
-> m (Path Abs File)
makeObjectFilePathFromC Path Abs Dir
biCabalDir NamedComponent
biComponentName Path Abs Dir
biDistDir)
                 [Path Abs File]
cfiles
    cfiles :: [Path Abs File]
cfiles = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalPath -> Maybe (Path Abs File)
dotCabalCFilePath [DotCabalPath]
biDotCabalPaths
    installVersion :: (a, b) -> b
installVersion = forall a b. (a, b) -> b
snd
    -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ...

    deps :: [String]
deps =
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name InstalledMap
biInstalledMap of
                Just (InstallLocation
_, Stack.Types.Package.Library PackageIdentifier
_ident GhcPkgId
ipid Maybe (Either License License)
_) -> [String
"-package-id=" forall a. Semigroup a => a -> a -> a
<> GhcPkgId -> String
ghcPkgIdString GhcPkgId
ipid]
                Maybe (InstallLocation, Installed)
_ -> [String
"-package=" forall a. Semigroup a => a -> a -> a
<> PackageName -> String
packageNameString PackageName
name forall a. Semigroup a => a -> a -> a
<>
                 forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" -- This empty case applies to e.g. base.

                     (((String
"-" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
versionString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
installVersion)
                     (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PackageName
name InstallMap
biInstallMap)]
            | PackageName
name <- [PackageName]
pkgs]
    pkgs :: [PackageName]
pkgs =
        [PackageName]
biAddPackages forall a. [a] -> [a] -> [a]
++
        [ PackageName
name
        | Dependency PackageName
name VersionRange
_ NonEmptySet LibraryName
_ <- BuildInfo -> [Dependency]
targetBuildDepends BuildInfo
biBuildInfo -- TODO: cabal 3 introduced multiple public libraries in a single dependency

        , PackageName
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageName]
biOmitPackages]
    PerCompilerFlavor [String]
ghcOpts [String]
_ = BuildInfo -> PerCompilerFlavor [String]
options BuildInfo
biBuildInfo
    extOpts :: [String]
extOpts = forall a b. (a -> b) -> [a] -> [b]
map ((String
"-X" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> String
display) (BuildInfo -> [Extension]
usedExtensions BuildInfo
biBuildInfo)
    srcOpts :: [String]
srcOpts =
        forall a b. (a -> b) -> [a] -> [b]
map ((String
"-i" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Path loc Dir -> String
toFilePathNoTrailingSep)
            (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [ Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentBuildDir Version
biCabalVersion NamedComponent
biComponentName Path Abs Dir
biDistDir ]
              , [ Path Abs Dir
biCabalDir
                | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
biBuildInfo)
                ]
              , forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Maybe (Path Abs Dir)
toIncludeDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall from to. SymbolicPath from to -> String
getSymbolicPath) (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
biBuildInfo)
              , [ Path Abs Dir
componentAutogen ]
              , forall a. Maybe a -> [a]
maybeToList (Version -> Path Abs Dir -> Maybe (Path Abs Dir)
packageAutogenDir Version
biCabalVersion Path Abs Dir
biDistDir)
              , [ NamedComponent -> Path Abs Dir -> Path Abs Dir
componentOutputDir NamedComponent
biComponentName Path Abs Dir
biDistDir ]
              ]) forall a. [a] -> [a] -> [a]
++
        [ String
"-stubdir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
biDistDir) ]
    componentAutogen :: Path Abs Dir
componentAutogen = Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentAutogenDir Version
biCabalVersion NamedComponent
biComponentName Path Abs Dir
biDistDir
    toIncludeDir :: String -> Maybe (Path Abs Dir)
toIncludeDir String
"." = forall a. a -> Maybe a
Just Path Abs Dir
biCabalDir
    toIncludeDir String
relDir = forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir -> String -> m (Path Abs Dir)
concatAndCollapseAbsDir Path Abs Dir
biCabalDir String
relDir
    includeOpts :: [String]
includeOpts =
        forall a b. (a -> b) -> [a] -> [b]
map (String
"-I" forall a. Semigroup a => a -> a -> a
<>) ([String]
biConfigIncludeDirs forall a. Semigroup a => a -> a -> a
<> [String]
pkgIncludeOpts)
    pkgIncludeOpts :: [String]
pkgIncludeOpts =
        [ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
absDir
        | String
dir <- BuildInfo -> [String]
includeDirs BuildInfo
biBuildInfo
        , Path Abs Dir
absDir <- String -> [Path Abs Dir]
handleDir String
dir
        ]
    libOpts :: [String]
libOpts =
        forall a b. (a -> b) -> [a] -> [b]
map (String
"-l" forall a. Semigroup a => a -> a -> a
<>) (BuildInfo -> [String]
extraLibs BuildInfo
biBuildInfo) forall a. Semigroup a => a -> a -> a
<>
        forall a b. (a -> b) -> [a] -> [b]
map (String
"-L" forall a. Semigroup a => a -> a -> a
<>) ([String]
biConfigLibDirs forall a. Semigroup a => a -> a -> a
<> [String]
pkgLibDirs)
    pkgLibDirs :: [String]
pkgLibDirs =
        [ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
absDir
        | String
dir <- BuildInfo -> [String]
extraLibDirs BuildInfo
biBuildInfo
        , Path Abs Dir
absDir <- String -> [Path Abs Dir]
handleDir String
dir
        ]
    handleDir :: String -> [Path Abs Dir]
handleDir String
dir = case (forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir String
dir, forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
dir) of
       (Just Path Abs Dir
ab, Maybe (Path Rel Dir)
_       ) -> [Path Abs Dir
ab]
       (Maybe (Path Abs Dir)
_      , Just Path Rel Dir
rel) -> [Path Abs Dir
biCabalDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
rel]
       (Maybe (Path Abs Dir)
Nothing, Maybe (Path Rel Dir)
Nothing ) -> []
    fworks :: [String]
fworks = forall a b. (a -> b) -> [a] -> [b]
map (\String
fwk -> String
"-framework=" forall a. Semigroup a => a -> a -> a
<> String
fwk) (BuildInfo -> [String]
frameworks BuildInfo
biBuildInfo)

-- | Make the .o path from the .c file path for a component. Example:

--

-- @

-- executable FOO

--   c-sources:        cbits/text_search.c

-- @

--

-- Produces

--

-- <dist-dir>/build/FOO/FOO-tmp/cbits/text_search.o

--

-- Example:

--

-- λ> makeObjectFilePathFromC

--     $(mkAbsDir "/Users/chris/Repos/hoogle")

--     CLib

--     $(mkAbsDir "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist")

--     $(mkAbsFile "/Users/chris/Repos/hoogle/cbits/text_search.c")

-- Just "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist/build/cbits/text_search.o"

-- λ> makeObjectFilePathFromC

--     $(mkAbsDir "/Users/chris/Repos/hoogle")

--     (CExe "hoogle")

--     $(mkAbsDir "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist")

--     $(mkAbsFile "/Users/chris/Repos/hoogle/cbits/text_search.c")

-- Just "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist/build/hoogle/hoogle-tmp/cbits/text_search.o"

-- λ>

makeObjectFilePathFromC
    :: MonadThrow m
    => Path Abs Dir          -- ^ The cabal directory.

    -> NamedComponent        -- ^ The name of the component.

    -> Path Abs Dir          -- ^ Dist directory.

    -> Path Abs File         -- ^ The path to the .c file.

    -> m (Path Abs File) -- ^ The path to the .o file for the component.

makeObjectFilePathFromC :: forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir
-> NamedComponent
-> Path Abs Dir
-> Path Abs File
-> m (Path Abs File)
makeObjectFilePathFromC Path Abs Dir
cabalDir NamedComponent
namedComponent Path Abs Dir
distDir Path Abs File
cFilePath = do
    Path Rel File
relCFilePath <- forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
cabalDir Path Abs File
cFilePath
    Path Rel File
relOFilePath <-
        forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String -> String -> String
replaceExtension (forall b t. Path b t -> String
toFilePath Path Rel File
relCFilePath) String
"o")
    forall (m :: * -> *) a. Monad m => a -> m a
return (NamedComponent -> Path Abs Dir -> Path Abs Dir
componentOutputDir NamedComponent
namedComponent Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relOFilePath)

-- | Make the global autogen dir if Cabal version is new enough.

packageAutogenDir :: Version -> Path Abs Dir -> Maybe (Path Abs Dir)
packageAutogenDir :: Version -> Path Abs Dir -> Maybe (Path Abs Dir)
packageAutogenDir Version
cabalVer Path Abs Dir
distDir
    | Version
cabalVer forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2, Int
0] = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirGlobalAutogen

-- | Make the autogen dir.

componentAutogenDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentAutogenDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentAutogenDir Version
cabalVer NamedComponent
component Path Abs Dir
distDir =
    Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentBuildDir Version
cabalVer NamedComponent
component Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirAutogen

-- | See 'Distribution.Simple.LocalBuildInfo.componentBuildDir'

componentBuildDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentBuildDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentBuildDir Version
cabalVer NamedComponent
component Path Abs Dir
distDir
    | Version
cabalVer forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2, Int
0] = Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir
    | Bool
otherwise =
        case NamedComponent
component of
            NamedComponent
CLib -> Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir
            CInternalLib Text
name -> Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Text -> Path Rel Dir
componentNameToDir Text
name
            CExe Text
name -> Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Text -> Path Rel Dir
componentNameToDir Text
name
            CTest Text
name -> Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Text -> Path Rel Dir
componentNameToDir Text
name
            CBench Text
name -> Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Text -> Path Rel Dir
componentNameToDir Text
name

-- | The directory where generated files are put like .o or .hs (from .x files).

componentOutputDir :: NamedComponent -> Path Abs Dir -> Path Abs Dir
componentOutputDir :: NamedComponent -> Path Abs Dir -> Path Abs Dir
componentOutputDir NamedComponent
namedComponent Path Abs Dir
distDir =
    case NamedComponent
namedComponent of
        NamedComponent
CLib -> Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir
        CInternalLib Text
name -> Text -> Path Abs Dir
makeTmp Text
name
        CExe Text
name -> Text -> Path Abs Dir
makeTmp Text
name
        CTest Text
name -> Text -> Path Abs Dir
makeTmp Text
name
        CBench Text
name -> Text -> Path Abs Dir
makeTmp Text
name
  where
    makeTmp :: Text -> Path Abs Dir
makeTmp Text
name =
      Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Text -> Path Rel Dir
componentNameToDir (Text
name forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"-tmp")

-- | Make the build dir. Note that Cabal >= 2.0 uses the

-- 'componentBuildDir' above for some things.

buildDir :: Path Abs Dir -> Path Abs Dir
buildDir :: Path Abs Dir -> Path Abs Dir
buildDir Path Abs Dir
distDir = Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBuild

-- NOTE: don't export this, only use it for valid paths based on

-- component names.

componentNameToDir :: Text -> Path Rel Dir
componentNameToDir :: Text -> Path Rel Dir
componentNameToDir Text
name =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Invariant violated: component names should always parse as directory names")
            (forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (Text -> String
T.unpack Text
name))

-- | Get all dependencies of the package (buildable targets only).

--

-- Note that for Cabal versions 1.22 and earlier, there is a bug where

-- Cabal requires dependencies for non-buildable components to be

-- present. We're going to use GHC version as a proxy for Cabal

-- library version in this case for simplicity, so we'll check for GHC

-- being 7.10 or earlier. This obviously makes our function a lot more

-- fun to write...

packageDependencies
  :: PackageConfig
  -> PackageDescription
  -> Map PackageName VersionRange
packageDependencies :: PackageConfig -> PackageDescription -> Map PackageName VersionRange
packageDependencies PackageConfig
pkgConfig PackageDescription
pkg' =
  forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith VersionRange -> VersionRange -> VersionRange
intersectVersionRanges forall a b. (a -> b) -> a -> b
$
  forall a b. (a -> b) -> [a] -> [b]
map (Dependency -> PackageName
depPkgName forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Dependency -> VersionRange
depVerRange) forall a b. (a -> b) -> a -> b
$
  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BuildInfo -> [Dependency]
targetBuildDepends (PackageDescription -> [BuildInfo]
allBuildInfo' PackageDescription
pkg) forall a. [a] -> [a] -> [a]
++
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] SetupBuildInfo -> [Dependency]
setupDepends (PackageDescription -> Maybe SetupBuildInfo
setupBuildInfo PackageDescription
pkg)
  where
    pkg :: PackageDescription
pkg
      | ActualCompiler -> Version
getGhcVersion (PackageConfig -> ActualCompiler
packageConfigCompilerVersion PackageConfig
pkgConfig) forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
0] = PackageDescription
pkg'
      -- Set all components to buildable. Only need to worry about

      -- library, exe, test, and bench, since others didn't exist in

      -- older Cabal versions

      | Bool
otherwise = PackageDescription
pkg'
        { library :: Maybe Library
library = (\Library
c -> Library
c { libBuildInfo :: BuildInfo
libBuildInfo = BuildInfo -> BuildInfo
go (Library -> BuildInfo
libBuildInfo Library
c) }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageDescription -> Maybe Library
library PackageDescription
pkg'
        , executables :: [Executable]
executables = (\Executable
c -> Executable
c { buildInfo :: BuildInfo
buildInfo = BuildInfo -> BuildInfo
go (Executable -> BuildInfo
buildInfo Executable
c) }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageDescription -> [Executable]
executables PackageDescription
pkg'
        , testSuites :: [TestSuite]
testSuites =
            if PackageConfig -> Bool
packageConfigEnableTests PackageConfig
pkgConfig
              then (\TestSuite
c -> TestSuite
c { testBuildInfo :: BuildInfo
testBuildInfo = BuildInfo -> BuildInfo
go (TestSuite -> BuildInfo
testBuildInfo TestSuite
c) }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageDescription -> [TestSuite]
testSuites PackageDescription
pkg'
              else PackageDescription -> [TestSuite]
testSuites PackageDescription
pkg'
        , benchmarks :: [Benchmark]
benchmarks =
            if PackageConfig -> Bool
packageConfigEnableBenchmarks PackageConfig
pkgConfig
              then (\Benchmark
c -> Benchmark
c { benchmarkBuildInfo :: BuildInfo
benchmarkBuildInfo = BuildInfo -> BuildInfo
go (Benchmark -> BuildInfo
benchmarkBuildInfo Benchmark
c) }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageDescription -> [Benchmark]
benchmarks PackageDescription
pkg'
              else PackageDescription -> [Benchmark]
benchmarks PackageDescription
pkg'
        }

    go :: BuildInfo -> BuildInfo
go BuildInfo
bi = BuildInfo
bi { buildable :: Bool
buildable = Bool
True }

-- | Get all dependencies of the package (buildable targets only).

--

-- This uses both the new 'buildToolDepends' and old 'buildTools'

-- information.

packageDescTools
  :: PackageDescription
  -> (Set ExeName, Map PackageName DepValue)
packageDescTools :: PackageDescription -> (Set ExeName, Map PackageName DepValue)
packageDescTools PackageDescription
pd =
    (forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ExeName]]
unknowns, forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Semigroup a => a -> a -> a
(<>) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(PackageName, DepValue)]]
knowns)
  where
    ([[ExeName]]
unknowns, [[(PackageName, DepValue)]]
knowns) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map BuildInfo -> ([ExeName], [(PackageName, DepValue)])
perBI forall a b. (a -> b) -> a -> b
$ PackageDescription -> [BuildInfo]
allBuildInfo' PackageDescription
pd

    perBI :: BuildInfo -> ([ExeName], [(PackageName, DepValue)])
    perBI :: BuildInfo -> ([ExeName], [(PackageName, DepValue)])
perBI BuildInfo
bi =
        ([ExeName]
unknownTools, [(PackageName, DepValue)]
tools)
      where
        ([ExeName]
unknownTools, [ExeDependency]
knownTools) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map LegacyExeDependency -> Either ExeName ExeDependency
go1 (BuildInfo -> [LegacyExeDependency]
buildTools BuildInfo
bi)

        tools :: [(PackageName, DepValue)]
tools = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ExeDependency -> Maybe (PackageName, DepValue)
go2 ([ExeDependency]
knownTools forall a. [a] -> [a] -> [a]
++ BuildInfo -> [ExeDependency]
buildToolDepends BuildInfo
bi)

        -- This is similar to desugarBuildTool from Cabal, however it

        -- uses our own hard-coded map which drops tools shipped with

        -- GHC (like hsc2hs), and includes some tools from Stackage.

        go1 :: Cabal.LegacyExeDependency -> Either ExeName Cabal.ExeDependency
        go1 :: LegacyExeDependency -> Either ExeName ExeDependency
go1 (Cabal.LegacyExeDependency String
name VersionRange
range) =
          case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name Map String PackageName
hardCodedMap of
            Just PackageName
pkgName -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ PackageName -> UnqualComponentName -> VersionRange -> ExeDependency
Cabal.ExeDependency PackageName
pkgName (String -> UnqualComponentName
Cabal.mkUnqualComponentName String
name) VersionRange
range
            Maybe PackageName
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> ExeName
ExeName forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
name

        go2 :: Cabal.ExeDependency -> Maybe (PackageName, DepValue)
        go2 :: ExeDependency -> Maybe (PackageName, DepValue)
go2 (Cabal.ExeDependency PackageName
pkg UnqualComponentName
_name VersionRange
range)
          | PackageName
pkg forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
preInstalledPackages = forall a. Maybe a
Nothing
          | Bool
otherwise = forall a. a -> Maybe a
Just
              ( PackageName
pkg
              , DepValue
                  { dvVersionRange :: VersionRange
dvVersionRange = VersionRange
range
                  , dvType :: DepType
dvType = DepType
AsBuildTool
                  }
              )

-- | A hard-coded map for tool dependencies

hardCodedMap :: Map String PackageName
hardCodedMap :: Map String PackageName
hardCodedMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ (String
"alex", String -> PackageName
Distribution.Package.mkPackageName String
"alex")
  , (String
"happy", String -> PackageName
Distribution.Package.mkPackageName String
"happy")
  , (String
"cpphs", String -> PackageName
Distribution.Package.mkPackageName String
"cpphs")
  , (String
"greencard", String -> PackageName
Distribution.Package.mkPackageName String
"greencard")
  , (String
"c2hs", String -> PackageName
Distribution.Package.mkPackageName String
"c2hs")
  , (String
"hscolour", String -> PackageName
Distribution.Package.mkPackageName String
"hscolour")
  , (String
"hspec-discover", String -> PackageName
Distribution.Package.mkPackageName String
"hspec-discover")
  , (String
"hsx2hs", String -> PackageName
Distribution.Package.mkPackageName String
"hsx2hs")
  , (String
"gtk2hsC2hs", String -> PackageName
Distribution.Package.mkPackageName String
"gtk2hs-buildtools")
  , (String
"gtk2hsHookGenerator", String -> PackageName
Distribution.Package.mkPackageName String
"gtk2hs-buildtools")
  , (String
"gtk2hsTypeGen", String -> PackageName
Distribution.Package.mkPackageName String
"gtk2hs-buildtools")
  ]

-- | Executable-only packages which come pre-installed with GHC and do

-- not need to be built. Without this exception, we would either end

-- up unnecessarily rebuilding these packages, or failing because the

-- packages do not appear in the Stackage snapshot.

preInstalledPackages :: Set PackageName
preInstalledPackages :: Set PackageName
preInstalledPackages = forall a. Ord a => [a] -> Set a
S.fromList
  [ String -> PackageName
mkPackageName String
"hsc2hs"
  , String -> PackageName
mkPackageName String
"haddock"
  ]

-- | Variant of 'allBuildInfo' from Cabal that, like versions before

-- 2.2, only includes buildable components.

allBuildInfo' :: PackageDescription -> [BuildInfo]
allBuildInfo' :: PackageDescription -> [BuildInfo]
allBuildInfo' PackageDescription
pkg_descr = [ BuildInfo
bi | Library
lib <- PackageDescription -> [Library]
allLibraries PackageDescription
pkg_descr
                               , let bi :: BuildInfo
bi = Library -> BuildInfo
libBuildInfo Library
lib
                               , BuildInfo -> Bool
buildable BuildInfo
bi ]
                       forall a. [a] -> [a] -> [a]
++ [ BuildInfo
bi | ForeignLib
flib <- PackageDescription -> [ForeignLib]
foreignLibs PackageDescription
pkg_descr
                               , let bi :: BuildInfo
bi = ForeignLib -> BuildInfo
foreignLibBuildInfo ForeignLib
flib
                               , BuildInfo -> Bool
buildable BuildInfo
bi ]
                       forall a. [a] -> [a] -> [a]
++ [ BuildInfo
bi | Executable
exe <- PackageDescription -> [Executable]
executables PackageDescription
pkg_descr
                               , let bi :: BuildInfo
bi = Executable -> BuildInfo
buildInfo Executable
exe
                               , BuildInfo -> Bool
buildable BuildInfo
bi ]
                       forall a. [a] -> [a] -> [a]
++ [ BuildInfo
bi | TestSuite
tst <- PackageDescription -> [TestSuite]
testSuites PackageDescription
pkg_descr
                               , let bi :: BuildInfo
bi = TestSuite -> BuildInfo
testBuildInfo TestSuite
tst
                               , BuildInfo -> Bool
buildable BuildInfo
bi ]
                       forall a. [a] -> [a] -> [a]
++ [ BuildInfo
bi | Benchmark
tst <- PackageDescription -> [Benchmark]
benchmarks PackageDescription
pkg_descr
                               , let bi :: BuildInfo
bi = Benchmark -> BuildInfo
benchmarkBuildInfo Benchmark
tst
                               , BuildInfo -> Bool
buildable BuildInfo
bi ]

-- | Get all files referenced by the package.

packageDescModulesAndFiles
    :: PackageDescription
    -> RIO Ctx (Map NamedComponent (Map ModuleName (Path Abs File)), Map NamedComponent [DotCabalPath], Set (Path Abs File), [PackageWarning])
packageDescModulesAndFiles :: PackageDescription
-> RIO
     Ctx
     (Map NamedComponent (Map ModuleName (Path Abs File)),
      Map NamedComponent [DotCabalPath], Set (Path Abs File),
      [PackageWarning])
packageDescModulesAndFiles PackageDescription
pkg = do
    (Map NamedComponent (Map ModuleName (Path Abs File))
libraryMods,Map NamedComponent [DotCabalPath]
libDotCabalFiles,[PackageWarning]
libWarnings) <-
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Map k a
M.empty, forall k a. Map k a
M.empty, []))
            (forall {m :: * -> *} {t} {k} {a} {a} {c}.
Monad m =>
(t -> k) -> (k -> t -> m (a, a, c)) -> t -> m (Map k a, Map k a, c)
asModuleAndFileMap forall {b}. b -> NamedComponent
libComponent NamedComponent
-> Library
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
libraryFiles)
            (PackageDescription -> Maybe Library
library PackageDescription
pkg)
    (Map NamedComponent (Map ModuleName (Path Abs File))
subLibrariesMods,Map NamedComponent [DotCabalPath]
subLibDotCabalFiles,[PackageWarning]
subLibWarnings) <-
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
            forall {a} {a} {a}.
[(Map NamedComponent a, Map NamedComponent a, [a])]
-> (Map NamedComponent a, Map NamedComponent a, [a])
foldTuples
            (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
                 (forall {m :: * -> *} {t} {k} {a} {a} {c}.
Monad m =>
(t -> k) -> (k -> t -> m (a, a, c)) -> t -> m (Map k a, Map k a, c)
asModuleAndFileMap Library -> NamedComponent
internalLibComponent NamedComponent
-> Library
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
libraryFiles)
                 (PackageDescription -> [Library]
subLibraries PackageDescription
pkg))
    (Map NamedComponent (Map ModuleName (Path Abs File))
executableMods,Map NamedComponent [DotCabalPath]
exeDotCabalFiles,[PackageWarning]
exeWarnings) <-
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
            forall {a} {a} {a}.
[(Map NamedComponent a, Map NamedComponent a, [a])]
-> (Map NamedComponent a, Map NamedComponent a, [a])
foldTuples
            (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
                 (forall {m :: * -> *} {t} {k} {a} {a} {c}.
Monad m =>
(t -> k) -> (k -> t -> m (a, a, c)) -> t -> m (Map k a, Map k a, c)
asModuleAndFileMap Executable -> NamedComponent
exeComponent NamedComponent
-> Executable
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
executableFiles)
                 (PackageDescription -> [Executable]
executables PackageDescription
pkg))
    (Map NamedComponent (Map ModuleName (Path Abs File))
testMods,Map NamedComponent [DotCabalPath]
testDotCabalFiles,[PackageWarning]
testWarnings) <-
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
            forall {a} {a} {a}.
[(Map NamedComponent a, Map NamedComponent a, [a])]
-> (Map NamedComponent a, Map NamedComponent a, [a])
foldTuples
            (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {m :: * -> *} {t} {k} {a} {a} {c}.
Monad m =>
(t -> k) -> (k -> t -> m (a, a, c)) -> t -> m (Map k a, Map k a, c)
asModuleAndFileMap TestSuite -> NamedComponent
testComponent NamedComponent
-> TestSuite
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
testFiles) (PackageDescription -> [TestSuite]
testSuites PackageDescription
pkg))
    (Map NamedComponent (Map ModuleName (Path Abs File))
benchModules,Map NamedComponent [DotCabalPath]
benchDotCabalPaths,[PackageWarning]
benchWarnings) <-
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
            forall {a} {a} {a}.
[(Map NamedComponent a, Map NamedComponent a, [a])]
-> (Map NamedComponent a, Map NamedComponent a, [a])
foldTuples
            (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
                 (forall {m :: * -> *} {t} {k} {a} {a} {c}.
Monad m =>
(t -> k) -> (k -> t -> m (a, a, c)) -> t -> m (Map k a, Map k a, c)
asModuleAndFileMap Benchmark -> NamedComponent
benchComponent NamedComponent
-> Benchmark
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
benchmarkFiles)
                 (PackageDescription -> [Benchmark]
benchmarks PackageDescription
pkg))
    Set (Path Abs File)
dfiles <- CabalSpecVersion -> [String] -> RIO Ctx (Set (Path Abs File))
resolveGlobFiles (PackageDescription -> CabalSpecVersion
specVersion PackageDescription
pkg)
                    (PackageDescription -> [String]
extraSrcFiles PackageDescription
pkg
                        forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (PackageDescription -> String
dataDir PackageDescription
pkg String -> String -> String
FilePath.</>) (PackageDescription -> [String]
dataFiles PackageDescription
pkg))
    let modules :: Map NamedComponent (Map ModuleName (Path Abs File))
modules = Map NamedComponent (Map ModuleName (Path Abs File))
libraryMods forall a. Semigroup a => a -> a -> a
<> Map NamedComponent (Map ModuleName (Path Abs File))
subLibrariesMods forall a. Semigroup a => a -> a -> a
<> Map NamedComponent (Map ModuleName (Path Abs File))
executableMods forall a. Semigroup a => a -> a -> a
<> Map NamedComponent (Map ModuleName (Path Abs File))
testMods forall a. Semigroup a => a -> a -> a
<> Map NamedComponent (Map ModuleName (Path Abs File))
benchModules
        files :: Map NamedComponent [DotCabalPath]
files =
            Map NamedComponent [DotCabalPath]
libDotCabalFiles forall a. Semigroup a => a -> a -> a
<> Map NamedComponent [DotCabalPath]
subLibDotCabalFiles forall a. Semigroup a => a -> a -> a
<> Map NamedComponent [DotCabalPath]
exeDotCabalFiles forall a. Semigroup a => a -> a -> a
<> Map NamedComponent [DotCabalPath]
testDotCabalFiles forall a. Semigroup a => a -> a -> a
<>
            Map NamedComponent [DotCabalPath]
benchDotCabalPaths
        warnings :: [PackageWarning]
warnings = [PackageWarning]
libWarnings forall a. Semigroup a => a -> a -> a
<> [PackageWarning]
subLibWarnings forall a. Semigroup a => a -> a -> a
<> [PackageWarning]
exeWarnings forall a. Semigroup a => a -> a -> a
<> [PackageWarning]
testWarnings forall a. Semigroup a => a -> a -> a
<> [PackageWarning]
benchWarnings
    forall (m :: * -> *) a. Monad m => a -> m a
return (Map NamedComponent (Map ModuleName (Path Abs File))
modules, Map NamedComponent [DotCabalPath]
files, Set (Path Abs File)
dfiles, [PackageWarning]
warnings)
  where
    libComponent :: b -> NamedComponent
libComponent = forall a b. a -> b -> a
const NamedComponent
CLib
    internalLibComponent :: Library -> NamedComponent
internalLibComponent = Text -> NamedComponent
CInternalLib forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" UnqualComponentName -> String
Cabal.unUnqualComponentName forall b c a. (b -> c) -> (a -> b) -> a -> c
. LibraryName -> Maybe UnqualComponentName
libraryNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> LibraryName
libName
    exeComponent :: Executable -> NamedComponent
exeComponent = Text -> NamedComponent
CExe forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> String
Cabal.unUnqualComponentName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Executable -> UnqualComponentName
exeName
    testComponent :: TestSuite -> NamedComponent
testComponent = Text -> NamedComponent
CTest forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> String
Cabal.unUnqualComponentName forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuite -> UnqualComponentName
testName
    benchComponent :: Benchmark -> NamedComponent
benchComponent = Text -> NamedComponent
CBench forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> String
Cabal.unUnqualComponentName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Benchmark -> UnqualComponentName
benchmarkName
    asModuleAndFileMap :: (t -> k) -> (k -> t -> m (a, a, c)) -> t -> m (Map k a, Map k a, c)
asModuleAndFileMap t -> k
label k -> t -> m (a, a, c)
f t
lib = do
        (a
a,a
b,c
c) <- k -> t -> m (a, a, c)
f (t -> k
label t
lib) t
lib
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. k -> a -> Map k a
M.singleton (t -> k
label t
lib) a
a, forall k a. k -> a -> Map k a
M.singleton (t -> k
label t
lib) a
b, c
c)
    foldTuples :: [(Map NamedComponent a, Map NamedComponent a, [a])]
-> (Map NamedComponent a, Map NamedComponent a, [a])
foldTuples = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Semigroup a => a -> a -> a
(<>) (forall k a. Map k a
M.empty, forall k a. Map k a
M.empty, [])

-- | Resolve globbing of files (e.g. data files) to absolute paths.

resolveGlobFiles
  :: CabalSpecVersion -- ^ cabal file version

  -> [String]
  -> RIO Ctx (Set (Path Abs File))
resolveGlobFiles :: CabalSpecVersion -> [String] -> RIO Ctx (Set (Path Abs File))
resolveGlobFiles CabalSpecVersion
cabalFileVersion =
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> RIO Ctx [Maybe (Path Abs File)]
resolve
  where
    resolve :: String -> RIO Ctx [Maybe (Path Abs File)]
resolve String
name =
        if Char
'*' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
name
            then String -> RIO Ctx [Maybe (Path Abs File)]
explode String
name
            else forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (m :: * -> *) a. Monad m => a -> m a
return (String -> RIO Ctx (Maybe (Path Abs File))
resolveFileOrWarn String
name)
    explode :: String -> RIO Ctx [Maybe (Path Abs File)]
explode String
name = do
        Path Abs Dir
dir <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall b t. Path b t -> Path b Dir
parent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> Path Abs File
ctxFile)
        [String]
names <-
            forall {m :: * -> *} {env}.
(MonadUnliftIO m, HasTerm env, MonadReader env m) =>
String -> String -> m [String]
matchDirFileGlob'
                (forall b t. Path b t -> String
FL.toFilePath Path Abs Dir
dir)
                String
name
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> RIO Ctx (Maybe (Path Abs File))
resolveFileOrWarn [String]
names
    matchDirFileGlob' :: String -> String -> m [String]
matchDirFileGlob' String
dir String
glob =
        forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
            (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Verbosity -> CabalSpecVersion -> String -> String -> IO [String]
matchDirFileGlob forall a. Bounded a => a
minBound CabalSpecVersion
cabalFileVersion String
dir String
glob))
            (\(IOException
e :: IOException) ->
                  if IOException -> Bool
isUserError IOException
e
                      then do
                          forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
                              [ String -> StyleDoc
flow String
"Wildcard does not match any files:"
                              , Style -> StyleDoc -> StyleDoc
style Style
File forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
glob
                              , StyleDoc
line forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"in directory:"
                              , Style -> StyleDoc -> StyleDoc
style Style
Dir forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
dir
                              ]
                          forall (m :: * -> *) a. Monad m => a -> m a
return []
                      else forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOException
e)

-- | Get all files referenced by the benchmark.

benchmarkFiles
    :: NamedComponent
    -> Benchmark
    -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
benchmarkFiles :: NamedComponent
-> Benchmark
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
benchmarkFiles NamedComponent
component Benchmark
bench = do
    NamedComponent
-> BuildInfo
-> [DotCabalDescriptor]
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveComponentFiles NamedComponent
component BuildInfo
build [DotCabalDescriptor]
names
  where
    names :: [DotCabalDescriptor]
names = [DotCabalDescriptor]
bnames forall a. Semigroup a => a -> a -> a
<> [DotCabalDescriptor]
exposed
    exposed :: [DotCabalDescriptor]
exposed =
        case Benchmark -> BenchmarkInterface
benchmarkInterface Benchmark
bench of
            BenchmarkExeV10 Version
_ String
fp -> [String -> DotCabalDescriptor
DotCabalMain String
fp]
            BenchmarkUnsupported BenchmarkType
_ -> []
    bnames :: [DotCabalDescriptor]
bnames = forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> DotCabalDescriptor
DotCabalModule (BuildInfo -> [ModuleName]
otherModules BuildInfo
build)
    build :: BuildInfo
build = Benchmark -> BuildInfo
benchmarkBuildInfo Benchmark
bench

-- | Get all files referenced by the test.

testFiles
    :: NamedComponent
    -> TestSuite
    -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
testFiles :: NamedComponent
-> TestSuite
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
testFiles NamedComponent
component TestSuite
test = do
    NamedComponent
-> BuildInfo
-> [DotCabalDescriptor]
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveComponentFiles NamedComponent
component BuildInfo
build [DotCabalDescriptor]
names
  where
    names :: [DotCabalDescriptor]
names = [DotCabalDescriptor]
bnames forall a. Semigroup a => a -> a -> a
<> [DotCabalDescriptor]
exposed
    exposed :: [DotCabalDescriptor]
exposed =
        case TestSuite -> TestSuiteInterface
testInterface TestSuite
test of
            TestSuiteExeV10 Version
_ String
fp -> [String -> DotCabalDescriptor
DotCabalMain String
fp]
            TestSuiteLibV09 Version
_ ModuleName
mn -> [ModuleName -> DotCabalDescriptor
DotCabalModule ModuleName
mn]
            TestSuiteUnsupported TestType
_ -> []
    bnames :: [DotCabalDescriptor]
bnames = forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> DotCabalDescriptor
DotCabalModule (BuildInfo -> [ModuleName]
otherModules BuildInfo
build)
    build :: BuildInfo
build = TestSuite -> BuildInfo
testBuildInfo TestSuite
test

-- | Get all files referenced by the executable.

executableFiles
    :: NamedComponent
    -> Executable
    -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
executableFiles :: NamedComponent
-> Executable
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
executableFiles NamedComponent
component Executable
exe = do
    NamedComponent
-> BuildInfo
-> [DotCabalDescriptor]
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveComponentFiles NamedComponent
component BuildInfo
build [DotCabalDescriptor]
names
  where
    build :: BuildInfo
build = Executable -> BuildInfo
buildInfo Executable
exe
    names :: [DotCabalDescriptor]
names =
        forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> DotCabalDescriptor
DotCabalModule (BuildInfo -> [ModuleName]
otherModules BuildInfo
build) forall a. [a] -> [a] -> [a]
++
        [String -> DotCabalDescriptor
DotCabalMain (Executable -> String
modulePath Executable
exe)]

-- | Get all files referenced by the library.

libraryFiles
    :: NamedComponent
    -> Library
    -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
libraryFiles :: NamedComponent
-> Library
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
libraryFiles NamedComponent
component Library
lib = do
    NamedComponent
-> BuildInfo
-> [DotCabalDescriptor]
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveComponentFiles NamedComponent
component BuildInfo
build [DotCabalDescriptor]
names
  where
    build :: BuildInfo
build = Library -> BuildInfo
libBuildInfo Library
lib
    names :: [DotCabalDescriptor]
names = [DotCabalDescriptor]
bnames forall a. [a] -> [a] -> [a]
++ [DotCabalDescriptor]
exposed
    exposed :: [DotCabalDescriptor]
exposed = forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> DotCabalDescriptor
DotCabalModule (Library -> [ModuleName]
exposedModules Library
lib)
    bnames :: [DotCabalDescriptor]
bnames = forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> DotCabalDescriptor
DotCabalModule (BuildInfo -> [ModuleName]
otherModules BuildInfo
build)

-- | Get all files referenced by the component.

resolveComponentFiles
    :: NamedComponent
    -> BuildInfo
    -> [DotCabalDescriptor]
    -> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveComponentFiles :: NamedComponent
-> BuildInfo
-> [DotCabalDescriptor]
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveComponentFiles NamedComponent
component BuildInfo
build [DotCabalDescriptor]
names = do
    [Path Abs Dir]
dirs <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (String -> RIO Ctx (Maybe (Path Abs Dir))
resolveDirOrWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall from to. SymbolicPath from to -> String
getSymbolicPath) (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
build)
    Path Abs Dir
dir <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall b t. Path b t -> Path b Dir
parent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> Path Abs File
ctxFile)
    [Path Abs Dir]
agdirs <- RIO Ctx [Path Abs Dir]
autogenDirs
    (Map ModuleName (Path Abs File)
modules,[DotCabalPath]
files,[PackageWarning]
warnings) <-
        NamedComponent
-> [Path Abs Dir]
-> [DotCabalDescriptor]
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveFilesAndDeps
            NamedComponent
component
            ((if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs Dir]
dirs then [Path Abs Dir
dir] else [Path Abs Dir]
dirs) forall a. [a] -> [a] -> [a]
++ [Path Abs Dir]
agdirs)
            [DotCabalDescriptor]
names
    [DotCabalPath]
cfiles <- BuildInfo -> RIO Ctx [DotCabalPath]
buildOtherSources BuildInfo
build
    forall (m :: * -> *) a. Monad m => a -> m a
return (Map ModuleName (Path Abs File)
modules, [DotCabalPath]
files forall a. Semigroup a => a -> a -> a
<> [DotCabalPath]
cfiles, [PackageWarning]
warnings)
  where
    autogenDirs :: RIO Ctx [Path Abs Dir]
autogenDirs = do
      Version
cabalVer <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Ctx -> Version
ctxCabalVer
      Path Abs Dir
distDir <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Ctx -> Path Abs Dir
ctxDistDir
      let compDir :: Path Abs Dir
compDir = Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir
componentAutogenDir Version
cabalVer NamedComponent
component Path Abs Dir
distDir
          pkgDir :: [Path Abs Dir]
pkgDir = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ Version -> Path Abs Dir -> Maybe (Path Abs Dir)
packageAutogenDir Version
cabalVer Path Abs Dir
distDir
      forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist forall a b. (a -> b) -> a -> b
$ Path Abs Dir
compDir forall a. a -> [a] -> [a]
: [Path Abs Dir]
pkgDir

-- | Get all C sources and extra source files in a build.

buildOtherSources :: BuildInfo -> RIO Ctx [DotCabalPath]
buildOtherSources :: BuildInfo -> RIO Ctx [DotCabalPath]
buildOtherSources BuildInfo
build = do
    Path Abs Dir
cwd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
    Path Abs Dir
dir <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall b t. Path b t -> Path b Dir
parent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> Path Abs File
ctxFile)
    Path Abs File
file <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Ctx -> Path Abs File
ctxFile
    let resolveDirFiles :: [String] -> (Path Abs File -> b) -> RIO Ctx [b]
resolveDirFiles [String]
files Path Abs File -> b
toCabalPath =
            forall (m :: * -> *) a b.
Monad m =>
[a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM [String]
files forall a b. (a -> b) -> a -> b
$ \String
fp -> do
                Maybe (Path Abs File)
result <- forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> String -> m (Maybe (Path Abs File))
resolveDirFile Path Abs Dir
dir String
fp
                case Maybe (Path Abs File)
result of
                    Maybe (Path Abs File)
Nothing -> do
                        Text -> Path Abs Dir -> String -> Path Abs File -> RIO Ctx ()
warnMissingFile Text
"File" Path Abs Dir
cwd String
fp Path Abs File
file
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                    Just Path Abs File
p -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Path Abs File -> b
toCabalPath Path Abs File
p)
    [DotCabalPath]
csources <- forall {b}. [String] -> (Path Abs File -> b) -> RIO Ctx [b]
resolveDirFiles (BuildInfo -> [String]
cSources BuildInfo
build) Path Abs File -> DotCabalPath
DotCabalCFilePath
    [DotCabalPath]
jsources <- forall {b}. [String] -> (Path Abs File -> b) -> RIO Ctx [b]
resolveDirFiles (BuildInfo -> [String]
targetJsSources BuildInfo
build) Path Abs File -> DotCabalPath
DotCabalFilePath
    forall (m :: * -> *) a. Monad m => a -> m a
return ([DotCabalPath]
csources forall a. Semigroup a => a -> a -> a
<> [DotCabalPath]
jsources)

-- | Get the target's JS sources.

targetJsSources :: BuildInfo -> [FilePath]
targetJsSources :: BuildInfo -> [String]
targetJsSources = BuildInfo -> [String]
jsSources

-- | A pair of package descriptions: one which modified the buildable

-- values of test suites and benchmarks depending on whether they are

-- enabled, and one which does not.

--

-- Fields are intentionally lazy, we may only need one or the other

-- value.

--

-- MSS 2017-08-29: The very presence of this data type is terribly

-- ugly, it represents the fact that the Cabal 2.0 upgrade did _not_

-- go well. Specifically, we used to have a field to indicate whether

-- a component was enabled in addition to buildable, but that's gone

-- now, and this is an ugly proxy. We should at some point clean up

-- the mess of Package, LocalPackage, etc, and probably pull in the

-- definition of PackageDescription from Cabal with our additionally

-- needed metadata. But this is a good enough hack for the

-- moment. Odds are, you're reading this in the year 2024 and thinking

-- "wtf?"

data PackageDescriptionPair = PackageDescriptionPair
  { PackageDescriptionPair -> PackageDescription
pdpOrigBuildable :: PackageDescription
  , PackageDescriptionPair -> PackageDescription
pdpModifiedBuildable :: PackageDescription
  }

-- | Evaluates the conditions of a 'GenericPackageDescription', yielding

-- a resolved 'PackageDescription'.

resolvePackageDescription :: PackageConfig
                          -> GenericPackageDescription
                          -> PackageDescriptionPair
resolvePackageDescription :: PackageConfig
-> GenericPackageDescription -> PackageDescriptionPair
resolvePackageDescription PackageConfig
packageConfig (GenericPackageDescription PackageDescription
desc Maybe Version
_ [PackageFlag]
defaultFlags Maybe (CondTree ConfVar [Dependency] Library)
mlib [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
subLibs [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
foreignLibs' [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
exes [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
tests [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
benches) =
    PackageDescriptionPair
      { pdpOrigBuildable :: PackageDescription
pdpOrigBuildable = Bool -> PackageDescription
go Bool
False
      , pdpModifiedBuildable :: PackageDescription
pdpModifiedBuildable = Bool -> PackageDescription
go Bool
True
      }
  where
        go :: Bool -> PackageDescription
go Bool
modBuildable =
          PackageDescription
desc {library :: Maybe Library
library =
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall target cs.
(Semigroup target, Monoid target, Show target) =>
ResolveConditions
-> (target -> cs -> target) -> CondTree ConfVar cs target -> target
resolveConditions ResolveConditions
rc Library -> [Dependency] -> Library
updateLibDeps) Maybe (CondTree ConfVar [Dependency] Library)
mlib
               ,subLibraries :: [Library]
subLibraries =
                  forall a b. (a -> b) -> [a] -> [b]
map (\(UnqualComponentName
n, CondTree ConfVar [Dependency] Library
v) -> (forall target cs.
(Semigroup target, Monoid target, Show target) =>
ResolveConditions
-> (target -> cs -> target) -> CondTree ConfVar cs target -> target
resolveConditions ResolveConditions
rc Library -> [Dependency] -> Library
updateLibDeps CondTree ConfVar [Dependency] Library
v){libName :: LibraryName
libName=UnqualComponentName -> LibraryName
LSubLibName UnqualComponentName
n})
                      [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
subLibs
               ,foreignLibs :: [ForeignLib]
foreignLibs =
                  forall a b. (a -> b) -> [a] -> [b]
map (\(UnqualComponentName
n, CondTree ConfVar [Dependency] ForeignLib
v) -> (forall target cs.
(Semigroup target, Monoid target, Show target) =>
ResolveConditions
-> (target -> cs -> target) -> CondTree ConfVar cs target -> target
resolveConditions ResolveConditions
rc ForeignLib -> [Dependency] -> ForeignLib
updateForeignLibDeps CondTree ConfVar [Dependency] ForeignLib
v){foreignLibName :: UnqualComponentName
foreignLibName=UnqualComponentName
n})
                      [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
foreignLibs'
               ,executables :: [Executable]
executables =
                  forall a b. (a -> b) -> [a] -> [b]
map (\(UnqualComponentName
n, CondTree ConfVar [Dependency] Executable
v) -> (forall target cs.
(Semigroup target, Monoid target, Show target) =>
ResolveConditions
-> (target -> cs -> target) -> CondTree ConfVar cs target -> target
resolveConditions ResolveConditions
rc Executable -> [Dependency] -> Executable
updateExeDeps CondTree ConfVar [Dependency] Executable
v){exeName :: UnqualComponentName
exeName=UnqualComponentName
n})
                      [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
exes
               ,testSuites :: [TestSuite]
testSuites =
                  forall a b. (a -> b) -> [a] -> [b]
map (\(UnqualComponentName
n,CondTree ConfVar [Dependency] TestSuite
v) -> (forall target cs.
(Semigroup target, Monoid target, Show target) =>
ResolveConditions
-> (target -> cs -> target) -> CondTree ConfVar cs target -> target
resolveConditions ResolveConditions
rc (Bool -> TestSuite -> [Dependency] -> TestSuite
updateTestDeps Bool
modBuildable) CondTree ConfVar [Dependency] TestSuite
v){testName :: UnqualComponentName
testName=UnqualComponentName
n})
                      [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
tests
               ,benchmarks :: [Benchmark]
benchmarks =
                  forall a b. (a -> b) -> [a] -> [b]
map (\(UnqualComponentName
n,CondTree ConfVar [Dependency] Benchmark
v) -> (forall target cs.
(Semigroup target, Monoid target, Show target) =>
ResolveConditions
-> (target -> cs -> target) -> CondTree ConfVar cs target -> target
resolveConditions ResolveConditions
rc (Bool -> Benchmark -> [Dependency] -> Benchmark
updateBenchmarkDeps Bool
modBuildable) CondTree ConfVar [Dependency] Benchmark
v){benchmarkName :: UnqualComponentName
benchmarkName=UnqualComponentName
n})
                      [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
benches}

        flags :: Map FlagName Bool
flags =
          forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (PackageConfig -> Map FlagName Bool
packageConfigFlags PackageConfig
packageConfig)
                  ([PackageFlag] -> Map FlagName Bool
flagMap [PackageFlag]
defaultFlags)

        rc :: ResolveConditions
rc = ActualCompiler
-> Platform -> Map FlagName Bool -> ResolveConditions
mkResolveConditions
                (PackageConfig -> ActualCompiler
packageConfigCompilerVersion PackageConfig
packageConfig)
                (PackageConfig -> Platform
packageConfigPlatform PackageConfig
packageConfig)
                Map FlagName Bool
flags

        updateLibDeps :: Library -> [Dependency] -> Library
updateLibDeps Library
lib [Dependency]
deps =
          Library
lib {libBuildInfo :: BuildInfo
libBuildInfo =
                 (Library -> BuildInfo
libBuildInfo Library
lib) {targetBuildDepends :: [Dependency]
targetBuildDepends = [Dependency]
deps}}
        updateForeignLibDeps :: ForeignLib -> [Dependency] -> ForeignLib
updateForeignLibDeps ForeignLib
lib [Dependency]
deps =
          ForeignLib
lib {foreignLibBuildInfo :: BuildInfo
foreignLibBuildInfo =
                 (ForeignLib -> BuildInfo
foreignLibBuildInfo ForeignLib
lib) {targetBuildDepends :: [Dependency]
targetBuildDepends = [Dependency]
deps}}
        updateExeDeps :: Executable -> [Dependency] -> Executable
updateExeDeps Executable
exe [Dependency]
deps =
          Executable
exe {buildInfo :: BuildInfo
buildInfo =
                 (Executable -> BuildInfo
buildInfo Executable
exe) {targetBuildDepends :: [Dependency]
targetBuildDepends = [Dependency]
deps}}

        -- Note that, prior to moving to Cabal 2.0, we would set

        -- testEnabled/benchmarkEnabled here. These fields no longer

        -- exist, so we modify buildable instead here.  The only

        -- wrinkle in the Cabal 2.0 story is

        -- https://github.com/haskell/cabal/issues/1725, where older

        -- versions of Cabal (which may be used for actually building

        -- code) don't properly exclude build-depends for

        -- non-buildable components. Testing indicates that everything

        -- is working fine, and that this comment can be completely

        -- ignored. I'm leaving the comment anyway in case something

        -- breaks and you, poor reader, are investigating.

        updateTestDeps :: Bool -> TestSuite -> [Dependency] -> TestSuite
updateTestDeps Bool
modBuildable TestSuite
test [Dependency]
deps =
          let bi :: BuildInfo
bi = TestSuite -> BuildInfo
testBuildInfo TestSuite
test
              bi' :: BuildInfo
bi' = BuildInfo
bi
                { targetBuildDepends :: [Dependency]
targetBuildDepends = [Dependency]
deps
                , buildable :: Bool
buildable = BuildInfo -> Bool
buildable BuildInfo
bi Bool -> Bool -> Bool
&& (if Bool
modBuildable then PackageConfig -> Bool
packageConfigEnableTests PackageConfig
packageConfig else Bool
True)
                }
           in TestSuite
test { testBuildInfo :: BuildInfo
testBuildInfo = BuildInfo
bi' }
        updateBenchmarkDeps :: Bool -> Benchmark -> [Dependency] -> Benchmark
updateBenchmarkDeps Bool
modBuildable Benchmark
benchmark [Dependency]
deps =
          let bi :: BuildInfo
bi = Benchmark -> BuildInfo
benchmarkBuildInfo Benchmark
benchmark
              bi' :: BuildInfo
bi' = BuildInfo
bi
                { targetBuildDepends :: [Dependency]
targetBuildDepends = [Dependency]
deps
                , buildable :: Bool
buildable = BuildInfo -> Bool
buildable BuildInfo
bi Bool -> Bool -> Bool
&& (if Bool
modBuildable then PackageConfig -> Bool
packageConfigEnableBenchmarks PackageConfig
packageConfig else Bool
True)
                }
           in Benchmark
benchmark { benchmarkBuildInfo :: BuildInfo
benchmarkBuildInfo = BuildInfo
bi' }

-- | Make a map from a list of flag specifications.

--

-- What is @flagManual@ for?

flagMap :: [PackageFlag] -> Map FlagName Bool
flagMap :: [PackageFlag] -> Map FlagName Bool
flagMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> (FlagName, Bool)
pair
  where pair :: PackageFlag -> (FlagName, Bool)
        pair :: PackageFlag -> (FlagName, Bool)
pair = PackageFlag -> FlagName
flagName forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& PackageFlag -> Bool
flagDefault

data ResolveConditions = ResolveConditions
    { ResolveConditions -> Map FlagName Bool
rcFlags :: Map FlagName Bool
    , ResolveConditions -> ActualCompiler
rcCompilerVersion :: ActualCompiler
    , ResolveConditions -> OS
rcOS :: OS
    , ResolveConditions -> Arch
rcArch :: Arch
    }

-- | Generic a @ResolveConditions@ using sensible defaults.

mkResolveConditions :: ActualCompiler -- ^ Compiler version

                    -> Platform -- ^ installation target platform

                    -> Map FlagName Bool -- ^ enabled flags

                    -> ResolveConditions
mkResolveConditions :: ActualCompiler
-> Platform -> Map FlagName Bool -> ResolveConditions
mkResolveConditions ActualCompiler
compilerVersion (Platform Arch
arch OS
os) Map FlagName Bool
flags = ResolveConditions
    { rcFlags :: Map FlagName Bool
rcFlags = Map FlagName Bool
flags
    , rcCompilerVersion :: ActualCompiler
rcCompilerVersion = ActualCompiler
compilerVersion
    , rcOS :: OS
rcOS = OS
os
    , rcArch :: Arch
rcArch = Arch
arch
    }

-- | Resolve the condition tree for the library.

resolveConditions :: (Semigroup target,Monoid target,Show target)
                  => ResolveConditions
                  -> (target -> cs -> target)
                  -> CondTree ConfVar cs target
                  -> target
resolveConditions :: forall target cs.
(Semigroup target, Monoid target, Show target) =>
ResolveConditions
-> (target -> cs -> target) -> CondTree ConfVar cs target -> target
resolveConditions ResolveConditions
rc target -> cs -> target
addDeps (CondNode target
lib cs
deps [CondBranch ConfVar cs target]
cs) = target
basic forall a. Semigroup a => a -> a -> a
<> target
children
  where basic :: target
basic = target -> cs -> target
addDeps target
lib cs
deps
        children :: target
children = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map CondBranch ConfVar cs target -> target
apply [CondBranch ConfVar cs target]
cs)
          where apply :: CondBranch ConfVar cs target -> target
apply (Cabal.CondBranch Condition ConfVar
cond CondTree ConfVar cs target
node Maybe (CondTree ConfVar cs target)
mcs) =
                  if Condition ConfVar -> Bool
condSatisfied Condition ConfVar
cond
                     then forall target cs.
(Semigroup target, Monoid target, Show target) =>
ResolveConditions
-> (target -> cs -> target) -> CondTree ConfVar cs target -> target
resolveConditions ResolveConditions
rc target -> cs -> target
addDeps CondTree ConfVar cs target
node
                     else forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall target cs.
(Semigroup target, Monoid target, Show target) =>
ResolveConditions
-> (target -> cs -> target) -> CondTree ConfVar cs target -> target
resolveConditions ResolveConditions
rc target -> cs -> target
addDeps) Maybe (CondTree ConfVar cs target)
mcs
                condSatisfied :: Condition ConfVar -> Bool
condSatisfied Condition ConfVar
c =
                  case Condition ConfVar
c of
                    Var ConfVar
v -> ConfVar -> Bool
varSatisfied ConfVar
v
                    Lit Bool
b -> Bool
b
                    CNot Condition ConfVar
c' ->
                      Bool -> Bool
not (Condition ConfVar -> Bool
condSatisfied Condition ConfVar
c')
                    COr Condition ConfVar
cx Condition ConfVar
cy ->
                      Condition ConfVar -> Bool
condSatisfied Condition ConfVar
cx Bool -> Bool -> Bool
|| Condition ConfVar -> Bool
condSatisfied Condition ConfVar
cy
                    CAnd Condition ConfVar
cx Condition ConfVar
cy ->
                      Condition ConfVar -> Bool
condSatisfied Condition ConfVar
cx Bool -> Bool -> Bool
&& Condition ConfVar -> Bool
condSatisfied Condition ConfVar
cy
                varSatisfied :: ConfVar -> Bool
varSatisfied ConfVar
v =
                  case ConfVar
v of
                    OS OS
os -> OS
os forall a. Eq a => a -> a -> Bool
== ResolveConditions -> OS
rcOS ResolveConditions
rc
                    Arch Arch
arch -> Arch
arch forall a. Eq a => a -> a -> Bool
== ResolveConditions -> Arch
rcArch ResolveConditions
rc
                    PackageFlag FlagName
flag ->
                      forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FlagName
flag (ResolveConditions -> Map FlagName Bool
rcFlags ResolveConditions
rc)
                      -- NOTE:  ^^^^^ This should never happen, as all flags

                      -- which are used must be declared. Defaulting to

                      -- False.

                    Impl CompilerFlavor
flavor VersionRange
range ->
                      case (CompilerFlavor
flavor, ResolveConditions -> ActualCompiler
rcCompilerVersion ResolveConditions
rc) of
                        (CompilerFlavor
GHC, ACGhc Version
vghc) -> Version
vghc Version -> VersionRange -> Bool
`withinRange` VersionRange
range
                        (CompilerFlavor, ActualCompiler)
_ -> Bool
False

-- | Try to resolve the list of base names in the given directory by

-- looking for unique instances of base names applied with the given

-- extensions, plus find any of their module and TemplateHaskell

-- dependencies.

resolveFilesAndDeps
    :: NamedComponent       -- ^ Package component name

    -> [Path Abs Dir]       -- ^ Directories to look in.

    -> [DotCabalDescriptor] -- ^ Base names.

    -> RIO Ctx (Map ModuleName (Path Abs File),[DotCabalPath],[PackageWarning])
resolveFilesAndDeps :: NamedComponent
-> [Path Abs Dir]
-> [DotCabalDescriptor]
-> RIO
     Ctx
     (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])
resolveFilesAndDeps NamedComponent
component [Path Abs Dir]
dirs [DotCabalDescriptor]
names0 = do
    ([DotCabalPath]
dotCabalPaths, Map ModuleName (Path Abs File)
foundModules, [ModuleName]
missingModules) <- [DotCabalDescriptor]
-> Set ModuleName
-> RIO
     Ctx ([DotCabalPath], Map ModuleName (Path Abs File), [ModuleName])
loop [DotCabalDescriptor]
names0 forall a. Set a
S.empty
    [PackageWarning]
warnings <- forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. [a] -> [a] -> [a]
(++) (forall {m :: * -> *} {b}.
Monad m =>
Map ModuleName b -> m [PackageWarning]
warnUnlisted Map ModuleName (Path Abs File)
foundModules) (forall {m :: * -> *} {p} {a}. Monad m => p -> m [a]
warnMissing [ModuleName]
missingModules)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Map ModuleName (Path Abs File)
foundModules, [DotCabalPath]
dotCabalPaths, [PackageWarning]
warnings)
  where
    loop :: [DotCabalDescriptor]
-> Set ModuleName
-> RIO
     Ctx ([DotCabalPath], Map ModuleName (Path Abs File), [ModuleName])
loop [] Set ModuleName
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall k a. Map k a
M.empty, [])
    loop [DotCabalDescriptor]
names Set ModuleName
doneModules0 = do
        [(DotCabalDescriptor, Maybe DotCabalPath)]
resolved <- [Path Abs Dir]
-> [DotCabalDescriptor]
-> RIO Ctx [(DotCabalDescriptor, Maybe DotCabalPath)]
resolveFiles [Path Abs Dir]
dirs [DotCabalDescriptor]
names
        let foundFiles :: [DotCabalPath]
foundFiles = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> b
snd [(DotCabalDescriptor, Maybe DotCabalPath)]
resolved
            foundModules :: [(ModuleName, Path Abs File)]
foundModules = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (DotCabalDescriptor, Maybe DotCabalPath)
-> Maybe (ModuleName, Path Abs File)
toResolvedModule [(DotCabalDescriptor, Maybe DotCabalPath)]
resolved
            missingModules :: [ModuleName]
missingModules = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (DotCabalDescriptor, Maybe DotCabalPath) -> Maybe ModuleName
toMissingModule [(DotCabalDescriptor, Maybe DotCabalPath)]
resolved
        [(Set ModuleName, [Path Abs File])]
pairs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NamedComponent
-> [Path Abs Dir]
-> DotCabalPath
-> RIO Ctx (Set ModuleName, [Path Abs File])
getDependencies NamedComponent
component [Path Abs Dir]
dirs) [DotCabalPath]
foundFiles
        let doneModules :: Set ModuleName
doneModules =
                forall a. Ord a => Set a -> Set a -> Set a
S.union
                    Set ModuleName
doneModules0
                    (forall a. Ord a => [a] -> Set a
S.fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DotCabalDescriptor -> Maybe ModuleName
dotCabalModule [DotCabalDescriptor]
names))
            moduleDeps :: Set ModuleName
moduleDeps = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Set ModuleName, [Path Abs File])]
pairs)
            thDepFiles :: [Path Abs File]
thDepFiles = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(Set ModuleName, [Path Abs File])]
pairs
            modulesRemaining :: Set ModuleName
modulesRemaining = forall a. Ord a => Set a -> Set a -> Set a
S.difference Set ModuleName
moduleDeps Set ModuleName
doneModules
        -- Ignore missing modules discovered as dependencies - they may

        -- have been deleted.

        ([DotCabalPath]
resolvedFiles, Map ModuleName (Path Abs File)
resolvedModules, [ModuleName]
_) <-
            [DotCabalDescriptor]
-> Set ModuleName
-> RIO
     Ctx ([DotCabalPath], Map ModuleName (Path Abs File), [ModuleName])
loop (forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> DotCabalDescriptor
DotCabalModule (forall a. Set a -> [a]
S.toList Set ModuleName
modulesRemaining)) Set ModuleName
doneModules
        forall (m :: * -> *) a. Monad m => a -> m a
return
            ( forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ [DotCabalPath]
foundFiles forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map Path Abs File -> DotCabalPath
DotCabalFilePath [Path Abs File]
thDepFiles forall a. Semigroup a => a -> a -> a
<> [DotCabalPath]
resolvedFiles
            , forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union
                  (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(ModuleName, Path Abs File)]
foundModules)
                  Map ModuleName (Path Abs File)
resolvedModules
            , [ModuleName]
missingModules)
    warnUnlisted :: Map ModuleName b -> m [PackageWarning]
warnUnlisted Map ModuleName b
foundModules = do
        let unlistedModules :: Map ModuleName b
unlistedModules =
                Map ModuleName b
foundModules forall k a b. Ord k => Map k a -> Map k b -> Map k a
`M.difference`
                forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCabalDescriptor -> Maybe ModuleName
dotCabalModule) [DotCabalDescriptor]
names0)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            if forall k a. Map k a -> Bool
M.null Map ModuleName b
unlistedModules
                then []
                else [ NamedComponent -> [ModuleName] -> PackageWarning
UnlistedModulesWarning
                           NamedComponent
component
                           (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall k a. Map k a -> [(k, a)]
M.toList Map ModuleName b
unlistedModules))]
    warnMissing :: p -> m [a]
warnMissing p
_missingModules = do
        forall (m :: * -> *) a. Monad m => a -> m a
return []
        -- TODO: bring this back - see

        -- https://github.com/commercialhaskell/stack/issues/2649

        {-
        cabalfp <- asks ctxFile
        return $
            if null missingModules
               then []
               else [ MissingModulesWarning
                           cabalfp
                           component
                           missingModules]
        -}
    -- TODO: In usages of toResolvedModule / toMissingModule, some sort

    -- of map + partition would probably be better.

    toResolvedModule
        :: (DotCabalDescriptor, Maybe DotCabalPath)
        -> Maybe (ModuleName, Path Abs File)
    toResolvedModule :: (DotCabalDescriptor, Maybe DotCabalPath)
-> Maybe (ModuleName, Path Abs File)
toResolvedModule (DotCabalModule ModuleName
mn, Just (DotCabalModulePath Path Abs File
fp)) =
        forall a. a -> Maybe a
Just (ModuleName
mn, Path Abs File
fp)
    toResolvedModule (DotCabalDescriptor, Maybe DotCabalPath)
_ =
        forall a. Maybe a
Nothing
    toMissingModule
        :: (DotCabalDescriptor, Maybe DotCabalPath)
        -> Maybe ModuleName
    toMissingModule :: (DotCabalDescriptor, Maybe DotCabalPath) -> Maybe ModuleName
toMissingModule (DotCabalModule ModuleName
mn, Maybe DotCabalPath
Nothing) =
        forall a. a -> Maybe a
Just ModuleName
mn
    toMissingModule (DotCabalDescriptor, Maybe DotCabalPath)
_ =
        forall a. Maybe a
Nothing

-- | Get the dependencies of a Haskell module file.

getDependencies
    :: NamedComponent -> [Path Abs Dir] -> DotCabalPath -> RIO Ctx (Set ModuleName, [Path Abs File])
getDependencies :: NamedComponent
-> [Path Abs Dir]
-> DotCabalPath
-> RIO Ctx (Set ModuleName, [Path Abs File])
getDependencies NamedComponent
component [Path Abs Dir]
dirs DotCabalPath
dotCabalPath =
    case DotCabalPath
dotCabalPath of
        DotCabalModulePath Path Abs File
resolvedFile -> forall {t}. Path Abs t -> RIO Ctx (Set ModuleName, [Path Abs File])
readResolvedHi Path Abs File
resolvedFile
        DotCabalMainPath Path Abs File
resolvedFile -> forall {t}. Path Abs t -> RIO Ctx (Set ModuleName, [Path Abs File])
readResolvedHi Path Abs File
resolvedFile
        DotCabalFilePath{} -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Set a
S.empty, [])
        DotCabalCFilePath{} -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Set a
S.empty, [])
  where
    readResolvedHi :: Path Abs t -> RIO Ctx (Set ModuleName, [Path Abs File])
readResolvedHi Path Abs t
resolvedFile = do
        Path Abs Dir
dumpHIDir <- NamedComponent -> Path Abs Dir -> Path Abs Dir
componentOutputDir NamedComponent
component forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Ctx -> Path Abs Dir
ctxDistDir
        Path Abs Dir
dir <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall b t. Path b t -> Path b Dir
parent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> Path Abs File
ctxFile)
        let sourceDir :: Path Abs Dir
sourceDir = forall a. a -> Maybe a -> a
fromMaybe Path Abs Dir
dir forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall b t. Path b Dir -> Path b t -> Bool
`isProperPrefixOf` Path Abs t
resolvedFile) [Path Abs Dir]
dirs
            stripSourceDir :: Path Abs Dir -> m (Path Rel t)
stripSourceDir Path Abs Dir
d = forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
d Path Abs t
resolvedFile
        case forall {m :: * -> *}.
MonadThrow m =>
Path Abs Dir -> m (Path Rel t)
stripSourceDir Path Abs Dir
sourceDir of
            Maybe (Path Rel t)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Set a
S.empty, [])
            Just Path Rel t
fileRel -> do
                let hiPath :: String
hiPath =
                        String -> String -> String
FilePath.replaceExtension
                            (forall b t. Path b t -> String
toFilePath (Path Abs Dir
dumpHIDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel t
fileRel))
                            String
".hi"
                Bool
dumpHIExists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
D.doesFileExist String
hiPath
                if Bool
dumpHIExists
                    then String -> RIO Ctx (Set ModuleName, [Path Abs File])
parseHI String
hiPath
                    else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Set a
S.empty, [])

-- | Parse a .hi file into a set of modules and files.

parseHI
    :: FilePath -> RIO Ctx (Set ModuleName, [Path Abs File])
parseHI :: String -> RIO Ctx (Set ModuleName, [Path Abs File])
parseHI String
hiPath = do
  Path Abs Dir
dir <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall b t. Path b t -> Path b Dir
parent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> Path Abs File
ctxFile)
  Either String Interface
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Either String Interface)
Iface.fromFile String
hiPath forall a (m :: * -> *).
(NFData a, MonadUnliftIO m) =>
m a -> (SomeException -> m a) -> m a
`catchAnyDeep` \SomeException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show SomeException
e))
  case Either String Interface
result of
    Left String
msg -> do
      forall env. HasConfig env => [StyleDoc] -> RIO env ()
prettyStackDevL
        [ String -> StyleDoc
flow String
"Failed to decode module interface:"
        , Style -> StyleDoc -> StyleDoc
style Style
File forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
hiPath
        , String -> StyleDoc
flow String
"Decoding failure:"
        , Style -> StyleDoc -> StyleDoc
style Style
Error forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
msg
        ]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Set a
S.empty, [])
    Right Interface
iface -> do
      let moduleNames :: Interface -> [ModuleName]
moduleNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8Lenient forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        forall a. List a -> [a]
Iface.unList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> List (ByteString, Bool)
Iface.dmods forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> Dependencies
Iface.deps
          resolveFileDependency :: String -> m (Maybe (Path Abs File))
resolveFileDependency String
file = do
            Maybe (Path Abs File)
resolved <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence (forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs File)
resolveFile Path Abs Dir
dir String
file)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadIO m =>
Maybe (Path Abs File) -> m (Maybe (Path Abs File))
rejectMissingFile
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe (Path Abs File)
resolved) forall a b. (a -> b) -> a -> b
$
              forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
              [ String -> StyleDoc
flow String
"Dependent file listed in:"
              , Style -> StyleDoc -> StyleDoc
style Style
File forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
hiPath
              , String -> StyleDoc
flow String
"does not exist:"
              , Style -> StyleDoc -> StyleDoc
style Style
File forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
file
              ]
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
resolved
          resolveUsages :: Interface -> RIO Ctx [Maybe (Path Abs File)]
resolveUsages = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall {m :: * -> *} {env}.
(MonadIO m, HasTerm env, MonadReader env m) =>
String -> m (Maybe (Path Abs File))
resolveFileDependency forall b c a. (b -> c) -> (a -> b) -> a -> c
. Usage -> String
Iface.unUsage) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. List a -> [a]
Iface.unList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> List Usage
Iface.usage
      [Path Abs File]
resolvedUsages <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Interface -> RIO Ctx [Maybe (Path Abs File)]
resolveUsages Interface
iface
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ Interface -> [ModuleName]
moduleNames Interface
iface, [Path Abs File]
resolvedUsages)

-- | Try to resolve the list of base names in the given directory by

-- looking for unique instances of base names applied with the given

-- extensions.

resolveFiles
    :: [Path Abs Dir] -- ^ Directories to look in.

    -> [DotCabalDescriptor] -- ^ Base names.

    -> RIO Ctx [(DotCabalDescriptor, Maybe DotCabalPath)]
resolveFiles :: [Path Abs Dir]
-> [DotCabalDescriptor]
-> RIO Ctx [(DotCabalDescriptor, Maybe DotCabalPath)]
resolveFiles [Path Abs Dir]
dirs [DotCabalDescriptor]
names =
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DotCabalDescriptor]
names (\DotCabalDescriptor
name -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (DotCabalDescriptor
name, ) ([Path Abs Dir]
-> DotCabalDescriptor -> RIO Ctx (Maybe DotCabalPath)
findCandidate [Path Abs Dir]
dirs DotCabalDescriptor
name))

data CabalFileNameParseFail
  = CabalFileNameParseFail FilePath
  | CabalFileNameInvalidPackageName FilePath
  deriving (Typeable)

instance Exception CabalFileNameParseFail
instance Show CabalFileNameParseFail where
    show :: CabalFileNameParseFail -> String
show (CabalFileNameParseFail String
fp) = String
"Invalid file path for cabal file, must have a .cabal extension: " forall a. [a] -> [a] -> [a]
++ String
fp
    show (CabalFileNameInvalidPackageName String
fp) = String
"cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " forall a. [a] -> [a] -> [a]
++ String
fp

-- | Parse a package name from a file path.

parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName
parsePackageNameFromFilePath :: forall (m :: * -> *) a.
MonadThrow m =>
Path a File -> m PackageName
parsePackageNameFromFilePath Path a File
fp = do
    String
base <- String -> m String
clean forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath forall a b. (a -> b) -> a -> b
$ forall b. Path b File -> Path Rel File
filename Path a File
fp
    case String -> Maybe PackageName
parsePackageName String
base of
        Maybe PackageName
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> CabalFileNameParseFail
CabalFileNameInvalidPackageName forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path a File
fp
        Just PackageName
x -> forall (m :: * -> *) a. Monad m => a -> m a
return PackageName
x
  where clean :: String -> m String
clean = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {m :: * -> *}. MonadThrow m => String -> m String
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
        strip :: String -> m String
strip (Char
'l':Char
'a':Char
'b':Char
'a':Char
'c':Char
'.':String
xs) = forall (m :: * -> *) a. Monad m => a -> m a
return String
xs
        strip String
_ = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> CabalFileNameParseFail
CabalFileNameParseFail (forall b t. Path b t -> String
toFilePath Path a File
fp))

-- | Find a candidate for the given module-or-filename from the list

-- of directories and given extensions.

findCandidate
    :: [Path Abs Dir]
    -> DotCabalDescriptor
    -> RIO Ctx (Maybe DotCabalPath)
findCandidate :: [Path Abs Dir]
-> DotCabalDescriptor -> RIO Ctx (Maybe DotCabalPath)
findCandidate [Path Abs Dir]
dirs DotCabalDescriptor
name = do
    PackageName
pkg <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Ctx -> Path Abs File
ctxFile forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
MonadThrow m =>
Path a File -> m PackageName
parsePackageNameFromFilePath
    [Text]
customPreprocessorExts <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Config -> [Text]
configCustomPreprocessorExts
    let haskellPreprocessorExts :: [Text]
haskellPreprocessorExts = [Text]
haskellDefaultPreprocessorExts forall a. [a] -> [a] -> [a]
++ [Text]
customPreprocessorExts
    [Path Abs File]
candidates <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Text] -> IO [Path Abs File]
makeNameCandidates [Text]
haskellPreprocessorExts
    case [Path Abs File]
candidates of
        [Path Abs File
candidate] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Path Abs File -> DotCabalPath
cons Path Abs File
candidate))
        [] -> do
            case DotCabalDescriptor
name of
                DotCabalModule ModuleName
mn
                  | forall a. Pretty a => a -> String
display ModuleName
mn forall a. Eq a => a -> a -> Bool
/= PackageName -> String
paths_pkg PackageName
pkg -> forall env.
HasTerm env =>
[Path Abs Dir] -> ModuleName -> RIO env ()
logPossibilities [Path Abs Dir]
dirs ModuleName
mn
                DotCabalDescriptor
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        (Path Abs File
candidate:[Path Abs File]
rest) -> do
            forall b t.
DotCabalDescriptor -> Path b t -> [Path b t] -> RIO Ctx ()
warnMultiple DotCabalDescriptor
name Path Abs File
candidate [Path Abs File]
rest
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Path Abs File -> DotCabalPath
cons Path Abs File
candidate))
  where
    cons :: Path Abs File -> DotCabalPath
cons =
        case DotCabalDescriptor
name of
            DotCabalModule{} -> Path Abs File -> DotCabalPath
DotCabalModulePath
            DotCabalMain{} -> Path Abs File -> DotCabalPath
DotCabalMainPath
            DotCabalFile{} -> Path Abs File -> DotCabalPath
DotCabalFilePath
            DotCabalCFile{} -> Path Abs File -> DotCabalPath
DotCabalCFilePath
    paths_pkg :: PackageName -> String
paths_pkg PackageName
pkg = String
"Paths_" forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
pkg
    makeNameCandidates :: [Text] -> IO [Path Abs File]
makeNameCandidates [Text]
haskellPreprocessorExts =
        forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Text] -> Path Abs Dir -> IO [Path Abs File]
makeDirCandidates [Text]
haskellPreprocessorExts) [Path Abs Dir]
dirs)
    makeDirCandidates :: [Text]
                      -> Path Abs Dir
                      -> IO [Path Abs File]
    makeDirCandidates :: [Text] -> Path Abs Dir -> IO [Path Abs File]
makeDirCandidates [Text]
haskellPreprocessorExts Path Abs Dir
dir =
        case DotCabalDescriptor
name of
            DotCabalMain String
fp -> forall {f :: * -> *}.
(MonadIO f, MonadThrow f) =>
Path Abs Dir -> String -> f [Path Abs File]
resolveCandidate Path Abs Dir
dir String
fp
            DotCabalFile String
fp -> forall {f :: * -> *}.
(MonadIO f, MonadThrow f) =>
Path Abs Dir -> String -> f [Path Abs File]
resolveCandidate Path Abs Dir
dir String
fp
            DotCabalCFile String
fp -> forall {f :: * -> *}.
(MonadIO f, MonadThrow f) =>
Path Abs Dir -> String -> f [Path Abs File]
resolveCandidate Path Abs Dir
dir String
fp
            DotCabalModule ModuleName
mn -> do
              let perExt :: Text -> f [Path Abs File]
perExt Text
ext =
                     forall {f :: * -> *}.
(MonadIO f, MonadThrow f) =>
Path Abs Dir -> String -> f [Path Abs File]
resolveCandidate Path Abs Dir
dir (ModuleName -> String
Cabal.toFilePath ModuleName
mn forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
ext)
              [[Path Abs File]]
withHaskellExts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {f :: * -> *}.
(MonadIO f, MonadThrow f) =>
Text -> f [Path Abs File]
perExt [Text]
haskellFileExts
              [[Path Abs File]]
withPPExts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {f :: * -> *}.
(MonadIO f, MonadThrow f) =>
Text -> f [Path Abs File]
perExt [Text]
haskellPreprocessorExts
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                case (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Path Abs File]]
withHaskellExts, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Path Abs File]]
withPPExts) of
                  -- If we have exactly 1 Haskell extension and exactly

                  -- 1 preprocessor extension, assume the former file is

                  -- generated from the latter

                  --

                  -- See https://github.com/commercialhaskell/stack/issues/4076

                  ([Path Abs File
_], [Path Abs File
y]) -> [Path Abs File
y]

                  -- Otherwise, return everything

                  ([Path Abs File]
xs, [Path Abs File]
ys) -> [Path Abs File]
xs forall a. [a] -> [a] -> [a]
++ [Path Abs File]
ys
    resolveCandidate :: Path Abs Dir -> String -> f [Path Abs File]
resolveCandidate Path Abs Dir
dir = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> String -> m (Maybe (Path Abs File))
resolveDirFile Path Abs Dir
dir

-- | Resolve file as a child of a specified directory, symlinks

-- don't get followed.

resolveDirFile
    :: (MonadIO m, MonadThrow m)
    => Path Abs Dir -> FilePath.FilePath -> m (Maybe (Path Abs File))
resolveDirFile :: forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Path Abs Dir -> String -> m (Maybe (Path Abs File))
resolveDirFile Path Abs Dir
x String
y = do
    -- The standard canonicalizePath does not work for this case

    Path Abs File
p <- forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseCollapsedAbsFile (forall b t. Path b t -> String
toFilePath Path Abs Dir
x String -> String -> String
FilePath.</> String
y)
    Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
p
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
exists then forall a. a -> Maybe a
Just Path Abs File
p else forall a. Maybe a
Nothing

-- | Warn the user that multiple candidates are available for an

-- entry, but that we picked one anyway and continued.

warnMultiple
    :: DotCabalDescriptor -> Path b t -> [Path b t] -> RIO Ctx ()
warnMultiple :: forall b t.
DotCabalDescriptor -> Path b t -> [Path b t] -> RIO Ctx ()
warnMultiple DotCabalDescriptor
name Path b t
candidate [Path b t]
rest =
    -- TODO: figure out how to style 'name' and the dispOne stuff

    forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
        [ String -> StyleDoc
flow String
"There were multiple candidates for the Cabal entry"
        , forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotCabalDescriptor -> String
showName forall a b. (a -> b) -> a -> b
$ DotCabalDescriptor
name
        , StyleDoc
line forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map forall {b} {t}. Path b t -> StyleDoc
dispOne (Path b t
candidateforall a. a -> [a] -> [a]
:[Path b t]
rest))
        , StyleDoc
line forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"picking:"
        , forall {b} {t}. Path b t -> StyleDoc
dispOne Path b t
candidate
        ]
  where showName :: DotCabalDescriptor -> String
showName (DotCabalModule ModuleName
name') = forall a. Pretty a => a -> String
display ModuleName
name'
        showName (DotCabalMain String
fp) = String
fp
        showName (DotCabalFile String
fp) = String
fp
        showName (DotCabalCFile String
fp) = String
fp
        dispOne :: Path b t -> StyleDoc
dispOne = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath
          -- TODO: figure out why dispOne can't be just `display`

          --       (remove the .hlint.yaml exception if it can be)


-- | Log that we couldn't find a candidate, but there are

-- possibilities for custom preprocessor extensions.

--

-- For example: .erb for a Ruby file might exist in one of the

-- directories.

logPossibilities
    :: HasTerm env
    => [Path Abs Dir] -> ModuleName -> RIO env ()
logPossibilities :: forall env.
HasTerm env =>
[Path Abs Dir] -> ModuleName -> RIO env ()
logPossibilities [Path Abs Dir]
dirs ModuleName
mn = do
    [Path Rel File]
possibilities <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall {m :: * -> *} {a}.
(MonadIO m, Pretty a) =>
a -> m [[Path Rel File]]
makePossibilities ModuleName
mn)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Rel File]
possibilities) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
        [ String -> StyleDoc
flow String
"Unable to find a known candidate for the Cabal entry"
        , (Style -> StyleDoc -> StyleDoc
style Style
PP.Module forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> String
display ModuleName
mn) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
        , String -> StyleDoc
flow String
"but did find:"
        , StyleDoc
line forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> StyleDoc
pretty [Path Rel File]
possibilities)
        , String -> StyleDoc
flow String
"If you are using a custom preprocessor for this module"
        , String -> StyleDoc
flow String
"with its own file extension, consider adding the extension"
        , String -> StyleDoc
flow String
"to the 'custom-preprocessor-extensions' field in stack.yaml."
        ]
  where
    makePossibilities :: a -> m [[Path Rel File]]
makePossibilities a
name =
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
            (\Path Abs Dir
dir ->
                  do ([Path Abs Dir]
_,[Path Abs File]
files) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
                     forall (m :: * -> *) a. Monad m => a -> m a
return
                         (forall a b. (a -> b) -> [a] -> [b]
map
                              forall b. Path b File -> Path Rel File
filename
                              (forall a. (a -> Bool) -> [a] -> [a]
filter
                                   (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (forall a. Pretty a => a -> String
display a
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                    forall b t. Path b t -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Path b File -> Path Rel File
filename)
                                   [Path Abs File]
files)))
            [Path Abs Dir]
dirs

-- | Path for the package's build log.

buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m)
             => Package -> Maybe String -> m (Path Abs File)
buildLogPath :: forall env (m :: * -> *).
(MonadReader env m, HasBuildConfig env, MonadThrow m) =>
Package -> Maybe String -> m (Path Abs File)
buildLogPath Package
package' Maybe String
msuffix = do
  env
env <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let stack :: Path Abs Dir
stack = forall env (m :: * -> *).
(HasBuildConfig env, MonadReader env m) =>
m (Path Abs Dir)
getProjectWorkDir env
env
  Path Rel File
fp <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
    PackageIdentifier -> String
packageIdentifierString (Package -> PackageIdentifier
packageIdentifier Package
package') forall a. a -> [a] -> [a]
:
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\String
suffix -> (String
"-" forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
suffix forall a. a -> [a] -> [a]
:)) Maybe String
msuffix [String
".log"]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Path Abs Dir
stack forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirLogs forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
fp

-- Internal helper to define resolveFileOrWarn and resolveDirOrWarn

resolveOrWarn :: Text
              -> (Path Abs Dir -> String -> RIO Ctx (Maybe a))
              -> FilePath.FilePath
              -> RIO Ctx (Maybe a)
resolveOrWarn :: forall a.
Text
-> (Path Abs Dir -> String -> RIO Ctx (Maybe a))
-> String
-> RIO Ctx (Maybe a)
resolveOrWarn Text
subject Path Abs Dir -> String -> RIO Ctx (Maybe a)
resolver String
path =
  do Path Abs Dir
cwd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
     Path Abs File
file <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Ctx -> Path Abs File
ctxFile
     Path Abs Dir
dir <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall b t. Path b t -> Path b Dir
parent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> Path Abs File
ctxFile)
     Maybe a
result <- Path Abs Dir -> String -> RIO Ctx (Maybe a)
resolver Path Abs Dir
dir String
path
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe a
result) forall a b. (a -> b) -> a -> b
$ Text -> Path Abs Dir -> String -> Path Abs File -> RIO Ctx ()
warnMissingFile Text
subject Path Abs Dir
cwd String
path Path Abs File
file
     forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
result

warnMissingFile :: Text -> Path Abs Dir -> FilePath -> Path Abs File -> RIO Ctx ()
warnMissingFile :: Text -> Path Abs Dir -> String -> Path Abs File -> RIO Ctx ()
warnMissingFile Text
subject Path Abs Dir
cwd String
path Path Abs File
fromFile =
    forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
        [ forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
subject -- TODO: needs style?

        , String -> StyleDoc
flow String
"listed in"
        , forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
fromFile) forall a. Pretty a => a -> StyleDoc
pretty (forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
cwd Path Abs File
fromFile)
        , String -> StyleDoc
flow String
"file does not exist:"
        , Style -> StyleDoc -> StyleDoc
style Style
Dir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String
path
        ]

-- | Resolve the file, if it can't be resolved, warn for the user

-- (purely to be helpful).

resolveFileOrWarn :: FilePath.FilePath
                  -> RIO Ctx (Maybe (Path Abs File))
resolveFileOrWarn :: String -> RIO Ctx (Maybe (Path Abs File))
resolveFileOrWarn = forall a.
Text
-> (Path Abs Dir -> String -> RIO Ctx (Maybe a))
-> String
-> RIO Ctx (Maybe a)
resolveOrWarn Text
"File" forall {m :: * -> *}.
MonadIO m =>
Path Abs Dir -> String -> m (Maybe (Path Abs File))
f
  where f :: Path Abs Dir -> String -> m (Maybe (Path Abs File))
f Path Abs Dir
p String
x = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence (forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs File)
resolveFile Path Abs Dir
p String
x)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadIO m =>
Maybe (Path Abs File) -> m (Maybe (Path Abs File))
rejectMissingFile

-- | Resolve the directory, if it can't be resolved, warn for the user

-- (purely to be helpful).

resolveDirOrWarn :: FilePath.FilePath
                 -> RIO Ctx (Maybe (Path Abs Dir))
resolveDirOrWarn :: String -> RIO Ctx (Maybe (Path Abs Dir))
resolveDirOrWarn = forall a.
Text
-> (Path Abs Dir -> String -> RIO Ctx (Maybe a))
-> String
-> RIO Ctx (Maybe a)
resolveOrWarn Text
"Directory" forall {m :: * -> *}.
MonadIO m =>
Path Abs Dir -> String -> m (Maybe (Path Abs Dir))
f
  where f :: Path Abs Dir -> String -> m (Maybe (Path Abs Dir))
f Path Abs Dir
p String
x = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence (forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs Dir)
resolveDir Path Abs Dir
p String
x)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadIO m =>
Maybe (Path Abs Dir) -> m (Maybe (Path Abs Dir))
rejectMissingDir

    {- FIXME
-- | Create a 'ProjectPackage' from a directory containing a package.
mkProjectPackage
  :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PrintWarnings
  -> ResolvedPath Dir
  -> RIO env ProjectPackage
mkProjectPackage printWarnings dir = do
  (gpd, name, cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)
  return ProjectPackage
    { ppCabalFP = cabalfp
    , ppGPD' = gpd printWarnings
    , ppResolvedDir = dir
    , ppName = name
    }

-- | Create a 'DepPackage' from a 'PackageLocation'
mkDepPackage
  :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageLocation
  -> RIO env DepPackage
mkDepPackage pl = do
  (name, gpdio) <-
    case pl of
      PLMutable dir -> do
        (gpdio, name, _cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)
        pure (name, gpdio NoPrintWarnings)
      PLImmutable pli -> do
        PackageIdentifier name _ <- getPackageLocationIdent pli
        run <- askRunInIO
        pure (name, run $ loadCabalFileImmutable pli)
  return DepPackage
    { dpGPD' = gpdio
    , dpLocation = pl
    , dpName = name
    }

    -}

-- | Force a package to be treated as a custom build type, see

-- <https://github.com/commercialhaskell/stack/issues/4488>

applyForceCustomBuild
  :: Version -- ^ global Cabal version

  -> Package
  -> Package
applyForceCustomBuild :: Version -> Package -> Package
applyForceCustomBuild Version
cabalVersion Package
package
    | Bool
forceCustomBuild =
        Package
package
          { packageBuildType :: BuildType
packageBuildType = BuildType
Custom
          , packageDeps :: Map PackageName DepValue
packageDeps = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Semigroup a => a -> a -> a
(<>) PackageName
"Cabal" (VersionRange -> DepType -> DepValue
DepValue VersionRange
cabalVersionRange DepType
AsLibrary)
                        forall a b. (a -> b) -> a -> b
$ Package -> Map PackageName DepValue
packageDeps Package
package
          , packageSetupDeps :: Maybe (Map PackageName VersionRange)
packageSetupDeps = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
              [ (PackageName
"Cabal", VersionRange
cabalVersionRange)
              , (PackageName
"base", VersionRange
anyVersion)
              ]
          }
    | Bool
otherwise = Package
package
  where
    cabalVersionRange :: VersionRange
cabalVersionRange =
      Version -> VersionRange
orLaterVersion forall a b. (a -> b) -> a -> b
$ [Int] -> Version
mkVersion forall a b. (a -> b) -> a -> b
$ CabalSpecVersion -> [Int]
cabalSpecToVersionDigits forall a b. (a -> b) -> a -> b
$
        Package -> CabalSpecVersion
packageCabalSpec Package
package
    forceCustomBuild :: Bool
forceCustomBuild =
      Package -> BuildType
packageBuildType Package
package forall a. Eq a => a -> a -> Bool
== BuildType
Simple Bool -> Bool -> Bool
&&
      Bool -> Bool
not (Version
cabalVersion Version -> VersionRange -> Bool
`withinRange` VersionRange
cabalVersionRange)