packdeps-0.6.0.0: tools/packdeps-cli.hs

{-# LANGUAGE ViewPatterns #-}
import Control.Applicative (many, some)
import Control.Monad (forM_, foldM, when)
import Control.Monad (liftM)
import Data.Char (isSpace)
import Data.List (foldl')
import Distribution.PackDeps
import Distribution.Package (PackageIdentifier (pkgName, pkgVersion), PackageName, unPackageName)
import Distribution.Text (display)
import Distribution.Version (Version)
import qualified Distribution.InstalledPackageInfo as IPI
import System.Exit (exitFailure, exitSuccess)
import System.Process (readProcess)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)

import qualified Data.Map as Map
import qualified Options.Applicative as O

main :: IO ()
main = do
    run' <- O.execParser $ O.info (O.helper <*> opts) $ mconcat
        [ O.fullDesc
        , O.progDesc $ unwords
            [ "Check the given cabal file's dependency list to make sure that it does not exclude"
            , "the newest package available. It's probably worth running the 'cabal update' command"
            , "immediately before running this program."
            ]
        ]
    isGood <- run'
    if isGood then exitSuccess else exitFailure
  where
    opts = run
        <$> O.switch (O.short 'r' <> O.long "recursive" <> O.help "Check transitive dependencies as well.")
        <*> O.switch (O.short 'q' <> O.long "quiet" <> O.help "Suppress output for .cabal files which can accept the newest packages available.")
        <*> O.switch (O.short 'g' <> O.long "ghc-pkg" <> O.help "Use ghc-pkg list to additionally populate the newest packages database.")
        <*> O.switch (O.short 'p' <> O.long "preferred" <> O.help "Consider only preferred versions")
        <*> many (O.strOption (O.short 'e' <> O.long "exclude" <> O.metavar "pkgname" <> O.help "Exclude the package from the output."))
        <*> some (O.strArgument (O.metavar "pkgname.cabal"))

type CheckDeps = Newest -> DescInfo -> (PackageName, Version, CheckDepsRes)

checkDepsCli :: Bool -> [String] -> CheckDeps -> Newest -> DescInfo -> IO Bool
checkDepsCli quiet excludes cd newest di =
    case overTrd filterExcludes $ cd newest di of
        (pn, v, AllNewest)
          | quiet -> return True
          | otherwise -> do
            putStrLn $ concat
                [ unPackageName pn
                , "-"
                , display v
                , ": Can use newest versions of all dependencies"
                ]
            return True
        (pn, v, WontAccept p _) -> do
            putStrLn $ concat
                [ unPackageName pn
                , "-"
                , display v
                , ": Cannot accept the following packages"
                ]
            forM_ p $ \(x, y) -> putStrLn $ display x ++ " " ++ display y
            return False
  where
    overTrd :: (a -> b) -> (x, y, a) -> (x, y, b)
    overTrd f (x, y, a) = (x, y, f a)

    filterExcludes :: CheckDepsRes -> CheckDepsRes
    filterExcludes AllNewest = AllNewest
    filterExcludes (WontAccept p t) =
        case filter (\(n, _) -> display n `notElem` excludes) p of
            [] -> AllNewest
            p' -> WontAccept p' t

-- TODO
updateWithGhcPkg :: Newest -> IO Newest
updateWithGhcPkg newest = do
    output <- readProcess "ghc-pkg" ["dump"] ""
    ipis <- either (fail . show) (return . map snd) $
        traverse IPI.parseInstalledPackageInfo $
        map (encodeUtf8 . T.pack) $
        splitPkgs output
    return $ foldl' apply newest $ map toPackInfo ipis
  where
    apply :: Newest -> (PackageName, PackInfo) -> Newest
    apply m (k, v) = Map.insert k v m

    toPackInfo :: IPI.InstalledPackageInfo -> (PackageName, PackInfo)
    toPackInfo ipi = (pkgName $ IPI.sourcePackageId ipi, pinfo) where
        pinfo = PackInfo
            { piVersion = pkgVersion $ IPI.sourcePackageId ipi
            , piEpoch   = 0
            , piDesc    = Nothing
            }

    -- copied from from Cabal
    splitPkgs :: String -> [String]
    splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines
      where
        -- Handle the case of there being no packages at all.
        checkEmpty [s] | all isSpace s = []
        checkEmpty ss                  = ss

        splitWith :: (a -> Bool) -> [a] -> [[a]]
        splitWith p xs = ys : case zs of
                           []   -> []
                           _:ws -> splitWith p ws
          where (ys,zs) = break p xs

run :: Bool        -- ^ Check transitive dependencies
    -> Bool        -- ^ Quiet -- only report packages that are not up to date
    -> Bool        -- ^ ghc-pkg -- use ghc-pkg list to see whether there are even newer packages.
    -> Bool        -- ^ preferred -- consider only preferred versions
    -> [String]    -- ^ packages to exclude
    -> [FilePath]  -- ^ .cabal filenames
    -> IO Bool
run deep quiet ghcpkg preferred excludes args = do
    newest' <- loadNewest preferred
    newest <- if ghcpkg then updateWithGhcPkg newest' else return newest'
    foldM (go newest) True args
  where
    go newest wasAllGood fp = do
        mdi <- loadPackage fp
        di <- case mdi of
             Just di -> return di
             Nothing -> error $ "Could not parse cabal file: " ++ fp
        allGood <- checkDepsCli quiet excludes checkDeps newest di
        depsGood <- if deep
                       then do putStrLn $ "\nTransitive dependencies:"
                               allM (checkDepsCli quiet excludes checkLibDeps newest) (deepLibDeps newest [di])
                       else return True
        when (not (allGood && depsGood)) $ putStrLn ""
        return $ wasAllGood && allGood && depsGood

-- | Non short-circuiting monadic version of 'all'
-- Duh, pre-AMP code.
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM f xs = and `liftM` mapM f xs