{-# 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 :: forall a. Ord a => [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 -> [String]
libSourceDirectories :: [FilePath]
, Library -> [String]
libCSourceDirectories :: [FilePath]
, Library -> [ModuleName]
libModules :: [ModuleName]
, Library -> [Extension]
libDefaultExtensions :: [Extension]
}
deriving (Int -> Library -> ShowS
[Library] -> ShowS
Library -> String
(Int -> Library -> ShowS)
-> (Library -> String) -> ([Library] -> ShowS) -> Show Library
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Library] -> ShowS
$cshowList :: [Library] -> ShowS
show :: Library -> String
$cshow :: Library -> String
showsPrec :: Int -> Library -> ShowS
$cshowsPrec :: Int -> Library -> ShowS
Show)
mergeLibraries :: [Library] -> Library
mergeLibraries :: [Library] -> Library
mergeLibraries [Library]
libs = Library :: [String] -> [String] -> [ModuleName] -> [Extension] -> Library
Library
{ libSourceDirectories :: [String]
libSourceDirectories = (Library -> [String]) -> [Library] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Library -> [String]
libSourceDirectories [Library]
libs
, libCSourceDirectories :: [String]
libCSourceDirectories = (Library -> [String]) -> [Library] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Library -> [String]
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 -> ([String], [String], [String])
libraryToGhciArgs Library{[String]
[Extension]
[ModuleName]
libDefaultExtensions :: [Extension]
libModules :: [ModuleName]
libCSourceDirectories :: [String]
libSourceDirectories :: [String]
libDefaultExtensions :: Library -> [Extension]
libModules :: Library -> [ModuleName]
libCSourceDirectories :: Library -> [String]
libSourceDirectories :: Library -> [String]
..} = ([String]
hsSrcArgs [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
cSrcArgs, [String]
modArgs, [String]
extArgs)
where
hsSrcArgs :: [String]
hsSrcArgs = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-i" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) [String]
libSourceDirectories
cSrcArgs :: [String]
cSrcArgs = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-I" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) [String]
libCSourceDirectories
modArgs :: [String]
modArgs = (ModuleName -> String) -> [ModuleName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> String
forall a. Pretty a => a -> String
prettyShow [ModuleName]
libModules
extArgs :: [String]
extArgs = (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
showExt [Extension]
libDefaultExtensions
showExt :: Extension -> String
showExt = \case
EnableExtension KnownExtension
ext -> String
"-X" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> KnownExtension -> String
forall a. Show a => a -> String
show KnownExtension
ext
DisableExtension KnownExtension
ext -> String
"-XNo" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> KnownExtension -> String
forall a. Show a => a -> String
show KnownExtension
ext
UnknownExtension String
ext -> String
"-X" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ext
dropEnd :: Int -> [a] -> [a]
dropEnd :: forall a. 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 :: HasCallStack => String -> IO String
findCabalPackage String
packageName = String -> IO String
goUp (String -> IO String) -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
canonicalizePath String
packageName
where
goUp :: FilePath -> IO FilePath
goUp :: String -> IO String
goUp String
path
| String -> Bool
isDrive String
path = String -> IO String
forall a. HasCallStack => String -> a
error (String
"Could not find '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
packageFilename String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'")
| Bool
otherwise = do
Bool
packageExists <- String -> IO Bool
doesFileExist (String
path String -> ShowS
</> String
packageFilename)
Bool
projectExists <- String -> IO Bool
doesFileExist (String
path String -> ShowS
</> String
projectFilename)
if | Bool
packageExists -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
path String -> ShowS
</> String
packageFilename)
| Bool
projectExists -> String -> IO String
goDown String
path
| Bool
otherwise -> String -> IO String
goUp (ShowS
takeDirectory String
path)
goDown :: FilePath -> IO FilePath
goDown :: String -> IO String
goDown String
path = do
[String]
candidates <- String -> IO [String]
glob (String
path String -> ShowS
</> String
"**" String -> ShowS
</> String
packageFilename)
case [String]
candidates of
[] -> String -> IO String
forall a. HasCallStack => String -> a
error (String
"Could not find " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
packageFilename String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" in project " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
path)
(String
_:String
_:[String]
_) -> String -> IO String
forall a. HasCallStack => String -> a
error (String
"Ambiguous packages in project " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show [String]
candidates)
[String
c] -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
c
packageFilename :: String
packageFilename = String
packageName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".cabal"
projectFilename :: String
projectFilename = String
"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 :: forall c a. 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 :: forall c a. 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
_ -> String -> Bool
forall a. HasCallStack => String -> a
error (String
"Unrecognized compiler: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CompilerFlavor -> String
forall a. Show a => a -> String
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 String
maybeLibName String
pkgPath = do
GenericPackageDescription
pkg <- Verbosity -> String -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
silent String
pkgPath
case Maybe String
maybeLibName of
Maybe String
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
String -> IO Library
forall a. HasCallStack => String -> a
error (String
"Could not find main library in: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageIdentifier -> String
forall a. Show a => a -> String
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 String
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
-> String
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> CondTree ConfVar [Dependency] Library
forall {a}.
GenericPackageDescription
-> String -> [(UnqualComponentName, a)] -> a
findSubLib GenericPackageDescription
pkg String
libName (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condSubLibraries GenericPackageDescription
pkg)))
where
findSubLib :: GenericPackageDescription
-> String -> [(UnqualComponentName, a)] -> a
findSubLib GenericPackageDescription
pkg String
targetLibName [] =
let pkgDescription :: PackageIdentifier
pkgDescription = PackageDescription -> PackageIdentifier
package (GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
pkg) in
String -> a
forall a. HasCallStack => String -> a
error (String
"Could not find library " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
targetLibName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageIdentifier -> String
forall a. Show a => a -> String
show PackageIdentifier
pkgDescription)
findSubLib GenericPackageDescription
pkg String
targetLibName ((UnqualComponentName
libName, a
lib):[(UnqualComponentName, a)]
libs)
| UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
libName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
targetLibName = a
lib
| Bool
otherwise = GenericPackageDescription
-> String -> [(UnqualComponentName, a)] -> a
findSubLib GenericPackageDescription
pkg String
targetLibName [(UnqualComponentName, a)]
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 :: [String] -> [String] -> [ModuleName] -> [Extension] -> Library
Library
{ libSourceDirectories :: [String]
libSourceDirectories = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
root String -> ShowS
</>) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
compatPrettyShow) [String]
sourceDirs
, libCSourceDirectories :: [String]
libCSourceDirectories = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
root String -> ShowS
</>) [String]
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 :: [String]
sourceDirs = BuildInfo -> [String]
hsSourceDirs BuildInfo
buildInfo
cSourceDirs :: [String]
cSourceDirs = BuildInfo -> [String]
includeDirs BuildInfo
buildInfo
root :: String
root = ShowS
takeDirectory String
pkgPath
extractCabalLibrary :: FilePath -> IO Library
= Maybe String -> String -> IO Library
extractSpecificCabalLibrary Maybe String
forall a. Maybe a
Nothing