diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for `cabal-plan` +## 0.2.0.0 + +* Add an optional `--builddir` argument to all commands and to `findAndDecodePlanJson` function +* Add experimental support for underlining +* Reimplement CLI with `optparse-applicative` +* Add new sub-command `list-bins` and change semantics of existing `list-bin` sub-cmd + ## 0.1.1.0 * Add `cabal-plan fingerprint` command for printing diff --git a/cabal-plan.cabal b/cabal-plan.cabal --- a/cabal-plan.cabal +++ b/cabal-plan.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.0 name: cabal-plan -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Library and utiltity for processing cabal's plan.json file homepage: https://github.com/hvr/cabal-plan license: GPL-3 @@ -9,16 +10,34 @@ copyright: 2016 Herbert Valerio Riedel category: Development build-type: Simple -cabal-version: >=1.10 -tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 -description: - This package provides a library for decoding @plan.json@ files as - well as simple tool @cabal-plan@ for extracting and pretty printing - the information contained in the @plan.json@ file. +description: { +This package provides a library for decoding @plan.json@ files as +well as the simple tool @cabal-plan@ for extracting and pretty printing +the information contained in the @plan.json@ file. +. +@plan.json@ files are generated by [cabal](https://hackage.haskell.org/package/cabal-install)'s [nix-style local builds](http://cabal.readthedocs.io/en/latest/nix-local-build.html) and contain detailed information about the build/install plan computed by the cabal solver. +} extra-source-files: ChangeLog.md +tested-with: + GHC==8.2.1, + GHC==8.0.2, + GHC==7.10.3, + GHC==7.8.4, + GHC==7.6.3 + +flag exe + -- this automatic flag allows the cabal solver to disable the exe:cabal-plan component (& its build-deps); + -- IOW, emulate https://github.com/haskell/cabal/issues/4660 + description: Enable @exe:cabal-plan@ component + +flag _ + description: Enable underlining of primary unit-ids + manual: True + default: False + library default-language: Haskell2010 other-extensions: OverloadedStrings @@ -26,14 +45,14 @@ RecordWildCards exposed-modules: Cabal.Plan - build-depends: base >= 4.6 && <4.10 - , aeson >= 1 && <1.2 - , bytestring == 0.10.* - , containers == 0.5.* - , text == 1.2.* - , directory >= 1.2 && < 1.4 - , filepath >= 1.3 && < 1.5 - , base16-bytestring >= 0.1.1 && < 0.2 + build-depends: base (>= 4.6 && <4.10) || ^>= 4.10 + , aeson ^>= 1.2.0 + , bytestring ^>= 0.10.0 + , containers ^>= 0.5.0 + , text ^>= 1.2.2 + , directory ^>= 1.2.0 || ^>= 1.3.0 + , filepath ^>= 1.3.0 || ^>= 1.4.0 + , base16-bytestring ^>= 0.1.1 hs-source-dirs: src @@ -46,19 +65,25 @@ main-is: src-exe/cabal-plan.hs - -- dependencies w/ inherited version ranges via 'cabal-plan' library - build-depends: cabal-plan - , base - , text - , containers - , bytestring + if flag(exe) + -- dependencies w/ inherited version ranges via 'cabal-plan' library + build-depends: cabal-plan + , base + , text + , containers + , bytestring - -- dependencies which require version bounds - build-depends: mtl >= 2.2.1 && < 2.3 - , ansi-terminal >= 0.6.2 && < 0.7 + -- dependencies which require version bounds + build-depends: mtl ^>= 2.2.1 + , ansi-terminal ^>= 0.6.2 + , optparse-applicative ^>= 0.13.0 || ^>= 0.14.0 - ghc-options: -Wall + if flag(_) + cpp-options: -DUNDERLINE_SUPPORT + else + buildable: False + ghc-options: -Wall source-repository head type: git diff --git a/src-exe/cabal-plan.hs b/src-exe/cabal-plan.hs --- a/src-exe/cabal-plan.hs +++ b/src-exe/cabal-plan.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} @@ -5,7 +6,9 @@ import Control.Monad import Control.Monad.RWS.Strict +import Data.Foldable (asum) import qualified Data.Graph as G +import Data.List (isPrefixOf, isInfixOf, isSuffixOf) import Data.Map (Map) import qualified Data.Map as M import Data.Set (Set) @@ -15,44 +18,140 @@ import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as LT import qualified Data.Text.Lazy.IO as LT +import Options.Applicative import System.Console.ANSI -import System.Environment +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) import Cabal.Plan +haveUnderlineSupport :: Bool +#if defined(UNDERLINE_SUPPORT) +haveUnderlineSupport = True +#else +haveUnderlineSupport = False +#endif + +data GlobalOptions = GlobalOptions + { buildDir :: Maybe FilePath + , cmd :: Command + } + +data Command + = InfoCommand | ShowCommand | FingerprintCommand + | ListBinsCommand MatchCount MatchPref [Pattern] + main :: IO () main = do - -- TODO: optparse-applicative - args <- getArgs - case args of - [] -> doInfo - ("info":_) -> doInfo - ("show":_) -> print =<< findAndDecodePlanJson - ("list-bin":_) -> doListBin - ("fingerprint":_) -> doFingerprint - _ -> fail "unknown command (known commands: info show list-bin fingerprint)" + GlobalOptions{..} <- execParser $ info (optParser <**> helper) fullDesc + val@(plan, _) <- findAndDecodePlanJson buildDir + case cmd of + InfoCommand -> doInfo val + ShowCommand -> print val + ListBinsCommand count pref pats -> do + let bins = doListBin plan pref pats + case (count, bins) of + (MatchMany, _) -> forM_ bins $ \(g, fn) -> + putStrLn (g ++ " " ++ fn) + (MatchOne, [(_,p)]) -> putStrLn p + (MatchOne, []) -> do + hPutStrLn stderr "No matches found." + exitFailure + (MatchOne, _) -> do + hPutStrLn stderr "Found more than one matching pattern:" + forM_ bins $ \(p,_) -> hPutStrLn stderr $ " " ++ p + exitFailure + FingerprintCommand -> doFingerprint plan + where + optParser = GlobalOptions <$> dirParser <*> (cmdParser <|> defaultCommand) + dirParser = optional . strOption $ mconcat + [ long "builddir", metavar "DIR" + , help "Build directory to read plan.json from." ] -doListBin :: IO () -doListBin = do - (v,_projbase) <- findAndDecodePlanJson + subCommand name desc val = command name $ info val (progDesc desc) - forM_ (M.toList (pjUnits v)) $ \(_,Unit{..}) -> do - forM_ (M.toList uComps) $ \(cn,ci) -> do - case ciBinFile ci of - Nothing -> return () - Just fn -> do - let PkgId (PkgName pn) _ = uPId - g = case cn of - CompNameLib -> T.unpack (pn <> T.pack":lib:" <> pn) - _ -> T.unpack (pn <> T.pack":" <> dispCompName cn) - putStrLn (g ++ " " ++ fn) + patternParser = argument (Pattern <$> str) . mconcat -doFingerprint :: IO () -doFingerprint = do - (v,_projbase) <- findAndDecodePlanJson + cmdParser = subparser $ mconcat + [ subCommand "info" "Info" $ pure InfoCommand + , subCommand "show" "Show" $ pure ShowCommand + , subCommand "list-bins" "List All Binaries" . + listBinParser MatchMany . many $ patternParser + [ metavar "PATTERNS...", help "Patterns to match." ] + , subCommand "list-bin" "List Single Binary" . + listBinParser MatchOne $ pure <$> patternParser + [ metavar "PATTERN", help "Pattern to match." ] + , subCommand "fingerprint" "Fingerprint" $ pure FingerprintCommand + ] + defaultCommand = pure InfoCommand - let pids = M.fromList [ (uPId u, u) | (_,u) <- M.toList (pjUnits v) ] +data Pattern = Pattern String + deriving (Show, Eq) +data MatchCount = MatchOne | MatchMany + deriving (Show, Eq) + +data MatchPref = Prefix | Infix | Suffix | Exact + deriving (Show, Eq) + +listBinParser + :: MatchCount + -> Parser [Pattern] + -> Parser Command +listBinParser count pats + = ListBinsCommand count <$> matchPrefParser <*> pats <**> helper + where + matchPrefParser :: Parser MatchPref + matchPrefParser = asum [exact, prefix, infix_, suffix, pure Exact ] + + exact :: Parser MatchPref + exact = flag' Exact $ mconcat + [ long "exact" , help "Use exact match for pattern." ] + + prefix :: Parser MatchPref + prefix = flag' Prefix $ mconcat + [ long "prefix" , help "Use prefix match for pattern." ] + + infix_ :: Parser MatchPref + infix_ = flag' Infix $ mconcat + [ long "infix" , help "Use infix match for pattern." ] + + suffix :: Parser MatchPref + suffix = flag' Suffix $ mconcat + [ long "suffix" , help "Use suffix match for pattern." ] + +checkPattern :: MatchPref -> Pattern -> String -> Any +checkPattern pref (Pattern p) s = Any $ compareFun p s + where + compareFun = case pref of + Prefix -> isPrefixOf + Infix -> isInfixOf + Suffix -> isSuffixOf + Exact -> (==) + +doListBin :: PlanJson -> MatchPref -> [Pattern] -> [(String, FilePath)] +doListBin plan pref patterns = do + (_, Unit{..}) <- M.toList $ pjUnits plan + (cn, ci) <- M.toList $ uComps + case ciBinFile ci of + Nothing -> [] + Just fn -> do + let PkgId (PkgName pn) _ = uPId + g = case cn of + CompNameLib -> T.unpack (pn <> T.pack":lib:" <> pn) + _ -> T.unpack (pn <> T.pack":" <> dispCompName cn) + guard . getAny $ patternChecker g + [(g, fn)] + where + patternChecker :: String -> Any + patternChecker = case patterns of + [] -> const $ Any True + _ -> mconcat $ map (checkPattern pref) patterns + +doFingerprint :: PlanJson -> IO () +doFingerprint plan = do + let pids = M.fromList [ (uPId u, u) | (_,u) <- M.toList (pjUnits plan) ] + forM_ (M.toList pids) $ \(_,Unit{..}) -> do let h = maybe "________________________________________________________________" dispSha256 $ uSha256 @@ -62,16 +161,14 @@ UnitTypeLocal -> T.putStrLn (h <> " L " <> dispPkgId uPId) UnitTypeInplace -> T.putStrLn (h <> " I " <> dispPkgId uPId) -doInfo :: IO () -doInfo = do - (v,projbase) <- findAndDecodePlanJson - +doInfo :: (PlanJson, FilePath) -> IO () +doInfo (plan,projbase) = do putStrLn ("using '" ++ projbase ++ "' as project root") putStrLn "" putStrLn "Tree" putStrLn "~~~~" putStrLn "" - LT.putStrLn (dumpPlanJson v) + LT.putStrLn (dumpPlanJson plan) -- print (findCycles (planJsonIdGrap v)) @@ -80,7 +177,7 @@ putStrLn "~~~~~~~~~~" putStrLn "" - let xs = toposort (planJsonIdGraph v) + let xs = toposort (planJsonIdGraph plan) forM_ xs print putStrLn "" @@ -89,7 +186,7 @@ putStrLn "" let locals = [ Unit{..} | Unit{..} <- M.elems pm, uType == UnitTypeLocal ] - pm = pjUnits v + pm = pjUnits plan forM_ locals $ \pitem -> do print (uPId pitem) @@ -120,7 +217,7 @@ go2 lvl pid = do pidSeen <- gets (S.member pid) - let pid_label = if preExists then (prettyId pid) else colorify White (prettyId pid) + let pid_label = if preExists then (prettyId pid) else colorify_ White (prettyId pid) if not pidSeen then do @@ -164,9 +261,9 @@ prettyCompTy :: PkgId -> CompName -> String prettyCompTy _pid c@CompNameLib = ccol c "[lib]" prettyCompTy _pid c@CompNameSetup = ccol c "[setup]" - prettyCompTy pid c@(CompNameExe n) = ccol c $ "[" ++ prettyPid pid ++ ":exe:" ++ show n ++ "]" - prettyCompTy pid c@(CompNameTest n) = ccol c $ "[" ++ prettyPid pid ++ ":test:" ++ show n ++ "]" - prettyCompTy pid c@(CompNameBench n) = ccol c $ "[" ++ prettyPid pid ++ ":bench:" ++ show n ++ "]" + prettyCompTy pid c@(CompNameExe n) = ccol c $ "[" ++ prettyPid pid ++ ":exe:" ++ show n ++ "]" + prettyCompTy pid c@(CompNameTest n) = ccol c $ "[" ++ prettyPid pid ++ ":test:" ++ show n ++ "]" + prettyCompTy pid c@(CompNameBench n) = ccol c $ "[" ++ prettyPid pid ++ ":bench:" ++ show n ++ "]" prettyCompTy pid c@(CompNameSubLib n) = ccol c $ "[" ++ prettyPid pid ++ ":lib:" ++ show n ++ "]" ccol CompNameLib = colorify White @@ -176,10 +273,13 @@ ccol (CompNameBench _) = colorify Cyan ccol (CompNameSubLib _) = colorify Blue - colorify :: Color -> String -> String colorify col s = setSGRCode [SetColor Foreground Vivid col] ++ s ++ setSGRCode [Reset] +colorify_ :: Color -> String -> String +colorify_ col s + | haveUnderlineSupport = setSGRCode [SetUnderlining SingleUnderline, SetColor Foreground Vivid col] ++ s ++ setSGRCode [Reset] + | otherwise = colorify col s lastAnn :: [x] -> [(Bool,x)] lastAnn = reverse . firstAnn . reverse diff --git a/src/Cabal/Plan.hs b/src/Cabal/Plan.hs --- a/src/Cabal/Plan.hs +++ b/src/Cabal/Plan.hs @@ -43,6 +43,7 @@ import Data.List import Data.Map (Map) import qualified Data.Map as M +import Data.Maybe (fromMaybe) import Data.Monoid import Data.Set (Set) import qualified Data.Set as S @@ -243,18 +244,23 @@ ---------------------------------------------------------------------------- -- Convenience helper --- | Locates and decodes @plan.json@ for cabal project being in scope --- for current working directory +-- | Locates the project root for cabal project in scope for the current +-- working directory. -- +-- @plan.json@ is located from either the optional build dir argument, or in +-- the default directory (@dist-newstyle@) relative to the project root. +-- -- The folder assumed to be the project-root is returned as well. -- -- Throws 'IO' exceptions on errors. -- -findAndDecodePlanJson :: IO (PlanJson, FilePath) -findAndDecodePlanJson = do +findAndDecodePlanJson + :: Maybe FilePath -- ^ Optional build dir to look in. + -> IO (PlanJson, FilePath) +findAndDecodePlanJson mBuildDir = do projbase <- findProjRoot - let distFolder = projbase "dist-newstyle" + let distFolder = fromMaybe (projbase "dist-newstyle") mBuildDir haveDistFolder <- doesDirectoryExist distFolder unless haveDistFolder $