diff --git a/Src/Graph.hs b/Src/Graph.hs new file mode 100644 --- /dev/null +++ b/Src/Graph.hs @@ -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 diff --git a/Src/Main.hs b/Src/Main.hs --- a/Src/Main.hs +++ b/Src/Main.hs @@ -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 diff --git a/Src/Options.hs b/Src/Options.hs new file mode 100644 --- /dev/null +++ b/Src/Options.hs @@ -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 "") + <*> argument Just (metavar "") + <*> argument Just (metavar "") + cmdRevdeps = CmdRevdeps + <$> packages + cmdInfo = CmdInfo + <$> packages + cmdSearch accessor = CmdSearch accessor + <$> many (argument Just (metavar "")) + 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 "")) + +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 diff --git a/cabal-db.cabal b/cabal-db.cabal --- a/cabal-db.cabal +++ b/cabal-db.cabal @@ -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