{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Distribution.Extra.Doctest (
defaultMainWithDoctests,
defaultMainAutoconfWithDoctests,
addDoctestsUserHook,
doctestsUserHooks,
generateBuildModule,
) where
#if MIN_VERSION_Cabal(1,24,0)
#define InstalledPackageId UnitId
#endif
import Control.Monad
(when)
import Data.List
(nub)
import Data.Maybe
(maybeToList, mapMaybe)
import Data.String
(fromString)
import qualified Data.Foldable as F
(for_)
import qualified Data.Traversable as T
(traverse)
import Distribution.Package
(InstalledPackageId)
import Distribution.Package
(Package (..), PackageId, packageVersion)
import Distribution.PackageDescription
(BuildInfo (..), Executable (..), Library (..), GenericPackageDescription,
PackageDescription (), TestSuite (..))
import Distribution.Simple
(UserHooks (..), autoconfUserHooks, defaultMainWithHooks, simpleUserHooks)
import Distribution.Simple.Compiler
(PackageDB (..), showCompilerId)
import Distribution.Simple.LocalBuildInfo
(ComponentLocalBuildInfo (componentPackageDeps), LocalBuildInfo (),
compiler, withExeLBI, withLibLBI, withPackageDB, withTestLBI)
import Distribution.Simple.Setup
(BuildFlags (buildDistPref, buildVerbosity), HaddockFlags (haddockDistPref, haddockVerbosity), fromFlag, emptyBuildFlags)
import Distribution.Simple.Utils
(createDirectoryIfMissingVerbose, info)
import Distribution.Text
(display, simpleParse)
import System.FilePath
((</>))
import Data.IORef (newIORef, modifyIORef, readIORef)
import Distribution.Simple.BuildPaths
#if MIN_VERSION_Cabal(1,25,0)
(autogenComponentModulesDir)
#else
(autogenModulesDir)
#endif
#if MIN_VERSION_Cabal(2,0,0)
import Distribution.Types.MungedPackageId
(MungedPackageId)
import Distribution.Types.UnqualComponentName
(unUnqualComponentName)
import Distribution.Types.GenericPackageDescription
(GenericPackageDescription (condTestSuites))
import Distribution.PackageDescription
(CondTree (..))
#endif
#if MIN_VERSION_Cabal(3,0,0)
import Distribution.Simple.Utils (findFileEx)
#else
import Distribution.Simple.Utils (findFile)
#endif
#if MIN_VERSION_Cabal(3,0,0)
import Distribution.Types.LibraryName (libraryNameString)
#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
#if !MIN_VERSION_Cabal(3,0,0)
findFileEx :: verbosity -> [FilePath] -> FilePath -> IO FilePath
findFileEx _ = findFile
#endif
defaultMainWithDoctests
:: String
-> IO ()
defaultMainWithDoctests = defaultMainWithHooks . doctestsUserHooks
defaultMainAutoconfWithDoctests
:: String
-> IO ()
defaultMainAutoconfWithDoctests n =
defaultMainWithHooks (addDoctestsUserHook n autoconfUserHooks)
doctestsUserHooks
:: String
-> UserHooks
doctestsUserHooks testsuiteName =
addDoctestsUserHook testsuiteName simpleUserHooks
addDoctestsUserHook :: String -> UserHooks -> UserHooks
addDoctestsUserHook testsuiteName uh = uh
{ buildHook = \pkg lbi hooks flags -> do
generateBuildModule testsuiteName flags pkg lbi
buildHook uh pkg lbi hooks flags
, confHook = \(gpd, hbi) flags ->
confHook uh (amendGPD testsuiteName gpd, hbi) flags
, haddockHook = \pkg lbi hooks flags -> do
generateBuildModule testsuiteName (haddockToBuildFlags flags) pkg lbi
haddockHook uh pkg lbi hooks flags
}
haddockToBuildFlags :: HaddockFlags -> BuildFlags
haddockToBuildFlags f = emptyBuildFlags
{ buildVerbosity = haddockVerbosity f
, buildDistPref = haddockDistPref f
}
data Name = NameLib (Maybe String) | NameExe String deriving (Eq, Show)
nameToString :: Name -> String
nameToString n = case n of
NameLib x -> maybe "" (("_lib_" ++) . map fixchar) x
NameExe x -> "_exe_" ++ map fixchar x
where
fixchar :: Char -> Char
fixchar '-' = '_'
fixchar c = c
data Component = Component Name [String] [String] [String]
deriving Show
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
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
let buildDoctestsFile = testAutogenDir </> "Build_doctests.hs"
info verbosity $ "cabal-doctest: writing Build_doctests to " ++ buildDoctestsFile
writeFile buildDoctestsFile $ unlines
[ "module Build_doctests where"
, ""
, "import Prelude"
, ""
, "data Name = NameLib (Maybe String) | NameExe String deriving (Eq, Show)"
, "data Component = Component Name [String] [String] [String] deriving (Eq, Show)"
, ""
]
componentsRef <- newIORef []
let testBI = testBuildInfo suite
let additionalFlags = maybe [] words
$ lookup "x-doctest-options"
$ customFieldsBI testBI
let additionalModules = maybe [] words
$ lookup "x-doctest-modules"
$ customFieldsBI testBI
let additionalDirs' = maybe [] words
$ lookup "x-doctest-source-dirs"
$ customFieldsBI testBI
additionalDirs <- mapM (fmap ("-i" ++) . makeAbsolute) additionalDirs'
let getBuildDoctests withCompLBI mbCompName compExposedModules compMainIs compBuildInfo =
withCompLBI pkg lbi $ \comp compCfg -> do
let compBI = compBuildInfo comp
let modules = compExposedModules comp ++ otherModules compBI
let module_sources = modules
#if MIN_VERSION_Cabal(1,25,0)
let compAutogenDir = autogenComponentModulesDir lbi compCfg
#else
let compAutogenDir = autogenModulesDir lbi
#endif
iArgsNoPrefix
<- mapM makeAbsolute
$ compAutogenDir
: (distPref ++ "/build")
: hsSourceDirs compBI
includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs compBI
let iArgs' = map ("-i"++) iArgsNoPrefix
iArgs = "-i" : iArgs'
let extensionArgs = map (("-X"++) . display) $ defaultExtensions compBI
let cppFlags = map ("-optP"++) $
[ "-include", compAutogenDir ++ "/cabal_macros.h" ]
++ cppOptions compBI
mainIsPath <- T.traverse (findFileEx verbosity iArgsNoPrefix) (compMainIs comp)
let all_sources = map display module_sources
++ additionalModules
++ maybeToList mainIsPath
let component = Component
(mbCompName comp)
(formatDeps $ testDeps compCfg suitecfg)
(concat
[ iArgs
, additionalDirs
, includeArgs
, dbFlags
, cppFlags
, extensionArgs
, additionalFlags
])
all_sources
modifyIORef componentsRef (\cs -> cs ++ [component])
getBuildDoctests withLibLBI mbLibraryName exposedModules (const Nothing) libBuildInfo
getBuildDoctests withExeLBI (NameExe . executableName) (const []) (Just . modulePath) buildInfo
components <- readIORef componentsRef
F.for_ components $ \(Component cmpName cmpPkgs cmpFlags cmpSources) -> do
let compSuffix = nameToString cmpName
pkgs_comp = "pkgs" ++ compSuffix
flags_comp = "flags" ++ compSuffix
module_sources_comp = "module_sources" ++ compSuffix
appendFile buildDoctestsFile $ unlines
[
pkgs_comp ++ " :: [String]"
, pkgs_comp ++ " = " ++ show cmpPkgs
, ""
, flags_comp ++ " :: [String]"
, flags_comp ++ " = " ++ show cmpFlags
, ""
, module_sources_comp ++ " :: [String]"
, module_sources_comp ++ " = " ++ show cmpSources
, ""
]
let enabledComponents = maybe [NameLib Nothing] (mapMaybe parseComponentName . words)
$ lookup "x-doctest-components"
$ customFieldsBI testBI
let components' =
filter (\(Component n _ _ _) -> n `elem` enabledComponents) components
appendFile buildDoctestsFile $ unlines
[ "-- " ++ show enabledComponents
, "components :: [Component]"
, "components = " ++ show components'
]
where
parseComponentName :: String -> Maybe Name
parseComponentName "lib" = Just (NameLib Nothing)
parseComponentName ('l' : 'i' : 'b' : ':' : x) = Just (NameLib (Just x))
parseComponentName ('e' : 'x' : 'e' : ':' : x) = Just (NameExe x)
parseComponentName _ = Nothing
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)
| display (packageId pkg) == display 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
mbLibraryName :: Library -> Name
#if MIN_VERSION_Cabal(3,0,0)
mbLibraryName = NameLib . fmap unUnqualComponentName . libraryNameString . libName
#elif MIN_VERSION_Cabal(2,0,0)
mbLibraryName = NameLib . fmap unUnqualComponentName . libName
#else
mbLibraryName _ = NameLib Nothing
#endif
executableName :: Executable -> String
#if MIN_VERSION_Cabal(2,0,0)
executableName = unUnqualComponentName . exeName
#else
executableName = exeName
#endif
testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo
#if MIN_VERSION_Cabal(2,0,0)
-> [(InstalledPackageId, MungedPackageId)]
#else
-> [(InstalledPackageId, PackageId)]
#endif
testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
amendGPD
:: String
-> GenericPackageDescription
-> GenericPackageDescription
#if !(MIN_VERSION_Cabal(2,0,0))
amendGPD _ = id
#else
amendGPD testSuiteName gpd = gpd
{ condTestSuites = map f (condTestSuites gpd)
}
where
f (name, condTree)
| name == fromString testSuiteName = (name, condTree')
| otherwise = (name, condTree)
where
testSuite = condTreeData condTree
bi = testBuildInfo testSuite
om = otherModules bi
am = autogenModules bi
om' = nub $ mn : om
am' = nub $ mn : am
mn = fromString "Build_doctests"
bi' = bi { otherModules = om', autogenModules = am' }
testSuite' = testSuite { testBuildInfo = bi' }
condTree' = condTree { condTreeData = testSuite' }
#endif