Commit 435fd96e authored by Moritz Angermann's avatar Moritz Angermann

Add `doctest’ command.

This adds the `doctest` command to cabal.  It does however not yet work as the driver
is baiscally a stub.

This is therfore only the first step towards #2327.
parent 365f4872
......@@ -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` doctestAcion hooks
,haddockCommand `commandAddAction` haddockAction hooks
,cleanCommand `commandAddAction` cleanAction hooks
,sdistCommand `commandAddAction` sdistAction hooks
......@@ -290,6 +292,21 @@ hscolourAction hooks flags args = do
(getBuildConfig hooks verbosity distPref)
hooks flags' args
doctestAcion :: UserHooks -> DoctestFlags -> Args -> IO ()
doctestAcion hooks flags args = do
distPref <- findDistPrefOrDefault (doctestDistPref flags)
let verbosity = fromFlag $ doctestVerbosity flags
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 +579,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 DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Haddock
-- Copyright : Isaac Jones 2003-2005
-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- This module deals with the @doctest@ command.
module Distribution.Simple.Doctest (
doctest
) where
import Prelude ()
import Distribution.Compat.Prelude
-- local
import Distribution.PackageDescription as PD hiding (Flag)
import Distribution.Simple.PreProcess
import Distribution.Simple.Setup
import Distribution.Simple.Build
import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate)
import Distribution.Compat.Semigroup (Any (..))
-- -----------------------------------------------------------------------------
-- Types
-- | A record that represents the arguments to the doctest executable.
data DoctestArgs = DoctestArgs {
argHelp :: Any,
argVersion :: Any,
argNoMagic :: Any
} deriving Generic
-- -----------------------------------------------------------------------------
-- Doctest support
doctest :: PackageDescription
-> LocalBuildInfo
-> [PPSuffixHandler]
-> DoctestFlags
-> IO ()
doctest pkg_descr lbi suffixes doctestFlags = do
let verbosity = flag doctestVerbosity
flag f = fromFlag $ f doctestFlags
withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do
componentInitialBuildSteps (flag doctestDistPref) pkg_descr lbi clbi verbosity
preprocessComponent pkg_descr component lbi clbi False verbosity suffixes
......@@ -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,16 @@ hscolourProgram = (simpleProgram "hscolour") {
_ -> ""
}
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 ->
......
......@@ -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,63 @@ 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
$ addKnownProgram ghcProgram
$ emptyProgramDb
doctestOptions :: ShowOrParseArgs -> [OptionField DoctestFlags]
doctestOptions 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"
, "outdated"
, "doctest"
, "haddock"
, "hscolour"
, "copy"
......@@ -232,6 +233,7 @@ globalCommand commands = CommandUI {
, addCmd "freeze"
, addCmd "gen-bounds"
, addCmd "outdated"
, addCmd "doctest"
, addCmd "haddock"
, addCmd "hscolour"
, addCmd "copy"
......
......@@ -50,6 +50,7 @@ import Distribution.Client.Setup
)
import Distribution.Simple.Setup
( HaddockTarget(..)
, DoctestFlags(..), doctestCommand, defaultDoctestFlags
, HaddockFlags(..), haddockCommand, defaultHaddockFlags
, HscolourFlags(..), hscolourCommand
, ReplFlags(..)
......@@ -270,6 +271,7 @@ mainWorker args = topHandler $
, regularCmd buildCommand buildAction
, regularCmd replCommand replAction
, regularCmd sandboxCommand sandboxAction
, regularCmd doctestCommand doctestAcion
, regularCmd haddockCommand haddockAction
, regularCmd execCommand execAction
, regularCmd userConfigCommand userConfigAction
......@@ -761,6 +763,14 @@ haddockAction haddockFlags extraArgs globalFlags = do
createTarGzFile dest docDir name
notice verbosity $ "Documentation tarball created: " ++ dest
doctestAcion :: DoctestFlags -> [String] -> Action
doctestAcion doctestFlags extraArgs globalFlags = do
let verbosity = fromFlag (doctestVerbosity doctestFlags)
(useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags
setupWrapper verbosity defaultSetupScriptOptions Nothing
doctestCommand (const doctestFlags) extraArgs
cleanAction :: CleanFlags -> [String] -> Action
cleanAction cleanFlags extraArgs globalFlags = do
load <- try (loadConfigOrSandboxConfig verbosity globalFlags)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment