{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.Doctest (
doctest
) where
import Prelude ()
import Distribution.Compat.Prelude
import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
import Distribution.PackageDescription
import Distribution.Simple.Compiler
import Distribution.Simple.Program.GHC
import Distribution.Simple.Program
import Distribution.Simple.PreProcess
import Distribution.Simple.Setup
import Distribution.Simple.Build
import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate)
import Distribution.Simple.Register (internalPackageDBPath)
import Distribution.Simple.BuildPaths
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Version
import Distribution.Verbosity
data DoctestArgs = DoctestArgs {
DoctestArgs -> [String]
argTargets :: [FilePath]
, DoctestArgs -> Flag (GhcOptions, Version)
argGhcOptions :: Flag (GhcOptions, Version)
} deriving (Int -> DoctestArgs -> ShowS
[DoctestArgs] -> ShowS
DoctestArgs -> String
(Int -> DoctestArgs -> ShowS)
-> (DoctestArgs -> String)
-> ([DoctestArgs] -> ShowS)
-> Show DoctestArgs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DoctestArgs] -> ShowS
$cshowList :: [DoctestArgs] -> ShowS
show :: DoctestArgs -> String
$cshow :: DoctestArgs -> String
showsPrec :: Int -> DoctestArgs -> ShowS
$cshowsPrec :: Int -> DoctestArgs -> ShowS
Show, (forall x. DoctestArgs -> Rep DoctestArgs x)
-> (forall x. Rep DoctestArgs x -> DoctestArgs)
-> Generic DoctestArgs
forall x. Rep DoctestArgs x -> DoctestArgs
forall x. DoctestArgs -> Rep DoctestArgs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DoctestArgs x -> DoctestArgs
$cfrom :: forall x. DoctestArgs -> Rep DoctestArgs x
Generic)
doctest :: PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> DoctestFlags
-> IO ()
doctest :: PackageDescription
-> LocalBuildInfo -> [PPSuffixHandler] -> DoctestFlags -> IO ()
doctest PackageDescription
pkg_descr LocalBuildInfo
lbi [PPSuffixHandler]
suffixes DoctestFlags
doctestFlags = do
let verbosity :: Verbosity
verbosity = (DoctestFlags -> Flag Verbosity) -> Verbosity
forall {a}. (DoctestFlags -> Flag a) -> a
flag DoctestFlags -> Flag Verbosity
doctestVerbosity
distPref :: String
distPref = (DoctestFlags -> Flag String) -> String
forall {a}. (DoctestFlags -> Flag a) -> a
flag DoctestFlags -> Flag String
doctestDistPref
flag :: (DoctestFlags -> Flag a) -> a
flag DoctestFlags -> Flag a
f = Flag a -> a
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag a -> a) -> Flag a -> a
forall a b. (a -> b) -> a -> b
$ DoctestFlags -> Flag a
f DoctestFlags
doctestFlags
tmpFileOpts :: TempFileOptions
tmpFileOpts = TempFileOptions
defaultTempFileOptions
lbi' :: LocalBuildInfo
lbi' = LocalBuildInfo
lbi { withPackageDB :: PackageDBStack
withPackageDB = LocalBuildInfo -> PackageDBStack
withPackageDB LocalBuildInfo
lbi
PackageDBStack -> PackageDBStack -> PackageDBStack
forall a. [a] -> [a] -> [a]
++ [String -> PackageDB
SpecificPackageDB (LocalBuildInfo -> ShowS
internalPackageDBPath LocalBuildInfo
lbi String
distPref)] }
(ConfiguredProgram
doctestProg, Version
_version, ProgramDb
_) <-
Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion Verbosity
verbosity Program
doctestProgram
(Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
0,Int
11,Int
3])) (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
PackageDescription
-> LocalBuildInfo
-> (Component -> ComponentLocalBuildInfo -> IO ())
-> IO ()
withAllComponentsInBuildOrder PackageDescription
pkg_descr LocalBuildInfo
lbi ((Component -> ComponentLocalBuildInfo -> IO ()) -> IO ())
-> (Component -> ComponentLocalBuildInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Component
component ComponentLocalBuildInfo
clbi -> do
String
-> PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Verbosity
-> IO ()
componentInitialBuildSteps String
distPref PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Verbosity
verbosity
PackageDescription
-> Component
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Bool
-> Verbosity
-> [PPSuffixHandler]
-> IO ()
preprocessComponent PackageDescription
pkg_descr Component
component LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Bool
False Verbosity
verbosity [PPSuffixHandler]
suffixes
case Component
component of
CLib Library
lib -> do
Verbosity
-> TempFileOptions
-> String
-> String
-> (String -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions -> String -> String -> (String -> IO a) -> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
tmpFileOpts (LocalBuildInfo -> String
buildDir LocalBuildInfo
lbi) String
"tmp" ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
\String
tmp -> do
[String]
inFiles <- ((ModuleName, String) -> String)
-> [(ModuleName, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, String) -> String
forall a b. (a, b) -> b
snd ([(ModuleName, String)] -> [String])
-> IO [(ModuleName, String)] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO [(ModuleName, String)]
getLibSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi
DoctestArgs
args <- Verbosity
-> String
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> [String]
-> BuildInfo
-> IO DoctestArgs
mkDoctestArgs Verbosity
verbosity String
tmp LocalBuildInfo
lbi' ComponentLocalBuildInfo
clbi [String]
inFiles (Library -> BuildInfo
libBuildInfo Library
lib)
Verbosity
-> Compiler
-> Platform
-> ConfiguredProgram
-> DoctestArgs
-> IO ()
runDoctest Verbosity
verbosity (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) ConfiguredProgram
doctestProg DoctestArgs
args
CExe Executable
exe -> do
Verbosity
-> TempFileOptions
-> String
-> String
-> (String -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions -> String -> String -> (String -> IO a) -> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
tmpFileOpts (LocalBuildInfo -> String
buildDir LocalBuildInfo
lbi) String
"tmp" ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
\String
tmp -> do
[String]
inFiles <- ((ModuleName, String) -> String)
-> [(ModuleName, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, String) -> String
forall a b. (a, b) -> b
snd ([(ModuleName, String)] -> [String])
-> IO [(ModuleName, String)] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO [(ModuleName, String)]
getExeSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Executable
exe ComponentLocalBuildInfo
clbi
DoctestArgs
args <- Verbosity
-> String
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> [String]
-> BuildInfo
-> IO DoctestArgs
mkDoctestArgs Verbosity
verbosity String
tmp LocalBuildInfo
lbi' ComponentLocalBuildInfo
clbi [String]
inFiles (Executable -> BuildInfo
buildInfo Executable
exe)
Verbosity
-> Compiler
-> Platform
-> ConfiguredProgram
-> DoctestArgs
-> IO ()
runDoctest Verbosity
verbosity (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) ConfiguredProgram
doctestProg DoctestArgs
args
CFLib ForeignLib
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CTest TestSuite
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
CBench Benchmark
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
componentGhcOptions :: Verbosity -> LocalBuildInfo
-> BuildInfo -> ComponentLocalBuildInfo -> FilePath
-> GhcOptions
componentGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi String
odir =
let f :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
f = case Compiler -> CompilerFlavor
compilerFlavor (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) of
CompilerFlavor
GHC -> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
GHC.componentGhcOptions
CompilerFlavor
GHCJS -> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
GHCJS.componentGhcOptions
CompilerFlavor
_ -> String
-> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
forall a. HasCallStack => String -> a
error (String
-> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions)
-> String
-> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
forall a b. (a -> b) -> a -> b
$
String
"Distribution.Simple.Doctest.componentGhcOptions:" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
"doctest only supports GHC and GHCJS"
in Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
f Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi String
odir
mkDoctestArgs :: Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> [FilePath]
-> BuildInfo
-> IO DoctestArgs
mkDoctestArgs :: Verbosity
-> String
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> [String]
-> BuildInfo
-> IO DoctestArgs
mkDoctestArgs Verbosity
verbosity String
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi [String]
inFiles BuildInfo
bi = do
let vanillaOpts :: GhcOptions
vanillaOpts = (Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
componentGhcOptions Verbosity
normal LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi (LocalBuildInfo -> String
buildDir LocalBuildInfo
lbi))
{ ghcOptOptimisation :: Flag GhcOptimisation
ghcOptOptimisation = Flag GhcOptimisation
forall a. Monoid a => a
mempty
, ghcOptWarnMissingHomeModules :: Flag Bool
ghcOptWarnMissingHomeModules = Flag Bool
forall a. Monoid a => a
mempty
, ghcOptExtra :: [String]
ghcOptExtra = [String]
forall a. Monoid a => a
mempty
, ghcOptCabal :: Flag Bool
ghcOptCabal = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False
, ghcOptObjDir :: Flag String
ghcOptObjDir = String -> Flag String
forall a. a -> Flag a
toFlag String
tmp
, ghcOptHiDir :: Flag String
ghcOptHiDir = String -> Flag String
forall a. a -> Flag a
toFlag String
tmp
, ghcOptStubDir :: Flag String
ghcOptStubDir = String -> Flag String
forall a. a -> Flag a
toFlag String
tmp }
sharedOpts :: GhcOptions
sharedOpts = GhcOptions
vanillaOpts
{ ghcOptDynLinkMode :: Flag GhcDynLinkMode
ghcOptDynLinkMode = GhcDynLinkMode -> Flag GhcDynLinkMode
forall a. a -> Flag a
toFlag GhcDynLinkMode
GhcDynamicOnly
, ghcOptFPic :: Flag Bool
ghcOptFPic = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
True
, ghcOptHiSuffix :: Flag String
ghcOptHiSuffix = String -> Flag String
forall a. a -> Flag a
toFlag String
"dyn_hi"
, ghcOptObjSuffix :: Flag String
ghcOptObjSuffix = String -> Flag String
forall a. a -> Flag a
toFlag String
"dyn_o"
, ghcOptExtra :: [String]
ghcOptExtra = CompilerFlavor -> BuildInfo -> [String]
hcSharedOptions CompilerFlavor
GHC BuildInfo
bi}
GhcOptions
opts <- if LocalBuildInfo -> Bool
withVanillaLib LocalBuildInfo
lbi
then GhcOptions -> IO GhcOptions
forall (m :: * -> *) a. Monad m => a -> m a
return GhcOptions
vanillaOpts
else if LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi
then GhcOptions -> IO GhcOptions
forall (m :: * -> *) a. Monad m => a -> m a
return GhcOptions
sharedOpts
else Verbosity -> String -> IO GhcOptions
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO GhcOptions) -> String -> IO GhcOptions
forall a b. (a -> b) -> a -> b
$ String
"Must have vanilla or shared libraries "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"enabled in order to run doctest"
Version
ghcVersion <- IO Version
-> (Version -> IO Version) -> Maybe Version -> IO Version
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Verbosity -> String -> IO Version
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"Compiler has no GHC version")
Version -> IO Version
forall (m :: * -> *) a. Monad m => a -> m a
return
(CompilerFlavor -> Compiler -> Maybe Version
compilerCompatVersion CompilerFlavor
GHC (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi))
DoctestArgs -> IO DoctestArgs
forall (m :: * -> *) a. Monad m => a -> m a
return (DoctestArgs -> IO DoctestArgs) -> DoctestArgs -> IO DoctestArgs
forall a b. (a -> b) -> a -> b
$ DoctestArgs :: [String] -> Flag (GhcOptions, Version) -> DoctestArgs
DoctestArgs
{ argTargets :: [String]
argTargets = [String]
inFiles
, argGhcOptions :: Flag (GhcOptions, Version)
argGhcOptions = (GhcOptions, Version) -> Flag (GhcOptions, Version)
forall a. a -> Flag a
toFlag (GhcOptions
opts, Version
ghcVersion)
}
runDoctest :: Verbosity
-> Compiler
-> Platform
-> ConfiguredProgram
-> DoctestArgs
-> IO ()
runDoctest :: Verbosity
-> Compiler
-> Platform
-> ConfiguredProgram
-> DoctestArgs
-> IO ()
runDoctest Verbosity
verbosity Compiler
comp Platform
platform ConfiguredProgram
doctestProg DoctestArgs
args = do
Verbosity
-> Compiler
-> Platform
-> DoctestArgs
-> (([String], [String]) -> IO ())
-> IO ()
forall a.
Verbosity
-> Compiler
-> Platform
-> DoctestArgs
-> (([String], [String]) -> IO a)
-> IO a
renderArgs Verbosity
verbosity Compiler
comp Platform
platform DoctestArgs
args ((([String], [String]) -> IO ()) -> IO ())
-> (([String], [String]) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
\([String]
flags, [String]
files) -> do
Verbosity -> ConfiguredProgram -> [String] -> IO ()
runProgram Verbosity
verbosity ConfiguredProgram
doctestProg ([String]
flags [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
files)
renderArgs :: Verbosity
-> Compiler
-> Platform
-> DoctestArgs
-> (([String],[FilePath]) -> IO a)
-> IO a
renderArgs :: forall a.
Verbosity
-> Compiler
-> Platform
-> DoctestArgs
-> (([String], [String]) -> IO a)
-> IO a
renderArgs Verbosity
_verbosity Compiler
comp Platform
platform DoctestArgs
args ([String], [String]) -> IO a
k = do
([String], [String]) -> IO a
k ([String]
flags, DoctestArgs -> [String]
argTargets DoctestArgs
args)
where
flags :: [String]
flags :: [String]
flags = [[String]] -> [String]
forall a. Monoid a => [a] -> a
mconcat
[ String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"--no-magic"
, String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"-fdiagnostics-color=never"
, [ String
opt | (GhcOptions
opts, Version
_ghcVer) <- Flag (GhcOptions, Version) -> [(GhcOptions, Version)]
forall a. Flag a -> [a]
flagToList (DoctestArgs -> Flag (GhcOptions, Version)
argGhcOptions DoctestArgs
args)
, String
opt <- Compiler -> Platform -> GhcOptions -> [String]
renderGhcOptions Compiler
comp Platform
platform GhcOptions
opts ]
]
instance Monoid DoctestArgs where
mempty :: DoctestArgs
mempty = DoctestArgs
forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
mappend :: DoctestArgs -> DoctestArgs -> DoctestArgs
mappend = DoctestArgs -> DoctestArgs -> DoctestArgs
forall a. Semigroup a => a -> a -> a
(<>)
instance Semigroup DoctestArgs where
<> :: DoctestArgs -> DoctestArgs -> DoctestArgs
(<>) = DoctestArgs -> DoctestArgs -> DoctestArgs
forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend