Adds cabal doctest

Cabal/Cabal.cabal

@@ -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

Cabal/Distribution/Simple.hs

@@ -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
       }

Cabal/Distribution/Simple/Doctest.hs

@@ -0,0 +1,158 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RankNTypes    #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Distribution.Simple.Haddock
+-- Copyright   :  Isaac Jones 2003-2005
+-- License     :  BSD3
+--
+-- Maintainer  :  [email protected]
+-- Portability :  portable
+--
+-- This module deals with the @doctest@ command.
+
+module Distribution.Simple.Doctest (
+  doctest
+  ) where
+
+import Prelude ()
+import Distribution.Compat.Prelude
+
+
+-- local
+import Distribution.Backpack.DescribeUnitId (setupMessage')
+import Distribution.Types.UnqualComponentName
+import Distribution.Types.ComponentLocalBuildInfo
+import Distribution.Package
+import qualified Distribution.ModuleName as ModuleName
+import Distribution.PackageDescription as PD hiding (Flag)
+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.BuildPaths
+import Distribution.Simple.Utils
+import Distribution.Text
+import Distribution.Version
+import Distribution.Verbosity
+
+import System.FilePath  ( (</>), normalise )
+
+-- -----------------------------------------------------------------------------
+-- Types
+
+-- | A record that represents the arguments to the doctest executable.
+data DoctestArgs = DoctestArgs {
+  argTargets :: [FilePath]
+  -- ^ Modules to process
+} deriving (Show, 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
+  (doctestProg, version, _) <-
+    requireProgramVersion verbosity doctestProgram
+      (orLaterVersion (mkVersion [0,11])) (withPrograms lbi)
+
+  withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do
+     componentInitialBuildSteps (flag doctestDistPref) pkg_descr lbi clbi verbosity
+     preprocessComponent pkg_descr component lbi clbi False verbosity suffixes
+     let
+       smsg :: IO ()
+       smsg = setupMessage' verbosity "Running Doctest on" (packageId pkg_descr)
+              (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
+
+     case component of 
+       CLib lib -> do
+         args <- DoctestArgs . map snd <$> getLibSourceFiles verbosity lbi lib clbi
+         runDoctest verbosity doctestProg args
+       CExe exe -> do
+         args <- DoctestArgs . map snd <$> getExeSourceFiles verbosity lbi exe clbi
+         runDoctest verbosity doctestProg args
+       CFLib _  -> return () -- do not doctest foreign libs
+       CTest _  -> return () -- do not doctest tests
+       CBench _ -> return () -- do not doctest benchmarks 
+
+-- -----------------------------------------------------------------------------
+-- Call doctest with the specified arguments.
+runDoctest :: Verbosity
+           -> ConfiguredProgram
+           -> DoctestArgs
+           -> IO ()
+runDoctest verbosity doctestProg args = do
+  renderArgs verbosity args $
+    \(flags, files) -> do
+      runProgram verbosity doctestProg (flags <> files)
+
+renderArgs :: Verbosity
+           -> DoctestArgs
+           -> (([String],[FilePath]) -> IO a)
+           -> IO a
+renderArgs verbosity args k = do
+  -- inject the "--no-magic" flag, to have a rather bare
+  -- doctest invocation, and disable doctests automagic discovery heuristics.
+  k (["--no-magic"], argTargets args)
+
+-- -----------------------------------------------------------------------------
+-- TODO: move somewhere else (this is copied from Haddock.hs!)
+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
+
+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 $ "doctest: 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
+
+-- ------------------------------------------------------------------------------
+-- Boilerplate Monoid instance.
+instance Monoid DoctestArgs where
+    mempty = gmempty
+    mappend = (<>)
+
+instance Semigroup DoctestArgs where
+    (<>) = gmappend

Cabal/Distribution/Simple/Program.hs

@@ -112,6 +112,7 @@ module Distribution.Simple.Program (
     , c2hsProgram
     , cpphsProgram
     , hscolourProgram
+    , doctestProgram
     , haddockProgram
     , greencardProgram
     , ldProgram

Cabal/Distribution/Simple/Program/Builtin.hs

@@ -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 ->

Cabal/Distribution/Simple/Program/Types.hs

@@ -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
 

Cabal/Distribution/Simple/Setup.hs

@@ -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,69 @@ 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 =
+  [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
 -- ------------------------------------------------------------

Cabal/Distribution/Simple/UserHooks.hs

@@ -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,

cabal-install/Distribution/Client/Setup.hs

@@ -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"

cabal-install/main/Main.hs

@@ -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)