Commit 6beff4ef authored by Moritz Angermann's avatar Moritz Angermann Committed by GitHub
Browse files

Merge pull request #4480 from zw3rk/master

Adds cabal doctest
parents 5afa3624 f75c6b15
......@@ -170,6 +170,7 @@ library
Distribution.Simple.GHC
Distribution.Simple.GHCJS
Distribution.Simple.Haddock
Distribution.Simple.Doctest
Distribution.Simple.HaskellSuite
Distribution.Simple.Hpc
Distribution.Simple.Install
......
......@@ -85,6 +85,7 @@ import Distribution.Simple.BuildPaths
import Distribution.Simple.Test
import Distribution.Simple.Install
import Distribution.Simple.Haddock
import Distribution.Simple.Doctest
import Distribution.Simple.Utils
import Distribution.Utils.NubList
import Distribution.Verbosity
......@@ -175,6 +176,7 @@ defaultMainHelper hooks args = topHandler $
,replCommand progs `commandAddAction` replAction hooks
,installCommand `commandAddAction` installAction hooks
,copyCommand `commandAddAction` copyAction hooks
,doctestCommand `commandAddAction` doctestAction hooks
,haddockCommand `commandAddAction` haddockAction hooks
,cleanCommand `commandAddAction` cleanAction hooks
,sdistCommand `commandAddAction` sdistAction hooks
......@@ -290,6 +292,22 @@ hscolourAction hooks flags args = do
(getBuildConfig hooks verbosity distPref)
hooks flags' args
doctestAction :: UserHooks -> DoctestFlags -> Args -> IO ()
doctestAction hooks flags args = do
distPref <- findDistPrefOrDefault (doctestDistPref flags)
let verbosity = fromFlag $ doctestVerbosity flags
flags' = flags { doctestDistPref = toFlag distPref }
lbi <- getBuildConfig hooks verbosity distPref
progs <- reconfigurePrograms verbosity
(doctestProgramPaths flags')
(doctestProgramArgs flags')
(withPrograms lbi)
hookedAction preDoctest doctestHook postDoctest
(return lbi { withPrograms = progs })
hooks flags' args
haddockAction :: UserHooks -> HaddockFlags -> Args -> IO ()
haddockAction hooks flags args = do
distPref <- findDistPrefOrDefault (haddockDistPref flags)
......@@ -562,6 +580,7 @@ simpleUserHooks =
cleanHook = \p _ _ f -> clean p f,
hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f,
haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f,
doctestHook = \p l h f -> doctest p l (allSuffixHandlers h) f,
regHook = defaultRegHook,
unregHook = \p l _ f -> unregister p l f
}
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.BuildPaths
......@@ -31,11 +33,16 @@ module Distribution.Simple.BuildPaths (
objExtension,
dllExtension,
staticLibExtension,
-- * Source files & build directories
getSourceFiles, getLibSourceFiles, getExeSourceFiles,
getFLibSourceFiles, exeBuildDir, flibBuildDir,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.ForeignLib
import Distribution.Types.UnqualComponentName (unUnqualComponentName)
import Distribution.Package
import Distribution.ModuleName as ModuleName
import Distribution.Compiler
......@@ -44,8 +51,10 @@ import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Setup
import Distribution.Text
import Distribution.System
import Distribution.Verbosity
import Distribution.Simple.Utils
import System.FilePath ((</>), (<.>))
import System.FilePath ((</>), (<.>), normalise)
-- ---------------------------------------------------------------------------
-- Build directories and files
......@@ -104,6 +113,72 @@ autogenPathsModuleName pkg_descr =
haddockName :: PackageDescription -> FilePath
haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock"
-- -----------------------------------------------------------------------------
-- Source File helper
getLibSourceFiles :: Verbosity
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO [(ModuleName.ModuleName, FilePath)]
getLibSourceFiles verbosity lbi lib clbi = getSourceFiles verbosity searchpaths modules
where
bi = libBuildInfo lib
modules = allLibModules lib clbi
searchpaths = componentBuildDir lbi clbi : hsSourceDirs bi ++
[ autogenComponentModulesDir lbi clbi
, autogenPackageModulesDir lbi ]
getExeSourceFiles :: Verbosity
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO [(ModuleName.ModuleName, FilePath)]
getExeSourceFiles verbosity lbi exe clbi = do
moduleFiles <- getSourceFiles verbosity searchpaths modules
srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe)
return ((ModuleName.main, srcMainPath) : moduleFiles)
where
bi = buildInfo exe
modules = otherModules bi
searchpaths = autogenComponentModulesDir lbi clbi
: autogenPackageModulesDir lbi
: exeBuildDir lbi exe : hsSourceDirs bi
getFLibSourceFiles :: Verbosity
-> LocalBuildInfo
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO [(ModuleName.ModuleName, FilePath)]
getFLibSourceFiles verbosity lbi flib clbi = getSourceFiles verbosity searchpaths modules
where
bi = foreignLibBuildInfo flib
modules = otherModules bi
searchpaths = autogenComponentModulesDir lbi clbi
: autogenPackageModulesDir lbi
: flibBuildDir lbi flib : hsSourceDirs bi
getSourceFiles :: Verbosity -> [FilePath]
-> [ModuleName.ModuleName]
-> IO [(ModuleName.ModuleName, FilePath)]
getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> fmap ((,) m) $
findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m)
>>= maybe (notFound m) (return . normalise)
where
notFound module_ = die' verbosity $ "can't find source for module " ++ display module_
-- | The directory where we put build results for an executable
exeBuildDir :: LocalBuildInfo -> Executable -> FilePath
exeBuildDir lbi exe = buildDir lbi </> nm </> nm ++ "-tmp"
where
nm = unUnqualComponentName $ exeName exe
-- | The directory where we put build results for a foreign library
flibBuildDir :: LocalBuildInfo -> ForeignLib -> FilePath
flibBuildDir lbi flib = buildDir lbi </> nm </> nm ++ "-tmp"
where
nm = unUnqualComponentName $ foreignLibName flib
-- ---------------------------------------------------------------------------
-- Library file names
......
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Doctest
-- Copyright : Moritz Angermann 2017
-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- This module deals with the @doctest@ command.
-- Note: this module is modelled after Distribution.Simple.Haddock
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
-- local
import Distribution.PackageDescription as PD hiding (Flag)
import Distribution.Simple.Compiler hiding (Flag)
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.Utils.NubList
import Distribution.Version
import Distribution.Verbosity
-- -----------------------------------------------------------------------------
-- Types
-- | A record that represents the arguments to the doctest executable.
data DoctestArgs = DoctestArgs {
argTargets :: [FilePath]
-- ^ Modules to process
, argGhcOptions :: Flag (GhcOptions, Version)
} deriving (Show, Generic)
-- -----------------------------------------------------------------------------
-- Doctest support
doctest :: PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> DoctestFlags
-> IO ()
doctest pkg_descr lbi suffixes doctestFlags = do
let verbosity = flag doctestVerbosity
distPref = flag doctestDistPref
flag f = fromFlag $ f doctestFlags
tmpFileOpts = defaultTempFileOptions
lbi' = lbi { withPackageDB = withPackageDB lbi
++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] }
(doctestProg, _version, _) <-
requireProgramVersion verbosity doctestProgram
(orLaterVersion (mkVersion [0,11,3])) (withPrograms lbi)
withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do
componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity
preprocessComponent pkg_descr component lbi clbi False verbosity suffixes
case component of
CLib lib -> do
withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $
\tmp -> do
inFiles <- map snd <$> getLibSourceFiles verbosity lbi lib clbi
args <- mkDoctestArgs verbosity tmp lbi' clbi inFiles (libBuildInfo lib)
runDoctest verbosity (compiler lbi) (hostPlatform lbi) doctestProg args
CExe exe -> do
withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $
\tmp -> do
inFiles <- map snd <$> getExeSourceFiles verbosity lbi exe clbi
args <- mkDoctestArgs verbosity tmp lbi' clbi inFiles (buildInfo exe)
runDoctest verbosity (compiler lbi) (hostPlatform lbi) doctestProg args
CFLib _ -> return () -- do not doctest foreign libs
CTest _ -> return () -- do not doctest tests
CBench _ -> return () -- do not doctest benchmarks
-- -----------------------------------------------------------------------------
-- Contributions to DoctestArgs (see also Haddock.hs for very similar code).
componentGhcOptions :: Verbosity -> LocalBuildInfo
-> BuildInfo -> ComponentLocalBuildInfo -> FilePath
-> GhcOptions
componentGhcOptions verbosity lbi bi clbi odir =
let f = case compilerFlavor (compiler lbi) of
GHC -> GHC.componentGhcOptions
GHCJS -> GHCJS.componentGhcOptions
_ -> error $
"Distribution.Simple.Doctest.componentGhcOptions:" ++
"doctest only supports GHC and GHCJS"
in f verbosity lbi bi clbi odir
mkDoctestArgs :: Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> [FilePath]
-> BuildInfo
-> IO DoctestArgs
mkDoctestArgs verbosity tmp lbi clbi inFiles bi = do
let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi))
{ ghcOptOptimisation = mempty -- no optimizations when runnign doctest
-- disable -Wmissing-home-modules
, ghcOptWarnMissingHomeModules = mempty
-- clear out ghc-options: these are likely not meant for doctest.
-- If so, should be explicitly specified via doctest-ghc-options: again.
, ghcOptExtra = mempty
, ghcOptCabal = toFlag False
, ghcOptObjDir = toFlag tmp
, ghcOptHiDir = toFlag tmp
, ghcOptStubDir = toFlag tmp }
sharedOpts = vanillaOpts
{ ghcOptDynLinkMode = toFlag GhcDynamicOnly
, ghcOptFPic = toFlag True
, ghcOptHiSuffix = toFlag "dyn_hi"
, ghcOptObjSuffix = toFlag "dyn_o"
, ghcOptExtra = toNubListR (hcSharedOptions GHC bi)}
opts <- if withVanillaLib lbi
then return vanillaOpts
else if withSharedLib lbi
then return sharedOpts
else die' verbosity $ "Must have vanilla or shared lirbaries "
++ "enabled in order to run doctest"
ghcVersion <- maybe (die' verbosity "Compiler has no GHC version")
return
(compilerCompatVersion GHC (compiler lbi))
return $ DoctestArgs
{ argTargets = inFiles
, argGhcOptions = toFlag (opts, ghcVersion)
}
-- -----------------------------------------------------------------------------
-- Call doctest with the specified arguments.
runDoctest :: Verbosity
-> Compiler
-> Platform
-> ConfiguredProgram
-> DoctestArgs
-> IO ()
runDoctest verbosity comp platform doctestProg args = do
renderArgs verbosity comp platform args $
\(flags, files) -> do
runProgram verbosity doctestProg (flags <> files)
renderArgs :: Verbosity
-> Compiler
-> Platform
-> DoctestArgs
-> (([String],[FilePath]) -> IO a)
-> IO a
renderArgs _verbosity comp platform args k = do
k (flags, argTargets args)
where
flags :: [String]
flags = mconcat
[ pure "--no-magic" -- disable doctests automagic discovery heuristics
, pure "-fdiagnostics-color=never" -- disable ghc's color diagnostics.
, [ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args)
, opt <- renderGhcOptions comp platform opts ]
]
-- ------------------------------------------------------------------------------
-- Boilerplate Monoid instance.
instance Monoid DoctestArgs where
mempty = gmempty
mappend = (<>)
instance Semigroup DoctestArgs where
(<>) = gmappend
......@@ -242,7 +242,7 @@ haddock pkg_descr lbi suffixes flags' = do
for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)
-- ------------------------------------------------------------------------------
-- Contributions to HaddockArgs.
-- Contributions to HaddockArgs (see also Doctest.hs for very similar code).
fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags env flags =
......@@ -751,71 +751,6 @@ haddockToHscolour flags =
hscolourVerbosity = haddockVerbosity flags,
hscolourDistPref = haddockDistPref flags
}
---------------------------------------------------------------------------------
-- TODO these should be moved elsewhere.
getLibSourceFiles :: Verbosity
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO [(ModuleName.ModuleName, FilePath)]
getLibSourceFiles verbosity lbi lib clbi = getSourceFiles verbosity searchpaths modules
where
bi = libBuildInfo lib
modules = allLibModules lib clbi
searchpaths = componentBuildDir lbi clbi : hsSourceDirs bi ++
[ autogenComponentModulesDir lbi clbi
, autogenPackageModulesDir lbi ]
getExeSourceFiles :: Verbosity
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO [(ModuleName.ModuleName, FilePath)]
getExeSourceFiles verbosity lbi exe clbi = do
moduleFiles <- getSourceFiles verbosity searchpaths modules
srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe)
return ((ModuleName.main, srcMainPath) : moduleFiles)
where
bi = buildInfo exe
modules = otherModules bi
searchpaths = autogenComponentModulesDir lbi clbi
: autogenPackageModulesDir lbi
: exeBuildDir lbi exe : hsSourceDirs bi
getFLibSourceFiles :: Verbosity
-> LocalBuildInfo
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO [(ModuleName.ModuleName, FilePath)]
getFLibSourceFiles verbosity lbi flib clbi = getSourceFiles verbosity searchpaths modules
where
bi = foreignLibBuildInfo flib
modules = otherModules bi
searchpaths = autogenComponentModulesDir lbi clbi
: autogenPackageModulesDir lbi
: flibBuildDir lbi flib : hsSourceDirs bi
getSourceFiles :: Verbosity -> [FilePath]
-> [ModuleName.ModuleName]
-> IO [(ModuleName.ModuleName, FilePath)]
getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> fmap ((,) m) $
findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m)
>>= maybe (notFound m) (return . normalise)
where
notFound module_ = die' verbosity $ "haddock: can't find source for module " ++ display module_
-- | The directory where we put build results for an executable
exeBuildDir :: LocalBuildInfo -> Executable -> FilePath
exeBuildDir lbi exe = buildDir lbi </> nm </> nm ++ "-tmp"
where
nm = unUnqualComponentName $ exeName exe
-- | The directory where we put build results for a foreign library
flibBuildDir :: LocalBuildInfo -> ForeignLib -> FilePath
flibBuildDir lbi flib = buildDir lbi </> nm </> nm ++ "-tmp"
where
nm = unUnqualComponentName $ foreignLibName flib
-- ------------------------------------------------------------------------------
-- Boilerplate Monoid instance.
......
......@@ -62,7 +62,7 @@ module Distribution.Simple.LocalBuildInfo (
module Distribution.Simple.InstallDirs,
absoluteInstallDirs, prefixRelativeInstallDirs,
absoluteComponentInstallDirs, prefixRelativeComponentInstallDirs,
substPathTemplate
substPathTemplate,
) where
import Prelude ()
......@@ -383,3 +383,4 @@ substPathTemplate pkgid lbi uid = fromPathTemplate
uid
(compilerInfo (compiler lbi))
(hostPlatform lbi)
......@@ -112,6 +112,7 @@ module Distribution.Simple.Program (
, c2hsProgram
, cpphsProgram
, hscolourProgram
, doctestProgram
, haddockProgram
, greencardProgram
, ldProgram
......
......@@ -37,6 +37,7 @@ module Distribution.Simple.Program.Builtin (
c2hsProgram,
cpphsProgram,
hscolourProgram,
doctestProgram,
haddockProgram,
greencardProgram,
ldProgram,
......@@ -85,6 +86,7 @@ builtinPrograms =
, hpcProgram
-- preprocessors
, hscolourProgram
, doctestProgram
, haddockProgram
, happyProgram
, alexProgram
......@@ -309,6 +311,18 @@ hscolourProgram = (simpleProgram "hscolour") {
_ -> ""
}
-- TODO: Ensure that doctest is built against the same GHC as the one
-- that's being used. Same for haddock. @phadej pointed this out.
doctestProgram :: Program
doctestProgram = (simpleProgram "doctest") {
programFindLocation = \v p -> findProgramOnSearchPath v p "doctest"
, programFindVersion = findProgramVersion "--version" $ \str ->
-- "doctest version 0.11.2"
case words str of
(_:_:ver:_) -> ver
_ -> ""
}
haddockProgram :: Program
haddockProgram = (simpleProgram "haddock") {
programFindVersion = findProgramVersion "--version" $ \str ->
......
......@@ -76,6 +76,8 @@ data Program = Program {
-- it could add args, or environment vars.
programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
}
instance Show Program where
show (Program name _ _ _) = "Program: " ++ name
type ProgArg = String
......
......@@ -42,6 +42,7 @@ module Distribution.Simple.Setup (
configAbsolutePaths, readPackageDbList, showPackageDbList,
CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand,
InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand,
DoctestFlags(..), emptyDoctestFlags, defaultDoctestFlags, doctestCommand,
HaddockTarget(..),
HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand,
HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,
......@@ -1387,6 +1388,68 @@ hscolourCommand = CommandUI
]
}
-- ------------------------------------------------------------
-- * Doctest flags
-- ------------------------------------------------------------
data DoctestFlags = DoctestFlags {
doctestProgramPaths :: [(String, FilePath)],
doctestProgramArgs :: [(String, [String])],
doctestDistPref :: Flag FilePath,
doctestVerbosity :: Flag Verbosity
}
deriving (Show, Generic)
defaultDoctestFlags :: DoctestFlags
defaultDoctestFlags = DoctestFlags {
doctestProgramPaths = mempty,
doctestProgramArgs = [],
doctestDistPref = NoFlag,
doctestVerbosity = Flag normal
}
doctestCommand :: CommandUI DoctestFlags
doctestCommand = CommandUI
{ commandName = "doctest"
, commandSynopsis = "Run doctest tests."
, commandDescription = Just $ \_ ->
"Requires the program doctest, version 0.12.\n"
, commandNotes = Nothing
, commandUsage = \pname ->
"Usage: " ++ pname ++ " doctest [FLAGS]\n"
, commandDefaultFlags = defaultDoctestFlags
, commandOptions = \showOrParseArgs ->
doctestOptions showOrParseArgs
++ programDbPaths progDb ParseArgs
doctestProgramPaths (\v flags -> flags { doctestProgramPaths = v })
++ programDbOption progDb showOrParseArgs
doctestProgramArgs (\v fs -> fs { doctestProgramArgs = v })
++ programDbOptions progDb ParseArgs
doctestProgramArgs (\v flags -> flags { doctestProgramArgs = v })
}
where
progDb = addKnownProgram doctestProgram
emptyProgramDb
doctestOptions :: ShowOrParseArgs -> [OptionField DoctestFlags]
doctestOptions showOrParseArgs =
[optionVerbosity doctestVerbosity
(\v flags -> flags { doctestVerbosity = v })
,optionDistPref
doctestDistPref (\d flags -> flags { doctestDistPref = d })
showOrParseArgs
]
emptyDoctestFlags :: DoctestFlags
emptyDoctestFlags = mempty
instance Monoid DoctestFlags where
mempty = gmempty
mappend = (<>)
instance Semigroup DoctestFlags where
(<>) = gmappend
-- ------------------------------------------------------------
-- * Haddock flags
-- ------------------------------------------------------------
......
......@@ -135,6 +135,13 @@ data UserHooks = UserHooks {
-- |Hook to run after hscolour command. Second arg indicates verbosity level.
postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-- |Hook to run before doctest command. Second arg indicates verbosity level.
preDoctest :: Args -> DoctestFlags -> IO HookedBuildInfo,
-- |Over-ride this hook to get different behavior during doctest.
doctestHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> DoctestFlags -> IO (),
-- |Hook to run after doctest command. Second arg indicates verbosity level.
postDoctest :: Args -> DoctestFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-- |Hook to run before haddock command. Second arg indicates verbosity level.
preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo,
-- |Over-ride this hook to get different behavior during haddock.
......@@ -197,6 +204,9 @@ emptyUserHooks
preHscolour = rn,
hscolourHook = ru,
postHscolour = ru,
preDoctest = rn,
doctestHook = ru,
postDoctest = ru,
preHaddock = rn,
haddockHook = ru,
postHaddock = ru,
......
......@@ -172,6 +172,7 @@ globalCommand commands = CommandUI {
, "freeze"
, "gen-bounds"