cabal-db 0.1.6 → 0.1.7
raw patch · 4 files changed
+158/−11 lines, 4 filesdep +ansi-wl-pprint
Dependencies added: ansi-wl-pprint
Files
- Src/Graph.hs +61/−0
- Src/Main.hs +19/−9
- Src/Options.hs +73/−0
- cabal-db.cabal +5/−2
+ Src/Graph.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE BangPatterns #-}+module Graph+ ( GraphSt+ , GraphIndex+ , graphResolve+ , graphInsertDep+ , withGraph+ , graphLoop+ ) where++import Control.Applicative+import qualified Data.Map as M+import Control.Monad.State++-- represent the element in the graph+type GraphIndex = Int++data GraphSt a = GraphSt+ { nextIndex :: !GraphIndex+ , indexTable :: M.Map a GraphIndex+ , depsTable :: M.Map GraphIndex [GraphIndex]+ } deriving (Show,Eq)++-- | return the graph index of a 'a' object.+-- if it doesn't exist, it create one+graphResolve :: (Monad m, Ord a) => a -> StateT (GraphSt a) m GraphIndex+graphResolve pn = get >>= addOrGet+ where addOrGet st = maybe (add st) return $ M.lookup pn (indexTable st)+ add st = put (st { nextIndex = ni+1, indexTable = M.insert pn ni (indexTable st) }) >> return ni+ where ni = nextIndex st++graphIsProcessed :: (Functor f, Monad f) => GraphIndex -> StateT (GraphSt a) f Bool+graphIsProcessed pn = M.member pn <$> gets depsTable++graphInsertDep :: Monad m => GraphIndex -> GraphIndex -> StateT (GraphSt a) m ()+graphInsertDep i j = modifyDepsTable i appendOrCreateList+ where appendOrCreateList Nothing = Just [j]+ appendOrCreateList (Just z) = Just (j:z)+ modifyDepsTable k f = modify (\st -> st { depsTable = M.alter f k (depsTable st) })++withGraph :: (Functor m, Monad m)+ => StateT (GraphSt a) m ()+ -> m (M.Map a GraphIndex, M.Map GraphIndex [GraphIndex])+withGraph f = (\st -> (indexTable st, depsTable st))+ <$> execStateT f (GraphSt 1 M.empty M.empty)++graphLoop :: Ord a+ => (a -> IO [a])+ -> a+ -> StateT (GraphSt a) IO ()+graphLoop getEdges = loop (0 :: Int)+ where loop !depth pn+ | depth > 1000 = error "internal error: infinite loop detected"+ | otherwise = do+ pni <- graphResolve pn+ processed <- graphIsProcessed pni+ --liftIO $ putStrLn ("loop: " ++ show pn ++ " processed: " ++ show processed ++ " depth: " ++ show depth)+ unless processed $ do+ depNames <- filter (/= pn) <$> liftIO (getEdges pn)+ mapM_ (loop (depth+1)) depNames+ mapM_ (graphResolve >=> graphInsertDep pni) depNames
Src/Main.hs view
@@ -35,6 +35,8 @@ import Options import Graph +import qualified Text.PrettyPrint.ANSI.Leijen as PP+ platformPackages = map PackageName $ ["array" ,"base", "bytestring"@@ -285,8 +287,10 @@ when ((not printTree && not printSummary) || printSummary) $ do putStrLn "== license summary =="- forM_ (map nameAndLength $ group $ sortBy licenseCmp $ map snd $ M.toList foundLicenses) $ \(licenseName, licenseNumb) ->- putStrLn (ppLicense licenseName ++ ": " ++ show licenseNumb)+ forM_ (map nameAndLength $ group $ sortBy licenseCmp $ map snd $ M.toList foundLicenses) $ \(licenseName, licenseNumb) -> do+ let (lstr, ppComb) = ppLicense licenseName+ PP.putDoc (ppComb (PP.text lstr) PP.<> PP.colon PP.<+> PP.text (show licenseNumb) PP.<> PP.line)+ where getDeps apkgs pn = do let desc = finPkgDesc <$> getPackageDescription apkgs pn Nothing case desc of@@ -302,7 +306,9 @@ case desc of Just (Right (d,_)) -> do let found = license d- when printTree $ putStrLn (replicate indentSpaces ' ' ++ name ++ ": " ++ ppLicense found)+ when printTree $ do+ let (lstr, ppComb) = ppLicense found+ PP.putDoc $ PP.text (replicate indentSpaces ' ') PP.<> PP.text name PP.<> PP.colon PP.<+> ppComb (PP.text lstr) PP.<> PP.line case M.lookup pn tbl of Just l -> foldM (loop apkgs tbl (indentSpaces + 2)) (M.insert pn found founds) l Nothing -> error "internal error"@@ -314,12 +320,16 @@ nameAndLength [] = error "empty group" nameAndLength l@(x:_) = (x, length l) - ppLicense (GPL (Just (Version [v] []))) = "GPLv" ++ show v- ppLicense (AGPL (Just (Version [v] []))) = "AGPLv" ++ show v- ppLicense (LGPL (Just (Version [v] []))) = "LGPLv" ++ show v- ppLicense (Apache (Just (Version [v] []))) = "Apache" ++ show v- ppLicense (UnknownLicense s) = s- ppLicense l = show l+ ppLicense (GPL (Just (Version [v] []))) = ("GPLv" ++ show v, PP.yellow)+ ppLicense (GPL Nothing) = ("GPL", PP.yellow)+ ppLicense (AGPL (Just (Version [v] []))) = ("AGPLv" ++ show v, PP.yellow)+ ppLicense (LGPL (Just (Version [v] []))) = ("LGPLv" ++ show v, PP.yellow)+ ppLicense (Apache (Just (Version [v] []))) = ("Apache" ++ show v, PP.green)+ ppLicense (UnknownLicense s) = (s, PP.red)+ ppLicense BSD3 = ("BSD3", PP.green)+ ppLicense BSD4 = ("BSD4", PP.green)+ ppLicense MIT = ("MIT", PP.green)+ ppLicense l = (show l, PP.magenta) ----------------------------------------------------------------------- runCmd (CmdSearch term vals) = do
+ Src/Options.hs view
@@ -0,0 +1,73 @@+module Options+ ( Command(..)+ , SearchTerm(..)+ , getOptions+ ) where++import Options.Applicative+import Paths_cabal_db (version)+import Data.Version+import Data.List (intercalate)++data Command =+ CmdGraph+ { graphHide :: [String]+ , graphHidePlatform :: Bool+ , graphPackages :: [String]+ }+ | CmdDiff+ { diffPackage :: String+ , diffVer1 :: String+ , diffVer2 :: String+ }+ | CmdRevdeps+ { revdepPackages :: [String]+ }+ | CmdInfo+ { infoPackages :: [String]+ }+ | CmdSearch+ { searchTerm :: SearchTerm+ , searchValues :: [String]+ }+ | CmdLicense+ { licensePrintTree :: Bool+ , licensePrintSummary :: Bool+ , licensePackages :: [String]+ }++data SearchTerm = SearchMaintainer | SearchAuthor++parseCArgs = subparser+ ( command "graph" (info cmdGraph (progDesc "generate a .dot dependencies graph of all the packages in argument"))+ <> command "diff" (info cmdDiff (progDesc "generate a diff between two versions of a package"))+ <> command "revdeps" (info cmdRevdeps (progDesc "list all reverse dependencies of a set of packages"))+ <> command "info" (info cmdInfo (progDesc "list some information about a set of packages"))+ <> command "search-author" (info (cmdSearch SearchAuthor) (progDesc "search the cabal database by author(s)"))+ <> command "search-maintainer" (info (cmdSearch SearchMaintainer) (progDesc "search the cabal database by maintainer(s)"))+ <> command "license" (info cmdLicense (progDesc "list all licenses of a set of packages and their dependencies"))+ )+ where cmdGraph = CmdGraph+ <$> many (strOption (long "hide" <> short 'h' <> metavar "PACKAGE" <> help "package to hide"))+ <*> switch (long "hide-platform" <> help "Hide all packages from the platform")+ <*> packages+ cmdDiff = CmdDiff+ <$> argument Just (metavar "<package>")+ <*> argument Just (metavar "<ver1>")+ <*> argument Just (metavar "<ver2>")+ cmdRevdeps = CmdRevdeps+ <$> packages+ cmdInfo = CmdInfo+ <$> packages+ cmdSearch accessor = CmdSearch accessor+ <$> many (argument Just (metavar "<search-term>"))+ cmdLicense = CmdLicense+ <$> switch (short 't' <> long "tree" <> help "show the tree dependencies of license")+ <*> switch (short 's' <> long "summary" <> help "Show the summary")+ <*> packages+ packages = some (argument Just (metavar "<packages..>"))++getOptions :: IO Command+getOptions = execParser (info (pVersion *> parseCArgs <**> helper) idm)+ where pVersion = infoOption ver (long "version" <> help "Print version information")+ ver = intercalate "." $ map show $ versionBranch version
cabal-db.cabal view
@@ -1,5 +1,5 @@ Name: cabal-db-Version: 0.1.6+Version: 0.1.7 Synopsis: query tools for the local cabal database (revdeps, graph, info, search-by) Description: Query tool for the local cabal database@@ -24,11 +24,13 @@ Build-Type: Simple Homepage: http://github.com/vincenthz/cabal-db Cabal-Version: >=1.8-data-files: README.md+extra-source-files: README.md Executable cabal-db Main-Is: Main.hs hs-source-dirs: Src+ Other-modules: Graph+ , Options ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures Build-depends: base >= 4 && < 5 , mtl@@ -42,6 +44,7 @@ , pretty , process , optparse-applicative+ , ansi-wl-pprint Buildable: True source-repository head