diff --git a/CmdDB.hs b/CmdDB.hs new file mode 100644 --- /dev/null +++ b/CmdDB.hs @@ -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 " []" + } + , 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 " []" + } + , 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 "" + } + , 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 "" + } + , CommandSpec { + command = Deps + , commandNames = ["deps"] + , document = "Show dependencies of this package" + , routing = RouteFunc deps + , options = [(OptRecursive, Nothing) + ,(OptAll, Nothing) + ] + , manual = Just " []" + } + , CommandSpec { + command = RevDeps + , commandNames = ["revdeps", "dependents"] + , document = "Show reverse dependencies of this package" + , routing = RouteFunc revdeps + , options = [(OptRecursive, Nothing) + ,(OptAll, Nothing) + ] + , manual = Just " []" + } + , 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 "" + } + , CommandSpec { + command = Help + , commandNames = ["help"] + , document = "Display the help message of the command" + , routing = RouteFunc helpCommandAndExit + , options = [] + , manual = Just "[]" + } + ] + +---------------------------------------------------------------- + +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 ++ " [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 = " ++ 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 diff --git a/Commands.hs b/Commands.hs new file mode 100644 --- /dev/null +++ b/Commands.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 diff --git a/PkgDB.hs b/PkgDB.hs new file mode 100644 --- /dev/null +++ b/PkgDB.hs @@ -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 diff --git a/Process.hs b/Process.hs new file mode 100644 --- /dev/null +++ b/Process.hs @@ -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 + } diff --git a/Program.hs b/Program.hs new file mode 100644 --- /dev/null +++ b/Program.hs @@ -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" diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Types.hs b/Types.hs new file mode 100644 --- /dev/null +++ b/Types.hs @@ -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] + +---------------------------------------------------------------- diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -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 diff --git a/VerDB.hs b/VerDB.hs new file mode 100644 --- /dev/null +++ b/VerDB.hs @@ -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") diff --git a/cab.cabal b/cab.cabal new file mode 100644 --- /dev/null +++ b/cab.cabal @@ -0,0 +1,39 @@ +Name: cab +Version: 0.0.0 +Author: Kazu Yamamoto +Maintainer: Kazu Yamamoto +License: BSD3 +License-File: LICENSE +Synopsis: A maintenance command of Haskell cabal packages +Description: This is a MacPorts-like maintenance command of + Haskell cabal packages. Some part of this program is a wrapper to + "ghc-pkg" and "cabal". + If you are always confused due to inconsistency of two commands, + or if you want a way to check all outdated packages, + or if you want a way to remove outdated packages recursively, + this command helps you. +Homepage: http://www.mew.org/~kazu/proj/cab/ +Category: Distribution +Cabal-Version: >= 1.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