nixdu (empty) → 0.1.0.0
raw patch · 6 files changed
+888/−0 lines, 6 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, brick, containers, deepseq, directory, filepath, hashable, hrfsize, lens, parallel, protolude, text, transformers, typed-process, unordered-containers, vty
Files
- README.md +40/−0
- nixdu.cabal +40/−0
- src/App.hs +371/−0
- src/Main.hs +79/−0
- src/PathStats.hs +122/−0
- src/StorePath.hs +236/−0
+ README.md view
@@ -0,0 +1,40 @@+# nixdu++Interactively browse the dependency graph of your Nix derivations.++[](https://asciinema.org/a/XVVOPQuU6ZQ0vGuO8ejr4JB11)++## Installation++```+nix-env -iA nixdu -f https://github.com/utdemir/nixdu/archive/master.tar.gz+```++A nixpkgs overlay is also provided via `overlay.nix`, that can be used+with tools like [home-manager][]:++```nix+nixpkgs.overlays = [+ (let url = https://github.com/utdemir/nixdu/archive/master.tar.gz;+ in import "${builtins.fetchTarball url}/overlay.nix" {})+];++home.packages = [ pkgs.nixdu ];+```++## Usage++```+$ nixdu --help+nixdu --help+Usage: nixdu [paths] [-h|--help]+ Paths default to $HOME/.nix-profile and /var/run/current-system.+Keybindings:+ hjkl/Arrow Keys : Navigate+ q/Esc: : Quit / close modal+ w : Open why-depends mode+ i : Toggle modeline+ ? : Show help+```++[home-manager]: https://github.com/rycee/home-manager
+ nixdu.cabal view
@@ -0,0 +1,40 @@+name: nixdu+synopsis: Interactively browse a Nix store paths dependencies+description: A terminal curses application to browse a Nix store paths dependencies+version: 0.1.0.0+homepage: https://github.com/utdemir/nixdu+license: BSD3+author: Utku Demir+maintainer: Utku Demir+copyright: Utku Demir+category: Language.Nix+build-type: Simple+cabal-version: >=1.10+extra-source-files: README.md++executable nixdu+ main-is: Main.hs+ hs-source-dirs: src+ default-language: Haskell2010+ other-modules: PathStats+ StorePath+ App+ ghc-options: -Wall -fno-warn-name-shadowing -threaded -O2 -threaded+ build-depends: base >= 4.11 && < 5+ , aeson+ , async+ , brick+ , containers+ , deepseq+ , directory+ , filepath+ , hashable+ , hrfsize+ , lens+ , parallel+ , protolude+ , text+ , transformers+ , typed-process+ , unordered-containers+ , vty
+ src/App.hs view
@@ -0,0 +1,371 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module App (run, helpText) where++import qualified Brick as B+import qualified Brick.Widgets.Border as B+import qualified Brick.Widgets.Center as B+import qualified Brick.Widgets.List as B+import qualified Data.List.NonEmpty as NE+import qualified Data.Sequence as S+import qualified Data.Text as T+import qualified Graphics.Vty as V+import PathStats+import Protolude+import qualified System.HrfSize as HRF++data Widgets+ = WidgetPrevPane+ | WidgetCurrPane+ | WidgetNextPane+ | WidgetWhyDepends+ deriving (Show, Eq, Ord)++data Modal s+ = ModalHelp+ | ModalWhyDepends (B.GenericList Widgets Seq (NonEmpty (Path s)))++data AppEnv s = AppEnv+ { aeActualStoreEnv :: StoreEnv s (PathStats s),+ aePrevPane :: List s,+ aeCurrPane :: List s,+ aeNextPane :: List s,+ aeParents :: [List s],+ aeOpenModal :: Maybe (Modal s),+ aeShowInfoPane :: Bool+ }++type Path s = StorePath s (StoreName s) (PathStats s)++type List s = B.GenericList Widgets Seq (Path s)++attrTerminal :: B.AttrName+attrTerminal = "terminal"++run :: StoreEnv s (PathStats s) -> IO ()+run env = void $ B.defaultMain app appEnv+ where+ appEnv =+ AppEnv+ { aeActualStoreEnv =+ env,+ aePrevPane =+ B.list WidgetPrevPane S.empty 0,+ aeCurrPane =+ B.list WidgetCurrPane (S.fromList . NE.toList $ seGetRoots env) 0,+ aeNextPane =+ B.list WidgetNextPane S.empty 0,+ aeParents =+ [],+ aeOpenModal =+ Nothing,+ aeShowInfoPane =+ True+ }+ & repopulateNextPane++renderList ::+ Bool ->+ List s ->+ B.Widget Widgets+renderList isFocused list =+ B.renderList+ ( \_+ StorePath+ { spName,+ spPayload = PathStats {psTotalSize, psAddedSize},+ spRefs+ } ->+ let color =+ if null spRefs+ then B.withAttr attrTerminal+ else identity+ in color $+ B.padRight B.Max (B.txt $ storeNameToShortText spName)+ B.<+> B.padLeft+ B.Max+ ( B.txt $+ prettySize psTotalSize+ <> if not (null spRefs)+ then+ " ("+ <> prettySize psAddedSize+ <> ")"+ else mempty+ )+ )+ isFocused+ list++app :: B.App (AppEnv s) () Widgets+app =+ B.App+ { B.appDraw = \env@AppEnv {aeOpenModal} ->+ [ case aeOpenModal of+ Nothing -> B.emptyWidget+ Just ModalHelp -> renderHelpModal+ Just (ModalWhyDepends l) -> renderWhyDependsModal l,+ renderMainScreen env+ ],+ B.appChooseCursor = \_ -> const Nothing,+ B.appHandleEvent = \s e ->+ case (e, aeOpenModal s) of+ -- main screen+ (B.VtyEvent (V.EvKey k []), Nothing)+ | k `elem` [V.KChar 'q', V.KEsc] ->+ B.halt s+ (B.VtyEvent (V.EvKey (V.KChar '?') []), Nothing) ->+ B.continue s {aeOpenModal = Just ModalHelp}+ (B.VtyEvent (V.EvKey (V.KChar 'w') []), Nothing) ->+ B.continue $ showWhyDepends s+ (B.VtyEvent (V.EvKey (V.KChar 'i') []), Nothing) ->+ B.continue $ s {aeShowInfoPane = not (aeShowInfoPane s)}+ (B.VtyEvent (V.EvKey k []), Nothing)+ | k `elem` [V.KChar 'h', V.KLeft] ->+ B.continue $ moveLeft s+ (B.VtyEvent (V.EvKey k []), Nothing)+ | k `elem` [V.KChar 'j', V.KDown] ->+ B.continue $ move B.listMoveDown s+ (B.VtyEvent (V.EvKey k []), Nothing)+ | k `elem` [V.KChar 'k', V.KUp] ->+ B.continue $ move B.listMoveUp s+ (B.VtyEvent (V.EvKey k []), Nothing)+ | k `elem` [V.KChar 'l', V.KRight] ->+ B.continue $ moveRight s+ (B.VtyEvent (V.EvKey V.KPageUp []), Nothing) ->+ B.continue =<< moveF B.listMovePageUp s+ (B.VtyEvent (V.EvKey V.KPageDown []), Nothing) ->+ B.continue =<< moveF B.listMovePageDown s+ -- modals+ (B.VtyEvent (V.EvKey k []), Just _)+ | k `elem` [V.KChar 'q', V.KEsc] ->+ B.continue s {aeOpenModal = Nothing}+ -- why-depends modal+ (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends l))+ | k `elem` [V.KChar 'j', V.KDown] ->+ B.continue s {aeOpenModal = Just $ ModalWhyDepends (B.listMoveDown l)}+ (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends l))+ | k `elem` [V.KChar 'k', V.KUp] ->+ B.continue s {aeOpenModal = Just $ ModalWhyDepends (B.listMoveUp l)}+ (B.VtyEvent (V.EvKey V.KPageUp []), Just (ModalWhyDepends l)) ->+ B.listMovePageUp l >>= \l' ->+ B.continue s {aeOpenModal = Just $ ModalWhyDepends l'}+ (B.VtyEvent (V.EvKey V.KPageDown []), Just (ModalWhyDepends l)) ->+ B.listMovePageDown l >>= \l' ->+ B.continue s {aeOpenModal = Just $ ModalWhyDepends l'}+ (B.VtyEvent (V.EvKey V.KEnter []), Just (ModalWhyDepends l)) ->+ let closed = s {aeOpenModal = Nothing}+ in case B.listSelectedElement l of+ Nothing -> B.continue closed+ Just (_, path) -> B.continue $ selectPath path closed+ -- otherwise+ _ ->+ B.continue s,+ B.appStartEvent = \s -> return s,+ B.appAttrMap = \_ ->+ B.attrMap+ (V.white `B.on` V.black)+ [ (B.listSelectedFocusedAttr, V.black `B.on` V.white),+ (attrTerminal, B.fg V.blue)+ ]+ }++renderMainScreen :: AppEnv s -> B.Widget Widgets+renderMainScreen env@AppEnv {aePrevPane, aeCurrPane, aeNextPane, aeShowInfoPane} =+ (B.joinBorders . B.border)+ ( B.hBox+ [ renderList True aePrevPane,+ B.vBorder,+ renderList True aeCurrPane,+ B.vBorder,+ renderList False aeNextPane+ ]+ )+ B.<=> if aeShowInfoPane then renderInfoPane env else renderModeline env++renderModeline :: AppEnv s -> B.Widget Widgets+renderModeline env =+ let selected = selectedPath env+ in B.txt $+ T.intercalate+ " - "+ [ T.pack $ storeNameToPath (spName selected),+ "NAR Size: " <> prettySize (spSize selected),+ "Closure Size: " <> prettySize (psTotalSize $ spPayload selected)+ ]++renderInfoPane :: AppEnv s -> B.Widget Widgets+renderInfoPane env =+ let selected = selectedPath env+ immediateParents = psImmediateParents $ spPayload selected+ in B.txt $+ T.intercalate+ "\n"+ [ T.pack $ storeNameToPath (spName selected),+ "NAR Size: " <> prettySize (spSize selected),+ "Closure Size: " <> prettySize (psTotalSize $ spPayload selected),+ if null immediateParents+ then "Immediate Parents: -"+ else+ "Immediate Parents (" <> T.pack (show $ length immediateParents) <> "): "+ <> T.intercalate ", " (map storeNameToShortText immediateParents)+ ]++helpText :: Text+helpText =+ T.intercalate+ "\n"+ [ "hjkl/Arrow Keys : Navigate",+ "q/Esc: : Quit / close modal",+ "w : Open why-depends mode",+ "i : Toggle modeline",+ "? : Show help"+ ]++renderHelpModal :: B.Widget a+renderHelpModal =+ B.txt helpText+ & B.borderWithLabel (B.txt "Help")+ & B.hLimitPercent 90+ & B.vLimitPercent 60+ & B.centerLayer++renderWhyDependsModal ::+ B.GenericList Widgets Seq (NonEmpty (Path s)) ->+ B.Widget Widgets+renderWhyDependsModal l =+ B.renderList renderDepends True l+ & B.hLimitPercent 80+ & B.vLimitPercent 60+ & B.borderWithLabel (B.txt "why-depends")+ & B.centerLayer+ where+ renderDepends _ =+ B.txt . pathsToText+ pathsToText xs =+ xs+ & NE.toList+ & fmap (storeNameToShortText . spName)+ & T.intercalate " → "++showWhyDepends :: AppEnv s -> AppEnv s+showWhyDepends env@AppEnv {aeActualStoreEnv} =+ env+ { aeOpenModal =+ Just . ModalWhyDepends $+ let selected = selectedPath env+ route = selectedPaths env+ xs = S.fromList $ whyDepends aeActualStoreEnv (spName selected)+ in B.list WidgetWhyDepends xs 1+ & B.listMoveTo+ (fromMaybe 0 $ (((==) `on` fmap spName) route) `S.findIndexL` xs)+ }++move :: (List s -> List s) -> AppEnv s -> AppEnv s+move f = runIdentity . moveF (Identity . f)++moveF :: Applicative f => (List s -> f (List s)) -> AppEnv s -> f (AppEnv s)+moveF f env@AppEnv {aeCurrPane} =+ repopulateNextPane . (\p -> env {aeCurrPane = p}) <$> f aeCurrPane++moveLeft :: AppEnv s -> AppEnv s+moveLeft env@AppEnv {aeParents = []} = env+moveLeft env@AppEnv {aePrevPane, aeCurrPane, aeParents = parent : grandparents} =+ env+ { aeParents = grandparents,+ aePrevPane = parent,+ aeCurrPane = aePrevPane {B.listName = WidgetCurrPane},+ aeNextPane = aeCurrPane {B.listName = WidgetNextPane}+ }++moveRight :: AppEnv s -> AppEnv s+moveRight env@AppEnv {aePrevPane, aeCurrPane, aeNextPane, aeParents}+ | null (B.listElements aeNextPane) = env+ | otherwise =+ env+ { aePrevPane = aeCurrPane {B.listName = WidgetPrevPane},+ aeCurrPane = aeNextPane {B.listName = WidgetCurrPane},+ aeParents = aePrevPane : aeParents+ }+ & repopulateNextPane++repopulateNextPane :: AppEnv s -> AppEnv s+repopulateNextPane env@AppEnv {aeActualStoreEnv, aeNextPane} =+ let ref = selectedPath env+ in env+ { aeNextPane =+ B.listReplace+ ( S.sortOn (Down . psTotalSize . spPayload)+ . S.fromList+ . map (seLookup aeActualStoreEnv)+ $ spRefs ref+ )+ (Just 0)+ aeNextPane+ }++selectedPath :: AppEnv s -> Path s+selectedPath = NE.head . selectedPaths++selectedPaths :: AppEnv s -> NonEmpty (Path s)+selectedPaths AppEnv {aePrevPane, aeCurrPane, aeParents} =+ let parents =+ mapMaybe+ (fmap snd . B.listSelectedElement)+ (aePrevPane : aeParents)+ in case B.listSelectedElement aeCurrPane of+ Nothing -> panic "invariant violation: no selected element"+ Just (_, p) -> p :| parents++selectPath :: NonEmpty (Path s) -> AppEnv s -> AppEnv s+selectPath path env+ | (spName <$> path) == (spName <$> selectedPaths env) =+ env+selectPath path env@AppEnv {aeActualStoreEnv} =+ let root :| children = NE.reverse path+ lists =+ NE.scanl+ ( \(_, prev) curr ->+ ( map (seLookup aeActualStoreEnv) $+ spRefs prev,+ curr+ )+ )+ (NE.toList (seGetRoots aeActualStoreEnv), root)+ children+ & NE.reverse+ & fmap+ (\(possible, selected) -> mkList WidgetPrevPane possible selected)+ & (<> (emptyPane :| []))+ in case lists of+ (curr :| prevs) ->+ let (prev, parents) = case prevs of+ [] -> (emptyPane, [])+ p : ps -> (p, ps)+ in env+ { aeParents = parents,+ aePrevPane = prev,+ aeCurrPane = curr {B.listName = WidgetCurrPane}+ }+ & repopulateNextPane+ where+ mkList name possible selected =+ let contents = S.sortOn (Down . psTotalSize . spPayload) (S.fromList possible)+ in B.list name contents 1+ & B.listMoveTo+ (fromMaybe (0) $ (((==) `on` spName) selected) `S.findIndexL` contents)+ emptyPane =+ B.list WidgetPrevPane S.empty 0++-- Utils++prettySize :: Int -> T.Text+prettySize size = case HRF.convertSize $ fromIntegral size of+ HRF.Bytes d -> T.pack (show d)+ HRF.KiB d -> T.pack (show d) <> " KiB"+ HRF.MiB d -> T.pack (show d) <> " MiB"+ HRF.GiB d -> T.pack (show d) <> " GiB"+ HRF.TiB d -> T.pack (show d) <> " TiB"
+ src/Main.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Main where++import App+import qualified Data.HashMap.Strict as HM+import PathStats+import Protolude+import System.Directory (canonicalizePath, doesDirectoryExist, getHomeDirectory)+import System.FilePath ((</>))++usage :: Text+usage =+ unlines+ [ "Usage: nixdu [paths] [-h|--help]",+ " Paths default to $HOME/.nix-profile and /var/run/current-system.",+ "Keybindings:",+ unlines . map (" " <>) . lines $ helpText+ ]++usageAndFail :: Text -> IO a+usageAndFail msg = do+ hPutStrLn stderr $ "Error: " <> msg+ hPutStr stderr usage+ exitWith (ExitFailure 1)++main :: IO ()+main = do+ args <- getArgs+ when (any (`elem` ["-h", "--help"]) args) $ do+ putStr usage+ exitWith ExitSuccess++ paths <- case args of+ p : ps ->+ return $ p :| ps+ [] -> do+ home <- getHomeDirectory+ roots <-+ filterM+ doesDirectoryExist+ [ home </> ".nix-profile",+ "/var/run/current-system"+ ]+ case roots of+ [] -> usageAndFail "No store path given."+ p : ps -> return $ p :| ps+ storePaths <- mapM canonicalizePath paths+ ret <- withStoreEnv storePaths $ \env' -> do+ let env = calculatePathStats env'++ -- Small hack to evaluate the tree branches with a breadth-first+ -- traversal in the background+ let go _ [] = return ()+ go remaining nodes = do+ let (newRemaining, foundNodes) =+ foldl'+ ( \(nr, fs) n ->+ ( HM.delete n nr,+ HM.lookup n nr : fs+ )+ )+ (remaining, [])+ nodes+ evaluate $ rnf foundNodes+ go+ newRemaining+ (concatMap (maybe [] spRefs) foundNodes)+ _ <- forkIO $ go (sePaths env) (toList $ seRoots env)++ run env++ case ret of+ Right () -> return ()+ Left err ->+ usageAndFail $ "Not a store path: " <> show err
+ src/PathStats.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module PathStats+ ( PathStats (..),+ calculatePathStats,+ markRouteTo,+ whyDepends,+ module StorePath,+ )+where++import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Lazy as M+import qualified Data.Set as S+import Protolude+import StorePath++data IntermediatePathStats s = IntermediatePathStats+ { ipsAllRefs :: M.Map (StoreName s) (StorePath s (StoreName s) ())+ }++data PathStats s = PathStats+ { psTotalSize :: !Int,+ psAddedSize :: !Int,+ psImmediateParents :: [StoreName s]+ }+ deriving (Show, Generic, NFData)++mkIntermediateEnv ::+ (StoreName s -> Bool) ->+ StoreEnv s () ->+ StoreEnv s (IntermediatePathStats s)+mkIntermediateEnv pred =+ seBottomUp $ \curr ->+ IntermediatePathStats+ { ipsAllRefs =+ M.unions+ ( M.fromList+ [ (spName, const () <$> sp)+ | sp@StorePath {spName} <- spRefs curr,+ pred spName+ ]+ : map (ipsAllRefs . spPayload) (spRefs curr)+ )+ }++mkFinalEnv :: StoreEnv s (IntermediatePathStats s) -> StoreEnv s (PathStats s)+mkFinalEnv env =+ let totalSize = calculateEnvSize env+ immediateParents = calculateImmediateParents (sePaths env)+ in flip seBottomUp env $ \StorePath {spName, spSize, spPayload} ->+ let filteredSize =+ seFetchRefs env (/= spName) (seRoots env)+ & calculateRefsSize+ addedSize = totalSize - filteredSize+ in PathStats+ { psTotalSize =+ spSize+ + calculateRefsSize (ipsAllRefs spPayload),+ psAddedSize = addedSize,+ psImmediateParents =+ maybe [] S.toList $ M.lookup spName immediateParents+ }+ where+ calculateEnvSize :: StoreEnv s (IntermediatePathStats s) -> Int+ calculateEnvSize env =+ seGetRoots env+ & toList+ & map+ ( \sp@StorePath {spName, spPayload} ->+ M.insert+ spName+ (const () <$> sp)+ (ipsAllRefs spPayload)+ )+ & M.unions+ & calculateRefsSize+ calculateRefsSize :: (Functor f, Foldable f) => f (StorePath s a b) -> Int+ calculateRefsSize = sum . fmap spSize+ calculateImmediateParents ::+ (Foldable f) =>+ f (StorePath s (StoreName s) b) ->+ M.Map (StoreName s) (S.Set (StoreName s))+ calculateImmediateParents =+ foldl'+ ( \m StorePath {spName, spRefs} ->+ M.unionWith+ (<>)+ m+ (M.fromList (map (\r -> (r, S.singleton spName)) spRefs))+ )+ M.empty++calculatePathStats :: StoreEnv s () -> StoreEnv s (PathStats s)+calculatePathStats = mkFinalEnv . mkIntermediateEnv (const True)++whyDepends :: StoreEnv s a -> StoreName s -> [NonEmpty (StorePath s (StoreName s) a)]+whyDepends env name =+ seBottomUp+ ( \curr ->+ if spName curr == name+ then [curr {spRefs = map spName (spRefs curr)} :| []]+ else+ concat . transpose $+ map+ (map (curr {spRefs = map spName (spRefs curr)} NE.<|) . spPayload)+ (spRefs curr)+ )+ env+ & seGetRoots+ & fmap spPayload+ & concat+ & map NE.reverse++markRouteTo :: StoreName s -> StoreEnv s a -> StoreEnv s (Bool, a)+markRouteTo name = seBottomUp $ \sp@StorePath {spName, spRefs} ->+ ( spName == name || any (fst . spPayload) spRefs,+ spPayload sp+ )
+ src/StorePath.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-}++module StorePath+ ( StoreName (..),+ storeNameToPath,+ storeNameToText,+ storeNameToShortText,+ StorePath (..),+ StoreEnv (..),+ withStoreEnv,+ seLookup,+ seGetRoots,+ seBottomUp,+ seFetchRefs,+ )+where++import Control.Monad (fail)+import Data.Aeson ((.:), FromJSON (..), Value (..), decode)+import qualified Data.HashMap.Strict as HM+import Data.HashMap.Strict (HashMap)+import qualified Data.HashSet as HS+import qualified Data.Text as T+import Protolude+import System.FilePath.Posix (splitDirectories)+import System.Process.Typed (proc, readProcessStdout_)++--------------------------------------------------------------------------------++newtype StoreName s = StoreName Text+ deriving newtype (Show, Eq, Ord, Hashable, NFData)++mkStoreName :: FilePath -> Maybe (StoreName a)+mkStoreName path =+ case splitDirectories path of+ "/" : "nix" : "store" : name : _ -> Just . StoreName $ toS name+ _ -> Nothing++storeNameToText :: StoreName a -> Text+storeNameToText (StoreName n) = n++storeNameToPath :: StoreName a -> FilePath+storeNameToPath (StoreName sn) = "/nix/store/" <> toS sn++storeNameToShortText :: StoreName a -> Text+storeNameToShortText = T.drop 1 . T.dropWhile (/= '-') . storeNameToText++--------------------------------------------------------------------------------++data StorePath s ref payload = StorePath+ { spName :: StoreName s,+ spSize :: Int,+ spRefs :: [ref],+ spPayload :: payload+ }+ deriving (Show, Eq, Ord, Functor, Generic)++instance (NFData a, NFData b) => NFData (StorePath s a b)++mkStorePaths :: NonEmpty (StoreName s) -> IO [StorePath s (StoreName s) ()]+mkStorePaths names = do+ infos <-+ decode @[NixPathInfoResult]+ <$> readProcessStdout_+ ( proc+ "nix"+ ( ["path-info", "--recursive", "--json"]+ ++ map storeNameToPath (toList names)+ )+ )+ >>= maybe (fail "Failed parsing nix path-info output.") return+ >>= mapM assertValidInfo+ mapM infoToStorePath infos+ where+ infoToStorePath NixPathInfo {npiPath, npiNarSize, npiReferences} = do+ name <- mkStoreNameIO npiPath+ refs <- filter (/= name) <$> mapM mkStoreNameIO npiReferences+ return $+ StorePath+ { spName = name,+ spRefs = refs,+ spSize = npiNarSize,+ spPayload = ()+ }+ mkStoreNameIO p =+ maybe+ (fail $ "Failed parsing Nix store path: " ++ show p)+ return+ (mkStoreName p)+ assertValidInfo (NixPathInfoValid pi) = return pi+ assertValidInfo (NixPathInfoInvalid path) =+ fail $ "Invalid path: " ++ path ++ ". Inconsistent /nix/store or ongoing GC."++--------------------------------------------------------------------------------++data StoreEnv s payload = StoreEnv+ { sePaths :: HashMap (StoreName s) (StorePath s (StoreName s) payload),+ seRoots :: NonEmpty (StoreName s)+ }+ deriving (Functor, Generic, NFData)++withStoreEnv ::+ forall m a.+ MonadIO m =>+ NonEmpty FilePath ->+ (forall s. StoreEnv s () -> m a) ->+ m (Either [FilePath] a)+withStoreEnv fnames cb = do+ let names' =+ fnames+ & toList+ & map (\f -> maybe (Left f) Right (mkStoreName f))+ & partitionEithers++ case names' of+ (errs@(_ : _), _) -> return (Left errs)+ ([], xs) -> case nonEmpty xs of+ Nothing -> panic "invariant violation"+ Just names -> do+ paths <- liftIO $ mkStorePaths names+ let env =+ StoreEnv+ ( paths+ & map (\p@StorePath {spName} -> (spName, p))+ & HM.fromList+ )+ names+ Right <$> cb env++seLookup :: StoreEnv s a -> StoreName s -> StorePath s (StoreName s) a+seLookup StoreEnv {sePaths} name =+ fromMaybe+ (panic $ "invariant violation, StoreName not found: " <> show name)+ (HM.lookup name sePaths)++seGetRoots :: StoreEnv s a -> NonEmpty (StorePath s (StoreName s) a)+seGetRoots env@StoreEnv {seRoots} =+ map (seLookup env) seRoots++seFetchRefs ::+ StoreEnv s a ->+ (StoreName s -> Bool) ->+ NonEmpty (StoreName s) ->+ [StorePath s (StoreName s) a]+seFetchRefs env predicate =+ fst+ . foldl'+ (\(acc, visited) name -> go acc visited name)+ ([], HS.empty)+ where+ go acc visited name+ | HS.member name visited = (acc, visited)+ | not (predicate name) = (acc, visited)+ | otherwise =+ let sp@StorePath {spRefs} = seLookup env name+ in foldl'+ (\(acc', visited') name' -> go acc' visited' name')+ (sp : acc, HS.insert name visited)+ spRefs++seBottomUp ::+ forall s a b.+ (StorePath s (StorePath s (StoreName s) b) a -> b) ->+ StoreEnv s a ->+ StoreEnv s b+seBottomUp f StoreEnv {sePaths, seRoots} =+ StoreEnv+ { sePaths = snd $ execState (mapM_ go seRoots) (sePaths, HM.empty),+ seRoots+ }+ where+ unsafeLookup k m =+ fromMaybe+ (panic $ "invariant violation: name doesn't exists: " <> show k)+ (HM.lookup k m)+ go ::+ StoreName s ->+ State+ ( HashMap (StoreName s) (StorePath s (StoreName s) a),+ HashMap (StoreName s) (StorePath s (StoreName s) b)+ )+ (StorePath s (StoreName s) b)+ go name = do+ bs <- gets snd+ case name `HM.lookup` bs of+ Just sp -> return sp+ Nothing -> do+ sp@StorePath {spName, spRefs} <- unsafeLookup name <$> gets fst+ refs <- mapM go spRefs+ let new = sp {spPayload = f sp {spRefs = refs}}+ modify+ ( \(as, bs) ->+ ( HM.delete spName as,+ HM.insert spName new bs+ )+ )+ return new++--------------------------------------------------------------------------------++data NixPathInfo = NixPathInfo+ { npiPath :: FilePath,+ npiNarSize :: Int,+ npiReferences :: [FilePath]+ }++data NixPathInfoResult+ = NixPathInfoValid NixPathInfo+ | NixPathInfoInvalid FilePath++instance FromJSON NixPathInfoResult where+ parseJSON (Object obj) =+ ( NixPathInfoValid+ <$> ( NixPathInfo+ <$> obj .: "path"+ <*> obj .: "narSize"+ <*> obj .: "references"+ )+ )+ <|> ( do+ path <- obj .: "path"+ valid <- obj .: "valid"+ guard (not valid)+ return $ NixPathInfoInvalid path+ )+ parseJSON _ = fail "Expecting an object."