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

module Test.DocTest.Helpers where

import GHC.Stack (HasCallStack)

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

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

-- Cabal
import Distribution.ModuleName (ModuleName)
import Distribution.Simple
  ( Extension (DisableExtension, EnableExtension, UnknownExtension) )
import Distribution.Types.UnqualComponentName ( unUnqualComponentName )
import Distribution.PackageDescription
  ( CondTree(CondNode, condTreeData), GenericPackageDescription (condLibrary)
  , exposedModules, libBuildInfo, hsSourceDirs, defaultExtensions, package
  , packageDescription, condSubLibraries )
import Distribution.Pretty (prettyShow)
import Distribution.Verbosity (silent)

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

-- cabal-install-parsers
import Distribution.PackageDescription.Parsec (readGenericPackageDescription)

data Library = Library
  { Library -> [FilePath]
libSourceDirectories :: [FilePath]
  , Library -> [ModuleName]
libModules :: [ModuleName]
  , Library -> [Extension]
libDefaultExtensions :: [Extension]
  }
  deriving (Int -> Library -> ShowS
[Library] -> ShowS
Library -> FilePath
(Int -> Library -> ShowS)
-> (Library -> FilePath) -> ([Library] -> ShowS) -> Show Library
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Library] -> ShowS
$cshowList :: [Library] -> ShowS
show :: Library -> FilePath
$cshow :: Library -> FilePath
showsPrec :: Int -> Library -> ShowS
$cshowsPrec :: Int -> Library -> ShowS
Show)

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

  showExt :: Extension -> FilePath
showExt = \case
    EnableExtension ext :: KnownExtension
ext -> "-X" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> KnownExtension -> FilePath
forall a. Show a => a -> FilePath
show KnownExtension
ext
    DisableExtension ext :: KnownExtension
ext -> "-XNo" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> KnownExtension -> FilePath
forall a. Show a => a -> FilePath
show KnownExtension
ext
    UnknownExtension ext :: FilePath
ext -> "-X" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
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 :: Int -> [a] -> [a]
dropEnd i :: Int
i xs :: [a]
xs
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 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]
as) (_:bs :: [a]
bs) = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
f [a]
as [a]
bs
   f _ _ = []

-- 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 :: FilePath -> IO FilePath
findCabalPackage packageName :: FilePath
packageName = FilePath -> IO FilePath
goUp (FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO FilePath
canonicalizePath FilePath
packageName
 where
  goUp :: FilePath -> IO FilePath
  goUp :: FilePath -> IO FilePath
goUp path :: FilePath
path
    | FilePath -> Bool
isDrive FilePath
path = FilePath -> IO FilePath
forall a. HasCallStack => FilePath -> a
error ("Could not find '" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
packageFilename FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> "'")
    | Bool
otherwise = do
      Bool
packageExists <- FilePath -> IO Bool
doesFileExist (FilePath
path FilePath -> ShowS
</> FilePath
packageFilename)
      Bool
projectExists <- FilePath -> IO Bool
doesFileExist (FilePath
path FilePath -> ShowS
</> FilePath
projectFilename)

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

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

  packageFilename :: FilePath
packageFilename = FilePath
packageName FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ".cabal"
  projectFilename :: FilePath
projectFilename = "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

-- 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 FilePath -> FilePath -> IO Library
extractSpecificCabalLibrary maybeLibName :: Maybe FilePath
maybeLibName pkgPath :: FilePath
pkgPath = do
  GenericPackageDescription
pkg <- Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
silent FilePath
pkgPath
  case Maybe FilePath
maybeLibName of
    Nothing ->
      case GenericPackageDescription
-> Maybe (CondTree ConfVar [Dependency] Library)
condLibrary GenericPackageDescription
pkg of
        Nothing ->
          let pkgDescription :: PackageIdentifier
pkgDescription = PackageDescription -> PackageIdentifier
package (GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
pkg) in
          FilePath -> IO Library
forall a. HasCallStack => FilePath -> a
error ("Could not find main library in: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> PackageIdentifier -> FilePath
forall a. Show a => a -> FilePath
show PackageIdentifier
pkgDescription)
        Just lib :: CondTree ConfVar [Dependency] Library
lib ->
          CondTree ConfVar [Dependency] Library -> IO Library
forall (f :: * -> *) v c.
Applicative f =>
CondTree v c Library -> f Library
go CondTree ConfVar [Dependency] Library
lib

    Just libName :: FilePath
libName ->
      CondTree ConfVar [Dependency] Library -> IO Library
forall (f :: * -> *) v c.
Applicative f =>
CondTree v c Library -> f Library
go (GenericPackageDescription
-> FilePath
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> CondTree ConfVar [Dependency] Library
forall p.
GenericPackageDescription
-> FilePath -> [(UnqualComponentName, p)] -> p
findSubLib GenericPackageDescription
pkg FilePath
libName (GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condSubLibraries GenericPackageDescription
pkg))

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

  go :: CondTree v c Library -> f Library
go CondNode{condTreeData :: forall v c a. CondTree v c a -> a
condTreeData=Library
lib} =
    let
      buildInfo :: BuildInfo
buildInfo = Library -> BuildInfo
libBuildInfo Library
lib
      sourceDirs :: [FilePath]
sourceDirs = BuildInfo -> [FilePath]
hsSourceDirs BuildInfo
buildInfo
      root :: FilePath
root = ShowS
takeDirectory FilePath
pkgPath
    in
      Library -> f Library
forall (f :: * -> *) a. Applicative f => a -> f a
pure Library :: [FilePath] -> [ModuleName] -> [Extension] -> Library
Library
        { libSourceDirectories :: [FilePath]
libSourceDirectories = ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
root FilePath -> ShowS
</>) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
compatPrettyShow) [FilePath]
sourceDirs
        , libModules :: [ModuleName]
libModules = Library -> [ModuleName]
exposedModules Library
lib
        , libDefaultExtensions :: [Extension]
libDefaultExtensions = BuildInfo -> [Extension]
defaultExtensions BuildInfo
buildInfo
        }


-- 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 :: FilePath -> IO Library
extractCabalLibrary = Maybe FilePath -> FilePath -> IO Library
extractSpecificCabalLibrary Maybe FilePath
forall a. Maybe a
Nothing