{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE TupleSections #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE DataKinds #-}

{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE RankNTypes #-}

{-# LANGUAGE RecordWildCards #-}

-- | 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 Data.Maybe (maybe)

import qualified Data.Map.Strict as M

import qualified Data.Set as S

import qualified Data.Text as T

import Distribution.Compiler

import Distribution.ModuleName (ModuleName)

import qualified Distribution.ModuleName as Cabal

import qualified Distribution.Package as D

import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier)

import qualified Distribution.PackageDescription as D

import Distribution.PackageDescription hiding (FlagName)

import Distribution.PackageDescription.Parsec

import Distribution.Simple.Glob (matchDirFileGlob)

import Distribution.System (OS (..), Arch, Platform (..))

import qualified Distribution.Text as D

import qualified Distribution.Types.CondTree as Cabal

import qualified Distribution.Types.ExeDependency as Cabal

import Distribution.Types.ForeignLib

import qualified Distribution.Types.LegacyExeDependency as Cabal

import Distribution.Types.MungedPackageName

import qualified Distribution.Types.UnqualComponentName as Cabal

import qualified Distribution.Verbosity as D

import Distribution.Version (mkVersion, orLaterVersion, anyVersion)

import qualified HiFileParser as Iface

import Path as FL

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

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 { ctxFile :: !(Path Abs File)

, ctxDistDir :: !(Path Abs Dir)

, ctxBuildConfig :: !BuildConfig

}

instance HasPlatform Ctx

instance HasGHCVariant Ctx

instance HasLogFunc Ctx where

logFuncL = configL.logFuncL

instance HasRunner Ctx where

runnerL = configL.runnerL

instance HasStylesUpdate Ctx where

stylesUpdateL = runnerL.stylesUpdateL

instance HasTerm Ctx where

useColorL = runnerL.useColorL

termWidthL = runnerL.termWidthL

instance HasConfig Ctx

instance HasPantryConfig Ctx where

pantryConfigL = configL.pantryConfigL

instance HasProcessContext Ctx where

processContextL = configL.processContextL

instance HasBuildConfig Ctx where

buildConfigL = lens ctxBuildConfig (\x y -> x { ctxBuildConfig = 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 buildinfofp =

liftIO $ readHookedBuildInfo D.silent (toFilePath 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 gpkg =

packageFromPackageDescription

packageConfig

(genPackageFlags gpkg)

(resolvePackageDescription packageConfig gpkg)

packageFromPackageDescription :: PackageConfig

-> [D.Flag]

-> PackageDescriptionPair

-> Package

packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkgNoMod pkg) =

Package

{ packageName = name

, packageVersion = pkgVersion pkgId

, packageLicense = licenseRaw pkg

, packageDeps = deps

, packageFiles = pkgFiles

, packageUnknownTools = unknownTools

, packageGhcOptions = packageConfigGhcOptions packageConfig

, packageCabalConfigOpts = packageConfigCabalConfigOpts packageConfig

, packageFlags = packageConfigFlags packageConfig

, packageDefaultFlags = M.fromList

[(flagName flag, flagDefault flag) | flag <- pkgFlags]

, packageAllDeps = S.fromList (M.keys deps)

, packageLibraries =

let mlib = do

lib <- library pkg

guard $ buildable $ libBuildInfo lib

Just lib

in

case mlib of

Nothing -> NoLibraries

Just _ -> HasLibraries foreignLibNames

, packageInternalLibraries = subLibNames

, packageTests = M.fromList

[(T.pack (Cabal.unUnqualComponentName $ testName t), testInterface t)

| t <- testSuites pkgNoMod

, buildable (testBuildInfo t)

]

, packageBenchmarks = S.fromList

[T.pack (Cabal.unUnqualComponentName $ benchmarkName b)

| b <- benchmarks pkgNoMod

, buildable (benchmarkBuildInfo b)

]

-- Same comment about buildable applies here too.

, packageExes = S.fromList

[T.pack (Cabal.unUnqualComponentName $ exeName biBuildInfo)

| biBuildInfo <- executables pkg

, buildable (buildInfo 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 $

\installMap installedMap omitPkgs addPkgs cabalfp ->

do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp

let internals = S.toList $ internalLibComponents $ M.keysSet componentsModules

excludedInternals <- mapM (parsePackageNameThrowing . T.unpack) internals

mungedInternals <- mapM (parsePackageNameThrowing . T.unpack .

toInternalPackageMungedName) internals

componentsOpts <-

generatePkgDescOpts installMap installedMap

(excludedInternals ++ omitPkgs) (mungedInternals ++ addPkgs)

cabalfp pkg componentFiles

return (componentsModules,componentFiles,componentsOpts)

, packageHasExposedModules = maybe

False

(not . null . exposedModules)

(library pkg)

, packageBuildType = buildType pkg

, packageSetupDeps = msetupDeps

, packageCabalSpec = either orLaterVersion id $ specVersionRaw pkg

}

where

extraLibNames = S.union subLibNames foreignLibNames

subLibNames

= S.fromList

$ map (T.pack . Cabal.unUnqualComponentName)

$ mapMaybe libName -- this is a design bug in the Cabal API: this should statically be known to exist

$ filter (buildable . libBuildInfo)

$ subLibraries pkg

foreignLibNames

= S.fromList

$ map (T.pack . Cabal.unUnqualComponentName . foreignLibName)

$ filter (buildable . foreignLibBuildInfo)

$ foreignLibs pkg

toInternalPackageMungedName

= T.pack . unMungedPackageName . computeCompatPackageName (pkgName pkgId)

. Just . Cabal.mkUnqualComponentName . 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 $

\cabalfp -> debugBracket ("getPackageFiles" <+> pretty cabalfp) $ do

let pkgDir = parent cabalfp

distDir <- distDirFromDir pkgDir

bc <- view buildConfigL

(componentModules,componentFiles,dataFiles',warnings) <-

runRIO

(Ctx cabalfp distDir bc)

(packageDescModulesAndFiles pkg)

setupFiles <-

if buildType pkg == Custom

then do

let setupHsPath = pkgDir </> relFileSetupHs

setupLhsPath = pkgDir </> relFileSetupLhs

setupHsExists <- doesFileExist setupHsPath

if setupHsExists then return (S.singleton setupHsPath) else do

setupLhsExists <- doesFileExist setupLhsPath

if setupLhsExists then return (S.singleton setupLhsPath) else return S.empty

else return S.empty

buildFiles <- liftM (S.insert cabalfp . S.union setupFiles) $ do

let hpackPath = pkgDir </> relFileHpackPackageConfig

hpackExists <- doesFileExist hpackPath

return $ if hpackExists then S.singleton hpackPath else S.empty

return (componentModules, componentFiles, buildFiles <> dataFiles', warnings)

pkgId = package pkg

name = pkgName pkgId

(unknownTools, knownTools) = packageDescTools pkg

deps = M.filterWithKey (const . not . isMe) (M.unionsWith (<>)

[ asLibrary <$> packageDependencies packageConfig 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.

, asLibrary <$> fromMaybe M.empty msetupDeps

, knownTools

])

msetupDeps = fmap

(M.fromList . map (depName &&& depRange) . setupDepends)

(setupBuildInfo pkg)

asLibrary range = DepValue

{ dvVersionRange = range

, dvType = AsLibrary

}

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

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

isMe name' = name' == name || fromString (packageNameString name') `S.member` 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 installMap installedMap omitPkgs addPkgs cabalfp pkg componentPaths = do

config <- view configL

cabalVer <- view cabalVersionL

distDir <- distDirFromDir cabalDir

let generate namedComponent binfo =

( namedComponent

, generateBuildInfoOpts BioInput

{ biInstallMap = installMap

, biInstalledMap = installedMap

, biCabalDir = cabalDir

, biDistDir = distDir

, biOmitPackages = omitPkgs

, biAddPackages = addPkgs

, biBuildInfo = binfo

, biDotCabalPaths = fromMaybe [] (M.lookup namedComponent componentPaths)

, biConfigLibDirs = configExtraLibDirs config

, biConfigIncludeDirs = configExtraIncludeDirs config

, biComponentName = namedComponent

, biCabalVersion = cabalVer

}

)

return

( M.fromList

(concat

[ maybe

[]

(return . generate CLib . libBuildInfo)

(library pkg)

, mapMaybe

(\sublib -> do

let maybeLib = CInternalLib . T.pack . Cabal.unUnqualComponentName <$> libName sublib

flip generate (libBuildInfo sublib) <$> maybeLib

)

(subLibraries pkg)

, fmap

(\exe ->

generate

(CExe (T.pack (Cabal.unUnqualComponentName (exeName exe))))

(buildInfo exe))

(executables pkg)

, fmap

(\bench ->

generate

(CBench (T.pack (Cabal.unUnqualComponentName (benchmarkName bench))))

(benchmarkBuildInfo bench))

(benchmarks pkg)

, fmap

(\test ->

generate

(CTest (T.pack (Cabal.unUnqualComponentName (testName test))))

(testBuildInfo test))

(testSuites pkg)]))

where

cabalDir = parent cabalfp

-- | Input to 'generateBuildInfoOpts'

data BioInput = BioInput

{ biInstallMap :: !InstallMap

, biInstalledMap :: !InstalledMap

, biCabalDir :: !(Path Abs Dir)

, biDistDir :: !(Path Abs Dir)

, biOmitPackages :: ![PackageName]

, biAddPackages :: ![PackageName]

, biBuildInfo :: !BuildInfo

, biDotCabalPaths :: ![DotCabalPath]

, biConfigLibDirs :: ![FilePath]

, biConfigIncludeDirs :: ![FilePath]

, biComponentName :: !NamedComponent

, 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

{ bioOpts = ghcOpts ++ cppOptions 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 = nubOrd $ concat

[extOpts, srcOpts, includeOpts, libOpts, fworks, cObjectFiles]

, bioPackageFlags = deps

, bioCabalMacros = componentAutogen </> relFileCabalMacrosH

}

where

cObjectFiles =

mapMaybe (fmap toFilePath .

makeObjectFilePathFromC biCabalDir biComponentName biDistDir)

cfiles

cfiles = mapMaybe dotCabalCFilePath biDotCabalPaths

installVersion = snd

-- Generates: -package=base -package=base16-bytestring-0.1.1.6 ...

deps =

concat

[ case M.lookup name biInstalledMap of

Just (_, Stack.Types.Package.Library _ident ipid _) -> ["-package-id=" <> ghcPkgIdString ipid]

_ -> ["-package=" <> packageNameString name <>

maybe "" -- This empty case applies to e.g. base.

((("-" <>) . versionString) . installVersion)

(M.lookup name biInstallMap)]

| name <- pkgs]

pkgs =

biAddPackages ++

[ name

| Dependency name _ <- targetBuildDepends biBuildInfo

, name `notElem` biOmitPackages]

ghcOpts = concatMap snd . filter (isGhc . fst) $ options biBuildInfo

where

isGhc GHC = True

isGhc _ = False

extOpts = map (("-X" ++) . D.display) (usedExtensions biBuildInfo)

srcOpts =

map (("-i" <>) . toFilePathNoTrailingSep)

(concat

[ [ componentBuildDir biCabalVersion biComponentName biDistDir ]

, [ biCabalDir

| null (hsSourceDirs biBuildInfo)

]

, mapMaybe toIncludeDir (hsSourceDirs biBuildInfo)

, [ componentAutogen ]

, maybeToList (packageAutogenDir biCabalVersion biDistDir)

, [ componentOutputDir biComponentName biDistDir ]

]) ++

[ "-stubdir=" ++ toFilePathNoTrailingSep (buildDir biDistDir) ]

componentAutogen = componentAutogenDir biCabalVersion biComponentName biDistDir

toIncludeDir "." = Just biCabalDir

toIncludeDir relDir = concatAndColapseAbsDir biCabalDir relDir

includeOpts =

map ("-I" <>) (biConfigIncludeDirs <> pkgIncludeOpts)

pkgIncludeOpts =

[ toFilePathNoTrailingSep absDir

| dir <- includeDirs biBuildInfo

, absDir <- handleDir dir

]

libOpts =

map ("-l" <>) (extraLibs biBuildInfo) <>

map ("-L" <>) (biConfigLibDirs <> pkgLibDirs)

pkgLibDirs =

[ toFilePathNoTrailingSep absDir

| dir <- extraLibDirs biBuildInfo

, absDir <- handleDir dir

]

handleDir dir = case (parseAbsDir dir, parseRelDir dir) of

(Just ab, _ ) -> [ab]

(_ , Just rel) -> [biCabalDir </> rel]

(Nothing, Nothing ) -> []

fworks = map (\fwk -> "-framework=" <> fwk) (frameworks 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 cabalDir namedComponent distDir cFilePath = do

relCFilePath <- stripProperPrefix cabalDir cFilePath

relOFilePath <-

parseRelFile (replaceExtension (toFilePath relCFilePath) "o")

return (componentOutputDir namedComponent distDir </> relOFilePath)

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

packageAutogenDir :: Version -> Path Abs Dir -> Maybe (Path Abs Dir)

packageAutogenDir cabalVer distDir

| cabalVer < mkVersion [2, 0] = Nothing

| otherwise = Just $ buildDir distDir </> relDirGlobalAutogen

-- | Make the autogen dir.

componentAutogenDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir

componentAutogenDir cabalVer component distDir =

componentBuildDir cabalVer component distDir </> relDirAutogen

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

componentBuildDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir

componentBuildDir cabalVer component distDir

| cabalVer < mkVersion [2, 0] = buildDir distDir

| otherwise =

case component of

CLib -> buildDir distDir

CInternalLib name -> buildDir distDir </> componentNameToDir name

CExe name -> buildDir distDir </> componentNameToDir name

CTest name -> buildDir distDir </> componentNameToDir name

CBench name -> buildDir distDir </> componentNameToDir 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 distDir =

case namedComponent of

CLib -> buildDir distDir

CInternalLib name -> makeTmp name

CExe name -> makeTmp name

CTest name -> makeTmp name

CBench name -> makeTmp name

where

makeTmp name =

buildDir distDir </> componentNameToDir (name <> "/" <> name <> "-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 distDir = distDir </> relDirBuild

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

-- component names.

componentNameToDir :: Text -> Path Rel Dir

componentNameToDir name =

fromMaybe (error "Invariant violated: component names should always parse as directory names")

(parseRelDir (T.unpack 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 pkgConfig pkg' =

M.fromListWith intersectVersionRanges $

map (depName &&& depRange) $

concatMap targetBuildDepends (allBuildInfo' pkg) ++

maybe [] setupDepends (setupBuildInfo pkg)

where

pkg

| getGhcVersion (packageConfigCompilerVersion pkgConfig) >= mkVersion [8, 0] = 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

| otherwise = pkg'

{ library = (\c -> c { libBuildInfo = go (libBuildInfo c) }) <$> library pkg'

, executables = (\c -> c { buildInfo = go (buildInfo c) }) <$> executables pkg'

, testSuites =

if packageConfigEnableTests pkgConfig

then (\c -> c { testBuildInfo = go (testBuildInfo c) }) <$> testSuites pkg'

else testSuites pkg'

, benchmarks =

if packageConfigEnableBenchmarks pkgConfig

then (\c -> c { benchmarkBuildInfo = go (benchmarkBuildInfo c) }) <$> benchmarks pkg'

else benchmarks pkg'

}

go bi = bi { buildable = 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 pd =

(S.fromList $ concat unknowns, M.fromListWith (<>) $ concat knowns)

where

(unknowns, knowns) = unzip $ map perBI $ allBuildInfo' pd

perBI :: BuildInfo -> ([ExeName], [(PackageName, DepValue)])

perBI bi =

(unknownTools, tools)

where

(unknownTools, knownTools) = partitionEithers $ map go1 (buildTools bi)

tools = mapMaybe go2 (knownTools ++ buildToolDepends 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 (Cabal.LegacyExeDependency name range) =

case M.lookup name hardCodedMap of

Just pkgName -> Right $ Cabal.ExeDependency pkgName (Cabal.mkUnqualComponentName name) range

Nothing -> Left $ ExeName $ T.pack name

go2 :: Cabal.ExeDependency -> Maybe (PackageName, DepValue)

go2 (Cabal.ExeDependency pkg _name range)

| pkg `S.member` preInstalledPackages = Nothing

| otherwise = Just

( pkg

, DepValue

{ dvVersionRange = range

, dvType = AsBuildTool

}

)

-- | A hard-coded map for tool dependencies

hardCodedMap :: Map String D.PackageName

hardCodedMap = M.fromList

[ ("alex", Distribution.Package.mkPackageName "alex")

, ("happy", Distribution.Package.mkPackageName "happy")

, ("cpphs", Distribution.Package.mkPackageName "cpphs")

, ("greencard", Distribution.Package.mkPackageName "greencard")

, ("c2hs", Distribution.Package.mkPackageName "c2hs")

, ("hscolour", Distribution.Package.mkPackageName "hscolour")

, ("hspec-discover", Distribution.Package.mkPackageName "hspec-discover")

, ("hsx2hs", Distribution.Package.mkPackageName "hsx2hs")

, ("gtk2hsC2hs", Distribution.Package.mkPackageName "gtk2hs-buildtools")

, ("gtk2hsHookGenerator", Distribution.Package.mkPackageName "gtk2hs-buildtools")

, ("gtk2hsTypeGen", Distribution.Package.mkPackageName "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 D.PackageName

preInstalledPackages = S.fromList

[ D.mkPackageName "hsc2hs"

, D.mkPackageName "haddock"

]

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

-- 2.2, only includes buildable components.

allBuildInfo' :: PackageDescription -> [BuildInfo]

allBuildInfo' pkg_descr = [ bi | lib <- allLibraries pkg_descr

, let bi = libBuildInfo lib

, buildable bi ]

++ [ bi | flib <- foreignLibs pkg_descr

, let bi = foreignLibBuildInfo flib

, buildable bi ]

++ [ bi | exe <- executables pkg_descr

, let bi = buildInfo exe

, buildable bi ]

++ [ bi | tst <- testSuites pkg_descr

, let bi = testBuildInfo tst

, buildable bi ]

++ [ bi | tst <- benchmarks pkg_descr

, let bi = benchmarkBuildInfo tst

, buildable 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 pkg = do

(libraryMods,libDotCabalFiles,libWarnings) <-

maybe

(return (M.empty, M.empty, []))

(asModuleAndFileMap libComponent libraryFiles)

(library pkg)

(subLibrariesMods,subLibDotCabalFiles,subLibWarnings) <-

liftM

foldTuples

(mapM

(asModuleAndFileMap internalLibComponent libraryFiles)

(subLibraries pkg))

(executableMods,exeDotCabalFiles,exeWarnings) <-

liftM

foldTuples

(mapM

(asModuleAndFileMap exeComponent executableFiles)

(executables pkg))

(testMods,testDotCabalFiles,testWarnings) <-

liftM

foldTuples

(mapM (asModuleAndFileMap testComponent testFiles) (testSuites pkg))

(benchModules,benchDotCabalPaths,benchWarnings) <-

liftM

foldTuples

(mapM

(asModuleAndFileMap benchComponent benchmarkFiles)

(benchmarks pkg))

dfiles <- resolveGlobFiles (specVersion pkg)

(extraSrcFiles pkg

++ map (dataDir pkg FilePath.</>) (dataFiles pkg))

let modules = libraryMods <> subLibrariesMods <> executableMods <> testMods <> benchModules

files =

libDotCabalFiles <> subLibDotCabalFiles <> exeDotCabalFiles <> testDotCabalFiles <>

benchDotCabalPaths

warnings = libWarnings <> subLibWarnings <> exeWarnings <> testWarnings <> benchWarnings

return (modules, files, dfiles, warnings)

where

libComponent = const CLib

internalLibComponent = CInternalLib . T.pack . maybe "" Cabal.unUnqualComponentName . libName

exeComponent = CExe . T.pack . Cabal.unUnqualComponentName . exeName

testComponent = CTest . T.pack . Cabal.unUnqualComponentName . testName

benchComponent = CBench . T.pack . Cabal.unUnqualComponentName . benchmarkName

asModuleAndFileMap label f lib = do

(a,b,c) <- f (label lib) lib

return (M.singleton (label lib) a, M.singleton (label lib) b, c)

foldTuples = foldl' (<>) (M.empty, M.empty, [])

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

resolveGlobFiles

:: Version -- ^ cabal file version

-> [String]

-> RIO Ctx (Set (Path Abs File))

resolveGlobFiles cabalFileVersion =

liftM (S.fromList . catMaybes . concat) .

mapM resolve

where

resolve name =

if '*' `elem` name

then explode name

else liftM return (resolveFileOrWarn name)

explode name = do

dir <- asks (parent . ctxFile)

names <-

matchDirFileGlob'

(FL.toFilePath dir)

name

mapM resolveFileOrWarn names

matchDirFileGlob' dir glob =

catch

(liftIO (matchDirFileGlob minBound cabalFileVersion dir glob))

(\(e :: IOException) ->

if isUserError e

then do

prettyWarnL

[ flow "Wildcard does not match any files:"

, style File $ fromString glob

, line <> flow "in directory:"

, style Dir $ fromString dir

]

return []

else throwIO e)

-- | Get all files referenced by the benchmark.

benchmarkFiles

:: NamedComponent

-> Benchmark

-> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])

benchmarkFiles component bench = do

resolveComponentFiles component build names

where

names = bnames <> exposed

exposed =

case benchmarkInterface bench of

BenchmarkExeV10 _ fp -> [DotCabalMain fp]

BenchmarkUnsupported _ -> []

bnames = map DotCabalModule (otherModules build)

build = benchmarkBuildInfo bench

-- | Get all files referenced by the test.

testFiles

:: NamedComponent

-> TestSuite

-> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])

testFiles component test = do

resolveComponentFiles component build names

where

names = bnames <> exposed

exposed =

case testInterface test of

TestSuiteExeV10 _ fp -> [DotCabalMain fp]

TestSuiteLibV09 _ mn -> [DotCabalModule mn]

TestSuiteUnsupported _ -> []

bnames = map DotCabalModule (otherModules build)

build = testBuildInfo test

-- | Get all files referenced by the executable.

executableFiles

:: NamedComponent

-> Executable

-> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])

executableFiles component exe = do

resolveComponentFiles component build names

where

build = buildInfo exe

names =

map DotCabalModule (otherModules build) ++

[DotCabalMain (modulePath exe)]

-- | Get all files referenced by the library.

libraryFiles

:: NamedComponent

-> Library

-> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])

libraryFiles component lib = do

resolveComponentFiles component build names

where

build = libBuildInfo lib

names = bnames ++ exposed

exposed = map DotCabalModule (exposedModules lib)

bnames = map DotCabalModule (otherModules build)

-- | Get all files referenced by the component.

resolveComponentFiles

:: NamedComponent

-> BuildInfo

-> [DotCabalDescriptor]

-> RIO Ctx (Map ModuleName (Path Abs File), [DotCabalPath], [PackageWarning])

resolveComponentFiles component build names = do

dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)

dir <- asks (parent . ctxFile)

(modules,files,warnings) <-

resolveFilesAndDeps

component

(if null dirs then [dir] else dirs)

names

cfiles <- buildOtherSources build

return (modules, files <> cfiles, warnings)

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

buildOtherSources :: BuildInfo -> RIO Ctx [DotCabalPath]

buildOtherSources build = do

cwd <- liftIO getCurrentDir

dir <- asks (parent . ctxFile)

file <- asks ctxFile

let resolveDirFiles files toCabalPath =

forMaybeM files $ \fp -> do

result <- resolveDirFile dir fp

case result of

Nothing -> do

warnMissingFile "File" cwd fp file

return Nothing

Just p -> return $ Just (toCabalPath p)

csources <- resolveDirFiles (cSources build) DotCabalCFilePath

jsources <- resolveDirFiles (targetJsSources build) DotCabalFilePath

return (csources <> jsources)

-- | Get the target's JS sources.

targetJsSources :: BuildInfo -> [FilePath]

targetJsSources = 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

{ pdpOrigBuildable :: PackageDescription

, pdpModifiedBuildable :: PackageDescription

}

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

-- a resolved 'PackageDescription'.

resolvePackageDescription :: PackageConfig

-> GenericPackageDescription

-> PackageDescriptionPair

resolvePackageDescription packageConfig (GenericPackageDescription desc defaultFlags mlib subLibs foreignLibs' exes tests benches) =

PackageDescriptionPair

{ pdpOrigBuildable = go False

, pdpModifiedBuildable = go True

}

where

go modBuildable =

desc {library =

fmap (resolveConditions rc updateLibDeps) mlib

,subLibraries =

map (\(n, v) -> (resolveConditions rc updateLibDeps v){libName=Just n})

subLibs

,foreignLibs =

map (\(n, v) -> (resolveConditions rc updateForeignLibDeps v){foreignLibName=n})

foreignLibs'

,executables =

map (\(n, v) -> (resolveConditions rc updateExeDeps v){exeName=n})

exes

,testSuites =

map (\(n,v) -> (resolveConditions rc (updateTestDeps modBuildable) v){testName=n})

tests

,benchmarks =

map (\(n,v) -> (resolveConditions rc (updateBenchmarkDeps modBuildable) v){benchmarkName=n})

benches}

flags =

M.union (packageConfigFlags packageConfig)

(flagMap defaultFlags)

rc = mkResolveConditions

(packageConfigCompilerVersion packageConfig)

(packageConfigPlatform packageConfig)

flags

updateLibDeps lib deps =

lib {libBuildInfo =

(libBuildInfo lib) {targetBuildDepends = deps}}

updateForeignLibDeps lib deps =

lib {foreignLibBuildInfo =

(foreignLibBuildInfo lib) {targetBuildDepends = deps}}

updateExeDeps exe deps =

exe {buildInfo =

(buildInfo exe) {targetBuildDepends = 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 modBuildable test deps =

let bi = testBuildInfo test

bi' = bi

{ targetBuildDepends = deps

, buildable = buildable bi && (if modBuildable then packageConfigEnableTests packageConfig else True)

}

in test { testBuildInfo = bi' }

updateBenchmarkDeps modBuildable benchmark deps =

let bi = benchmarkBuildInfo benchmark

bi' = bi

{ targetBuildDepends = deps

, buildable = buildable bi && (if modBuildable then packageConfigEnableBenchmarks packageConfig else True)

}

in benchmark { benchmarkBuildInfo = bi' }

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

--

-- What is @flagManual@ for?

flagMap :: [Flag] -> Map FlagName Bool

flagMap = M.fromList . map pair

where pair :: Flag -> (FlagName, Bool)

pair = flagName &&& flagDefault

data ResolveConditions = ResolveConditions

{ rcFlags :: Map FlagName Bool

, rcCompilerVersion :: ActualCompiler

, rcOS :: OS

, rcArch :: Arch

}

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

mkResolveConditions :: ActualCompiler -- ^ Compiler version

-> Platform -- ^ installation target platform

-> Map FlagName Bool -- ^ enabled flags

-> ResolveConditions

mkResolveConditions compilerVersion (Platform arch os) flags = ResolveConditions

{ rcFlags = flags

, rcCompilerVersion = compilerVersion

, rcOS = os

, rcArch = 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 rc addDeps (CondNode lib deps cs) = basic <> children

where basic = addDeps lib deps

children = mconcat (map apply cs)

where apply (Cabal.CondBranch cond node mcs) =

if condSatisfied cond

then resolveConditions rc addDeps node

else maybe mempty (resolveConditions rc addDeps) mcs

condSatisfied c =

case c of

Var v -> varSatisifed v

Lit b -> b

CNot c' ->

not (condSatisfied c')

COr cx cy ->

condSatisfied cx || condSatisfied cy

CAnd cx cy ->

condSatisfied cx && condSatisfied cy

varSatisifed v =

case v of

OS os -> os == rcOS rc

Arch arch -> arch == rcArch rc

Flag flag ->

fromMaybe False $ M.lookup flag (rcFlags rc)

-- NOTE: ^^^^^ This should never happen, as all flags

-- which are used must be declared. Defaulting to

-- False.

Impl flavor range ->

case (flavor, rcCompilerVersion rc) of

(GHC, ACGhc vghc) -> vghc `withinRange` range

(GHC, ACGhcjs _ vghc) -> vghc `withinRange` range

(GHCJS, ACGhcjs vghcjs _) ->

vghcjs `withinRange` range

_ -> False

-- | Get the name of a dependency.

depName :: Dependency -> PackageName

depName (Dependency n _) = n

-- | Get the version range of a dependency.

depRange :: Dependency -> VersionRange

depRange (Dependency _ r) = r

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