{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Test.DocTest.Helpers where
import GHC.Stack (HasCallStack)
import System.Directory
( canonicalizePath, doesFileExist )
import System.FilePath ((</>), isDrive, takeDirectory)
import System.FilePath.Glob (glob)
import System.Info (compilerVersion)
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid ((<>))
#endif
import qualified Data.Set as Set
import Distribution.ModuleName (ModuleName)
import Distribution.Simple
( Extension (DisableExtension, EnableExtension, UnknownExtension) )
import Distribution.Types.UnqualComponentName ( unUnqualComponentName )
import Distribution.PackageDescription
( GenericPackageDescription (condLibrary)
, exposedModules, libBuildInfo, hsSourceDirs, defaultExtensions, package
, packageDescription, condSubLibraries, includeDirs, autogenModules, ConfVar )
import Distribution.Compiler (CompilerFlavor(GHC))
import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
import Distribution.Pretty (prettyShow)
import Distribution.System (buildArch, buildOS)
import Distribution.Types.Condition (Condition(..))
import Distribution.Types.CondTree
import Distribution.Types.ConfVar (ConfVar(..))
import Distribution.Types.Version (Version, mkVersion')
import Distribution.Types.VersionRange (withinRange)
import Distribution.Verbosity (silent)
#if MIN_VERSION_Cabal(3,6,0)
import Distribution.Utils.Path (SourceDir, PackageDir, SymbolicPath)
#endif
rmList :: Ord a => [a] -> [a] -> [a]
rmList :: [a] -> [a] -> [a]
rmList [a]
xs ([a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList -> Set a
ys) = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
ys)) [a]
xs
data Library = Library
{ Library -> [FilePath]
libSourceDirectories :: [FilePath]
, Library -> [FilePath]
libCSourceDirectories :: [FilePath]
, Library -> [ModuleName]
libModules :: [ModuleName]
, Library -> [Extension]
libDefaultExtensions :: [Extension]
}
deriving (Int -> Library -> ShowS
[Library] -> ShowS
Library -> FilePath
(Int -> Library -> ShowS)
-> (Library -> FilePath) -> ([Library] -> ShowS) -> Show Library
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Library] -> ShowS
$cshowList :: [Library] -> ShowS
show :: Library -> FilePath
$cshow :: Library -> FilePath
showsPrec :: Int -> Library -> ShowS
$cshowsPrec :: Int -> Library -> ShowS
Show)
mergeLibraries :: [Library] -> Library
mergeLibraries :: [Library] -> Library
mergeLibraries [Library]
libs = Library :: [FilePath] -> [FilePath] -> [ModuleName] -> [Extension] -> Library
Library
{ libSourceDirectories :: [FilePath]
libSourceDirectories = (Library -> [FilePath]) -> [Library] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Library -> [FilePath]
libSourceDirectories [Library]
libs
, libCSourceDirectories :: [FilePath]
libCSourceDirectories = (Library -> [FilePath]) -> [Library] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Library -> [FilePath]
libCSourceDirectories [Library]
libs
, libModules :: [ModuleName]
libModules = (Library -> [ModuleName]) -> [Library] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Library -> [ModuleName]
libModules [Library]
libs
, libDefaultExtensions :: [Extension]
libDefaultExtensions = (Library -> [Extension]) -> [Library] -> [Extension]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Library -> [Extension]
libDefaultExtensions [Library]
libs
}
libraryToGhciArgs :: Library -> ([String], [String], [String])
libraryToGhciArgs :: Library -> ([FilePath], [FilePath], [FilePath])
libraryToGhciArgs Library{[FilePath]
[Extension]
[ModuleName]
libDefaultExtensions :: [Extension]
libModules :: [ModuleName]
libCSourceDirectories :: [FilePath]
libSourceDirectories :: [FilePath]
libDefaultExtensions :: Library -> [Extension]
libModules :: Library -> [ModuleName]
libCSourceDirectories :: Library -> [FilePath]
libSourceDirectories :: Library -> [FilePath]
..} = ([FilePath]
hsSrcArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
cSrcArgs, [FilePath]
modArgs, [FilePath]
extArgs)
where
hsSrcArgs :: [FilePath]
hsSrcArgs = ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-i" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>) [FilePath]
libSourceDirectories
cSrcArgs :: [FilePath]
cSrcArgs = ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-I" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>) [FilePath]
libCSourceDirectories
modArgs :: [FilePath]
modArgs = (ModuleName -> FilePath) -> [ModuleName] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow [ModuleName]
libModules
extArgs :: [FilePath]
extArgs = (Extension -> FilePath) -> [Extension] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> FilePath
showExt [Extension]
libDefaultExtensions
showExt :: Extension -> FilePath
showExt = \case
EnableExtension KnownExtension
ext -> FilePath
"-X" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> KnownExtension -> FilePath
forall a. Show a => a -> FilePath
show KnownExtension
ext
DisableExtension KnownExtension
ext -> FilePath
"-XNo" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> KnownExtension -> FilePath
forall a. Show a => a -> FilePath
show KnownExtension
ext
UnknownExtension FilePath
ext -> FilePath
"-X" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
ext
dropEnd :: Int -> [a] -> [a]
dropEnd :: Int -> [a] -> [a]
dropEnd Int
i [a]
xs
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [a]
xs
| Bool
otherwise = [a] -> [a] -> [a]
forall a a. [a] -> [a] -> [a]
f [a]
xs (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
i [a]
xs)
where
f :: [a] -> [a] -> [a]
f (a
a:[a]
as) (a
_:[a]
bs) = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
f [a]
as [a]
bs
f [a]
_ [a]
_ = []
findCabalPackage :: HasCallStack => String -> IO FilePath
findCabalPackage :: FilePath -> IO FilePath
findCabalPackage FilePath
packageName = FilePath -> IO FilePath
goUp (FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO FilePath
canonicalizePath FilePath
packageName
where
goUp :: FilePath -> IO FilePath
goUp :: FilePath -> IO FilePath
goUp FilePath
path
| FilePath -> Bool
isDrive FilePath
path = FilePath -> IO FilePath
forall a. HasCallStack => FilePath -> a
error (FilePath
"Could not find '" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
packageFilename FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"'")
| Bool
otherwise = do
Bool
packageExists <- FilePath -> IO Bool
doesFileExist (FilePath
path FilePath -> ShowS
</> FilePath
packageFilename)
Bool
projectExists <- FilePath -> IO Bool
doesFileExist (FilePath
path FilePath -> ShowS
</> FilePath
projectFilename)
if | Bool
packageExists -> FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
path FilePath -> ShowS
</> FilePath
packageFilename)
| Bool
projectExists -> FilePath -> IO FilePath
goDown FilePath
path
| Bool
otherwise -> FilePath -> IO FilePath
goUp (ShowS
takeDirectory FilePath
path)
goDown :: FilePath -> IO FilePath
goDown :: FilePath -> IO FilePath
goDown FilePath
path = do
[FilePath]
candidates <- FilePath -> IO [FilePath]
glob (FilePath
path FilePath -> ShowS
</> FilePath
"**" FilePath -> ShowS
</> FilePath
packageFilename)
case [FilePath]
candidates of
[] -> FilePath -> IO FilePath
forall a. HasCallStack => FilePath -> a
error (FilePath
"Could not find " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
packageFilename FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" in project " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
path)
(FilePath
_:FilePath
_:[FilePath]
_) -> FilePath -> IO FilePath
forall a. HasCallStack => FilePath -> a
error (FilePath
"Ambiguous packages in project " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
path FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
": " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
candidates)
[FilePath
c] -> FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
c
packageFilename :: FilePath
packageFilename = FilePath
packageName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
".cabal"
projectFilename :: FilePath
projectFilename = FilePath
"cabal.project"
#if MIN_VERSION_Cabal(3,6,0)
compatPrettyShow :: SymbolicPath PackageDir SourceDir -> FilePath
compatPrettyShow :: SymbolicPath PackageDir SourceDir -> FilePath
compatPrettyShow = SymbolicPath PackageDir SourceDir -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow
#else
compatPrettyShow :: FilePath -> FilePath
compatPrettyShow = id
#endif
solveCondTree :: CondTree ConfVar c a -> [(c, a)]
solveCondTree :: CondTree ConfVar c a -> [(c, a)]
solveCondTree CondNode{a
condTreeData :: forall v c a. CondTree v c a -> a
condTreeData :: a
condTreeData, c
condTreeConstraints :: forall v c a. CondTree v c a -> c
condTreeConstraints :: c
condTreeConstraints, [CondBranch ConfVar c a]
condTreeComponents :: forall v c a. CondTree v c a -> [CondBranch v c a]
condTreeComponents :: [CondBranch ConfVar c a]
condTreeComponents} =
(c
condTreeConstraints, a
condTreeData) (c, a) -> [(c, a)] -> [(c, a)]
forall a. a -> [a] -> [a]
: (CondBranch ConfVar c a -> [(c, a)])
-> [CondBranch ConfVar c a] -> [(c, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CondBranch ConfVar c a -> [(c, a)]
forall c a. CondBranch ConfVar c a -> [(c, a)]
goBranch [CondBranch ConfVar c a]
condTreeComponents
where
goBranch :: CondBranch ConfVar c a -> [(c, a)]
goBranch :: CondBranch ConfVar c a -> [(c, a)]
goBranch (CondBranch Condition ConfVar
condBranchCondition CondTree ConfVar c a
condBranchIfTrue Maybe (CondTree ConfVar c a)
condBranchIfFalse) =
if Condition ConfVar -> Bool
goCondition Condition ConfVar
condBranchCondition
then CondTree ConfVar c a -> [(c, a)]
forall c a. CondTree ConfVar c a -> [(c, a)]
solveCondTree CondTree ConfVar c a
condBranchIfTrue
else [(c, a)]
-> (CondTree ConfVar c a -> [(c, a)])
-> Maybe (CondTree ConfVar c a)
-> [(c, a)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(c, a)]
forall a. Monoid a => a
mempty CondTree ConfVar c a -> [(c, a)]
forall c a. CondTree ConfVar c a -> [(c, a)]
solveCondTree Maybe (CondTree ConfVar c a)
condBranchIfFalse
goCondition :: Condition ConfVar -> Bool
goCondition :: Condition ConfVar -> Bool
goCondition = \case
Var ConfVar
cv ->
case ConfVar
cv of
OS OS
os -> OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
buildOS
Arch Arch
ar -> Arch
ar Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
buildArch
Impl CompilerFlavor
cf VersionRange
versionRange ->
case CompilerFlavor
cf of
CompilerFlavor
GHC -> Version -> VersionRange -> Bool
withinRange Version
buildGhc VersionRange
versionRange
CompilerFlavor
_ -> FilePath -> Bool
forall a. HasCallStack => FilePath -> a
error (FilePath
"Unrecognized compiler: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> CompilerFlavor -> FilePath
forall a. Show a => a -> FilePath
show CompilerFlavor
cf)
PackageFlag FlagName
_fn -> Bool
False
Lit Bool
b -> Bool
b
CNot Condition ConfVar
con -> Bool -> Bool
not (Condition ConfVar -> Bool
goCondition Condition ConfVar
con)
COr Condition ConfVar
con0 Condition ConfVar
con1 -> Condition ConfVar -> Bool
goCondition Condition ConfVar
con0 Bool -> Bool -> Bool
|| Condition ConfVar -> Bool
goCondition Condition ConfVar
con1
CAnd Condition ConfVar
con0 Condition ConfVar
con1 -> Condition ConfVar -> Bool
goCondition Condition ConfVar
con0 Bool -> Bool -> Bool
&& Condition ConfVar -> Bool
goCondition Condition ConfVar
con1
buildGhc :: Version
buildGhc :: Version
buildGhc = Version -> Version
mkVersion' Version
compilerVersion
extractSpecificCabalLibrary :: Maybe String -> FilePath -> IO Library
Maybe FilePath
maybeLibName FilePath
pkgPath = do
GenericPackageDescription
pkg <- Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
silent FilePath
pkgPath
case Maybe FilePath
maybeLibName of
Maybe FilePath
Nothing ->
case GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
condLibrary GenericPackageDescription
pkg of
Maybe (CondTree ConfVar [Dependency] Library)
Nothing ->
let pkgDescription :: PackageIdentifier
pkgDescription = PackageDescription -> PackageIdentifier
package (GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
pkg) in
FilePath -> IO Library
forall a. HasCallStack => FilePath -> a
error (FilePath
"Could not find main library in: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageIdentifier -> FilePath
forall a. Show a => a -> FilePath
show PackageIdentifier
pkgDescription)
Just CondTree ConfVar [Dependency] Library
lib ->
Library -> IO Library
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CondTree ConfVar [Dependency] Library -> Library
forall a. CondTree ConfVar a Library -> Library
go CondTree ConfVar [Dependency] Library
lib)
Just FilePath
libName ->
Library -> IO Library
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CondTree ConfVar [Dependency] Library -> Library
forall a. CondTree ConfVar a Library -> Library
go (GenericPackageDescription
-> FilePath
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> CondTree ConfVar [Dependency] Library
forall p.
GenericPackageDescription
-> FilePath -> [(UnqualComponentName, p)] -> p
findSubLib GenericPackageDescription
pkg FilePath
libName (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condSubLibraries GenericPackageDescription
pkg)))
where
findSubLib :: GenericPackageDescription
-> FilePath -> [(UnqualComponentName, p)] -> p
findSubLib GenericPackageDescription
pkg FilePath
targetLibName [] =
let pkgDescription :: PackageIdentifier
pkgDescription = PackageDescription -> PackageIdentifier
package (GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
pkg) in
FilePath -> p
forall a. HasCallStack => FilePath -> a
error (FilePath
"Could not find library " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
targetLibName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" in " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageIdentifier -> FilePath
forall a. Show a => a -> FilePath
show PackageIdentifier
pkgDescription)
findSubLib GenericPackageDescription
pkg FilePath
targetLibName ((UnqualComponentName
libName, p
lib):[(UnqualComponentName, p)]
libs)
| UnqualComponentName -> FilePath
unUnqualComponentName UnqualComponentName
libName FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
targetLibName = p
lib
| Bool
otherwise = GenericPackageDescription
-> FilePath -> [(UnqualComponentName, p)] -> p
findSubLib GenericPackageDescription
pkg FilePath
targetLibName [(UnqualComponentName, p)]
libs
go :: CondTree ConfVar a Library -> Library
go CondTree ConfVar a Library
condNode = [Library] -> Library
mergeLibraries [Library]
libs1
where
libs0 :: [Library]
libs0 = ((a, Library) -> Library) -> [(a, Library)] -> [Library]
forall a b. (a -> b) -> [a] -> [b]
map (a, Library) -> Library
forall a b. (a, b) -> b
snd (CondTree ConfVar a Library -> [(a, Library)]
forall c a. CondTree ConfVar c a -> [(c, a)]
solveCondTree CondTree ConfVar a Library
condNode)
libs1 :: [Library]
libs1 = (Library -> Library) -> [Library] -> [Library]
forall a b. (a -> b) -> [a] -> [b]
map Library -> Library
goLib [Library]
libs0
goLib :: Library -> Library
goLib Library
lib = Library :: [FilePath] -> [FilePath] -> [ModuleName] -> [Extension] -> Library
Library
{ libSourceDirectories :: [FilePath]
libSourceDirectories = (SymbolicPath PackageDir SourceDir -> FilePath)
-> [SymbolicPath PackageDir SourceDir] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
root FilePath -> ShowS
</>) ShowS
-> (SymbolicPath PackageDir SourceDir -> FilePath)
-> SymbolicPath PackageDir SourceDir
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath PackageDir SourceDir -> FilePath
compatPrettyShow) [SymbolicPath PackageDir SourceDir]
sourceDirs
, libCSourceDirectories :: [FilePath]
libCSourceDirectories = ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
root FilePath -> ShowS
</>) [FilePath]
cSourceDirs
, libModules :: [ModuleName]
libModules = Library -> [ModuleName]
exposedModules Library
lib [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Ord a => [a] -> [a] -> [a]
`rmList` BuildInfo -> [ModuleName]
autogenModules BuildInfo
buildInfo
, libDefaultExtensions :: [Extension]
libDefaultExtensions = BuildInfo -> [Extension]
defaultExtensions BuildInfo
buildInfo
}
where
buildInfo :: BuildInfo
buildInfo = Library -> BuildInfo
libBuildInfo Library
lib
sourceDirs :: [SymbolicPath PackageDir SourceDir]
sourceDirs = BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
buildInfo
cSourceDirs :: [FilePath]
cSourceDirs = BuildInfo -> [FilePath]
includeDirs BuildInfo
buildInfo
root :: FilePath
root = ShowS
takeDirectory FilePath
pkgPath
extractCabalLibrary :: FilePath -> IO Library
= Maybe FilePath -> FilePath -> IO Library
extractSpecificCabalLibrary Maybe FilePath
forall a. Maybe a
Nothing