From 591ccc35389cade0f35450b0c895aa27aea727b0 Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 11 Apr 2020 18:05:22 +0200 Subject: [PATCH 1/4] Move existing code for re-using --- src-exe/cabal-plan.hs | 33 ++++++++++++++++++--------------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/src-exe/cabal-plan.hs b/src-exe/cabal-plan.hs index 70949d1..61fe53f 100644 --- a/src-exe/cabal-plan.hs +++ b/src-exe/cabal-plan.hs @@ -1188,7 +1188,7 @@ doLicenseReport :: Maybe FilePath -> Pattern -> IO () doLicenseReport mlicdir pat = do plan <- getCurrentDirectory >>= findAndDecodePlanJson . ProjectRelativeToDir - case findUnit plan of + case findUnit plan pat of [] -> do hPutStrLn stderr "No matches found." exitFailure @@ -1201,17 +1201,17 @@ doLicenseReport mlicdir pat = do [(_,uid,cn)] -> generateLicenseReport mlicdir plan uid cn - where - findUnit plan = do - (_, Unit{..}) <- M.toList $ pjUnits plan - (cn, _) <- M.toList $ uComps +findUnit :: PlanJson -> Pattern -> [(Text, UnitId, CompName)] +findUnit plan pat = do + (_, Unit{..}) <- M.toList $ pjUnits plan + (cn, _) <- M.toList $ uComps - let PkgId pn _ = uPId - g = dispCompNameTarget pn cn + let PkgId pn _ = uPId + g = dispCompNameTarget pn cn - guard (getAny $ checkPattern pat pn cn) + guard (getAny $ checkPattern pat pn cn) - pure (g, uId, cn) + pure (g, uId, cn) ------------------------------------------------------------------------------- @@ -1269,7 +1269,15 @@ doTopo useColors showBuiltin showGlobal plan rev showFlags = do dumpPlanJson :: PlanJson -> CWriter () dumpPlanJson (PlanJson { pjUnits = pm }) = - evalStateT (mapM_ (go2 []) (S.toList roots)) S.empty + evalStateT (mapM_ (writePlanJson pm) (S.toList roots)) S.empty + where + roots :: Set UnitId + roots = M.keysSet pm `S.difference` leafs + where + leafs = mconcat $ concatMap (map (ciLibDeps . snd) . M.toList . uComps) (M.elems pm) + +writePlanJson :: Map UnitId Unit -> UnitId -> StateT (Set UnitId) CWriter () +writePlanJson pm unitId = go2 [] unitId where id2pid :: Map UnitId PkgId id2pid = M.fromList [ (uId, uPId) | Unit{..} <- M.elems pm ] @@ -1314,11 +1322,6 @@ dumpPlanJson (PlanJson { pjUnits = pm }) = linepfx' :: CText linepfx' = mconcat [ fromT $ if x then Vert else Spac | (_,x) <- lvl ] - roots :: Set UnitId - roots = M.keysSet pm `S.difference` leafs - where - leafs = mconcat $ concatMap (map (ciLibDeps . snd) . M.toList . uComps) (M.elems pm) - prettyId :: UnitId -> String prettyId = prettyPid . lupPid prettyPid = T.unpack . dispPkgId From db194296f643939455baed9d77480a72c69b6a86 Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 11 Apr 2020 18:05:52 +0200 Subject: [PATCH 2/4] Implement whyDepends function --- src-exe/cabal-plan.hs | 61 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 59 insertions(+), 2 deletions(-) diff --git a/src-exe/cabal-plan.hs b/src-exe/cabal-plan.hs index 61fe53f..067e422 100644 --- a/src-exe/cabal-plan.hs +++ b/src-exe/cabal-plan.hs @@ -9,7 +9,7 @@ module Main where import Control.Monad (guard, unless, when) import Control.Monad.ST (runST) -import Control.Monad.State.Strict (StateT, evalStateT, gets, modify') +import Control.Monad.State.Strict (StateT, State, evalStateT, runState, gets, modify') import Data.Align (align) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -1265,7 +1265,64 @@ doTopo useColors showBuiltin showGlobal plan rev showFlags = do <> fromString (T.unpack components) <> flags ----------------------------------------------------------------------------- +------------------------------------------------------------------------------- +-- why-depends +------------------------------------------------------------------------------- + +doWhyDepends :: UseColors -> UseAscii -> PlanJson -> UnitId -> UnitId -> IO () +doWhyDepends useColors useAscii (PlanJson { pjUnits = pm}) unitId pkg = do + let (_u, newPm) = runState (buildDependencyGraph unitId) M.empty + let pm' = M.mapMaybe id newPm + runCWriterIO useColors useAscii (evalStateT (writePlanJson pm' unitId) S.empty) + where + buildDependencyGraph :: UnitId -> State (Map UnitId (Maybe Unit)) (Maybe Unit) + buildDependencyGraph uid = do + munit <- gets (uid `M.lookup`) + case munit of + Just cacheHit -> pure cacheHit + Nothing -> do + let unit = pm M.! uid + newComps <- catMaybes <$> mapM filterDependencies (M.toList (uComps unit)) + buildResult unit newComps + + buildResult :: Unit -> [(CompName, CompInfo)] -> State (Map UnitId (Maybe Unit)) (Maybe Unit) + buildResult unit comps + | (uId unit) == pkg = do + newUnit <- buildNewUnit unit [] + pure $ Just newUnit + | null comps = do + modify' (M.insert (uId unit) Nothing) + pure Nothing + | otherwise = do + newUnit <- buildNewUnit unit comps + pure $ Just newUnit + + filterDependencies :: (CompName, CompInfo) -> State (Map UnitId (Maybe Unit)) (Maybe (CompName, CompInfo)) + filterDependencies (n, compInfo) = do + filterCompInfo compInfo >>= \mcomp -> + case mcomp of + Nothing -> pure Nothing + Just newInfo -> pure $ Just (n, newInfo) + + filterCompInfo :: CompInfo -> State (Map UnitId (Maybe Unit)) (Maybe CompInfo) + filterCompInfo CompInfo {..} = do + newLibUnitIds <- map uId . catMaybes <$> mapM buildDependencyGraph (S.toList ciLibDeps) + newExeUnitIds <- map uId . catMaybes <$> mapM buildDependencyGraph (S.toList ciExeDeps) + if null newLibUnitIds && null newExeUnitIds + then pure Nothing + else pure $ Just CompInfo + { ciLibDeps = S.fromList newLibUnitIds + , ciExeDeps = S.fromList newExeUnitIds, + .. + } + + buildNewUnit :: Unit -> [(CompName, CompInfo)] -> State (Map UnitId (Maybe Unit)) Unit + buildNewUnit old comps = do + let newUnit = old + { uComps = M.fromList comps + } + modify' $ M.insert (uId old) (Just newUnit) + pure newUnit dumpPlanJson :: PlanJson -> CWriter () dumpPlanJson (PlanJson { pjUnits = pm }) = From fcaaa1c7ee48262d01e49226f489878d233f93c6 Mon Sep 17 00:00:00 2001 From: fendor Date: Sat, 11 Apr 2020 18:06:19 +0200 Subject: [PATCH 3/4] Implement CLI for "why-depends" command --- src-exe/cabal-plan.hs | 29 ++++++++++++++++++++++++++--- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/src-exe/cabal-plan.hs b/src-exe/cabal-plan.hs index 067e422..8d0fbc5 100644 --- a/src-exe/cabal-plan.hs +++ b/src-exe/cabal-plan.hs @@ -93,6 +93,7 @@ data Command | TopoCommand (Maybe SearchPlanJson) (Flag TopoReverse) (Flag ShowFlags) | LicenseReport (Maybe FilePath) Pattern | DiffCommand SearchPlanJson SearchPlanJson + | WhyDependsCommand (Maybe SearchPlanJson) Pattern Pattern data RunDot = PNG | PDF @@ -308,6 +309,11 @@ main = do (_, plan) <- findPlan s doTopo optsUseColors optsShowBuiltin optsShowGlobal plan rev showFlags LicenseReport mfp pat -> doLicenseReport mfp pat + WhyDependsCommand s compPat depPat -> do + (_, plan) <- findPlan s + let [(_, compId, _)] = findUnit plan compPat + let [(_, depId, _)] = findUnit plan depPat + doWhyDepends optsUseColors optsUseAscii plan compId depId where findPlan search = do cwd <- getCurrentDirectory @@ -411,6 +417,10 @@ main = do <*> patternArgument [ metavar "PATTERN", help "Pattern to match.", completer $ patternCompleter False ] <**> helper + , subCommand "why-depends" "Why does a package depend on another package" $ WhyDependsCommand + <$> planParser + <*> patternArgument [ metavar "TARGET", help "Target with dependencies", completer $ patternCompleter False ] + <*> patternArgument [ metavar "DEPENDENCY", help "Dependency, might be local or global", completer $ patternCompleter False ] ] defaultCommand = pure (InfoCommand Nothing) @@ -1271,10 +1281,23 @@ doTopo useColors showBuiltin showGlobal plan rev showFlags = do doWhyDepends :: UseColors -> UseAscii -> PlanJson -> UnitId -> UnitId -> IO () doWhyDepends useColors useAscii (PlanJson { pjUnits = pm}) unitId pkg = do - let (_u, newPm) = runState (buildDependencyGraph unitId) M.empty - let pm' = M.mapMaybe id newPm - runCWriterIO useColors useAscii (evalStateT (writePlanJson pm' unitId) S.empty) + let (unitWithStrippedDeps, newPm) = runState (buildDependencyGraph unitId) M.empty + case unitWithStrippedDeps of + Nothing -> + runCWriterIO useColors useAscii $ do + putCTextLn $ "The unit " <> prettyUnitId unitId <> " does not depend on " <> prettyUnitId pkg + Just _ -> do + let pm' = M.mapMaybe id newPm + runCWriterIO useColors useAscii $ evalStateT (writePlanJson pm' unitId) S.empty where + prettyUnitId :: UnitId -> CText + prettyUnitId uid = + let + Unit {..} = M.findWithDefault undefined uid pm + in + underline (colorifyText White $ dispPkgId uPId) + + buildDependencyGraph :: UnitId -> State (Map UnitId (Maybe Unit)) (Maybe Unit) buildDependencyGraph uid = do munit <- gets (uid `M.lookup`) From 17a7e16e625b14d8d2b279f0cdde983c38067399 Mon Sep 17 00:00:00 2001 From: unknown Date: Mon, 13 Apr 2020 17:12:21 +0200 Subject: [PATCH 4/4] Improve CLI parsing with explicit error handling --- src-exe/cabal-plan.hs | 37 +++++++++++++++++++++++++++++++++++-- 1 file changed, 35 insertions(+), 2 deletions(-) diff --git a/src-exe/cabal-plan.hs b/src-exe/cabal-plan.hs index 8d0fbc5..838f8ca 100644 --- a/src-exe/cabal-plan.hs +++ b/src-exe/cabal-plan.hs @@ -143,6 +143,21 @@ parsePattern = either (Left . show) Right . P.runParser (patternP <* P.eof) () " toCompType "test" = return $ CompTypeTest toCompType t = fail $ "Unknown component type: " ++ show t +prettyPattern :: Pattern -> T.Text +prettyPattern (Pattern pkg kind cname) = + maybe "" (<> ":") pkg + <> maybe "" ((<> ":") . prettyCompType) kind + <> fromMaybe "" cname + +prettyCompType :: CompType -> T.Text +prettyCompType compType = case compType of + CompTypeBench -> "bench" + CompTypeExe -> "exe" + CompTypeLib -> "lib" + CompTypeFLib -> "flib" + CompTypeSetup -> "setup" + CompTypeTest -> "test" + patternCompleter :: Bool -> Completer patternCompleter onlyWithExes = mkCompleter $ \pfx -> do plan <- getCurrentDirectory >>= findAndDecodePlanJson . ProjectRelativeToDir @@ -311,10 +326,28 @@ main = do LicenseReport mfp pat -> doLicenseReport mfp pat WhyDependsCommand s compPat depPat -> do (_, plan) <- findPlan s - let [(_, compId, _)] = findUnit plan compPat - let [(_, depId, _)] = findUnit plan depPat + compId <- findUniqueUnitOrExit plan compPat + depId <- findUniqueUnitOrExit plan depPat doWhyDepends optsUseColors optsUseAscii plan compId depId where + findUniqueUnitOrExit :: PlanJson -> Pattern -> IO UnitId + findUniqueUnitOrExit p pat = + case findUnit p pat of + [(_, uid, _)] -> pure uid + [] -> do + hPutStrLn stderr $ "Could not find any unit with pattern: " ++ T.unpack (prettyPattern pat) + exitFailure + xs + | [(_, uid, _)] <- filter nonSetupUnits xs -> pure uid + | otherwise -> do + hPutStrLn stderr $ "Ambiguous pattern \"" ++ T.unpack (prettyPattern pat) ++ "\". Found the following targets:" + for_ xs $ \(t, _, _) -> hPutStrLn stderr $ " " ++ T.unpack t + exitFailure + + nonSetupUnits :: (Text, UnitId, CompName) -> Bool + nonSetupUnits (_, _, CompNameSetup) = False + nonSetupUnits _ = True + findPlan search = do cwd <- getCurrentDirectory (searchMethod, mProjRoot) <- case search of