{-# 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.Types.UnqualComponentName ( unUnqualComponentName )
import Distribution.PackageDescription
( CondTree(CondNode, condTreeData), GenericPackageDescription (condLibrary)
, exposedModules, libBuildInfo, hsSourceDirs, defaultExtensions, package
, packageDescription, condSubLibraries )
import Distribution.Pretty (prettyShow)
import Distribution.Verbosity (silent)
#if MIN_VERSION_Cabal(3,6,0)
import Distribution.Utils.Path (SourceDir, PackageDir, SymbolicPath)
#endif
import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
data Library = Library
{ Library -> [FilePath]
libSourceDirectories :: [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)
libraryToGhciArgs :: Library -> ([String], [String], [String])
libraryToGhciArgs :: Library -> ([FilePath], [FilePath], [FilePath])
libraryToGhciArgs Library{..} = ([FilePath]
srcArgs, [FilePath]
modArgs, [FilePath]
extArgs)
where
srcArgs :: [FilePath]
srcArgs = ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ("-i" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>) [FilePath]
libSourceDirectories
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 ext :: KnownExtension
ext -> "-X" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> KnownExtension -> FilePath
forall a. Show a => a -> FilePath
show KnownExtension
ext
DisableExtension ext :: KnownExtension
ext -> "-XNo" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> KnownExtension -> FilePath
forall a. Show a => a -> FilePath
show KnownExtension
ext
UnknownExtension ext :: FilePath
ext -> "-X" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
ext
dropEnd :: Int -> [a] -> [a]
dropEnd :: Int -> [a] -> [a]
dropEnd i :: Int
i xs :: [a]
xs
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 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]
as) (_:bs :: [a]
bs) = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
f [a]
as [a]
bs
f _ _ = []
findCabalPackage :: HasCallStack => String -> IO FilePath
findCabalPackage :: FilePath -> IO FilePath
findCabalPackage packageName :: 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 path :: FilePath
path
| FilePath -> Bool
isDrive FilePath
path = FilePath -> IO FilePath
forall a. HasCallStack => FilePath -> a
error ("Could not find '" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
packageFilename FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> "'")
| 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 path :: FilePath
path = do
[FilePath]
candidates <- FilePath -> IO [FilePath]
glob (FilePath
path FilePath -> ShowS
</> "**" FilePath -> ShowS
</> FilePath
packageFilename)
case [FilePath]
candidates of
[] -> FilePath -> IO FilePath
forall a. HasCallStack => FilePath -> a
error ("Could not find " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
packageFilename FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> " in project " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
path)
(_:_:_) -> FilePath -> IO FilePath
forall a. HasCallStack => FilePath -> a
error ("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 -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
candidates)
[c :: 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
<> ".cabal"
projectFilename :: FilePath
projectFilename = "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
extractSpecificCabalLibrary :: Maybe String -> FilePath -> IO Library
maybeLibName :: Maybe FilePath
maybeLibName pkgPath :: FilePath
pkgPath = do
GenericPackageDescription
pkg <- Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
silent FilePath
pkgPath
case Maybe FilePath
maybeLibName of
Nothing ->
case GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
condLibrary GenericPackageDescription
pkg of
Nothing ->
let pkgDescription :: PackageIdentifier
pkgDescription = PackageDescription -> PackageIdentifier
package (GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
pkg) in
FilePath -> IO Library
forall a. HasCallStack => FilePath -> a
error ("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 lib :: 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 libName :: FilePath
libName ->
CondTree ConfVar [Dependency] Library -> IO Library
forall (f :: * -> *) v c.
Applicative f =>
CondTree v c Library -> f 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 pkg :: GenericPackageDescription
pkg targetLibName :: FilePath
targetLibName [] =
let pkgDescription :: PackageIdentifier
pkgDescription = PackageDescription -> PackageIdentifier
package (GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
pkg) in
FilePath -> p
forall a. HasCallStack => FilePath -> a
error ("Could not find library " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
targetLibName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> " in " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageIdentifier -> FilePath
forall a. Show a => a -> FilePath
show PackageIdentifier
pkgDescription)
findSubLib pkg :: GenericPackageDescription
pkg targetLibName :: FilePath
targetLibName ((libName :: UnqualComponentName
libName, lib :: p
lib):libs :: [(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 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 :: [FilePath]
sourceDirs = BuildInfo -> [FilePath]
hsSourceDirs BuildInfo
buildInfo
root :: FilePath
root = ShowS
takeDirectory FilePath
pkgPath
in
Library -> f Library
forall (f :: * -> *) a. Applicative f => a -> f a
pure Library :: [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
, libModules :: [ModuleName]
libModules = Library -> [ModuleName]
exposedModules Library
lib
, libDefaultExtensions :: [Extension]
libDefaultExtensions = BuildInfo -> [Extension]
defaultExtensions BuildInfo
buildInfo
}
extractCabalLibrary :: FilePath -> IO Library
= Maybe FilePath -> FilePath -> IO Library
extractSpecificCabalLibrary Maybe FilePath
forall a. Maybe a
Nothing