cab 0.2.9 → 0.2.22
raw patch · 19 files changed
Files
- Distribution/Cab.hs +17/−16
- Distribution/Cab/Commands.hs +156/−80
- Distribution/Cab/GenPaths.hs +24/−18
- Distribution/Cab/PkgDB.hs +100/−22
- Distribution/Cab/Printer.hs +50/−37
- Distribution/Cab/Sandbox.hs +27/−24
- Distribution/Cab/Utils.hs +108/−3
- Distribution/Cab/VerDB.hs +27/−22
- Distribution/Cab/Version.hs +25/−12
- Setup.hs +1/−0
- cab.cabal +77/−81
- src/Commands.hs +254/−220
- src/Doc.hs +20/−17
- src/Help.hs +18/−17
- src/Main.hs +24/−22
- src/Options.hs +113/−45
- src/Program.hs +6/−4
- src/Run.hs +39/−24
- src/Types.hs +58/−50
Distribution/Cab.hs view
@@ -1,19 +1,20 @@ module Distribution.Cab (- -- * Types- Option(..)- , FunctionCommand- -- * Commands- , deps- , revdeps- , installed- , outdated- , uninstall- , search- , genpaths- , check- , add- , initSandbox- , ghci- ) where+ -- * Types+ Option (..),+ FunctionCommand,++ -- * Commands+ deps,+ revdeps,+ installed,+ outdated,+ uninstall,+ search,+ genpaths,+ check,+ add,+ initSandbox,+ ghci,+) where import Distribution.Cab.Commands
Distribution/Cab/Commands.hs view
@@ -1,54 +1,70 @@ module Distribution.Cab.Commands (- FunctionCommand- , Option(..)- , deps, revdeps, installed, outdated, uninstall, search- , genpaths, check, initSandbox, add, ghci- ) where+ 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, isSuffixOf, intercalate)-import qualified Data.Map as M+import qualified Control.Exception as E+import Control.Monad (forM_, unless, void, when)+import Data.Char (toLower)+import Data.List (intercalate, isPrefixOf)+import qualified Data.Map.Strict 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)+import System.Directory (doesDirectoryExist, removeDirectoryRecursive)+import System.Exit (exitFailure)+import System.FilePath (takeDirectory, takeFileName)+import System.IO (hPutStrLn, stderr)+import System.Process (readProcess, system) ---------------------------------------------------------------- type FunctionCommand = [String] -> [Option] -> [String] -> IO () -data Option = OptNoharm- | OptRecursive- | OptAll- | OptInfo- | OptFlag String- | OptTest- | OptHelp- | OptBench- | OptDepsOnly- | OptLibProfile- | OptExecProfile- | OptJobs String- | OptImport String- | OptStatic- deriving (Eq,Show)+data Option+ = OptNoharm+ | OptRecursive+ | OptAll+ | OptInfo+ | OptFlag String+ | OptTest+ | OptHelp+ | OptBench+ | OptDepsOnly+ | OptLibProfile+ | OptExecProfile+ | OptJobs String+ | OptImport String+ | OptStatic+ | OptFuture+ | OptDebug+ | OptAllowNewer+ | OptCleanUp+ deriving (Eq, Show) ---------------------------------------------------------------- search :: FunctionCommand search [x] _ _ = do nvls <- toList <$> getVerDB AllRegistered- forM_ (lok nvls) $ \(n,v) -> putStrLn $ n ++ " " ++ verToString v+ forM_ (lok nvls) $ \(n, v) -> putStrLn $ n ++ " " ++ verToString v where key = map toLower x- sat (n,_) = key `isPrefixOf` map toLower n+ sat (n, _) = key `isPrefixOf` map toLower n lok = filter sat search _ _ _ = do hPutStrLn stderr "One search-key should be specified."@@ -73,63 +89,118 @@ outdated _ opts _ = do pkgs <- toPkgInfos <$> getDB opts verDB <- toMap <$> getVerDB InstalledOnly+ let del = OptCleanUp `elem` opts forM_ pkgs $ \p -> case M.lookup (nameOfPkgInfo p) verDB of- Nothing -> return ()- Just ver -> when (verOfPkgInfo p /= ver) $- putStrLn $ fullNameOfPkgInfo p ++ " /= " ++ verToString ver+ Nothing -> return ()+ Just ver -> do+ let comp = verOfPkgInfo p `compare` ver+ when (dated comp) $ do+ if del+ then do+ let (nm, vr) = pairNameOfPkgInfo p+ uninstall [nm, vr] [OptRecursive] [] `E.catch` \(E.SomeException _) -> return ()+ else+ putStrLn $ fullNameOfPkgInfo p ++ showIneq comp ++ verToString ver+ where+ dated LT = True+ dated GT = OptFuture `elem` opts+ dated EQ = False+ showIneq LT = " < "+ showIneq GT = " > "+ showIneq EQ = error "Packages have equal versions" getDB :: [Option] -> IO PkgDB getDB opts- | optall = getSandbox >>= getPkgDB- | otherwise = getSandbox >>= getUserPkgDB+ | optall = getSandbox >>= getPkgDB+ | otherwise = getSandbox >>= getUserPkgDB where optall = OptAll `elem` opts ---------------------------------------------------------------- uninstall :: FunctionCommand-uninstall nmver opts _ = do+uninstall nmver opts _ = uninstall' opts $ Right nmver++uninstall' :: [Option] -> Either PkgInfo [String] -> IO ()+uninstall' opts ex = 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_ (purge doit opts . pairNameOfPkgInfo) sortedPkgs+ pkgi <- case ex of+ Right nmver -> lookupPkg nmver userDB+ Left pkgi' -> return $ pkgi'+ let sortedPkgs = topSortedPkgs pkgi 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_ (purge doit opts) sortedPkgs+ -- If "delete -r" removes a sub libraries of a package+ -- which exports multiple libraries, we need to delete the+ -- main library. Otherwise, DB gets inconsistency.+ when doit $ do+ -- DB is not updated. So, if doit is False, this may+ -- result in infinite loop, sigh.+ let sourceLibs = map Left $ concatMap (findSourceLib userDB) sortedPkgs+ mapM_ (uninstall' opts) sourceLibs where onlyOne = OptRecursive `notElem` opts doit = OptNoharm `notElem` opts -purge :: Bool -> [Option] -> (String,String) -> IO ()-purge doit opts (name,ver) = do--- putStrLn $ "Deleting " ++ name ++ " " ++ ver+purge :: Bool -> [Option] -> PkgInfo -> IO ()+purge doit opts pkgInfo = do sandboxOpts <- (makeOptList . getSandboxOpts2) <$> getSandbox- libdirs <- queryGhcPkg sandboxOpts "library-dirs"- haddoc <- cutTrailing "html" `fmap` queryGhcPkg sandboxOpts "haddock-html"- unregister doit opts (name,ver)- putStrLn $ unwords ["Deleting dirs:", libdirs, haddoc]- when doit . void . system . unwords $ ["rm -rf ", libdirs, haddoc]+ dirs <- getDirs nameVer sandboxOpts+ unregister doit opts nameVer+ mapM_ unregisterInternal $ findInternalLibs pkgInfo name+ mapM_ (removeDir doit) dirs where+ unregisterInternal subname = unregister doit opts (subname, ver)+ nameVer@(name, ver) = pairNameOfPkgInfo pkgInfo makeOptList "" = []- makeOptList x = [x]- queryGhcPkg sandboxOpts field = do- let options = ["field"] ++ sandboxOpts ++ [name ++ "-" ++ ver, field]- (!!1) . words <$> readProcess "ghc-pkg" options ""- cutTrailing suffix s- | suffix `isSuffixOf` s = reverse . drop (length suffix) . reverse $ s- | otherwise = s+ makeOptList x = [x] -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+getDirs :: (String, String) -> [String] -> IO [FilePath]+getDirs (name, ver) sandboxOpts = do+ importDirs <- queryGhcPkg "import-dirs"+ haddock <- map docDir <$> queryGhcPkg "haddock-html"+ return $ topDir $ importDirs ++ haddock where+ nameVer = name ++ "-" ++ ver+ queryGhcPkg field = do+ let options = ["field"] ++ sandboxOpts ++ [nameVer, field]+ ws <- words <$> readProcess "ghc-pkg" options ""+ return $ case ws of+ [] -> []+ (_ : xs) -> xs+ docDir dir+ | takeFileName dir == "html" = takeDirectory dir+ | otherwise = dir+ topDir [] = []+ topDir ds@(dir : _)+ | takeFileName top == nameVer = top : ds+ | otherwise = ds+ where+ top = takeDirectory dir++removeDir :: Bool -> FilePath -> IO ()+removeDir doit dir = do+ exist <- doesDirectoryExist dir+ when exist $ do+ putStrLn $ "Deleting " ++ dir+ when doit $ removeDirectoryRecursive dir++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 ----------------------------------------------------------------@@ -154,8 +225,11 @@ revdeps :: FunctionCommand revdeps nmver opts _ = printDepends nmver opts printRevDeps -printDepends :: [String] -> [Option]- -> (Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()) -> IO ()+printDepends+ :: [String]+ -> [Option]+ -> (Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ())+ -> IO () printDepends nmver opts func = do db' <- getSandbox >>= getPkgDB pkg <- lookupPkg nmver db'@@ -169,13 +243,13 @@ lookupPkg :: [String] -> PkgDB -> IO PkgInfo lookupPkg [] _ = do- hPutStrLn stderr "Package name must be specified."- exitFailure+ 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 [name, ver] db = checkOne $ lookupByVersion name ver db lookupPkg _ _ = do- hPutStrLn stderr "Only one package name must be specified."- exitFailure+ hPutStrLn stderr "Only one package name must be specified."+ exitFailure checkOne :: [PkgInfo] -> IO PkgInfo checkOne [] = do@@ -190,17 +264,17 @@ ---------------------------------------------------------------- initSandbox :: FunctionCommand-initSandbox [] _ _ = void . system $ "cabal sandbox init"-initSandbox [path] _ _ = void . system $ "cabal sandbox init --sandbox " ++ path-initSandbox _ _ _ = do+initSandbox [] _ _ = void . system $ "cabal v1-sandbox init"+initSandbox [path] _ _ = void . system $ "cabal v1-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+add [src] _ _ = void . system $ "cabal v1-sandbox add-source " ++ src+add _ _ _ = do hPutStrLn stderr "A source path be specified." exitFailure @@ -209,4 +283,6 @@ ghci :: FunctionCommand ghci args _ options = do sbxOpts <- getSandboxOpts <$> getSandbox- void $ system $ "ghci" ++ " " ++ sbxOpts ++ " " ++ intercalate " " (options ++ args)+ void $+ system $+ "ghci" ++ " " ++ sbxOpts ++ " " ++ intercalate " " (options ++ args)
Distribution/Cab/GenPaths.hs view
@@ -2,52 +2,58 @@ module Distribution.Cab.GenPaths (genPaths) where -import Control.Applicative import Control.Exception import Control.Monad import Data.List (isSuffixOf)-import Distribution.Package-import Distribution.PackageDescription-import Distribution.PackageDescription.Parse (readPackageDescription)+import Distribution.Cab.Utils (readGenericPackageDescription, unPackageName)+import Distribution.Package (pkgName, pkgVersion)+import Distribution.PackageDescription (package, packageDescription) import Distribution.Verbosity (silent) import Distribution.Version import System.Directory genPaths :: IO () genPaths = do- (nm,ver) <- getCabalFile >>= getNameVersion+ (nm, ver) <- getCabalFile >>= getNameVersion let file = "Paths_" ++ nm ++ ".hs" check file >> do putStrLn $ "Writing " ++ file ++ "..."- writeFile file $ "module Paths_" ++ nm ++ " where\n"- ++ "import Data.Version\n"- ++ "\n"- ++ "version :: Version\n"- ++ "version = " ++ show ver ++ "\n"+ writeFile file $+ "module Paths_"+ ++ nm+ ++ " where\n"+ ++ "import Data.Version\n"+ ++ "\n"+ ++ "version :: Version\n"+ ++ "version = "+ ++ show ver+ ++ "\n" where check file = do exist <- doesFileExist file when exist . throwIO . userError $ file ++ " already exists" -getNameVersion :: FilePath -> IO (String,Version)+getNameVersion :: FilePath -> IO (String, Version) getNameVersion file = do- desc <- readPackageDescription silent file+ desc <- readGenericPackageDescription silent file let pkg = package . packageDescription $ desc- PackageName nm = pkgName pkg+ nm = unPackageName $ pkgName pkg name = map (trans '-' '_') nm version = pkgVersion pkg return (name, version) where trans c1 c2 c- | c == c1 = c2- | otherwise = c+ | c == c1 = c2+ | otherwise = c getCabalFile :: IO FilePath getCabalFile = do- cnts <- (filter isCabal <$> getDirectoryContents ".")+ cnts <-+ (filter isCabal <$> getDirectoryContents ".") >>= filterM doesFileExist case cnts of- [] -> throwIO $ userError "Cabal file does not exist"- cfile:_ -> return cfile+ [] -> throwIO $ userError "Cabal file does not exist"+ cfile : _ -> return cfile where+ isCabal :: String -> Bool isCabal nm = ".cabal" `isSuffixOf` nm && length nm > 6
Distribution/Cab/PkgDB.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Distribution.Cab.PkgDB ( -- * Types PkgDB@@ -18,25 +19,52 @@ , fullNameOfPkgInfo , pairNameOfPkgInfo , verOfPkgInfo+ -- * Find other libraries+ , findInternalLibs+ , findSourceLib ) where -import Distribution.Cab.Utils (fromDotted)+import Distribution.Cab.Utils+ (fromDotted, installedUnitId, mkPackageName, unPackageName) import Distribution.Cab.Version import Distribution.Cab.VerDB (PkgName)-import Distribution.Version (Version(..)) import Distribution.InstalledPackageInfo- (InstalledPackageInfo_(..), InstalledPackageInfo)-import Distribution.Package (PackageName(..), PackageIdentifier(..))+ (InstalledPackageInfo(depends), sourcePackageId, sourceLibName)+import Distribution.Package (PackageIdentifier(..))+#if MIN_VERSION_Cabal(3,14,0)+import Distribution.Simple.Compiler (PackageDB, PackageDBX(..))+#else import Distribution.Simple.Compiler (PackageDB(..))+#endif import Distribution.Simple.GHC (configure, getInstalledPackages, getPackageDBContents) import Distribution.Simple.PackageIndex- (lookupPackageName, lookupSourcePackageId- , allPackages, fromList, reverseDependencyClosure- , topologicalOrder, PackageIndex)+ (lookupPackageName, lookupSourcePackageId, allPackages+ , fromList, reverseDependencyClosure, topologicalOrder)+#if MIN_VERSION_Cabal(1,22,0)+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+#else+import Distribution.Simple.PackageIndex (PackageIndex)+#endif import Distribution.Simple.Program.Db (defaultProgramDb)+import Distribution.Types.LibraryName+import Distribution.Types.UnitId (unUnitId)+import Distribution.Types.UnqualComponentName (unUnqualComponentName) import Distribution.Verbosity (normal) +#if MIN_VERSION_Cabal(3,14,0)+import Distribution.Utils.Path (makeSymbolicPath)+#endif++import Data.Char+import Data.Maybe++----------------------------------------------------------------++#if MIN_VERSION_Cabal(1,22,0)+type PkgDB = InstalledPackageIndex+#else type PkgDB = PackageIndex+#endif type PkgInfo = InstalledPackageInfo ----------------------------------------------------------------@@ -61,17 +89,33 @@ toUserSpec :: Maybe FilePath -> PackageDB toUserSpec Nothing = UserPackageDB+#if MIN_VERSION_Cabal(3,14,0)+toUserSpec (Just path) = SpecificPackageDB $ makeSymbolicPath path+#else toUserSpec (Just path) = SpecificPackageDB path+#endif -getDBs :: [PackageDB] -> IO PackageIndex+getDBs :: [PackageDB] -> IO PkgDB getDBs specs = do- (_,_,pro) <- configure normal Nothing Nothing defaultProgramDb- getInstalledPackages normal specs pro+ (_comp,_,pro) <- configure normal Nothing Nothing defaultProgramDb+ getInstalledPackages normal+#if MIN_VERSION_Cabal(1,23,0)+ _comp+#endif+#if MIN_VERSION_Cabal(3,14,0)+ Nothing+#endif+ specs pro -getDB :: PackageDB -> IO PackageIndex+getDB :: PackageDB -> IO PkgDB getDB spec = do (_,_,pro) <- configure normal Nothing Nothing defaultProgramDb- getPackageDBContents normal spec pro+ getPackageDBContents+ normal+#if MIN_VERSION_Cabal(3,14,0)+ Nothing+#endif+ spec pro ---------------------------------------------------------------- @@ -80,7 +124,7 @@ -- > pkgdb <- getGlobalPkgDB -- > lookupByName "base" pkgdb lookupByName :: PkgName -> PkgDB -> [PkgInfo]-lookupByName name db = concatMap snd $ lookupPackageName db (PackageName name)+lookupByName name db = concatMap snd $ lookupPackageName db (mkPackageName name) -- | --@@ -90,11 +134,8 @@ lookupByVersion name ver db = lookupSourcePackageId db src where src = PackageIdentifier {- pkgName = PackageName name- , pkgVersion = Version {- versionBranch = fromDotted ver- , versionTags = []- }+ pkgName = mkPackageName name+ , pkgVersion = toVersion $ fromDotted ver } ----------------------------------------------------------------@@ -105,9 +146,11 @@ ---------------------------------------------------------------- nameOfPkgInfo :: PkgInfo -> PkgName-nameOfPkgInfo = toString . pkgName . sourcePackageId+nameOfPkgInfo pkgi = case sourceLibName pkgi of+ LMainLibName -> name+ LSubLibName sub -> libNameHack name $ unUnqualComponentName sub where- toString (PackageName x) = x+ name = unPackageName $ pkgName $ sourcePackageId pkgi fullNameOfPkgInfo :: PkgInfo -> String fullNameOfPkgInfo pkgi = nameOfPkgInfo pkgi ++ " " ++ verToString (verOfPkgInfo pkgi)@@ -121,7 +164,42 @@ ---------------------------------------------------------------- topSortedPkgs :: PkgInfo -> PkgDB -> [PkgInfo]-topSortedPkgs pkgi db = topSort $ pkgids [pkgi]+topSortedPkgs pkgi db = topSort $ unitids [pkgi] where- pkgids = map installedPackageId+ unitids = map installedUnitId topSort = topologicalOrder . fromList . reverseDependencyClosure db++----------------------------------------------------------------++findInternalLibs :: PkgInfo -> String -> [String]+findInternalLibs pkgInfo name = map (libNameHack name) $+ catMaybes $ map (getInternalLib . unUnitId) $ depends pkgInfo++getInternalLib :: String -> Maybe String+getInternalLib xs0 = case drop 22 $ skip xs0 of+ _:xs1 -> Just xs1+ _ -> Nothing+ where+ skip ys = case break (== '-') ys of+ (_,'-':b:bs)+ | isDigit b -> case break (== '-') bs of+ (_,'-':ds) -> ds+ _ -> "" -- error+ | otherwise -> skip bs+ _ -> "" -- error+++----------------------------------------------------------------++-- A cabal package can exports multiple libraries.+findSourceLib :: PkgDB -> PkgInfo -> [PkgInfo]+findSourceLib db pkgi = case sourceLibName pkgi of+ -- Only one library is exported.+ LMainLibName -> []+ -- This is a sub library. Need to find a main(source) library.+ LSubLibName _ -> lookupSourcePackageId db $ sourcePackageId pkgi++----------------------------------------------------------------++libNameHack :: String -> String -> String+libNameHack name subname = "z-" ++ name ++ "-z-" ++ subname
Distribution/Cab/Printer.hs view
@@ -1,33 +1,39 @@+{-# LANGUAGE CPP #-}+ module Distribution.Cab.Printer (- printDeps- , printRevDeps- , extraInfo- ) where+ printDeps,+ printRevDeps,+ extraInfo,+) where import Control.Monad import Data.Function import Data.List-import Data.Map (Map)-import qualified Data.Map as M+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M import Distribution.Cab.PkgDB+import Distribution.Cab.Utils (UnitId, installedUnitId, lookupUnitId) import Distribution.Cab.Version-import Distribution.InstalledPackageInfo (InstalledPackageInfo_(..))-import Distribution.License (License(..))-import Distribution.Package (InstalledPackageId)-import Distribution.Simple.PackageIndex (lookupInstalledPackageId, allPackages)+import Distribution.InstalledPackageInfo (author, depends, license)+import Distribution.License (License (..))+import Distribution.Simple.PackageIndex (allPackages) +#if MIN_VERSION_Cabal(2,2,0)+import Distribution.License (licenseFromSPDX)+#endif+ ---------------------------------------------------------------- -type RevDB = Map InstalledPackageId [InstalledPackageId]+type RevDB = Map UnitId [UnitId] makeRevDepDB :: PkgDB -> RevDB makeRevDepDB db = M.fromList revdeps where pkgs = allPackages db deps = map idDeps pkgs- idDeps pkg = (installedPackageId pkg, depends pkg)+ idDeps pkg = (installedUnitId pkg, depends pkg) kvs = sort $ concatMap decomp deps- decomp (k,vs) = map (\v -> (v,k)) vs+ decomp (k, vs) = map (\v -> (v, k)) vs kvss = groupBy ((==) `on` fst) kvs comp xs = (fst (head xs), map snd xs) revdeps = map comp kvss@@ -37,14 +43,14 @@ printDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO () printDeps rec info db n pkgi = mapM_ (printDep rec info db n) $ depends pkgi -printDep :: Bool -> Bool -> PkgDB -> Int -> InstalledPackageId -> IO ()-printDep rec info db n pid = case lookupInstalledPackageId db pid of- Nothing -> return ()- Just pkgi -> do- putStr $ prefix ++ fullNameOfPkgInfo pkgi- extraInfo info pkgi+printDep :: Bool -> Bool -> PkgDB -> Int -> UnitId -> IO ()+printDep rec info db n uid = case lookupUnitId db uid of+ Nothing -> return ()+ Just uniti -> do+ putStr $ prefix ++ fullNameOfPkgInfo uniti+ extraInfo info uniti putStrLn ""- when rec $ printDeps rec info db (n+1) pkgi+ when rec $ printDeps rec info db (n + 1) uniti where prefix = replicate (n * 4) ' ' @@ -56,20 +62,20 @@ revdb = makeRevDepDB db printRevDeps' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> PkgInfo -> IO ()-printRevDeps' rec info db revdb n pkgi = case M.lookup pkgid revdb of+printRevDeps' rec info db revdb n pkgi = case M.lookup unitid revdb of Nothing -> return ()- Just pkgids -> mapM_ (printRevDep' rec info db revdb n) pkgids+ Just unitids -> mapM_ (printRevDep' rec info db revdb n) unitids where- pkgid = installedPackageId pkgi+ unitid = installedUnitId pkgi -printRevDep' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> InstalledPackageId -> IO ()-printRevDep' rec info db revdb n pid = case lookupInstalledPackageId db pid of- Nothing -> return ()- Just pkgi -> do- putStr $ prefix ++ fullNameOfPkgInfo pkgi- extraInfo info pkgi+printRevDep' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> UnitId -> IO ()+printRevDep' rec info db revdb n uid = case lookupUnitId db uid of+ Nothing -> return ()+ Just uniti -> do+ putStr $ prefix ++ fullNameOfPkgInfo uniti+ extraInfo info uniti putStrLn ""- when rec $ printRevDeps' rec info db revdb (n+1) pkgi+ when rec $ printRevDeps' rec info db revdb (n + 1) uniti where prefix = replicate (n * 4) ' ' @@ -77,15 +83,22 @@ extraInfo :: Bool -> PkgInfo -> IO () extraInfo False _ = return ()-extraInfo True pkgi = putStr $ " " ++ lcns ++ " \"" ++ auth ++ "\""+extraInfo True pkgi = putStr $ " " ++ lcns ++ " \"" ++ show auth ++ "\"" where- lcns = showLicense (license pkgi)+ lcns = showLicense (pkgInfoLicense pkgi) auth = author pkgi +pkgInfoLicense :: PkgInfo -> License+#if MIN_VERSION_Cabal(2,2,0)+pkgInfoLicense = either licenseFromSPDX id . license+#else+pkgInfoLicense = license+#endif+ showLicense :: License -> String-showLicense (GPL (Just v)) = "GPL" ++ versionToString v-showLicense (GPL Nothing) = "GPL"-showLicense (LGPL (Just v)) = "LGPL" ++ versionToString v-showLicense (LGPL Nothing) = "LGPL"+showLicense (GPL (Just v)) = "GPL" ++ versionToString v+showLicense (GPL Nothing) = "GPL"+showLicense (LGPL (Just v)) = "LGPL" ++ versionToString v+showLicense (LGPL Nothing) = "LGPL" showLicense (UnknownLicense s) = s-showLicense x = show x+showLicense x = show x
Distribution/Cab/Sandbox.hs view
@@ -1,17 +1,16 @@ {-# LANGUAGE BangPatterns #-} module Distribution.Cab.Sandbox (- getSandbox- , getSandboxOpts- , getSandboxOpts2- ) where+ getSandbox,+ getSandboxOpts,+ getSandboxOpts2,+) where -import Control.Applicative ((<$>))-import Control.Exception as E (catch, SomeException, throwIO)+import Control.Exception as E (SomeException, catch, throwIO) import Data.Char (isSpace) import Data.List (isPrefixOf, tails)-import System.Directory (getCurrentDirectory, doesFileExist)-import System.FilePath ((</>), takeDirectory, takeFileName)+import System.Directory (doesFileExist, getCurrentDirectory)+import System.FilePath (takeDirectory, takeFileName, (</>)) ---------------------------------------------------------------- @@ -39,14 +38,16 @@ getSandboxConfigFile dir = do let cfile = dir </> configFile exist <- doesFileExist cfile- if exist then- return cfile- else do- let dir' = takeDirectory dir- if dir == dir' then- throwIO $ userError "sandbox config file not found"- else- getSandboxConfigFile dir'+ if exist+ then+ return cfile+ else do+ let dir' = takeDirectory dir+ if dir == dir'+ then+ throwIO $ userError "sandbox config file not found"+ else+ getSandboxConfigFile dir' -- | Extract a package db directory from the sandbox config file. -- Exception is thrown if the sandbox config file is broken.@@ -70,20 +71,22 @@ -- >>> getSandboxOpts (Just "/path/.cabal-sandbox/i386-osx-ghc-7.4.1-packages.conf.d") -- "-package-conf /path/.cabal-sandbox/i386-osx-ghc-7.4.1-packages.conf.d" getSandboxOpts :: Maybe FilePath -> String-getSandboxOpts Nothing = ""+getSandboxOpts Nothing = "" getSandboxOpts (Just path) = pkgOpt ++ path where ghcver = extractGhcVer path- pkgOpt | ghcver >= 706 = "-package-db "- | otherwise = "-package-conf "+ pkgOpt+ | ghcver >= 706 = "-package-db "+ | otherwise = "-package-conf " getSandboxOpts2 :: Maybe FilePath -> String-getSandboxOpts2 Nothing = ""+getSandboxOpts2 Nothing = "" getSandboxOpts2 (Just path) = pkgOpt ++ "=" ++ path where ghcver = extractGhcVer path- pkgOpt | ghcver >= 706 = "--package-db"- | otherwise = "--package-conf"+ pkgOpt+ | ghcver >= 706 = "--package-db"+ | otherwise = "--package-conf" -- | Extracting GHC version from the path of package db. -- Exception is thrown if the string argument is incorrect.@@ -95,6 +98,6 @@ where file = takeFileName dir findVer = drop 4 . head . filter ("ghc-" `isPrefixOf`) . tails- (verStr1,_:left) = break (== '.') $ findVer file- (verStr2,_) = break (== '.') left+ (verStr1, left) = break (== '.') $ findVer file+ (verStr2, _) = break (== '.') $ tail left ver = read verStr1 * 100 + read verStr2
Distribution/Cab/Utils.hs view
@@ -1,18 +1,123 @@+{-# LANGUAGE CPP #-}+ module Distribution.Cab.Utils where import Data.List +import Distribution.InstalledPackageInfo (InstalledPackageInfo)+import Distribution.Package (PackageName)+import Distribution.PackageDescription (GenericPackageDescription)+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Verbosity (Verbosity)++#if MIN_VERSION_Cabal(1,21,0) && !(MIN_VERSION_Cabal(1,23,0))+import Distribution.Package (PackageInstalled)+#endif++#if MIN_VERSION_Cabal(1,23,0)+import qualified Distribution.InstalledPackageInfo as Cabal+ (installedUnitId)+import qualified Distribution.Package as Cabal (UnitId)+import qualified Distribution.Simple.PackageIndex as Cabal+ (lookupUnitId)+#else+import qualified Distribution.InstalledPackageInfo as Cabal+ (installedPackageId)+import qualified Distribution.Package as Cabal (InstalledPackageId)+import qualified Distribution.Simple.PackageIndex as Cabal+ (lookupInstalledPackageId)+#endif++#if MIN_VERSION_Cabal(2,0,0)+import qualified Distribution.Package as Cabal+ (mkPackageName, unPackageName)+#else+import qualified Distribution.Package as Cabal (PackageName(..))+#endif++#if MIN_VERSION_Cabal(3,14,0)+import qualified Distribution.Simple.PackageDescription as Cabal+ (readGenericPackageDescription)+import Distribution.Utils.Path (makeSymbolicPath)+#elif MIN_VERSION_Cabal(3,8,0)+import qualified Distribution.Simple.PackageDescription as Cabal+ (readGenericPackageDescription)+#elif MIN_VERSION_Cabal(2,2,0)+import qualified Distribution.PackageDescription.Parsec as Cabal+ (readGenericPackageDescription)+#elif MIN_VERSION_Cabal(2,0,0)+import qualified Distribution.PackageDescription.Parse as Cabal+ (readGenericPackageDescription)+#else+import qualified Distribution.PackageDescription.Parse as Cabal+ (readPackageDescription)+#endif+ -- | -- >>> fromDotted "1.2.3" -- [1,2,3] fromDotted :: String -> [Int] fromDotted [] = []-fromDotted xs = case break (=='.') xs of- (x,"") -> [read x :: Int]- (x,_:ys) -> (read x :: Int) : fromDotted ys+fromDotted xs = case break (== '.') xs of+ (x, "") -> [read x :: Int]+ (x, _ : ys) -> (read x :: Int) : fromDotted ys -- | -- >>> toDotted [1,2,3] -- "1.2.3" toDotted :: [Int] -> String toDotted = intercalate "." . map show++-- UnitIds++#if MIN_VERSION_Cabal(1,23,0)+type UnitId = Cabal.UnitId+#else+type UnitId = Cabal.InstalledPackageId+#endif++installedUnitId :: InstalledPackageInfo -> UnitId+#if MIN_VERSION_Cabal(1,23,0)+installedUnitId = Cabal.installedUnitId+#else+installedUnitId = Cabal.installedPackageId+#endif++#if MIN_VERSION_Cabal(1,23,0)+lookupUnitId :: PackageIndex a -> UnitId -> Maybe a+lookupUnitId = Cabal.lookupUnitId+#elif MIN_VERSION_Cabal(1,21,0)+lookupUnitId :: PackageInstalled a => PackageIndex a -> UnitId -> Maybe a+lookupUnitId = Cabal.lookupInstalledPackageId+#else+lookupUnitId :: PackageIndex -> UnitId -> Maybe InstalledPackageInfo+lookupUnitId = Cabal.lookupInstalledPackageId+#endif++-- PackageNames++mkPackageName :: String -> PackageName+#if MIN_VERSION_Cabal(2,0,0)+mkPackageName = Cabal.mkPackageName+#else+mkPackageName = Cabal.PackageName+#endif++unPackageName :: PackageName -> String+#if MIN_VERSION_Cabal(2,0,0)+unPackageName = Cabal.unPackageName+#else+unPackageName (Cabal.PackageName s) = s+#endif++-- GenericPackageDescription++readGenericPackageDescription+ :: Verbosity -> FilePath -> IO GenericPackageDescription+#if MIN_VERSION_Cabal(3,14,0)+readGenericPackageDescription v fp = Cabal.readGenericPackageDescription v Nothing $ makeSymbolicPath fp+#elif MIN_VERSION_Cabal(2,0,0)+readGenericPackageDescription = Cabal.readGenericPackageDescription+#else+readGenericPackageDescription = Cabal.readPackageDescription+#endif
Distribution/Cab/VerDB.hs view
@@ -1,25 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} module Distribution.Cab.VerDB (- -- * Types- PkgName- , VerDB- , HowToObtain(..)- -- * Creating- , getVerDB- -- * Converting- , toList- , toMap- ) where+ -- * Types+ PkgName,+ VerDB,+ HowToObtain (..), + -- * Creating+ getVerDB,++ -- * Converting+ toList,+ toMap,+) where+ import Control.Applicative import Control.Arrow (second)+import Control.Monad.Trans.Resource (runResourceT) import Data.Attoparsec.ByteString.Char8-import Data.Conduit import Data.Conduit.Attoparsec import Data.Conduit.Process-import Data.Map (Map)-import qualified Data.Map as M+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M import Data.Maybe import Distribution.Cab.Version @@ -29,7 +31,7 @@ type VerInfo = (PkgName, Maybe [Int]) -newtype VerDB = VerDB [(PkgName,Ver)] deriving (Eq, Show)+newtype VerDB = VerDB [(PkgName, Ver)] deriving (Eq, Show) data HowToObtain = InstalledOnly | AllRegistered @@ -41,8 +43,8 @@ script = case how of InstalledOnly -> "cabal list --installed" AllRegistered -> "cabal list"- verInfos = runResourceT $ sourceCmd script $$ cabalListParser- justOnly = map (second (toVer . fromJust)) . filter (isJust . snd)+ verInfos = runResourceT $ sourceCmdWithConsumer script cabalListParser+ justOnly = map (second (toVer . fromJust)) . filter (isJust . snd) . snd cabalListParser = sinkParser verinfos ----------------------------------------------------------------@@ -73,15 +75,18 @@ endOfLine return (name, lat) where- latestLabel = string " Default available version: " -- cabal 0.10- <|> string " Latest version available: " -- cabal 0.8+ latestLabel =+ string " Default available version: " -- cabal 0.10+ <|> string " Latest version available: " -- cabal 0.8 skip = many1 nonEols *> endOfLine- synpsis = string " Synopsis:" *> nonEols *> endOfLine *> more- <|> return ()+ synpsis =+ string " Synopsis:" *> nonEols *> endOfLine *> more+ <|> return () where more = () <$ many (string " " *> nonEols *> endOfLine)- latest = Nothing <$ (char '[' *> nonEols)- <|> Just <$> dotted+ latest =+ Nothing <$ (char '[' *> nonEols)+ <|> Just <$> dotted dotted :: Parser [Int] dotted = decimal `sepBy` char '.'
Distribution/Cab/Version.hs view
@@ -1,16 +1,19 @@+{-# LANGUAGE CPP #-}+ module Distribution.Cab.Version (- Ver- , toVer- , verToString- , version- , versionToString- ) where+ Ver,+ toVer,+ toVersion,+ verToString,+ version,+ versionToString,+) where import Distribution.Cab.Utils-import Distribution.Version (Version(..))+import Distribution.Version -- | Package version.-newtype Ver = Ver [Int] deriving (Eq,Show)+newtype Ver = Ver [Int] deriving (Eq, Ord, Read, Show) -- | Creating 'Ver'. --@@ -19,6 +22,14 @@ toVer :: [Int] -> Ver toVer is = Ver is +-- | Creating 'Version' in Cabal.+toVersion :: [Int] -> Version+#if MIN_VERSION_Cabal(2,0,0)+toVersion is = mkVersion is+#else+toVersion is = Version is []+#endif+ -- | From 'Version' to 'String' -- -- >>> verToString $ toVer [1,2,3]@@ -28,16 +39,18 @@ -- | From 'Version' in Cabal to 'Ver'. ----- >>> version $ Version [1,2,3] []+-- >>> version $ toVersion [1,2,3] -- Ver [1,2,3] version :: Version -> Ver+#if MIN_VERSION_Cabal(2,0,0)+version = Ver . versionNumbers+#else version = Ver . versionBranch+#endif -- | From 'Version' in Cabal to 'String'. ----- >>> versionToString $ Version [1,2,3] []+-- >>> versionToString $ toVersion [1,2,3] -- "1.2.3" versionToString :: Version -> String versionToString = verToString . version--
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
cab.cabal view
@@ -1,85 +1,81 @@-Name: cab-Version: 0.2.9-Author: Kazu Yamamoto <kazu@iij.ad.jp>-Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>-License: BSD3-License-File: LICENSE-Synopsis: A maintenance command of Haskell cabal packages-Description: This is a MacPorts-like maintenance command of- Haskell cabal packages. Some part of this program is a wrapper to- "ghc-pkg" and "cabal".- If you are always confused due to inconsistency of two commands,- or if you want a way to check all outdated packages,- or if you want a way to remove outdated packages recursively,- this command helps you.-Homepage: http://www.mew.org/~kazu/proj/cab/-Category: Distribution-Cabal-Version: >= 1.10-Build-Type: Simple+cabal-version: >=1.10+name: cab+version: 0.2.22+license: BSD3+license-file: LICENSE+maintainer: Kazu Yamamoto <kazu@iij.ad.jp>+author: Kazu Yamamoto <kazu@iij.ad.jp>+homepage: http://www.mew.org/~kazu/proj/cab/+synopsis: A maintenance command of Haskell cabal packages+description:+ This is a MacPorts-like maintenance command of+ Haskell cabal packages. Some part of this program is a wrapper to+ "ghc-pkg" and "cabal".+ If you are always confused due to inconsistency of two commands,+ or if you want a way to check all outdated packages,+ or if you want a way to remove outdated packages recursively,+ this command helps you. -Library- Default-Language: Haskell2010- GHC-Options: -Wall- Build-Depends: base >= 4.0 && < 5- , Cabal- , attoparsec >= 0.10- , attoparsec-conduit >= 0.3- , bytestring- , conduit >= 0.3- , containers- , directory- , filepath- , process- , process-conduit >= 0.1- Exposed-Modules: Distribution.Cab- Distribution.Cab.PkgDB- Distribution.Cab.Printer- Distribution.Cab.Sandbox- Distribution.Cab.VerDB- Distribution.Cab.Version- Other-Modules: Distribution.Cab.Commands- Distribution.Cab.GenPaths- Distribution.Cab.Utils+category: Distribution+build-type: Simple -Executable cab- Default-Language: Haskell2010- Main-Is: Main.hs- GHC-Options: -Wall- HS-Source-Dirs: src- Build-Depends: base >= 4.0 && < 5- , cab- , Cabal >= 1.18- , attoparsec >= 0.10- , attoparsec-conduit >= 0.3- , bytestring- , conduit >= 0.3- , containers- , directory- , filepath- , process- , process-conduit >= 0.1- if os(windows)- Build-Depends:- else- Build-Depends: unix- Other-Modules: Commands- Doc- Help- Options- Program- Run- Types- Paths_cab+source-repository head+ type: git+ location: git://github.com/kazu-yamamoto/cab.git --- Test-Suite doctest--- Type: exitcode-stdio-1.0--- Default-Language: Haskell2010--- HS-Source-Dirs: test--- Ghc-Options: -threaded -Wall--- Main-Is: doctests.hs--- Build-Depends: base--- , doctest >= 0.9.3+library+ exposed-modules:+ Distribution.Cab+ Distribution.Cab.PkgDB+ Distribution.Cab.Printer+ Distribution.Cab.Sandbox+ Distribution.Cab.VerDB+ Distribution.Cab.Version -Source-Repository head- Type: git- Location: git://github.com/kazu-yamamoto/cab.git+ other-modules:+ Distribution.Cab.Commands+ Distribution.Cab.GenPaths+ Distribution.Cab.Utils++ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.0 && <5,+ Cabal >=1.18,+ attoparsec >=0.10,+ bytestring,+ conduit >=1.1,+ conduit-extra >=1.1.2,+ containers,+ directory,+ filepath,+ process,+ resourcet++executable cab+ main-is: Main.hs+ hs-source-dirs: src+ other-modules:+ Commands+ Doc+ Help+ Options+ Program+ Run+ Types+ Paths_cab++ default-language: Haskell2010+ ghc-options: -Wall -threaded+ build-depends:+ base >=4.0 && <5,+ cab,+ Cabal >=1.18,+ attoparsec >=0.10,+ bytestring,+ conduit >=1.1,+ conduit-extra >=1.1.2,+ containers,+ directory,+ filepath,+ process
src/Commands.hs view
@@ -7,223 +7,257 @@ ---------------------------------------------------------------- commandDB :: FunctionCommand -> [CommandSpec]-commandDB help = [- CommandSpec {- command = Sync- , commandNames = ["sync", "update"]- , document = "Fetch the latest package index"- , routing = RouteCabal ["update"]- , switches = []- , manual = Nothing- }- , CommandSpec {- command = Install- , commandNames = ["install"]- , document = "Install packages"- , routing = RouteCabal ["install"]- , switches = [(SwNoharm, Solo "--dry-run -v")- ,(SwFlag, WithEqArg "--flags")- ,(SwTest, Solo "--enable-tests")- ,(SwBench, Solo "--enable-benchmarks")- ,(SwDepsOnly, Solo "--only-dependencies")- ,(SwLibProfile, Solo "--enable-library-profiling --ghc-options=\"-fprof-auto -fprof-cafs\"")- ,(SwExecProfile, Solo "--enable-executable-profiling --ghc-options=\"-fprof-auto -fprof-cafs\"")- ,(SwJobs, WithEqArg "--jobs")- ,(SwStatic, Solo "--disable-shared")- ]- , manual = Just "[<package> [<ver>]]"- }- , CommandSpec {- command = Uninstall- , commandNames = ["uninstall", "delete", "remove", "unregister"]- , document = "Uninstall packages"- , routing = RouteFunc uninstall- , switches = [(SwNoharm, None)- ,(SwRecursive, None)- ] -- don't allow SwAll- , manual = Just "<package> [<ver>]"- }- , CommandSpec {- command = Installed- , commandNames = ["installed", "list"]- , document = "List installed packages"- , routing = RouteFunc installed- , switches = [(SwAll, None)- ,(SwRecursive, None)- ,(SwInfo, None)- ]- , manual = Nothing- }- , CommandSpec {- command = Configure- , commandNames = ["configure", "conf"]- , document = "Configure a cabal package"- , routing = RouteCabal ["configure"]- , switches = [(SwFlag, WithEqArg "--flags")- ,(SwTest, Solo "--enable-tests")- ,(SwBench, Solo "--enable-benchmarks")- ,(SwLibProfile, Solo "--enable-library-profiling --ghc-options=\"-fprof-auto -fprof-cafs\"")- ,(SwExecProfile, Solo "--enable-executable-profiling --ghc-options=\"-fprof-auto -fprof-cafs\"")- ,(SwStatic, Solo "--disable-shared")- ]- , manual = Nothing- }- , CommandSpec {- command = Build- , commandNames = ["build"]- , document = "Build a cabal package"- , routing = RouteCabal ["build"]- , switches = [(SwJobs, WithEqArg "--jobs")]- , manual = Nothing- }- , CommandSpec {- command = Clean- , commandNames = ["clean"]- , document = "Clean up a build directory"- , routing = RouteCabal ["clean"]- , switches = []- , manual = Nothing- }- , CommandSpec {- command = Outdated- , commandNames = ["outdated"]- , document = "Display outdated packages"- , routing = RouteFunc outdated- , switches = [(SwAll, None)]- , manual = Nothing- }- , CommandSpec {- command = Info- , commandNames = ["info"]- , document = "Display information of a package"- , routing = RouteCabal ["info"]- , switches = []- , manual = Just "<package> [<ver>]"- }- , CommandSpec {- command = Sdist- , commandNames = ["sdist", "pack"]- , document = "Make tar.gz for source distribution"- , routing = RouteCabal ["sdist"]- , switches = []- , manual = Nothing- }- , CommandSpec {- command = Upload- , commandNames = ["upload", "up"]- , document = "Uploading tar.gz to HackageDB"- , routing = RouteCabal ["upload"]- , switches = [(SwNoharm, Solo "-c")]- , manual = Nothing- }- , CommandSpec {- command = Unpack- , commandNames = ["unpack"]- , document = "Untar a package in the current directory"- , routing = RouteCabal ["unpack"]- , switches = []- , manual = Just "<package> [<ver>]"- }- , CommandSpec {- command = Deps- , commandNames = ["deps"]- , document = "Show dependencies of this package"- , routing = RouteFunc deps- , switches = [(SwRecursive, None)- ,(SwAll, None)- ,(SwInfo, None)- ]- , manual = Just "<package> [<ver>]"- }- , CommandSpec {- command = RevDeps- , commandNames = ["revdeps", "dependents"]- , document = "Show reverse dependencies of this package"- , routing = RouteFunc revdeps- , switches = [(SwRecursive, None)- ,(SwAll, None)- ,(SwInfo, None)- ]- , manual = Just "<package> [<ver>]"- }- , CommandSpec {- command = Check- , commandNames = ["check"]- , document = "Check consistency of packages"- , routing = RouteFunc check- , switches = []- , manual = Nothing- }- , CommandSpec {- command = GenPaths- , commandNames = ["genpaths", "genpath"]- , document = "Generate Paths_<pkg>.hs"- , routing = RouteFunc genpaths- , switches = []- , manual = Nothing- }- , CommandSpec {- command = Search- , commandNames = ["search"]- , document = "Search available packages by package name"- , routing = RouteFunc search- , switches = []- , manual = Just "<key>"- }- , CommandSpec {- command = Add- , commandNames = ["add", "add-source"]- , document = "Add a source directory"- , routing = RouteFunc add- , switches = []- , manual = Just "<source>"- }- , CommandSpec {- command = Test- , commandNames = ["test"]- , document = "Run tests"- , routing = RouteCabal ["test"]- , switches = []- , manual = Just "[testsuite]"- }- , CommandSpec {- command = Bench- , commandNames = ["bench"]- , document = "Run benchmarks"- , routing = RouteCabal ["bench"]- , switches = []- , manual = Nothing- }- , CommandSpec {- command = Doc- , commandNames = ["doc", "haddock", "man"]- , document = "Generate manuals"- , routing = RouteCabal ["haddock", "--hyperlink-source"]- , switches = []- , manual = Nothing- }- , CommandSpec {- command = Ghci- , commandNames = ["ghci", "repl"]- , document = "Run GHCi (with a sandbox)"- , routing = RouteFunc ghci- , switches = [(SwImport, FollowArg "-i")]- , manual = Nothing- }- , CommandSpec {- command = Init- , commandNames = ["init"]- , document = "Initialize a sandbox"- , routing = RouteFunc initSandbox- , switches = []- , manual = Nothing- }- , CommandSpec {- command = Help- , commandNames = ["help"]- , document = "Display the help message of the command"- , routing = RouteFunc help- , switches = []- , manual = Just "[<command>]"- }- ]+commandDB help =+ [ CommandSpec+ { command = Sync+ , commandNames = ["sync", "update"]+ , document = "Fetch the latest package index"+ , routing = RouteCabal ["update"]+ , switches = []+ , manual = Nothing+ }+ , CommandSpec+ { command = Install+ , commandNames = ["install"]+ , document = "Install packages"+ , routing = RouteCabal ["v1-install"]+ , switches =+ [ (SwNoharm, Solo "--dry-run -v")+ , (SwFlag, WithEqArg "--flags")+ , (SwTest, Solo "--enable-tests")+ , (SwBench, Solo "--enable-benchmarks")+ , (SwDepsOnly, Solo "--only-dependencies")+ ,+ ( SwLibProfile+ , Solo "--enable-library-profiling --ghc-options=\"-fprof-auto -fprof-cafs\""+ )+ ,+ ( SwExecProfile+ , Solo "--enable-profiling --ghc-options=\"-fprof-auto -fprof-cafs\""+ )+ , (SwDebug, Solo "--ghc-options=\"-g\"")+ , (SwJobs, WithEqArg "--jobs")+ , (SwStatic, Solo "--disable-shared")+ , (SwAllowNewer, Solo "--allow-newer")+ ]+ , manual = Just "[<package> [<ver>]]"+ }+ , CommandSpec+ { command = Uninstall+ , commandNames = ["uninstall", "delete", "remove", "unregister"]+ , document = "Uninstall packages"+ , routing = RouteFunc uninstall+ , switches =+ [ (SwNoharm, None)+ , (SwRecursive, None)+ ] -- don't allow SwAll+ , manual = Just "<package> [<ver>]"+ }+ , CommandSpec+ { command = Installed+ , commandNames = ["installed", "list"]+ , document = "List installed packages"+ , routing = RouteFunc installed+ , switches =+ [ (SwAll, None)+ , (SwRecursive, None)+ , (SwInfo, None)+ ]+ , manual = Nothing+ }+ , CommandSpec+ { command = Configure+ , commandNames = ["configure", "conf"]+ , document = "Configure a cabal package"+ , routing = RouteCabal ["v1-configure"]+ , switches =+ [ (SwFlag, WithEqArg "--flags")+ , (SwTest, Solo "--enable-tests")+ , (SwBench, Solo "--enable-benchmarks")+ ,+ ( SwLibProfile+ , Solo "--enable-library-profiling --ghc-options=\"-fprof-auto -fprof-cafs\""+ )+ ,+ ( SwExecProfile+ , Solo "--enable-profiling --ghc-options=\"-fprof-auto -fprof-cafs\""+ )+ , (SwDebug, Solo "--ghc-options=\"-g\"")+ , (SwStatic, Solo "--disable-shared")+ , (SwAllowNewer, Solo "--allow-newer")+ ]+ , manual = Nothing+ }+ , CommandSpec+ { command = Build+ , commandNames = ["build"]+ , document = "Build a cabal package"+ , routing = RouteCabal ["v1-build"]+ , switches = [(SwJobs, WithEqArg "--jobs")]+ , manual = Nothing+ }+ , CommandSpec+ { command = Clean+ , commandNames = ["clean"]+ , document = "Clean up a build directory"+ , routing = RouteCabal ["v1-clean"]+ , switches = []+ , manual = Nothing+ }+ , CommandSpec+ { command = Outdated+ , commandNames = ["outdated"]+ , document = "Display outdated packages"+ , routing = RouteFunc outdated+ , switches =+ [ (SwAll, None)+ , (SwFuture, Solo "--future")+ , (SwCleanUp, None)+ ]+ , manual = Nothing+ }+ , CommandSpec+ { command = Info+ , commandNames = ["info"]+ , document = "Display information of a package"+ , routing = RouteCabal ["v1-info"]+ , switches = []+ , manual = Just "<package> [<ver>]"+ }+ , CommandSpec+ { command = Sdist+ , commandNames = ["sdist", "pack"]+ , document = "Make tar.gz for source distribution"+ , routing = RouteCabal ["sdist"]+ , switches = []+ , manual = Nothing+ }+ , CommandSpec+ { command = Upload+ , commandNames = ["upload", "up"]+ , document = "Uploading tar.gz to HackageDB"+ , routing = RouteCabal ["upload", "--publish"]+ , switches = [(SwNoharm, Solo "-c")]+ , manual = Nothing+ }+ , CommandSpec+ { command = Unpack+ , commandNames = ["get", "unpack"]+ , document = "Untar a package in the current directory"+ , routing = RouteCabal ["get"]+ , switches = []+ , manual = Just "<package> [<ver>]"+ }+ , CommandSpec+ { command = Deps+ , commandNames = ["deps"]+ , document = "Show dependencies of this package"+ , routing = RouteFunc deps+ , switches =+ [ (SwRecursive, None)+ , (SwAll, None)+ , (SwInfo, None)+ ]+ , manual = Just "<package> [<ver>]"+ }+ , CommandSpec+ { command = RevDeps+ , commandNames = ["revdeps", "dependents"]+ , document = "Show reverse dependencies of this package"+ , routing = RouteFunc revdeps+ , switches =+ [ (SwRecursive, None)+ , (SwAll, None)+ , (SwInfo, None)+ ]+ , manual = Just "<package> [<ver>]"+ }+ , CommandSpec+ { command = Check+ , commandNames = ["check"]+ , document = "Check consistency of packages"+ , routing = RouteFunc check+ , switches = []+ , manual = Nothing+ }+ , CommandSpec+ { command = GenPaths+ , commandNames = ["genpaths", "genpath"]+ , document = "Generate Paths_<pkg>.hs"+ , routing = RouteFunc genpaths+ , switches = []+ , manual = Nothing+ }+ , CommandSpec+ { command = Search+ , commandNames = ["search"]+ , document = "Search available packages by package name"+ , routing = RouteFunc search+ , switches = []+ , manual = Just "<key>"+ }+ , CommandSpec+ { command = Add+ , commandNames = ["add", "add-source"]+ , document = "Add a source directory"+ , routing = RouteFunc add+ , switches = []+ , manual = Just "<source>"+ }+ , CommandSpec+ { command = Test+ , commandNames = ["test"]+ , document = "Run tests"+ , routing = RouteCabal ["v1-test"]+ , switches = []+ , manual = Just "[testsuite]"+ }+ , CommandSpec+ { command = Bench+ , commandNames = ["bench"]+ , document = "Run benchmarks"+ , routing = RouteCabal ["v1-bench"]+ , switches = []+ , manual = Nothing+ }+ , CommandSpec+ { command = Doc+ , commandNames = ["doc", "haddock", "man"]+ , document = "Generate manuals"+ , routing = RouteCabal ["v1-haddock", "--hyperlink-source"]+ , switches = []+ , manual = Nothing+ }+ , CommandSpec+ { command = Ghci+ , commandNames = ["ghci", "repl"]+ , document = "Run GHCi (with a sandbox)"+ , routing = RouteFunc ghci+ , switches = [(SwImport, FollowArg "-i")]+ , manual = Nothing+ }+ , CommandSpec+ { command = Init+ , commandNames = ["init"]+ , document = "Initialize a sandbox"+ , routing = RouteFunc initSandbox+ , switches = []+ , manual = Nothing+ }+ , CommandSpec+ { command = DocTest+ , commandNames = ["doctest"]+ , document = "Run doctest"+ , routing = RouteCabal ["v1-repl", "--with-ghc=doctest"]+ , switches = []+ , manual = Nothing+ }+ , CommandSpec+ { command = Help+ , commandNames = ["help"]+ , document = "Display the help message of the command"+ , routing = RouteFunc help+ , switches = []+ , manual = Just "[<command>]"+ }+ ]
src/Doc.hs view
@@ -1,54 +1,57 @@ module Doc where import Data.List (intercalate)-import System.Console.GetOpt (OptDescr(..), ArgDescr(..))+import System.Console.GetOpt (ArgDescr (..), OptDescr (..)) import Options import Types commandSpecByName :: String -> CommandDB -> Maybe CommandSpec commandSpecByName _ [] = Nothing-commandSpecByName x (ent:ents)+commandSpecByName x (ent : ents) | x `elem` commandNames ent = Just ent- | otherwise = commandSpecByName x ents+ | otherwise = commandSpecByName x ents ---------------------------------------------------------------- usageDocAlias :: CommandSpec -> (String, String, String)-usageDocAlias cmdspec = (usage,doc,alias)+usageDocAlias cmdspec = (usage, doc, alias) where usage = cmd ++ " " ++ showOptions ++ showArgs doc = document cmdspec alias = showAliases cmdspec- cmd:_ = commandNames cmdspec+ cmd : _ = commandNames cmdspec options = opts cmdspec showOptions- | null options = ""- | otherwise = "[" ++ intercalate "] [" (concatMap (masterOption optionDB) (opts cmdspec)) ++ "]"+ | null options = ""+ | otherwise =+ "["+ ++ intercalate "] [" (concatMap (masterOption optionDB) (opts cmdspec))+ ++ "]" showArgs = maybe "" (" " ++) $ manual cmdspec opts = map fst . switches masterOption [] _ = []- masterOption (spec:specs) o- | fst spec == o = optionName spec : masterOption specs o- | otherwise = masterOption specs o+ masterOption (spec : specs) o+ | fst spec == o = optionName spec : masterOption specs o+ | otherwise = masterOption specs o showAliases = intercalate ", " . tail . commandNames ---------------------------------------------------------------- optionDoc :: OptionSpec -> (String, String)-optionDoc spec = (key,doc)+optionDoc spec = (key, doc) where key = intercalate ", " . reverse . optionNames $ spec doc = optionDesc spec optionName :: OptionSpec -> String-optionName (_,Option (c:_) _ (ReqArg _ arg) _) = '-':c:' ':arg-optionName (_,Option (c:_) _ _ _) = '-':[c]-optionName _ = ""+optionName (_, Option (c : _) _ (ReqArg _ arg) _) = '-' : c : ' ' : arg+optionName (_, Option (c : _) _ _ _) = '-' : [c]+optionName _ = "" optionNames :: OptionSpec -> [String]-optionNames (_,Option (c:_) (s:_) _ _) = ['-':[c],'-':'-':s]-optionNames _ = []+optionNames (_, Option (c : _) (s : _) _ _) = ['-' : [c], '-' : '-' : s]+optionNames _ = [] optionDesc :: OptionSpec -> String-optionDesc (_,Option _ _ _ desc) = desc+optionDesc (_, Option _ _ _ desc) = desc
src/Help.hs view
@@ -2,9 +2,9 @@ -- Only Help.hs depends on Path_cab.hs module Help (- helpAndExit- , helpCommandAndExit- ) where+ helpAndExit,+ helpCommandAndExit,+) where import Control.Monad (forM_) import Data.List (intersperse)@@ -21,11 +21,11 @@ helpCommandAndExit :: FunctionCommand helpCommandAndExit [] _ _ = helpAndExit-helpCommandAndExit (cmd:_) _ _ = do+helpCommandAndExit (cmd : _) _ _ = do case mcmdspec of Nothing -> helpAndExit Just cmdspec -> do- let (usage,doc,alias) = usageDocAlias cmdspec+ let (usage, doc, alias) = usageDocAlias cmdspec putStrLn $ "Usage: " ++ usage putStr "\n" putStrLn $ doc@@ -43,11 +43,11 @@ where opts = map fst $ switches cmdspec printOption [] _ = return ()- printOption (spec:specs) o- | fst spec == o = do- let (key,doc) = optionDoc spec- putStrLn $ key ++ "\t" ++ doc- | otherwise = printOption specs o+ printOption (spec : specs) o+ | fst spec == o = do+ let (key, doc) = optionDoc spec+ putStrLn $ key ++ "\t" ++ doc+ | otherwise = printOption specs o ---------------------------------------------------------------- @@ -59,16 +59,17 @@ putStrLn "Usage:" putStrLn $ "\t" ++ programName putStrLn $ "\t" ++ programName ++ " <command> [args...]"- putStrLn "\t where"+ putStrLn "\t where" printCommands . getCommands . commandDB $ helpCommandAndExit exitSuccess where- getCommands = map concat- . split helpCommandNumber- . intersperse ", "- . map (head . commandNames)+ getCommands =+ map concat+ . split helpCommandNumber+ . intersperse ", "+ . map (head . commandNames) printCommands [] = return ()- printCommands (x:xs) = do+ printCommands (x : xs) = do putStrLn $ "\t <command> = " ++ x mapM_ (\cmds -> putStrLn $ "\t " ++ cmds) xs @@ -84,4 +85,4 @@ split _ [] = [] split n ss = x : split n rest where- (x,rest) = splitAt n ss+ (x, rest) = splitAt n ss
src/Main.hs view
@@ -1,12 +1,12 @@ module Main where -import Control.Exception (Handler(..))+import Control.Exception (Handler (..)) import qualified Control.Exception as E (catches) import Control.Monad (when)-import Data.List (isPrefixOf, intercalate)+import Data.List (intercalate, isPrefixOf) import Data.Maybe (isNothing) import Distribution.Cab-import System.Console.GetOpt (ArgOrder(..), OptDescr(..), getOpt')+import System.Console.GetOpt (ArgOrder (..), OptDescr (..), getOpt') import System.Environment (getArgs) import System.Exit (ExitCode, exitFailure) import System.IO@@ -25,11 +25,11 @@ oargs <- getArgs let pargs = parseArgs getOptDB oargs checkOptions1 pargs illegalOptionsAndExit- let Right (args,opts0) = pargs+ let Right (args, opts0) = pargs when (args == []) helpAndExit when (OptHelp `elem` opts0) $ helpCommandAndExit args [] [] let opts1 = filter (/= OptHelp) opts0- act:params = args+ act : params = args mcmdspec = commandSpecByName act (commandDB helpCommandAndExit) when (isNothing mcmdspec) (illegalCommandAndExit act) let Just cmdspec = mcmdspec@@ -50,18 +50,19 @@ ---------------------------------------------------------------- illegalOptionsAndExit :: UnknownOptPrinter-illegalOptionsAndExit xs = do -- FixME+illegalOptionsAndExit xs = do+ -- FixME hPutStrLn stderr $ "Illegal options: " ++ intercalate " " xs exitFailure ---------------------------------------------------------------- -type ParsedArgs = Either [UnknownOpt] ([Arg],[Option])+type ParsedArgs = Either [UnknownOpt] ([Arg], [Option]) parseArgs :: [GetOptSpec] -> [Arg] -> ParsedArgs parseArgs db args = case getOpt' Permute db args of- (o,n,[],[]) -> Right (n,o)- (_,_,unknowns,_) -> Left unknowns+ (o, n, [], []) -> Right (n, o)+ (_, _, unknowns, _) -> Left unknowns ---------------------------------------------------------------- @@ -72,7 +73,7 @@ checkOptions1 :: ParsedArgs -> UnknownOptPrinter -> IO () checkOptions1 (Left es) func = func es-checkOptions1 _ _ = return ()+checkOptions1 _ _ = return () ---------------------------------------------------------------- @@ -86,22 +87,23 @@ unknownOptions :: [Option] -> CommandSpec -> [Switch] unknownOptions opts cmdspec = chk specified supported where- chk [] _ = []- chk (x:xs) ys- | x `elem` ys = chk xs ys- | otherwise = x : chk xs ys+ chk [] _ = []+ chk (x : xs) ys+ | x `elem` ys = chk xs ys+ | otherwise = x : chk xs ys specified = map toSwitch opts supported = map fst $ switches cmdspec resolveOptionString :: [Arg] -> Switch -> [UnknownOpt] resolveOptionString oargs sw = case lookup sw optionDB of- Nothing -> error "resolveOptionString"- Just gspec -> let (s,l) = getOptNames gspec- in checkShort s ++ checkLong l+ Nothing -> error "resolveOptionString"+ Just gspec ->+ let (s, l) = getOptNames gspec+ in checkShort s ++ checkLong l where- checkShort s = filter (==s) oargs- checkLong l = filter (l `isPrefixOf`) oargs+ checkShort s = filter (== s) oargs+ checkLong l = filter (l `isPrefixOf`) oargs -getOptNames :: GetOptSpec -> (String,String)-getOptNames (Option (c:_) (s:_) _ _) = ('-':[c],'-':'-':s)-getOptNames _ = error "getOptNames"+getOptNames :: GetOptSpec -> (String, String)+getOptNames (Option (c : _) (s : _) _ _) = ('-' : [c], '-' : '-' : s)+getOptNames _ = error "getOptNames"
src/Options.hs view
@@ -8,50 +8,118 @@ ---------------------------------------------------------------- getOptDB :: GetOptDB-getOptDB = [- Option ['n'] ["dry-run"]- (NoArg OptNoharm)- "Run without destructive operations"- , Option ['r'] ["recursive"]- (NoArg OptRecursive)- "Follow dependencies recursively"- , Option ['a'] ["all"]- (NoArg OptAll)- "Show global packages in addition to user packages"- , Option ['m'] ["info"]- (NoArg OptInfo)- "Show license and author information"- , Option ['f'] ["flags"]- (ReqArg OptFlag "<flags>")- "Specify flags"- , Option ['t'] ["test"]- (NoArg OptTest)- "Enable test"- , Option ['b'] ["bench"]- (NoArg OptBench)- "Enable benchmark"- , Option ['d'] ["dep-only"]- (NoArg OptDepsOnly)- "Target only dependencies"- , Option ['p'] ["lib-prof"]- (NoArg OptLibProfile)- "Enable library profiling"- , Option ['e'] ["exec-prof"]- (NoArg OptExecProfile)- "Enable library profiling"- , Option ['j'] ["jobs"]- (ReqArg OptJobs "<jobs>")- "Run N jobs"- , Option ['i'] ["import"]- (ReqArg OptImport "<dir>:<dir>")- "Add module import paths"- , Option ['s'] ["static"]- (NoArg OptStatic)- "Create static libraries only"- , Option ['h'] ["help"]- (NoArg OptHelp)- "Show help message"- ]+getOptDB =+ [ Option+ ['n']+ ["dry-run"]+ (NoArg OptNoharm)+ "Run without destructive operations"+ , Option+ ['r']+ ["recursive"]+ (NoArg OptRecursive)+ "Follow dependencies recursively"+ , Option+ ['a']+ ["all"]+ (NoArg OptAll)+ "Show global packages in addition to user packages"+ , Option+ ['m']+ ["info"]+ (NoArg OptInfo)+ "Show license and author information"+ , Option+ ['f']+ ["flags"]+ (ReqArg OptFlag "<flags>")+ "Specify flags"+ , Option+ ['t']+ ["test"]+ (NoArg OptTest)+ "Enable test"+ , Option+ ['b']+ ["bench"]+ (NoArg OptBench)+ "Enable benchmark"+ , Option+ ['d']+ ["dep-only"]+ (NoArg OptDepsOnly)+ "Target only dependencies"+ , Option+ ['p']+ ["lib-prof"]+ (NoArg OptLibProfile)+ "Enable library profiling"+ , Option+ ['e']+ ["exec-prof"]+ (NoArg OptExecProfile)+ "Enable library profiling"+ , Option+ ['g']+ ["debug"]+ (NoArg OptDebug)+ "Enable debug trace"+ , Option+ ['j']+ ["jobs"]+ (ReqArg OptJobs "<jobs>")+ "Run N jobs"+ , Option+ ['i']+ ["import"]+ (ReqArg OptImport "<dir>:<dir>")+ "Add module import paths"+ , Option+ ['s']+ ["static"]+ (NoArg OptStatic)+ "Create static libraries only"+ , Option+ ['u']+ ["future"]+ (NoArg OptFuture)+ "Show packages with versions ahead of Hackage"+ , Option+ ['x']+ ["newer"]+ (NoArg OptAllowNewer)+ "Allow newer versions"+ , Option+ ['c']+ ["cleanup"]+ (NoArg OptCleanUp)+ "Remove outdated packages"+ , Option+ ['h']+ ["help"]+ (NoArg OptHelp)+ "Show help message"+ ] optionDB :: OptionDB-optionDB = zip [SwNoharm,SwRecursive,SwAll,SwInfo,SwFlag,SwTest,SwBench,SwDepsOnly,SwLibProfile,SwExecProfile,SwJobs,SwImport,SwStatic] getOptDB+optionDB =+ zip+ [ SwNoharm+ , SwRecursive+ , SwAll+ , SwInfo+ , SwFlag+ , SwTest+ , SwBench+ , SwDepsOnly+ , SwLibProfile+ , SwExecProfile+ , SwDebug+ , SwJobs+ , SwImport+ , SwStatic+ , SwFuture+ , SwAllowNewer+ , SwCleanUp+ ]+ getOptDB
src/Program.hs view
@@ -1,10 +1,12 @@ module Program (- version, showVersion- , programName, description- ) where+ version,+ showVersion,+ programName,+ description,+) where -import Paths_cab import Data.Version+import Paths_cab programName :: String programName = "cab"
src/Run.hs view
@@ -1,45 +1,55 @@+{-# LANGUAGE CPP #-}+ module Run (run, toSwitch) where -import Control.Monad (void) import Data.List (intercalate) import Distribution.Cab+#if MIN_VERSION_process(1,2,0)+import System.Process (callCommand)+#else+import Control.Monad (void) import System.Cmd (system)+#endif import Types ---------------------------------------------------------------- toSwitch :: Option -> Switch-toSwitch OptNoharm = SwNoharm-toSwitch OptRecursive = SwRecursive-toSwitch OptAll = SwAll-toSwitch OptInfo = SwInfo-toSwitch (OptFlag _) = SwFlag-toSwitch OptTest = SwTest-toSwitch OptBench = SwBench-toSwitch OptDepsOnly = SwDepsOnly-toSwitch OptLibProfile = SwLibProfile+toSwitch OptNoharm = SwNoharm+toSwitch OptRecursive = SwRecursive+toSwitch OptAll = SwAll+toSwitch OptInfo = SwInfo+toSwitch (OptFlag _) = SwFlag+toSwitch OptTest = SwTest+toSwitch OptBench = SwBench+toSwitch OptDepsOnly = SwDepsOnly+toSwitch OptLibProfile = SwLibProfile toSwitch OptExecProfile = SwExecProfile-toSwitch (OptJobs _) = SwJobs-toSwitch (OptImport _) = SwImport-toSwitch OptStatic = SwStatic-toSwitch _ = error "toSwitch"+toSwitch OptDebug = SwDebug+toSwitch (OptJobs _) = SwJobs+toSwitch (OptImport _) = SwImport+toSwitch OptStatic = SwStatic+toSwitch OptFuture = SwFuture+toSwitch OptAllowNewer = SwAllowNewer+toSwitch OptCleanUp = SwCleanUp+toSwitch _ = error "toSwitch" ---------------------------------------------------------------- optionArg :: Option -> String-optionArg (OptFlag str) = str-optionArg (OptJobs str) = str+optionArg (OptFlag str) = str+optionArg (OptJobs str) = str optionArg (OptImport str) = str-optionArg _ = ""+optionArg _ = "" optionsToString :: [Option] -> SwitchDB -> [String] optionsToString opts swdb = concatMap suboption opts where suboption opt = case lookup (toSwitch opt) swdb of- Nothing -> []- Just None -> []- Just (Solo x) -> [x]+ Nothing -> []+ Just None -> []+ Just (Solo x) -> [x] Just (WithEqArg x) -> [x ++ "=" ++ optionArg opt] Just (FollowArg x) -> [x ++ optionArg opt] @@ -47,7 +57,7 @@ run :: CommandSpec -> [Arg] -> [Option] -> IO () run cmdspec params opts = case routing cmdspec of- RouteFunc func -> func params opts options+ RouteFunc func -> func params opts options RouteCabal subargs -> callProcess pro subargs params options where pro = "cabal"@@ -55,8 +65,13 @@ options = optionsToString opts sws callProcess :: String -> [String] -> [Arg] -> [String] -> IO ()-callProcess pro args0 args1 options = void . system $ script+callProcess pro args0 args1 options = systemCommand script where+#if MIN_VERSION_process(1,2,0)+ systemCommand = callCommand+#else+ systemCommand = void . system+#endif script = intercalate " " $ pro : args0 ++ cat args1 ++ options- cat [pkg,ver] = [pkg ++ "-" ++ ver]- cat x = x+ cat [pkg, ver] = [pkg ++ "-" ++ ver]+ cat x = x
src/Types.hs view
@@ -9,20 +9,25 @@ ---------------------------------------------------------------- -data Switch = SwNoharm- | SwRecursive- | SwAll- | SwInfo- | SwFlag- | SwTest- | SwBench- | SwDepsOnly- | SwLibProfile- | SwExecProfile- | SwJobs- | SwImport- | SwStatic- deriving (Eq,Show)+data Switch+ = SwNoharm+ | SwRecursive+ | SwAll+ | SwInfo+ | SwFlag+ | SwTest+ | SwBench+ | SwDepsOnly+ | SwLibProfile+ | SwExecProfile+ | SwDebug+ | SwJobs+ | SwImport+ | SwStatic+ | SwFuture+ | SwAllowNewer+ | SwCleanUp+ deriving (Eq, Show) ---------------------------------------------------------------- @@ -34,49 +39,52 @@ type GetOptSpec = OptDescr Option type GetOptDB = [GetOptSpec] -type OptionSpec = (Switch,GetOptSpec)+type OptionSpec = (Switch, GetOptSpec) type OptionDB = [OptionSpec] ---------------------------------------------------------------- -data Command = Sync- | Install- | Uninstall- | Installed- | Configure- | Build- | Clean- | Outdated- | Sdist- | Upload- | Unpack- | Info- | Deps- | RevDeps- | Check- | GenPaths- | Search- | Add- | Ghci- | Test- | Bench- | Doc- | Init- | Help- deriving (Eq,Show)+data Command+ = Sync+ | Install+ | Uninstall+ | Installed+ | Configure+ | Build+ | Clean+ | Outdated+ | Sdist+ | Upload+ | Unpack+ | Info+ | Deps+ | RevDeps+ | Check+ | GenPaths+ | Search+ | Add+ | Ghci+ | Test+ | Bench+ | Doc+ | Init+ | DocTest+ | Help+ deriving (Eq, Show) -data CommandSpec = CommandSpec {- command :: Command- , commandNames :: [String]- , document :: String- , routing :: Route- , switches :: SwitchDB- , manual :: Maybe String- }+data CommandSpec = CommandSpec+ { command :: Command+ , commandNames :: [String]+ , document :: String+ , routing :: Route+ , switches :: SwitchDB+ , manual :: Maybe String+ } type CommandDB = [CommandSpec] ---------------------------------------------------------------- -data Route = RouteFunc FunctionCommand- | RouteCabal [String]+data Route+ = RouteFunc FunctionCommand+ | RouteCabal [String]