module Distribution.Extra.Doctest (
defaultMainWithDoctests,
doctestsUserHooks,
generateBuildModule,
) where
#if MIN_VERSION_Cabal(1,24,0)
#define InstalledPackageId UnitId
#endif
import Control.Monad
(when)
import Data.List
(nub)
import Data.String
(fromString)
import Distribution.Package
(InstalledPackageId)
import Distribution.Package
(Package (..), PackageId, packageVersion)
import Distribution.PackageDescription
(BuildInfo (..), Library (..), PackageDescription (), TestSuite (..))
import Distribution.Simple
(UserHooks (..), defaultMainWithHooks, simpleUserHooks)
import Distribution.Simple.BuildPaths
(autogenModulesDir)
import Distribution.Simple.Compiler
(PackageDB (..), showCompilerId)
import Distribution.Simple.LocalBuildInfo
(ComponentLocalBuildInfo (componentPackageDeps), LocalBuildInfo (),
compiler, withLibLBI, withPackageDB, withTestLBI)
import Distribution.Simple.Setup
(BuildFlags (buildDistPref, buildVerbosity), fromFlag)
import Distribution.Simple.Utils
(createDirectoryIfMissingVerbose, rewriteFile)
import Distribution.Text
(display, simpleParse)
import System.FilePath
((</>))
#if MIN_VERSION_Cabal(1,25,0)
import Distribution.Simple.BuildPaths
(autogenComponentModulesDir)
#endif
#if MIN_VERSION_directory(1,2,2)
import System.Directory
(makeAbsolute)
#else
import System.Directory
(getCurrentDirectory)
import System.FilePath
(isAbsolute)
makeAbsolute :: FilePath -> IO FilePath
makeAbsolute p | isAbsolute p = return p
| otherwise = do
cwd <- getCurrentDirectory
return $ cwd </> p
#endif
defaultMainWithDoctests
:: String
-> IO ()
defaultMainWithDoctests = defaultMainWithHooks . doctestsUserHooks
doctestsUserHooks
:: String
-> UserHooks
doctestsUserHooks testsuiteName = simpleUserHooks
{ buildHook = \pkg lbi hooks flags -> do
generateBuildModule testsuiteName flags pkg lbi
buildHook simpleUserHooks pkg lbi hooks flags
}
generateBuildModule
:: String
-> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
generateBuildModule testSuiteName flags pkg lbi = do
let verbosity = fromFlag (buildVerbosity flags)
let distPref = fromFlag (buildDistPref flags)
let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]
let dbFlags = "-hide-all-packages" : packageDbArgs dbStack
withLibLBI pkg lbi $ \lib libcfg -> do
let libBI = libBuildInfo lib
let modules = exposedModules lib ++ otherModules libBI
let module_sources = modules
#if MIN_VERSION_Cabal(1,25,0)
let libAutogenDir = autogenComponentModulesDir lbi libcfg
#else
let libAutogenDir = autogenModulesDir lbi
#endif
iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ libAutogenDir : hsSourceDirs libBI
includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI
let cppFlags = map ("-optP"++) $
[ "-include", libAutogenDir ++ "/cabal_macros.h" ]
++ cppOptions libBI
withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testSuiteName) $ do
#if MIN_VERSION_Cabal(1,25,0)
let testAutogenDir = autogenComponentModulesDir lbi suitecfg
#else
let testAutogenDir = autogenModulesDir lbi
#endif
createDirectoryIfMissingVerbose verbosity True testAutogenDir
rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines
[ "module Build_doctests where"
, ""
, "pkgs :: [String]"
, "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg)
, ""
, "flags :: [String]"
, "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)
, ""
, "module_sources :: [String]"
, "module_sources = " ++ show (map display module_sources)
]
where
isOldCompiler = maybe False id $ do
a <- simpleParse $ showCompilerId $ compiler lbi
b <- simpleParse "7.5"
return $ packageVersion (a :: PackageId) < b
formatDeps = map formatOne
formatOne (installedPkgId, pkgId)
| packageId pkg == pkgId = "-package=" ++ display pkgId
| otherwise = "-package-id=" ++ display installedPkgId
packageDbArgs :: [PackageDB] -> [String]
packageDbArgs | isOldCompiler = packageDbArgsConf
| otherwise = packageDbArgsDb
packageDbArgsConf :: [PackageDB] -> [String]
packageDbArgsConf dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
(GlobalPackageDB:dbs) -> ("-no-user-package-conf")
: concatMap specific dbs
_ -> ierror
where
specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]
specific _ = ierror
ierror = error $ "internal error: unexpected package db stack: "
++ show dbstack
packageDbArgsDb :: [PackageDB] -> [String]
packageDbArgsDb dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs)
| all isSpecific dbs -> concatMap single dbs
(GlobalPackageDB:dbs)
| all isSpecific dbs -> "-no-user-package-db"
: concatMap single dbs
dbs -> "-clear-package-db"
: concatMap single dbs
where
single (SpecificPackageDB db) = [ "-package-db=" ++ db ]
single GlobalPackageDB = [ "-global-package-db" ]
single UserPackageDB = [ "-user-package-db" ]
isSpecific (SpecificPackageDB _) = True
isSpecific _ = False
testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys