{-# 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 {}; 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