{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
#if MIN_VERSION_Cabal(3,14,0)
{-# LANGUAGE DataKinds #-}
#endif
{-# LANGUAGE MultiParamTypeClasses #-}

-- | See cabal-doctest README for full-fledged recipes & caveats.
--
-- The provided 'generateBuildModule' generates a module named @Build_doctests@.
--
-- That module exports just enough compiler flags, so that doctest could be simply
--
-- @
-- module Main where
--
-- import Build_doctests (flags, pkgs, module_sources)
-- import Test.Doctest (doctest)
--
-- main :: IO ()
-- main = doctest args
--   where
--     args = flags ++ pkgs ++ module_sources
-- @
--
-- As this module-generation is done at build-time, 'generateBuildModule' must be
-- invoked from @Setup.hs@, which also necessarily means @build-type: Custom@.
--
-- @Setup.hs@ can use libraries, but they must be declared as dependencies in the
-- @custom-setup@ stanza of the user's cabal file. To use @cabal-doctest@ then:
--
-- @
-- custom-setup
--  setup-depends:
--    base >= 4 && <5,
--    cabal-doctest >= 1 && <1.1
-- @
--
-- Finally, simple shortcuts are provided to avoid an explicit dependency on @Cabal@
-- from @setup-depends@: 'defaultMainWithDoctests' and 'defaultMainAutoconfWithDoctests'.
--
module Distribution.Extra.Doctest (
    TestSuiteName,
    defaultMainWithDoctests,
    defaultMainAutoconfWithDoctests,
    addDoctestsUserHook,
    doctestsUserHooks,
    generateBuildModule,
    ) where

import Control.Monad
       (when)
import Data.IORef
       (modifyIORef, newIORef, readIORef)
import Data.List
       (nub)
import Data.Maybe
       (mapMaybe, maybeToList)
import Data.String
       (fromString)
import Distribution.Package
       (UnitId, Package (..))
import Distribution.PackageDescription
       (BuildInfo (..), Executable (..), GenericPackageDescription,
       Library (..), PackageDescription, TestSuite (..))
import Distribution.Simple
       (UserHooks (..), autoconfUserHooks, defaultMainWithHooks,
       simpleUserHooks)
import Distribution.Simple.Compiler
       (CompilerFlavor (GHC), CompilerId (..), compilerId)
import Distribution.Simple.LocalBuildInfo
       (ComponentLocalBuildInfo (componentPackageDeps), LocalBuildInfo,
       compiler, withExeLBI, withLibLBI, withPackageDB, withTestLBI)
import Distribution.Simple.Setup
       (BuildFlags (..),
       emptyBuildFlags,
       fromFlag)
import Distribution.Simple.Utils
       (createDirectoryIfMissingVerbose, info)
import Distribution.Text
       (display)

import qualified Data.Foldable    as F
                 (for_)
import qualified Data.Traversable as T
                 (traverse)
import qualified System.FilePath ((</>))

#if MIN_VERSION_base(4,11,0)
import Data.Functor ((<&>))
#endif

#if MIN_VERSION_Cabal(1,25,0)
import Distribution.Simple.BuildPaths
       (autogenComponentModulesDir)
#else
import Distribution.Simple.BuildPaths
       (autogenModulesDir)
#endif

#if MIN_VERSION_Cabal(2,0,0)
import Distribution.Types.MungedPackageId
       (MungedPackageId)
import Distribution.Types.UnqualComponentName
       (unUnqualComponentName)

-- For amendGPD
import Distribution.PackageDescription
       (CondTree (..))
import Distribution.Types.GenericPackageDescription
       (GenericPackageDescription (condTestSuites))

import Distribution.Version
       (mkVersion)
#else
import Data.Version
       (Version (..))
import Distribution.Package
       (PackageId)
#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_Cabal(3,5,0)
import Distribution.Utils.Path
       (getSymbolicPath)
#endif

#if MIN_VERSION_Cabal(3,14,0)
-- https://github.com/haskell/cabal/issues/10559
import Distribution.Simple.Compiler
       (PackageDB, PackageDBX (GlobalPackageDB, UserPackageDB, SpecificPackageDB))
import Distribution.Simple.LocalBuildInfo
       (absoluteWorkingDirLBI, interpretSymbolicPathLBI)
import Distribution.Simple.Setup
       (HaddockFlags, haddockCommonFlags)
import Distribution.Utils.Path
       (FileOrDir(..), SymbolicPath, interpretSymbolicPathAbsolute, makeRelativePathEx, makeSymbolicPath)
import qualified Distribution.Utils.Path as SymPath ((</>))
#else
import Distribution.Simple.Compiler
       (PackageDB (GlobalPackageDB, UserPackageDB, SpecificPackageDB))
import Distribution.Simple.Setup
       (HaddockFlags (haddockDistPref, haddockVerbosity))
#endif

#if MIN_VERSION_directory(1,2,2)
import System.Directory
       (makeAbsolute)
#else
import System.Directory
       (getCurrentDirectory)
import System.FilePath
       (isAbsolute)
#endif

{- HLINT ignore "Use fewer imports" -}

-------------------------------------------------------------------------------
-- Compat
-------------------------------------------------------------------------------

#if !MIN_VERSION_base(4,11,0)
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip fmap
infixl 1 <&>
#endif

class CompatSymPath p q where
  (</>) :: p -> FilePath -> q
infixr 5 </>
instance CompatSymPath FilePath FilePath where
  </> :: [Char] -> [Char] -> [Char]
(</>) = [Char] -> [Char] -> [Char]
(System.FilePath.</>)
#if MIN_VERSION_Cabal(3,14,0)
instance CompatSymPath (SymbolicPath allowAbs ('Dir loc1))
                       (SymbolicPath allowAbs ('Dir loc2)) where
  SymbolicPath allowAbs ('Dir loc1)
dir </> :: SymbolicPath allowAbs ('Dir loc1)
-> [Char] -> SymbolicPath allowAbs ('Dir loc2)
</> [Char]
name = SymbolicPath allowAbs ('Dir loc1)
dir SymbolicPath allowAbs ('Dir loc1)
-> SymbolicPathX 'OnlyRelative loc1 ('Dir loc2)
-> SymbolicPath allowAbs ('Dir loc2)
forall p q r. PathLike p q r => p -> q -> r
SymPath.</> [Char] -> SymbolicPathX 'OnlyRelative loc1 ('Dir loc2)
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
name
#endif

#if MIN_VERSION_Cabal(3,14,0)
unsymbolizePath :: SymbolicPathX allowAbsolute from to -> [Char]
unsymbolizePath = SymbolicPathX allowAbsolute from to -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath
#else
makeSymbolicPath :: FilePath -> FilePath
makeSymbolicPath = id
unsymbolizePath :: FilePath -> FilePath
unsymbolizePath = id
#endif


#if !MIN_VERSION_directory(1,2,2)
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

#if !MIN_VERSION_Cabal(2,0,0)
mkVersion :: [Int] -> Version
mkVersion ds = Version ds []
#endif

-------------------------------------------------------------------------------
-- Mains
-------------------------------------------------------------------------------

-- | This type is a 'String' which identifies a test-suite in your cabal-file;
-- the one you'll be running doctest from.
type TestSuiteName = String

-- | A default @Setup.hs@ main with doctests:
--
-- @
-- import Distribution.Extra.Doctest
--        (defaultMainWithDoctests)
--
-- main :: IO ()
-- main = defaultMainWithDoctests "doctests"
-- @
--
-- The argument @"doctests"@ identifies a test-suite in your cabal-file; the
-- one you'll run doctest from. If you have @test-suite my-test@, you should
-- invoke @defaultMainWithDoctests "my-test"@ in Setup.hs.
--
-- This argument does not change the generated module name imported from the
-- test-driver's @Main@ -- that one always remains @import Build_doctests@.
defaultMainWithDoctests
    :: TestSuiteName
    -> IO ()
defaultMainWithDoctests :: [Char] -> IO ()
defaultMainWithDoctests = UserHooks -> IO ()
defaultMainWithHooks (UserHooks -> IO ()) -> ([Char] -> UserHooks) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> UserHooks
doctestsUserHooks

-- | Like 'defaultMainWithDoctests', but for packages with @build-type: Configure@.
--
-- @since 1.0.2
defaultMainAutoconfWithDoctests
    :: TestSuiteName
    -> IO ()
defaultMainAutoconfWithDoctests :: [Char] -> IO ()
defaultMainAutoconfWithDoctests [Char]
n =
    UserHooks -> IO ()
defaultMainWithHooks ([Char] -> UserHooks -> UserHooks
addDoctestsUserHook [Char]
n UserHooks
autoconfUserHooks)

-- | 'simpleUserHooks' with 'generateBuildModule' already wired-in.
doctestsUserHooks
    :: TestSuiteName
    -> UserHooks
doctestsUserHooks :: [Char] -> UserHooks
doctestsUserHooks [Char]
testsuiteName =
    [Char] -> UserHooks -> UserHooks
addDoctestsUserHook [Char]
testsuiteName UserHooks
simpleUserHooks

-- | Compose 'generateBuildModule' into Cabal's 'UserHooks' (prepending the action).
--
-- This is exported for advanced custom Setup-s.
--
-- @since 1.0.2
addDoctestsUserHook :: TestSuiteName -> UserHooks -> UserHooks
addDoctestsUserHook :: [Char] -> UserHooks -> UserHooks
addDoctestsUserHook [Char]
testsuiteName UserHooks
uh = UserHooks
uh
    { buildHook = \PackageDescription
pkg LocalBuildInfo
lbi UserHooks
hooks BuildFlags
flags -> do
        [Char]
-> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
generateBuildModule [Char]
testsuiteName BuildFlags
flags PackageDescription
pkg LocalBuildInfo
lbi
        UserHooks
-> PackageDescription
-> LocalBuildInfo
-> UserHooks
-> BuildFlags
-> IO ()
buildHook UserHooks
uh PackageDescription
pkg LocalBuildInfo
lbi UserHooks
hooks BuildFlags
flags
    -- We use confHook to add "Build_doctests" to otherModules and autogenModules.
    --
    -- We cannot use HookedBuildInfo as it lets alter only the library and executables.
    , confHook = \(GenericPackageDescription
gpd, HookedBuildInfo
hbi) ConfigFlags
flags ->
        UserHooks
-> (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags
-> IO LocalBuildInfo
confHook UserHooks
uh ([Char] -> GenericPackageDescription -> GenericPackageDescription
amendGPD [Char]
testsuiteName GenericPackageDescription
gpd, HookedBuildInfo
hbi) ConfigFlags
flags
    , haddockHook = \PackageDescription
pkg LocalBuildInfo
lbi UserHooks
hooks HaddockFlags
flags -> do
        [Char]
-> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
generateBuildModule [Char]
testsuiteName (HaddockFlags -> BuildFlags
haddockToBuildFlags HaddockFlags
flags) PackageDescription
pkg LocalBuildInfo
lbi
        UserHooks
-> PackageDescription
-> LocalBuildInfo
-> UserHooks
-> HaddockFlags
-> IO ()
haddockHook UserHooks
uh PackageDescription
pkg LocalBuildInfo
lbi UserHooks
hooks HaddockFlags
flags
    }

-- | Convert only flags used by 'generateBuildModule'.
haddockToBuildFlags :: HaddockFlags -> BuildFlags
haddockToBuildFlags :: HaddockFlags -> BuildFlags
haddockToBuildFlags HaddockFlags
f =
#if MIN_VERSION_Cabal(3,14,0)
  BuildFlags
emptyBuildFlags
    { buildCommonFlags = haddockCommonFlags f }
#else
   emptyBuildFlags
    { buildVerbosity = haddockVerbosity f
    , buildDistPref  = haddockDistPref f
    }
#endif

data Name = NameLib (Maybe String) | NameExe String deriving (Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
/= :: Name -> Name -> Bool
Eq, Int -> Name -> [Char] -> [Char]
[Name] -> [Char] -> [Char]
Name -> [Char]
(Int -> Name -> [Char] -> [Char])
-> (Name -> [Char]) -> ([Name] -> [Char] -> [Char]) -> Show Name
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Name -> [Char] -> [Char]
showsPrec :: Int -> Name -> [Char] -> [Char]
$cshow :: Name -> [Char]
show :: Name -> [Char]
$cshowList :: [Name] -> [Char] -> [Char]
showList :: [Name] -> [Char] -> [Char]
Show)

nameToString :: Name -> String
nameToString :: Name -> [Char]
nameToString Name
n = case Name
n of
  NameLib Maybe [Char]
x -> [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (([Char]
"_lib_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
fixchar) Maybe [Char]
x
  NameExe [Char]
x -> [Char]
"_exe_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
fixchar [Char]
x
  where
    -- Taken from Cabal:
    -- https://github.com/haskell/cabal/blob/20de0bfea72145ba1c37e3f500cee5258cc18e51/Cabal/Distribution/Simple/Build/Macros.hs#L156-L158
    --
    -- Needed to fix component names with hyphens in them, as hyphens aren't
    -- allowed in Haskell identifier names.
    fixchar :: Char -> Char
    fixchar :: Char -> Char
fixchar Char
'-' = Char
'_'
    fixchar Char
c   = Char
c

data Component = Component Name [String] [String] [String]
  deriving Int -> Component -> [Char] -> [Char]
[Component] -> [Char] -> [Char]
Component -> [Char]
(Int -> Component -> [Char] -> [Char])
-> (Component -> [Char])
-> ([Component] -> [Char] -> [Char])
-> Show Component
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Component -> [Char] -> [Char]
showsPrec :: Int -> Component -> [Char] -> [Char]
$cshow :: Component -> [Char]
show :: Component -> [Char]
$cshowList :: [Component] -> [Char] -> [Char]
showList :: [Component] -> [Char] -> [Char]
Show

-- | Generate a build module for the test suite.
--
-- @
-- import Distribution.Simple
--        (defaultMainWithHooks, UserHooks(..), simpleUserHooks)
-- import Distribution.Extra.Doctest
--        (generateBuildModule)
--
-- main :: IO ()
-- main = defaultMainWithHooks simpleUserHooks
--     { buildHook = \pkg lbi hooks flags -> do
--         generateBuildModule "doctests" flags pkg lbi
--         buildHook simpleUserHooks pkg lbi hooks flags
--     }
-- @
generateBuildModule
    :: TestSuiteName
    -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
generateBuildModule :: [Char]
-> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
generateBuildModule [Char]
testSuiteName BuildFlags
flags PackageDescription
pkg LocalBuildInfo
lbi = do
  let verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (BuildFlags -> Flag Verbosity
buildVerbosity BuildFlags
flags)
  let distPref :: SymbolicPath Pkg ('Dir Dist)
distPref = Flag (SymbolicPath Pkg ('Dir Dist)) -> SymbolicPath Pkg ('Dir Dist)
forall a. WithCallStack (Flag a -> a)
fromFlag (BuildFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
buildDistPref BuildFlags
flags)

  -- Package DBs & environments
  let dbStack :: [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbStack = LocalBuildInfo -> [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
withPackageDB LocalBuildInfo
lbi [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
-> [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
-> [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
forall a. [a] -> [a] -> [a]
++ [ SymbolicPath Pkg ('Dir PkgDB)
-> PackageDBX (SymbolicPath Pkg ('Dir PkgDB))
forall fp. fp -> PackageDBX fp
SpecificPackageDB (SymbolicPath Pkg ('Dir PkgDB)
 -> PackageDBX (SymbolicPath Pkg ('Dir PkgDB)))
-> SymbolicPath Pkg ('Dir PkgDB)
-> PackageDBX (SymbolicPath Pkg ('Dir PkgDB))
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Dist)
distPref SymbolicPath Pkg ('Dir Dist)
-> [Char] -> SymbolicPath Pkg ('Dir PkgDB)
forall p q. CompatSymPath p q => p -> [Char] -> q
</> [Char]
"package.conf.inplace" ]
  let dbFlags :: [[Char]]
dbFlags = [Char]
"-hide-all-packages" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> [[Char]]
packageDbArgs [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbStack
  let envFlags :: [[Char]]
envFlags
        | Bool
ghcCanBeToldToIgnorePkgEnvs = [ [Char]
"-package-env=-" ]
        | Bool
otherwise = []

  PackageDescription
-> LocalBuildInfo
-> (TestSuite -> ComponentLocalBuildInfo -> IO ())
-> IO ()
withTestLBI PackageDescription
pkg LocalBuildInfo
lbi ((TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO ())
-> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TestSuite
suite ComponentLocalBuildInfo
suitecfg -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestSuite -> UnqualComponentName
testName TestSuite
suite UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> UnqualComponentName
forall a. IsString a => [Char] -> a
fromString [Char]
testSuiteName) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do

    -- Locate autogen dir, to put our output into.
#if MIN_VERSION_Cabal(3,14,0)
    let testAutogenDir :: [Char]
testAutogenDir = LocalBuildInfo
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Source) -> [Char]
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> [Char]
interpretSymbolicPathLBI LocalBuildInfo
lbi
                       (SymbolicPathX 'AllowAbsolute Pkg ('Dir Source) -> [Char])
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Source) -> [Char]
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)
autogenComponentModulesDir LocalBuildInfo
lbi ComponentLocalBuildInfo
suitecfg
#elif MIN_VERSION_Cabal(1,25,0)
    let testAutogenDir = autogenComponentModulesDir lbi suitecfg
#else
    let testAutogenDir = autogenModulesDir lbi
#endif
    Verbosity -> Bool -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True [Char]
testAutogenDir

    let buildDoctestsFile :: [Char]
buildDoctestsFile = [Char]
testAutogenDir [Char] -> [Char] -> [Char]
forall p q. CompatSymPath p q => p -> [Char] -> q
</> [Char]
"Build_doctests.hs"

    -- First, we create the autogen'd module Build_doctests.
    -- Initially populate Build_doctests with a simple preamble.
    Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"cabal-doctest: writing Build_doctests to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
buildDoctestsFile
    [Char] -> [Char] -> IO ()
writeFile [Char]
buildDoctestsFile ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
      [ [Char]
"module Build_doctests where"
      , [Char]
""
      , [Char]
"import Prelude"
      , [Char]
""
      , [Char]
"data Name = NameLib (Maybe String) | NameExe String deriving (Eq, Show)"
      , [Char]
"data Component = Component Name [String] [String] [String] deriving (Eq, Show)"
      , [Char]
""
      ]

    -- we cannot traverse, only traverse_
    -- so we use IORef to collect components
    componentsRef <- [Component] -> IO (IORef [Component])
forall a. a -> IO (IORef a)
newIORef []

    let testBI = TestSuite -> BuildInfo
testBuildInfo TestSuite
suite

    -- TODO: `words` is not proper parser (no support for quotes)
    let additionalFlags = [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Char] -> [[Char]]
words
          (Maybe [Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"x-doctest-options"
          ([([Char], [Char])] -> Maybe [Char])
-> [([Char], [Char])] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [([Char], [Char])]
customFieldsBI BuildInfo
testBI

    let additionalModules = [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Char] -> [[Char]]
words
          (Maybe [Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"x-doctest-modules"
          ([([Char], [Char])] -> Maybe [Char])
-> [([Char], [Char])] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [([Char], [Char])]
customFieldsBI BuildInfo
testBI

    let additionalDirs' = [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Char] -> [[Char]]
words
          (Maybe [Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"x-doctest-source-dirs"
          ([([Char], [Char])] -> Maybe [Char])
-> [([Char], [Char])] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [([Char], [Char])]
customFieldsBI BuildInfo
testBI

    additionalDirs <- mapM (fmap ("-i" ++) . makeAbsolute) additionalDirs'

    -- Next, for each component (library or executable), we get to Build_doctests
    -- the sets of flags needed to run doctest on that component.
    let getBuildDoctests PackageDescription
-> LocalBuildInfo -> (t -> ComponentLocalBuildInfo -> IO ()) -> b
withCompLBI t -> Name
mbCompName t -> [ModuleName]
compExposedModules t -> Maybe (SymbolicPathX 'OnlyRelative Source 'File)
compMainIs t -> BuildInfo
compBuildInfo =
         PackageDescription
-> LocalBuildInfo -> (t -> ComponentLocalBuildInfo -> IO ()) -> b
withCompLBI PackageDescription
pkg LocalBuildInfo
lbi ((t -> ComponentLocalBuildInfo -> IO ()) -> b)
-> (t -> ComponentLocalBuildInfo -> IO ()) -> b
forall a b. (a -> b) -> a -> b
$ \t
comp ComponentLocalBuildInfo
compCfg -> do
           let compBI :: BuildInfo
compBI = t -> BuildInfo
compBuildInfo t
comp

           -- modules
           let modules :: [ModuleName]
modules = t -> [ModuleName]
compExposedModules t
comp [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [ModuleName]
otherModules BuildInfo
compBI
           -- it seems that doctest is happy to take in module names, not actual files!
           let module_sources :: [ModuleName]
module_sources = [ModuleName]
modules

           -- We need the directory with the component's cabal_macros.h!
#if MIN_VERSION_Cabal(3,14,0)
           let compAutogenDir :: [Char]
compAutogenDir = LocalBuildInfo
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Source) -> [Char]
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> [Char]
interpretSymbolicPathLBI LocalBuildInfo
lbi
                              (SymbolicPathX 'AllowAbsolute Pkg ('Dir Source) -> [Char])
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Source) -> [Char]
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)
autogenComponentModulesDir LocalBuildInfo
lbi ComponentLocalBuildInfo
compCfg
#elif MIN_VERSION_Cabal(1,25,0)
           let compAutogenDir = autogenComponentModulesDir lbi compCfg
#else
           let compAutogenDir = autogenModulesDir lbi
#endif

           -- Lib sources and includes
           let iArgsSymbolic :: [SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)]
iArgsSymbolic =
                  [Char] -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)
forall from (to :: FileOrDir). [Char] -> SymbolicPath from to
makeSymbolicPath [Char]
compAutogenDir -- autogen dir
                -- preprocessed files (.hsc -> .hs); "build" is hardcoded in Cabal.
                SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)
-> [SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)]
-> [SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)]
forall a. a -> [a] -> [a]
: (SymbolicPath Pkg ('Dir Dist)
distPref SymbolicPath Pkg ('Dir Dist)
-> [Char] -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)
forall p q. CompatSymPath p q => p -> [Char] -> q
</> [Char]
"build")
#if MIN_VERSION_Cabal(3,14,0)
                SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)
-> [SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)]
-> [SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)]
forall a. a -> [a] -> [a]
: BuildInfo -> [SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)]
hsSourceDirs BuildInfo
compBI
#elif MIN_VERSION_Cabal(3,5,0)
                : (hsSourceDirs compBI <&> getSymbolicPath)
#else
                : hsSourceDirs compBI
#endif
#if MIN_VERSION_Cabal(3,14,0)
           pkgWorkdir <- LocalBuildInfo -> IO (AbsolutePath ('Dir Pkg))
absoluteWorkingDirLBI LocalBuildInfo
lbi
           let iArgsNoPrefix = [SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)]
iArgsSymbolic [SymbolicPathX 'AllowAbsolute Pkg ('Dir Source)]
-> (SymbolicPathX 'AllowAbsolute Pkg ('Dir Source) -> [Char])
-> [[Char]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> AbsolutePath ('Dir Pkg)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Source) -> [Char]
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
AbsolutePath ('Dir Pkg)
-> SymbolicPathX allowAbsolute Pkg to -> [Char]
interpretSymbolicPathAbsolute AbsolutePath ('Dir Pkg)
pkgWorkdir
           let includeArgs = BuildInfo -> [SymbolicPath Pkg ('Dir Include)]
includeDirs BuildInfo
compBI [SymbolicPath Pkg ('Dir Include)]
-> (SymbolicPath Pkg ('Dir Include) -> [Char]) -> [[Char]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([Char]
"-I"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char])
-> (SymbolicPath Pkg ('Dir Include) -> [Char])
-> SymbolicPath Pkg ('Dir Include)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath ('Dir Pkg)
-> SymbolicPath Pkg ('Dir Include) -> [Char]
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
AbsolutePath ('Dir Pkg)
-> SymbolicPathX allowAbsolute Pkg to -> [Char]
interpretSymbolicPathAbsolute AbsolutePath ('Dir Pkg)
pkgWorkdir
#else
           iArgsNoPrefix <- mapM makeAbsolute iArgsSymbolic
           includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs compBI
#endif
           -- We clear all includes, so the CWD isn't used.
           let iArgs' = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"-i"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) [[Char]]
iArgsNoPrefix
               iArgs  = [Char]
"-i" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
iArgs'

           -- default-extensions
           let extensionArgs = (Extension -> [Char]) -> [Extension] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char]
"-X"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (Extension -> [Char]) -> Extension -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Extension -> [Char]
forall a. Pretty a => a -> [Char]
display) ([Extension] -> [[Char]]) -> [Extension] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [Extension]
defaultExtensions BuildInfo
compBI

           -- CPP includes, i.e. include cabal_macros.h
           let cppFlags = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"-optP"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
                   [ [Char]
"-include", [Char]
compAutogenDir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/cabal_macros.h" ]
                   [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [[Char]]
cppOptions BuildInfo
compBI

           -- Unlike other modules, the main-is module of an executable is not
           -- guaranteed to share a module name with its filepath name. That is,
           -- even though the main-is module is named Main, its filepath might
           -- actually be Something.hs. To account for this possibility, we simply
           -- pass the full path to the main-is module instead.
           mainIsPath <- T.traverse (findFileEx verbosity iArgsSymbolic) (compMainIs comp)

           let all_sources = (ModuleName -> [Char]) -> [ModuleName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> [Char]
forall a. Pretty a => a -> [Char]
display [ModuleName]
module_sources
                             [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
additionalModules
                             [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ Maybe [Char] -> [[Char]]
forall a. Maybe a -> [a]
maybeToList (Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File)
mainIsPath Maybe (SymbolicPathX 'AllowAbsolute Pkg 'File)
-> (SymbolicPathX 'AllowAbsolute Pkg 'File -> [Char])
-> Maybe [Char]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> SymbolicPathX 'AllowAbsolute Pkg 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
unsymbolizePath)

           let component = Name -> [[Char]] -> [[Char]] -> [[Char]] -> Component
Component
                (t -> Name
mbCompName t
comp)
                ([(UnitId, MungedPackageId)] -> [[Char]]
formatDeps ([(UnitId, MungedPackageId)] -> [[Char]])
-> [(UnitId, MungedPackageId)] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ComponentLocalBuildInfo
-> ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
testDeps ComponentLocalBuildInfo
compCfg ComponentLocalBuildInfo
suitecfg)
                ([[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                  [ [[Char]]
iArgs
                  , [[Char]]
additionalDirs
                  , [[Char]]
includeArgs
                  , [[Char]]
envFlags
                  , [[Char]]
dbFlags
                  , [[Char]]
cppFlags
                  , [[Char]]
extensionArgs
                  , [[Char]]
additionalFlags
                  ])
                [[Char]]
all_sources

           -- modify IORef, append component
           modifyIORef componentsRef (\[Component]
cs -> [Component]
cs [Component] -> [Component] -> [Component]
forall a. [a] -> [a] -> [a]
++ [Component
component])

    -- For now, we only check for doctests in libraries and executables.
    getBuildDoctests withLibLBI mbLibraryName           exposedModules (const Nothing)     libBuildInfo
    getBuildDoctests withExeLBI (NameExe . executableName) (const [])     (Just . modulePath) buildInfo

    components <- readIORef componentsRef
    F.for_ components $ \(Component Name
cmpName [[Char]]
cmpPkgs [[Char]]
cmpFlags [[Char]]
cmpSources) -> do
       let compSuffix :: [Char]
compSuffix          = Name -> [Char]
nameToString Name
cmpName
           pkgs_comp :: [Char]
pkgs_comp           = [Char]
"pkgs"           [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
compSuffix
           flags_comp :: [Char]
flags_comp          = [Char]
"flags"          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
compSuffix
           module_sources_comp :: [Char]
module_sources_comp = [Char]
"module_sources" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
compSuffix

       -- write autogen'd file
       [Char] -> [Char] -> IO ()
appendFile [Char]
buildDoctestsFile ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
         [ -- -package-id etc. flags
           [Char]
pkgs_comp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" :: [String]"
         , [Char]
pkgs_comp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
cmpPkgs
         , [Char]
""
         , [Char]
flags_comp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" :: [String]"
         , [Char]
flags_comp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
cmpFlags
         , [Char]
""
         , [Char]
module_sources_comp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" :: [String]"
         , [Char]
module_sources_comp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
cmpSources
         , [Char]
""
         ]

    -- write enabled components, i.e. x-doctest-components
    -- if none enabled, pick library
    let enabledComponents = [Name] -> ([Char] -> [Name]) -> Maybe [Char] -> [Name]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Maybe [Char] -> Name
NameLib Maybe [Char]
forall a. Maybe a
Nothing] (([Char] -> Maybe Name) -> [[Char]] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Char] -> Maybe Name
parseComponentName ([[Char]] -> [Name]) -> ([Char] -> [[Char]]) -> [Char] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
words)
           (Maybe [Char] -> [Name]) -> Maybe [Char] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"x-doctest-components"
           ([([Char], [Char])] -> Maybe [Char])
-> [([Char], [Char])] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [([Char], [Char])]
customFieldsBI BuildInfo
testBI

    let components' =
         (Component -> Bool) -> [Component] -> [Component]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Component Name
n [[Char]]
_ [[Char]]
_ [[Char]]
_) -> Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
enabledComponents) [Component]
components
    appendFile buildDoctestsFile $ unlines
      [ "-- " ++ show enabledComponents
      , "components :: [Component]"
      , "components = " ++ show components'
      ]

  where
    parseComponentName :: String -> Maybe Name
    parseComponentName :: [Char] -> Maybe Name
parseComponentName [Char]
"lib"                       = Name -> Maybe Name
forall a. a -> Maybe a
Just (Maybe [Char] -> Name
NameLib Maybe [Char]
forall a. Maybe a
Nothing)
    parseComponentName (Char
'l' : Char
'i' : Char
'b' : Char
':' : [Char]
x) = Name -> Maybe Name
forall a. a -> Maybe a
Just (Maybe [Char] -> Name
NameLib ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
x))
    parseComponentName (Char
'e' : Char
'x' : Char
'e' : Char
':' : [Char]
x) = Name -> Maybe Name
forall a. a -> Maybe a
Just ([Char] -> Name
NameExe [Char]
x)
    parseComponentName [Char]
_ = Maybe Name
forall a. Maybe a
Nothing

    -- we do this check in Setup, as then doctests don't need to depend on Cabal
    isNewCompiler :: Bool
isNewCompiler = case Compiler -> CompilerId
compilerId (Compiler -> CompilerId) -> Compiler -> CompilerId
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi of
      CompilerId CompilerFlavor
GHC Version
v -> Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
7,Int
6]
      CompilerId
_                -> Bool
False

    ghcCanBeToldToIgnorePkgEnvs :: Bool
    ghcCanBeToldToIgnorePkgEnvs :: Bool
ghcCanBeToldToIgnorePkgEnvs = case Compiler -> CompilerId
compilerId (Compiler -> CompilerId) -> Compiler -> CompilerId
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi of
      CompilerId CompilerFlavor
GHC Version
v -> Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8,Int
4,Int
4]
      CompilerId
_                -> Bool
False

    formatDeps :: [(UnitId, MungedPackageId)] -> [[Char]]
formatDeps = ((UnitId, MungedPackageId) -> [Char])
-> [(UnitId, MungedPackageId)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, MungedPackageId) -> [Char]
forall {a} {a}. (Pretty a, Pretty a) => (a, a) -> [Char]
formatOne
    formatOne :: (a, a) -> [Char]
formatOne (a
installedPkgId, a
pkgId)
      -- The problem is how different cabal executables handle package databases
      -- when doctests depend on the library
      --
      -- If the pkgId is current package, we don't output the full package-id
      -- but only the name
      --
      -- Because of MungedPackageId we compare display version of identifiers
      -- not the identifiers themfselves.
      | PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
display (PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== a -> [Char]
forall a. Pretty a => a -> [Char]
display a
pkgId = [Char]
"-package=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Pretty a => a -> [Char]
display a
pkgId
      | Bool
otherwise              = [Char]
"-package-id=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Pretty a => a -> [Char]
display a
installedPkgId

    -- From Distribution.Simple.Program.GHC
    packageDbArgs :: [PackageDB] -> [String]
    packageDbArgs :: [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> [[Char]]
packageDbArgs | Bool
isNewCompiler = [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> [[Char]]
packageDbArgsDb
                  | Bool
otherwise     = [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> [[Char]]
packageDbArgsConf

    -- GHC <7.6 uses '-package-conf' instead of '-package-db'.
    packageDbArgsConf :: [PackageDB] -> [String]
    packageDbArgsConf :: [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> [[Char]]
packageDbArgsConf [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbstack = case [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbstack of
      (PackageDBX (SymbolicPath Pkg ('Dir PkgDB))
GlobalPackageDB:PackageDBX (SymbolicPath Pkg ('Dir PkgDB))
UserPackageDB:[PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbs) -> (PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> [[Char]])
-> [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> [[Char]]
forall {allowAbsolute :: AllowAbsolute} {from} {to :: FileOrDir}.
PackageDBX (SymbolicPathX allowAbsolute from to) -> [[Char]]
specific [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbs
      (PackageDBX (SymbolicPath Pkg ('Dir PkgDB))
GlobalPackageDB:[PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbs)               -> [Char]
"-no-user-package-conf"
                                           [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> [[Char]])
-> [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> [[Char]]
forall {allowAbsolute :: AllowAbsolute} {from} {to :: FileOrDir}.
PackageDBX (SymbolicPathX allowAbsolute from to) -> [[Char]]
specific [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbs
      [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
_ -> [[Char]]
forall {b}. b
ierror
      where
        specific :: PackageDBX (SymbolicPathX allowAbsolute from to) -> [[Char]]
specific (SpecificPackageDB SymbolicPathX allowAbsolute from to
db) = [ [Char]
"-package-conf=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SymbolicPathX allowAbsolute from to -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
unsymbolizePath SymbolicPathX allowAbsolute from to
db ]
        specific PackageDBX (SymbolicPathX allowAbsolute from to)
_                      = [[Char]]
forall {b}. b
ierror
        ierror :: b
ierror = [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
forall a b. (a -> b) -> a -> b
$ [Char]
"internal error: unexpected package db stack: "
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> [Char]
forall a. Show a => a -> [Char]
show [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbstack

    -- GHC >= 7.6 uses the '-package-db' flag. See
    -- https://ghc.haskell.org/trac/ghc/ticket/5977.
    packageDbArgsDb :: [PackageDB] -> [String]
    -- special cases to make arguments prettier in common scenarios
    packageDbArgsDb :: [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> [[Char]]
packageDbArgsDb [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbstack = case [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbstack of
      (PackageDBX (SymbolicPath Pkg ('Dir PkgDB))
GlobalPackageDB:PackageDBX (SymbolicPath Pkg ('Dir PkgDB))
UserPackageDB:[PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbs)
        | (PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> Bool)
-> [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> Bool
forall {fp}. PackageDBX fp -> Bool
isSpecific [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbs              -> (PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> [[Char]])
-> [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> [[Char]]
forall {allowAbsolute :: AllowAbsolute} {from} {to :: FileOrDir}.
PackageDBX (SymbolicPathX allowAbsolute from to) -> [[Char]]
single [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbs
      (PackageDBX (SymbolicPath Pkg ('Dir PkgDB))
GlobalPackageDB:[PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbs)
        | (PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> Bool)
-> [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> Bool
forall {fp}. PackageDBX fp -> Bool
isSpecific [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbs              -> [Char]
"-no-user-package-db"
                                           [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> [[Char]])
-> [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> [[Char]]
forall {allowAbsolute :: AllowAbsolute} {from} {to :: FileOrDir}.
PackageDBX (SymbolicPathX allowAbsolute from to) -> [[Char]]
single [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbs
      [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbs                                 -> [Char]
"-clear-package-db"
                                           [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> [[Char]])
-> [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PackageDBX (SymbolicPath Pkg ('Dir PkgDB)) -> [[Char]]
forall {allowAbsolute :: AllowAbsolute} {from} {to :: FileOrDir}.
PackageDBX (SymbolicPathX allowAbsolute from to) -> [[Char]]
single [PackageDBX (SymbolicPath Pkg ('Dir PkgDB))]
dbs
     where
       single :: PackageDBX (SymbolicPathX allowAbsolute from to) -> [[Char]]
single (SpecificPackageDB SymbolicPathX allowAbsolute from to
db) = [ [Char]
"-package-db=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SymbolicPathX allowAbsolute from to -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
unsymbolizePath SymbolicPathX allowAbsolute from to
db ]
       single PackageDBX (SymbolicPathX allowAbsolute from to)
GlobalPackageDB        = [ [Char]
"-global-package-db" ]
       single PackageDBX (SymbolicPathX allowAbsolute from to)
UserPackageDB          = [ [Char]
"-user-package-db" ]
       isSpecific :: PackageDBX fp -> Bool
isSpecific (SpecificPackageDB fp
_) = Bool
True
       isSpecific PackageDBX fp
_                     = Bool
False

    mbLibraryName :: Library -> Name
#if MIN_VERSION_Cabal(3,0,0)
    mbLibraryName :: Library -> Name
mbLibraryName = Maybe [Char] -> Name
NameLib (Maybe [Char] -> Name)
-> (Library -> Maybe [Char]) -> Library -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName -> [Char])
-> Maybe UnqualComponentName -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnqualComponentName -> [Char]
unUnqualComponentName (Maybe UnqualComponentName -> Maybe [Char])
-> (Library -> Maybe UnqualComponentName)
-> Library
-> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LibraryName -> Maybe UnqualComponentName
libraryNameString (LibraryName -> Maybe UnqualComponentName)
-> (Library -> LibraryName) -> Library -> Maybe UnqualComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> LibraryName
libName
#elif MIN_VERSION_Cabal(2,0,0)
    -- Cabal-2.0 introduced internal libraries, which are named.
    mbLibraryName = NameLib . fmap unUnqualComponentName . libName
#else
    -- Before that, there was only ever at most one library per
    -- .cabal file, which has no name.
    mbLibraryName _ = NameLib Nothing
#endif

    executableName :: Executable -> String
#if MIN_VERSION_Cabal(2,0,0)
    executableName :: Executable -> [Char]
executableName = UnqualComponentName -> [Char]
unUnqualComponentName (UnqualComponentName -> [Char])
-> (Executable -> UnqualComponentName) -> Executable -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Executable -> UnqualComponentName
exeName
#else
    executableName = exeName
#endif

-- | In compat settings it's better to omit the type-signature
testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo
#if MIN_VERSION_Cabal(2,0,0)
         -> [(UnitId, MungedPackageId)]
#else
         -> [(UnitId, PackageId)]
#endif
testDeps :: ComponentLocalBuildInfo
-> ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
testDeps ComponentLocalBuildInfo
xs ComponentLocalBuildInfo
ys = [(UnitId, MungedPackageId)] -> [(UnitId, MungedPackageId)]
forall a. Eq a => [a] -> [a]
nub ([(UnitId, MungedPackageId)] -> [(UnitId, MungedPackageId)])
-> [(UnitId, MungedPackageId)] -> [(UnitId, MungedPackageId)]
forall a b. (a -> b) -> a -> b
$ ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
componentPackageDeps ComponentLocalBuildInfo
xs [(UnitId, MungedPackageId)]
-> [(UnitId, MungedPackageId)] -> [(UnitId, MungedPackageId)]
forall a. [a] -> [a] -> [a]
++ ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
componentPackageDeps ComponentLocalBuildInfo
ys

amendGPD
    :: TestSuiteName
    -> GenericPackageDescription
    -> GenericPackageDescription
#if !(MIN_VERSION_Cabal(2,0,0))
amendGPD _ gpd = gpd
#else
amendGPD :: [Char] -> GenericPackageDescription -> GenericPackageDescription
amendGPD [Char]
testSuiteName GenericPackageDescription
gpd = GenericPackageDescription
gpd
    { condTestSuites = map f (condTestSuites gpd)
    }
  where
    f :: (a, CondTree v c TestSuite) -> (a, CondTree v c TestSuite)
f (a
name, CondTree v c TestSuite
condTree)
        | a
name a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> a
forall a. IsString a => [Char] -> a
fromString [Char]
testSuiteName = (a
name, CondTree v c TestSuite
condTree')
        | Bool
otherwise                        = (a
name, CondTree v c TestSuite
condTree)
      where
        -- I miss 'lens'
        testSuite :: TestSuite
testSuite = CondTree v c TestSuite -> TestSuite
forall v c a. CondTree v c a -> a
condTreeData CondTree v c TestSuite
condTree
        bi :: BuildInfo
bi = TestSuite -> BuildInfo
testBuildInfo TestSuite
testSuite
        om :: [ModuleName]
om = BuildInfo -> [ModuleName]
otherModules BuildInfo
bi
        am :: [ModuleName]
am = BuildInfo -> [ModuleName]
autogenModules BuildInfo
bi

        -- Cons the module to both other-modules and autogen-modules.
        -- At the moment, cabal-spec-2.0 and cabal-spec-2.2 don't have
        -- "all autogen-modules are other-modules if they aren't exposed-modules"
        -- rule. Hopefully cabal-spec-3.0 will have.
        --
        -- Note: we `nub`, because it's unclear if that's ok to have duplicate
        -- modules in the lists.
        om' :: [ModuleName]
om' = [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ModuleName
mn ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [ModuleName]
om
        am' :: [ModuleName]
am' = [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ModuleName
mn ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [ModuleName]
am

        mn :: ModuleName
mn = [Char] -> ModuleName
forall a. IsString a => [Char] -> a
fromString [Char]
"Build_doctests"

        bi' :: BuildInfo
bi' = BuildInfo
bi { otherModules = om', autogenModules = am' }
        testSuite' :: TestSuite
testSuite' = TestSuite
testSuite { testBuildInfo = bi' }
        condTree' :: CondTree v c TestSuite
condTree' = CondTree v c TestSuite
condTree { condTreeData = testSuite' }
#endif