diff --git a/CmdDB.hs b/CmdDB.hs deleted file mode 100644 --- a/CmdDB.hs +++ /dev/null @@ -1,394 +0,0 @@ -module CmdDB where - -import Commands -import Control.Monad -import Data.List -import Program -import System.Console.GetOpt -import System.Exit -import System.IO -import Types -import Utils - ----------------------------------------------------------------- - -commandDB :: CommandDB -commandDB = [ - CommandSpec { - command = Sync - , commandNames = ["sync", "update"] - , document = "Fetch the latest package index" - , routing = RouteCabal ["update"] - , switches = [] - , manual = Nothing - } - , CommandSpec { - command = Install - , commandNames = ["install"] - , document = "Install packages" - , routing = RouteCabal ["install"] - , switches = [(SwNoharm, Just "--dry-run -v") - -- FIXME cabal-dev not support --dry-run - ,(SwSandbox, Just "--sandbox") - ,(SwFlag, Just "--flags") - ] - , manual = Just "[ []]" - } - , CommandSpec { - command = Uninstall - , commandNames = ["uninstall", "delete", "remove", "unregister"] - , document = "Uninstall packages" - , routing = RouteFunc uninstall - , switches = [(SwNoharm, Nothing) - ,(SwRecursive, Nothing) - ,(SwSandbox, Just "--sandbox") - ] -- don't allow SwAll - , manual = Just " []" - } - , CommandSpec { - command = Installed - , commandNames = ["installed", "list"] - , document = "List installed packages" - , routing = RouteFunc installed - , switches = [(SwAll, Nothing) - ,(SwRecursive, Nothing) - ,(SwInfo, Nothing) - ,(SwSandbox, Just "--sandbox") - ] - , manual = Nothing - } - , CommandSpec { - command = Configure - , commandNames = ["configure", "conf"] - , document = "Configure a cabal package" - , routing = RouteCabal ["configure"] - , switches = [(SwSandbox, Just "--sandbox") - ,(SwFlag, Just "--flags") - ,(SwTest, Just "--enable-tests") - ,(SwBench, Just "--enable-benchmarks") - ] - , manual = Nothing - } - , CommandSpec { - command = Build - , commandNames = ["build"] - , document = "Build a cabal package" - , routing = RouteCabal ["build"] - , switches = [] - , manual = Nothing - } - , CommandSpec { - command = Clean - , commandNames = ["clean"] - , document = "Clean up a build directory" - , routing = RouteCabal ["clean"] - , switches = [] - , manual = Nothing - } - , CommandSpec { - command = Outdated - , commandNames = ["outdated"] - , document = "Display outdated packages" - , routing = RouteFunc outdated - , switches = [(SwAll, Nothing) - ,(SwSandbox, Just "--sandbox")] - , manual = Nothing - } - , CommandSpec { - command = Info - , commandNames = ["info"] - , document = "Display information of a package" - , routing = RouteCabal ["info"] - , switches = [(SwSandbox, Just "--sandbox")] - , 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"] - , switches = [(SwNoharm, Just "-c")] - , manual = Nothing - } - , CommandSpec { - command = Unpack - , commandNames = ["unpack"] - , document = "Untar a package in the current directory" - , routing = RouteCabal ["unpack"] - , switches = [] - , manual = Just " []" - } - , CommandSpec { - command = Deps - , commandNames = ["deps"] - , document = "Show dependencies of this package" - , routing = RouteFunc deps - , switches = [(SwRecursive, Nothing) - ,(SwAll, Nothing) - ,(SwInfo, Nothing) - ,(SwSandbox, Just "--sandbox") - ] - , manual = Just " []" - } - , CommandSpec { - command = RevDeps - , commandNames = ["revdeps", "dependents"] - , document = "Show reverse dependencies of this package" - , routing = RouteFunc revdeps - , switches = [(SwRecursive, Nothing) - ,(SwAll, Nothing) - ,(SwInfo, Nothing) - ,(SwSandbox, Just "--sandbox") - ] - , manual = Just " []" - } - , CommandSpec { - command = Check - , commandNames = ["check"] - , document = "Check consistency of packages" - , routing = RouteFunc check - , switches = [(SwSandbox, Just "--sandbox")] - , 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 = Env - , commandNames = ["env"] - , document = "Show environment variables" - , routing = RouteFunc env - , switches = [(SwSandbox, Just "--sandbox")] - , manual = Nothing - } - , CommandSpec { - command = Add - , commandNames = ["add", "add-source"] - , document = "Add a source directory" - , routing = RouteFunc add - , switches = [(SwSandbox, Just "--sandbox")] - , manual = Just "" - } - , CommandSpec { - command = Test - , commandNames = ["test"] - , document = "Run tests" - , routing = RouteCabal ["test"] - , switches = [(SwSandbox, Just "--sandbox")] - , manual = Nothing - } - , CommandSpec { - command = Bench - , commandNames = ["bench"] - , document = "Run benchmarks" - , routing = RouteCabal ["bench"] - , switches = [(SwSandbox, Just "--sandbox")] - , manual = Nothing - } - , CommandSpec { - command = Doc - , commandNames = ["doc", "haddock", "man"] - , document = "Generate manuals" - , routing = RouteCabal ["haddock", "--hyperlink-source"] - , switches = [] - , manual = Nothing - } - , CommandSpec { - command = Ghci - , commandNames = ["ghci"] - , document = "Run GHCi within a sandbox" - , routing = RouteFunc ghci - , switches = [(SwSandbox, Just "--sandbox")] - , manual = Nothing - } - , CommandSpec { - command = Help - , commandNames = ["help"] - , document = "Display the help message of the command" - , routing = RouteFunc helpCommandAndExit - , switches = [] - , manual = Just "[]" - } - ] - ----------------------------------------------------------------- - -commandSpecByName :: String -> CommandDB -> Maybe CommandSpec -commandSpecByName _ [] = Nothing -commandSpecByName x (ent:ents) - | x `elem` commandNames ent = Just ent - | otherwise = commandSpecByName x ents - ----------------------------------------------------------------- - -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 ['i'] ["info"] - (NoArg OptInfo) - "Show license and author information" - , Option ['s'] ["sandbox"] - (ReqArg OptSandbox "") - "Specify a sandbox directory" - , Option ['f'] ["flags"] - (ReqArg OptFlag "") - "Specify flags" - , Option ['t'] ["test"] - (NoArg OptTest) - "Enable test" - , Option ['b'] ["bench"] - (NoArg OptBench) - "Enable benchmark" - , Option ['h'] ["help"] - (NoArg OptHelp) - "Show help message" - ] - -optionDB :: OptionDB -optionDB = zip [SwNoharm,SwRecursive,SwAll,SwInfo,SwSandbox,SwFlag,SwTest,SwBench] getOptDB - ----------------------------------------------------------------- - -optionName :: OptionSpec -> String -optionName (_,Option (c:_) _ (ReqArg _ arg) _) = '-':c:' ':arg -optionName (_,Option (c:_) _ _ _) = '-':[c] -optionName _ = "" - -optionNames :: OptionSpec -> [String] -optionNames (_,Option (c:_) (s:_) _ _) = ['-':[c],'-':'-':s] -optionNames _ = [] - -optionDesc :: OptionSpec -> String -optionDesc (_,Option _ _ _ desc) = desc - -getOptNames :: GetOptSpec -> (String,String) -getOptNames (Option (c:_) (s:_) _ _) = ('-':[c],'-':'-':s) -getOptNames _ = error "getOptNames" - -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 - where - checkShort s = filter (==s) oargs - checkLong l = filter (l `isPrefixOf`) oargs - -optionsToString :: [Option] -> SwitchDB -> [String] -optionsToString opts swdb = concatMap suboption opts - where - suboption opt = case lookup (toSwitch opt) swdb of - Nothing -> [] - Just Nothing -> [] - Just (Just x) -> case opt of - OptSandbox dir -> [x++"="++dir] - OptFlag flags -> [x++"="++flags] - _ -> [x] - ----------------------------------------------------------------- - -helpCommandAndExit :: FunctionCommand -helpCommandAndExit _ [] _ = helpAndExit -helpCommandAndExit _ (cmd:_) _ = do - case mcmdspec of - Nothing -> helpAndExit - Just cmdspec -> do - putStrLn $ "Usage: " ++ cmd ++ " " ++ showOptions cmdspec ++ showArgs cmdspec - putStr "\n" - putStrLn $ document cmdspec - putStr "\n" - putStrLn $ "Aliases: " ++ showAliases cmdspec - putStr "\n" - printOptions cmdspec - exitSuccess - where - mcmdspec = commandSpecByName cmd commandDB - showOptions cmdspec = "[" ++ joinBy "] [" (concatMap (masterOption optionDB) (opts cmdspec)) ++ "]" - showArgs cmdspec = maybe "" (" " ++) $ manual cmdspec - opts = map fst . switches - masterOption [] _ = [] - masterOption (spec:specs) o - | fst spec == o = optionName spec : masterOption specs o - | otherwise = masterOption specs o - showAliases = joinBy ", " . commandNames - -printOptions :: CommandSpec -> IO () -printOptions cmdspec = - forM_ opts (printOption optionDB) - where - opts = map fst $ switches cmdspec - printOption [] _ = return () - printOption (spec:specs) o - | fst spec == o = - putStrLn $ (joinBy ", " . reverse . optionNames $ spec) - ++ "\t" ++ optionDesc spec - | otherwise = printOption specs o - ----------------------------------------------------------------- - -helpAndExit :: IO () -helpAndExit = do - putStrLn $ programName ++ " " ++ " -- " ++ description - putStrLn "" - putStrLn $ "Version: " ++ showVersion version - putStrLn "Usage:" - putStrLn $ "\t" ++ programName - putStrLn $ "\t" ++ programName ++ " [args...]" - putStrLn "\t where" - printCommands (getCommands commandDB) - exitSuccess - where - getCommands = map concat - . split helpCommandNumber - . intersperse ", " - . map (head . commandNames) - printCommands [] = return () - printCommands (x:xs) = do - putStrLn $ "\t = " ++ x - mapM_ (\cmds -> putStrLn $ "\t " ++ cmds) xs - -helpCommandNumber :: Int -helpCommandNumber = 10 - ----------------------------------------------------------------- - -illegalCommandAndExit :: String -> IO () -illegalCommandAndExit x = do - hPutStrLn stderr $ "Illegal command: " ++ x - exitFailure - ----------------------------------------------------------------- - -illegalOptionsAndExit :: [UnknownOpt] -> IO () -illegalOptionsAndExit xs = do -- FixME - hPutStrLn stderr $ "Illegal options: " ++ joinBy " " xs - exitFailure diff --git a/Commands.hs b/Commands.hs deleted file mode 100644 --- a/Commands.hs +++ /dev/null @@ -1,202 +0,0 @@ -module Commands ( - deps, revdeps, installed, outdated, uninstall, search, env - , genpaths, check, add, ghci - ) where - -import Control.Applicative hiding (many) -import Control.Monad -import Data.Char -import Data.List -import Data.Maybe -import GenPaths -import PkgDB -import System.Exit -import System.IO -import System.Process hiding (env) -import Types -import Utils -import VerDB - ----------------------------------------------------------------- - -search :: FunctionCommand -search _ [x] _ = do - nvls <- getVerAlist False - forM_ (lok nvls) $ \(n,v) -> putStrLn $ n ++ " " ++ toDotted v - where - key = map toLower x - sat (n,_) = key `isPrefixOf` map toLower n - lok [] = [] - lok (e:es) - | sat e = e : lok es - | otherwise = lok es -search _ _ _ = do - hPutStrLn stderr "One search-key should be specified." - exitFailure - ----------------------------------------------------------------- - -installed :: FunctionCommand -installed _ _ opts = do - let optall = OptAll `elem` opts - optrec = OptRecursive `elem` opts - db' <- getPkgDB (getSandbox opts) - flt <- if optall then allPkgs else userPkgs - -- FIXME: the optall case does unnecessary conversion - let pkgs = toPkgList flt db' - db = toPkgDB pkgs - forM_ pkgs $ \pkgi -> do - putStr $ fullNameOfPkgInfo pkgi - extraInfo info pkgi - putStrLn "" - when optrec $ printDeps True info db 1 pkgi - where - info = OptInfo `elem` opts - -outdated :: FunctionCommand -outdated _ _ opts = do - flt <- if OptAll `elem` opts then allPkgs else userPkgs - pkgs <- toPkgList flt <$> getPkgDB (getSandbox opts) - verDB <- getVerDB - forM_ pkgs $ \p -> case lookupLatestVersion (nameOfPkgInfo p) verDB of - Nothing -> return () - Just ver -> when (numVersionOfPkgInfo p /= ver) $ - putStrLn $ fullNameOfPkgInfo p ++ " < " ++ toDotted ver - ----------------------------------------------------------------- - -uninstall :: FunctionCommand -uninstall _ nmver opts = do - db' <- getPkgDB (getSandbox opts) - db <- toPkgDB . flip toPkgList db' <$> userPkgs - pkg <- lookupPkg nmver db - let sortedPkgs = topSortedPkgs pkg db - if onlyOne && length sortedPkgs /= 1 then do - hPutStrLn stderr "The following packages depend on this. Use the \"-r\" option." - mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) (init sortedPkgs) - else do - unless doit $ putStrLn "The following packages are deleted without the \"-n\" option." - mapM_ (unregister doit opts . pairNameOfPkgInfo) sortedPkgs - where - onlyOne = OptRecursive `notElem` opts - doit = OptNoharm `notElem` opts - -unregister :: Bool -> [Option] -> (String,String) -> IO () -unregister doit opts (name,ver) = - if doit then do - putStrLn $ "Deleting " ++ name ++ " " ++ ver - pkgconf <- pkgConfOpt opts - when doit $ void . system $ script pkgconf - else - putStrLn $ name ++ " " ++ ver - where - script pkgconf = "ghc-pkg unregister " ++ pkgconf ++ name ++ "-" ++ ver - -pkgConfOpt :: [Option] -> IO String -pkgConfOpt opts = case getSandbox opts of - Nothing -> return "" - Just path -> do - pkgConf <- getPackageConf path - return $ "--package-conf=" ++ pkgConf ++ " " - ----------------------------------------------------------------- - -genpaths :: FunctionCommand -genpaths _ _ _ = genPaths - ----------------------------------------------------------------- - -check :: FunctionCommand -check _ _ opts = do - pkgconf <- pkgConfOpt opts - void . system $ script pkgconf - where - script pkgconf = "ghc-pkg check -v " ++ pkgconf - ----------------------------------------------------------------- - -deps :: FunctionCommand -deps _ nmver opts = printDepends nmver opts printDeps - -revdeps :: FunctionCommand -revdeps _ nmver opts = printDepends nmver opts printRevDeps - -printDepends :: [String] -> [Option] - -> (Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()) -> IO () -printDepends nmver opts func = do - db' <- getPkgDB (getSandbox opts) - pkg <- lookupPkg nmver db' - db <- if OptAll `elem` opts - then return db' - else toPkgDB . flip toPkgList db' <$> userPkgs - func rec info db 0 pkg - where - rec = OptRecursive `elem` opts - info = OptInfo `elem` opts - ----------------------------------------------------------------- - -lookupPkg :: [String] -> PkgDB -> IO PkgInfo -lookupPkg [] _ = do - hPutStrLn stderr "Package name must be specified." - exitFailure -lookupPkg [name] db = checkOne $ lookupByName name db -lookupPkg [name,ver] db = checkOne $ lookupByVersion name ver db -lookupPkg _ _ = do - hPutStrLn stderr "Only one package name must be specified." - exitFailure - -checkOne :: [PkgInfo] -> IO PkgInfo -checkOne [] = do - hPutStrLn stderr "No such package found." - exitFailure -checkOne [pkg] = return pkg -checkOne pkgs = do - hPutStrLn stderr "Package version must be specified." - mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) pkgs - exitFailure - ----------------------------------------------------------------- - -env :: FunctionCommand -env _ _ opts = case getSandbox opts of - Nothing -> do - putStrLn "unset CAB_SANDBOX_PATH" - putStrLn "unsetenv CAB_SANDBOX_PATH" - putStrLn "" - putStrLn "unset GHC_PACKAGE_PATH" - putStrLn "unsetenv GHC_PACKAGE_PATH" - Just path -> do - pkgConf <- getPackageConf path - gPkgConf <- globalPackageDB - putStrLn $ "export CAB_SANDBOX_PATH=" ++ path - putStrLn $ "setenv CAB_SANDBOX_PATH " ++ path - putStrLn "" - putStrLn "The following commands are not necessary in normal case." - let confs = gPkgConf ++ ":" ++ pkgConf - putStrLn $ "export GHC_PACKAGE_PATH=" ++ confs - putStrLn $ "setenv GHC_PACKAGE_PATH " ++ confs - -globalPackageDB :: IO String -globalPackageDB = do - res <- readProcess "ghc" ["--info"] [] - let alist = read res :: [(String,String)] - return . fromJust $ lookup "Global Package DB" alist - ----------------------------------------------------------------- - -add :: FunctionCommand -add _ params opts = case getSandbox opts of - Nothing -> hPutStrLn stderr "A sandbox must be specified with \"-s\" option." - Just sbox -> case params of - [src] -> void . system $ "cabal-dev add-source " ++ src ++ " -s " ++ sbox - _ -> hPutStrLn stderr "A source path be specified." - ----------------------------------------------------------------- - -ghci :: FunctionCommand -ghci _ _ opts = case getSandbox opts of - Nothing -> hPutStrLn stderr "A sandbox must be specified with \"-s\" option." - Just sbox -> do - _ <- system $ "cabal-dev -s " ++ sbox ++ " ghci" - return () diff --git a/Distribution/Cab.hs b/Distribution/Cab.hs new file mode 100644 --- /dev/null +++ b/Distribution/Cab.hs @@ -0,0 +1,23 @@ +module Distribution.Cab ( + -- * Types + Option(..) + , FunctionCommand + -- * Commands + , deps + , revdeps + , installed + , outdated + , uninstall + , search + , genpaths + , check + , add + , initSandbox + , ghci + -- * Utilities + , joinBy + , split + ) where + +import Distribution.Cab.Commands +import Distribution.Cab.Utils diff --git a/Distribution/Cab/Commands.hs b/Distribution/Cab/Commands.hs new file mode 100644 --- /dev/null +++ b/Distribution/Cab/Commands.hs @@ -0,0 +1,192 @@ +module Distribution.Cab.Commands ( + FunctionCommand + , Option(..) + , deps, revdeps, installed, outdated, uninstall, search + , genpaths, check, initSandbox, add, ghci + ) where + +import Control.Applicative hiding (many) +import Control.Monad +import Data.Char +import Data.List +import qualified Data.Map as M +import Distribution.Cab.GenPaths +import Distribution.Cab.PkgDB +import Distribution.Cab.Printer +import Distribution.Cab.Sandbox +import Distribution.Cab.VerDB +import Distribution.Cab.Version +import Distribution.Cab.Utils +import System.Exit +import System.IO +import System.Process hiding (env) + +---------------------------------------------------------------- + +type FunctionCommand = [String] -> [Option] -> IO () + +data Option = OptNoharm + | OptRecursive + | OptAll + | OptInfo + | OptFlag String + | OptTest + | OptHelp + | OptBench + | OptDepsOnly + | OptLibProfile + | OptExecProfile + | OptJobs String + deriving (Eq,Show) + +---------------------------------------------------------------- + +search :: FunctionCommand +search [x] _ = do + nvls <- toList <$> getVerDB AllRegistered + forM_ (lok nvls) $ \(n,v) -> putStrLn $ n ++ " " ++ verToString v + where + key = map toLower x + sat (n,_) = key `isPrefixOf` map toLower n + lok = filter sat +search _ _ = do + hPutStrLn stderr "One search-key should be specified." + exitFailure + +---------------------------------------------------------------- + +installed :: FunctionCommand +installed _ opts = do + db <- getDB opts + let pkgs = toPkgInfos db + forM_ pkgs $ \pkgi -> do + putStr $ fullNameOfPkgInfo pkgi + extraInfo info pkgi + putStrLn "" + when optrec $ printDeps True info db 1 pkgi + where + info = OptInfo `elem` opts + optrec = OptRecursive `elem` opts + +outdated :: FunctionCommand +outdated _ opts = do + pkgs <- toPkgInfos <$> getDB opts + verDB <- toMap <$> getVerDB InstalledOnly + forM_ pkgs $ \p -> case M.lookup (nameOfPkgInfo p) verDB of + Nothing -> return () + Just ver -> when (verOfPkgInfo p /= ver) $ + putStrLn $ fullNameOfPkgInfo p ++ " < " ++ verToString ver + +getDB :: [Option] -> IO PkgDB +getDB opts + | optall = getSandbox >>= getPkgDB + | otherwise = getSandbox >>= getUserPkgDB + where + optall = OptAll `elem` opts + +---------------------------------------------------------------- + +uninstall :: FunctionCommand +uninstall nmver opts = do + userDB <- getSandbox >>= getUserPkgDB + pkg <- lookupPkg nmver userDB + let sortedPkgs = topSortedPkgs pkg userDB + if onlyOne && length sortedPkgs /= 1 then do + hPutStrLn stderr "The following packages depend on this. Use the \"-r\" option." + mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) (init sortedPkgs) + else do + unless doit $ putStrLn "The following packages are deleted without the \"-n\" option." + mapM_ (unregister doit opts . pairNameOfPkgInfo) sortedPkgs + where + onlyOne = OptRecursive `notElem` opts + doit = OptNoharm `notElem` opts + +unregister :: Bool -> [Option] -> (String,String) -> IO () +unregister doit _ (name,ver) = + if doit then do + putStrLn $ "Deleting " ++ name ++ " " ++ ver + sandboxOpts <- getSandboxOpts <$> getSandbox + when doit $ void . system $ script sandboxOpts + else + putStrLn $ name ++ " " ++ ver + where + script sandboxOpts = "ghc-pkg unregister " ++ sandboxOpts ++ " " ++ name ++ "-" ++ ver + +---------------------------------------------------------------- + +genpaths :: FunctionCommand +genpaths _ _ = genPaths + +---------------------------------------------------------------- + +check :: FunctionCommand +check _ _ = do + sandboxOpts <- getSandboxOpts <$> getSandbox + void . system $ script sandboxOpts + where + script sandboxOpts = "ghc-pkg check -v " ++ sandboxOpts + +---------------------------------------------------------------- + +deps :: FunctionCommand +deps nmver opts = printDepends nmver opts printDeps + +revdeps :: FunctionCommand +revdeps nmver opts = printDepends nmver opts printRevDeps + +printDepends :: [String] -> [Option] + -> (Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO ()) -> IO () +printDepends nmver opts func = do + db' <- getSandbox >>= getPkgDB + pkg <- lookupPkg nmver db' + db <- getDB opts + func rec info db 0 pkg + where + rec = OptRecursive `elem` opts + info = OptInfo `elem` opts + +---------------------------------------------------------------- + +lookupPkg :: [String] -> PkgDB -> IO PkgInfo +lookupPkg [] _ = do + hPutStrLn stderr "Package name must be specified." + exitFailure +lookupPkg [name] db = checkOne $ lookupByName name db +lookupPkg [name,ver] db = checkOne $ lookupByVersion name ver db +lookupPkg _ _ = do + hPutStrLn stderr "Only one package name must be specified." + exitFailure + +checkOne :: [PkgInfo] -> IO PkgInfo +checkOne [] = do + hPutStrLn stderr "No such package found." + exitFailure +checkOne [pkg] = return pkg +checkOne pkgs = do + hPutStrLn stderr "Package version must be specified." + mapM_ (hPutStrLn stderr . fullNameOfPkgInfo) pkgs + exitFailure + +---------------------------------------------------------------- + +initSandbox :: FunctionCommand +initSandbox [] _ = void . system $ "cabal sandbox init" +initSandbox [path] _ = void . system $ "cabal sandbox init --sandbox " ++ path +initSandbox _ _ = do + hPutStrLn stderr "Only one argument is allowed" + exitFailure + +---------------------------------------------------------------- + +add :: FunctionCommand +add [src] _ = void . system $ "cabal sandbox add-source " ++ src +add _ _ = do + hPutStrLn stderr "A source path be specified." + exitFailure + +---------------------------------------------------------------- + +ghci :: FunctionCommand +ghci args _ = do + opts <- getSandboxOpts <$> getSandbox + void $ system $ "ghci" ++ " " ++ opts ++ " " ++ joinBy " " args diff --git a/Distribution/Cab/GenPaths.hs b/Distribution/Cab/GenPaths.hs new file mode 100644 --- /dev/null +++ b/Distribution/Cab/GenPaths.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Cab.GenPaths (genPaths) where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Data.List (isSuffixOf) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.Verbosity (silent) +import Distribution.Version +import System.Directory + +genPaths :: IO () +genPaths = do + (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" + where + check file = do + exist <- doesFileExist file + when exist . throwIO . userError $ file ++ " already exists" + +getNameVersion :: FilePath -> IO (String,Version) +getNameVersion file = do + desc <- readPackageDescription silent file + let pkg = package . packageDescription $ desc + PackageName nm = pkgName pkg + name = map (trans '-' '_') nm + version = pkgVersion pkg + return (name, version) + where + trans c1 c2 c + | c == c1 = c2 + | otherwise = c + +getCabalFile :: IO FilePath +getCabalFile = do + cnts <- (filter isCabal <$> getDirectoryContents ".") + >>= filterM doesFileExist + case cnts of + [] -> throwIO $ userError "Cabal file does not exist" + cfile:_ -> return cfile + where + isCabal nm = ".cabal" `isSuffixOf` nm && length nm > 6 diff --git a/Distribution/Cab/PkgDB.hs b/Distribution/Cab/PkgDB.hs new file mode 100644 --- /dev/null +++ b/Distribution/Cab/PkgDB.hs @@ -0,0 +1,127 @@ +module Distribution.Cab.PkgDB ( + -- * Types + PkgDB + , PkgInfo + -- * Obtaining 'PkgDB' + , getPkgDB + , getGlobalPkgDB + , getUserPkgDB + -- * Looking up + , lookupByName + , lookupByVersion + -- * Topological sorting + , topSortedPkgs + -- * To 'PkgInfo' + , toPkgInfos + -- * From 'PkgInfo' + , nameOfPkgInfo + , fullNameOfPkgInfo + , pairNameOfPkgInfo + , verOfPkgInfo + ) where + +import Distribution.Cab.Utils (fromDotted) +import Distribution.Cab.Version +import Distribution.Cab.VerDB (PkgName) +import Distribution.Version (Version(..)) +import Distribution.InstalledPackageInfo + (InstalledPackageInfo_(..), InstalledPackageInfo) +import Distribution.Package (PackageName(..), PackageIdentifier(..)) +import Distribution.Simple.Compiler (PackageDB(..)) +import Distribution.Simple.GHC (configure, getInstalledPackages, getPackageDBContents) +import Distribution.Simple.PackageIndex + (lookupPackageName, lookupSourcePackageId + , allPackages, fromList, reverseDependencyClosure + , topologicalOrder, PackageIndex) +import Distribution.Simple.Program.Db (defaultProgramDb) +import Distribution.Verbosity (normal) + +type PkgDB = PackageIndex +type PkgInfo = InstalledPackageInfo + +---------------------------------------------------------------- + +-- | Obtaining 'PkgDB' for global and user +-- +-- > getSandbox >>= getPkgDB +getPkgDB :: Maybe FilePath -> IO PkgDB +getPkgDB mpath = getDBs [GlobalPackageDB,userDB] + where + userDB = toUserSpec mpath + +-- | Obtaining 'PkgDB' for user +getUserPkgDB :: Maybe FilePath -> IO PkgDB +getUserPkgDB mpath = getDB userDB + where + userDB = toUserSpec mpath + +-- | Obtaining 'PkgDB' for global +getGlobalPkgDB :: IO PkgDB +getGlobalPkgDB = getDB GlobalPackageDB + +toUserSpec :: Maybe FilePath -> PackageDB +toUserSpec Nothing = UserPackageDB +toUserSpec (Just path) = SpecificPackageDB path + +getDBs :: [PackageDB] -> IO PackageIndex +getDBs specs = do + (_,_,pro) <- configure normal Nothing Nothing defaultProgramDb + getInstalledPackages normal specs pro + +getDB :: PackageDB -> IO PackageIndex +getDB spec = do + (_,_,pro) <- configure normal Nothing Nothing defaultProgramDb + getPackageDBContents normal spec pro + +---------------------------------------------------------------- + +-- | +-- +-- > pkgdb <- getGlobalPkgDB +-- > lookupByName "base" pkgdb +lookupByName :: PkgName -> PkgDB -> [PkgInfo] +lookupByName name db = concatMap snd $ lookupPackageName db (PackageName name) + +-- | +-- +-- > pkgdb <- getGlobalPkgDB +-- > lookupByVersion "base" "4.6.0.1" pkgdb +lookupByVersion :: PkgName -> String -> PkgDB -> [PkgInfo] +lookupByVersion name ver db = lookupSourcePackageId db src + where + src = PackageIdentifier { + pkgName = PackageName name + , pkgVersion = Version { + versionBranch = fromDotted ver + , versionTags = [] + } + } + +---------------------------------------------------------------- + +toPkgInfos :: PkgDB -> [PkgInfo] +toPkgInfos db = allPackages db + +---------------------------------------------------------------- + +nameOfPkgInfo :: PkgInfo -> PkgName +nameOfPkgInfo = toString . pkgName . sourcePackageId + where + toString (PackageName x) = x + +fullNameOfPkgInfo :: PkgInfo -> String +fullNameOfPkgInfo pkgi = nameOfPkgInfo pkgi ++ " " ++ verToString (verOfPkgInfo pkgi) + +pairNameOfPkgInfo :: PkgInfo -> (PkgName,String) +pairNameOfPkgInfo pkgi = (nameOfPkgInfo pkgi, verToString (verOfPkgInfo pkgi)) + +verOfPkgInfo :: PkgInfo -> Ver +verOfPkgInfo = version . pkgVersion . sourcePackageId + +---------------------------------------------------------------- + +topSortedPkgs :: PkgInfo -> PkgDB -> [PkgInfo] +topSortedPkgs pkgi db = topSort $ pkgids [pkgi] + where + pkgids = map installedPackageId + topSort = topologicalOrder . fromList . reverseDependencyClosure db diff --git a/Distribution/Cab/Printer.hs b/Distribution/Cab/Printer.hs new file mode 100644 --- /dev/null +++ b/Distribution/Cab/Printer.hs @@ -0,0 +1,91 @@ +module Distribution.Cab.Printer ( + printDeps + , printRevDeps + , extraInfo + ) where + +import Control.Monad +import Data.Function +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Distribution.Cab.PkgDB +import Distribution.Cab.Version +import Distribution.InstalledPackageInfo (InstalledPackageInfo_(..)) +import Distribution.License (License(..)) +import Distribution.Package (InstalledPackageId) +import Distribution.Simple.PackageIndex (lookupInstalledPackageId, allPackages) + +---------------------------------------------------------------- + +type RevDB = Map InstalledPackageId [InstalledPackageId] + +makeRevDepDB :: PkgDB -> RevDB +makeRevDepDB db = M.fromList revdeps + where + pkgs = allPackages db + deps = map idDeps pkgs + idDeps pkg = (installedPackageId pkg, depends pkg) + kvs = sort $ concatMap decomp deps + 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 + +---------------------------------------------------------------- + +printDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO () +printDeps rec info db n pkgi = mapM_ (printDep rec info db n) $ depends pkgi + +printDep :: Bool -> Bool -> PkgDB -> Int -> InstalledPackageId -> IO () +printDep rec info db n pid = case lookupInstalledPackageId db pid of + Nothing -> return () + Just pkgi -> do + putStr $ prefix ++ fullNameOfPkgInfo pkgi + extraInfo info pkgi + putStrLn "" + when rec $ printDeps rec info db (n+1) pkgi + where + prefix = replicate (n * 4) ' ' + +---------------------------------------------------------------- + +printRevDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO () +printRevDeps rec info db n pkgi = printRevDeps' rec info db revdb n pkgi + where + revdb = makeRevDepDB db + +printRevDeps' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> PkgInfo -> IO () +printRevDeps' rec info db revdb n pkgi = case M.lookup pkgid revdb of + Nothing -> return () + Just pkgids -> mapM_ (printRevDep' rec info db revdb n) pkgids + where + pkgid = installedPackageId pkgi + +printRevDep' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> InstalledPackageId -> IO () +printRevDep' rec info db revdb n pid = case lookupInstalledPackageId db pid of + Nothing -> return () + Just pkgi -> do + putStr $ prefix ++ fullNameOfPkgInfo pkgi + extraInfo info pkgi + putStrLn "" + when rec $ printRevDeps' rec info db revdb (n+1) pkgi + where + prefix = replicate (n * 4) ' ' + +---------------------------------------------------------------- + +extraInfo :: Bool -> PkgInfo -> IO () +extraInfo False _ = return () +extraInfo True pkgi = putStr $ " " ++ lcns ++ " \"" ++ auth ++ "\"" + where + lcns = showLicense (license pkgi) + auth = author pkgi + +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 (UnknownLicense s) = s +showLicense x = show x diff --git a/Distribution/Cab/Sandbox.hs b/Distribution/Cab/Sandbox.hs new file mode 100644 --- /dev/null +++ b/Distribution/Cab/Sandbox.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE BangPatterns #-} + +module Distribution.Cab.Sandbox ( + getSandbox + , getSandboxOpts + ) where + +import Control.Applicative ((<$>)) +import Control.Exception as E (catch, SomeException, throwIO) +import Data.Char (isSpace) +import Data.List (isPrefixOf, tails) +import System.Directory (getCurrentDirectory, doesFileExist) +import System.FilePath ((), takeDirectory, takeFileName) + +---------------------------------------------------------------- + +configFile :: String +configFile = "cabal.sandbox.config" + +pkgDbKey :: String +pkgDbKey = "package-db:" + +pkgDbKeyLen :: Int +pkgDbKeyLen = length pkgDbKey + +-- | Find a sandbox config file by tracing ancestor directories, +-- parse it and return the package db path +getSandbox :: IO (Maybe FilePath) +getSandbox = (Just <$> getPkgDb) `E.catch` handler + where + getPkgDb = getCurrentDirectory >>= getSandboxConfigFile >>= getPackageDbDir + handler :: SomeException -> IO (Maybe String) + handler _ = return Nothing + +-- | Find a sandbox config file by tracing ancestor directories. +-- Exception is thrown if not found +getSandboxConfigFile :: FilePath -> IO FilePath +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' + +-- | Extract a package db directory from the sandbox config file. +-- Exception is thrown if the sandbox config file is broken. +getPackageDbDir :: FilePath -> IO FilePath +getPackageDbDir sconf = do + -- Be strict to ensure that an error can be caught. + !path <- extractValue . parse <$> readFile sconf + return path + where + parse = head . filter ("package-db:" `isPrefixOf`) . lines + extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen + +---------------------------------------------------------------- + +-- | Generate GHC options for package db according to GHC version. +-- +-- >>> getSandboxOpts Nothing +-- "" +-- >>> getSandboxOpts (Just "/path/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") +-- "-package-db /path/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" +-- >>> 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 (Just path) = pkgOpt ++ path + where + ghcver = extractGhcVer path + 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. +-- +-- >>> extractGhcVer "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d" +-- 706 +extractGhcVer :: String -> Int +extractGhcVer dir = ver + where + file = takeFileName dir + findVer = drop 4 . head . filter ("ghc-" `isPrefixOf`) . tails + (verStr1,_:left) = break (== '.') $ findVer file + (verStr2,_) = break (== '.') left + ver = read verStr1 * 100 + read verStr2 diff --git a/Distribution/Cab/Utils.hs b/Distribution/Cab/Utils.hs new file mode 100644 --- /dev/null +++ b/Distribution/Cab/Utils.hs @@ -0,0 +1,33 @@ +module Distribution.Cab.Utils where + +import Data.List + +-- | +-- >>> fromDotted "1.2.3" +-- [1,2,3] +fromDotted :: String -> [Int] +fromDotted [] = [] +fromDotted xs = case break (=='.') xs of + (x,"") -> [read x :: Int] + (x,_:ys) -> (read x :: Int) : fromDotted ys + +-- | +-- >>> toDotted [1,2,3] +-- "1.2.3" +toDotted :: [Int] -> String +toDotted = joinBy "." . map show + +-- | +-- >>> joinBy "," ["foo","bar","baz"] +-- "foo,bar,baz" +joinBy :: String -> [String] -> String +joinBy = intercalate + +-- | +-- >>> split 4 "0123457689" +-- ["0123","4576","89"] +split :: Int -> [a] -> [[a]] +split _ [] = [] +split n ss = x : split n rest + where + (x,rest) = splitAt n ss diff --git a/Distribution/Cab/VerDB.hs b/Distribution/Cab/VerDB.hs new file mode 100644 --- /dev/null +++ b/Distribution/Cab/VerDB.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Distribution.Cab.VerDB ( + -- * Types + PkgName + , VerDB + , HowToObtain(..) + -- * Creating + , getVerDB + -- * Converting + , toList + , toMap + ) where + +import Control.Applicative +import Control.Arrow (second) +import Data.Attoparsec.ByteString.Char8 +import Data.Conduit +import Data.Conduit.Attoparsec +import Data.Conduit.Process +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Distribution.Cab.Version + +---------------------------------------------------------------- + +type PkgName = String + +type VerInfo = (PkgName, Maybe [Int]) + +newtype VerDB = VerDB [(PkgName,Ver)] deriving (Eq, Show) + +data HowToObtain = InstalledOnly | AllRegistered + +---------------------------------------------------------------- + +getVerDB :: HowToObtain -> IO VerDB +getVerDB how = VerDB . justOnly <$> verInfos + where + script = case how of + InstalledOnly -> "cabal list --installed" + AllRegistered -> "cabal list" + verInfos = runResourceT $ sourceCmd script $$ cabalListParser + justOnly = map (second (toVer . fromJust)) . filter (isJust . snd) + cabalListParser = sinkParser verinfos + +---------------------------------------------------------------- + +-- | Converting 'VerDB' to alist. +-- +-- >>> db <- getVerDB InstalledOnly +-- >>> elem "base" . map fst . toList $ db +-- True +toList :: VerDB -> [(PkgName, Ver)] +toList (VerDB alist) = alist + +-- | Converting 'VerDB' to 'Map'. +toMap :: VerDB -> Map PkgName Ver +toMap (VerDB alist) = M.fromList alist + +---------------------------------------------------------------- + +verinfos :: Parser [VerInfo] +verinfos = many1 verinfo + +verinfo :: Parser VerInfo +verinfo = do + name <- string "* " *> nonEols <* endOfLine + synpsis + lat <- latestLabel *> latest <* endOfLine + _ <- many skip + endOfLine + return (name, lat) + where + 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 () + where + more = () <$ many (string " " *> nonEols *> endOfLine) + latest = Nothing <$ (char '[' *> nonEols) + <|> Just <$> dotted + +dotted :: Parser [Int] +dotted = decimal `sepBy` char '.' + +nonEols :: Parser String +nonEols = many1 $ satisfy (notInClass "\r\n") diff --git a/Distribution/Cab/Version.hs b/Distribution/Cab/Version.hs new file mode 100644 --- /dev/null +++ b/Distribution/Cab/Version.hs @@ -0,0 +1,43 @@ +module Distribution.Cab.Version ( + Ver + , toVer + , verToString + , version + , versionToString + ) where + +import Distribution.Cab.Utils +import Distribution.Version (Version(..)) + +-- | Package version. +newtype Ver = Ver [Int] deriving (Eq,Show) + +-- | Creating 'Ver'. +-- +-- >>> toVer [1,2,3] +-- Ver [1,2,3] +toVer :: [Int] -> Ver +toVer is = Ver is + +-- | From 'Version' to 'String' +-- +-- >>> verToString $ toVer [1,2,3] +-- "1.2.3" +verToString :: Ver -> String +verToString (Ver ver) = toDotted ver + +-- | From 'Version' in Cabal to 'Ver'. +-- +-- >>> version $ Version [1,2,3] [] +-- Ver [1,2,3] +version :: Version -> Ver +version = Ver . versionBranch + +-- | From 'Version' in Cabal to 'String'. +-- +-- >>> versionToString $ Version [1,2,3] [] +-- "1.2.3" +versionToString :: Version -> String +versionToString = verToString . version + + diff --git a/Env.hs b/Env.hs deleted file mode 100644 --- a/Env.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Env (unsetEnv) where - -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) -unsetEnv :: String -> IO () -unsetEnv _ = return () -#else -import System.Posix.Env (unsetEnv) -#endif diff --git a/GenPaths.hs b/GenPaths.hs deleted file mode 100644 --- a/GenPaths.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module GenPaths (genPaths) where - -import Control.Applicative -import Control.Exception -import Control.Monad -import Data.List (isSuffixOf) -import Distribution.Package -import Distribution.PackageDescription -import Distribution.PackageDescription.Parse (readPackageDescription) -import Distribution.Verbosity (silent) -import Distribution.Version -import System.Directory - -genPaths :: IO () -genPaths = do - (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" - where - check file = do - exist <- doesFileExist file - when exist . throwIO . userError $ file ++ " already exists" - -getNameVersion :: FilePath -> IO (String,Version) -getNameVersion file = do - desc <- readPackageDescription silent file - let pkg = package . packageDescription $ desc - PackageName nm = pkgName pkg - name = map (trans '-' '_') nm - version = pkgVersion pkg - return (name, version) - where - trans c1 c2 c - | c == c1 = c2 - | otherwise = c - -getCabalFile :: IO FilePath -getCabalFile = do - cnts <- (filter isCabal <$> getDirectoryContents ".") - >>= filterM doesFileExist - case cnts of - [] -> throwIO $ userError "Cabal file does not exist" - cfile:_ -> return cfile - where - isCabal nm = ".cabal" `isSuffixOf` nm && length nm > 6 diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Main where - -import CmdDB -import Control.Applicative -import Control.Exception -import Control.Monad -import Data.Maybe -import Prelude hiding (catch) -import System.Cmd -import System.Console.GetOpt -import System.Environment -import System.Exit -import Env -import Types -import Utils - ----------------------------------------------------------------- - -main :: IO () -main = flip catches handlers $ do - unsetEnv "GHC_PACKAGE_PATH" - oargs <- getArgs - let pargs = parseArgs getOptDB oargs - checkOptions1 pargs illegalOptionsAndExit - let Right (args,opts0) = pargs - when (args == []) helpAndExit - when (OptHelp `elem` opts0) $ helpCommandAndExit undefined args undefined - let opts1 = filter (/= OptHelp) opts0 - act:params = args - mcmdspec = commandSpecByName act commandDB - when (isNothing mcmdspec) (illegalCommandAndExit act) - let Just cmdspec = mcmdspec - checkOptions2 opts1 cmdspec oargs illegalOptionsAndExit - opts <- sandboxEnv cmdspec opts1 - run cmdspec params opts - where - handlers = [Handler handleExit] - handleExit :: ExitCode -> IO () - handleExit _ = return () - ----------------------------------------------------------------- - -parseArgs :: [GetOptSpec] -> [Arg] -> ParsedArgs -parseArgs db args = case getOpt' Permute db args of - (o,n,[],[]) -> Right (n,o) - (_,_,unknowns,_) -> Left unknowns - -checkOptions1 :: ParsedArgs -> ([UnknownOpt] -> IO ()) -> IO () -checkOptions1 (Left es) func = func es -checkOptions1 _ _ = return () - -checkOptions2 :: [Option] -> CommandSpec -> [Arg] -> ([UnknownOpt] -> IO ()) -> IO () -checkOptions2 opts cmdspec oargs func = do - let unknowns = check specified supported - when (unknowns /= []) $ func (concatMap (resolveOptionString oargs) unknowns) - where - check [] _ = [] - check (x:xs) ys - | x `elem` ys = check xs ys - | otherwise = x : check xs ys - specified = map toSwitch opts - supported = map fst $ switches cmdspec - -sandboxEnv :: CommandSpec -> [Option] -> IO [Option] -sandboxEnv cmdspec opts = - if hasSandboxOption cmdspec && command cmdspec /= Env - then tryEnv `catch` ignore - else return opts - where - tryEnv = (\path -> OptSandbox path : opts) <$> getEnv cabEnvVar - ignore :: SomeException -> IO [Option] - ignore _ = return opts - -hasSandboxOption :: CommandSpec -> Bool -hasSandboxOption cmdspec = isJust $ lookup SwSandbox (switches cmdspec) - ----------------------------------------------------------------- - -run :: CommandSpec -> [Arg] -> [Option] -> IO () -run cmdspec params opts = case routing cmdspec of - RouteFunc func -> func cmdspec params opts - RouteCabal subargs -> callProcess pro subargs params opts sws - where - pro = cabalCommand opts - sws = switches cmdspec - -callProcess :: String -> [String] -> [Arg] -> [Option] -> [SwitchSpec] -> IO () -callProcess pro args0 args1 opts sws = void . system $ script - where - swchs = optionsToString opts sws - script = joinBy " " $ pro : args0 ++ cat args1 ++ swchs - cat [pkg,ver] = [pkg ++ "-" ++ ver] - cat x = x diff --git a/PkgDB.hs b/PkgDB.hs deleted file mode 100644 --- a/PkgDB.hs +++ /dev/null @@ -1,196 +0,0 @@ -module PkgDB where - -import Control.Monad -import Data.Function -import Data.List -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (isNothing) -import Distribution.Compiler - (CompilerId(..)) -import Distribution.License - (License(..)) -import Distribution.Version - (Version(..)) -import Distribution.InstalledPackageInfo - (InstalledPackageInfo_(..), InstalledPackageInfo) -import Distribution.Package - (PackageName(..), PackageIdentifier(..), InstalledPackageId) -import Distribution.Simple.Compiler - (PackageDB(..),Compiler(..)) -import Distribution.Simple.GHC - (configure, getInstalledPackages) -import Distribution.Simple.PackageIndex - (lookupPackageName, lookupSourcePackageId, lookupInstalledPackageId - , allPackages, fromList, reverseDependencyClosure - , topologicalOrder, PackageIndex) -import Distribution.Simple.Program.Db - (defaultProgramDb) -import Distribution.Verbosity - (normal) -import System.FilePath -import Utils - -type PkgDB = PackageIndex -type PkgInfo = InstalledPackageInfo - ----------------------------------------------------------------- - -getPkgDB :: Maybe FilePath -> IO PkgDB -getPkgDB mpath = do - (com,pro) <- configure normal Nothing Nothing defaultProgramDb - let userDB = case mpath of - Nothing -> UserPackageDB - Just path -> SpecificPackageDB $ packageConf path com - getInstalledPackages normal [GlobalPackageDB,userDB] pro - -getGlobalPkgDB :: IO PkgDB -getGlobalPkgDB = do - (_,pro) <- configure normal Nothing Nothing defaultProgramDb - getInstalledPackages normal [GlobalPackageDB] pro - -getPackageConf :: FilePath -> IO FilePath -getPackageConf path = do - (com,_) <- configure normal Nothing Nothing defaultProgramDb - return $ packageConf path com - -packageConf :: FilePath -> Compiler -> FilePath -packageConf path com = path "packages-" ++ version ver ++ ".conf" - where - CompilerId _ ver = compilerId com - -toPkgDB :: [PkgInfo] -> PkgDB -toPkgDB = fromList - -version :: Version -> String -version = toDotted . versionBranch - ----------------------------------------------------------------- - -lookupByName :: String -> PkgDB -> [PkgInfo] -lookupByName name db = concatMap snd $ lookupPackageName db (PackageName name) - -lookupByVersion :: String -> String -> PkgDB -> [PkgInfo] -lookupByVersion name ver db = lookupSourcePackageId db src - where - src = PackageIdentifier { - pkgName = PackageName name - , pkgVersion = Version { - versionBranch = fromDotted ver - , versionTags = [] - } - } - ----------------------------------------------------------------- - -toPkgList :: (PkgInfo -> Bool) -> PkgDB -> [PkgInfo] -toPkgList prd db = filter prd $ allPackages db - -userPkgs :: IO (PkgInfo -> Bool) -userPkgs = do - gDB <- getGlobalPkgDB - return$ \pkgi -> isNothing$ lookupInstalledPackageId gDB (installedPackageId pkgi) - -allPkgs :: IO (PkgInfo -> Bool) -allPkgs = return (const True) - ----------------------------------------------------------------- - -fullNameOfPkgInfo :: PkgInfo -> String -fullNameOfPkgInfo pkgi = nameOfPkgInfo pkgi ++ " " ++ versionOfPkgInfo pkgi - -pairNameOfPkgInfo :: PkgInfo -> (String,String) -pairNameOfPkgInfo pkgi = (nameOfPkgInfo pkgi, versionOfPkgInfo pkgi) - -nameOfPkgInfo :: PkgInfo -> String -nameOfPkgInfo = toString . pkgName . sourcePackageId - where - toString (PackageName x) = x - -versionOfPkgInfo :: PkgInfo -> String -versionOfPkgInfo = toDotted . numVersionOfPkgInfo - -numVersionOfPkgInfo :: PkgInfo -> [Int] -numVersionOfPkgInfo = versionBranch . pkgVersion . sourcePackageId - ----------------------------------------------------------------- - -extraInfo :: Bool -> PkgInfo -> IO () -extraInfo False _ = return () -extraInfo True pkgi = putStr $ " " ++ lcns ++ " \"" ++ auth ++ "\"" - where - lcns = showLicense (license pkgi) - auth = author pkgi - ----------------------------------------------------------------- - -printDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO () -printDeps rec info db n pkgi = mapM_ (printDep rec info db n) $ depends pkgi - -printDep :: Bool -> Bool -> PkgDB -> Int -> InstalledPackageId -> IO () -printDep rec info db n pid = case lookupInstalledPackageId db pid of - Nothing -> return () - Just pkgi -> do - putStr $ prefix ++ fullNameOfPkgInfo pkgi - extraInfo info pkgi - putStrLn "" - when rec $ printDeps rec info db (n+1) pkgi - where - prefix = replicate (n * 4) ' ' - -showLicense :: License -> String -showLicense (GPL (Just v)) = "GPL" ++ version v -showLicense (GPL Nothing) = "GPL" -showLicense (LGPL (Just v)) = "LGPL" ++ version v -showLicense (LGPL Nothing) = "LGPL" -showLicense (UnknownLicense s) = s -showLicense x = show x - ----------------------------------------------------------------- - -printRevDeps :: Bool -> Bool -> PkgDB -> Int -> PkgInfo -> IO () -printRevDeps rec info db n pkgi = printRevDeps' rec info db revdb n pkgi - where - revdb = makeRevDepDB db - -printRevDeps' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> PkgInfo -> IO () -printRevDeps' rec info db revdb n pkgi = case M.lookup pkgid revdb of - Nothing -> return () - Just pkgids -> mapM_ (printRevDep' rec info db revdb n) pkgids - where - pkgid = installedPackageId pkgi - -printRevDep' :: Bool -> Bool -> PkgDB -> RevDB -> Int -> InstalledPackageId -> IO () -printRevDep' rec info db revdb n pid = case lookupInstalledPackageId db pid of - Nothing -> return () - Just pkgi -> do - putStr $ prefix ++ fullNameOfPkgInfo pkgi - extraInfo info pkgi - putStrLn "" - when rec $ printRevDeps' rec info db revdb (n+1) pkgi - where - prefix = replicate (n * 4) ' ' - ----------------------------------------------------------------- - -type RevDB = Map InstalledPackageId [InstalledPackageId] - -makeRevDepDB :: PkgDB -> RevDB -makeRevDepDB db = M.fromList revdeps - where - pkgs = allPackages db - deps = map idDeps pkgs - idDeps pkg = (installedPackageId pkg, depends pkg) - kvs = sort $ concatMap decomp deps - 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 - ----------------------------------------------------------------- - -topSortedPkgs :: PkgInfo -> PkgDB -> [PkgInfo] -topSortedPkgs pkgi db = topSort $ pkgids [pkgi] - where - pkgids = map installedPackageId - topSort = topologicalOrder . fromList . reverseDependencyClosure db diff --git a/Program.hs b/Program.hs deleted file mode 100644 --- a/Program.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Program ( - version, showVersion - , programName, description - ) where - -import Paths_cab -import Data.Version - -programName :: String -programName = "cab" - -description :: String -description = "A maintenance command of Haskell cabal packages" diff --git a/Types.hs b/Types.hs deleted file mode 100644 --- a/Types.hs +++ /dev/null @@ -1,122 +0,0 @@ -module Types where - -import Data.List -import System.Console.GetOpt - -type Arg = String -type UnknownOpt = String -type ParsedArgs = Either [UnknownOpt] ([Arg],[Option]) - ----------------------------------------------------------------- - -data Switch = SwNoharm - | SwRecursive - | SwAll - | SwInfo - | SwSandbox - | SwFlag - | SwTest - | SwBench - deriving (Eq,Show) - -data Option = OptNoharm - | OptRecursive - | OptAll - | OptInfo - | OptSandbox String - | OptFlag String - | OptTest - | OptHelp - | OptBench - deriving (Eq,Show) - -toSwitch :: Option -> Switch -toSwitch OptNoharm = SwNoharm -toSwitch OptRecursive = SwRecursive -toSwitch OptAll = SwAll -toSwitch OptInfo = SwInfo -toSwitch (OptSandbox _) = SwSandbox -toSwitch (OptFlag _) = SwFlag -toSwitch OptTest = SwTest -toSwitch OptBench = SwBench -toSwitch _ = error "toSwitch" - -getSandbox :: [Option] -> Maybe FilePath -getSandbox = getValue (\x -> toSwitch x == SwSandbox) - -getFlag :: [Option] -> Maybe FilePath -getFlag = getValue (\x -> toSwitch x == SwFlag) - -getValue :: (Option -> Bool) -> [Option] -> Maybe FilePath -getValue p opts = case find p opts of - Nothing -> Nothing - Just (OptSandbox path) -> Just path - _ -> error "getSandbox" - -type SwitchSpec = (Switch, Maybe String) -type SwitchDB = [SwitchSpec] - -type GetOptSpec = OptDescr Option -type GetOptDB = [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 - | Env - | Add - | Ghci - | Test - | Bench - | Doc - | Help - deriving (Eq,Show) - -data CommandSpec = CommandSpec { - command :: Command - , commandNames :: [String] - , document :: String - , routing :: Route - , switches :: SwitchDB - , manual :: Maybe String - } - -type CommandDB = [CommandSpec] - ----------------------------------------------------------------- - -type FunctionCommand = CommandSpec -> [String] -> [Option] -> IO () - -data Route = RouteFunc FunctionCommand - | RouteCabal [String] - -cabalCommand :: [Option] -> String -cabalCommand opts - | SwSandbox `elem` map toSwitch opts = "cabal-dev" - | otherwise = "cabal" - ----------------------------------------------------------------- - -cabEnvVar :: String -cabEnvVar = "CAB_SANDBOX_PATH" - -ghcEnvVar :: String -ghcEnvVar = "GHC_PACKAGE_PATH" diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 --- a/Utils.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Utils where - -import Data.List - -fromDotted :: String -> [Int] -fromDotted [] = [] -fromDotted xs = case break (=='.') xs of - (x,"") -> [read x :: Int] - (x,_:ys) -> (read x :: Int) : fromDotted ys - -toDotted :: [Int] -> String -toDotted = joinBy "." . map show - -joinBy :: String -> [String] -> String -joinBy = intercalate - -split :: Int -> [a] -> [[a]] -split _ [] = [] -split n ss = x : split n rest - where - (x,rest) = splitAt n ss diff --git a/VerDB.hs b/VerDB.hs deleted file mode 100644 --- a/VerDB.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module VerDB ( - VerDB, getVerDB, lookupLatestVersion, getVerAlist - ) where - -import Control.Applicative -import Control.Arrow (second) -import Data.Attoparsec.ByteString.Char8 -import Data.Conduit -import Data.Conduit.Attoparsec -import Data.Conduit.Process -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe - ----------------------------------------------------------------- - -type VerInfo = (String, Maybe [Int]) - -data VerDB = VerDB (Map String [Int]) - ----------------------------------------------------------------- - -getVerDB :: IO VerDB -getVerDB = VerDB . M.fromList <$> getVerAlist True - -getVerAlist :: Bool -> IO [(String,[Int])] -getVerAlist installedOnly = justOnly <$> verInfos - where - script = if installedOnly - then "cabal list --installed" - else "cabal list" - verInfos = runResourceT $ sourceCmd script $$ cabalListParser - justOnly = map (second fromJust) . filter (isJust . snd) - - cabalListParser = sinkParser verinfos - ----------------------------------------------------------------- - -lookupLatestVersion :: String -> VerDB -> Maybe [Int] -lookupLatestVersion pkgid (VerDB db) = M.lookup pkgid db - ----------------------------------------------------------------- - -verinfos :: Parser [VerInfo] -verinfos = many1 verinfo - -verinfo :: Parser VerInfo -verinfo = do - name <- string "* " *> nonEols <* endOfLine - synpsis - lat <- latestLabel *> latest <* endOfLine - _ <- many skip - endOfLine - return (name, lat) - where - 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 () - where - more = () <$ many (string " " *> nonEols *> endOfLine) - latest = Nothing <$ (char '[' *> nonEols) - <|> Just <$> dotted - -dotted :: Parser [Int] -dotted = decimal `sepBy` char '.' - -nonEols :: Parser String -nonEols = many1 $ satisfy (notInClass "\r\n") diff --git a/cab.cabal b/cab.cabal --- a/cab.cabal +++ b/cab.cabal @@ -1,5 +1,5 @@ Name: cab -Version: 0.1.15 +Version: 0.2.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -14,14 +14,41 @@ this command helps you. Homepage: http://www.mew.org/~kazu/proj/cab/ Category: Distribution -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.10 Build-Type: Simple +Library + Default-Language: Haskell2010 + GHC-Options: -Wall + Build-Depends: base >= 4.0 && < 5 + , Cabal + , attoparsec >= 0.10 + , attoparsec-conduit >= 0.3 + , bytestring + , conduit >= 0.3 + , containers + , directory + , filepath + , process + , process-conduit >= 0.1 + Exposed-Modules: Distribution.Cab + Distribution.Cab.PkgDB + Distribution.Cab.Printer + Distribution.Cab.Sandbox + Distribution.Cab.VerDB + Distribution.Cab.Version + Other-Modules: Distribution.Cab.Commands + Distribution.Cab.GenPaths + Distribution.Cab.Utils + Executable cab + Default-Language: Haskell2010 Main-Is: Main.hs GHC-Options: -Wall + HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 - , Cabal + , cab + , Cabal >= 1.18 , attoparsec >= 0.10 , attoparsec-conduit >= 0.3 , bytestring @@ -35,16 +62,22 @@ Build-Depends: else Build-Depends: unix - Other-Modules: CmdDB - Commands - Env - GenPaths - PkgDB + Other-Modules: Commands + Help + Options Program Types - Utils - VerDB Paths_cab + +-- Test-Suite doctest +-- Type: exitcode-stdio-1.0 +-- Default-Language: Haskell2010 +-- HS-Source-Dirs: test +-- Ghc-Options: -threaded -Wall +-- Main-Is: doctests.hs +-- Build-Depends: base +-- , doctest >= 0.9.3 + Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/cab.git diff --git a/src/Commands.hs b/src/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Commands.hs @@ -0,0 +1,235 @@ +module Commands (commandDB, commandSpecByName) where + +import Distribution.Cab + +import {-# SOURCE #-} Help (helpCommandAndExit) +import Types + +---------------------------------------------------------------- + +commandDB :: CommandDB +commandDB = [ + CommandSpec { + command = Sync + , commandNames = ["sync", "update"] + , document = "Fetch the latest package index" + , routing = RouteCabal ["update"] + , switches = [] + , manual = Nothing + } + , CommandSpec { + command = Install + , commandNames = ["install"] + , document = "Install packages" + , routing = RouteCabal ["install"] + , switches = [(SwNoharm, Solo "--dry-run -v") + ,(SwFlag, WithArg "--flags") + ,(SwTest, Solo "--enable-tests") + ,(SwDepsOnly, Solo "--only-dependencies") + ,(SwLibProfile, Solo "--enable-library-profiling") + ,(SwExecProfile, Solo "--enable-executable-profiling") + ,(SwJobs, WithArg "--jobs") + ] + , 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 ["configure"] + , switches = [(SwFlag, WithArg "--flags") + ,(SwTest, Solo "--enable-tests") + ,(SwBench, Solo "--enable-benchmarks") + ,(SwLibProfile, Solo "--enable-library-profiling") + ,(SwExecProfile, Solo "--enable-executable-profiling") + ] + , manual = Nothing + } + , CommandSpec { + command = Build + , commandNames = ["build"] + , document = "Build a cabal package" + , routing = RouteCabal ["build"] + , switches = [(SwJobs, WithArg "--jobs")] + , manual = Nothing + } + , CommandSpec { + command = Clean + , commandNames = ["clean"] + , document = "Clean up a build directory" + , routing = RouteCabal ["clean"] + , switches = [] + , manual = Nothing + } + , CommandSpec { + command = Outdated + , commandNames = ["outdated"] + , document = "Display outdated packages" + , routing = RouteFunc outdated + , switches = [(SwAll, None)] + , manual = Nothing + } + , CommandSpec { + command = Info + , commandNames = ["info"] + , document = "Display information of a package" + , routing = RouteCabal ["info"] + , switches = [] + , manual = Just " []" + } + , CommandSpec { + command = Sdist + , commandNames = ["sdist", "pack"] + , document = "Make tar.gz for source distribution" + , routing = RouteCabal ["sdist"] + , switches = [] + , manual = Nothing + } + , CommandSpec { + command = Upload + , commandNames = ["upload", "up"] + , document = "Uploading tar.gz to HackageDB" + , routing = RouteCabal ["upload"] + , switches = [(SwNoharm, Solo "-c")] + , manual = Nothing + } + , CommandSpec { + command = Unpack + , commandNames = ["unpack"] + , document = "Untar a package in the current directory" + , routing = RouteCabal ["unpack"] + , switches = [] + , manual = Just " []" + } + , 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 ["test"] + , switches = [] + , manual = Nothing + } + , CommandSpec { + command = Bench + , commandNames = ["bench"] + , document = "Run benchmarks" + , routing = RouteCabal ["bench"] + , switches = [] + , manual = Nothing + } + , CommandSpec { + command = Doc + , commandNames = ["doc", "haddock", "man"] + , document = "Generate manuals" + , routing = RouteCabal ["haddock", "--hyperlink-source"] + , switches = [] + , manual = Nothing + } + , CommandSpec { + command = Ghci + , commandNames = ["ghci", "repl"] + , document = "Run GHCi (with a sandbox)" + , routing = RouteFunc ghci + , switches = [] + , manual = Nothing + } + , CommandSpec { + command = Init + , commandNames = ["init"] + , document = "Initialize a sandbox" + , routing = RouteFunc initSandbox + , switches = [] + , manual = Nothing + } + , CommandSpec { + command = Help + , commandNames = ["help"] + , document = "Display the help message of the command" + , routing = RouteFunc helpCommandAndExit + , switches = [] + , manual = Just "[]" + } + ] + +---------------------------------------------------------------- + +commandSpecByName :: String -> CommandDB -> Maybe CommandSpec +commandSpecByName _ [] = Nothing +commandSpecByName x (ent:ents) + | x `elem` commandNames ent = Just ent + | otherwise = commandSpecByName x ents diff --git a/src/Help.hs b/src/Help.hs new file mode 100644 --- /dev/null +++ b/src/Help.hs @@ -0,0 +1,111 @@ +module Help ( + helpAndExit + , helpCommandAndExit + , illegalOptionsAndExit + , illegalCommandAndExit + ) where + +import Control.Monad +import Data.List +import Distribution.Cab +import System.Console.GetOpt +import System.Exit +import System.IO + +import Commands +import Options +import Program +import Types + +---------------------------------------------------------------- + +helpCommandAndExit :: FunctionCommand +helpCommandAndExit [] _ = helpAndExit +helpCommandAndExit (cmd:_) _ = do + case mcmdspec of + Nothing -> helpAndExit + Just cmdspec -> do + putStrLn $ "Usage: " ++ cmd ++ " " ++ showOptions cmdspec ++ showArgs cmdspec + putStr "\n" + putStrLn $ document cmdspec + putStr "\n" + putStrLn $ "Aliases: " ++ showAliases cmdspec + putStr "\n" + printOptions cmdspec + exitSuccess + where + mcmdspec = commandSpecByName cmd commandDB + showOptions cmdspec = "[" ++ joinBy "] [" (concatMap (masterOption optionDB) (opts cmdspec)) ++ "]" + showArgs cmdspec = maybe "" (" " ++) $ manual cmdspec + opts = map fst . switches + masterOption [] _ = [] + masterOption (spec:specs) o + | fst spec == o = optionName spec : masterOption specs o + | otherwise = masterOption specs o + showAliases = joinBy ", " . commandNames + +printOptions :: CommandSpec -> IO () +printOptions cmdspec = + forM_ opts (printOption optionDB) + where + opts = map fst $ switches cmdspec + printOption [] _ = return () + printOption (spec:specs) o + | fst spec == o = + putStrLn $ (joinBy ", " . reverse . optionNames $ spec) + ++ "\t" ++ optionDesc spec + | otherwise = printOption specs o + +---------------------------------------------------------------- + +optionName :: OptionSpec -> String +optionName (_,Option (c:_) _ (ReqArg _ arg) _) = '-':c:' ':arg +optionName (_,Option (c:_) _ _ _) = '-':[c] +optionName _ = "" + +optionNames :: OptionSpec -> [String] +optionNames (_,Option (c:_) (s:_) _ _) = ['-':[c],'-':'-':s] +optionNames _ = [] + +optionDesc :: OptionSpec -> String +optionDesc (_,Option _ _ _ desc) = desc + +---------------------------------------------------------------- + +helpAndExit :: IO () +helpAndExit = do + putStrLn $ programName ++ " " ++ " -- " ++ description + putStrLn "" + putStrLn $ "Version: " ++ showVersion version + putStrLn "Usage:" + putStrLn $ "\t" ++ programName + putStrLn $ "\t" ++ programName ++ " [args...]" + putStrLn "\t where" + printCommands (getCommands commandDB) + exitSuccess + where + getCommands = map concat + . split helpCommandNumber + . intersperse ", " + . map (head . commandNames) + printCommands [] = return () + printCommands (x:xs) = do + putStrLn $ "\t = " ++ x + mapM_ (\cmds -> putStrLn $ "\t " ++ cmds) xs + +helpCommandNumber :: Int +helpCommandNumber = 10 + +---------------------------------------------------------------- + +illegalCommandAndExit :: String -> IO () +illegalCommandAndExit x = do + hPutStrLn stderr $ "Illegal command: " ++ x + exitFailure + +---------------------------------------------------------------- + +illegalOptionsAndExit :: [UnknownOpt] -> IO () +illegalOptionsAndExit xs = do -- FixME + hPutStrLn stderr $ "Illegal options: " ++ joinBy " " xs + exitFailure diff --git a/src/Help.hs-boot b/src/Help.hs-boot new file mode 100644 --- /dev/null +++ b/src/Help.hs-boot @@ -0,0 +1,5 @@ +module Help where + +import Distribution.Cab + +helpCommandAndExit :: FunctionCommand diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,104 @@ +module Main where + +import Control.Exception (Handler(..)) +import qualified Control.Exception as E +import Control.Monad +import Data.Maybe +import Data.List (isPrefixOf) +import Distribution.Cab +import System.Cmd +import System.Console.GetOpt +import System.Environment +import System.Exit + +import Commands +import Help +import Options +import Types + +---------------------------------------------------------------- + +main :: IO () +main = flip E.catches handlers $ do + oargs <- getArgs + let pargs = parseArgs getOptDB oargs + checkOptions1 pargs illegalOptionsAndExit + let Right (args,opts0) = pargs + when (args == []) helpAndExit + when (OptHelp `elem` opts0) $ helpCommandAndExit args undefined + let opts1 = filter (/= OptHelp) opts0 + act:params = args + mcmdspec = commandSpecByName act commandDB + when (isNothing mcmdspec) (illegalCommandAndExit act) + let Just cmdspec = mcmdspec + checkOptions2 opts1 cmdspec oargs illegalOptionsAndExit + run cmdspec params opts1 + where + handlers = [Handler handleExit] + handleExit :: ExitCode -> IO () + handleExit _ = return () + +---------------------------------------------------------------- + +parseArgs :: [GetOptSpec] -> [Arg] -> ParsedArgs +parseArgs db args = case getOpt' Permute db args of + (o,n,[],[]) -> Right (n,o) + (_,_,unknowns,_) -> Left unknowns + +checkOptions1 :: ParsedArgs -> ([UnknownOpt] -> IO ()) -> IO () +checkOptions1 (Left es) func = func es +checkOptions1 _ _ = return () + +checkOptions2 :: [Option] -> CommandSpec -> [Arg] -> ([UnknownOpt] -> IO ()) -> IO () +checkOptions2 opts cmdspec oargs func = do + let unknowns = chk specified supported + when (unknowns /= []) $ func (concatMap (resolveOptionString oargs) unknowns) + where + 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 + +---------------------------------------------------------------- + +run :: CommandSpec -> [Arg] -> [Option] -> IO () +run cmdspec params opts = case routing cmdspec of + RouteFunc func -> func params opts + RouteCabal subargs -> callProcess pro subargs params opts sws + where + pro = "cabal" + sws = switches cmdspec + +callProcess :: String -> [String] -> [Arg] -> [Option] -> [SwitchSpec] -> IO () +callProcess pro args0 args1 opts sws = void . system $ script + where + swchs = optionsToString opts sws + script = joinBy " " $ pro : args0 ++ cat args1 ++ swchs + cat [pkg,ver] = [pkg ++ "-" ++ ver] + cat x = x + +---------------------------------------------------------------- + +getOptNames :: GetOptSpec -> (String,String) +getOptNames (Option (c:_) (s:_) _ _) = ('-':[c],'-':'-':s) +getOptNames _ = error "getOptNames" + +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 + where + checkShort s = filter (==s) oargs + checkLong l = filter (l `isPrefixOf`) oargs + +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] + Just (WithArg x) -> [x ++ "=" ++ optionArg opt] diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -0,0 +1,51 @@ +module Options (optionDB, getOptDB) where + +import Distribution.Cab +import System.Console.GetOpt + +import Types + +---------------------------------------------------------------- + +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 ['i'] ["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'] ["libr-prof"] + (NoArg OptLibProfile) + "Enable library profiling" + , Option ['e'] ["exec-prof"] + (NoArg OptExecProfile) + "Enable library profiling" + , Option ['j'] ["jobs"] + (ReqArg OptJobs "") + "Run N jobs" + , Option ['h'] ["help"] + (NoArg OptHelp) + "Show help message" + ] + +optionDB :: OptionDB +optionDB = zip [SwNoharm,SwRecursive,SwAll,SwInfo,SwFlag,SwTest,SwBench,SwDepsOnly,SwLibProfile,SwExecProfile,SwJobs] getOptDB diff --git a/src/Program.hs b/src/Program.hs new file mode 100644 --- /dev/null +++ b/src/Program.hs @@ -0,0 +1,13 @@ +module Program ( + version, showVersion + , programName, description + ) where + +import Paths_cab +import Data.Version + +programName :: String +programName = "cab" + +description :: String +description = "A maintenance command of Haskell cabal packages" diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,101 @@ +module Types where + +import Distribution.Cab +import System.Console.GetOpt + +type Arg = String +type UnknownOpt = String +type ParsedArgs = Either [UnknownOpt] ([Arg],[Option]) + +---------------------------------------------------------------- + +data Switch = SwNoharm + | SwRecursive + | SwAll + | SwInfo + | SwFlag + | SwTest + | SwBench + | SwDepsOnly + | SwLibProfile + | SwExecProfile + | SwJobs + deriving (Eq,Show) + +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 OptExecProfile = SwExecProfile +toSwitch (OptJobs _) = SwJobs +toSwitch _ = error "toSwitch" + +---------------------------------------------------------------- + +optionArg :: Option -> String +optionArg (OptFlag str) = str +optionArg (OptJobs str) = str +optionArg _ = "" + +---------------------------------------------------------------- + +data SwitchKind = None | Solo String | WithArg String + +type SwitchSpec = (Switch, SwitchKind) +type SwitchDB = [SwitchSpec] + +type GetOptSpec = OptDescr Option +type GetOptDB = [GetOptSpec] + +type OptionSpec = (Switch,GetOptSpec) +type OptionDB = [OptionSpec] + +---------------------------------------------------------------- + +data Command = Sync + | Install + | Uninstall + | Installed + | Configure + | Build + | Clean + | Outdated + | Sdist + | Upload + | Unpack + | Info + | Deps + | RevDeps + | Check + | GenPaths + | Search + | Add + | Ghci + | Test + | Bench + | Doc + | Init + | Help + deriving (Eq,Show) + +data CommandSpec = CommandSpec { + command :: Command + , commandNames :: [String] + , document :: String + , routing :: Route + , switches :: SwitchDB + , manual :: Maybe String + } + +type CommandDB = [CommandSpec] + +---------------------------------------------------------------- + +data Route = RouteFunc FunctionCommand + | RouteCabal [String]