cab 0.2.21 → 0.2.22
raw patch · 19 files changed
+887/−700 lines, 19 filessetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Distribution.Cab.PkgDB: findSourceLib :: PkgDB -> PkgInfo -> [PkgInfo]
- Distribution.Cab.PkgDB: findInternalLibs :: PkgInfo -> [String]
+ Distribution.Cab.PkgDB: findInternalLibs :: PkgInfo -> String -> [String]
Files
- Distribution/Cab.hs +17/−16
- Distribution/Cab/Commands.hs +110/−80
- Distribution/Cab/GenPaths.hs +18/−12
- Distribution/Cab/PkgDB.hs +51/−8
- Distribution/Cab/Printer.hs +19/−18
- Distribution/Cab/Sandbox.hs +27/−23
- Distribution/Cab/Utils.hs +14/−6
- Distribution/Cab/VerDB.hs +24/−19
- Distribution/Cab/Version.hs +9/−8
- Setup.hs +1/−0
- cab.cabal +77/−76
- src/Commands.hs +254/−235
- src/Doc.hs +20/−17
- src/Help.hs +18/−17
- src/Main.hs +24/−22
- src/Options.hs +113/−57
- src/Program.hs +6/−4
- src/Run.hs +27/−27
- src/Types.hs +58/−55
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,15 +1,24 @@ 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 qualified Control.Exception as E-import Control.Monad (forM_, unless, when, void)+import Control.Monad (forM_, unless, void, when) import Data.Char (toLower) import Data.List (intercalate, isPrefixOf)-import qualified Data.Map as M+import qualified Data.Map.Strict as M import Distribution.Cab.GenPaths import Distribution.Cab.PkgDB import Distribution.Cab.Printer@@ -26,35 +35,36 @@ 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- | OptFuture- | OptDebug- | OptAllowNewer- | OptCleanUp- 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."@@ -81,15 +91,16 @@ verDB <- toMap <$> getVerDB InstalledOnly let del = OptCleanUp `elem` opts forM_ pkgs $ \p -> case M.lookup (nameOfPkgInfo p) verDB of- Nothing -> return ()+ 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+ 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@@ -100,24 +111,39 @@ 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) 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@@ -127,18 +153,16 @@ sandboxOpts <- (makeOptList . getSandboxOpts2) <$> getSandbox dirs <- getDirs nameVer sandboxOpts unregister doit opts nameVer- mapM_ unregisterInternal $ findInternalLibs pkgInfo+ mapM_ unregisterInternal $ findInternalLibs pkgInfo name mapM_ (removeDir doit) dirs where- unregisterInternal subname = unregister doit opts (nm,ver)- where- nm = "z-" ++ name ++ "-z-" ++ subname- nameVer@(name,ver) = pairNameOfPkgInfo pkgInfo+ unregisterInternal subname = unregister doit opts (subname, ver)+ nameVer@(name, ver) = pairNameOfPkgInfo pkgInfo makeOptList "" = []- makeOptList x = [x]+ makeOptList x = [x] -getDirs :: (String,String) -> [String] -> IO [FilePath]-getDirs (name,ver) sandboxOpts = do+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@@ -148,15 +172,15 @@ let options = ["field"] ++ sandboxOpts ++ [nameVer, field] ws <- words <$> readProcess "ghc-pkg" options "" return $ case ws of- [] -> []- (_:xs) -> xs+ [] -> []+ (_ : xs) -> xs docDir dir- | takeFileName dir == "html" = takeDirectory dir- | otherwise = dir- topDir [] = []- topDir ds@(dir:_)- | takeFileName top == nameVer = top : ds- | otherwise = ds+ | takeFileName dir == "html" = takeDirectory dir+ | otherwise = dir+ topDir [] = []+ topDir ds@(dir : _)+ | takeFileName top == nameVer = top : ds+ | otherwise = ds where top = takeDirectory dir @@ -167,14 +191,15 @@ 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+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 @@ -200,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'@@ -215,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@@ -236,9 +264,9 @@ ---------------------------------------------------------------- initSandbox :: FunctionCommand-initSandbox [] _ _ = void . system $ "cabal v1-sandbox init"+initSandbox [] _ _ = void . system $ "cabal v1-sandbox init" initSandbox [path] _ _ = void . system $ "cabal v1-sandbox init --sandbox " ++ path-initSandbox _ _ _ = do+initSandbox _ _ _ = do hPutStrLn stderr "Only one argument is allowed" exitFailure @@ -246,7 +274,7 @@ add :: FunctionCommand add [src] _ _ = void . system $ "cabal v1-sandbox add-source " ++ src-add _ _ _ = do+add _ _ _ = do hPutStrLn stderr "A source path be specified." exitFailure @@ -255,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
@@ -14,21 +14,26 @@ 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 <- readGenericPackageDescription silent file let pkg = package . packageDescription $ desc@@ -38,16 +43,17 @@ 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
@@ -19,8 +19,9 @@ , fullNameOfPkgInfo , pairNameOfPkgInfo , verOfPkgInfo- -- * Find internal libraries+ -- * Find other libraries , findInternalLibs+ , findSourceLib ) where import Distribution.Cab.Utils@@ -28,9 +29,13 @@ import Distribution.Cab.Version import Distribution.Cab.VerDB (PkgName) import Distribution.InstalledPackageInfo- (InstalledPackageInfo(depends), sourcePackageId)+ (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@@ -41,9 +46,15 @@ import Distribution.Simple.PackageIndex (PackageIndex) #endif import Distribution.Simple.Program.Db (defaultProgramDb)-import Distribution.Verbosity (normal)+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 @@ -78,7 +89,11 @@ 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 PkgDB getDBs specs = do@@ -87,12 +102,20 @@ #if MIN_VERSION_Cabal(1,23,0) _comp #endif+#if MIN_VERSION_Cabal(3,14,0)+ Nothing+#endif specs pro 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 ---------------------------------------------------------------- @@ -123,7 +146,11 @@ ---------------------------------------------------------------- nameOfPkgInfo :: PkgInfo -> PkgName-nameOfPkgInfo = unPackageName . pkgName . sourcePackageId+nameOfPkgInfo pkgi = case sourceLibName pkgi of+ LMainLibName -> name+ LSubLibName sub -> libNameHack name $ unUnqualComponentName sub+ where+ name = unPackageName $ pkgName $ sourcePackageId pkgi fullNameOfPkgInfo :: PkgInfo -> String fullNameOfPkgInfo pkgi = nameOfPkgInfo pkgi ++ " " ++ verToString (verOfPkgInfo pkgi)@@ -144,13 +171,13 @@ ---------------------------------------------------------------- -findInternalLibs :: PkgInfo -> [String]-findInternalLibs pkgInfo =+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 $ take (length xs1) xs1+ _:xs1 -> Just xs1 _ -> Nothing where skip ys = case break (== '-') ys of@@ -160,3 +187,19 @@ _ -> "" -- 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,20 +1,21 @@ {-# 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.Version import Distribution.Cab.Utils (UnitId, installedUnitId, lookupUnitId)+import Distribution.Cab.Version import Distribution.InstalledPackageInfo (author, depends, license)-import Distribution.License (License(..))+import Distribution.License (License (..)) import Distribution.Simple.PackageIndex (allPackages) #if MIN_VERSION_Cabal(2,2,0)@@ -32,7 +33,7 @@ deps = map idDeps pkgs 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@@ -44,12 +45,12 @@ printDep :: Bool -> Bool -> PkgDB -> Int -> UnitId -> IO () printDep rec info db n uid = case lookupUnitId db uid of- Nothing -> return ()+ Nothing -> return () Just uniti -> do putStr $ prefix ++ fullNameOfPkgInfo uniti extraInfo info uniti putStrLn ""- when rec $ printDeps rec info db (n+1) uniti+ when rec $ printDeps rec info db (n + 1) uniti where prefix = replicate (n * 4) ' ' @@ -69,12 +70,12 @@ printRevDep' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> UnitId -> IO () printRevDep' rec info db revdb n uid = case lookupUnitId db uid of- Nothing -> return ()+ Nothing -> return () Just uniti -> do putStr $ prefix ++ fullNameOfPkgInfo uniti extraInfo info uniti putStrLn ""- when rec $ printRevDeps' rec info db revdb (n+1) uniti+ when rec $ printRevDeps' rec info db revdb (n + 1) uniti where prefix = replicate (n * 4) ' ' @@ -95,9 +96,9 @@ #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,16 +1,16 @@ {-# LANGUAGE BangPatterns #-} module Distribution.Cab.Sandbox (- getSandbox- , getSandboxOpts- , getSandboxOpts2- ) where+ getSandbox,+ getSandboxOpts,+ getSandboxOpts2,+) where -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, (</>)) ---------------------------------------------------------------- @@ -38,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.@@ -69,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.@@ -94,6 +98,6 @@ where file = takeFileName dir findVer = drop 4 . head . filter ("ghc-" `isPrefixOf`) . tails- (verStr1,left) = break (== '.') $ findVer file- (verStr2,_) = break (== '.') $ tail left+ (verStr1, left) = break (== '.') $ findVer file+ (verStr2, _) = break (== '.') $ tail left ver = read verStr1 * 100 + read verStr2
Distribution/Cab/Utils.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+ module Distribution.Cab.Utils where import Data.List@@ -34,9 +35,13 @@ import qualified Distribution.Package as Cabal (PackageName(..)) #endif -#if MIN_VERSION_Cabal(3,8,0)+#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)@@ -53,9 +58,9 @@ -- [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]@@ -107,8 +112,11 @@ -- GenericPackageDescription -readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription-#if MIN_VERSION_Cabal(2,0,0)+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
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.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 @@ -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,18 +1,19 @@ {-# LANGUAGE CPP #-}+ module Distribution.Cab.Version (- Ver- , toVer- , toVersion- , verToString- , version- , versionToString- ) where+ Ver,+ toVer,+ toVersion,+ verToString,+ version,+ versionToString,+) where import Distribution.Cab.Utils import Distribution.Version -- | Package version.-newtype Ver = Ver [Int] deriving (Eq,Ord,Read,Show)+newtype Ver = Ver [Int] deriving (Eq, Ord, Read, Show) -- | Creating 'Ver'. --
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
cab.cabal view
@@ -1,80 +1,81 @@-Name: cab-Version: 0.2.21-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 >= 1.18- , attoparsec >= 0.10- , bytestring- , conduit >= 1.1- , conduit-extra >= 1.1.2- , containers- , directory- , filepath- , process- , resourcet- 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 -threaded- HS-Source-Dirs: src- 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- 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 >= 4.0 && < 5--- , 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,238 +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 ["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>]"- }- ]+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,62 +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 ['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"- ]+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,SwDebug,SwJobs,SwImport,SwStatic,SwFuture,SwAllowNewer,SwCleanUp] 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,4 +1,5 @@ {-# LANGUAGE CPP #-}+ module Run (run, toSwitch) where import Data.List (intercalate)@@ -15,40 +16,40 @@ ---------------------------------------------------------------- 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 OptDebug = SwDebug-toSwitch (OptJobs _) = SwJobs-toSwitch (OptImport _) = SwImport-toSwitch OptStatic = SwStatic-toSwitch OptFuture = SwFuture-toSwitch OptAllowNewer = SwAllowNewer-toSwitch OptCleanUp = SwCleanUp-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] @@ -56,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"@@ -71,7 +72,6 @@ #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,24 +9,25 @@ ---------------------------------------------------------------- -data Switch = SwNoharm- | SwRecursive- | SwAll- | SwInfo- | SwFlag- | SwTest- | SwBench- | SwDepsOnly- | SwLibProfile- | SwExecProfile- | SwDebug- | SwJobs- | SwImport- | SwStatic- | SwFuture- | SwAllowNewer- | SwCleanUp- 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) ---------------------------------------------------------------- @@ -38,50 +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- | DocTest- | 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]