diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,16 +1,37 @@ # Revision history for `cabal-plan` +## 0.3.0.0 + +### `lib:cabal-plan` Library + +* Add support for foreign-lib components. +* Add support for `dist-dir` `plan.json` field. +* Make `Sha256` type abstract and add new `sha256{To,From}ByteString` + conversion functions, as well as the new `parseSha256` function. +* Introduce `FlagName` newtype. +* Add `FromJSONKey`/`ToJSONKey` instances for `UnitId`, `PackageName`, and `PkgId`. + +### `exe:cabal-plan` Executable + +* smart completer for list-bin/list-bins pattern +* new command `topo` (printing out topographic sorting of install-plan) +* `dot` prints component dependency graph. New options: + - `--tred` transitive reduction + - `--tred-weights` Adjust edge thickness during transitive reduction + - `--path-from pkgA --path-from pkgB` Highlight dependency paths from *pkgA* to *pkgB* + - `--revdep pkg` highlight reverse dependencies of pkg in the install plan + ## 0.2.0.0 -* Add an optional `--builddir` argument to all commands and to `findAndDecodePlanJson` function -* Add experimental support for underlining -* Reimplement CLI with `optparse-applicative` -* Add new sub-command `list-bins` and change semantics of existing `list-bin` sub-cmd +* Add an optional `--builddir` argument to all commands and to `findAndDecodePlanJson` function. +* Add experimental support for underlining. +* Reimplement CLI with `optparse-applicative`. +* Add new sub-command `list-bins` and change semantics of existing `list-bin` sub-cmd. -## 0.1.1.0 +### 0.1.1.0 * Add `cabal-plan fingerprint` command for printing - sha256 sums of source tarballs + sha256 sums of source tarballs. ## 0.1.0.0 diff --git a/cabal-plan.cabal b/cabal-plan.cabal --- a/cabal-plan.cabal +++ b/cabal-plan.cabal @@ -1,15 +1,8 @@ cabal-version: 2.0 name: cabal-plan -version: 0.2.0.0 +version: 0.3.0.0 + synopsis: Library and utiltity for processing cabal's plan.json file -homepage: https://github.com/hvr/cabal-plan -license: GPL-3 -license-file: LICENSE -author: Herbert Valerio Riedel -maintainer: hvr@gnu.org -copyright: 2016 Herbert Valerio Riedel -category: Development -build-type: Simple description: { This package provides a library for decoding @plan.json@ files as well as the simple tool @cabal-plan@ for extracting and pretty printing @@ -18,8 +11,14 @@ @plan.json@ files are generated by [cabal](https://hackage.haskell.org/package/cabal-install)'s [nix-style local builds](http://cabal.readthedocs.io/en/latest/nix-local-build.html) and contain detailed information about the build/install plan computed by the cabal solver. } -extra-source-files: - ChangeLog.md +bug-reports: https://github.com/hvr/cabal-plan/issues +license: GPL-3 +license-files: LICENSE src-topograph/LICENSE +author: Herbert Valerio Riedel +maintainer: hvr@gnu.org +copyright: 2016 Herbert Valerio Riedel +category: Development +build-type: Simple tested-with: GHC==8.2.1, @@ -28,6 +27,11 @@ GHC==7.8.4, GHC==7.6.3 +extra-source-files: + ChangeLog.md + +---------------------------------------------------------------------------- + flag exe -- this automatic flag allows the cabal solver to disable the exe:cabal-plan component (& its build-deps); -- IOW, emulate https://github.com/haskell/cabal/issues/4660 @@ -58,16 +62,30 @@ 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 + , base-compat ^>= 0.9.3 + , base-orphans ^>= 0.6 + , containers ^>= 0.5.0 + , vector ^>= 0.12.0.1 + + hs-source-dirs: src-topograph + executable cabal-plan default-language: Haskell2010 other-extensions: RecordWildCards main-is: src-exe/cabal-plan.hs + other-modules: Paths_cabal_plan if flag(exe) -- dependencies w/ inherited version ranges via 'cabal-plan' library build-depends: cabal-plan + , topograph , base , text , containers @@ -76,7 +94,15 @@ -- dependencies which require version bounds build-depends: mtl ^>= 2.2.1 , ansi-terminal ^>= 0.6.2 + , base-compat ^>= 0.9.3 , optparse-applicative ^>= 0.13.0 || ^>= 0.14.0 + , parsec ^>= 3.1.11 + , vector ^>= 0.12.0.1 + + + if !impl(ghc >= 8.0) + build-depends: + semigroups ^>= 0.18.3 if flag(_) cpp-options: -DUNDERLINE_SUPPORT 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,29 +1,45 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Main where -import Control.Monad -import Control.Monad.RWS.Strict -import Data.Foldable (asum) -import qualified Data.Graph as G -import Data.List (isPrefixOf, isInfixOf, isSuffixOf) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S -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 Prelude () +import Prelude.Compat + +import Control.Monad.Compat (guard, unless, when) +import Control.Monad.RWS.Strict (RWS, evalRWS, gets, modify', tell) +import Control.Monad.ST (runST) +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.Semigroup (Semigroup (..)) +import Data.Set (Set) +import qualified Data.Set as S +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 qualified Data.Tree as Tr +import Data.Tuple (swap) +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MU +import Data.Version import Options.Applicative import System.Console.ANSI -import System.Exit (exitFailure) -import System.IO (hPutStrLn, stderr) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import qualified Text.Parsec as P +import qualified Text.Parsec.String as P +import qualified Topograph as TG import Cabal.Plan +import Paths_cabal_plan (version) haveUnderlineSupport :: Bool #if defined(UNDERLINE_SUPPORT) @@ -33,25 +49,199 @@ #endif data GlobalOptions = GlobalOptions - { buildDir :: Maybe FilePath - , cmd :: Command - } + { buildDir :: Maybe FilePath + , optsShowBuiltin :: Bool + , optsShowGlobal :: Bool + , cmd :: Command + } data Command - = InfoCommand | ShowCommand | FingerprintCommand - | ListBinsCommand MatchCount MatchPref [Pattern] + = InfoCommand + | ShowCommand + | FingerprintCommand + | ListBinsCommand MatchCount [Pattern] + | DotCommand Bool Bool [Highlight] + | TopoCommand Bool +------------------------------------------------------------------------------- +-- Pattern +------------------------------------------------------------------------------- + +-- | patterns are @[[pkg:]kind;]cname@ +data Pattern = Pattern (Maybe T.Text) (Maybe CompType) (Maybe T.Text) + deriving (Show, Eq) + +data CompType = CompTypeLib | CompTypeFLib | CompTypeExe | CompTypeTest | CompTypeBench | CompTypeSetup + deriving (Show, Eq, Enum, Bounded) + +parsePattern :: String -> Either String Pattern +parsePattern = either (Left . show) Right . P.runParser (patternP <* P.eof) () "" + where + patternP = do + -- first we parse up to 3 tokens + x <- tokenP + y <- optional $ do + _ <- P.char ':' + y <- tokenP + z <- optional $ P.char ':' >> tokenP + return (y, z) + -- then depending on how many tokens we got, we make a pattern + case y of + Nothing -> return $ Pattern Nothing Nothing x + Just (y', Nothing) -> do + t <- traverse toCompType x + return $ Pattern Nothing t y' + Just (y', Just z') -> do + t <- traverse toCompType y' + return $ Pattern x t z' + + tokenP :: P.Parser (Maybe T.Text) + tokenP = + Nothing <$ P.string "*" + <|> (Just . T.pack <$> some (P.satisfy (\c -> isAlphaNum c || c `elem` ("-_" :: String))) P. "part of pattern") + + toCompType :: T.Text -> P.Parser CompType + toCompType "bench" = return $ CompTypeBench + toCompType "exe" = return $ CompTypeExe + toCompType "lib" = return $ CompTypeLib + toCompType "flib" = return $ CompTypeFLib + toCompType "setup" = return $ CompTypeSetup + toCompType "test" = return $ CompTypeTest + toCompType t = fail $ "Unknown component type: " ++ show t + +patternCompleter :: Bool -> Completer +patternCompleter onlyWithExes = mkCompleter $ \pfx -> do + (plan, _) <- findAndDecodePlanJson Nothing + let tpfx = T.pack pfx + components = findComponents plan + + -- One scenario + -- $ cabal-plan list-bin cab + -- $ cabal-plan list-bin cabal-plan + -- $ cabal-plan list-bin cabal-plan:exe:cabal-plan + -- + -- Note: if this package had `tests` -suite, then we can + -- $ cabal-plan list-bin te + -- $ cabal-plan list-bin tests + -- $ cabal-plan list-bin cabal-plan:test:tests + -- + -- *BUT* at least zsh script have to be changed to complete from non-prefix. + return $ map T.unpack $ firstNonEmpty + -- 1. if tpfx matches component exacty, return full path + [ single $ map fst $ filter ((tpfx ==) . snd) components + + -- 2. match component parts + , uniques $ filter (T.isPrefixOf tpfx) $ map snd components + + -- otherwise match full paths + , filter (T.isPrefixOf tpfx) $ map fst components + ] + where + firstNonEmpty :: [[a]] -> [a] + firstNonEmpty [] = [] + firstNonEmpty ([] : xss) = firstNonEmpty xss + firstNonEmpty (xs : _) = xs + + -- single + single :: [a] -> [a] + single xs@[_] = xs + single _ = [] + + -- somewhat like 'nub' but drop duplicate names. Doesn't preserve order + uniques :: Ord a => [a] -> [a] + uniques = M.keys . M.filter (== 1) . M.fromListWith (+) . map (\x -> (x, 1 :: Int)) + + impl :: Bool -> Bool -> Bool + impl False _ = True + impl True x = x + + -- returns (full, cname) pair + findComponents :: PlanJson -> [(T.Text, T.Text)] + findComponents plan = do + (_, Unit{..}) <- M.toList $ pjUnits plan + (cn, ci) <- M.toList $ uComps + + -- if onlyWithExes, component should have binFile + guard (onlyWithExes `impl` isJust (ciBinFile ci)) + + let PkgId pn@(PkgName pnT) _ = uPId + g = case cn of + CompNameLib -> pnT <> T.pack":lib:" <> pnT + _ -> pnT <> T.pack":" <> dispCompName cn + + let cnT = extractCompName pn cn + [ (g, cnT) ] + +compNameType :: CompName -> CompType +compNameType CompNameLib = CompTypeLib +compNameType (CompNameSubLib _) = CompTypeLib +compNameType (CompNameFLib _) = CompTypeFLib +compNameType (CompNameExe _) = CompTypeExe +compNameType (CompNameTest _) = CompTypeTest +compNameType (CompNameBench _) = CompTypeBench +compNameType CompNameSetup = CompTypeSetup + +checkPattern :: Pattern -> PkgName -> CompName -> Any +checkPattern (Pattern n k c) pn cn = + Any $ nCheck && kCheck && cCheck + where + nCheck = case n of + Nothing -> True + Just pn' -> pn == PkgName pn' + + kCheck = case k of + Nothing -> True + Just k' -> k' == compNameType cn + cCheck = case c of + Nothing -> True + Just c' -> c' == extractCompName pn cn + +extractCompName :: PkgName -> CompName -> T.Text +extractCompName (PkgName pn) CompNameLib = pn +extractCompName (PkgName pn) CompNameSetup = pn +extractCompName _ (CompNameSubLib cn) = cn +extractCompName _ (CompNameFLib cn) = cn +extractCompName _ (CompNameExe cn) = cn +extractCompName _ (CompNameTest cn) = cn +extractCompName _ (CompNameBench cn) = cn + +------------------------------------------------------------------------------- +-- Highlight +------------------------------------------------------------------------------- + +data Highlight + = Path Pattern Pattern + | Revdep Pattern + deriving (Show, Eq) + +highlightParser :: Parser Highlight +highlightParser = pathParser <|> revdepParser + where + pathParser = Path + <$> option (eitherReader parsePattern) + (long "path-from" <> metavar "PATTERN" <> help "Highlight dependency paths from ...") + <*> option (eitherReader parsePattern) + (long "path-to" <> metavar "PATTERN") + + revdepParser = Revdep + <$> option (eitherReader parsePattern) + (long "revdep" <> metavar "PATTERN" <> help "Highlight reverse dependencies") + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + main :: IO () main = do - GlobalOptions{..} <- execParser $ info (optParser <**> helper) fullDesc + GlobalOptions{..} <- execParser $ info (helper <*> optVersion <*> optParser) fullDesc val@(plan, _) <- findAndDecodePlanJson buildDir case cmd of InfoCommand -> doInfo val ShowCommand -> print val - ListBinsCommand count pref pats -> do - let bins = doListBin plan pref pats + ListBinsCommand count pats -> do + let bins = doListBin plan pats case (count, bins) of - (MatchMany, _) -> forM_ bins $ \(g, fn) -> + (MatchMany, _) -> for_ bins $ \(g, fn) -> putStrLn (g ++ " " ++ fn) (MatchOne, [(_,p)]) -> putStrLn p (MatchOne, []) -> do @@ -59,100 +249,102 @@ exitFailure (MatchOne, _) -> do hPutStrLn stderr "Found more than one matching pattern:" - forM_ bins $ \(p,_) -> hPutStrLn stderr $ " " ++ p + for_ bins $ \(p,_) -> hPutStrLn stderr $ " " ++ p exitFailure FingerprintCommand -> doFingerprint plan + DotCommand tred tredWeights highlights -> doDot optsShowBuiltin optsShowGlobal plan tred tredWeights highlights + TopoCommand rev -> doTopo optsShowBuiltin optsShowGlobal plan rev where - optParser = GlobalOptions <$> dirParser <*> (cmdParser <|> defaultCommand) + 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" + <*> (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) - patternParser = argument (Pattern <$> str) . mconcat + patternParser = argument (eitherReader parsePattern) . mconcat + switchM = switch . mconcat + cmdParser = subparser $ mconcat [ subCommand "info" "Info" $ pure InfoCommand , subCommand "show" "Show" $ pure ShowCommand , subCommand "list-bins" "List All Binaries" . listBinParser MatchMany . many $ patternParser - [ metavar "PATTERNS...", help "Patterns to match." ] + [ metavar "PATTERNS...", help "Patterns to match.", completer $ patternCompleter True ] , subCommand "list-bin" "List Single Binary" . listBinParser MatchOne $ pure <$> patternParser - [ metavar "PATTERN", help "Pattern to match." ] + [ metavar "PATTERN", help "Pattern to match.", completer $ patternCompleter True ] , subCommand "fingerprint" "Fingerprint" $ pure FingerprintCommand + , 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 + , subCommand "topo" "Plan in a topological sort" $ TopoCommand + <$> switchM + [ long "reverse", help "Reverse order" ] + <**> helper ] - defaultCommand = pure InfoCommand -data Pattern = Pattern String - deriving (Show, Eq) - -data MatchCount = MatchOne | MatchMany - deriving (Show, Eq) + defaultCommand = pure InfoCommand -data MatchPref = Prefix | Infix | Suffix | Exact - deriving (Show, Eq) +------------------------------------------------------------------------------- +-- list-bin +------------------------------------------------------------------------------- listBinParser :: MatchCount -> Parser [Pattern] -> Parser Command listBinParser count pats - = ListBinsCommand count <$> matchPrefParser <*> pats <**> helper - where - matchPrefParser :: Parser MatchPref - matchPrefParser = asum [exact, prefix, infix_, suffix, pure Exact ] - - exact :: Parser MatchPref - exact = flag' Exact $ mconcat - [ long "exact" , help "Use exact match for pattern." ] - - prefix :: Parser MatchPref - prefix = flag' Prefix $ mconcat - [ long "prefix" , help "Use prefix match for pattern." ] - - infix_ :: Parser MatchPref - infix_ = flag' Infix $ mconcat - [ long "infix" , help "Use infix match for pattern." ] - - suffix :: Parser MatchPref - suffix = flag' Suffix $ mconcat - [ long "suffix" , help "Use suffix match for pattern." ] - -checkPattern :: MatchPref -> Pattern -> String -> Any -checkPattern pref (Pattern p) s = Any $ compareFun p s - where - compareFun = case pref of - Prefix -> isPrefixOf - Infix -> isInfixOf - Suffix -> isSuffixOf - Exact -> (==) + = ListBinsCommand count <$> pats <**> helper +data MatchCount = MatchOne | MatchMany + deriving (Show, Eq) -doListBin :: PlanJson -> MatchPref -> [Pattern] -> [(String, FilePath)] -doListBin plan pref patterns = do +doListBin :: PlanJson -> [Pattern] -> [(String, FilePath)] +doListBin plan patterns = do (_, Unit{..}) <- M.toList $ pjUnits plan (cn, ci) <- M.toList $ uComps case ciBinFile ci of Nothing -> [] Just fn -> do - let PkgId (PkgName pn) _ = uPId + let PkgId pn@(PkgName pnT) _ = uPId g = case cn of - CompNameLib -> T.unpack (pn <> T.pack":lib:" <> pn) - _ -> T.unpack (pn <> T.pack":" <> dispCompName cn) - guard . getAny $ patternChecker g + CompNameLib -> T.unpack (pnT <> T.pack":lib:" <> pnT) + _ -> T.unpack (pnT <> T.pack":" <> dispCompName cn) + guard . getAny $ patternChecker pn cn [(g, fn)] where - patternChecker :: String -> Any + patternChecker :: PkgName -> CompName -> Any patternChecker = case patterns of - [] -> const $ Any True - _ -> mconcat $ map (checkPattern pref) patterns + [] -> \_ _ -> Any True + _ -> mconcat $ map checkPattern patterns +------------------------------------------------------------------------------- +-- fingerprint +------------------------------------------------------------------------------- + doFingerprint :: PlanJson -> IO () doFingerprint plan = do let pids = M.fromList [ (uPId u, u) | (_,u) <- M.toList (pjUnits plan) ] - forM_ (M.toList pids) $ \(_,Unit{..}) -> do + for_ (M.toList pids) $ \(_,Unit{..}) -> do let h = maybe "________________________________________________________________" dispSha256 $ uSha256 case uType of @@ -161,6 +353,10 @@ UnitTypeLocal -> T.putStrLn (h <> " L " <> dispPkgId uPId) UnitTypeInplace -> T.putStrLn (h <> " I " <> dispPkgId uPId) +------------------------------------------------------------------------------- +-- info +------------------------------------------------------------------------------- + doInfo :: (PlanJson, FilePath) -> IO () doInfo (plan,projbase) = do putStrLn ("using '" ++ projbase ++ "' as project root") @@ -178,7 +374,7 @@ putStrLn "" let xs = toposort (planJsonIdGraph plan) - forM_ xs print + for_ xs print putStrLn "" putStrLn "Direct deps" @@ -188,11 +384,11 @@ let locals = [ Unit{..} | Unit{..} <- M.elems pm, uType == UnitTypeLocal ] pm = pjUnits plan - forM_ locals $ \pitem -> do + for_ locals $ \pitem -> do print (uPId pitem) - forM_ (M.toList $ uComps pitem) $ \(ct,ci) -> do + for_ (M.toList $ uComps pitem) $ \(ct,ci) -> do print ct - forM_ (S.toList $ ciLibDeps ci) $ \dep -> do + for_ (S.toList $ ciLibDeps ci) $ \dep -> do let Just dep' = M.lookup dep pm pid = uPId dep' putStrLn (" " ++ T.unpack (dispPkgId pid)) @@ -200,7 +396,305 @@ return () +------------------------------------------------------------------------------- +-- Dot +------------------------------------------------------------------------------- +-- | vertex of dot graph. +-- +-- if @'Maybe' 'CompName'@ is Nothing, this is legacy, multi-component unit. +data DotUnitId = DU UnitId (Maybe CompName) + deriving (Eq, Ord, Show) + +planJsonDotUnitGraph :: PlanJson -> Map DotUnitId (Set DotUnitId) +planJsonDotUnitGraph plan = M.fromList $ do + unit <- M.elems units + let mkDU = DU (uId unit) + let mkDeps cname ci = (mkDU (Just cname), deps ci) + case M.toList (uComps unit) of + [(cname, ci)] -> + [ mkDeps cname ci ] + cs -> + [ (mkDU Nothing, S.fromList $ map (mkDU . Just . fst) cs) ] + ++ map (uncurry mkDeps) cs + where + units = pjUnits plan + + unitToDot :: Unit -> DotUnitId + unitToDot unit = DU (uId unit) $ case M.toList (uComps unit) of + [(cname, _)] -> Just cname + _ -> Nothing + + unitIdToDot :: UnitId -> Maybe DotUnitId + unitIdToDot i = unitToDot <$> M.lookup i units + + deps :: CompInfo -> Set DotUnitId + deps CompInfo{..} = + S.fromList $ mapMaybe unitIdToDot $ S.toList $ ciLibDeps <> ciExeDeps + +-- | Tree which counts paths under it. +data Tr a = No !Int a [Tr a] + deriving (Show) + +trPaths :: Tr a -> Int +trPaths (No n _ _) = n + +-- | Create 'Tr' maintaining the invariant +mkNo :: a -> [Tr a] -> Tr a +mkNo x [] = No 1 x [] +mkNo x xs = No (sum $ map trPaths xs) x xs + +trFromTree :: Tr.Tree a -> Tr a +trFromTree (Tr.Node i is) = mkNo i (map trFromTree is) + +trPairs :: Tr a -> [(Int,a,a)] +trPairs (No _ i js) = + [ (n, i, j) | No n j _ <- js ] ++ concatMap trPairs js + +doDot :: Bool -> Bool -> PlanJson -> Bool -> Bool -> [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' + + -- Highlights + let paths :: [(DotUnitId, DotUnitId)] + paths = flip concatMap highlights $ \h -> case h of + Path a b -> + [ (x, y) + | x <- filter (getAny . checkPatternDotUnit a) $ toList dotUnits + , y <- filter (getAny . checkPatternDotUnit b) $ toList dotUnits + ] + Revdep _ -> [] + + let paths' :: [(DotUnitId, DotUnitId)] + paths' = flip concatMap paths $ \(a, b) -> fromMaybe [] $ do + i <- TG.gToVertex g a + j <- TG.gToVertex g b + pure $ concatMap TG.pairs $ (fmap . fmap) (TG.gFromVertex g) (TG.allPaths g i j) + + let revdeps :: [DotUnitId] + revdeps = flip concatMap highlights $ \h -> case h of + Path _ _ -> [] + Revdep a -> filter (getAny . checkPatternDotUnit a) $ toList dotUnits + + let tg = TG.transpose g + + let revdeps' :: [(DotUnitId, DotUnitId)] + revdeps' = flip concatMap revdeps $ \a -> fromMaybe [] $ do + i <- TG.gToVertex tg a + pure $ map swap $ TG.treePairs $ fmap (TG.gFromVertex tg) (TG.dfsTree tg i) + + let redVertices :: Set DotUnitId + redVertices = foldMap (\(a,b) -> S.fromList [a,b]) $ paths' ++ revdeps' + + let redEdges :: Set (DotUnitId, DotUnitId) + redEdges = S.fromList $ paths' ++ revdeps' + + -- Edge weights + let weights' :: U.Vector Double + weights' = runST $ do + let orig = TG.edgesSet g' + redu = TG.edgesSet g + len = TG.gVerticeCount g + v <- MU.replicate (len * len) (0 :: Double) + + -- for each edge (i, j) in original graph, but not in the reduction + for_ (S.difference orig redu) $ \(i, j) -> do + -- calculate all paths from i to j, in the reduction + for_ (fmap trFromTree $ TG.allPathsTree g i j) $ \ps -> do + -- divide weight across paths + let r = 1 / fromIntegral (trPaths ps) + + -- and add that weight to every edge on each path + for_ (trPairs ps) $ \(k, a, b) -> + MU.modify v + (\n -> n + fromIntegral k * r) + (TG.gToInt g b + TG.gToInt g a * len) + + U.freeze v + + let weights :: Map (DotUnitId, DotUnitId) Double + weights = + if tred && tredWeights + then M.fromList + [ ((a, b), w + 1) + | ((i, j), w) <- zip ((,) <$> TG.gVertices g <*> TG.gVertices g) (U.toList weights') + , w > 0 + , let a = TG.gFromVertex g i + , let b = TG.gFromVertex g j + ] + else M.empty + + -- Beging outputting + + putStrLn "digraph plan {" + putStrLn "overlap = false;" + putStrLn "rankdir=LR;" + putStrLn "node [penwidth=2];" + + -- vertices + for_ (TG.gVertices g) $ \i -> vertex redVertices (TG.gFromVertex g i) + + -- edges + for_ (TG.gVertices g) $ \i -> for_ (TG.gEdges g i) $ \j -> + edge weights redEdges (TG.gFromVertex g i) (TG.gFromVertex g j) + + putStrLn "}" + where + loopGraph [] = putStrLn "digraph plan {}" + loopGraph (u : us) = do + putStrLn "digraph plan {" + for_ (zip (u : us) (us ++ [u])) $ \(unitA, unitB) -> + T.putStrLn $ mconcat + [ "\"" + , dispDotUnit unitA + , "\"" + , " -> " + , "\"" + , dispDotUnit unitB + , "\"" + ] + putStrLn "}" + + am = planJsonDotUnitGraph plan + + dotUnits :: Set DotUnitId + dotUnits = S.fromList $ M.keys am + + units :: Map UnitId Unit + units = pjUnits plan + + duShape :: DotUnitId -> T.Text + duShape (DU unitId _) = case M.lookup unitId units of + Nothing -> "oval" + Just unit -> case uType unit of + UnitTypeBuiltin -> "octagon" + UnitTypeGlobal -> "box" + UnitTypeInplace -> "box" + UnitTypeLocal -> "box,style=rounded" + + duShow :: DotUnitId -> Bool + duShow (DU unitId _) = case M.lookup unitId units of + Nothing -> False + Just unit -> case uType unit of + UnitTypeBuiltin -> showBuiltin + UnitTypeGlobal -> showGlobal + UnitTypeLocal -> True + UnitTypeInplace -> True + + vertex :: Set DotUnitId -> DotUnitId -> IO () + vertex redVertices du = when (duShow du) $ T.putStrLn $ mconcat + [ "\"" + , dispDotUnit du + , "\"" + -- shape + , " [shape=" + , duShape du + -- color + , ",color=" + , color + , "];" + ] + where + color | S.member du redVertices = "red" + | otherwise = borderColor du + + borderColor :: DotUnitId -> T.Text + borderColor (DU _ Nothing) = "darkviolet" + borderColor (DU unitId (Just cname)) = case cname of + CompNameLib -> case M.lookup unitId units of + Nothing -> "black" + Just unit -> case uType unit of + UnitTypeLocal -> "blue" + UnitTypeInplace -> "blue" + _ -> "black" + (CompNameSubLib _) -> "gray" + (CompNameFLib _) -> "darkred" + (CompNameExe _) -> "brown" + (CompNameBench _) -> "darkorange" + (CompNameTest _) -> "darkgreen" + CompNameSetup -> "gold" + + edge + :: Map (DotUnitId, DotUnitId) Double + -> Set (DotUnitId, DotUnitId) + -> DotUnitId -> DotUnitId -> IO () + edge weights redEdges duA duB = when (duShow duA) $ when (duShow duB) $ + T.putStrLn $ mconcat + [ "\"" + , dispDotUnit duA + , "\"" + , " -> " + , "\"" + , dispDotUnit duB + , "\" [color=" + , color + , ",penwidth=" + , T.pack $ show $ logBase 4 w + 1 + , ",weight=" + , T.pack $ show $ logBase 4 w + 1 + , "];" + ] + where + idPair = (duA, duB) + + color | S.member idPair redEdges = "red" + | otherwise = borderColor duA + + w = fromMaybe 1 $ M.lookup idPair weights + + checkPatternDotUnit :: Pattern -> DotUnitId -> Any + checkPatternDotUnit p (DU unitId mcname) = case M.lookup unitId units of + Nothing -> Any False + Just unit -> case mcname of + Just cname -> checkPattern p pname cname + Nothing -> foldMap (checkPattern p pname) (M.keys (uComps unit)) + where + PkgId pname _ = uPId unit + + dispDotUnit :: DotUnitId -> T.Text + dispDotUnit (DU unitId mcname) = case M.lookup unitId units of + Nothing -> "?" + Just unit -> dispPkgId (uPId unit) <> maybe ":*" dispCompName' mcname + + dispCompName' :: CompName -> T.Text + dispCompName' CompNameLib = "" + dispCompName' cname = ":" <> dispCompName cname + +------------------------------------------------------------------------------- +-- topo +------------------------------------------------------------------------------- + +doTopo :: Bool -> Bool -> PlanJson -> Bool -> IO () +doTopo showBuiltin showGlobal plan rev = 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 + UnitTypeLocal -> True + UnitTypeInplace -> True + + let rev' = if rev then reverse else id + + for_ topo $ \topo' -> for_ (rev' topo') $ \unitId -> + for_ (M.lookup unitId units) $ \unit -> + when (showUnit unit) $ do + let colour = case uType unit of + UnitTypeBuiltin -> Blue + UnitTypeGlobal -> White + UnitTypeLocal -> Green + UnitTypeInplace -> Red + let components = case M.keys (uComps unit) of + [] -> "" + [CompNameLib] -> "" + names -> " " <> T.intercalate " " (map dispCompName names) + putStrLn $ + colorify colour (T.unpack $ dispPkgId $ uPId unit) + ++ T.unpack components + ---------------------------------------------------------------------------- dumpPlanJson :: PlanJson -> LT.Text @@ -235,10 +729,10 @@ preExists = uType x' == UnitTypeBuiltin - showDeps = forM_ (M.toList $ uComps x') $ \(ct,deps) -> do + showDeps = for_ (M.toList $ uComps x') $ \(ct,deps) -> do unless (ct == CompNameLib) $ tell (LT.fromString $ linepfx' ++ " " ++ prettyCompTy (lupPid pid) ct ++ "\n") - forM_ (lastAnn $ S.toList (ciLibDeps deps)) $ \(l,y) -> do + for_ (lastAnn $ S.toList (ciLibDeps deps)) $ \(l,y) -> do go2 (lvl ++ [(ct, not l)]) y @@ -265,6 +759,7 @@ prettyCompTy pid c@(CompNameTest n) = ccol c $ "[" ++ prettyPid pid ++ ":test:" ++ show n ++ "]" prettyCompTy pid c@(CompNameBench n) = ccol c $ "[" ++ prettyPid pid ++ ":bench:" ++ show n ++ "]" prettyCompTy pid c@(CompNameSubLib n) = ccol c $ "[" ++ prettyPid pid ++ ":lib:" ++ show n ++ "]" + prettyCompTy pid c@(CompNameFLib n) = ccol c $ "[" ++ prettyPid pid ++ ":flib:" ++ show n ++ "]" ccol CompNameLib = colorify White ccol (CompNameExe _) = colorify Green @@ -272,6 +767,7 @@ 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] @@ -292,12 +788,10 @@ unsnoc [] = Nothing unsnoc xs = Just (init xs, last xs) - toposort :: Ord a => Map a (Set a) -> [a] toposort m = reverse . map f . G.topSort $ g where (g, f) = graphFromMap m - graphFromMap :: Ord a => Map a (Set a) -> (G.Graph, G.Vertex -> a) graphFromMap m = (g, v2k') diff --git a/src-topograph/LICENSE b/src-topograph/LICENSE new file mode 100644 --- /dev/null +++ b/src-topograph/LICENSE @@ -0,0 +1,30 @@ +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 new file mode 100644 --- /dev/null +++ b/src-topograph/Topograph.hs @@ -0,0 +1,528 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, RecordWildCards #-} +-- | Tools to work with Directed Acyclic Graphs, +-- by taking advantage of topological sorting. +-- +-- * SPDX-License-Id: BSD-3-Clause +-- +-- * Author: Oleg Grenrus +-- +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 @@ -22,8 +22,14 @@ , PkgId(..) , dispPkgId , UnitId(..) - , Sha256(..) + , FlagName(..) + + -- ** SHA-256 + , Sha256 , dispSha256 + , parseSha256 + , sha256ToByteString + , sha256FromByteString -- * Utilities , planJsonIdGraph @@ -57,26 +63,30 @@ ---------------------------------------------------------------------------- --- | Equivalent to @Cabal@'s "Distribution.Package.Version" +-- | Equivalent to @Cabal@'s @Distribution.Package.Version@ newtype Ver = Ver [Int] deriving (Show,Eq,Ord) --- | Equivalent to @Cabal@'s "Distribution.Package.UnitId" +-- | Equivalent to @Cabal@'s @Distribution.Package.UnitId@ newtype UnitId = UnitId Text - deriving (Show,Eq,Ord,FromJSON,ToJSON) + deriving (Show,Eq,Ord,FromJSON,ToJSON,FromJSONKey,ToJSONKey) --- | Equivalent to @Cabal@'s "Distribution.Package.PackageName" +-- | Equivalent to @Cabal@'s @Distribution.Package.PackageName@ newtype PkgName = PkgName Text - deriving (Show,Eq,Ord,FromJSON,ToJSON) + deriving (Show,Eq,Ord,FromJSON,ToJSON,FromJSONKey,ToJSONKey) --- | Equivalent to @Cabal@'s "Distribution.Package.PackageIdentifier" +-- | Equivalent to @Cabal@'s @Distribution.Package.PackageIdentifier@ data PkgId = PkgId !PkgName !Ver deriving (Show,Eq,Ord) --- | SHA-256 hash +-- | Equivalent to @Cabal@'s @Distribution.PackageDescription.FlagName@ -- --- As an invariant, the wrapped 'B.ByteString' is exactly 32 bytes long. -newtype Sha256 = Sha256 B.ByteString +-- @since 0.3.0.0 +newtype FlagName = FlagName Text + deriving (Show,Eq,Ord,FromJSON,ToJSON,FromJSONKey,ToJSONKey) + +-- | hash +newtype Sha256 = Sha256 B.ByteString -- internal invariant: exactly 32 bytes long deriving (Eq,Ord) -- | Represents the information contained in cabal's @plan.json@ file. @@ -101,25 +111,29 @@ -- | Represents a build-plan unit uniquely identified by its 'UnitId' data Unit = Unit - { uId :: !UnitId -- ^ Unit ID uniquely identifying a 'Unit' in install plan - , uPId :: !PkgId -- ^ Package name and version (not necessarily unique within plan) - , uType :: !UnitType -- ^ Describes type of build item, see 'UnitType' - , uSha256 :: !(Maybe Sha256) -- ^ SHA256 source tarball checksum (as used by e.g. @hackage-security@) - , uComps :: !(Map CompName CompInfo) -- ^ Components identified by 'UnitId' + { uId :: !UnitId -- ^ Unit ID uniquely identifying a 'Unit' in install plan + , uPId :: !PkgId -- ^ Package name and version (not necessarily unique within plan) + , uType :: !UnitType -- ^ Describes type of build item, see 'UnitType' + , uSha256 :: !(Maybe Sha256) -- ^ SHA256 source tarball checksum (as used by e.g. @hackage-security@) + , uComps :: !(Map CompName CompInfo) -- ^ Components identified by 'UnitId' -- -- When @cabal@ needs to fall back to legacy-mode (currently for -- @custom@ build-types or obsolete @cabal-version@ values), 'uComps' -- may contain more than one element. - , uFlags :: !(Map Text Bool) -- ^ cabal flag settings (not available for 'UnitTypeBuiltin') + , uFlags :: !(Map FlagName Bool) -- ^ cabal flag settings (not available for 'UnitTypeBuiltin') + , uDistDir :: !(Maybe FilePath) -- ^ In-place dist-dir (if available) + -- + -- @since 0.3.0.0 } deriving Show -- | Component name inside a build-plan unit -- -- A similiar type exists in @Cabal@ codebase, see --- "Distribution.Simple.LocalBuildInfo.ComponentName" +-- @Distribution.Simple.LocalBuildInfo.ComponentName@ data CompName = CompNameLib | CompNameSubLib !Text + | CompNameFLib !Text -- ^ @since 0.3.0.0 | CompNameExe !Text | CompNameTest !Text | CompNameBench !Text @@ -151,28 +165,40 @@ instance ToJSONKey CompName where toJSONKey = toJSONKeyText dispCompName +---- + instance FromJSON CompInfo where parseJSON = withObject "CompInfo" $ \o -> CompInfo <$> o .:?! "depends" <*> o .:?! "exe-depends" <*> o .:? "bin-file" +---- + instance FromJSON PkgId where - parseJSON = withText "PkgId" (maybe (fail "PkgId") pure . parsePkgId) + parseJSON = withText "PkgId" (maybe (fail "invalid PkgId") pure . parsePkgId) instance ToJSON PkgId where toJSON = toJSON . dispPkgId +instance FromJSONKey PkgId where + fromJSONKey = FromJSONKeyTextParser (maybe (fail "PkgId") pure . parsePkgId) + +instance ToJSONKey PkgId where + toJSONKey = toJSONKeyText dispPkgId + + ---------------------------------------------------------------------------- -- parser helpers parseCompName :: Text -> Maybe CompName parseCompName t0 = case T.splitOn ":" t0 of ["lib"] -> Just CompNameLib - ["lib",n] -> Just $ CompNameSubLib n - ["exe",n] -> Just $ CompNameExe n - ["bench",n] -> Just $ CompNameBench n - ["test",n] -> Just $ CompNameTest n + ["lib",n] -> Just $! CompNameSubLib n + ["flib",n] -> Just $! CompNameFLib n + ["exe",n] -> Just $! CompNameExe n + ["bench",n] -> Just $! CompNameBench n + ["test",n] -> Just $! CompNameTest n ["setup"] -> Just CompNameSetup _ -> Nothing @@ -181,6 +207,7 @@ dispCompName cn = case cn of CompNameLib -> "lib" CompNameSubLib n -> "lib:" <> n + CompNameFLib n -> "flib:" <> n CompNameExe n -> "exe:" <> n CompNameBench n -> "bench:" <> n CompNameTest n -> "test:" <> n @@ -239,6 +266,8 @@ M.singleton CompNameLib <$> parseJSON (Object o) _ -> fail (show o) + uDistDir <- o .:? "dist-dir" + pure Unit{..} ---------------------------------------------------------------------------- @@ -350,17 +379,39 @@ dispPkgId :: PkgId -> Text dispPkgId (PkgId (PkgName pn) pv) = pn <> "-" <> dispVer pv + +-- | Pretty print 'Sha256' as base-16. +dispSha256 :: Sha256 -> Text +dispSha256 (Sha256 s) = T.decodeLatin1 (B16.encode s) + +-- | Parse base-16 encoded 'Sha256'. +-- +-- Returns 'Nothing' in case of parsing failure. +-- +-- @since 0.3.0.0 parseSha256 :: Text -> Maybe Sha256 parseSha256 t | B.length s == 32, B.null rest = Just (Sha256 s) - | otherwise = Nothing + | otherwise = Nothing where (s, rest) = B16.decode $ T.encodeUtf8 t --- | Pretty print 'Sha256' as base-16 -dispSha256 :: Sha256 -> Text -dispSha256 (Sha256 s) = T.decodeLatin1 (B16.encode s) +-- | Export the 'Sha256' digest to a 32-byte 'B.ByteString'. +-- +-- @since 0.3.0.0 +sha256ToByteString :: Sha256 -> B.ByteString +sha256ToByteString (Sha256 bs) = bs +-- | Import the 'Sha256' digest from a 32-byte 'B.ByteString'. +-- +-- Returns 'Nothing' if input 'B.ByteString' has incorrect length. +-- +-- @since 0.3.0.0 +sha256FromByteString :: B.ByteString -> Maybe Sha256 +sha256FromByteString bs + | B.length bs == 32 = Just (Sha256 bs) + | otherwise = Nothing + instance FromJSON Sha256 where parseJSON = withText "Sha256" (maybe (fail "Sha256") pure . parseSha256) @@ -369,8 +420,6 @@ instance Show Sha256 where show = show . dispSha256 - - ----------------------------------------------------------------------------