module Distribution.Cab.Commands (
FunctionCommand
, Option(..)
, deps, revdeps, installed, outdated, uninstall, search
, genpaths, check, initSandbox, add, ghci
) where
import Control.Applicative hiding (many)
import Control.Monad
import Data.Char
import Data.List (isPrefixOf, intercalate)
import qualified Data.Map as M
import Distribution.Cab.GenPaths
import Distribution.Cab.PkgDB
import Distribution.Cab.Printer
import Distribution.Cab.Sandbox
import Distribution.Cab.VerDB
import Distribution.Cab.Version
import System.Exit
import System.IO
import System.Process hiding (env)
type FunctionCommand = [String] -> [Option] -> [String] -> IO ()
data Option = OptNoharm
| OptRecursive
| OptAll
| OptInfo
| OptFlag String
| OptTest
| OptHelp
| OptBench
| OptDepsOnly
| OptLibProfile
| OptExecProfile
| OptJobs String
| OptImport String
deriving (Eq,Show)
search :: FunctionCommand
search [x] _ _ = do
nvls <- toList <$> getVerDB AllRegistered
forM_ (lok nvls) $ \(n,v) -> putStrLn $ n ++ " " ++ verToString v
where
key = map toLower x
sat (n,_) = key `isPrefixOf` map toLower n
lok = filter sat
search _ _ _ = do
hPutStrLn stderr "One search-key should be specified."
exitFailure
installed :: FunctionCommand
installed _ opts _ = do
db <- getDB opts
let pkgs = toPkgInfos db
forM_ pkgs $ \pkgi -> do
putStr $ fullNameOfPkgInfo pkgi
extraInfo info pkgi
putStrLn ""
when optrec $ printDeps True info db 1 pkgi
where
info = OptInfo `elem` opts
optrec = OptRecursive `elem` opts
outdated :: FunctionCommand
outdated _ opts _ = do
pkgs <- toPkgInfos <$> getDB opts
verDB <- toMap <$> getVerDB InstalledOnly
forM_ pkgs $ \p -> case M.lookup (nameOfPkgInfo p) verDB of
Nothing -> return ()
Just ver -> when (verOfPkgInfo p /= ver) $
putStrLn $ fullNameOfPkgInfo p ++ " < " ++ verToString ver
getDB :: [Option] -> IO PkgDB
getDB opts
| optall = getSandbox >>= getPkgDB
| otherwise = getSandbox >>= getUserPkgDB
where
optall = OptAll `elem` opts
uninstall :: FunctionCommand
uninstall nmver opts _ = do
userDB <- getSandbox >>= getUserPkgDB
pkg <- lookupPkg nmver userDB
let sortedPkgs = topSortedPkgs pkg userDB
if onlyOne && length sortedPkgs /= 1 then do
hPutStrLn stderr "The following packages depend on this. Use the \"-r\" option."
mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) (init sortedPkgs)
else do
unless doit $ putStrLn "The following packages are deleted without the \"-n\" option."
mapM_ (unregister doit opts . pairNameOfPkgInfo) sortedPkgs
where
onlyOne = OptRecursive `notElem` opts
doit = OptNoharm `notElem` opts
unregister :: Bool -> [Option] -> (String,String) -> IO ()
unregister doit _ (name,ver) =
if doit then do
putStrLn $ "Deleting " ++ name ++ " " ++ ver
sandboxOpts <- getSandboxOpts2 <$> getSandbox
when doit $ void . system $ script sandboxOpts
else
putStrLn $ name ++ " " ++ ver
where
script sandboxOpts = "ghc-pkg unregister " ++ sandboxOpts ++ " " ++ name ++ "-" ++ ver
genpaths :: FunctionCommand
genpaths _ _ _ = genPaths
check :: FunctionCommand
check _ _ _ = do
sandboxOpts <- getSandboxOpts <$> getSandbox
void . system $ script sandboxOpts
where
script sandboxOpts = "ghc-pkg check -v " ++ sandboxOpts
deps :: FunctionCommand
deps nmver opts _ = printDepends nmver opts printDeps
revdeps :: FunctionCommand
revdeps nmver opts _ = printDepends nmver opts printRevDeps
printDepends :: [String] -> [Option]
-> (Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()) -> IO ()
printDepends nmver opts func = do
db' <- getSandbox >>= getPkgDB
pkg <- lookupPkg nmver db'
db <- getDB opts
func rec info db 0 pkg
where
rec = OptRecursive `elem` opts
info = OptInfo `elem` opts
lookupPkg :: [String] -> PkgDB -> IO PkgInfo
lookupPkg [] _ = do
hPutStrLn stderr "Package name must be specified."
exitFailure
lookupPkg [name] db = checkOne $ lookupByName name db
lookupPkg [name,ver] db = checkOne $ lookupByVersion name ver db
lookupPkg _ _ = do
hPutStrLn stderr "Only one package name must be specified."
exitFailure
checkOne :: [PkgInfo] -> IO PkgInfo
checkOne [] = do
hPutStrLn stderr "No such package found."
exitFailure
checkOne [pkg] = return pkg
checkOne pkgs = do
hPutStrLn stderr "Package version must be specified."
mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) pkgs
exitFailure
initSandbox :: FunctionCommand
initSandbox [] _ _ = void . system $ "cabal sandbox init"
initSandbox [path] _ _ = void . system $ "cabal sandbox init --sandbox " ++ path
initSandbox _ _ _ = do
hPutStrLn stderr "Only one argument is allowed"
exitFailure
add :: FunctionCommand
add [src] _ _ = void . system $ "cabal sandbox add-source " ++ src
add _ _ _ = do
hPutStrLn stderr "A source path be specified."
exitFailure
ghci :: FunctionCommand
ghci args _ options = do
sbxOpts <- getSandboxOpts <$> getSandbox
void $ system $ "ghci" ++ " " ++ sbxOpts ++ " " ++ intercalate " " (options ++ args)