cabal-plan 0.1.1.0 → 0.2.0.0
raw patch · 4 files changed
+207/−69 lines, 4 filesdep +optparse-applicativedep ~aesondep ~ansi-terminaldep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: optparse-applicative
Dependency ranges changed: aeson, ansi-terminal, base, base16-bytestring, bytestring, containers, directory, filepath, mtl, text
API changes (from Hackage documentation)
- Cabal.Plan: findAndDecodePlanJson :: IO (PlanJson, FilePath)
+ Cabal.Plan: findAndDecodePlanJson :: Maybe FilePath -> IO (PlanJson, FilePath)
Files
- ChangeLog.md +7/−0
- cabal-plan.cabal +50/−25
- src-exe/cabal-plan.hs +139/−39
- src/Cabal/Plan.hs +11/−5
ChangeLog.md view
@@ -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
cabal-plan.cabal view
@@ -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
src-exe/cabal-plan.hs view
@@ -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
src/Cabal/Plan.hs view
@@ -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 $