{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module Test.DocTest.Helpers where

import GHC.Stack (HasCallStack)

import System.Directory
  ( canonicalizePath, doesFileExist )
import System.FilePath ((</>), isDrive, takeDirectory)
import System.FilePath.Glob (glob)
import System.Info (compilerVersion)

#if __GLASGOW_HASKELL__ < 804
import Data.Monoid ((<>))
#endif

import qualified Data.Set as Set

-- Cabal
import Distribution.ModuleName (ModuleName)
import Distribution.Simple
  ( Extension (DisableExtension, EnableExtension, UnknownExtension) )
import Distribution.Types.UnqualComponentName ( unUnqualComponentName )
import Distribution.PackageDescription
  ( GenericPackageDescription (condLibrary)
  , exposedModules, libBuildInfo, hsSourceDirs, defaultExtensions, package
  , packageDescription, condSubLibraries, includeDirs, autogenModules, ConfVar(..) )

import Distribution.Compiler (CompilerFlavor(GHC))
import Distribution.Pretty (prettyShow)
import Distribution.System (buildArch, buildOS)
import Distribution.Types.Condition (Condition(..))
import Distribution.Types.CondTree
import Distribution.Types.Version (Version, mkVersion')
import Distribution.Types.VersionRange (withinRange)
import Distribution.Verbosity (silent)

#if MIN_VERSION_Cabal(3,8,0)
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
#else
import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
#endif

#if MIN_VERSION_Cabal(3,6,0)
import Distribution.Utils.Path (SourceDir, PackageDir, SymbolicPath)
#endif


-- | Efficient implementation of set like deletion on lists
--
-- >>> "abcd" `rmList` "ad"
-- "bc"
-- >>> "aaabcccd" `rmList` "ad"
-- "bccc"
rmList :: Ord a => [a] -> [a] -> [a]
rmList :: forall a. Ord a => [a] -> [a] -> [a]
rmList [a]
xs ([a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList -> Set a
ys) = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
ys)) [a]
xs

data Library = Library
  { Library -> [String]
libSourceDirectories :: [FilePath]
    -- ^ Haskell source directories
  , Library -> [String]
libCSourceDirectories :: [FilePath]
    -- ^ C source directories
  , Library -> [ModuleName]
libModules :: [ModuleName]
    -- ^ Exposed modules
  , Library -> [Extension]
libDefaultExtensions :: [Extension]
    -- ^ Extensions enabled by default
  }
  deriving (Int -> Library -> ShowS
[Library] -> ShowS
Library -> String
(Int -> Library -> ShowS)
-> (Library -> String) -> ([Library] -> ShowS) -> Show Library
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Library -> ShowS
showsPrec :: Int -> Library -> ShowS
$cshow :: Library -> String
show :: Library -> String
$cshowList :: [Library] -> ShowS
showList :: [Library] -> ShowS
Show)

-- | Merge multiple libraries into one, by concatenating all their fields.
mergeLibraries :: [Library] -> Library
mergeLibraries :: [Library] -> Library
mergeLibraries [Library]
libs = Library
  { libSourceDirectories :: [String]
libSourceDirectories = (Library -> [String]) -> [Library] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Library -> [String]
libSourceDirectories [Library]
libs
  , libCSourceDirectories :: [String]
libCSourceDirectories = (Library -> [String]) -> [Library] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Library -> [String]
libCSourceDirectories [Library]
libs
  , libModules :: [ModuleName]
libModules = (Library -> [ModuleName]) -> [Library] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Library -> [ModuleName]
libModules [Library]
libs
  , libDefaultExtensions :: [Extension]
libDefaultExtensions = (Library -> [Extension]) -> [Library] -> [Extension]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Library -> [Extension]
libDefaultExtensions [Library]
libs
  }

-- | Convert a "Library" to arguments suitable to be passed to GHCi.
libraryToGhciArgs :: Library -> ([String], [String], [String])
libraryToGhciArgs :: Library -> ([String], [String], [String])
libraryToGhciArgs Library{[String]
[ModuleName]
[Extension]
libSourceDirectories :: Library -> [String]
libCSourceDirectories :: Library -> [String]
libModules :: Library -> [ModuleName]
libDefaultExtensions :: Library -> [Extension]
libSourceDirectories :: [String]
libCSourceDirectories :: [String]
libModules :: [ModuleName]
libDefaultExtensions :: [Extension]
..} = ([String]
hsSrcArgs [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
cSrcArgs, [String]
modArgs, [String]
extArgs)
 where
  hsSrcArgs :: [String]
hsSrcArgs = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-i" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) [String]
libSourceDirectories
  cSrcArgs :: [String]
cSrcArgs = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-I" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) [String]
libCSourceDirectories
  modArgs :: [String]
modArgs = (ModuleName -> String) -> [ModuleName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> String
forall a. Pretty a => a -> String
prettyShow [ModuleName]
libModules
  extArgs :: [String]
extArgs = (Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Extension -> String
showExt [Extension]
libDefaultExtensions

  showExt :: Extension -> String
showExt = \case
    EnableExtension KnownExtension
ext -> String
"-X" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> KnownExtension -> String
forall a. Show a => a -> String
show KnownExtension
ext
    DisableExtension KnownExtension
ext -> String
"-XNo" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> KnownExtension -> String
forall a. Show a => a -> String
show KnownExtension
ext
    UnknownExtension String
ext -> String
"-X" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ext

-- | Drop a number of elements from the end of the list.
--
-- > dropEnd 3 "hello"  == "he"
-- > dropEnd 5 "bye"    == ""
-- > dropEnd (-1) "bye" == "bye"
-- > \i xs -> dropEnd i xs `isPrefixOf` xs
-- > \i xs -> length (dropEnd i xs) == max 0 (length xs - max 0 i)
-- > \i -> take 3 (dropEnd 5 [i..]) == take 3 [i..]
dropEnd :: Int -> [a] -> [a]
dropEnd :: forall a. Int -> [a] -> [a]
dropEnd Int
i [a]
xs
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [a]
xs
  | Bool
otherwise = [a] -> [a] -> [a]
forall {a} {a}. [a] -> [a] -> [a]
f [a]
xs (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
i [a]
xs)
 where
   f :: [a] -> [a] -> [a]
f (a
a:[a]
as) (a
_:[a]
bs) = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
f [a]
as [a]
bs
   f [a]
_ [a]
_ = []

-- | Searches for a file called @package.cabal@, where @package@ is given as an
-- argument. It will look for it in the current directory. If it can't find it
-- there, it will traverse up until it finds the file or a file called
-- @cabal.project@. In case of the latter, it will traverse down recursively
-- until it encounters a @package.cabal@.
--
-- The returned path points to the @package.cabal@. Errors if it could not
-- find @package.cabal@ anywhere, or when it found multiple.
--
findCabalPackage :: HasCallStack => String -> IO FilePath
findCabalPackage :: HasCallStack => String -> IO String
findCabalPackage String
packageName = String -> IO String
goUp (String -> IO String) -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
canonicalizePath String
packageName
 where
  goUp :: FilePath -> IO FilePath
  goUp :: String -> IO String
goUp String
path
    | String -> Bool
isDrive String
path = String -> IO String
forall a. HasCallStack => String -> a
error (String
"Could not find '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
packageFilename String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'")
    | Bool
otherwise = do
      Bool
packageExists <- String -> IO Bool
doesFileExist (String
path String -> ShowS
</> String
packageFilename)
      Bool
projectExists <- String -> IO Bool
doesFileExist (String
path String -> ShowS
</> String
projectFilename)

      if | Bool
packageExists -> String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
path String -> ShowS
</> String
packageFilename)
         | Bool
projectExists -> String -> IO String
goDown String
path
         | Bool
otherwise -> String -> IO String
goUp (ShowS
takeDirectory String
path)

  goDown :: FilePath -> IO FilePath
  goDown :: String -> IO String
goDown String
path = do
    [String]
candidates <- String -> IO [String]
glob (String
path String -> ShowS
</> String
"**" String -> ShowS
</> String
packageFilename)
    case [String]
candidates of
      [] -> String -> IO String
forall a. HasCallStack => String -> a
error (String
"Could not find " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
packageFilename String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" in project " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
path)
      (String
_:String
_:[String]
_) -> String -> IO String
forall a. HasCallStack => String -> a
error (String
"Ambiguous packages in project " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
path String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show [String]
candidates)
      [String
c] -> String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
c

  packageFilename :: String
packageFilename = String
packageName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".cabal"
  projectFilename :: String
projectFilename = String
"cabal.project"

#if MIN_VERSION_Cabal(3,6,0)
compatPrettyShow :: SymbolicPath PackageDir SourceDir -> FilePath
compatPrettyShow :: SymbolicPath PackageDir SourceDir -> String
compatPrettyShow = SymbolicPath PackageDir SourceDir -> String
forall a. Pretty a => a -> String
prettyShow
#else
compatPrettyShow :: FilePath -> FilePath
compatPrettyShow = id
#endif

-- | Traverse the given tree, solve predicates in branches, and return its
-- contents.
--
-- XXX: Branches guarded by Cabal flags are ignored. I'm not sure where we should
--      get this info from.
--
solveCondTree :: CondTree ConfVar c a -> [(c, a)]
solveCondTree :: forall c a. CondTree ConfVar c a -> [(c, a)]
solveCondTree CondNode{a
condTreeData :: a
condTreeData :: forall v c a. CondTree v c a -> a
condTreeData, c
condTreeConstraints :: c
condTreeConstraints :: forall v c a. CondTree v c a -> c
condTreeConstraints, [CondBranch ConfVar c a]
condTreeComponents :: [CondBranch ConfVar c a]
condTreeComponents :: forall v c a. CondTree v c a -> [CondBranch v c a]
condTreeComponents} =
  (c
condTreeConstraints, a
condTreeData) (c, a) -> [(c, a)] -> [(c, a)]
forall a. a -> [a] -> [a]
: (CondBranch ConfVar c a -> [(c, a)])
-> [CondBranch ConfVar c a] -> [(c, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CondBranch ConfVar c a -> [(c, a)]
forall c a. CondBranch ConfVar c a -> [(c, a)]
goBranch [CondBranch ConfVar c a]
condTreeComponents
 where
  goBranch :: CondBranch ConfVar c a -> [(c, a)]
  goBranch :: forall c a. CondBranch ConfVar c a -> [(c, a)]
goBranch (CondBranch Condition ConfVar
condBranchCondition CondTree ConfVar c a
condBranchIfTrue Maybe (CondTree ConfVar c a)
condBranchIfFalse) =
    if   Condition ConfVar -> Bool
goCondition Condition ConfVar
condBranchCondition
    then CondTree ConfVar c a -> [(c, a)]
forall c a. CondTree ConfVar c a -> [(c, a)]
solveCondTree CondTree ConfVar c a
condBranchIfTrue
    else [(c, a)]
-> (CondTree ConfVar c a -> [(c, a)])
-> Maybe (CondTree ConfVar c a)
-> [(c, a)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(c, a)]
forall a. Monoid a => a
mempty CondTree ConfVar c a -> [(c, a)]
forall c a. CondTree ConfVar c a -> [(c, a)]
solveCondTree Maybe (CondTree ConfVar c a)
condBranchIfFalse

  goCondition :: Condition ConfVar -> Bool
  goCondition :: Condition ConfVar -> Bool
goCondition = \case
    Var ConfVar
cv ->
      case ConfVar
cv of
        OS OS
os -> OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
buildOS
        Arch Arch
ar -> Arch
ar Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
buildArch
        Impl CompilerFlavor
cf VersionRange
versionRange ->
          case CompilerFlavor
cf of
            CompilerFlavor
GHC -> Version -> VersionRange -> Bool
withinRange Version
buildGhc VersionRange
versionRange
            CompilerFlavor
_   -> String -> Bool
forall a. HasCallStack => String -> a
error (String
"Unrecognized compiler: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CompilerFlavor -> String
forall a. Show a => a -> String
show CompilerFlavor
cf)
        -- XXX: We currently ignore any flags passed to Cabal
#if MIN_VERSION_Cabal(3,4,0)
        PackageFlag FlagName
_fn -> Bool
False
#else
        Flag _fn -> False
#endif
    Lit Bool
b -> Bool
b
    CNot Condition ConfVar
con -> Bool -> Bool
not (Condition ConfVar -> Bool
goCondition Condition ConfVar
con)
    COr Condition ConfVar
con0 Condition ConfVar
con1 -> Condition ConfVar -> Bool
goCondition Condition ConfVar
con0 Bool -> Bool -> Bool
|| Condition ConfVar -> Bool
goCondition Condition ConfVar
con1
    CAnd Condition ConfVar
con0 Condition ConfVar
con1 -> Condition ConfVar -> Bool
goCondition Condition ConfVar
con0 Bool -> Bool -> Bool
&& Condition ConfVar -> Bool
goCondition Condition ConfVar
con1

-- | GHC version as Cabal's 'Version' data structure
buildGhc :: Version
buildGhc :: Version
buildGhc = Version -> Version
mkVersion' Version
compilerVersion

-- | Given a filepath to a @package.cabal@, parse it, and yield a "Library". Yields
-- the default Library if first argument is Nothing, otherwise it will look for
-- a specific sublibrary.
extractSpecificCabalLibrary :: Maybe String -> FilePath -> IO Library
extractSpecificCabalLibrary :: Maybe String -> String -> IO Library
extractSpecificCabalLibrary Maybe String
maybeLibName String
pkgPath = do
  GenericPackageDescription
pkg <- Verbosity -> String -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
silent String
pkgPath
  case Maybe String
maybeLibName of
    Maybe String
Nothing ->
      case GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
condLibrary GenericPackageDescription
pkg of
        Maybe (CondTree ConfVar [Dependency] Library)
Nothing ->
          let pkgDescription :: PackageIdentifier
pkgDescription = PackageDescription -> PackageIdentifier
package (GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
pkg) in
          String -> IO Library
forall a. HasCallStack => String -> a
error (String
"Could not find main library in: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageIdentifier -> String
forall a. Show a => a -> String
show PackageIdentifier
pkgDescription)
        Just CondTree ConfVar [Dependency] Library
lib ->
          Library -> IO Library
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CondTree ConfVar [Dependency] Library -> Library
forall {a}. CondTree ConfVar a Library -> Library
go CondTree ConfVar [Dependency] Library
lib)

    Just String
libName ->
      Library -> IO Library
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CondTree ConfVar [Dependency] Library -> Library
forall {a}. CondTree ConfVar a Library -> Library
go (GenericPackageDescription
-> String
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> CondTree ConfVar [Dependency] Library
forall {a}.
GenericPackageDescription
-> String -> [(UnqualComponentName, a)] -> a
findSubLib GenericPackageDescription
pkg String
libName (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condSubLibraries GenericPackageDescription
pkg)))

 where
  findSubLib :: GenericPackageDescription
-> String -> [(UnqualComponentName, a)] -> a
findSubLib GenericPackageDescription
pkg String
targetLibName [] =
    let pkgDescription :: PackageIdentifier
pkgDescription = PackageDescription -> PackageIdentifier
package (GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
pkg) in
    String -> a
forall a. HasCallStack => String -> a
error (String
"Could not find library " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
targetLibName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageIdentifier -> String
forall a. Show a => a -> String
show PackageIdentifier
pkgDescription)
  findSubLib GenericPackageDescription
pkg String
targetLibName ((UnqualComponentName
libName, a
lib):[(UnqualComponentName, a)]
libs)
    | UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
libName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
targetLibName = a
lib
    | Bool
otherwise = GenericPackageDescription
-> String -> [(UnqualComponentName, a)] -> a
findSubLib GenericPackageDescription
pkg String
targetLibName [(UnqualComponentName, a)]
libs

  go :: CondTree ConfVar a Library -> Library
go CondTree ConfVar a Library
condNode = [Library] -> Library
mergeLibraries [Library]
libs1
   where
    libs0 :: [Library]
libs0 = ((a, Library) -> Library) -> [(a, Library)] -> [Library]
forall a b. (a -> b) -> [a] -> [b]
map (a, Library) -> Library
forall a b. (a, b) -> b
snd (CondTree ConfVar a Library -> [(a, Library)]
forall c a. CondTree ConfVar c a -> [(c, a)]
solveCondTree CondTree ConfVar a Library
condNode)
    libs1 :: [Library]
libs1 = (Library -> Library) -> [Library] -> [Library]
forall a b. (a -> b) -> [a] -> [b]
map Library -> Library
goLib [Library]
libs0

  goLib :: Library -> Library
goLib Library
lib = Library
    { libSourceDirectories :: [String]
libSourceDirectories = (SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
root String -> ShowS
</>) ShowS
-> (SymbolicPath PackageDir SourceDir -> String)
-> SymbolicPath PackageDir SourceDir
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath PackageDir SourceDir -> String
compatPrettyShow) [SymbolicPath PackageDir SourceDir]
sourceDirs
    , libCSourceDirectories :: [String]
libCSourceDirectories = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
root String -> ShowS
</>) [String]
cSourceDirs
    , libModules :: [ModuleName]
libModules = Library -> [ModuleName]
exposedModules Library
lib [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. Ord a => [a] -> [a] -> [a]
`rmList` BuildInfo -> [ModuleName]
autogenModules BuildInfo
buildInfo
    , libDefaultExtensions :: [Extension]
libDefaultExtensions = BuildInfo -> [Extension]
defaultExtensions BuildInfo
buildInfo
    }
   where
    buildInfo :: BuildInfo
buildInfo = Library -> BuildInfo
libBuildInfo Library
lib
    sourceDirs :: [SymbolicPath PackageDir SourceDir]
sourceDirs = BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
buildInfo
    cSourceDirs :: [String]
cSourceDirs = BuildInfo -> [String]
includeDirs BuildInfo
buildInfo
    root :: String
root = ShowS
takeDirectory String
pkgPath


-- | Given a filepath to a @package.cabal@, parse it, and yield a "Library". Returns
-- and error if no library was specified in the cabal package file.
extractCabalLibrary :: FilePath -> IO Library
extractCabalLibrary :: String -> IO Library
extractCabalLibrary = Maybe String -> String -> IO Library
extractSpecificCabalLibrary Maybe String
forall a. Maybe a
Nothing