{-# 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
import Distribution.Simple.Compiler
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.Version
import Distribution.Verbosity

-- -----------------------------------------------------------------------------
-- Types

-- | A record that represents the arguments to the doctest executable.
data DoctestArgs = DoctestArgs {
    DoctestArgs -> [FilePath]
argTargets :: [FilePath]
    -- ^ Modules to process
  , DoctestArgs -> Flag (GhcOptions, Version)
argGhcOptions :: Flag (GhcOptions, Version)
} deriving (Int -> DoctestArgs -> ShowS
[DoctestArgs] -> ShowS
DoctestArgs -> FilePath
(Int -> DoctestArgs -> ShowS)
-> (DoctestArgs -> FilePath)
-> ([DoctestArgs] -> ShowS)
-> Show DoctestArgs
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DoctestArgs] -> ShowS
$cshowList :: [DoctestArgs] -> ShowS
show :: DoctestArgs -> FilePath
$cshow :: DoctestArgs -> FilePath
showsPrec :: Int -> DoctestArgs -> ShowS
$cshowsPrec :: Int -> DoctestArgs -> ShowS
Show, (forall x. DoctestArgs -> Rep DoctestArgs x)
-> (forall x. Rep DoctestArgs x -> DoctestArgs)
-> Generic DoctestArgs
forall x. Rep DoctestArgs x -> DoctestArgs
forall x. DoctestArgs -> Rep DoctestArgs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DoctestArgs x -> DoctestArgs
$cfrom :: forall x. DoctestArgs -> Rep DoctestArgs x
Generic)

-- -----------------------------------------------------------------------------
-- Doctest support

doctest :: PackageDescription
        -> LocalBuildInfo
        -> [PPSuffixHandler]
        -> DoctestFlags
        -> IO ()
doctest :: PackageDescription
-> LocalBuildInfo -> [PPSuffixHandler] -> DoctestFlags -> IO ()
doctest PackageDescription
pkg_descr LocalBuildInfo
lbi [PPSuffixHandler]
suffixes DoctestFlags
doctestFlags = do
  let verbosity :: Verbosity
verbosity     = (DoctestFlags -> Flag Verbosity) -> Verbosity
forall a. (DoctestFlags -> Flag a) -> a
flag DoctestFlags -> Flag Verbosity
doctestVerbosity
      distPref :: FilePath
distPref      = (DoctestFlags -> Flag FilePath) -> FilePath
forall a. (DoctestFlags -> Flag a) -> a
flag DoctestFlags -> Flag FilePath
doctestDistPref
      flag :: (DoctestFlags -> Flag a) -> a
flag DoctestFlags -> Flag a
f        = Flag a -> a
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag a -> a) -> Flag a -> a
forall a b. (a -> b) -> a -> b
$ DoctestFlags -> Flag a
f DoctestFlags
doctestFlags
      tmpFileOpts :: TempFileOptions
tmpFileOpts   = TempFileOptions
defaultTempFileOptions
      lbi' :: LocalBuildInfo
lbi'          = LocalBuildInfo
lbi { withPackageDB :: PackageDBStack
withPackageDB = LocalBuildInfo -> PackageDBStack
withPackageDB LocalBuildInfo
lbi
                            PackageDBStack -> PackageDBStack -> PackageDBStack
forall a. [a] -> [a] -> [a]
++ [FilePath -> PackageDB
SpecificPackageDB (LocalBuildInfo -> ShowS
internalPackageDBPath LocalBuildInfo
lbi FilePath
distPref)] }

  (ConfiguredProgram
doctestProg, Version
_version, ProgramDb
_) <-
    Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion Verbosity
verbosity Program
doctestProgram
      (Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
0,Int
11,Int
3])) (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)

  PackageDescription
-> LocalBuildInfo
-> (Component -> ComponentLocalBuildInfo -> IO ())
-> IO ()
withAllComponentsInBuildOrder PackageDescription
pkg_descr LocalBuildInfo
lbi ((Component -> ComponentLocalBuildInfo -> IO ()) -> IO ())
-> (Component -> ComponentLocalBuildInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Component
component ComponentLocalBuildInfo
clbi -> do
     FilePath
-> PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Verbosity
-> IO ()
componentInitialBuildSteps FilePath
distPref PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Verbosity
verbosity
     PackageDescription
-> Component
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> Bool
-> Verbosity
-> [PPSuffixHandler]
-> IO ()
preprocessComponent PackageDescription
pkg_descr Component
component LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi Bool
False Verbosity
verbosity [PPSuffixHandler]
suffixes

     case Component
component of
       CLib Library
lib -> do
         Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO a)
-> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
tmpFileOpts (LocalBuildInfo -> FilePath
buildDir LocalBuildInfo
lbi) FilePath
"tmp" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
           \FilePath
tmp -> do
             [FilePath]
inFiles <- ((ModuleName, FilePath) -> FilePath)
-> [(ModuleName, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, FilePath) -> FilePath
forall a b. (a, b) -> b
snd ([(ModuleName, FilePath)] -> [FilePath])
-> IO [(ModuleName, FilePath)] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO [(ModuleName, FilePath)]
getLibSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi
             DoctestArgs
args    <- Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> [FilePath]
-> BuildInfo
-> IO DoctestArgs
mkDoctestArgs Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi' ComponentLocalBuildInfo
clbi [FilePath]
inFiles (Library -> BuildInfo
libBuildInfo Library
lib)
             Verbosity
-> Compiler
-> Platform
-> ConfiguredProgram
-> DoctestArgs
-> IO ()
runDoctest Verbosity
verbosity (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) ConfiguredProgram
doctestProg DoctestArgs
args
       CExe Executable
exe -> do
         Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions
-> FilePath
-> FilePath
-> (FilePath -> IO a)
-> IO a
withTempDirectoryEx Verbosity
verbosity TempFileOptions
tmpFileOpts (LocalBuildInfo -> FilePath
buildDir LocalBuildInfo
lbi) FilePath
"tmp" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
           \FilePath
tmp -> do
             [FilePath]
inFiles <- ((ModuleName, FilePath) -> FilePath)
-> [(ModuleName, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, FilePath) -> FilePath
forall a b. (a, b) -> b
snd ([(ModuleName, FilePath)] -> [FilePath])
-> IO [(ModuleName, FilePath)] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO [(ModuleName, FilePath)]
getExeSourceFiles Verbosity
verbosity LocalBuildInfo
lbi Executable
exe ComponentLocalBuildInfo
clbi
             DoctestArgs
args    <- Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> [FilePath]
-> BuildInfo
-> IO DoctestArgs
mkDoctestArgs Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi' ComponentLocalBuildInfo
clbi [FilePath]
inFiles (Executable -> BuildInfo
buildInfo Executable
exe)
             Verbosity
-> Compiler
-> Platform
-> ConfiguredProgram
-> DoctestArgs
-> IO ()
runDoctest Verbosity
verbosity (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) ConfiguredProgram
doctestProg DoctestArgs
args
       CFLib ForeignLib
_  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- do not doctest foreign libs
       CTest TestSuite
_  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- do not doctest tests
       CBench Benchmark
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
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
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi FilePath
odir =
  let f :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
f = case Compiler -> CompilerFlavor
compilerFlavor (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) of
            CompilerFlavor
GHC   -> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
GHC.componentGhcOptions
            CompilerFlavor
GHCJS -> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
GHCJS.componentGhcOptions
            CompilerFlavor
_     -> FilePath
-> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
forall a. HasCallStack => FilePath -> a
error (FilePath
 -> Verbosity
 -> LocalBuildInfo
 -> BuildInfo
 -> ComponentLocalBuildInfo
 -> FilePath
 -> GhcOptions)
-> FilePath
-> Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
forall a b. (a -> b) -> a -> b
$
                       FilePath
"Distribution.Simple.Doctest.componentGhcOptions:" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
                       FilePath
"doctest only supports GHC and GHCJS"
  in Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
f Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi FilePath
odir

mkDoctestArgs :: Verbosity
              -> FilePath
              -> LocalBuildInfo
              -> ComponentLocalBuildInfo
              -> [FilePath]
              -> BuildInfo
              -> IO DoctestArgs
mkDoctestArgs :: Verbosity
-> FilePath
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> [FilePath]
-> BuildInfo
-> IO DoctestArgs
mkDoctestArgs Verbosity
verbosity FilePath
tmp LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi [FilePath]
inFiles BuildInfo
bi = do
  let vanillaOpts :: GhcOptions
vanillaOpts = (Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> GhcOptions
componentGhcOptions Verbosity
normal LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi (LocalBuildInfo -> FilePath
buildDir LocalBuildInfo
lbi))
        { ghcOptOptimisation :: Flag GhcOptimisation
ghcOptOptimisation = Flag GhcOptimisation
forall a. Monoid a => a
mempty -- no optimizations when runnign doctest
        -- disable -Wmissing-home-modules
        , ghcOptWarnMissingHomeModules :: Flag Bool
ghcOptWarnMissingHomeModules = Flag Bool
forall a. Monoid a => a
mempty
        -- clear out ghc-options: these are likely not meant for doctest.
        -- If so, should be explicitly specified via doctest-ghc-options: again.
        , ghcOptExtra :: [FilePath]
ghcOptExtra   = [FilePath]
forall a. Monoid a => a
mempty
        , ghcOptCabal :: Flag Bool
ghcOptCabal   = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
False

        , ghcOptObjDir :: Flag FilePath
ghcOptObjDir  = FilePath -> Flag FilePath
forall a. a -> Flag a
toFlag FilePath
tmp
        , ghcOptHiDir :: Flag FilePath
ghcOptHiDir   = FilePath -> Flag FilePath
forall a. a -> Flag a
toFlag FilePath
tmp
        , ghcOptStubDir :: Flag FilePath
ghcOptStubDir = FilePath -> Flag FilePath
forall a. a -> Flag a
toFlag FilePath
tmp }
      sharedOpts :: GhcOptions
sharedOpts = GhcOptions
vanillaOpts
        { ghcOptDynLinkMode :: Flag GhcDynLinkMode
ghcOptDynLinkMode = GhcDynLinkMode -> Flag GhcDynLinkMode
forall a. a -> Flag a
toFlag GhcDynLinkMode
GhcDynamicOnly
        , ghcOptFPic :: Flag Bool
ghcOptFPic        = Bool -> Flag Bool
forall a. a -> Flag a
toFlag Bool
True
        , ghcOptHiSuffix :: Flag FilePath
ghcOptHiSuffix    = FilePath -> Flag FilePath
forall a. a -> Flag a
toFlag FilePath
"dyn_hi"
        , ghcOptObjSuffix :: Flag FilePath
ghcOptObjSuffix   = FilePath -> Flag FilePath
forall a. a -> Flag a
toFlag FilePath
"dyn_o"
        , ghcOptExtra :: [FilePath]
ghcOptExtra       = CompilerFlavor -> BuildInfo -> [FilePath]
hcSharedOptions CompilerFlavor
GHC BuildInfo
bi}
  GhcOptions
opts <- if LocalBuildInfo -> Bool
withVanillaLib LocalBuildInfo
lbi
          then GhcOptions -> IO GhcOptions
forall (m :: * -> *) a. Monad m => a -> m a
return GhcOptions
vanillaOpts
          else if LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi
          then GhcOptions -> IO GhcOptions
forall (m :: * -> *) a. Monad m => a -> m a
return GhcOptions
sharedOpts
          else Verbosity -> FilePath -> IO GhcOptions
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO GhcOptions) -> FilePath -> IO GhcOptions
forall a b. (a -> b) -> a -> b
$ FilePath
"Must have vanilla or shared libraries "
               FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"enabled in order to run doctest"
  Version
ghcVersion <- IO Version
-> (Version -> IO Version) -> Maybe Version -> IO Version
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Verbosity -> FilePath -> IO Version
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
"Compiler has no GHC version")
                      Version -> IO Version
forall (m :: * -> *) a. Monad m => a -> m a
return
                      (CompilerFlavor -> Compiler -> Maybe Version
compilerCompatVersion CompilerFlavor
GHC (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi))
  DoctestArgs -> IO DoctestArgs
forall (m :: * -> *) a. Monad m => a -> m a
return (DoctestArgs -> IO DoctestArgs) -> DoctestArgs -> IO DoctestArgs
forall a b. (a -> b) -> a -> b
$ DoctestArgs :: [FilePath] -> Flag (GhcOptions, Version) -> DoctestArgs
DoctestArgs
    { argTargets :: [FilePath]
argTargets = [FilePath]
inFiles
    , argGhcOptions :: Flag (GhcOptions, Version)
argGhcOptions = (GhcOptions, Version) -> Flag (GhcOptions, Version)
forall a. a -> Flag a
toFlag (GhcOptions
opts, Version
ghcVersion)
    }


-- -----------------------------------------------------------------------------
-- Call doctest with the specified arguments.
runDoctest :: Verbosity
           -> Compiler
           -> Platform
           -> ConfiguredProgram
           -> DoctestArgs
           -> IO ()
runDoctest :: Verbosity
-> Compiler
-> Platform
-> ConfiguredProgram
-> DoctestArgs
-> IO ()
runDoctest Verbosity
verbosity Compiler
comp Platform
platform ConfiguredProgram
doctestProg DoctestArgs
args = do
  Verbosity
-> Compiler
-> Platform
-> DoctestArgs
-> (([FilePath], [FilePath]) -> IO ())
-> IO ()
forall a.
Verbosity
-> Compiler
-> Platform
-> DoctestArgs
-> (([FilePath], [FilePath]) -> IO a)
-> IO a
renderArgs Verbosity
verbosity Compiler
comp Platform
platform DoctestArgs
args ((([FilePath], [FilePath]) -> IO ()) -> IO ())
-> (([FilePath], [FilePath]) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    \([FilePath]
flags, [FilePath]
files) -> do
      Verbosity -> ConfiguredProgram -> [FilePath] -> IO ()
runProgram Verbosity
verbosity ConfiguredProgram
doctestProg ([FilePath]
flags [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
files)

renderArgs :: Verbosity
           -> Compiler
           -> Platform
           -> DoctestArgs
           -> (([String],[FilePath]) -> IO a)
           -> IO a
renderArgs :: Verbosity
-> Compiler
-> Platform
-> DoctestArgs
-> (([FilePath], [FilePath]) -> IO a)
-> IO a
renderArgs Verbosity
_verbosity Compiler
comp Platform
platform DoctestArgs
args ([FilePath], [FilePath]) -> IO a
k = do
  ([FilePath], [FilePath]) -> IO a
k ([FilePath]
flags, DoctestArgs -> [FilePath]
argTargets DoctestArgs
args)
  where
    flags :: [String]
    flags :: [FilePath]
flags  = [[FilePath]] -> [FilePath]
forall a. Monoid a => [a] -> a
mconcat
      [ FilePath -> [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"--no-magic" -- disable doctests automagic discovery heuristics
      , FilePath -> [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"-fdiagnostics-color=never" -- disable ghc's color diagnostics.
      , [ FilePath
opt | (GhcOptions
opts, Version
_ghcVer) <- Flag (GhcOptions, Version) -> [(GhcOptions, Version)]
forall a. Flag a -> [a]
flagToList (DoctestArgs -> Flag (GhcOptions, Version)
argGhcOptions DoctestArgs
args)
              , FilePath
opt <- Compiler -> Platform -> GhcOptions -> [FilePath]
renderGhcOptions Compiler
comp Platform
platform GhcOptions
opts ]
      ]

-- ------------------------------------------------------------------------------
-- Boilerplate Monoid instance.
instance Monoid DoctestArgs where
    mempty :: DoctestArgs
mempty = DoctestArgs
forall a. (Generic a, GMonoid (Rep a)) => a
gmempty
    mappend :: DoctestArgs -> DoctestArgs -> DoctestArgs
mappend = DoctestArgs -> DoctestArgs -> DoctestArgs
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup DoctestArgs where
    <> :: DoctestArgs -> DoctestArgs -> DoctestArgs
(<>) = DoctestArgs -> DoctestArgs -> DoctestArgs
forall a. (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend