jbi-0.2.0.0: lib/System/JBI/Commands/Cabal.hs
{-# LANGUAGE CPP, OverloadedStrings #-}
{- |
Module : System.JBI.Commands.Cabal
Description : cabal-install support
Copyright : (c) Ivan Lazar Miljenovic
License : MIT
Maintainer : Ivan.Miljenovic@gmail.com
-}
module System.JBI.Commands.Cabal
( Cabal
, CabalMode
, Sandbox
, Nix
) where
import System.JBI.Commands.BuildTool
import System.JBI.Commands.Nix
import System.JBI.Commands.Tool
import System.JBI.Environment
import System.JBI.Tagged
import Control.Applicative (liftA2, (<*>))
import Control.Monad (filterM)
import Data.Bool (bool)
import Data.Maybe (isJust, maybeToList)
import Data.Proxy (Proxy(Proxy))
import Data.Version (Version, makeVersion)
import System.Directory (doesFileExist, getCurrentDirectory, listDirectory,
removeFile)
import System.Exit (ExitCode, die, exitSuccess)
import System.FilePath (takeExtension, (</>))
import System.IO.Error (ioError, isDoesNotExistError, tryIOError)
import qualified Distribution.Package as CPkg
import Distribution.PackageDescription (GenericPackageDescription,
condBenchmarks,
condExecutables,
condLibrary,
condTestSuites)
import qualified Distribution.PackageDescription.Parse as CParse
import Distribution.Verbosity (silent)
#if MIN_VERSION_Cabal (2,0,0)
import Distribution.Types.UnqualComponentName (UnqualComponentName,
unUnqualComponentName)
#endif
--------------------------------------------------------------------------------
data Cabal mode
instance Tool (Cabal mode) where
commandName = "cabal"
instance (CabalMode mode) => BuildTool (Cabal mode) where
canUseCommand = canUseMode
commandProjectRoot = cabalProjectRoot
hasBuildArtifacts = hasModeArtifacts
commandPrepare = cabalPrepare
commandTargets = cabalTargets
commandBuild env cmd = cabalTry env cmd . cabalBuild env cmd
commandRepl env cmd rargs = cabalTry env cmd . cabalRepl env cmd rargs
commandClean = cabalClean
commandTest = liftA2 (<*>) cabalTry cabalTest
commandBench = liftA2 (<*>) cabalTry cabalBench
commandExec = cabalExec
commandRun env cmd = (cabalTry env cmd .) . cabalRun env cmd
commandUpdate = cabalUpdate
cabalTry :: (CabalMode mode) => Env -> Tagged (Cabal mode) CommandPath
-> IO ExitCode -> IO ExitCode
cabalTry env cmd = tryCommand "Command failed, trying to re-configure"
(cabalConfigure env cmd)
instance (CabalMode mode) => NamedTool (Cabal mode) where
prettyName p = "cabal+" ++ modeName (getMode p)
getMode :: proxy (Cabal mode) -> Proxy mode
getMode _ = Proxy
class CabalMode mode where
modeName :: proxy mode -> String
-- | Optional minimal version of @cabal@ required. Used to provide
-- default instance of @canUseMode@.
--
-- @since 0.2.0.0
needsMinCabal :: Maybe (Tagged (Cabal mode) Version)
needsMinCabal = Nothing
-- | @since 0.2.0.0
canUseMode :: Env -> Tagged (Cabal mode) CommandPath -> IO Bool
canUseMode env cp = case needsMinCabal of
Nothing -> return hasGHC
Just mv -> maybe hasGHC (mv <=)
<$> commandVersion (envConfig env) cp
where
hasGHC = isJust (ghc (envTools env))
cabalProjectRoot :: Tagged (Cabal mode) CommandPath
-> IO (Maybe (Tagged (Cabal mode) ProjectRoot))
cabalProjectRoot = withTaggedF go
where
-- Type signature needed to make withTaggedF happy, though we
-- don't actually use the command itself for this.
go :: FilePath -> IO (Maybe FilePath)
go _ = recurseUpFindFile isCabalFile
hasModeArtifacts :: Tagged (Cabal mode) ProjectRoot -> IO Bool
cabalPrepare :: Env -> Tagged (Cabal mode) CommandPath -> IO ExitCode
cabalTargets :: Config -> Tagged (Cabal mode) CommandPath
-> IO [Tagged (Cabal mode) ProjectTarget]
cabalTargets _ = withTaggedF go
where
-- Make withTaggedF happy
go :: FilePath -> IO [String]
go _ = cabalFileComponents
-- | This is an additional function than found in 'BuildTool'. May
-- include installing dependencies.
cabalConfigure :: Env -> Tagged (Cabal mode) CommandPath -> IO ExitCode
cabalBuild :: Env -> Tagged (Cabal mode) CommandPath
-> Maybe (Tagged (Cabal mode) ProjectTarget) -> IO ExitCode
cabalBuild = commandArgTarget "build"
cabalRepl :: Env -> Tagged (Cabal mode) CommandPath
-> Tagged (Cabal mode) Args
-> Maybe (Tagged (Cabal mode) ProjectTarget)
-> IO ExitCode
cabalRepl env cmd rargs = commandArgsTarget ("repl" : ghcArgs) env cmd
where
ghcArgs = ["--ghc-options", unwords (stripTag rargs :: Args)]
cabalClean :: Env -> Tagged (Cabal mode) CommandPath -> IO ExitCode
cabalTest :: Env -> Tagged (Cabal mode) CommandPath -> IO ExitCode
cabalTest = commandArg "test"
cabalBench :: Env -> Tagged (Cabal mode) CommandPath -> IO ExitCode
cabalBench = commandArg "bench"
cabalExec :: Env -> Tagged (Cabal mode) CommandPath -> String -> Args -> IO ExitCode
cabalExec env cmd prog progArgs = commandArgs args env cmd
where
args = "exec" : prog : "--" : progArgs
cabalRun :: Env -> Tagged (Cabal mode) CommandPath -> Tagged (Cabal mode) ProjectTarget
-> Args -> IO ExitCode
cabalRun env cmd prog progArgs = commandArgs args env cmd
where
args = "run" : componentName (stripTag prog) : "--" : progArgs
cabalUpdate :: Env -> Tagged (Cabal mode) CommandPath -> IO ExitCode
cabalUpdate = commandArg "update"
--------------------------------------------------------------------------------
data Sandbox
instance CabalMode Sandbox where
modeName _ = "sandbox"
needsMinCabal = Just (tag (makeVersion [1,18]))
hasModeArtifacts pr = doesFileExist (stripTag pr </> "cabal.sandbox.config")
cabalPrepare = commandArgs ["sandbox", "init"]
cabalConfigure env cmd = tryConfigure
where
install = commandArgs ["install", "--only-dependencies"
, "--enable-tests", "--enable-benchmarks"]
env cmd
tryInstall = tryCommand "Installation failed; updating index."
(cabalUpdate env cmd)
install
tryConfigure = tryCommand "Configuring failed; checking dependencies"
tryInstall
configure
configure = commandArgs ["configure", "--enable-tests", "--enable-benchmarks"]
env cmd
-- Note: we don't treat "dist" as part of the tool artifacts, but it
-- doesn't make sense without the sandbox so remove it as well.
cabalClean env cmd = commandArg "clean" env cmd
.&&. commandArgs ["sandbox", "delete"] env cmd
--------------------------------------------------------------------------------
data Nix
instance CabalMode Nix where
modeName _ = "nix"
-- We don't test for nix-instantiate here, as it's just used if it
-- can be used.
canUseMode env _ = return (has nixShell && has cabal2Nix)
where
has :: (NixSupport -> Maybe (Installed a)) -> Bool
has f = isJust (f (nix (envTools env)))
hasModeArtifacts pr = or <$> mapM (doesFileExist . (stripTag pr </>))
["shell.nix", "default.nix"]
-- Note that commandPrepare is meant to be run within ProjectRoot
cabalPrepare env _ = case path <$> cabal2Nix (nix (envTools env)) of
Nothing -> die "cabal2Nix required"
Just c2n -> tryRunToFile (envConfig env) "shell.nix" c2n ["--shell", "."]
-- It is tempting to want to run cabal2nix again here just in case,
-- but people might have customised variants (different
-- haskellPackages set, etc.).
--
-- Instead, people need to run @jbi prepare@ if the .cabal file
-- changes.
cabalConfigure env _ = case path <$> nixShell nixEnv of
Nothing -> die "nix-shell required"
Just ns -> do
-- We now evaluate canBench twice, which isn't ideal.
--
-- Should also warn if it's False.
args <- extraArgs
cArgs <- cabalArgs
tryRunErr
"Configuration failed; you may need to manually enable 'withBenchmarkDepends' or 'doBenchmark' in your shell.nix file."
(tryRun cfg ns (args ++ ["--run", cArgs]))
where
extraArgs = bool [] ["--arg", "doBenchmark", "true"] <$> canBench
nixEnv = nix (envTools env)
cfg = envConfig env
canBench =
case path <$> nixInstantiate nixEnv of
Nothing -> return False
Just ni -> do
res <- tryRunLine cfg (stripTag ni) ["--eval", "--expr", "with import <nixpkgs> {}; haskell.lib ? doBenchmark"]
return $ case res of
Just "true" -> maybe False (>= c2nBenchSupport) (cabal2Nix nixEnv >>= version)
_ -> False
c2nBenchSupport :: Tagged Cabal2Nix Version
c2nBenchSupport = tag (makeVersion [2,6])
cabalArgs = unwords . (["cabal", "configure", "--enable-tests"] ++) . bnchArgs <$> canBench
where
bnchArgs canB
| canB = ["--enable-benchmarks"]
| otherwise = []
cabalClean env cmd = commandArg "clean" env cmd
.&&. rmFile "shell.nix"
.&&. rmFile "default.nix"
where
rmFile file = do
rmStatus <- tryIOError (removeFile file)
case rmStatus of
-- We're guessing as to which file is the one being used
-- here, so an error because a file doesn't exist is OK;
-- anything else is serious and should be re-thrown.
Left err | not (isDoesNotExistError err) -> ioError err
_ -> exitSuccess
--------------------------------------------------------------------------------
isCabalFile :: FilePath -> Bool
isCabalFile = (== ".cabal") . takeExtension
--------------------------------------------------------------------------------
-- The Cabal library likes to really keep changing things...
cabalFileComponents :: IO [String]
cabalFileComponents = do
dir <- getCurrentDirectory
cntns <- map (dir </>) <$> listDirectory dir
files <- filterM doesFileExist cntns
let cabalFiles = filter isCabalFile files
case cabalFiles of
[] -> return []
(c:_) -> getComponents <$> parseCabalFile c
parseCabalFile :: FilePath -> IO GenericPackageDescription
parseCabalFile =
#if MIN_VERSION_Cabal(2,0,0)
CParse.readGenericPackageDescription
#else
CParse.readPackageDescription
#endif
silent
type ComponentName =
#if MIN_VERSION_Cabal (2,0,0)
UnqualComponentName
#else
String
#endif
rawComponentName :: ComponentName -> String
rawComponentName =
#if MIN_VERSION_Cabal (2,0,0)
unUnqualComponentName
#else
id
#endif
packageName :: GenericPackageDescription -> String
packageName =
#if MIN_VERSION_Cabal (2,0,0)
CPkg.unPackageName
#else
(\(CPkg.PackageName nm) -> nm)
#endif
. CPkg.packageName
getComponents :: GenericPackageDescription -> [String]
getComponents gpd = concat
[ getLib
, getType condExecutables "exe"
, getType condTestSuites "test"
, getType condBenchmarks "bench"
]
where
pkgName = packageName gpd
getLib
| isJust (condLibrary gpd) = ["lib:" ++ pkgName]
| otherwise = []
getType f typ = map (\cmp -> typ ++ ':' : rawComponentName (fst cmp)) (f gpd)
--------------------------------------------------------------------------------
commandArgsTarget :: Args -> Env -> Tagged (Cabal mode) CommandPath
-> Maybe (Tagged (Cabal mode) ProjectTarget) -> IO ExitCode
commandArgsTarget args env cmd mt = commandArgs args' env cmd
where
args' = args ++ maybeToList (fmap stripTag mt)
commandArgTarget :: String -> Env -> Tagged (Cabal mode) CommandPath
-> Maybe (Tagged (Cabal mode) ProjectTarget) -> IO ExitCode
commandArgTarget = commandArgsTarget . (:[])
commandArg :: String -> Env -> Tagged (Cabal mode) CommandPath
-> IO ExitCode
commandArg arg = commandArgs [arg]
commandArgs :: Args -> Env -> Tagged (Cabal mode) CommandPath
-> IO ExitCode
commandArgs args env cmd = tryRun (envConfig env) cmd args