diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/cabal-plan.cabal b/cabal-plan.cabal --- a/cabal-plan.cabal +++ b/cabal-plan.cabal @@ -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 diff --git a/src-exe/Flag.hs b/src-exe/Flag.hs new file mode 100644 --- /dev/null +++ b/src-exe/Flag.hs @@ -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 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,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' diff --git a/src-topograph/LICENSE b/src-topograph/LICENSE deleted file mode 100644 --- a/src-topograph/LICENSE +++ /dev/null @@ -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. diff --git a/src-topograph/Topograph.hs b/src-topograph/Topograph.hs deleted file mode 100644 --- a/src-topograph/Topograph.hs +++ /dev/null @@ -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 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 diff --git a/src/Cabal/Plan.hs b/src/Cabal/Plan.hs --- a/src/Cabal/Plan.hs +++ b/src/Cabal/Plan.hs @@ -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' --