{-# 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.Pretty (prettyShow)
import Distribution.System (buildArch, buildOS)
import Distribution.Types.Condition (Condition(..))
import Distribution.Types.CondTree
import Distribution.Types.Version (Version, mkVersion')
import Distribution.Types.VersionRange (withinRange)
import Distribution.Verbosity (silent)
#if MIN_VERSION_Cabal(3,8,0)
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
#else
import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
#endif
#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 = prettyShow
#else
compatPrettyShow :: FilePath -> FilePath
compatPrettyShow :: ShowS
compatPrettyShow = ShowS
forall a. a -> a
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)
#if MIN_VERSION_Cabal(3,4,0)
PackageFlag _fn -> False
#else
Flag FlagName
_fn -> Bool
False
#endif
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 = ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
root FilePath -> ShowS
</>) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
compatPrettyShow) [FilePath]
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 :: [FilePath]
sourceDirs = BuildInfo -> [FilePath]
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