cabal-plan 0.2.0.0 → 0.3.0.0
raw patch · 6 files changed
+1280/−132 lines, 6 filesdep +base-compatdep +base-orphansdep +parsecdep ~aesondep ~ansi-terminaldep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: base-compat, base-orphans, parsec, semigroups, vector
Dependency ranges changed: aeson, ansi-terminal, base
API changes (from Hackage documentation)
- Cabal.Plan: Sha256 :: ByteString -> Sha256
- Cabal.Plan: newtype Sha256
+ Cabal.Plan: CompNameFLib :: !Text -> CompName
+ Cabal.Plan: FlagName :: Text -> FlagName
+ Cabal.Plan: [uDistDir] :: Unit -> !(Maybe FilePath)
+ Cabal.Plan: data Sha256
+ Cabal.Plan: instance Data.Aeson.Types.FromJSON.FromJSON Cabal.Plan.FlagName
+ Cabal.Plan: instance Data.Aeson.Types.FromJSON.FromJSONKey Cabal.Plan.FlagName
+ Cabal.Plan: instance Data.Aeson.Types.FromJSON.FromJSONKey Cabal.Plan.PkgId
+ Cabal.Plan: instance Data.Aeson.Types.FromJSON.FromJSONKey Cabal.Plan.PkgName
+ Cabal.Plan: instance Data.Aeson.Types.FromJSON.FromJSONKey Cabal.Plan.UnitId
+ Cabal.Plan: instance Data.Aeson.Types.ToJSON.ToJSON Cabal.Plan.FlagName
+ Cabal.Plan: instance Data.Aeson.Types.ToJSON.ToJSONKey Cabal.Plan.FlagName
+ Cabal.Plan: instance Data.Aeson.Types.ToJSON.ToJSONKey Cabal.Plan.PkgId
+ Cabal.Plan: instance Data.Aeson.Types.ToJSON.ToJSONKey Cabal.Plan.PkgName
+ Cabal.Plan: instance Data.Aeson.Types.ToJSON.ToJSONKey Cabal.Plan.UnitId
+ Cabal.Plan: instance GHC.Classes.Eq Cabal.Plan.FlagName
+ Cabal.Plan: instance GHC.Classes.Ord Cabal.Plan.FlagName
+ Cabal.Plan: instance GHC.Show.Show Cabal.Plan.FlagName
+ Cabal.Plan: newtype FlagName
+ Cabal.Plan: parseSha256 :: Text -> Maybe Sha256
+ Cabal.Plan: sha256FromByteString :: ByteString -> Maybe Sha256
+ Cabal.Plan: sha256ToByteString :: Sha256 -> ByteString
- Cabal.Plan: Unit :: !UnitId -> !PkgId -> !UnitType -> !(Maybe Sha256) -> !(Map CompName CompInfo) -> !(Map Text Bool) -> Unit
+ Cabal.Plan: Unit :: !UnitId -> !PkgId -> !UnitType -> !(Maybe Sha256) -> !(Map CompName CompInfo) -> !(Map FlagName Bool) -> !(Maybe FilePath) -> Unit
- Cabal.Plan: [uFlags] :: Unit -> !(Map Text Bool)
+ Cabal.Plan: [uFlags] :: Unit -> !(Map FlagName Bool)
Files
- ChangeLog.md +27/−6
- cabal-plan.cabal +37/−11
- src-exe/cabal-plan.hs +581/−87
- src-topograph/LICENSE +30/−0
- src-topograph/Topograph.hs +528/−0
- src/Cabal/Plan.hs +77/−28
ChangeLog.md view
@@ -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
cabal-plan.cabal view
@@ -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
src-exe/cabal-plan.hs view
@@ -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) () "<argument>"+ 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<TAB>+ -- $ cabal-plan list-bin cabal-plan<TAB>+ -- $ cabal-plan list-bin cabal-plan:exe:cabal-plan+ --+ -- Note: if this package had `tests` -suite, then we can+ -- $ cabal-plan list-bin te<TAB>+ -- $ cabal-plan list-bin tests<TAB>+ -- $ 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')
+ src-topograph/LICENSE view
@@ -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.
+ src-topograph/Topograph.hs view
@@ -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 <https://en.wikipedia.org/wiki/Transitive_reduction> for a picture.+--+-- >>> let example :: Map Char (Set Char); example = M.map S.fromList $ M.fromList [('a', "bxde"), ('b', "d"), ('x', "de"), ('d', "e"), ('e', "")]+--+-- >>> :set -XRecordWildCards+-- >>> import Data.Monoid (All (..))+-- >>> import Data.Foldable (traverse_)+--+-- >>> let fmap2 = fmap . fmap+-- >>> let fmap3 = fmap . fmap2+-- >>> let traverse2_ = traverse_ . traverse_+-- >>> let traverse3_ = traverse_ . traverse2_+--+-- >>> let dispTree :: Show a => Tree a -> IO (); dispTree = go 0 where go i (T.Node x xs) = putStrLn (replicate (i * 2) ' ' ++ show x) >> traverse_ (go (succ i)) xs
src/Cabal/Plan.hs view
@@ -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)++-- | <https://en.wikipedia.org/wiki/SHA-2 SHA-256> 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-- ----------------------------------------------------------------------------