{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
module Test.DocTest.Helpers where
import GHC.Stack (HasCallStack)
import System.Directory
( canonicalizePath, doesFileExist )
import System.FilePath ((</>), isDrive, takeDirectory)
import System.FilePath.Glob (glob)
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid ((<>))
#endif
import Distribution.ModuleName (ModuleName)
import Distribution.Simple
( Extension (DisableExtension, EnableExtension, UnknownExtension) )
import Distribution.PackageDescription
( CondTree(CondNode, condTreeData), GenericPackageDescription (condLibrary)
, exposedModules, libBuildInfo, hsSourceDirs, defaultExtensions, package
, packageDescription, condSubLibraries )
import Distribution.Pretty (prettyShow)
import Distribution.Types.UnqualComponentName (unUnqualComponentName)
#if MIN_VERSION_Cabal(3,6,0)
import Distribution.Utils.Path (SourceDir, PackageDir, SymbolicPath)
#endif
import Cabal.Package (readPackage)
data Library = Library
{ Library -> [String]
libSourceDirectories :: [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)
libraryToGhciArgs :: Library -> ([String], [String], [String])
libraryToGhciArgs :: Library -> ([String], [String], [String])
libraryToGhciArgs Library{[String]
[Extension]
[ModuleName]
libDefaultExtensions :: [Extension]
libModules :: [ModuleName]
libSourceDirectories :: [String]
libDefaultExtensions :: Library -> [Extension]
libModules :: Library -> [ModuleName]
libSourceDirectories :: Library -> [String]
..} = ([String]
srcArgs, [String]
modArgs, [String]
extArgs)
where
srcArgs :: [String]
srcArgs = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-i" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) [String]
libSourceDirectories
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 :: SymbolicPath PackageDir SourceDir -> String
compatPrettyShow = SymbolicPath PackageDir SourceDir -> String
forall a. Pretty a => a -> String
prettyShow
#else
compatPrettyShow :: FilePath -> FilePath
compatPrettyShow = id
#endif
extractSpecificCabalLibrary :: Maybe String -> FilePath -> IO Library
Maybe String
maybeLibName String
pkgPath = do
GenericPackageDescription
pkg <- String -> IO GenericPackageDescription
readPackage 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 ->
CondTree ConfVar [Dependency] Library -> IO Library
forall {f :: * -> *} {v} {c}.
Applicative f =>
CondTree v c Library -> f Library
go CondTree ConfVar [Dependency] Library
lib
Just String
libName ->
CondTree ConfVar [Dependency] Library -> IO Library
forall {f :: * -> *} {v} {c}.
Applicative f =>
CondTree v c Library -> f 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 v c Library -> f Library
go CondNode{condTreeData :: forall v c a. CondTree v c a -> a
condTreeData=Library
lib} =
let
buildInfo :: BuildInfo
buildInfo = Library -> BuildInfo
libBuildInfo Library
lib
sourceDirs :: [SymbolicPath PackageDir SourceDir]
sourceDirs = BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
buildInfo
root :: String
root = ShowS
takeDirectory String
pkgPath
in
Library -> f Library
forall (f :: * -> *) a. Applicative f => a -> f a
pure Library :: [String] -> [ModuleName] -> [Extension] -> Library
Library
{ libSourceDirectories :: [String]
libSourceDirectories = (SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
root String -> ShowS
</>) ShowS
-> (SymbolicPath PackageDir SourceDir -> String)
-> SymbolicPath PackageDir SourceDir
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath PackageDir SourceDir -> String
compatPrettyShow) [SymbolicPath PackageDir SourceDir]
sourceDirs
, libModules :: [ModuleName]
libModules = Library -> [ModuleName]
exposedModules Library
lib
, libDefaultExtensions :: [Extension]
libDefaultExtensions = BuildInfo -> [Extension]
defaultExtensions BuildInfo
buildInfo
}
extractCabalLibrary :: FilePath -> IO Library
= Maybe String -> String -> IO Library
extractSpecificCabalLibrary Maybe String
forall a. Maybe a
Nothing