cab (empty) → 0.0.0
raw patch · 12 files changed
+912/−0 lines, 12 filesdep +Cabaldep +attoparsecdep +attoparsec-enumeratorsetup-changed
Dependencies added: Cabal, attoparsec, attoparsec-enumerator, base, bytestring, containers, directory, enumerator, filepath, process
Files
- CmdDB.hs +265/−0
- Commands.hs +120/−0
- LICENSE +29/−0
- Main.hs +77/−0
- PkgDB.hs +153/−0
- Process.hs +25/−0
- Program.hs +10/−0
- Setup.hs +2/−0
- Types.hs +98/−0
- Utils.hs +21/−0
- VerDB.hs +73/−0
- cab.cabal +39/−0
+ CmdDB.hs view
@@ -0,0 +1,265 @@+module CmdDB where++import Commands+import Control.Monad+import Data.List+import Program+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 = RouteProc "cabal" ["update"]+ , options = []+ , manual = Nothing+ }+ , CommandSpec {+ command = Install+ , commandNames = ["install"]+ , document = "Install packages"+ , routing = RouteProc "cabal" ["install"]+ , options = [(OptNoHarm, Just "--dry-run")]+ , manual = Just "<package> [<ver>]"+ }+ , CommandSpec {+ command = Uninstall+ , commandNames = ["uninstall", "delete", "remove", "unregister"]+ , document = "Uninstall packages"+ , routing = RouteFunc uninstall+ , options = [(OptNoHarm, Nothing)+ ,(OptRecursive, Nothing)+ ] -- don't allow OptAll+ , manual = Just "<package> [<ver>]"+ }+ , CommandSpec {+ command = Installed+ , commandNames = ["installed", "list"]+ , document = "List installed packages"+ , routing = RouteFunc installed+ , options = [(OptAll, Nothing)]+ , manual = Nothing+ }+ , CommandSpec {+ command = Configure+ , commandNames = ["configure", "conf"]+ , document = "Configure a cabal package"+ , routing = RouteProc "cabal" ["configure"]+ , options = []+ , manual = Nothing+ }+ , CommandSpec {+ command = Build+ , commandNames = ["build"]+ , document = "Build a cabal package"+ , routing = RouteProc "cabal" ["build"]+ , options = []+ , manual = Nothing+ }+ , CommandSpec {+ command = Clean+ , commandNames = ["clean"]+ , document = "Clean up a build directory"+ , routing = RouteProc "cabal" ["clean"]+ , options = []+ , manual = Nothing+ }+ , CommandSpec {+ command = Outdated+ , commandNames = ["outdated"]+ , document = "Display outdated packages"+ , routing = RouteFunc outdated+ , options = [(OptAll, Nothing)]+ , manual = Nothing+ }+ , CommandSpec {+ command = Info+ , commandNames = ["info"]+ , document = "Display information of a package"+ , routing = RouteProc "cabal" ["info"]+ , options = []+ , manual = Just "<package>"+ }+ , CommandSpec {+ command = Sdist+ , commandNames = ["sdist", "pack"]+ , document = "Make tar.gz for source distribution"+ , routing = RouteProc "cabal" ["sdist"]+ , options = []+ , manual = Nothing+ }+ , CommandSpec {+ command = Unpack+ , commandNames = ["unpack"]+ , document = "Untar a package in the current directory"+ , routing = RouteProc "cabal" ["unpack"]+ , options = []+ , manual = Just "<package>"+ }+ , CommandSpec {+ command = Deps+ , commandNames = ["deps"]+ , document = "Show dependencies of this package"+ , routing = RouteFunc deps+ , options = [(OptRecursive, Nothing)+ ,(OptAll, Nothing)+ ]+ , manual = Just "<package> [<ver>]"+ }+ , CommandSpec {+ command = RevDeps+ , commandNames = ["revdeps", "dependents"]+ , document = "Show reverse dependencies of this package"+ , routing = RouteFunc revdeps+ , options = [(OptRecursive, Nothing)+ ,(OptAll, Nothing)+ ]+ , manual = Just "<package> [<ver>]"+ }+ , CommandSpec {+ command = Check+ , commandNames = ["check"]+ , document = "Check consistency of packages"+ , routing = RouteProc "ghc-pkg" ["check"]+ , options = []+ , manual = Nothing+ }+ , CommandSpec {+ command = Search+ , commandNames = ["search"]+ , document = "Search available packages by package name"+ , routing = RouteFunc search+ , options = []+ , manual = Just "<key>"+ }+ , CommandSpec {+ command = Help+ , commandNames = ["help"]+ , document = "Display the help message of the command"+ , routing = RouteFunc helpCommandAndExit+ , options = []+ , manual = Just "[<command>]"+ }+ ]++----------------------------------------------------------------++optionDB :: OptionDB+optionDB = [+ OptionSpec {+ option = OptNoHarm+ , optionNames = ["--dry-run", "-n"]+ , optionDesc = "Run without destructive operations"+ }+ , OptionSpec {+ option = OptRecursive+ , optionNames = ["--recursive", "-r"]+ , optionDesc = "Follow dependencies recursively"+ }+ , OptionSpec {+ option = OptAll+ , optionNames = ["--all", "-a"]+ , optionDesc = "Show global packages in addition to user packages"+ }+ ]++----------------------------------------------------------------++commandSpecByName :: String -> CommandDB -> Maybe CommandSpec+commandSpecByName _ [] = Nothing+commandSpecByName x (ent:ents)+ | x `elem` commandNames ent = Just ent+ | otherwise = commandSpecByName x ents++optionSpecByName :: String -> OptionDB -> Maybe OptionSpec+optionSpecByName _ [] = Nothing+optionSpecByName x (ent:ents)+ | x `elem` optionNames ent = Just ent+ | otherwise = optionSpecByName x ents++----------------------------------------------------------------++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 . options+ masterOption [] _ = []+ masterOption (spec:specs) o+ | option spec == o = (head . optionNames $ spec) : masterOption specs o+ | otherwise = masterOption specs o+ showAliases = joinBy ", " . commandNames++printOptions :: CommandSpec -> IO ()+printOptions cmdspec =+ forM_ opts (printOption optionDB)+ where+ opts = map fst $ options cmdspec+ printOption [] _ = return ()+ printOption (spec:specs) o+ | option spec == o =+ putStrLn $ (joinBy ", " . reverse . optionNames $ spec)+ ++ "\t" ++ optionDesc spec+ | otherwise = printOption specs o++----------------------------------------------------------------++helpAndExit :: IO ()+helpAndExit = do+ putStrLn $ programName ++ " " ++ " -- " ++ description+ putStrLn ""+ putStrLn $ "Version: " ++ version+ putStrLn "Usage:"+ putStrLn $ "\t" ++ programName+ putStrLn $ "\t" ++ programName ++ " <command> [args...]"+ putStrLn $ "\t where"+ printCommands (getCommands commandDB)+ exitSuccess+ where+ getCommands = map concat+ . split helpCommandNumber+ . intersperse ", "+ . map head+ . map commandNames+ printCommands [] = return ()+ printCommands (x:xs) = do+ putStrLn $ "\t <command> = " ++ x+ mapM_ (\cmds -> putStrLn $ "\t " ++ cmds) xs++helpCommandNumber :: Int+helpCommandNumber = 10++----------------------------------------------------------------++illegalCommandAndExit :: String -> IO ()+illegalCommandAndExit x = do+ hPutStrLn stderr $ "Illegal command: " ++ x+ exitFailure++----------------------------------------------------------------++illegalOptionsAndExit :: [String] -> IO ()+illegalOptionsAndExit xs = do -- FixME+ hPutStrLn stderr $ "Illegal options: " ++ joinBy " " xs+ exitFailure
+ Commands.hs view
@@ -0,0 +1,120 @@+module Commands (+ deps, revdeps, installed, outdated, uninstall, search+ ) where++import Control.Applicative hiding (many)+import Control.Monad+import PkgDB+import System.Exit+import System.IO+import Types+import Utils+import VerDB+import System.Process+import Data.List+import Data.Char++----------------------------------------------------------------++search :: FunctionCommand+search _ [x] _ = do+ nvls <- getVerAlist False+ forM_ (lok nvls) $ \(n,v) -> putStrLn $ n ++ " " ++ toDotted v+ where+ key = map toLower x+ check (n,_) = key `isPrefixOf` map toLower n+ lok [] = []+ lok (e:es)+ | check e = e : lok es+ | otherwise = lok es+search _ _ _ = do+ hPutStrLn stderr "One search-key should be specified."+ exitFailure++----------------------------------------------------------------++installed :: FunctionCommand+installed _ _ flags = do+ flt <- if allFlag flags then allPkgs else userPkgs+ pkgs <- toPkgList flt <$> getPkgDB+ mapM_ putStrLn $ map fullNameOfPkgInfo pkgs++outdated :: FunctionCommand+outdated _ _ flags = do+ flt <- if allFlag flags then allPkgs else userPkgs+ pkgs <- toPkgList flt <$> getPkgDB+ verDB <- getVerDB+ forM_ pkgs $ \p -> do+ case lookupLatestVersion (nameOfPkgInfo p) verDB of+ Nothing -> return ()+ Just ver -> if numVersionOfPkgInfo p /= ver+ then putStrLn $ fullNameOfPkgInfo p ++ " < " ++ toDotted ver+ else return ()++----------------------------------------------------------------++uninstall :: FunctionCommand+uninstall _ nmver flags = do+ db' <- getPkgDB+ 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) (map pairNameOfPkgInfo sortedPkgs)+ where+ onlyOne = not $ recursiveFlag flags+ doit = not $ noHarmFlag flags++unregister :: Bool -> (String,String) -> IO ()+unregister doit (name,ver) = if doit+ then do+ putStrLn $ "Deleting " ++ name ++ " " ++ ver+ when doit $ system script >> return ()+ else putStrLn $ name ++ " " ++ ver+ where+ script = "ghc-pkg unregister " ++ name ++ "-" ++ ver++----------------------------------------------------------------++deps :: FunctionCommand+deps _ nmver flags = printDepends nmver flags printDeps++revdeps :: FunctionCommand+revdeps _ nmver flags = printDepends nmver flags printRevDeps++printDepends :: [String] -> Flags+ -> (Bool -> PkgDB -> Int -> PkgInfo -> IO ()) -> IO ()+printDepends nmver flags func = do+ db' <- getPkgDB+ db <- if allFlag flags+ then return db'+ else toPkgDB . flip toPkgList db' <$> userPkgs+ pkg <- lookupPkg nmver db+ func (recursiveFlag flags) db 0 pkg++----------------------------------------------------------------++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) $ map fullNameOfPkgInfo pkgs+ exitFailure
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2011, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in+ the documentation and/or other materials provided with the+ distribution.+ * Neither the name of the copyright holders nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,77 @@+module Main where++import CmdDB+import Control.Applicative+import Control.Exception+import Control.Monad+import Data.List+import Data.Maybe+import System.Cmd+import System.Environment (getArgs)+import System.Exit+import Types+import Utils++----------------------------------------------------------------++main :: IO ()+main = flip catches handlers $ do+ (args,opts) <- argsOpts <$> getArgs+ when (args == []) helpAndExit+ checkHelp args opts helpCommandAndExit+ let act = head args+ mcmdspec = commandSpecByName act commandDB+ when (isNothing mcmdspec) (illegalCommandAndExit act)+ let Just cmdspec = mcmdspec+ params = tail args+ eoptspecs = parseOptions cmdspec opts+ checkOptions eoptspecs illegalOptionsAndExit+ let Right flags = eoptspecs+ run cmdspec params flags+ where+ handlers = [Handler handleExit]+ handleExit :: ExitCode -> IO ()+ handleExit _ = return ()++----------------------------------------------------------------++argsOpts :: [String] -> ([String],[String])+argsOpts args = (args', opts)+ where+ args' = filter (not . isPrefixOf "-") args+ opts = filter (isPrefixOf "-") args++parseOptions :: CommandSpec -> [String] -> Either [String] Flags+parseOptions cmdspc opts = check opts [] defaultFlags+ where+ optMvals = options cmdspc+ check [] [] fg = Right fg+ check [] es _ = Left es+ check (o:os) es fg = case optionSpecByName o optionDB of+ Nothing -> check os (o:es) fg+ Just x -> case lookup (option x) optMvals of+ Nothing -> check os (o:es) fg+ Just mval -> check os es (updateFlags (option x) mval fg)++checkHelp :: [String] -> [String] -> FunctionCommand -> IO ()+checkHelp args opts func+ | "-h" `elem` opts+ || "--help" `elem` opts = func undefined args undefined+ | otherwise = return ()++checkOptions :: Either [String] Flags -> ([String] -> IO ()) -> IO ()+checkOptions (Left xs) func = func xs+checkOptions _ _ = return ()++----------------------------------------------------------------++run :: CommandSpec -> [String] -> Flags -> IO ()+run cmdspec params flags = case routing cmdspec of+ RouteFunc func -> func cmdspec params flags+ RouteProc subcmd subargs -> callProcess subcmd subargs params flags++callProcess :: String ->[String] -> [String] -> Flags -> IO ()+callProcess pro args0 args1 flags = system script >> return ()+ where+ opts = flagsToOptions flags+ script = joinBy " " $ pro : opts ++ args0 ++ args1
+ PkgDB.hs view
@@ -0,0 +1,153 @@+module PkgDB where++import Control.Applicative+import Control.Monad+import Data.List+import Data.Map (Map)+import qualified Data.Map as M+import Distribution.Version+ (Version(..))+import Distribution.InstalledPackageInfo+ (InstalledPackageInfo_(..), InstalledPackageInfo)+import Distribution.Package+ (PackageName(..), PackageIdentifier(..), InstalledPackageId)+import Distribution.Simple.Compiler+ (PackageDB(..))+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 System.Directory+import Utils++type PkgDB = PackageIndex+type PkgInfo = InstalledPackageInfo++----------------------------------------------------------------++getPkgDB :: IO PkgDB+getPkgDB = do+ (_,pro) <- configure normal Nothing Nothing defaultProgramDb+ getInstalledPackages normal [GlobalPackageDB,UserPackageDB] pro++toPkgDB :: [PkgInfo] -> PkgDB+toPkgDB = fromList++----------------------------------------------------------------++lookupByName :: String -> PkgDB -> [PkgInfo]+lookupByName name db = map (head . 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+ -- drop "/."+ userDirPref <- takeDirectory <$> getAppUserDataDirectory ""+ return $ \pkgi -> case libraryDirs pkgi of+ [] -> False -- haskell-platform for example+ x:_ -> userDirPref `isPrefixOf` x++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++----------------------------------------------------------------++printDeps :: Bool -> PkgDB -> Int -> PkgInfo -> IO ()+printDeps rec db n pkgi = mapM_ (printDep rec db n) $ depends pkgi++printDep :: Bool -> PkgDB -> Int -> InstalledPackageId -> IO ()+printDep rec db n pid = case lookupInstalledPackageId db pid of+ Nothing -> return ()+ Just pkgi -> do+ putStrLn $ prefix ++ fullNameOfPkgInfo pkgi+ when rec $ printDeps rec db (n+1) pkgi+ where+ prefix = replicate (n * 4) ' '++----------------------------------------------------------------++printRevDeps :: Bool -> PkgDB -> Int -> PkgInfo -> IO ()+printRevDeps rec db n pkgi = printRevDeps' rec db revdb n pkgi+ where+ revdb = makeRevDepDB db++printRevDeps' :: Bool -> PkgDB -> RevDB -> Int -> PkgInfo -> IO ()+printRevDeps' rec db revdb n pkgi = case M.lookup pkgid revdb of+ Nothing -> return ()+ Just pkgids -> mapM_ (printRevDep' rec db revdb n) $ pkgids+ where+ pkgid = installedPackageId pkgi++printRevDep' :: Bool -> PkgDB -> RevDB -> Int -> InstalledPackageId -> IO ()+printRevDep' rec db revdb n pid = case lookupInstalledPackageId db pid of+ Nothing -> return ()+ Just pkgi -> do+ putStrLn $ prefix ++ fullNameOfPkgInfo pkgi+ when rec $ printRevDeps' rec 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 (\x y -> fst x == fst y) 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
+ Process.hs view
@@ -0,0 +1,25 @@+module Process (+ Iteratee, infoFromProcess+ ) where++import Data.Enumerator (Iteratee, run_, ($$))+import Data.Enumerator.Binary (enumHandle)+import System.Process+import System.IO+import Data.ByteString (ByteString)++infoFromProcess :: String -> Iteratee ByteString IO a -> IO a+infoFromProcess shellCommand parser = do+ (Nothing, Just hdl, Nothing, _) <- createProcess proSpec+ hSetEncoding hdl latin1+ run_ (enumHandle 4096 hdl $$ parser)+ where+ proSpec = CreateProcess {+ cmdspec = ShellCommand shellCommand+ , cwd = Nothing+ , env = Nothing+ , std_in = Inherit+ , std_out = CreatePipe+ , std_err = Inherit+ , close_fds = True+ }
+ Program.hs view
@@ -0,0 +1,10 @@+module Program where++version :: String+version = "0.0.0"++programName :: String+programName = "cab"++description :: String+description = "A maintenance command of Haskell cabal packages"
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Types.hs view
@@ -0,0 +1,98 @@+module Types where++import Data.Maybe++----------------------------------------------------------------++data Command = Sync+ | Install+ | Uninstall+ | Installed+ | Configure+ | Build+ | Clean+ | Outdated+ | Sdist+ | Unpack+ | Info+ | Deps+ | RevDeps+ | Check+ | Search+ | Help+ deriving (Eq,Show)++data CommandSpec = CommandSpec {+ command :: Command+ , commandNames :: [String]+ , document :: String+ , routing :: Route+ , options :: [(Option, Maybe String)]+ , manual :: Maybe String+ }++type CommandDB = [CommandSpec]++----------------------------------------------------------------++data Option = OptNoHarm+ | OptRecursive+ | OptAll+ deriving (Eq,Show)++data OptionSpec = OptionSpec {+ option :: Option+ , optionNames :: [String]+ , optionDesc :: String+ }++type OptionDB = [OptionSpec]++data Flags = Flags {+ noHarmFlag :: Bool+ , noHarmOption :: Maybe String+ , recursiveFlag :: Bool+ , recursiveOption :: Maybe String+ , allFlag :: Bool+ , allOption :: Maybe String+ }++defaultFlags :: Flags+defaultFlags = Flags {+ noHarmFlag = False+ , noHarmOption = Nothing+ , recursiveFlag = False+ , recursiveOption = Nothing+ , allFlag = False+ , allOption = Nothing+ }++updateFlags :: Option -> Maybe String -> Flags -> Flags+updateFlags OptNoHarm val flg = flg {+ noHarmFlag = True+ , noHarmOption = val+ }+updateFlags OptRecursive val flg = flg {+ recursiveFlag = True+ , recursiveOption = val+ }+updateFlags OptAll val flg = flg {+ allFlag = True+ , allOption = val+ }++flagsToOptions :: Flags -> [String]+flagsToOptions flags = catMaybes [+ noHarmOption flags+ , recursiveOption flags+ , allOption flags+ ]++----------------------------------------------------------------++type FunctionCommand = CommandSpec -> [String] -> Flags -> IO ()++data Route = RouteFunc FunctionCommand+ | RouteProc String [String]++----------------------------------------------------------------
+ Utils.hs view
@@ -0,0 +1,21 @@+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 sep = concat . intersperse sep++split :: Int -> [a] -> [[a]]+split _ [] = []+split n ss = x : split n rest+ where+ (x,rest) = splitAt n ss
+ VerDB.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}++module VerDB (+ VerDB, getVerDB, lookupLatestVersion, getVerAlist+ ) where++import Control.Applicative hiding (many)+import Control.Arrow (second)+import Data.Attoparsec.Char8+import Data.Attoparsec.Enumerator+import Data.ByteString (ByteString)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Process++----------------------------------------------------------------++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 = infoFromProcess script cabalListParser+ justOnly = map (second fromJust) . filter (isJust . snd)++----------------------------------------------------------------++lookupLatestVersion :: String -> VerDB -> Maybe [Int]+lookupLatestVersion pkgid (VerDB db) = M.lookup pkgid db++----------------------------------------------------------------++cabalListParser :: Iteratee ByteString IO [VerInfo]+cabalListParser = iterParser verinfos++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")
+ cab.cabal view
@@ -0,0 +1,39 @@+Name: cab+Version: 0.0.0+Author: Kazu Yamamoto <kazu@iij.ad.jp>+Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>+License: BSD3+License-File: LICENSE+Synopsis: A maintenance command of Haskell cabal packages+Description: This is a MacPorts-like maintenance command of+ Haskell cabal packages. Some part of this program is a wrapper to+ "ghc-pkg" and "cabal".+ If you are always confused due to inconsistency of two commands,+ or if you want a way to check all outdated packages,+ or if you want a way to remove outdated packages recursively,+ this command helps you.+Homepage: http://www.mew.org/~kazu/proj/cab/+Category: Distribution+Cabal-Version: >= 1.6+Build-Type: Simple+Executable cab+ Main-Is: Main.hs+ if impl(ghc >= 6.12)+ GHC-Options: -Wall -fno-warn-unused-do-bind+ else+ GHC-Options: -Wall+ Build-Depends: base >= 4.0 && < 5, process, filepath, directory,+ containers, Cabal,+ attoparsec, attoparsec-enumerator,+ enumerator, bytestring+ Other-Modules: CmdDB+ Commands+ PkgDB+ Process+ Program+ Types+ Utils+ VerDB+Source-Repository head+ Type: git+ Location: git://github.com/kazu-yamamoto/cab.git