diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,11 +1,26 @@ # Revision history for `cabal-plan` +## 0.7.2.0 + +### `exe:cabal-plan` Executable + +* Use `cabal-install-parsers` to find and parse `~/cabal/config` +* Fix ascii/unicode output in `tred` +* Add flags to hide setup and executable components in dot command +* Update dependencies (support `base16-bytestring-1.0.0.0`) + +### Library + +* Update dependencies (support `base16-bytestring-1.0.0.0`) + ## 0.7.1.0 ### `exe:cabal-plan` Executable * Add `--ascii` / `--unicode` flags to control output character set * Add `dot-png` command as a version of `dot` command with different defaults +* Use `cabal-install-parsers`, + this makes `license-report` work with non-default configurations ## 0.7.0.0 diff --git a/cabal-plan.cabal b/cabal-plan.cabal --- a/cabal-plan.cabal +++ b/cabal-plan.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: cabal-plan -version: 0.7.1.0 +version: 0.7.2.0 synopsis: Library and utility for processing cabal's plan.json file description: { @@ -84,7 +84,7 @@ , text ^>= 1.2.2 , directory ^>= 1.2.0 || ^>= 1.3.0 , filepath ^>= 1.3.0 || ^>= 1.4.0 - , base16-bytestring ^>= 0.1.1 + , base16-bytestring ^>= 0.1.1 || ^>= 1.0.0.0 hs-source-dirs: src @@ -128,7 +128,8 @@ , vector ^>= 0.12.0.1 if flag(license-report) - build-depends: Cabal ^>= 2.2.0.1 || ^>= 2.4.0.1 || ^>= 3.0.0.0 || ^>=3.2.0.0 + build-depends: Cabal ^>=3.2.0.0 + , cabal-install-parsers ^>=0.3.0.1 || ^>=0.4 , tar ^>= 0.5.1.0 , zlib ^>= 0.6.2 , filepath ^>= 1.4.1.1 diff --git a/src-exe/LicenseReport.hs b/src-exe/LicenseReport.hs --- a/src-exe/LicenseReport.hs +++ b/src-exe/LicenseReport.hs @@ -17,6 +17,7 @@ import Control.Monad.Compat (forM, forM_, guard, unless, when) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString as BS +import Data.Functor.Identity (Identity (..)) import Data.Map (Map) import Data.List (nub) import qualified Data.Map as Map @@ -36,6 +37,8 @@ import Prelude () import Prelude.Compat +import Cabal.Config (readConfig, Config (..), cfgRepoIndex, hackageHaskellOrg) + #if MIN_VERSION_Cabal(3,2,0) import Distribution.Utils.ShortText (fromShortText) #endif @@ -65,11 +68,10 @@ _ -> Nothing -readHackageIndex :: IO [(PkgId, BSL.ByteString)] -readHackageIndex = do +readHackageIndex :: FilePath -> IO [(PkgId, BSL.ByteString)] +readHackageIndex indexPath = do -- TODO: expose package index configuration as CLI flag - cabalPkgCacheDir <- getAppUserDataDirectory "cabal/packages/hackage.haskell.org" - ents <- readTarEntries (cabalPkgCacheDir "01-index.tar") + ents <- readTarEntries indexPath pure [ (maybe (error $ show n) id $ fp2pid n,bsl) | e@(Tar.Entry { Tar.entryContent = Tar.NormalFile bsl _ }) <- ents @@ -77,9 +79,8 @@ , takeExtension n == ".cabal" ] -getLicenseFiles :: PkgId -> UnitId -> [FilePath] -> IO [BS.ByteString] -getLicenseFiles compilerId (UnitId uidt) fns = do - storeDir <- getAppUserDataDirectory "cabal/store" +getLicenseFiles :: FilePath -> PkgId -> UnitId -> [FilePath] -> IO [BS.ByteString] +getLicenseFiles storeDir compilerId (UnitId uidt) fns = do let docDir = storeDir T.unpack (dispPkgId compilerId) T.unpack uidt "share" "doc" forM fns $ \fn -> BS.readFile (docDir fn) @@ -105,9 +106,14 @@ -- TODO: emit report to Text or Text builder generateLicenseReport :: Maybe FilePath -> PlanJson -> UnitId -> CompName -> IO () generateLicenseReport mlicdir plan uid0 cn0 = do + -- find and read ~/.cabal/config + cfg <- readConfig + indexPath <- maybe (fail "No hackage.haskell.org repository") return $ cfgRepoIndex cfg hackageHaskellOrg + let storeDir = runIdentity (cfgStoreDir cfg) + let pidsOfInterest = Set.fromList (map uPId (Map.elems $ pjUnits plan)) - indexDb <- Map.fromList . filter (flip Set.member pidsOfInterest . fst) <$> readHackageIndex + indexDb <- Map.fromList . filter (flip Set.member pidsOfInterest . fst) <$> readHackageIndex indexPath let -- generally, units belonging to the same package as 'root' rootPkgUnits = [ u | u@(Unit { uPId = PkgId pn' _ }) <- Map.elems (pjUnits plan), pn' == pn0 ] @@ -197,7 +203,7 @@ when (length lfs' /= length lfs) $ do T.hPutStrLn stderr ("WARNING: Overlapping license filenames for " <> dispPkgId (uPId u)) - crdat <- getLicenseFiles (pjCompilerId plan) uid lfs' + crdat <- getLicenseFiles storeDir (pjCompilerId plan) uid lfs' forM_ (zip lfs' crdat) $ \(fn,txt) -> do let d = licdir T.unpack (dispPkgId (uPId u)) 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 @@ -58,6 +58,8 @@ data ShowBuiltin = ShowBuiltin data ShowGlobal = ShowGlobal +data ShowSetup = ShowSetup +data ShowExes = ShowExes data ShowCabSha = ShowCabSha data DotTred = DotTred data DotTredWght = DotTredWght @@ -66,6 +68,8 @@ instance HasDefault 'True ShowBuiltin instance HasDefault 'True ShowGlobal +instance HasDefault 'True ShowSetup +instance HasDefault 'True ShowExes instance HasDefault 'False ShowCabSha instance HasDefault 'False DotTred instance HasDefault 'False DotTredWght @@ -75,6 +79,8 @@ data GlobalOptions = GlobalOptions { optsShowBuiltin :: Flag ShowBuiltin , optsShowGlobal :: Flag ShowGlobal + , optsShowSetup :: Flag ShowSetup + , optsShowExes :: Flag ShowExes , optsUseColors :: UseColors , optsUseAscii :: UseAscii , cmd :: Command @@ -274,7 +280,7 @@ print plan TredCommand s -> do (_, plan) <- findPlan s - doTred optsUseColors plan + doTred optsUseColors optsUseAscii plan DiffCommand old new -> do (_, oldPlan) <- findPlan (Just old) (_, newPlan) <- findPlan (Just new) @@ -298,7 +304,7 @@ doFingerprint plan showCabSha DotCommand s tred tredWeights highlights rootPatterns output mdot -> do (_, plan) <- findPlan s - doDot optsShowBuiltin optsShowGlobal plan tred tredWeights highlights rootPatterns output mdot + doDot optsShowBuiltin optsShowGlobal optsShowSetup optsShowExes plan tred tredWeights highlights rootPatterns output mdot TopoCommand s rev showFlags -> do (_, plan) <- findPlan s doTopo optsUseColors optsShowBuiltin optsShowGlobal plan rev showFlags @@ -320,6 +326,8 @@ optParser = GlobalOptions <$> showHide ShowBuiltin "builtin" "Show / hide packages in global (non-nix-style) package db" <*> showHide ShowGlobal "global" "Show / hide packages in nix-store" + <*> showHide ShowSetup "setup" "Show / hide setup components" + <*> showHide ShowExes "exes" "Show / hide executable components" <*> useColorsParser <*> useAsciiParser <*> (cmdParser <|> defaultCommand) @@ -539,8 +547,8 @@ -- tred - Transitive reduction ------------------------------------------------------------------------------- -doTred :: UseColors -> PlanJson -> IO () -doTred useColors plan = runCWriterIO useColors UseAscii (dumpTred plan) +doTred :: UseColors -> UseAscii -> PlanJson -> IO () +doTred useColors useAscii plan = runCWriterIO useColors useAscii (dumpTred plan) dumpTred :: PlanJson -> CWriter () dumpTred plan = case fst <$> reductionClosureAM plan of @@ -604,7 +612,7 @@ let pid_label = emphasise' $ ccol comp (prettyCompTy pid comp) if seen - then putCTextLn $ linepfx lvl <> pid_label <> " ┄┄" + then putCTextLn $ linepfx lvl <> pid_label <> fromT Rest else do putCTextLn $ linepfx lvl <> pid_label @@ -899,6 +907,8 @@ doDot :: Flag ShowBuiltin -> Flag ShowGlobal + -> Flag ShowSetup + -> Flag ShowExes -> PlanJson -> Flag DotTred -> Flag DotTredWght @@ -907,7 +917,7 @@ -> FilePath -> Maybe RunDot -> IO () -doDot showBuiltin showGlobal plan tred tredWeights highlights rootPatterns output mdot = either loopGraph id $ TG.runG am $ \g' -> do +doDot showBuiltin showGlobal showSetup showExes plan tred tredWeights highlights rootPatterns output mdot = either loopGraph id $ TG.runG am $ \g' -> do let g = if fromFlag DotTred tred then TG.reduction g' else g' let closureAM = TG.adjacencyMap (TG.closure g) @@ -929,16 +939,21 @@ isReachableUnit unitId = S.member unitId reachableUnits let duShow :: DotUnitId -> Bool - duShow dotUnitId@(DU unitId _) = case M.lookup unitId units of - Nothing -> False - Just unit -> - if isReachableUnit dotUnitId - then case uType unit of - UnitTypeBuiltin -> fromFlag ShowBuiltin showBuiltin - UnitTypeGlobal -> fromFlag ShowGlobal showGlobal - UnitTypeLocal -> True - UnitTypeInplace -> True - else False + duShow dotUnitId@(DU unitId compName) = case M.lookup unitId units of + Nothing -> False + Just unit -> + if isReachableUnit dotUnitId + then case uType unit of + UnitTypeBuiltin -> fromFlag ShowBuiltin showBuiltin && showComp + UnitTypeGlobal -> fromFlag ShowGlobal showGlobal && showComp + UnitTypeLocal -> showComp + UnitTypeInplace -> showComp + else False + where + showComp = case compName of + Just CompNameSetup -> fromFlag ShowSetup showSetup + Just (CompNameExe _) -> fromFlag ShowExes showExes + _ -> True let vertex :: Set DotUnitId -> DotUnitId -> [Text] vertex redVertices du = do diff --git a/src/Cabal/Plan.hs b/src/Cabal/Plan.hs --- a/src/Cabal/Plan.hs +++ b/src/Cabal/Plan.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -579,10 +580,16 @@ -- @since 0.3.0.0 parseSha256 :: Text -> Maybe Sha256 parseSha256 t +#if MIN_VERSION_base16_bytestring(1,0,0) + = case B16.decode (T.encodeUtf8 t) of + Right s | B.length s == 32 -> Just (Sha256 s) + _ -> Nothing +#else | B.length s == 32, B.null rest = Just (Sha256 s) | otherwise = Nothing where (s, rest) = B16.decode $ T.encodeUtf8 t +#endif -- | Export the 'Sha256' digest to a 32-byte 'B.ByteString'. --