{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module Test.DocTest.Internal.Nix where
import Control.Monad (msum)
import Control.Monad.Extra (ifM)
import Control.Monad.Trans.Maybe
import Data.Bool (bool)
import Data.List (intercalate, isSuffixOf)
import Data.Maybe (isJust)
import Data.Version
import GHC.Base (mzero)
import System.Directory
import System.Environment (lookupEnv)
import System.FilePath ((</>), isDrive, takeDirectory)
import System.Process (readProcess)
#if __GLASGOW_HASKELL__ >= 900
import GHC.Data.Maybe (liftMaybeT)
import System.Info (fullCompilerVersion)
#else
import Maybes (liftMaybeT)
import System.Info (compilerVersion)
fullCompilerVersion :: Version
fullCompilerVersion :: Version
fullCompilerVersion =
case Version
compilerVersion of
Version [Int]
majorMinor [String]
tags ->
[Int] -> [String] -> Version
Version ([Int]
majorMinor [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
lvl1]) [String]
tags
where
lvl1 :: Int
lvl1 :: Int
lvl1 = __GLASGOW_HASKELL_PATCHLEVEL1__
#endif
compilerVersionStr :: String
compilerVersionStr :: String
compilerVersionStr = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show (Version -> [Int]
versionBranch Version
fullCompilerVersion))
findDirectoryUp :: (FilePath -> IO (Maybe a)) -> MaybeT IO a
findDirectoryUp :: (String -> IO (Maybe a)) -> MaybeT IO a
findDirectoryUp String -> IO (Maybe a)
f = do
String
home <- IO String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT IO String
getHomeDirectory
IO (Maybe a) -> MaybeT IO a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> String -> IO (Maybe a)
go String
home (String -> IO (Maybe a)) -> IO String -> IO (Maybe a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
getCurrentDirectory)
where
go :: String -> String -> IO (Maybe a)
go String
home String
cwd
| String -> Bool
isDrive String
cwd = Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
| String
cwd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
home = Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
| Bool
otherwise =
String -> IO (Maybe a)
f String
cwd IO (Maybe a) -> (Maybe a -> IO (Maybe a)) -> IO (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just a
a -> Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
Maybe a
Nothing -> String -> String -> IO (Maybe a)
go String
home (String -> String
takeDirectory String
cwd)
findDirectoryUpPredicate :: (FilePath -> IO Bool) -> MaybeT IO FilePath
findDirectoryUpPredicate :: (String -> IO Bool) -> MaybeT IO String
findDirectoryUpPredicate String -> IO Bool
f = (String -> IO (Maybe String)) -> MaybeT IO String
forall a. (String -> IO (Maybe a)) -> MaybeT IO a
findDirectoryUp (\String
fp -> Maybe String -> Maybe String -> Bool -> Maybe String
forall a. a -> a -> Bool -> a
bool Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
fp) (Bool -> Maybe String) -> IO Bool -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
f String
fp)
findCabalProjectRoot :: MaybeT IO FilePath
findCabalProjectRoot :: MaybeT IO String
findCabalProjectRoot =
[MaybeT IO String] -> MaybeT IO String
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
[ (String -> IO Bool) -> MaybeT IO String
findDirectoryUpPredicate String -> IO Bool
containsCabalProject
, (String -> IO Bool) -> MaybeT IO String
findDirectoryUpPredicate String -> IO Bool
containsCabalPackage
]
where
containsCabalPackage :: FilePath -> IO Bool
containsCabalPackage :: String -> IO Bool
containsCabalPackage String
fp = String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
"cabal.project" ([String] -> Bool) -> IO [String] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
fp
containsCabalProject :: FilePath -> IO Bool
containsCabalProject :: String -> IO Bool
containsCabalProject String
fp = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
".cabal" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) ([String] -> Bool) -> IO [String] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
fp
findLocalPackageDb :: MaybeT IO FilePath
findLocalPackageDb :: MaybeT IO String
findLocalPackageDb = do
String
projectRoot <- MaybeT IO String
findCabalProjectRoot
let
relDir :: String
relDir = String
"dist-newstyle" String -> String -> String
</> String
"packagedb" String -> String -> String
</> (String
"ghc-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
compilerVersionStr)
absDir :: String
absDir = String
projectRoot String -> String -> String
</> String
relDir
MaybeT IO Bool
-> MaybeT IO String -> MaybeT IO String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
(IO Bool -> MaybeT IO Bool
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
liftMaybeT (String -> IO Bool
doesDirectoryExist String
absDir))
(String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
absDir)
MaybeT IO String
forall (m :: * -> *) a. MonadPlus m => m a
mzero
inNixShell :: IO Bool
inNixShell :: IO Bool
inNixShell = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"IN_NIX_SHELL"
inNixBuild :: IO Bool
inNixBuild :: IO Bool
inNixBuild = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"NIX_BUILD_TOP"
getLocalCabalPackageDbArgs :: IO [String]
getLocalCabalPackageDbArgs :: IO [String]
getLocalCabalPackageDbArgs = do
MaybeT IO String -> IO (Maybe String)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT MaybeT IO String
findLocalPackageDb IO (Maybe String) -> (Maybe String -> IO [String]) -> IO [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe String
Nothing -> [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just String
s -> [String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"-package-db", String
s]
getLocalNixPackageDbArgs :: IO [String]
getLocalNixPackageDbArgs :: IO [String]
getLocalNixPackageDbArgs = do
String
pkgDb <- String -> IO String
makeAbsolute (String
"dist" String -> String -> String
</> String
"package.conf.inplace")
IO Bool -> IO [String] -> IO [String] -> IO [String]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
(String -> IO Bool
doesDirectoryExist String
pkgDb)
([String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"-package-db", String
pkgDb])
([String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
getGlobalPackageDb :: IO String
getGlobalPackageDb :: IO String
getGlobalPackageDb = String -> String
forall a. [a] -> [a]
init (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"ghc" [String
"--print-global-package-db"] String
""
getNixGhciArgs :: IO [String]
getNixGhciArgs :: IO [String]
getNixGhciArgs =
IO Bool -> IO [String] -> IO [String] -> IO [String]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM IO Bool
inNixShell IO [String]
goShell (IO Bool -> IO [String] -> IO [String] -> IO [String]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM IO Bool
inNixBuild IO [String]
goBuild ([String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []))
where
goShell :: IO [String]
goShell = do
String
globalPkgDb <- IO String
getGlobalPackageDb
[String]
localPkgDbFlag <- IO [String]
getLocalCabalPackageDbArgs
let globalDbFlag :: [String]
globalDbFlag = [String
"-package-db", String
globalPkgDb]
[String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String]
defaultArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
globalDbFlag [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
localPkgDbFlag)
goBuild :: IO [String]
goBuild = do
[String]
localDbFlag <- IO [String]
getLocalNixPackageDbArgs
[String] -> IO [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String]
defaultArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
localDbFlag)
defaultArgs :: [String]
defaultArgs =
[ String
"-package-env", String
"-"
, String
"-package", String
"ghc"
]