diff --git a/Distribution/Cab.hs b/Distribution/Cab.hs --- a/Distribution/Cab.hs +++ b/Distribution/Cab.hs @@ -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 diff --git a/Distribution/Cab/Commands.hs b/Distribution/Cab/Commands.hs --- a/Distribution/Cab/Commands.hs +++ b/Distribution/Cab/Commands.hs @@ -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) diff --git a/Distribution/Cab/GenPaths.hs b/Distribution/Cab/GenPaths.hs --- a/Distribution/Cab/GenPaths.hs +++ b/Distribution/Cab/GenPaths.hs @@ -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 diff --git a/Distribution/Cab/PkgDB.hs b/Distribution/Cab/PkgDB.hs --- a/Distribution/Cab/PkgDB.hs +++ b/Distribution/Cab/PkgDB.hs @@ -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 diff --git a/Distribution/Cab/Printer.hs b/Distribution/Cab/Printer.hs --- a/Distribution/Cab/Printer.hs +++ b/Distribution/Cab/Printer.hs @@ -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 diff --git a/Distribution/Cab/Sandbox.hs b/Distribution/Cab/Sandbox.hs --- a/Distribution/Cab/Sandbox.hs +++ b/Distribution/Cab/Sandbox.hs @@ -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 diff --git a/Distribution/Cab/Utils.hs b/Distribution/Cab/Utils.hs --- a/Distribution/Cab/Utils.hs +++ b/Distribution/Cab/Utils.hs @@ -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 diff --git a/Distribution/Cab/VerDB.hs b/Distribution/Cab/VerDB.hs --- a/Distribution/Cab/VerDB.hs +++ b/Distribution/Cab/VerDB.hs @@ -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 '.' diff --git a/Distribution/Cab/Version.hs b/Distribution/Cab/Version.hs --- a/Distribution/Cab/Version.hs +++ b/Distribution/Cab/Version.hs @@ -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'. -- diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/cab.cabal b/cab.cabal --- a/cab.cabal +++ b/cab.cabal @@ -1,80 +1,81 @@ -Name: cab -Version: 0.2.21 -Author: Kazu Yamamoto -Maintainer: Kazu Yamamoto -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 +author: Kazu Yamamoto +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 diff --git a/src/Commands.hs b/src/Commands.hs --- a/src/Commands.hs +++ b/src/Commands.hs @@ -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 "[ []]" - } - , 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 " []" - } - , 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 " []" - } - , 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 " []" - } - , CommandSpec { - command = Deps - , commandNames = ["deps"] - , document = "Show dependencies of this package" - , routing = RouteFunc deps - , switches = [(SwRecursive, None) - ,(SwAll, None) - ,(SwInfo, None) - ] - , manual = Just " []" - } - , 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 " []" - } - , 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_.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 "" - } - , CommandSpec { - command = Add - , commandNames = ["add", "add-source"] - , document = "Add a source directory" - , routing = RouteFunc add - , switches = [] - , manual = Just "" - } - , 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 "[]" - } - ] +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 "[ []]" + } + , 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 " []" + } + , 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 " []" + } + , 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 " []" + } + , CommandSpec + { command = Deps + , commandNames = ["deps"] + , document = "Show dependencies of this package" + , routing = RouteFunc deps + , switches = + [ (SwRecursive, None) + , (SwAll, None) + , (SwInfo, None) + ] + , manual = Just " []" + } + , 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 " []" + } + , 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_.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 "" + } + , CommandSpec + { command = Add + , commandNames = ["add", "add-source"] + , document = "Add a source directory" + , routing = RouteFunc add + , switches = [] + , manual = Just "" + } + , 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 "[]" + } + ] diff --git a/src/Doc.hs b/src/Doc.hs --- a/src/Doc.hs +++ b/src/Doc.hs @@ -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 diff --git a/src/Help.hs b/src/Help.hs --- a/src/Help.hs +++ b/src/Help.hs @@ -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 ++ " [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 = " ++ 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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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" diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -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 "") - "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 "") - "Run N jobs" - , Option ['i'] ["import"] - (ReqArg OptImport ":") - "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 "") + "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 "") + "Run N jobs" + , Option + ['i'] + ["import"] + (ReqArg OptImport ":") + "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 diff --git a/src/Program.hs b/src/Program.hs --- a/src/Program.hs +++ b/src/Program.hs @@ -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" diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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]