{-# 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.PackageDescription.Parsec (readGenericPackageDescription)
import Distribution.Pretty (prettyShow)
import Distribution.System (buildArch, buildOS)
import Distribution.Types.Condition (Condition(..))
import Distribution.Types.CondTree
import Distribution.Types.ConfVar (ConfVar(..))
import Distribution.Types.Version (Version, mkVersion')
import Distribution.Types.VersionRange (withinRange)
import Distribution.Verbosity (silent)

#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
showList :: [Library] -> ShowS
$cshowList :: [Library] -> ShowS
show :: Library -> String
$cshow :: Library -> String
showsPrec :: Int -> Library -> ShowS
$cshowsPrec :: Int -> Library -> ShowS
Show)

-- | Merge multiple libraries into one, by concatenating all their fields.
mergeLibraries :: [Library] -> Library
mergeLibraries :: [Library] -> Library
mergeLibraries [Library]
libs = Library :: [String] -> [String] -> [ModuleName] -> [Extension] -> Library
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]
[Extension]
[ModuleName]
libDefaultExtensions :: [Extension]
libModules :: [ModuleName]
libCSourceDirectories :: [String]
libSourceDirectories :: [String]
libDefaultExtensions :: Library -> [Extension]
libModules :: Library -> [ModuleName]
libCSourceDirectories :: Library -> [String]
libSourceDirectories :: Library -> [String]
..} = ([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 (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 (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 = prettyShow
#else
compatPrettyShow :: FilePath -> FilePath
compatPrettyShow :: ShowS
compatPrettyShow = ShowS
forall a. a -> a
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 :: forall v c a. CondTree v c a -> a
condTreeData :: a
condTreeData, c
condTreeConstraints :: forall v c a. CondTree v c a -> c
condTreeConstraints :: c
condTreeConstraints, [CondBranch ConfVar c a]
condTreeComponents :: forall v c a. CondTree v c a -> [CondBranch v c a]
condTreeComponents :: [CondBranch ConfVar 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
        PackageFlag FlagName
_fn -> Bool
False
    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 (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 (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 :: [String] -> [String] -> [ModuleName] -> [Extension] -> Library
Library
    { libSourceDirectories :: [String]
libSourceDirectories = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
root String -> ShowS
</>) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
compatPrettyShow) [String]
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 :: [String]
sourceDirs = BuildInfo -> [String]
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