cabal-plan 0.5.0.0 → 0.6.0.0
raw patch · 7 files changed
+762/−719 lines, 7 filesdep +lensdep +semialigndep +singleton-booldep −base-orphansdep ~Cabaldep ~ansi-terminaldep ~basenew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: lens, semialign, singleton-bool, these, topograph, transformers
Dependencies removed: base-orphans
Dependency ranges changed: Cabal, ansi-terminal, base, base-compat, optparse-applicative, semigroups
API changes (from Hackage documentation)
+ Cabal.Plan: ExactPath :: FilePath -> SearchPlanJson
Files
- ChangeLog.md +17/−0
- cabal-plan.cabal +23/−28
- src-exe/Flag.hs +69/−0
- src-exe/cabal-plan.hs +637/−123
- src-topograph/LICENSE +0/−30
- src-topograph/Topograph.hs +0/−527
- src/Cabal/Plan.hs +16/−11
ChangeLog.md view
@@ -1,5 +1,22 @@ # Revision history for `cabal-plan` +## 0.6.0.0++### `lib:cabal-plan` Library++* `ExactPath` constructor to skip `find` in `findAndDecodePlanJson`.+ (Note: see also `decodePlanJson`)+++### `exe:cabal-plan` Executable++* `--plan-json` for exact `plan.json` location+* `--relative` search for project root relative to that directory+* `--colors=auto|never|always` flag+* `tred` command to print transtive reduction of dependency graph+* `diff` command to compare two plans+* `list-bins` prints full selector "pkg:type:name", i.e. includes package name+ ## 0.5.0.0 ### `lib:cabal-plan` Library
cabal-plan.cabal view
@@ -1,8 +1,8 @@ cabal-version: 2.2 name: cabal-plan-version: 0.5.0.0+version: 0.6.0.0 -synopsis: Library and utiltity for processing cabal's plan.json file+synopsis: Library and utility for processing cabal's plan.json file description: { This package provides a library (see "Cabal.Plan") for decoding @plan.json@ files as well as the simple tool @cabal-plan@ for extracting and pretty printing@@ -16,6 +16,8 @@ . [info] Show basic report of dependency tree [show] Dump 'PlanJson' data-structure via 'Show' instance+[tred] Show dependency tree as a graph+[diff] Diff two install plans [list-bins] List all binaries [list-bin] List single binary (useful for scripting, e.g. @cabal list-bin exe:cabal-plan@) [fingerprint] Print SHA256 sums of dependencies' source tarballs and cabal files@@ -27,8 +29,8 @@ } bug-reports: https://github.com/hvr/cabal-plan/issues-license: GPL-2.0-or-later AND BSD-3-Clause-license-files: LICENSE.GPLv2 LICENSE.GPLv3 src-topograph/LICENSE+license: GPL-2.0-or-later+license-files: LICENSE.GPLv2 LICENSE.GPLv3 author: Herbert Valerio Riedel maintainer: hvr@gnu.org copyright: 2016 Herbert Valerio Riedel@@ -36,8 +38,9 @@ build-type: Simple tested-with:- GHC==8.6.3,- GHC==8.4.3,+ GHC==8.8.1,+ GHC==8.6.5,+ GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3,@@ -73,7 +76,7 @@ RecordWildCards exposed-modules: Cabal.Plan - build-depends: base (>= 4.6 && <4.10) || ^>= 4.10 || ^>=4.11 || ^>=4.12+ build-depends: base (>= 4.6 && <4.10) || ^>= 4.10 || ^>=4.11 || ^>=4.12 || ^>=4.13 , aeson ^>= 1.2.0 || ^>= 1.3.0 || ^>=1.4.0.0 , bytestring ^>= 0.10.0 , containers ^>= 0.5.0 || ^>= 0.6.0.1@@ -86,32 +89,18 @@ ghc-options: -Wall -library topograph- default-language: Haskell2010- other-extensions: RankNTypes ScopedTypeVariables RecordWildCards- exposed-modules: Topograph-- build-depends: base (>= 4.6 && <4.10) || ^>= 4.10 || ^>= 4.11 || ^>= 4.12- , base-compat ^>= 0.9.3 || ^>=0.10.1- , base-orphans ^>= 0.6 || ^>=0.7 || ^>=0.8- , containers ^>= 0.5.0 || ^>= 0.6.0.1- , vector ^>= 0.12.0.1-- hs-source-dirs: src-topograph- executable cabal-plan default-language: Haskell2010 other-extensions: RecordWildCards hs-source-dirs: src-exe main-is: cabal-plan.hs- other-modules: Paths_cabal_plan, LicenseReport+ other-modules: Paths_cabal_plan LicenseReport Flag autogen-modules: Paths_cabal_plan if flag(exe) -- dependencies w/ inherited version ranges via 'cabal-plan' library build-depends: cabal-plan- , topograph , base , text , containers@@ -120,22 +109,28 @@ -- dependencies which require version bounds build-depends: mtl ^>= 2.2.1- , ansi-terminal ^>= 0.6.2 || ^>= 0.8.0.2- , base-compat ^>= 0.9.3 || ^>=0.10.1- , optparse-applicative ^>= 0.13.0 || ^>= 0.14.0+ , transformers ^>= 0.3.0.0 || ^>= 0.4.2.0 || ^>= 0.5.2.0+ , ansi-terminal ^>= 0.9 || ^>=0.10+ , base-compat ^>= 0.10.5 || ^>=0.11+ , optparse-applicative ^>= 0.15.0.0 , parsec ^>= 3.1.11+ , transformers ^>= 0.3.0.0 || ^>=0.4.2.0 || ^>= 0.5.2.0+ , topograph ^>= 1 , vector ^>= 0.12.0.1-+ , lens ^>= 4.17 || ^>=4.18+ , these ^>= 1+ , semialign ^>= 1+ , singleton-bool ^>= 0.1.4 if flag(license-report)- build-depends: Cabal ^>= 2.2.0.1 || ^>= 2.4.0.1+ build-depends: Cabal ^>= 2.2.0.1 || ^>= 2.4.0.1 || ^>= 3.0.0.0 , tar ^>= 0.5.1.0 , zlib ^>= 0.6.2 , filepath ^>= 1.4.1.2 if !impl(ghc >= 8.0) build-depends:- semigroups ^>= 0.18.3+ semigroups ^>= 0.18.3 || ^>=0.19 if flag(_) cpp-options: -DUNDERLINE_SUPPORT
+ src-exe/Flag.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE KindSignatures, DataKinds #-}+{-# LANGUAGE FunctionalDependencies, FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Because 'Flag' constructor isn't exposed,+-- we have to explicitly 'toFlag' and 'fromFlag'.+-- That way it's less likely we mix up bare Booleans.+module Flag (+ -- * Flag+ Flag, toFlag, fromFlag,+ -- * HasDefault+ HasDefault,+ -- * optparse-applicative+ showHide,+ switchM,+ ) where++import Prelude ()+import Prelude.Compat++import Control.Applicative ((<|>))+import Data.Semigroup (Semigroup (..))+import Data.Singletons.Bool+import qualified Options.Applicative as O++-------------------------------------------------------------------------------+-- Flag+-------------------------------------------------------------------------------++newtype Flag t = Flag Bool++toFlag :: t -> Bool -> Flag t+toFlag _ = Flag++fromFlag :: t -> Flag t -> Bool+fromFlag _ (Flag b) = b++-------------------------------------------------------------------------------+-- HasDefault+-------------------------------------------------------------------------------++-- | Default value.+--+-- With 'DeriveAnyClass' one could write+--+-- @+-- data MyOpt = MyOpt deriving (HasDefault 'True)+-- @+--+class SBoolI def => HasDefault (def :: Bool) t | t -> def++def :: forall t def. HasDefault def t => t -> Flag t+def t = toFlag t (reflectBool (P :: P def))++data P (def :: Bool) = P++-------------------------------------------------------------------------------+-- optparse-applicative+-------------------------------------------------------------------------------++showHide :: HasDefault def t => t -> String -> String -> O.Parser (Flag t)+showHide t n d =+ O.flag' (toFlag t True) (O.long ("show-" ++ n) <> O.help d)+ <|> O.flag' (toFlag t False) (O.long ("hide-" ++ n))+ <|> pure (def t)++switchM :: HasDefault 'False t => t -> String -> String -> O.Parser (Flag t)+switchM t n d = fmap (toFlag t) $ O.switch $ O.long n <> d' where+ d' | null d = mempty+ | otherwise = O.help d
src-exe/cabal-plan.hs view
@@ -1,6 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-} -- | SPDX-License-Identifier: GPL-2.0-or-later module Main where@@ -8,24 +11,26 @@ import Prelude () import Prelude.Compat -import Control.Monad.Compat (forM_, guard, unless, when)-import Control.Monad.RWS.Strict (RWS, evalRWS, gets, modify', tell)+import Control.Lens (ifor_)+import Control.Monad.Compat (forM_, guard, unless, when, ap)+import Control.Monad.State.Strict (StateT, modify', evalStateT, gets)+import Control.Monad.Trans.Class (lift) import Control.Monad.ST (runST)+import Data.Align (align) import Data.Char (isAlphaNum) import Data.Foldable (for_, toList) import qualified Data.Graph as G import Data.Map (Map) import qualified Data.Map as M-import Data.Maybe (fromMaybe, isJust, mapMaybe)-import Data.Monoid (Any (..))+import Data.Maybe (fromMaybe, isJust, mapMaybe, catMaybes)+import Data.Monoid (Any (..), Endo (..)) import Data.Semigroup (Semigroup (..)) import Data.Set (Set) import qualified Data.Set as S+import Data.String (IsString (..)) import qualified Data.Text as T import qualified Data.Text.IO as T-import qualified Data.Text.Lazy as LT-import qualified Data.Text.Lazy.Builder as LT-import qualified Data.Text.Lazy.IO as LT+import Data.These (These (..)) import qualified Data.Tree as Tr import Data.Tuple (swap) import qualified Data.Vector.Unboxed as U@@ -35,10 +40,11 @@ import System.Console.ANSI import System.Directory (getCurrentDirectory) import System.Exit (exitFailure)-import System.IO (hPutStrLn, stderr)+import System.IO (hPutStrLn, stderr, stdout) import qualified Text.Parsec as P import qualified Text.Parsec.String as P import qualified Topograph as TG+import Flag import Cabal.Plan import LicenseReport (generateLicenseReport)@@ -51,21 +57,39 @@ haveUnderlineSupport = False #endif +data ShowBuiltin = ShowBuiltin+data ShowGlobal = ShowGlobal+data ShowCabSha = ShowCabSha+data DotTred = DotTred+data DotTredWght = DotTredWght+data TopoReverse = TopoReverse+data ShowFlags = ShowFlags++instance HasDefault 'True ShowBuiltin+instance HasDefault 'True ShowGlobal+instance HasDefault 'False ShowCabSha+instance HasDefault 'False DotTred+instance HasDefault 'False DotTredWght+instance HasDefault 'False TopoReverse+instance HasDefault 'False ShowFlags+ data GlobalOptions = GlobalOptions- { buildDir :: Maybe FilePath- , optsShowBuiltin :: Bool- , optsShowGlobal :: Bool+ { optsShowBuiltin :: Flag ShowBuiltin+ , optsShowGlobal :: Flag ShowGlobal+ , optsUseColors :: UseColors , cmd :: Command } data Command- = InfoCommand- | ShowCommand- | FingerprintCommand Bool- | ListBinsCommand MatchCount [Pattern]- | DotCommand Bool Bool [Highlight]- | TopoCommand Bool Bool- | LicenseReport (Maybe FilePath) Pattern+ = InfoCommand (Maybe SearchPlanJson)+ | ShowCommand (Maybe SearchPlanJson)+ | TredCommand (Maybe SearchPlanJson)+ | FingerprintCommand (Maybe SearchPlanJson) (Flag ShowCabSha)+ | ListBinsCommand (Maybe SearchPlanJson) MatchCount [Pattern]+ | DotCommand (Maybe SearchPlanJson) (Flag DotTred) (Flag DotTredWght) [Highlight]+ | TopoCommand (Maybe SearchPlanJson) (Flag TopoReverse) (Flag ShowFlags)+ | LicenseReport (Maybe FilePath) Pattern+ | DiffCommand SearchPlanJson SearchPlanJson ------------------------------------------------------------------------------- -- Pattern@@ -235,19 +259,26 @@ main :: IO () main = do- GlobalOptions{..} <- execParser $ info (helper <*> optVersion <*> optParser) fullDesc- (searchMethod, mProjRoot) <- case buildDir of- Just dir -> pure (InBuildDir dir, Nothing)- Nothing -> do- cwd <- getCurrentDirectory- root <- findProjectRoot cwd- pure (ProjectRelativeToDir cwd, root)+ let prefs' = prefs $ subparserInline+ GlobalOptions{..} <- customExecParser prefs' $ info (helper <*> optVersion <*> optParser) fullDesc - plan <- findAndDecodePlanJson searchMethod case cmd of- InfoCommand -> doInfo mProjRoot plan- ShowCommand -> mapM_ print mProjRoot >> print plan- ListBinsCommand count pats -> do+ InfoCommand s -> do+ (mProjRoot, plan) <- findPlan s+ doInfo optsUseColors mProjRoot plan+ ShowCommand s -> do+ (mProjRoot, plan) <- findPlan s+ mapM_ print mProjRoot+ print plan+ TredCommand s -> do+ (_, plan) <- findPlan s+ doTred optsUseColors plan+ DiffCommand old new -> do+ (_, oldPlan) <- findPlan (Just old)+ (_, newPlan) <- findPlan (Just new)+ doDiff optsUseColors oldPlan newPlan+ ListBinsCommand s count pats -> do+ (_, plan) <- findPlan s let bins = doListBin plan pats case (count, bins) of (MatchMany, _) -> for_ bins $ \(g, fn) ->@@ -260,38 +291,67 @@ hPutStrLn stderr "Found more than one matching pattern:" for_ bins $ \(p,_) -> hPutStrLn stderr $ " " ++ p exitFailure- FingerprintCommand showCabSha -> doFingerprint plan showCabSha- DotCommand tred tredWeights highlights -> doDot optsShowBuiltin optsShowGlobal plan tred tredWeights highlights- TopoCommand rev showFlags -> doTopo optsShowBuiltin optsShowGlobal plan rev showFlags+ FingerprintCommand s showCabSha -> do+ (_, plan) <- findPlan s+ doFingerprint plan showCabSha+ DotCommand s tred tredWeights highlights -> do+ (_, plan) <- findPlan s+ doDot optsShowBuiltin optsShowGlobal plan tred tredWeights highlights+ TopoCommand s rev showFlags -> do+ (_, plan) <- findPlan s+ doTopo optsUseColors optsShowBuiltin optsShowGlobal plan rev showFlags LicenseReport mfp pat -> doLicenseReport mfp pat where+ findPlan search = do+ cwd <- getCurrentDirectory+ (searchMethod, mProjRoot) <- case search of+ Just searchMethod -> pure (searchMethod, Nothing)+ Nothing -> do+ root <- findProjectRoot cwd+ pure (ProjectRelativeToDir cwd, root)+ plan <- findAndDecodePlanJson searchMethod+ return (mProjRoot, plan)+ optVersion = infoOption ("cabal-plan " ++ showVersion version) (long "version" <> help "output version information and exit") optParser = GlobalOptions- <$> dirParser- <*> showHide "builtin" "Show / hide packages in global (non-nix-style) package db"- <*> showHide "global" "Show / hide packages in nix-store"+ <$> showHide ShowBuiltin "builtin" "Show / hide packages in global (non-nix-style) package db"+ <*> showHide ShowGlobal "global" "Show / hide packages in nix-store"+ <*> useColorsParser <*> (cmdParser <|> defaultCommand) - showHide n d =- flag' True (long ("show-" ++ n) <> help d)- <|> flag' False (long ("hide-" ++ n))- <|> pure True - dirParser = optional . strOption $ mconcat- [ long "builddir", metavar "DIR"- , help "Build directory to read plan.json from." ] - subCommand name desc val = command name $ info val (progDesc desc)+ useColorsParser :: Parser UseColors+ useColorsParser = option (eitherReader parseColor) $ mconcat+ [ long "color", metavar "always|never|auto"+ , help "Color output"+ , value ColorsAuto+ , showDefault+ , completer $ listCompleter ["always","never","auto"]+ ] - patternParser = argument (eitherReader parsePattern) . mconcat+ parseColor :: String -> Either String UseColors+ parseColor "always" = Right ColorsAlways+ parseColor "never" = Right ColorsNever+ parseColor "auto" = Right ColorsAuto+ parseColor s = Left $ "Use always, never or auto; not " ++ s - switchM = switch . mconcat+ subCommand name desc val = command name $ info val $ progDesc desc + patternParser = argument (eitherReader parsePattern) . mconcat+ cmdParser = subparser $ mconcat- [ subCommand "info" "Info" $ pure InfoCommand- , subCommand "show" "Show" $ pure ShowCommand+ [ subCommand "info" "Info" $ InfoCommand+ <$> planParser+ , subCommand "show" "Show" $ ShowCommand+ <$> planParser+ , subCommand "tred" "Transitive reduction" $ TredCommand+ <$> planParser+ , subCommand "diff" "Compare two plans" $ DiffCommand+ <$> planParser'+ <*> planParser' , subCommand "list-bins" "List All Binaries" . listBinParser MatchMany . many $ patternParser [ metavar "PATTERNS...", help "Patterns to match.", completer $ patternCompleter True ]@@ -299,31 +359,60 @@ listBinParser MatchOne $ pure <$> patternParser [ metavar "PATTERN", help "Pattern to match.", completer $ patternCompleter True ] , subCommand "fingerprint" "Print dependency hash fingerprint" $ FingerprintCommand- <$> switchM [ long "show-cabal-sha256" ]- <**> helper+ <$> planParser+ <*> switchM ShowCabSha "show-cabal-sha256" ""+ <**> helper , subCommand "dot" "Dependency .dot" $ DotCommand- <$> switchM- [ long "tred", help "Transitive reduction" ]- <*> switchM- [ long "tred-weights", help "Adjust edge thickness during transitive reduction" ]- <*> many highlightParser- <**> helper+ <$> planParser+ <*> switchM DotTred "tred" "Transitive reduction"+ <*> switchM DotTredWght "tred-weights" "Adjust edge thickness during transitive reduction"+ <*> many highlightParser+ <**> helper , subCommand "topo" "Plan in a topological sort" $ TopoCommand- <$> switchM- [ long "reverse", help "Reverse order" ]- <*> switchM- [ long "show-flags", help "Show flags" ]- <**> helper+ <$> planParser+ <*> switchM TopoReverse "reverse" "Reverse order"+ <*> switchM ShowFlags "show-flags" "Show flag assignments"+ <**> helper , subCommand "license-report" "Generate license report for a component" $ LicenseReport- <$> optional (strOption $ mconcat [ long "licensedir", metavar "DIR", help "Write per-package license documents to folder" ])- <*> patternParser- [ metavar "PATTERN", help "Pattern to match.", completer $ patternCompleter False ]- <**> helper+ <$> optional (strOption $ mconcat [ long "licensedir", metavar "DIR", help "Write per-package license documents to folder" ])+ <*> patternParser+ [ metavar "PATTERN", help "Pattern to match.", completer $ patternCompleter False ]+ <**> helper ] - defaultCommand = pure InfoCommand+ defaultCommand = pure (InfoCommand Nothing) -------------------------------------------------------------------------------+-- Plan parser+-------------------------------------------------------------------------------++planParser :: Parser (Maybe SearchPlanJson)+planParser = optional planParser'++planParser' :: Parser SearchPlanJson+planParser' = InBuildDir <$> dirParser+ <|> ExactPath <$> planJsonParser+ <|> ProjectRelativeToDir <$> projectRootParser+ where+ dirParser = strOption $ mconcat+ [ long "builddir", metavar "DIR"+ , help "Build directory to read plan.json from."+ , completer (bashCompleter "directory")+ ]++ planJsonParser = strOption $ mconcat+ [ long "plan-json", metavar "PATH"+ , help "Exact location of plan.json."+ , completer (bashCompleter "file")+ ]++ projectRootParser = strOption $ mconcat+ [ long "relative", metavar "DIR"+ , help "Find the project root relative to specified directory."+ , completer (bashCompleter "directory")+ ]++------------------------------------------------------------------------------- -- list-bin ------------------------------------------------------------------------------- @@ -331,8 +420,9 @@ :: MatchCount -> Parser [Pattern] -> Parser Command-listBinParser count pats- = ListBinsCommand count <$> pats <**> helper+listBinParser count pats =+ ListBinsCommand <$> planParser <*> pure count <*> pats <**> helper+ data MatchCount = MatchOne | MatchMany deriving (Show, Eq) @@ -343,8 +433,8 @@ case ciBinFile ci of Nothing -> [] Just fn -> do- let PkgId pn _ = uPId- g = T.unpack $ dispCompNameTarget pn cn+ let PkgId pn@(PkgName pnT) _ = uPId+ g = T.unpack pnT ++ ":" ++ T.unpack (dispCompNameTarget pn cn) guard . getAny $ patternChecker pn cn [(g, fn)] where@@ -357,7 +447,7 @@ -- fingerprint ------------------------------------------------------------------------------- -doFingerprint :: PlanJson -> Bool -> IO ()+doFingerprint :: PlanJson -> Flag ShowCabSha -> IO () doFingerprint plan showCabSha = do let pids = M.fromList [ (uPId u, u) | (_,u) <- M.toList (pjUnits plan) ] @@ -373,21 +463,21 @@ UnitTypeLocal -> "L" UnitTypeInplace -> "I" - T.putStrLn (T.unwords $ if showCabSha then [ h1, h2, ty, dispPkgId uPId ] else [ h1, ty, dispPkgId uPId ])+ T.putStrLn (T.unwords $ if fromFlag ShowCabSha showCabSha then [ h1, h2, ty, dispPkgId uPId ] else [ h1, ty, dispPkgId uPId ]) ------------------------------------------------------------------------------- -- info ------------------------------------------------------------------------------- -doInfo :: Maybe FilePath -> PlanJson -> IO ()-doInfo mProjbase plan = do+doInfo :: UseColors -> Maybe FilePath -> PlanJson -> IO ()+doInfo useColors mProjbase plan = do forM_ mProjbase $ \projbase -> putStrLn ("using '" ++ projbase ++ "' as project root") putStrLn "" putStrLn "Tree" putStrLn "~~~~" putStrLn ""- LT.putStrLn (dumpPlanJson plan)+ runCWriterIO useColors (dumpPlanJson plan) -- print (findCycles (planJsonIdGrap v)) @@ -420,13 +510,319 @@ return () -------------------------------------------------------------------------------+-- tred - Transitive reduction+-------------------------------------------------------------------------------++doTred :: UseColors -> PlanJson -> IO ()+doTred useColors plan = runCWriterIO useColors (dumpTred plan)++dumpTred :: PlanJson -> CWriter ()+dumpTred plan = case fst <$> reductionClosureAM plan of+ Left xs -> loopGraph xs+ Right am -> do+ let nonRoots :: Set DotUnitId+ nonRoots = mconcat $ M.elems am++ roots :: Set DotUnitId+ roots = M.keysSet am `S.difference` nonRoots++ evalStateT (mapM_ (go1 am) roots) S.empty+ where+ pm = pjUnits plan++ directDepsOfLocalPackages :: Set UnitId+ directDepsOfLocalPackages = S.fromList+ [ depUid+ | u <- M.elems pm+ , uType u == UnitTypeLocal+ , ci <- M.elems (uComps u)+ , depUid <- S.toList (ciLibDeps ci)+ ]++ loopGraph :: [DotUnitId] -> CWriter ()+ loopGraph xs = do+ putCTextLn $ colorifyStr Red $ "panic: Found a loop"+ mapM_ (putCTextLn . fromString . show) xs++ go1 :: Map DotUnitId (Set DotUnitId)+ -> DotUnitId+ -> StateT (Set DotUnitId) CWriter ()+ go1 am = go2 [] where+ ccol :: Maybe CompName -> String -> CText+ ccol Nothing = colorifyStr White+ ccol (Just comp) = ccol' comp++ ccol' CompNameLib = colorifyStr White+ ccol' (CompNameExe _) = colorifyStr Green+ ccol' CompNameSetup = colorifyStr Red+ ccol' (CompNameTest _) = colorifyStr Yellow+ ccol' (CompNameBench _) = colorifyStr Cyan+ ccol' (CompNameSubLib _) = colorifyStr Blue+ ccol' (CompNameFLib _) = colorifyStr Magenta++ go2 :: [(Maybe CompName, Bool)]+ -> DotUnitId+ -> StateT (Set DotUnitId) CWriter ()+ go2 lvl duid@(DU uid comp) = do+ let unit = M.findWithDefault (error "non-existing UnitId") uid pm+ let deps = M.findWithDefault S.empty duid am+ let pid = uPId unit++ let emphasise' | uType unit == UnitTypeLocal = underline+ | uid `S.member` directDepsOfLocalPackages = emphasise+ | otherwise = id++ seen <- gets (S.member duid)+ modify' (S.insert duid)++ let pid_label = emphasise' $ ccol comp (prettyCompTy pid comp)++ if seen+ then putCTextLn $ linepfx lvl <> pid_label <> " ┄┄"+ else do+ putCTextLn $ linepfx lvl <> pid_label++ for_ (lastAnn $ S.toList deps) $ \(l, depDuid) ->+ go2 (lvl ++ [(comp, not l)]) depDuid++ linepfx :: [(Maybe CompName, Bool)] -> CText+ linepfx lvl = case unsnoc lvl of+ Nothing -> ""+ Just (xs,(zt,z)) -> mconcat [ if x then ccol xt " │ " else " " | (xt,x) <- xs ]+ <> (ccol zt $ if z then " ├─ " else " └─ ")++ prettyPid = T.unpack . dispPkgId++ prettyCompTy :: PkgId -> Maybe CompName -> String+ prettyCompTy pid Nothing = "[" ++ prettyPid pid ++ ":all]"+ prettyCompTy pid (Just c) = prettyCompTy' pid c++ prettyCompTy' :: PkgId -> CompName -> String+ prettyCompTy' pid CompNameLib = prettyPid pid+ prettyCompTy' _pid CompNameSetup = "[setup]"+ prettyCompTy' pid (CompNameExe n) = "[" ++ prettyPid pid ++ ":exe:" ++ show n ++ "]"+ prettyCompTy' pid (CompNameTest n) = "[" ++ prettyPid pid ++ ":test:" ++ show n ++ "]"+ prettyCompTy' pid (CompNameBench n) = "[" ++ prettyPid pid ++ ":bench:" ++ show n ++ "]"+ prettyCompTy' pid (CompNameSubLib n) = "[" ++ prettyPid pid ++ ":lib:" ++ show n ++ "]"+ prettyCompTy' pid (CompNameFLib n) = "[" ++ prettyPid pid ++ ":flib:" ++ show n ++ "]"++reductionClosureAM+ :: PlanJson+ -> Either [DotUnitId] (Map DotUnitId (Set DotUnitId), Map DotUnitId (Set DotUnitId))+reductionClosureAM plan = TG.runG am $ \g ->+ (TG.adjacencyMap (TG.reduction g), am)+ where+ am = planJsonDotUnitGraph plan++-------------------------------------------------------------------------------+-- Diff+-------------------------------------------------------------------------------++data DotPkgName = DPN !PkgName (Maybe CompName)+ deriving (Eq, Ord, Show)++data DiffOp = Removed | Changed | Added++-- quantified name to silent redundant import warning+instance Data.Semigroup.Semigroup DiffOp where+ Changed <> x = x+ x <> _ = x++doDiff :: UseColors -> PlanJson -> PlanJson -> IO ()+doDiff useColors oldPlan newPlan = runCWriterIO useColors (dumpDiff oldPlan newPlan)++dumpDiff :: PlanJson -> PlanJson -> CWriter ()+dumpDiff oldPlan newPlan = case liftA2 (,) (reductionClosureAM oldPlan) (reductionClosureAM newPlan) of+ Left xs -> loopGraph xs+ Right ((old, oldC), (new, newC)) -> do+ let oldPkgs, newPkgs :: Map DotPkgName Ver+ oldPkgs = M.fromList $ map (fromUnitId oldPm . fst) $ M.toList old+ newPkgs = M.fromList $ map (fromUnitId newPm . fst) $ M.toList new++ let alignedPkgs = align oldPkgs newPkgs++ unless (oldPkgs == newPkgs) $ do+ putCTextLn ""+ putCTextLn "Package versions"+ putCTextLn "~~~~~~~~~~~~~~~~"+ putCTextLn ""++ ifor_ alignedPkgs $ \(DPN pn cn) vers -> do+ let emphasise' | pn `S.member` localPackages = underline+ | pn `S.member` directDepsOfLocalPackages = emphasise+ | otherwise = id++ let putLine b v = putCTextLn $ colorifyText c s <> emphasise' (fromText (dispPkgId (PkgId pn v)) <> fromText (maybe "" (\cn' -> " " <> dispCompName cn') cn))+ where+ c = if b then Green else Red+ s = if b then "+" else "-"++ let putLine2 b v = putCTextLn $ colorifyText c s <> emphasise' (fromText (prettyPkgName pn) <> "-" <> colorifyText c (dispVer v) <> fromText (maybe "" (\cn' -> " " <> dispCompName cn') cn))+ where+ c = if b then Green else Red+ s = if b then "+" else "-"++ case vers of+ This o -> putLine False o+ That n -> putLine True n+ These o n+ | o == n -> pure ()+ | otherwise -> putLine2 False o >> putLine2 True n++ let mk :: Map UnitId Unit+ -> Map DotUnitId (Set DotUnitId)+ -> Map DotPkgName (Set DotPkgName)+ mk pm input = M.fromList+ [ (fromUnitId' pm k, S.map (fromUnitId' pm) vs)+ | (k, vs) <- M.toList input+ ]++ let oldAm, oldAmC, newAm, newAmC :: Map DotPkgName (Set DotPkgName)+ oldAm = mk oldPm old+ newAm = mk newPm new+ oldAmC = mk oldPm oldC+ newAmC = mk newPm newC++ unless (oldAm == newAm) $ do+ putCTextLn ""+ putCTextLn "Dependency graph"+ putCTextLn "~~~~~~~~~~~~~~~~"+ putCTextLn ""++ let am = align oldAm newAm+ let nonRoots = mconcat (M.elems oldAm) <> mconcat (M.elems newAm)+ let roots = M.keysSet am `S.difference` nonRoots++ evalStateT (mapM_ (go1 alignedPkgs oldAmC newAmC am) roots) S.empty+ where+ oldPm = pjUnits oldPlan+ newPm = pjUnits newPlan++ localPackages :: Set PkgName+ localPackages = S.fromList+ [ pn+ | u <- M.elems oldPm ++ M.elems newPm+ , uType u == UnitTypeLocal+ , let PkgId pn _ = uPId u+ ]++ directDepsOfLocalPackages :: Set PkgName+ directDepsOfLocalPackages = S.fromList $ catMaybes+ [ nameFromId . uPId <$> (M.lookup depUid oldPm <|> M.lookup depUid newPm)+ | u <- M.elems oldPm ++ M.elems newPm+ , uType u == UnitTypeLocal+ , ci <- M.elems (uComps u)+ , depUid <- S.toList (ciLibDeps ci)+ ]+ where+ nameFromId (PkgId pn _) = pn+++ fromUnitId :: Map UnitId Unit -> DotUnitId -> (DotPkgName, Ver)+ fromUnitId db (DU uid cn) = case M.lookup uid db of+ Nothing -> error $ "Unknown unit-id " ++ show uid+ Just Unit { uPId = PkgId pn ver } -> (DPN pn cn, ver)++ fromUnitId' :: Map UnitId Unit -> DotUnitId -> DotPkgName+ fromUnitId' db = fst . fromUnitId db++ loopGraph :: [DotUnitId] -> CWriter ()+ loopGraph xs = do+ putCTextLn $ colorifyStr Red $ "panic: Found a loop"+ mapM_ (putCTextLn . fromString . show) xs++ go1 :: Map DotPkgName (These Ver Ver)+ -> Map DotPkgName (Set DotPkgName)+ -> Map DotPkgName (Set DotPkgName)+ -> Map DotPkgName (These (Set DotPkgName) (Set DotPkgName))+ -> DotPkgName+ -> StateT (Set DotPkgName) CWriter ()+ go1 alignedPkgs oldAmC newAmC am = go2 Changed [] where+ go2 :: DiffOp+ -> [(Maybe CompName, Bool)]+ -> DotPkgName+ -> StateT (Set DotPkgName) CWriter ()+ go2 op' lvl dpn@(DPN pn comp) = do+ let emphasise' | pn `S.member` localPackages = underline+ | pn `S.member` directDepsOfLocalPackages = emphasise+ | otherwise = id+++ let deps = M.lookup dpn am+ let odepsC = M.findWithDefault S.empty dpn oldAmC+ let ndepsC = M.findWithDefault S.empty dpn newAmC++ let (op, odeps, ndeps) = case deps of+ -- when a dependency is added or removed we won't print its dependencies.+ Nothing -> (op', mempty, mempty)+ Just (This _) -> (op' <> Removed, mempty, mempty)+ Just (That _) -> (op' <> Added, mempty, mempty)+ Just (These o n) -> (op', o, n)++ let putStrLn' :: MonadCWriter m => CText -> CText -> m ()+ putStrLn' pfx s = putCTextLn $ case op of+ Changed -> " " <> pfx <> s+ Added -> colorifyText Green "+++ " <> pfx <> recolorify Green s+ Removed -> colorifyText Red "--- " <> pfx <> recolorify Red s++ seen <- gets (S.member dpn)+ modify' (S.insert dpn)++ let pn_label :: CText+ pn_label = emphasise' $ fromText (prettyCompTy pn comp) <> case (op, M.lookup dpn alignedPkgs) of+ (_, Nothing) -> ""+ (_, Just (This ver)) -> " " <> fromText (dispVer ver) <> " -> "+ (_, Just (That ver)) -> " -> " <> fromText (dispVer ver)+ (Changed, Just (These o n))+ | o == n -> "-" <> fromText (dispVer o)+ | otherwise -> " " <> colorifyText Red (dispVer o) <> " -> " <> colorifyText Green (dispVer n)+ (Added, Just (These o n))+ | o == n -> "-" <> fromText (dispVer o)+ | otherwise -> " -> " <> fromText (dispVer n)+ (Removed, Just (These o n))+ | o == n -> "-" <> fromText (dispVer o)+ | otherwise -> " " <> fromText (dispVer o) <> " ->"++ if seen+ then putStrLn' (linepfx lvl) $ pn_label <> " ┄┄"+ else do+ putStrLn' (linepfx lvl) pn_label+ for_ (lastAnn $ S.toList $ odeps <> ndeps) $ \(l, depDpn) -> do+ let depOp | S.member depDpn odeps && not (S.member depDpn ndepsC) = Removed+ | S.member depDpn ndeps && not (S.member depDpn odepsC) = Added+ | otherwise = Changed++ go2 depOp (lvl ++ [(comp, not l)]) depDpn++ linepfx :: [(Maybe CompName, Bool)] -> CText+ linepfx lvl = case unsnoc lvl of+ Nothing -> mempty+ Just (xs,(_,z)) -> mconcat [ if x then " │ " else " " | (_,x) <- xs ]+ <> (if z then " ├─ " else " └─ ")++ prettyPkgName (PkgName pn) = pn++ prettyCompTy :: PkgName -> Maybe CompName -> T.Text+ prettyCompTy pn Nothing = "[" <> prettyPkgName pn <> ":all]"+ prettyCompTy pn (Just c) = prettyCompTy' pn c++ prettyCompTy' :: PkgName -> CompName -> T.Text+ prettyCompTy' pn CompNameLib = prettyPkgName pn+ prettyCompTy' _pn CompNameSetup = "[setup]"+ prettyCompTy' pn (CompNameExe n) = "[" <> prettyPkgName pn <> ":exe:" <> n <> "]"+ prettyCompTy' pn (CompNameTest n) = "[" <> prettyPkgName pn <> ":test:" <> n <> "]"+ prettyCompTy' pn (CompNameBench n) = "[" <> prettyPkgName pn <> ":bench:" <> n <> "]"+ prettyCompTy' pn (CompNameSubLib n) = "[" <> prettyPkgName pn <> ":lib:" <> n <> "]"+ prettyCompTy' pn (CompNameFLib n) = "[" <> prettyPkgName pn <> ":flib:" <> n <> "]"++------------------------------------------------------------------------------- -- Dot ------------------------------------------------------------------------------- -- | vertex of dot graph. -- -- if @'Maybe' 'CompName'@ is Nothing, this is legacy, multi-component unit.-data DotUnitId = DU UnitId (Maybe CompName)+data DotUnitId = DU !UnitId (Maybe CompName) deriving (Eq, Ord, Show) planJsonDotUnitGraph :: PlanJson -> Map DotUnitId (Set DotUnitId)@@ -474,9 +870,15 @@ trPairs (No _ i js) = [ (n, i, j) | No n j _ <- js ] ++ concatMap trPairs js -doDot :: Bool -> Bool -> PlanJson -> Bool -> Bool -> [Highlight] -> IO ()+doDot+ :: Flag ShowBuiltin+ -> Flag ShowGlobal+ -> PlanJson+ -> Flag DotTred+ -> Flag DotTredWght+ -> [Highlight] -> IO () doDot showBuiltin showGlobal plan tred tredWeights highlights = either loopGraph id $ TG.runG am $ \g' -> do- let g = if tred then TG.reduction g' else g'+ let g = if fromFlag DotTred tred then TG.reduction g' else g' -- Highlights let paths :: [(DotUnitId, DotUnitId)]@@ -531,13 +933,13 @@ for_ (trPairs ps) $ \(k, a, b) -> MU.modify v (\n -> n + fromIntegral k * r)- (TG.gToInt g b + TG.gToInt g a * len)+ (TG.gVertexIndex g b + TG.gVertexIndex g a * len) U.freeze v let weights :: Map (DotUnitId, DotUnitId) Double weights =- if tred && tredWeights+ if fromFlag DotTred tred && fromFlag DotTredWght tredWeights then M.fromList [ ((a, b), w + 1) | ((i, j), w) <- zip ((,) <$> TG.gVertices g <*> TG.gVertices g) (U.toList weights')@@ -599,8 +1001,8 @@ duShow (DU unitId _) = case M.lookup unitId units of Nothing -> False Just unit -> case uType unit of- UnitTypeBuiltin -> showBuiltin- UnitTypeGlobal -> showGlobal+ UnitTypeBuiltin -> fromFlag ShowBuiltin showBuiltin+ UnitTypeGlobal -> fromFlag ShowGlobal showGlobal UnitTypeLocal -> True UnitTypeInplace -> True @@ -723,25 +1125,32 @@ -- topo ------------------------------------------------------------------------------- -doTopo :: Bool -> Bool -> PlanJson -> Bool -> Bool -> IO ()-doTopo showBuiltin showGlobal plan rev showFlags = do+doTopo+ :: UseColors+ -> Flag ShowBuiltin+ -> Flag ShowGlobal+ -> PlanJson+ -> Flag TopoReverse+ -> Flag ShowFlags+ -> IO ()+doTopo useColors showBuiltin showGlobal plan rev showFlags = do let units = pjUnits plan let topo = TG.runG (planJsonIdGraph plan) $ \TG.G {..} -> map gFromVertex gVertices let showUnit unit = case uType unit of- UnitTypeBuiltin -> showBuiltin- UnitTypeGlobal -> showGlobal+ UnitTypeBuiltin -> fromFlag ShowBuiltin showBuiltin+ UnitTypeGlobal -> fromFlag ShowGlobal showGlobal UnitTypeLocal -> True UnitTypeInplace -> True - let rev' = if rev then reverse else id+ let rev' = if fromFlag TopoReverse rev then reverse else id - for_ topo $ \topo' -> for_ (rev' topo') $ \unitId ->+ runCWriterIO useColors $ for_ topo $ \topo' -> for_ (rev' topo') $ \unitId -> for_ (M.lookup unitId units) $ \unit -> when (showUnit unit) $ do- let colour = case uType unit of+ let pkgIdColor = colorifyText $ case uType unit of UnitTypeBuiltin -> Blue UnitTypeGlobal -> White UnitTypeLocal -> Green@@ -751,42 +1160,42 @@ [] -> "" [CompNameLib] -> "" names -> " " <> T.intercalate " " (map (dispCompNameTarget pn) names)- let flags | showFlags = concat+ let flags | fromFlag ShowFlags showFlags = fromString $ concat [ " " ++ (if flagValue then "+" else "-") ++ T.unpack flagName | (FlagName flagName, flagValue) <- M.toList (uFlags unit) ] | otherwise = ""- putStrLn $- colorify colour (T.unpack $ dispPkgId $ uPId unit)- ++ T.unpack components- ++ flags+ putCTextLn $+ pkgIdColor (dispPkgId $ uPId unit)+ <> fromString (T.unpack components)+ <> flags ---------------------------------------------------------------------------- -dumpPlanJson :: PlanJson -> LT.Text-dumpPlanJson (PlanJson { pjUnits = pm }) = LT.toLazyText out+dumpPlanJson :: PlanJson -> CWriter ()+dumpPlanJson (PlanJson { pjUnits = pm }) =+ evalStateT (mapM_ (go2 []) (S.toList roots)) S.empty where- ((),out) = evalRWS (mapM_ (go2 []) (S.toList roots)) () mempty- id2pid :: Map UnitId PkgId id2pid = M.fromList [ (uId, uPId) | Unit{..} <- M.elems pm ] lupPid uid = M.findWithDefault undefined uid id2pid - go2 :: [(CompName,Bool)] -> UnitId -> (RWS () LT.Builder (Set UnitId)) ()+ go2 :: [(CompName,Bool)] -> UnitId -> StateT (Set UnitId) CWriter () 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 | preExists = fromString (prettyId pid)+ | otherwise = colorify_ White (prettyId pid) if not pidSeen then do- tell $ LT.fromString (linepfx ++ pid_label ++ "\n")+ putCTextLn $ linepfx <> pid_label showDeps else do- tell $ LT.fromString (linepfx ++ pid_label ++ ccol CompNameLib " ┄┄\n")+ putCTextLn $ linepfx <> pid_label <> ccol CompNameLib " ┄┄" -- tell $ LT.fromString (linepfx' ++ " └┄\n") modify' (S.insert pid)@@ -799,17 +1208,19 @@ showDeps = for_ (M.toList $ uComps x') $ \(ct,deps) -> do unless (ct == CompNameLib) $- tell (LT.fromString $ linepfx' ++ " " ++ prettyCompTy (lupPid pid) ct ++ "\n")+ putCTextLn $ linepfx' <> " " <> prettyCompTy (lupPid pid) ct for_ (lastAnn $ S.toList (ciLibDeps deps)) $ \(l,y) -> do go2 (lvl ++ [(ct, not l)]) y + linepfx :: CText linepfx = case unsnoc lvl of- Nothing -> ""- Just (xs,(zt,z)) -> concat [ if x then ccol xt " │ " else " " | (xt,x) <- xs ]- ++ (ccol zt $ if z then " ├─ " else " └─ ")+ Nothing -> ""+ Just (xs,(zt,z)) -> mconcat [ if x then ccol xt " │ " else " " | (xt,x) <- xs ]+ <> (ccol zt $ if z then " ├─ " else " └─ ") - linepfx' = concat [ if x then " │ " else " " | (_,x) <- lvl ]+ linepfx' :: CText+ linepfx' = mconcat [ if x then " │ " else " " | (_,x) <- lvl ] roots :: Set UnitId roots = M.keysSet pm `S.difference` leafs@@ -820,7 +1231,7 @@ prettyId = prettyPid . lupPid prettyPid = T.unpack . dispPkgId - prettyCompTy :: PkgId -> CompName -> String+ prettyCompTy :: PkgId -> CompName -> CText 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 ++ "]"@@ -829,21 +1240,18 @@ prettyCompTy pid c@(CompNameSubLib n) = ccol c $ "[" ++ prettyPid pid ++ ":lib:" ++ show n ++ "]" prettyCompTy pid c@(CompNameFLib n) = ccol c $ "[" ++ prettyPid pid ++ ":flib:" ++ show n ++ "]" - ccol CompNameLib = colorify White- ccol (CompNameExe _) = colorify Green- ccol CompNameSetup = colorify Red- ccol (CompNameTest _) = colorify Yellow- ccol (CompNameBench _) = colorify Cyan- ccol (CompNameSubLib _) = colorify Blue- ccol (CompNameFLib _) = colorify Magenta--colorify :: Color -> String -> String-colorify col s = setSGRCode [SetColor Foreground Vivid col] ++ s ++ setSGRCode [Reset]+ ccol CompNameLib = colorifyStr White+ ccol (CompNameExe _) = colorifyStr Green+ ccol CompNameSetup = colorifyStr Red+ ccol (CompNameTest _) = colorifyStr Yellow+ ccol (CompNameBench _) = colorifyStr Cyan+ ccol (CompNameSubLib _) = colorifyStr Blue+ ccol (CompNameFLib _) = colorifyStr Magenta -colorify_ :: Color -> String -> String+colorify_ :: Color -> String -> CText colorify_ col s- | haveUnderlineSupport = setSGRCode [SetUnderlining SingleUnderline, SetColor Foreground Vivid col] ++ s ++ setSGRCode [Reset]- | otherwise = colorify col s+ | haveUnderlineSupport = CText [CPiece (T.pack s) [SetUnderlining SingleUnderline, SetColor Foreground Vivid col]]+ | otherwise = colorifyStr col s lastAnn :: [x] -> [(Bool,x)] lastAnn = reverse . firstAnn . reverse@@ -868,3 +1276,109 @@ (g, v2k, _) = G.graphFromEdges [ ((), k, S.toList v) | (k,v) <- M.toList m ]++-------------------------------------------------------------------------------+-- Colors+-------------------------------------------------------------------------------++data CPiece = CPiece !T.Text [SGR]+ deriving (Eq, Show)++newtype CText = CText [CPiece]+ deriving (Eq, Show)++instance IsString CText where+ fromString s+ | null s = mempty+ | otherwise = CText [CPiece (fromString s) []]++instance Semigroup CText where+ CText xs <> CText ys = CText (xs <> ys)++instance Monoid CText where+ mempty = CText []+ mappend = (<>)++fromText :: T.Text -> CText+fromText t = CText [CPiece t []]++colorifyStr :: Color -> String -> CText+colorifyStr c t = CText [CPiece (T.pack t) [SetColor Foreground Vivid c]]++colorifyText :: Color -> T.Text -> CText+colorifyText c t = CText [CPiece t [SetColor Foreground Vivid c]]++recolorify :: Color -> CText -> CText+recolorify c (CText xs) = CText+ [ CPiece t (SetColor Foreground Vivid c : sgr)+ | CPiece t sgr' <- xs+ , let sgr = filter notSetColor sgr'+ ]+ where+ notSetColor SetColor {} = False+ notSetColor _ = True++-- | We decide to bold, we could do something else to.+emphasise :: CText -> CText+emphasise (CText xs) = CText+ [ CPiece t (SetConsoleIntensity BoldIntensity : sgr)+ | CPiece t sgr <- xs+ ]++underline :: CText -> CText+underline (CText xs) | haveUnderlineSupport = CText+ [ CPiece t (SetUnderlining SingleUnderline : sgr)+ | CPiece t sgr <- xs+ ]+underline x = x++-- | Colored writer (list is lines)+newtype CWriter a = CWriter { unCWriter :: Endo [CText] -> (Endo [CText], a) }+ deriving Functor++class Monad m => MonadCWriter m where+ putCTextLn :: CText -> m ()++instance MonadCWriter CWriter where+ putCTextLn t = CWriter $ \l -> (l <> Endo (t :), ())++instance MonadCWriter m => MonadCWriter (StateT s m) where+ putCTextLn = lift . putCTextLn++instance Applicative CWriter where+ pure = return+ (<*>) = ap++instance Monad CWriter where+ return x = CWriter $ \ls -> (ls, x)++ m >>= k = CWriter $ \ls0 ->+ let (ls1, x) = unCWriter m ls0+ in unCWriter (k x) ls1++data UseColors = ColorsNever | ColorsAuto | ColorsAlways+ deriving (Eq, Show)++runCWriterIO :: UseColors -> CWriter () -> IO ()+runCWriterIO ColorsNever m = runCWriterIONoColors m+runCWriterIO ColorsAlways m = runCWriterIOColors m+runCWriterIO ColorsAuto m = do+ supports <- hSupportsANSIColor stdout+ if supports+ then runCWriterIOColors m+ else runCWriterIONoColors m++runCWriterIOColors :: CWriter () -> IO ()+runCWriterIOColors (CWriter f) =+ forM_ (appEndo (fst (f mempty)) []) $ \(CText l) -> do+ forM_ l $ \(CPiece t sgr) -> do+ unless (null sgr) $ setSGR sgr+ T.putStr t+ unless (null sgr) $ setSGR []+ putChar '\n'++runCWriterIONoColors :: CWriter () -> IO ()+runCWriterIONoColors (CWriter f) =+ forM_ (appEndo (fst (f mempty)) []) $ \(CText l) -> do+ forM_ l $ \(CPiece t _) -> T.putStr t+ putChar '\n'
− src-topograph/LICENSE
@@ -1,30 +0,0 @@-Copyright (c) 2018, Oleg Grenrus--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of Oleg Grenrus nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− src-topograph/Topograph.hs
@@ -1,527 +0,0 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables, RecordWildCards #-}--- | Copyright: (c) 2018, Oleg Grenrus--- SPDX-License-Identifier: BSD-3-Clause------ Tools to work with Directed Acyclic Graphs,--- by taking advantage of topological sorting.----module Topograph (- -- * Graph- -- $setup-- G (..),- runG,- runG',- -- * All paths- allPaths,- allPaths',- allPathsTree,- -- * DFS- dfs,- dfsTree,- -- * Longest path- longestPathLengths,- -- * Transpose- transpose,- -- * Transitive reduction- reduction,- -- * Transitive closure- closure,- -- * Query- edgesSet,- adjacencyMap,- adjacencyList,- -- * Helper functions- treePairs,- pairs,- getDown,- ) where--import Prelude ()-import Prelude.Compat-import Data.Orphans ()--import Control.Monad.ST (ST, runST)-import Data.Maybe (fromMaybe, catMaybes, mapMaybe)-import Data.Monoid (First (..))-import Data.List (sort)-import Data.Foldable (for_)-import Data.Ord (Down (..))-import qualified Data.Graph as G-import Data.Tree as T-import Data.Map (Map)-import qualified Data.Map as M-import Data.Set (Set)-import qualified Data.Set as S-import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as U-import qualified Data.Vector.Unboxed.Mutable as MU--import Debug.Trace---- | Graph representation.-data G v a = G- { gVertices :: [a] -- ^ all vertices, in topological order.- , gFromVertex :: a -> v -- ^ retrieve original vertex data. /O(1)/- , gToVertex :: v -> Maybe a -- ^ /O(log n)/- , gEdges :: a -> [a] -- ^ Outgoing edges.- , gDiff :: a -> a -> Int -- ^ Upper bound of the path length. Negative if there aren't path. /O(1)/- , gVerticeCount :: Int- , gToInt :: a -> Int- }---- | Run action on topologically sorted representation of the graph.------ === __Examples__------ ==== Topological sorting------ >>> runG example $ \G {..} -> map gFromVertex gVertices--- Right "axbde"------ Vertices are sorted------ >>> runG example $ \G {..} -> map gFromVertex $ sort gVertices--- Right "axbde"------ ==== Outgoing edges------ >>> runG example $ \G {..} -> map (map gFromVertex . gEdges) gVertices--- Right ["xbde","de","d","e",""]------ Note: edges are always larger than source vertex:------ >>> runG example $ \G {..} -> getAll $ foldMap (\a -> foldMap (\b -> All (a < b)) (gEdges a)) gVertices--- Right True------ ==== Not DAG------ >>> let loop = M.map S.fromList $ M.fromList [('a', "bx"), ('b', "cx"), ('c', "ax"), ('x', "")]--- >>> runG loop $ \G {..} -> map gFromVertex gVertices--- Left "abc"------ >>> runG (M.singleton 'a' (S.singleton 'a')) $ \G {..} -> map gFromVertex gVertices--- Left "aa"----runG- :: forall v r. Ord v- => Map v (Set v) -- ^ Adjacency Map- -> (forall i. Ord i => G v i -> r) -- ^ function on linear indices- -> Either [v] r -- ^ Return the result or a cycle in the graph.-runG m f- | Just l <- loop = Left (map (indices V.!) l)- | otherwise = Right (f g)- where- gr :: G.Graph- r :: G.Vertex -> ((), v, [v])- _t :: v -> Maybe G.Vertex-- (gr, r, _t) = G.graphFromEdges [ ((), v, S.toAscList us) | (v, us) <- M.toAscList m ]-- r' :: G.Vertex -> v- r' i = case r i of (_, v, _) -> v-- topo :: [G.Vertex]- topo = G.topSort gr-- indices :: V.Vector v- indices = V.fromList (map r' topo)-- revIndices :: Map v Int- revIndices = M.fromList $ zip (map r' topo) [0..]-- edges :: V.Vector [Int]- edges = V.map- (\v -> maybe- []- (\sv -> sort $ mapMaybe (\v' -> M.lookup v' revIndices) $ S.toList sv)- (M.lookup v m))- indices-- -- TODO: let's see if this check is too expensive- loop :: Maybe [Int]- loop = getFirst $ foldMap (\a -> foldMap (check a) (gEdges g a)) (gVertices g)- where- check a b- | a < b = First Nothing- -- TODO: here we could use shortest path- | otherwise = First $ case allPaths g b a of- [] -> Nothing- (p : _) -> Just p-- g :: G v Int- g = G- { gVertices = [0 .. V.length indices - 1]- , gFromVertex = (indices V.!)- , gToVertex = (`M.lookup` revIndices)- , gDiff = \a b -> b - a- , gEdges = (edges V.!)- , gVerticeCount = V.length indices- , gToInt = id- }---- | Like 'runG' but returns 'Maybe'-runG'- :: forall v r. Ord v- => Map v (Set v) -- ^ Adjacency Map- -> (forall i. Ord i => G v i -> r) -- ^ function on linear indices- -> Maybe r -- ^ Return the result or 'Nothing' if there is a cycle.-runG' m f = either (const Nothing) Just (runG m f)------------------------------------------------------------------------------------ All paths------------------------------------------------------------------------------------ | All paths from @a@ to @b@. Note that every path has at least 2 elements, start and end.--- Use 'allPaths'' for the intermediate steps only.------ >>> runG example $ \g@G{..} -> fmap3 gFromVertex $ allPaths g <$> gToVertex 'a' <*> gToVertex 'e'--- Right (Just ["axde","axe","abde","ade","ae"])------ >>> runG example $ \g@G{..} -> fmap3 gFromVertex $ allPaths g <$> gToVertex 'a' <*> gToVertex 'a'--- Right (Just [])----allPaths :: forall v a. Ord a => G v a -> a -> a -> [[a]]-allPaths g a b = map (\p -> a : p) (allPaths' g a b [b])---- | 'allPaths' without begin and end elements.------ >>> runG example $ \g@G{..} -> fmap3 gFromVertex $ allPaths' g <$> gToVertex 'a' <*> gToVertex 'e' <*> pure []--- Right (Just ["xd","x","bd","d",""])----allPaths' :: forall v a. Ord a => G v a -> a -> a -> [a] -> [[a]]-allPaths' G {..} a b end = concatMap go (gEdges a) where- go :: a -> [[a]]- go i- | i == b = [end]- | otherwise =- let js :: [a]- js = filter (<= b) $ gEdges i-- js2b :: [[a]]- js2b = concatMap go js-- in map (i:) js2b------ | Like 'allPaths' but return a 'T.Tree'.------ >>> let t = runG example $ \g@G{..} -> fmap3 gFromVertex $ allPathsTree g <$> gToVertex 'a' <*> gToVertex 'e'--- >>> fmap3 (T.foldTree $ \a bs -> if null bs then [[a]] else concatMap (map (a:)) bs) t--- Right (Just (Just ["axde","axe","abde","ade","ae"]))------ >>> fmap3 (S.fromList . treePairs) t--- Right (Just (Just (fromList [('a','b'),('a','d'),('a','e'),('a','x'),('b','d'),('d','e'),('x','d'),('x','e')])))------ >>> let ls = runG example $ \g@G{..} -> fmap3 gFromVertex $ allPaths g <$> gToVertex 'a' <*> gToVertex 'e'--- >>> fmap2 (S.fromList . concatMap pairs) ls--- Right (Just (fromList [('a','b'),('a','d'),('a','e'),('a','x'),('b','d'),('d','e'),('x','d'),('x','e')]))------ >>> traverse3_ dispTree t--- 'a'--- 'x'--- 'd'--- 'e'--- 'e'--- 'b'--- 'd'--- 'e'--- 'd'--- 'e'--- 'e'------ >>> traverse3_ (putStrLn . T.drawTree . fmap show) t--- 'a'--- |--- +- 'x'--- | |--- | +- 'd'--- | | |--- | | `- 'e'--- | |--- | `- 'e'--- ...----allPathsTree :: forall v a. Ord a => G v a -> a -> a -> Maybe (T.Tree a)-allPathsTree G {..} a b = go a where- go :: a -> Maybe (T.Tree a)- go i- | i == b = Just (T.Node b [])- | otherwise = case mapMaybe go $ filter (<= b) $ gEdges i of- [] -> Nothing- js -> Just (T.Node i js)------------------------------------------------------------------------------------ DFS------------------------------------------------------------------------------------ | Depth-first paths starting at a vertex.------ >>> runG example $ \g@G{..} -> fmap3 gFromVertex $ dfs g <$> gToVertex 'x'--- Right (Just ["xde","xe"])----dfs :: forall v a. Ord a => G v a -> a -> [[a]]-dfs G {..} = go where- go :: a -> [[a]]- go a = case gEdges a of- [] -> [[a]]- bs -> concatMap (\b -> map (a :) (go b)) bs---- | like 'dfs' but returns a 'T.Tree'.------ >>> traverse2_ dispTree $ runG example $ \g@G{..} -> fmap2 gFromVertex $ dfsTree g <$> gToVertex 'x'--- 'x'--- 'd'--- 'e'--- 'e'-dfsTree :: forall v a. Ord a => G v a -> a -> T.Tree a-dfsTree G {..} = go where- go :: a -> Tree a- go a = case gEdges a of- [] -> T.Node a []- bs -> T.Node a $ map go bs------------------------------------------------------------------------------------ Longest / shortest path------------------------------------------------------------------------------------ | Longest paths lengths starting from a vertex.------ >>> runG example $ \g@G{..} -> longestPathLengths g <$> gToVertex 'a'--- Right (Just [0,1,1,2,3])------ >>> runG example $ \G {..} -> map gFromVertex gVertices--- Right "axbde"------ >>> runG example $ \g@G{..} -> longestPathLengths g <$> gToVertex 'b'--- Right (Just [0,0,0,1,2])----longestPathLengths :: Ord a => G v a -> a -> [Int]-longestPathLengths = pathLenghtsImpl max---- | Shortest paths lengths starting from a vertex.------ >>> runG example $ \g@G{..} -> shortestPathLengths g <$> gToVertex 'a'--- Right (Just [0,1,1,1,1])------ >>> runG example $ \g@G{..} -> shortestPathLengths g <$> gToVertex 'b'--- Right (Just [0,0,0,1,2])----shortestPathLengths :: Ord a => G v a -> a -> [Int]-shortestPathLengths = pathLenghtsImpl min' where- min' 0 y = y- min' x y = min x y--pathLenghtsImpl :: forall v a. Ord a => (Int -> Int -> Int) -> G v a -> a -> [Int]-pathLenghtsImpl merge G {..} a = runST $ do- v <- MU.replicate (length gVertices) (0 :: Int)- go v (S.singleton a)- v' <- U.freeze v- pure (U.toList v')- where- go :: MU.MVector s Int -> Set a -> ST s ()- go v xs = do- case S.minView xs of- Nothing -> pure ()- Just (x, xs') -> do- c <- MU.unsafeRead v (gToInt x)- let ys = S.fromList $ gEdges x- for_ ys $ \y ->- flip (MU.unsafeModify v) (gToInt y) $ \d -> merge d (c + 1)- go v (xs' `S.union` ys)------------------------------------------------------------------------------------ Transpose------------------------------------------------------------------------------------ | Graph with all edges reversed.------ >>> runG example $ adjacencyList . transpose--- Right [('a',""),('b',"a"),('d',"abx"),('e',"adx"),('x',"a")]------ === __Properties__------ Commutes with 'closure'------ >>> runG example $ adjacencyList . closure . transpose--- Right [('a',""),('b',"a"),('d',"abx"),('e',"abdx"),('x',"a")]------ >>> runG example $ adjacencyList . transpose . closure--- Right [('a',""),('b',"a"),('d',"abx"),('e',"abdx"),('x',"a")]------ Commutes with 'reduction'------ >>> runG example $ adjacencyList . reduction . transpose--- Right [('a',""),('b',"a"),('d',"bx"),('e',"d"),('x',"a")]------ >>> runG example $ adjacencyList . transpose . reduction--- Right [('a',""),('b',"a"),('d',"bx"),('e',"d"),('x',"a")]----transpose :: forall v a. Ord a => G v a -> G v (Down a)-transpose G {..} = G- { gVertices = map Down $ reverse gVertices- , gFromVertex = gFromVertex . getDown- , gToVertex = fmap Down . gToVertex- , gEdges = gEdges'- , gDiff = \(Down a) (Down b) -> gDiff b a- , gVerticeCount = gVerticeCount- , gToInt = \(Down a) -> gVerticeCount - gToInt a - 1- }- where- gEdges' :: Down a -> [Down a]- gEdges' (Down a) = es V.! gToInt a-- -- Note: in original order!- es :: V.Vector [Down a]- es = V.fromList $ map (map Down . revEdges) gVertices-- revEdges :: a -> [a]- revEdges x = concatMap (\y -> [y | x `elem` gEdges y ]) gVertices------------------------------------------------------------------------------------- Reduction------------------------------------------------------------------------------------ | Transitive reduction.------ Smallest graph,--- such that if there is a path from /u/ to /v/ in the original graph,--- then there is also such a path in the reduction.------ >>> runG example $ \g -> adjacencyList $ reduction g--- Right [('a',"bx"),('b',"d"),('d',"e"),('e',""),('x',"d")]------ Taking closure first doesn't matter:------ >>> runG example $ \g -> adjacencyList $ reduction $ closure g--- Right [('a',"bx"),('b',"d"),('d',"e"),('e',""),('x',"d")]----reduction :: Ord a => G v a -> G v a-reduction = transitiveImpl (== 1)------------------------------------------------------------------------------------ Closure------------------------------------------------------------------------------------ | Transitive closure.------ A graph,--- such that if there is a path from /u/ to /v/ in the original graph,--- then there is an edge from /u/ to /v/ in the closure.------ >>> runG example $ \g -> adjacencyList $ closure g--- Right [('a',"bdex"),('b',"de"),('d',"e"),('e',""),('x',"de")]------ Taking reduction first, doesn't matter:------ >>> runG example $ \g -> adjacencyList $ closure $ reduction g--- Right [('a',"bdex"),('b',"de"),('d',"e"),('e',""),('x',"de")]----closure :: Ord a => G v a -> G v a-closure = transitiveImpl (/= 0)--transitiveImpl :: forall v a. Ord a => (Int -> Bool) -> G v a -> G v a-transitiveImpl pred g@G {..} = g { gEdges = gEdges' } where- gEdges' :: a -> [a]- gEdges' a = es V.! gToInt a-- es :: V.Vector [a]- es = V.fromList $ map f gVertices where-- f :: a -> [a]- f x = catMaybes $ zipWith edge gVertices (longestPathLengths g x)-- edge y i | pred i = Just y- | otherwise = Nothing------------------------------------------------------------------------------------ Display------------------------------------------------------------------------------------ | Recover adjacency map representation from the 'G'.------ >>> runG example adjacencyMap--- Right (fromList [('a',fromList "bdex"),('b',fromList "d"),('d',fromList "e"),('e',fromList ""),('x',fromList "de")])-adjacencyMap :: Ord v => G v a -> Map v (Set v)-adjacencyMap G {..} = M.fromList $ map f gVertices where- f x = (gFromVertex x, S.fromList $ map gFromVertex $ gEdges x)---- | Adjacency list representation of 'G'.------ >>> runG example adjacencyList--- Right [('a',"bdex"),('b',"d"),('d',"e"),('e',""),('x',"de")]-adjacencyList :: Ord v => G v a -> [(v, [v])]-adjacencyList = flattenAM . adjacencyMap--flattenAM :: Map a (Set a) -> [(a, [a])]-flattenAM = map (fmap S.toList) . M.toList---- |------ >>> runG example $ \g@G{..} -> map (\(a,b) -> [gFromVertex a, gFromVertex b]) $ S.toList $ edgesSet g--- Right ["ax","ab","ad","ae","xd","xe","bd","de"]-edgesSet :: Ord a => G v a -> Set (a, a)-edgesSet G {..} = S.fromList- [ (x, y)- | x <- gVertices- , y <- gEdges x- ]------------------------------------------------------------------------------------ Utilities------------------------------------------------------------------------------------ | Like 'pairs' but for 'T.Tree'.-treePairs :: Tree a -> [(a,a)]-treePairs (T.Node i js) =- [ (i, j) | T.Node j _ <- js ] ++ concatMap treePairs js---- | Consequtive pairs.------ >>> pairs [1..10]--- [(1,2),(2,3),(3,4),(4,5),(5,6),(6,7),(7,8),(8,9),(9,10)]------ >>> pairs []--- []----pairs :: [a] -> [(a, a)]-pairs [] = []-pairs xs = zip xs (tail xs)---- | Unwrap 'Down'.-getDown :: Down a -> a-getDown (Down a) = a------------------------------------------------------------------------------------ Setup------------------------------------------------------------------------------------ $setup------ Graph used in examples (with all arrows pointing down)------ @--- a -------- / | \\ \\--- b | x \\--- \\ | / \\ |--- d \\ |--- ------- e--- @------ See <https://en.wikipedia.org/wiki/Transitive_reduction> for a picture.------ >>> let example :: Map Char (Set Char); example = M.map S.fromList $ M.fromList [('a', "bxde"), ('b', "d"), ('x', "de"), ('d', "e"), ('e', "")]------ >>> :set -XRecordWildCards--- >>> import Data.Monoid (All (..))--- >>> import Data.Foldable (traverse_)------ >>> let fmap2 = fmap . fmap--- >>> let fmap3 = fmap . fmap2--- >>> let traverse2_ = traverse_ . traverse_--- >>> let traverse3_ = traverse_ . traverse2_------ >>> let dispTree :: Show a => Tree a -> IO (); dispTree = go 0 where go i (T.Node x xs) = putStrLn (replicate (i * 2) ' ' ++ show x) >> traverse_ (go (succ i)) xs
src/Cabal/Plan.hs view
@@ -70,6 +70,7 @@ import qualified Data.Version as DV import qualified System.Directory as Dir import System.FilePath+ ((</>), takeExtension, isDrive, takeDirectory) import Text.ParserCombinators.ReadP ----------------------------------------------------------------------------@@ -365,7 +366,7 @@ pure pim (.:?!) :: (FromJSON a, Monoid a) => Object -> Text -> Parser a-o .:?! fld = o .:? fld .!= mempty+o .:?! fld = o .:? fld .!= Data.Monoid.mempty planItemAllDeps :: Unit -> Set UnitId planItemAllDeps Unit{..} = mconcat [ ciLibDeps <> ciExeDeps | CompInfo{..} <- M.elems uComps ]@@ -413,6 +414,7 @@ -- plan.json there. | InBuildDir FilePath -- ^ Look for plan.json in specified build -- directory.+ | ExactPath FilePath -- ^ Exact location of plan.json deriving (Eq, Show, Read) -- | Locates the project root for cabal project relative to specified@@ -437,20 +439,14 @@ :: SearchPlanJson -> IO PlanJson findAndDecodePlanJson searchLoc = do- distFolder <- case searchLoc of- InBuildDir builddir -> pure builddir+ planJsonFn <- case searchLoc of+ ExactPath fp -> pure fp+ InBuildDir builddir -> fromBuilddir builddir ProjectRelativeToDir fp -> do mRoot <- findProjectRoot fp case mRoot of Nothing -> fail ("missing project root relative to: " ++ fp)- Just dir -> pure $ dir </> "dist-newstyle"-- haveDistFolder <- Dir.doesDirectoryExist distFolder-- unless haveDistFolder $- fail ("missing " ++ show distFolder ++ " folder; do you need to run 'cabal new-build'?")-- let planJsonFn = distFolder </> "cache" </> "plan.json"+ Just dir -> fromBuilddir$ dir </> "dist-newstyle" havePlanJson <- Dir.doesFileExist planJsonFn @@ -458,6 +454,15 @@ fail "missing 'plan.json' file; do you need to run 'cabal new-build'?" decodePlanJson planJsonFn+ where+ fromBuilddir distFolder = do+ haveDistFolder <- Dir.doesDirectoryExist distFolder++ unless haveDistFolder $+ fail ("missing " ++ show distFolder ++ " folder; do you need to run 'cabal new-build'?")++ return $ distFolder </> "cache" </> "plan.json"+ -- | Decodes @plan.json@ file location provided as 'FilePath' --