nix-tree 0.1.7 → 0.1.8
raw patch · 17 files changed
+1307/−1271 lines, 17 filesdep +asyncdep +terminal-progress-bar
Dependencies added: async, terminal-progress-bar
Files
- CHANGELOG.md +6/−0
- README.md +13/−7
- nix-tree.cabal +11/−8
- src/App.hs +0/−592
- src/Clipboard.hs +0/−52
- src/Data/InvertedIndex.hs +76/−0
- src/InvertedIndex.hs +0/−76
- src/Main.hs +0/−84
- src/NixTree/App.hs +593/−0
- src/NixTree/Clipboard.hs +53/−0
- src/NixTree/Main.hs +78/−0
- src/NixTree/PathStats.hs +137/−0
- src/NixTree/StorePath.hs +297/−0
- src/PathStats.hs +0/−137
- src/StorePath.hs +0/−283
- test/Test.hs +4/−32
- test/Test/Data/InvertedIndex.hs +39/−0
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Changelog +## 0.1.8 - 2021-09-06:++* fix: Reduce idle CPU use+* fix: Put a timeout on yank command+* fix: Various performance improvements+ ## 0.1.7 - 2021-03-28 * feat: Ability to yank selected store path to clipboard (shortcut: 'y')
README.md view
@@ -3,24 +3,30 @@  [](https://repology.org/project/haskell:nix-tree/versions) -Interactively browse the dependency graph of your Nix derivations.+Interactively browse dependency graphs of Nix derivations. [](https://asciinema.org/a/cnilbmPXW51g97hdNJZcM5F6h) ## Installation -Stable version:+`nix-tree` is on `nixpkgs` since `20.09`, so just use your preferred method for adding packages to your system, eg: ``` nix-env -i nix-tree ``` -Development version (requires Nix with flake support):+To run the current development version: ```-nix profile install github:utdemir/nix-tree+nix-shell -p '(import (builtins.fetchTarball "https://github.com/utdemir/nix-tree/archive/main.tar.gz") {}).nix-tree' --run nix-tree ``` +Or, if you use a Nix version with flake support:++```+nix run github:utdemir/nix-tree+```+ ## Usage ```@@ -66,13 +72,13 @@ nix-build '<nixpkgs>' -A openssl.all --no-out-link | xargs -o nix-tree ``` -## Hacking+## Contributing All contributions, issues and feature requests are welcome. -To hack on it, simply run `nix-shell` (or `nix develop`) and use `cabal` as usual.+To hack on it, simply run `nix-shell` and use `cabal` as usual. Please run `./format.sh` before sending a PR. -# Related tools+## Related tools * [nix-du](https://github.com/symphorien/nix-du) * [nix-query-tree-viewer](https://github.com/cdepillabout/nix-query-tree-viewer)
nix-tree.cabal view
@@ -3,7 +3,7 @@ name: nix-tree synopsis: Interactively browse a Nix store paths dependencies description: A terminal curses application to browse a Nix store paths dependencies-version: 0.1.7+version: 0.1.8 homepage: https://github.com/utdemir/nix-tree license: BSD-3-Clause license-file: LICENSE@@ -36,11 +36,11 @@ RankNTypes ScopedTypeVariables NumericUnderscores- other-modules: PathStats- StorePath- App- InvertedIndex- Clipboard+ other-modules: NixTree.PathStats+ NixTree.StorePath+ NixTree.App+ Data.InvertedIndex+ NixTree.Clipboard Paths_nix_tree autogen-modules: Paths_nix_tree mixins: base hiding (Prelude)@@ -65,16 +65,19 @@ executable nix-tree import: common-options- ghc-options: -Wunused-packages- main-is: Main.hs+ ghc-options: -Wunused-packages -O2 -threaded -with-rtsopts=-N+ main-is: NixTree/Main.hs hs-source-dirs: src default-language: Haskell2010 build-depends: base >= 4.11 && < 5+ , terminal-progress-bar+ , async test-suite nix-tree-tests import: common-options type: exitcode-stdio-1.0 hs-source-dirs: test/ src/+ other-modules: Test.Data.InvertedIndex main-is: Test.hs build-depends: base >=4.11 && < 5 , hedgehog
− src/App.hs
@@ -1,592 +0,0 @@-module App (run, helpText) where--import qualified Brick as B-import qualified Brick.BChan 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 Clipboard-import Control.Concurrent-import qualified Data.List.NonEmpty as NE-import qualified Data.Map as Map-import qualified Data.Sequence as S-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Graphics.Vty as V-import InvertedIndex-import PathStats-import qualified System.Clock as Clock-import qualified System.HrfSize as HRF--data Event- = EventTick Clock.TimeSpec--data Widgets- = WidgetPrevPane- | WidgetCurrPane- | WidgetNextPane- | WidgetWhyDepends- | WidgetSearch- | WidgetWhyDependsViewport- deriving (Show, Eq, Ord)--data Notice = Notice Text Text--data Modal s- = ModalNotice Notice- | ModalWhyDepends (B.GenericList Widgets Seq (NonEmpty (Path s)))- | ModalSearch Text Text (B.GenericList Widgets Seq (Path s))--succCycle :: forall a. (Bounded a, Enum a) => a -> a-succCycle a- | fromEnum a == fromEnum (maxBound @a) = minBound- | otherwise = succ a--data AppEnv s = AppEnv- { aeActualStoreEnv :: StoreEnv s (PathStats s),- aeInvertedIndex :: InvertedIndex (Path s),- aePrevPane :: List s,- aeCurrPane :: List s,- aeNextPane :: List s,- aeParents :: [List s],- aeOpenModal :: Maybe (Modal s),- aeSortOrder :: SortOrder,- aeSortOrderLastChanged :: Clock.TimeSpec,- aeCurrTime :: Clock.TimeSpec- }--type Path s = StorePath s (StoreName s) (PathStats s)--type List s = B.GenericList Widgets Seq (Path s)--data SortOrder- = SortOrderAlphabetical- | SortOrderClosureSize- | SortOrderAddedSize- deriving (Show, Eq, Enum, Bounded)--compareBySortOrder :: SortOrder -> Path s -> Path s -> Ordering-compareBySortOrder SortOrderAlphabetical = compare `on` T.toLower . storeNameToShortText . spName-compareBySortOrder SortOrderClosureSize = compare `on` Down . psTotalSize . spPayload-compareBySortOrder SortOrderAddedSize = compare `on` Down . psAddedSize . spPayload--attrTerminal, attrUnderlined :: B.AttrName-attrTerminal = "terminal"-attrUnderlined = "underlined"--run :: StoreEnv s (PathStats s) -> IO ()-run env = do- -- Create the inverted index, and start evaluating it in the background- let ii = iiFromList . toList . fmap (\sp -> (storeNameToText (spName sp), sp)) $ seAll env- _ <- forkIO $ evaluateNF_ ii-- -- Initial state- let getTime = Clock.getTime Clock.Monotonic- currTime <- getTime- let defaultSortOrder = SortOrderClosureSize-- let appEnv =- AppEnv- { aeActualStoreEnv =- env,- aeInvertedIndex =- ii,- aePrevPane =- B.list WidgetPrevPane S.empty 0,- aeCurrPane =- B.list- WidgetCurrPane- (S.fromList . sortBy (compareBySortOrder defaultSortOrder) . NE.toList $ seGetRoots env)- 0,- aeNextPane =- B.list WidgetNextPane S.empty 0,- aeParents =- [],- aeOpenModal =- Nothing,- aeSortOrder =- defaultSortOrder,- aeSortOrderLastChanged =- Clock.TimeSpec 0 0,- aeCurrTime =- currTime- }- & repopulateNextPane-- -- Create a channel that's fed by current time- chan <- B.newBChan 10- void . forkIO $- forever $ do- threadDelay (100 * 100)- t <- getTime- _ <- B.writeBChanNonBlocking chan (EventTick t)- return ()-- -- And run the application- let mkVty = V.mkVty V.defaultConfig- initialVty <- mkVty- _ <- B.customMain initialVty mkVty (Just chan) app appEnv-- return ()--renderList ::- Maybe SortOrder ->- Bool ->- List s ->- B.Widget Widgets-renderList highlightSort isFocused =- B.renderList- ( \_- StorePath- { spName,- spPayload = PathStats {psTotalSize, psAddedSize},- spRefs- } ->- let color =- if null spRefs- then B.withAttr attrTerminal- else identity- in color $- B.hBox- [ B.txt (storeNameToShortText spName)- & underlineWhen SortOrderAlphabetical- & B.padRight (B.Pad 1)- & B.padRight B.Max,- if null spRefs- then- B.txt (prettySize psTotalSize)- & underlineWhen SortOrderClosureSize- & underlineWhen SortOrderAddedSize- else- B.hBox- [ B.txt (prettySize psTotalSize)- & underlineWhen SortOrderClosureSize,- B.txt " (",- B.txt (prettySize psAddedSize)- & underlineWhen SortOrderAddedSize,- B.txt ")"- ]- ]- )- isFocused- where- underlineWhen so =- if Just so == highlightSort- then B.withDefAttr attrUnderlined- else identity--app :: B.App (AppEnv s) Event Widgets-app =- B.App- { B.appDraw = \env@AppEnv {aeOpenModal} ->- [ case aeOpenModal of- Nothing -> B.emptyWidget- Just (ModalWhyDepends l) -> renderWhyDependsModal l- Just (ModalSearch l r xs) -> renderSearchModal l r xs- Just (ModalNotice notice) -> renderNotice notice,- 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 (ModalNotice helpNotice)}- (B.VtyEvent (V.EvKey (V.KChar 'w') []), Nothing) -> do- B.hScrollToBeginning (B.viewportScroll WidgetWhyDependsViewport)- B.continue $ showWhyDepends s- (B.VtyEvent (V.EvKey (V.KChar '/') []), Nothing) ->- B.continue $ showAndUpdateSearch "" "" s- (B.VtyEvent (V.EvKey (V.KChar 'y') []), Nothing) -> do- liftIO (yankToClipboard $ spName (selectedPath s))- >>= \case- Right () -> B.continue s- Left n -> B.continue s {aeOpenModal = Just (ModalNotice n)}- (B.VtyEvent (V.EvKey (V.KChar 's') []), Nothing) ->- B.continue $- s- { aeSortOrder = succCycle (aeSortOrder s),- aeSortOrderLastChanged = aeCurrTime s- }- & sortPanes- (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, V.KChar '\t'] ->- B.continue $ move B.listMoveDown s- (B.VtyEvent (V.EvKey k []), Nothing)- | k `elem` [V.KChar 'k', V.KUp, V.KBackTab] ->- 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- -- why-depends modal- (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends _))- | k `elem` [V.KChar 'q', V.KEsc] ->- B.continue s {aeOpenModal = Nothing}- (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends _))- | k `elem` [V.KChar 'h', V.KLeft] -> do- B.hScrollBy (B.viewportScroll WidgetWhyDependsViewport) (-1)- B.continue s- (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends l))- | k `elem` [V.KChar 'j', V.KDown, V.KChar '\t'] ->- B.continue s {aeOpenModal = Just $ ModalWhyDepends (B.listMoveDown l)}- (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends l))- | k `elem` [V.KChar 'k', V.KUp, V.KBackTab] ->- B.continue s {aeOpenModal = Just $ ModalWhyDepends (B.listMoveUp l)}- (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends _))- | k `elem` [V.KChar 'l', V.KRight] -> do- B.hScrollBy (B.viewportScroll WidgetWhyDependsViewport) 1- B.continue s- (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- -- search modal- (B.VtyEvent (V.EvKey V.KEsc []), Just (ModalSearch _ _ _)) ->- B.continue s {aeOpenModal = Nothing}- (B.VtyEvent (V.EvKey k []), Just (ModalSearch l r xs))- | k `elem` [V.KDown, V.KChar '\t'] ->- B.continue s {aeOpenModal = Just $ ModalSearch l r (B.listMoveDown xs)}- (B.VtyEvent (V.EvKey k []), Just (ModalSearch l r xs))- | k `elem` [V.KUp, V.KBackTab] ->- B.continue s {aeOpenModal = Just $ ModalSearch l r (B.listMoveUp xs)}- (B.VtyEvent (V.EvKey V.KLeft []), Just (ModalSearch l r xs)) ->- B.continue- s- { aeOpenModal =- Just $ ModalSearch (T.dropEnd 1 l) (T.takeEnd 1 l <> r) (B.listMoveUp xs)- }- (B.VtyEvent (V.EvKey V.KRight []), Just (ModalSearch l r xs)) ->- B.continue- s- { aeOpenModal =- Just $ ModalSearch (l <> T.take 1 r) (T.drop 1 r) (B.listMoveUp xs)- }- (B.VtyEvent (V.EvKey (V.KChar c) []), Just (ModalSearch l r _))- | c `Set.member` allowedSearchChars ->- B.continue (showAndUpdateSearch (l <> T.singleton c) r s)- (B.VtyEvent (V.EvKey (V.KBS) []), Just (ModalSearch l r _)) ->- B.continue (showAndUpdateSearch (T.dropEnd 1 l) r s)- (B.VtyEvent (V.EvKey V.KEnter []), Just (ModalSearch _ _ xs)) ->- let closed = s {aeOpenModal = Nothing}- in case B.listSelectedElement xs of- Nothing -> B.continue closed- Just (_, path) ->- B.continue $- selectPath- (shortestPathTo (aeActualStoreEnv s) (spName path))- closed- -- notices- (B.VtyEvent (V.EvKey k []), Just (ModalNotice _))- | k `elem` [V.KChar 'q', V.KEsc] ->- B.continue s {aeOpenModal = Nothing}- -- handle our events- (B.AppEvent (EventTick t), Nothing) ->- B.continue $ s {aeCurrTime = t}- -- ignore otherwise- _ ->- B.continue s,- B.appStartEvent = \s -> return s,- B.appAttrMap = \_ ->- B.attrMap- V.defAttr- [ (B.listSelectedFocusedAttr, V.currentAttr `V.withStyle` V.reverseVideo),- (attrTerminal, B.fg V.blue),- (attrUnderlined, V.currentAttr `V.withStyle` V.underline)- ]- }- where- allowedSearchChars :: Set Char- allowedSearchChars =- Set.fromList- ( mconcat- [ ['a' .. 'z'],- ['A' .. 'Z'],- ['0' .. '9'],- "+-.=?_"- ]- )--yankToClipboard :: StoreName s -> IO (Either Notice ())-yankToClipboard p =- Clipboard.copy (toText $ storeNameToPath p)- <&> \case- Right () -> Right ()- Left errs ->- Left $- Notice- "Error"- ( T.intercalate "\n" $- "Cannot copy to clipboard: " :- map (" " <>) errs- )--renderMainScreen :: AppEnv s -> B.Widget Widgets-renderMainScreen env@AppEnv {aePrevPane, aeCurrPane, aeNextPane} =- (B.joinBorders . B.border)- ( B.hBox- [ renderList Nothing True aePrevPane,- B.vBorder,- renderList shouldHighlightSortOrder True aeCurrPane,- B.vBorder,- renderList Nothing False aeNextPane- ]- )- B.<=> renderInfoPane env- where- shouldHighlightSortOrder =- let timePassed = Clock.diffTimeSpec (aeCurrTime env) (aeSortOrderLastChanged env)- in if timePassed < Clock.TimeSpec 0 (500 * 1_000_000)- then Just (aeSortOrder env)- else Nothing--renderInfoPane :: AppEnv s -> B.Widget Widgets-renderInfoPane env =- let selected = selectedPath env- immediateParents = psImmediateParents $ spPayload selected- in B.vBox- [ ( let (f, s) = storeNameToSplitShortText (spName selected)- in B.txt f B.<+> underlineWhen SortOrderAlphabetical (B.txt s)- ),- [ B.txt $ "NAR Size: " <> prettySize (spSize selected),- underlineWhen SortOrderClosureSize . B.txt $ "Closure Size: " <> prettySize (psTotalSize $ spPayload selected),- underlineWhen SortOrderAddedSize . B.txt $ "Added Size: " <> prettySize (psAddedSize $ spPayload selected)- ]- & intersperse (B.txt " | ")- & B.hBox,- B.txt $- if null immediateParents- then "Immediate Parents: -"- else- "Immediate Parents (" <> T.pack (show $ length immediateParents) <> "): "- <> T.intercalate ", " (map storeNameToShortText immediateParents)- ]- where- underlineWhen so =- if so == aeSortOrder env- then B.withAttr attrUnderlined- else identity--renderModal :: Text -> B.Widget a -> B.Widget a-renderModal title widget =- widget- & B.borderWithLabel (B.txt title)- & B.hLimitPercent 90- & B.vLimitPercent 60- & B.centerLayer--helpText :: Text-helpText =- T.intercalate- "\n"- [ "hjkl/Arrow Keys : Navigate",- "w : Open why-depends mode",- "/ : Open search mode",- "s : Change sort order",- "y : Yank selected path to clipboard",- "? : Show help",- "q/Esc: : Quit / close modal"- ]--helpNotice :: Notice-helpNotice = Notice "Help" helpText--renderNotice :: Notice -> B.Widget a-renderNotice (Notice title txt) = renderModal title (B.txt txt)--renderWhyDependsModal ::- B.GenericList Widgets Seq (NonEmpty (Path s)) ->- B.Widget Widgets-renderWhyDependsModal l =- B.renderList renderDepends True l- & B.hLimitPercent 100 -- This limit seems pointless, but otherwise render list takes infinite- -- amount of horizontal space and 'viewport' below complains.- & B.viewport WidgetWhyDependsViewport B.Horizontal- & renderModal "why-depends"- 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)- }--renderSearchModal :: Text -> Text -> B.GenericList Widgets Seq (Path s) -> B.Widget Widgets-renderSearchModal left right l =- renderModal "Search" window- where- window =- B.txt left B.<+> B.txt "|" B.<+> B.txt right- B.<=> B.hBorder- B.<=> renderList Nothing True l--showAndUpdateSearch :: Text -> Text -> AppEnv s -> AppEnv s-showAndUpdateSearch left right env@AppEnv {aeInvertedIndex} =- env {aeOpenModal = Just $ ModalSearch left right results}- where- results =- let xs =- iiSearch (left <> right) aeInvertedIndex- & Map.elems- & S.fromList- in B.list WidgetSearch xs 1--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, aeSortOrder} =- let ref = selectedPath env- in env- { aeNextPane =- B.listReplace- ( S.sortBy (compareBySortOrder aeSortOrder)- . S.fromList- . map (seLookup aeActualStoreEnv)- $ spRefs ref- )- (Just 0)- aeNextPane- }--sortPane :: SortOrder -> List s -> List s-sortPane so l =- let selected = B.listSelectedElement l- elems =- B.listElements l- & S.sortBy (compareBySortOrder so)- name = B.getName l- in mkList so name elems (snd <$> selected)--sortPanes :: AppEnv s -> AppEnv s-sortPanes env@AppEnv {aeParents, aePrevPane, aeCurrPane, aeNextPane, aeSortOrder} =- env- { aeCurrPane = sortPane aeSortOrder aeCurrPane,- aeNextPane = sortPane aeSortOrder aeNextPane,- aeParents = sortPane aeSortOrder <$> aeParents,- aePrevPane = sortPane aeSortOrder aePrevPane- }--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 -> error "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 (aeSortOrder env) WidgetPrevPane (S.fromList possible) (Just 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- emptyPane =- B.list WidgetPrevPane S.empty 0--mkList ::- SortOrder ->- n ->- Seq (Path s) ->- Maybe (Path s) ->- B.GenericList n Seq (Path s)-mkList sortOrder name possible selected =- let contents = S.sortBy (compareBySortOrder sortOrder) possible- in B.list name contents 1- & B.listMoveTo- (fromMaybe 0 $ selected >>= \s -> (((==) `on` spName) s) `S.findIndexL` contents)---- 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/Clipboard.hs
@@ -1,52 +0,0 @@-module Clipboard- ( copy,- )-where--import Control.Exception (try)-import System.Exit-import qualified System.Process.Typed as P--cmds :: [(FilePath, [String])]-cmds =- [ ("xsel", ["-i", "-b"]),- ("xclip", ["-selection", "clipboard"]),- ("wl-copy", []),- ("pbcopy", [])- ]--runCmd :: Text -> (FilePath, [String]) -> IO (Either Text ())-runCmd txt (cmd, args) =- P.proc (toString cmd) (map toString args)- & P.setStdin (P.byteStringInput $ encodeUtf8 txt)- & P.readProcess- & try- <&> \case- (Right (ExitSuccess, _, _)) -> Right ()- (Right (ExitFailure e, out, err)) ->- Left $- "Running " <> show (cmd, args) <> " "- <> "failed with exit code "- <> show e- <> ", "- <> "stdout: "- <> decodeUtf8 (toStrict out)- <> ", "- <> "stderr: "- <> decodeUtf8 (toStrict err)- <> "."- (Left (ex :: SomeException)) ->- Left $- "Running " <> show (cmd, args) <> " "- <> "failed with exception: "- <> show ex- <> "."--copy :: Text -> IO (Either [Text] ())-copy txt = go cmds []- where- go [] errs = return $ Left errs- go (x : xs) errs =- runCmd txt x >>= \case- Right () -> return $ Right ()- Left err -> go xs (err : errs)
+ src/Data/InvertedIndex.hs view
@@ -0,0 +1,76 @@+module Data.InvertedIndex+ ( InvertedIndex,+ iiFromList,+ iiInsert,+ iiSearch,+ )+where++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as Text++data InvertedIndex a = InvertedIndex+ { iiElems :: Map Text a,+ iiUnigrams :: Map Char (Set Text),+ iiBigrams :: Map (Char, Char) (Set Text),+ iiTrigrams :: Map (Char, Char, Char) (Set Text)+ }+ deriving (Generic, Show)++instance NFData a => NFData (InvertedIndex a)++iiInsert :: Text -> a -> InvertedIndex a -> InvertedIndex a+iiInsert txt val InvertedIndex {iiElems, iiUnigrams, iiBigrams, iiTrigrams} =+ InvertedIndex+ { iiElems = Map.insert txt val iiElems,+ iiUnigrams = combine iiUnigrams (unigramsOf txt),+ iiBigrams = combine iiBigrams (bigramsOf txt),+ iiTrigrams = combine iiTrigrams (trigramsOf txt)+ }+ where+ combine orig chrs =+ Map.unionWith+ (<>)+ orig+ (setToMap (Set.singleton txt) chrs)++iiFromList :: Foldable f => f (Text, a) -> InvertedIndex a+iiFromList =+ foldl'+ (flip (uncurry iiInsert))+ (InvertedIndex Map.empty Map.empty Map.empty Map.empty)++setToMap :: v -> Set k -> Map k v+setToMap v = Map.fromDistinctAscList . map (,v) . Set.toAscList++unigramsOf :: Text -> Set Char+unigramsOf = Set.fromList . Text.unpack . Text.toLower++bigramsOf :: Text -> Set (Char, Char)+bigramsOf txt = case Text.unpack (Text.toLower txt) of+ p1@(_ : p2) -> Set.fromList $ zip p1 p2+ _ -> Set.empty++trigramsOf :: Text -> Set (Char, Char, Char)+trigramsOf txt = case Text.unpack (Text.toLower txt) of+ p1@(_ : p2@(_ : p3)) -> Set.fromList $ zip3 p1 p2 p3+ _ -> Set.empty++iiSearch :: forall a. Text -> InvertedIndex a -> Map Text a+iiSearch txt InvertedIndex {iiElems, iiUnigrams, iiBigrams, iiTrigrams}+ | Text.length txt == 0 = iiElems+ | Text.length txt == 1 = using unigramsOf iiUnigrams+ | Text.length txt == 2 = using bigramsOf iiBigrams+ | otherwise = using trigramsOf iiTrigrams+ where+ lowerTxt = Text.toLower txt+ using :: Ord c => (Text -> Set c) -> Map c (Set Text) -> Map Text a+ using getGrams m =+ Map.intersection m (setToMap () (getGrams txt))+ & Map.elems+ & \case+ [] -> Set.empty+ x : xs -> foldl' Set.intersection x xs+ & Set.filter (\t -> lowerTxt `Text.isInfixOf` Text.toLower t)+ & Map.restrictKeys iiElems
− src/InvertedIndex.hs
@@ -1,76 +0,0 @@-module InvertedIndex- ( InvertedIndex,- iiFromList,- iiInsert,- iiSearch,- )-where--import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Text as Text--data InvertedIndex a = InvertedIndex- { iiElems :: Map Text a,- iiUnigrams :: Map Char (Set Text),- iiBigrams :: Map (Char, Char) (Set Text),- iiTrigrams :: Map (Char, Char, Char) (Set Text)- }- deriving (Generic, Show)--instance NFData a => NFData (InvertedIndex a)--iiInsert :: Text -> a -> InvertedIndex a -> InvertedIndex a-iiInsert txt val InvertedIndex {iiElems, iiUnigrams, iiBigrams, iiTrigrams} =- InvertedIndex- { iiElems = Map.insert txt val iiElems,- iiUnigrams = combine iiUnigrams (unigramsOf txt),- iiBigrams = combine iiBigrams (bigramsOf txt),- iiTrigrams = combine iiTrigrams (trigramsOf txt)- }- where- combine orig chrs =- Map.unionWith- (<>)- orig- (setToMap (Set.singleton txt) chrs)--iiFromList :: Foldable f => f (Text, a) -> InvertedIndex a-iiFromList =- foldl'- (flip (uncurry iiInsert))- (InvertedIndex Map.empty Map.empty Map.empty Map.empty)--setToMap :: v -> Set k -> Map k v-setToMap v = Map.fromDistinctAscList . map (,v) . Set.toAscList--unigramsOf :: Text -> Set Char-unigramsOf = Set.fromList . Text.unpack . Text.toLower--bigramsOf :: Text -> Set (Char, Char)-bigramsOf txt = case Text.unpack (Text.toLower txt) of- p1@(_ : p2) -> Set.fromList $ zip p1 p2- _ -> Set.empty--trigramsOf :: Text -> Set (Char, Char, Char)-trigramsOf txt = case Text.unpack (Text.toLower txt) of- p1@(_ : p2@(_ : p3)) -> Set.fromList $ zip3 p1 p2 p3- _ -> Set.empty--iiSearch :: forall a. Text -> InvertedIndex a -> Map Text a-iiSearch txt InvertedIndex {iiElems, iiUnigrams, iiBigrams, iiTrigrams}- | Text.length txt == 0 = iiElems- | Text.length txt == 1 = using unigramsOf iiUnigrams- | Text.length txt == 2 = using bigramsOf iiBigrams- | otherwise = using trigramsOf iiTrigrams- where- lowerTxt = Text.toLower txt- using :: Ord c => (Text -> Set c) -> Map c (Set Text) -> Map Text a- using getGrams m =- Map.intersection m (setToMap () (getGrams txt))- & Map.elems- & \case- [] -> Set.empty- x : xs -> foldl' Set.intersection x xs- & Set.filter (\t -> lowerTxt `Text.isInfixOf` Text.toLower t)- & Map.restrictKeys iiElems
− src/Main.hs
@@ -1,84 +0,0 @@-module Main where--import App-import Control.Concurrent (forkIO)-import qualified Data.HashMap.Strict as HM-import Data.Version (showVersion)-import PathStats-import Paths_nix_tree (version)-import System.Directory (canonicalizePath, doesDirectoryExist, getHomeDirectory)-import System.Environment (getArgs)-import System.Exit (ExitCode (..))-import System.FilePath ((</>))-import System.IO (hPutStr, hPutStrLn)--usage :: Text-usage =- unlines- [ "Usage: nix-tree [paths...] [-h|--help] [--version]",- " 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 . toString $ "Error: " <> msg- hPutStr stderr $ toString usage- exitWith (ExitFailure 1)--main :: IO ()-main = do- args <- getArgs- when (any (`elem` ["-h", "--help"]) args) $ do- putText usage- exitWith ExitSuccess-- when ("--version" `elem` args) $ do- putStrLn $ "nix-tree " ++ showVersion version- 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- evaluateNF_ 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/NixTree/App.hs view
@@ -0,0 +1,593 @@+module NixTree.App (run, helpText) where++import qualified Brick as B+import qualified Brick.BChan as B+import qualified Brick.Widgets.Border as B+import qualified Brick.Widgets.Center as B+import qualified Brick.Widgets.List as B+import Control.Concurrent+import Data.InvertedIndex+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import qualified Data.Sequence as S+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Graphics.Vty as V+import qualified NixTree.Clipboard as Clipboard+import NixTree.PathStats+import qualified System.Clock as Clock+import qualified System.HrfSize as HRF++data Event+ = EventTick Clock.TimeSpec++data Widgets+ = WidgetPrevPane+ | WidgetCurrPane+ | WidgetNextPane+ | WidgetWhyDepends+ | WidgetSearch+ | WidgetWhyDependsViewport+ deriving (Show, Eq, Ord)++data Notice = Notice Text Text++data Modal s+ = ModalNotice Notice+ | ModalWhyDepends (B.GenericList Widgets Seq (NonEmpty (Path s)))+ | ModalSearch Text Text (B.GenericList Widgets Seq (Path s))++succCycle :: forall a. (Bounded a, Enum a) => a -> a+succCycle a+ | fromEnum a == fromEnum (maxBound @a) = minBound+ | otherwise = succ a++data AppEnv s = AppEnv+ { aeActualStoreEnv :: StoreEnv s (PathStats s),+ aeInvertedIndex :: InvertedIndex (Path s),+ aePrevPane :: List s,+ aeCurrPane :: List s,+ aeNextPane :: List s,+ aeParents :: [List s],+ aeOpenModal :: Maybe (Modal s),+ aeSortOrder :: SortOrder,+ aeSortOrderLastChanged :: Clock.TimeSpec,+ aeCurrTime :: Clock.TimeSpec+ }++type Path s = StorePath s (StoreName s) (PathStats s)++type List s = B.GenericList Widgets Seq (Path s)++data SortOrder+ = SortOrderAlphabetical+ | SortOrderClosureSize+ | SortOrderAddedSize+ deriving (Show, Eq, Enum, Bounded)++compareBySortOrder :: SortOrder -> Path s -> Path s -> Ordering+compareBySortOrder SortOrderAlphabetical = compare `on` T.toLower . storeNameToShortText . spName+compareBySortOrder SortOrderClosureSize = compare `on` Down . psTotalSize . spPayload+compareBySortOrder SortOrderAddedSize = compare `on` Down . psAddedSize . spPayload++attrTerminal, attrUnderlined :: B.AttrName+attrTerminal = "terminal"+attrUnderlined = "underlined"++run :: StoreEnv s (PathStats s) -> IO ()+run env = do+ -- Create the inverted index, and start evaluating it in the background+ let ii = iiFromList . toList . fmap (\sp -> (storeNameToText (spName sp), sp)) $ seAll env+ _ <- forkIO $ evaluateNF_ ii++ -- Initial state+ let getTime = Clock.getTime Clock.Monotonic+ currTime <- getTime+ let defaultSortOrder = SortOrderClosureSize++ let appEnv =+ AppEnv+ { aeActualStoreEnv =+ env,+ aeInvertedIndex =+ ii,+ aePrevPane =+ B.list WidgetPrevPane S.empty 0,+ aeCurrPane =+ B.list+ WidgetCurrPane+ (S.fromList . sortBy (compareBySortOrder defaultSortOrder) . NE.toList $ seGetRoots env)+ 0,+ aeNextPane =+ B.list WidgetNextPane S.empty 0,+ aeParents =+ [],+ aeOpenModal =+ Nothing,+ aeSortOrder =+ defaultSortOrder,+ aeSortOrderLastChanged =+ Clock.TimeSpec 0 0,+ aeCurrTime =+ currTime+ }+ & repopulateNextPane++ -- Create a channel that's fed by current time+ chan <- B.newBChan 10+ void . forkIO $+ forever $ do+ threadDelay (100 * 1000)+ t <- getTime+ _ <- B.writeBChanNonBlocking chan (EventTick t)+ return ()++ -- And run the application+ let mkVty = V.mkVty V.defaultConfig+ initialVty <- mkVty+ _ <- B.customMain initialVty mkVty (Just chan) app appEnv++ return ()++renderList ::+ Maybe SortOrder ->+ Bool ->+ List s ->+ B.Widget Widgets+renderList highlightSort isFocused =+ B.renderList+ ( \_+ StorePath+ { spName,+ spPayload = PathStats {psTotalSize, psAddedSize},+ spRefs+ } ->+ let color =+ if null spRefs+ then B.withAttr attrTerminal+ else identity+ in color $+ B.hBox+ [ B.txt (storeNameToShortText spName)+ & underlineWhen SortOrderAlphabetical+ & B.padRight (B.Pad 1)+ & B.padRight B.Max,+ if null spRefs+ then+ B.txt (prettySize psTotalSize)+ & underlineWhen SortOrderClosureSize+ & underlineWhen SortOrderAddedSize+ else+ B.hBox+ [ B.txt (prettySize psTotalSize)+ & underlineWhen SortOrderClosureSize,+ B.txt " (",+ B.txt (prettySize psAddedSize)+ & underlineWhen SortOrderAddedSize,+ B.txt ")"+ ]+ ]+ )+ isFocused+ where+ underlineWhen so =+ if Just so == highlightSort+ then B.withDefAttr attrUnderlined+ else identity++app :: B.App (AppEnv s) Event Widgets+app =+ B.App+ { B.appDraw = \env@AppEnv {aeOpenModal} ->+ [ case aeOpenModal of+ Nothing -> B.emptyWidget+ Just (ModalWhyDepends l) -> renderWhyDependsModal l+ Just (ModalSearch l r xs) -> renderSearchModal l r xs+ Just (ModalNotice notice) -> renderNotice notice,+ 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 (ModalNotice helpNotice)}+ (B.VtyEvent (V.EvKey (V.KChar 'w') []), Nothing) -> do+ B.hScrollToBeginning (B.viewportScroll WidgetWhyDependsViewport)+ B.continue $ showWhyDepends s+ (B.VtyEvent (V.EvKey (V.KChar '/') []), Nothing) ->+ B.continue $ showAndUpdateSearch "" "" s+ (B.VtyEvent (V.EvKey (V.KChar 'y') []), Nothing) -> do+ liftIO (yankToClipboard $ spName (selectedPath s))+ >>= \case+ Right () -> B.continue s+ Left n -> B.continue s {aeOpenModal = Just (ModalNotice n)}+ (B.VtyEvent (V.EvKey (V.KChar 's') []), Nothing) ->+ B.continue $+ s+ { aeSortOrder = succCycle (aeSortOrder s),+ aeSortOrderLastChanged = aeCurrTime s+ }+ & sortPanes+ (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, V.KChar '\t'] ->+ B.continue $ move B.listMoveDown s+ (B.VtyEvent (V.EvKey k []), Nothing)+ | k `elem` [V.KChar 'k', V.KUp, V.KBackTab] ->+ 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+ -- why-depends modal+ (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends _))+ | k `elem` [V.KChar 'q', V.KEsc] ->+ B.continue s {aeOpenModal = Nothing}+ (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends _))+ | k `elem` [V.KChar 'h', V.KLeft] -> do+ B.hScrollBy (B.viewportScroll WidgetWhyDependsViewport) (-1)+ B.continue s+ (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends l))+ | k `elem` [V.KChar 'j', V.KDown, V.KChar '\t'] ->+ B.continue s {aeOpenModal = Just $ ModalWhyDepends (B.listMoveDown l)}+ (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends l))+ | k `elem` [V.KChar 'k', V.KUp, V.KBackTab] ->+ B.continue s {aeOpenModal = Just $ ModalWhyDepends (B.listMoveUp l)}+ (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends _))+ | k `elem` [V.KChar 'l', V.KRight] -> do+ B.hScrollBy (B.viewportScroll WidgetWhyDependsViewport) 1+ B.continue s+ (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+ -- search modal+ (B.VtyEvent (V.EvKey V.KEsc []), Just (ModalSearch _ _ _)) ->+ B.continue s {aeOpenModal = Nothing}+ (B.VtyEvent (V.EvKey k []), Just (ModalSearch l r xs))+ | k `elem` [V.KDown, V.KChar '\t'] ->+ B.continue s {aeOpenModal = Just $ ModalSearch l r (B.listMoveDown xs)}+ (B.VtyEvent (V.EvKey k []), Just (ModalSearch l r xs))+ | k `elem` [V.KUp, V.KBackTab] ->+ B.continue s {aeOpenModal = Just $ ModalSearch l r (B.listMoveUp xs)}+ (B.VtyEvent (V.EvKey V.KLeft []), Just (ModalSearch l r xs)) ->+ B.continue+ s+ { aeOpenModal =+ Just $ ModalSearch (T.dropEnd 1 l) (T.takeEnd 1 l <> r) (B.listMoveUp xs)+ }+ (B.VtyEvent (V.EvKey V.KRight []), Just (ModalSearch l r xs)) ->+ B.continue+ s+ { aeOpenModal =+ Just $ ModalSearch (l <> T.take 1 r) (T.drop 1 r) (B.listMoveUp xs)+ }+ (B.VtyEvent (V.EvKey (V.KChar c) []), Just (ModalSearch l r _))+ | c `Set.member` allowedSearchChars ->+ B.continue (showAndUpdateSearch (l <> T.singleton c) r s)+ (B.VtyEvent (V.EvKey (V.KBS) []), Just (ModalSearch l r _)) ->+ B.continue (showAndUpdateSearch (T.dropEnd 1 l) r s)+ (B.VtyEvent (V.EvKey V.KEnter []), Just (ModalSearch _ _ xs)) ->+ let closed = s {aeOpenModal = Nothing}+ in case B.listSelectedElement xs of+ Nothing -> B.continue closed+ Just (_, path) ->+ B.continue $+ selectPath+ (shortestPathTo (aeActualStoreEnv s) (spName path))+ closed+ -- notices+ (B.VtyEvent (V.EvKey k []), Just (ModalNotice _))+ | k `elem` [V.KChar 'q', V.KEsc] ->+ B.continue s {aeOpenModal = Nothing}+ -- handle our events+ (B.AppEvent (EventTick t), Nothing) ->+ B.continue $ s {aeCurrTime = t}+ -- ignore otherwise+ _ ->+ B.continue s,+ B.appStartEvent = \s -> return s,+ B.appAttrMap = \_ ->+ B.attrMap+ V.defAttr+ [ (B.listSelectedFocusedAttr, V.currentAttr `V.withStyle` V.reverseVideo),+ (attrTerminal, B.fg V.blue),+ (attrUnderlined, V.currentAttr `V.withStyle` V.underline)+ ]+ }+ where+ allowedSearchChars :: Set Char+ allowedSearchChars =+ Set.fromList+ ( mconcat+ [ ['a' .. 'z'],+ ['A' .. 'Z'],+ ['0' .. '9'],+ "+-.=?_"+ ]+ )++yankToClipboard :: StoreName s -> IO (Either Notice ())+yankToClipboard p =+ Clipboard.copy (toText $ storeNameToPath p)+ <&> \case+ Right () -> Right ()+ Left errs ->+ Left $+ Notice+ "Error"+ ( T.intercalate "\n" $+ "Cannot copy to clipboard: " :+ map (" " <>) errs+ ++ ["Please report this as a bug."]+ )++renderMainScreen :: AppEnv s -> B.Widget Widgets+renderMainScreen env@AppEnv {aePrevPane, aeCurrPane, aeNextPane} =+ (B.joinBorders . B.border)+ ( B.hBox+ [ renderList Nothing True aePrevPane,+ B.vBorder,+ renderList shouldHighlightSortOrder True aeCurrPane,+ B.vBorder,+ renderList Nothing False aeNextPane+ ]+ )+ B.<=> renderInfoPane env+ where+ shouldHighlightSortOrder =+ let timePassed = Clock.diffTimeSpec (aeCurrTime env) (aeSortOrderLastChanged env)+ in if timePassed < Clock.TimeSpec 0 (500 * 1_000_000)+ then Just (aeSortOrder env)+ else Nothing++renderInfoPane :: AppEnv s -> B.Widget Widgets+renderInfoPane env =+ let selected = selectedPath env+ immediateParents = psImmediateParents $ spPayload selected+ in B.vBox+ [ ( let (f, s) = storeNameToSplitShortText (spName selected)+ in B.txt f B.<+> underlineWhen SortOrderAlphabetical (B.txt s)+ ),+ [ B.txt $ "NAR Size: " <> prettySize (spSize selected),+ underlineWhen SortOrderClosureSize . B.txt $ "Closure Size: " <> prettySize (psTotalSize $ spPayload selected),+ underlineWhen SortOrderAddedSize . B.txt $ "Added Size: " <> prettySize (psAddedSize $ spPayload selected)+ ]+ & intersperse (B.txt " | ")+ & B.hBox,+ B.txt $+ if null immediateParents+ then "Immediate Parents: -"+ else+ "Immediate Parents (" <> T.pack (show $ length immediateParents) <> "): "+ <> T.intercalate ", " (map storeNameToShortText immediateParents)+ ]+ where+ underlineWhen so =+ if so == aeSortOrder env+ then B.withAttr attrUnderlined+ else identity++renderModal :: Text -> B.Widget a -> B.Widget a+renderModal title widget =+ widget+ & B.borderWithLabel (B.txt title)+ & B.hLimitPercent 90+ & B.vLimitPercent 60+ & B.centerLayer++helpText :: Text+helpText =+ T.intercalate+ "\n"+ [ "hjkl/Arrow Keys : Navigate",+ "w : Open why-depends mode",+ "/ : Open search mode",+ "s : Change sort order",+ "y : Yank selected path to clipboard",+ "? : Show help",+ "q/Esc: : Quit / close modal"+ ]++helpNotice :: Notice+helpNotice = Notice "Help" helpText++renderNotice :: Notice -> B.Widget a+renderNotice (Notice title txt) = renderModal title (B.txt txt)++renderWhyDependsModal ::+ B.GenericList Widgets Seq (NonEmpty (Path s)) ->+ B.Widget Widgets+renderWhyDependsModal l =+ B.renderList renderDepends True l+ & B.hLimitPercent 100 -- This limit seems pointless, but otherwise render list takes infinite+ -- amount of horizontal space and 'viewport' below complains.+ & B.viewport WidgetWhyDependsViewport B.Horizontal+ & renderModal "why-depends"+ 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)+ }++renderSearchModal :: Text -> Text -> B.GenericList Widgets Seq (Path s) -> B.Widget Widgets+renderSearchModal left right l =+ renderModal "Search" window+ where+ window =+ B.txt left B.<+> B.txt "|" B.<+> B.txt right+ B.<=> B.hBorder+ B.<=> renderList Nothing True l++showAndUpdateSearch :: Text -> Text -> AppEnv s -> AppEnv s+showAndUpdateSearch left right env@AppEnv {aeInvertedIndex} =+ env {aeOpenModal = Just $ ModalSearch left right results}+ where+ results =+ let xs =+ iiSearch (left <> right) aeInvertedIndex+ & Map.elems+ & S.fromList+ in B.list WidgetSearch xs 1++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, aeSortOrder} =+ let ref = selectedPath env+ in env+ { aeNextPane =+ B.listReplace+ ( S.sortBy (compareBySortOrder aeSortOrder)+ . S.fromList+ . map (seLookup aeActualStoreEnv)+ $ spRefs ref+ )+ (Just 0)+ aeNextPane+ }++sortPane :: SortOrder -> List s -> List s+sortPane so l =+ let selected = B.listSelectedElement l+ elems =+ B.listElements l+ & S.sortBy (compareBySortOrder so)+ name = B.getName l+ in mkList so name elems (snd <$> selected)++sortPanes :: AppEnv s -> AppEnv s+sortPanes env@AppEnv {aeParents, aePrevPane, aeCurrPane, aeNextPane, aeSortOrder} =+ env+ { aeCurrPane = sortPane aeSortOrder aeCurrPane,+ aeNextPane = sortPane aeSortOrder aeNextPane,+ aeParents = sortPane aeSortOrder <$> aeParents,+ aePrevPane = sortPane aeSortOrder aePrevPane+ }++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 -> error "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 (aeSortOrder env) WidgetPrevPane (S.fromList possible) (Just 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+ emptyPane =+ B.list WidgetPrevPane S.empty 0++mkList ::+ SortOrder ->+ n ->+ Seq (Path s) ->+ Maybe (Path s) ->+ B.GenericList n Seq (Path s)+mkList sortOrder name possible selected =+ let contents = S.sortBy (compareBySortOrder sortOrder) possible+ in B.list name contents 1+ & B.listMoveTo+ (fromMaybe 0 $ selected >>= \s -> (((==) `on` spName) s) `S.findIndexL` contents)++-- 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/NixTree/Clipboard.hs view
@@ -0,0 +1,53 @@+module NixTree.Clipboard+ ( copy,+ )+where++import Control.Exception (try)+import System.Exit+import qualified System.Process.Typed as P+import System.Timeout++cmds :: [(FilePath, [String])]+cmds =+ [ ("xsel", ["-i", "-b"]),+ ("xclip", ["-selection", "clipboard"]),+ ("wl-copy", []),+ ("pbcopy", [])+ ]++runCmd :: Text -> (FilePath, [String]) -> IO (Either Text ())+runCmd txt (cmd, args) =+ P.proc (toString cmd) (map toString args)+ & P.setStdin (P.byteStringInput $ encodeUtf8 txt)+ & P.readProcess+ & timeout 1_000_000+ & try+ <&> \case+ Right (Just (ExitSuccess, _, _)) -> Right ()+ Right (Just (ExitFailure e, out, err)) ->+ Left $+ "failed with exit code "+ <> show e+ <> ", "+ <> "stdout: "+ <> decodeUtf8 (toStrict out)+ <> ", "+ <> "stderr: "+ <> decodeUtf8 (toStrict err)+ Right Nothing ->+ Left $ "timed out"+ Left (ex :: SomeException) ->+ Left $ "failed with exception: " <> show ex+ <&> \case+ Right () -> Right ()+ Left err -> Left ("Running " <> show (cmd, args) <> " " <> err <> ".")++copy :: Text -> IO (Either [Text] ())+copy txt = go cmds []+ where+ go [] errs = return $ Left errs+ go (x : xs) errs =+ runCmd txt x >>= \case+ Right () -> return $ Right ()+ Left err -> go xs (err : errs)
+ src/NixTree/Main.hs view
@@ -0,0 +1,78 @@+module Main where++import Control.Concurrent.Async+import Control.Exception (evaluate)+import Data.Version (showVersion)+import NixTree.App+import NixTree.PathStats+import Paths_nix_tree (version)+import System.Directory (canonicalizePath, doesDirectoryExist, getHomeDirectory)+import System.Environment (getArgs)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.IO (hPutStr, hPutStrLn)+import System.ProgressBar hiding (msg)++usage :: Text+usage =+ unlines+ [ "Usage: nix-tree [paths...] [-h|--help] [--version]",+ " 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 . toString $ "Error: " <> msg+ hPutStr stderr $ toString usage+ exitWith (ExitFailure 1)++main :: IO ()+main = do+ args <- getArgs+ when (any (`elem` ["-h", "--help"]) args) $ do+ putText usage+ exitWith ExitSuccess++ when ("--version" `elem` args) $ do+ putStrLn $ "nix-tree " ++ showVersion version+ 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'+ allPaths = seAll env++ bar <- newProgressBar defStyle {stylePostfix = exact} 4 (Progress 0 (length allPaths) ())+ allPaths+ & toList+ & chunks 50+ & mapConcurrently_ (mapM_ (\p -> evaluate (rnf p) >> incProgress bar 1))++ run env++ case ret of+ Right () -> return ()+ Left err ->+ usageAndFail $ "Not a store path: " <> show err++chunks :: Int -> [a] -> [[a]]+chunks _ [] = []+chunks n xs =+ let (ys, zs) = splitAt n xs+ in ys : chunks n zs
+ src/NixTree/PathStats.hs view
@@ -0,0 +1,137 @@+module NixTree.PathStats+ ( PathStats (..),+ calculatePathStats,+ whyDepends,+ shortestPathTo,+ module NixTree.StorePath,+ )+where++import Data.List (minimumBy)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Lazy as M+import qualified Data.Set as S+import NixTree.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 env =+ seBottomUp $ \curr ->+ IntermediatePathStats+ { ipsAllRefs =+ M.unions+ ( M.fromList+ [ (spName, const () <$> sp)+ | sp@StorePath {spName} <- spRefs curr,+ env 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 e =+ seGetRoots e+ & 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++-- TODO: This can be precomputed.+shortestPathTo :: StoreEnv s a -> StoreName s -> NonEmpty (StorePath s (StoreName s) a)+shortestPathTo env name =+ seBottomUp+ ( \curr ->+ let currOut = curr {spRefs = spName <$> spRefs curr}+ in if spName curr == name+ then Just (1 :: Int, currOut :| [])+ else+ spRefs curr+ & fmap spPayload+ & catMaybes+ & \case+ [] -> Nothing+ xs -> case minimumBy (comparing fst) xs of+ (c, p) -> Just (c + 1, currOut NE.<| p)+ )+ env+ & seGetRoots+ & fmap spPayload+ & NE.toList+ & catMaybes+ & minimumBy (comparing fst)+ & snd+ & NE.reverse
+ src/NixTree/StorePath.hs view
@@ -0,0 +1,297 @@+module NixTree.StorePath+ ( StoreName (..),+ storeNameToPath,+ storeNameToText,+ storeNameToShortText,+ storeNameToSplitShortText,+ StorePath (..),+ StoreEnv (..),+ withStoreEnv,+ seLookup,+ seAll,+ seGetRoots,+ seBottomUp,+ seFetchRefs,+ getNixStore,+ mkStoreName,+ )+where++import Data.Aeson (FromJSON (..), Value (..), decode, (.:))+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.List (partition)+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import System.FilePath.Posix (addTrailingPathSeparator, splitDirectories, (</>))+import System.Process.Typed (proc, readProcessStdout_)++-- Technically these both are filepaths. However, most people use the default "/nix/store",+-- hence special casing it speeds things up.+data NixStore+ = NixStore+ | NixStoreCustom FilePath+ deriving stock (Show, Eq, Ord, Generic)+ deriving anyclass (NFData, Hashable)++mkNixStore :: FilePath -> NixStore+mkNixStore i' =+ let i = addTrailingPathSeparator i'+ in if i == "/nix/store/" then NixStore else NixStoreCustom i++unNixStore :: NixStore -> FilePath+unNixStore NixStore = "/nix/store/"+unNixStore (NixStoreCustom fp) = fp++getNixStore :: IO NixStore+getNixStore = do+ let prog = "nix-instantiate"+ args = ["--eval", "--expr", "(builtins.storeDir)", "--json"]+ out <-+ readProcessStdout_ (proc prog args)+ <&> fmap mkNixStore . decode @FilePath+ case out of+ Nothing -> fail $ "Error interpreting output of: " ++ show (prog, args)+ Just p -> return p++--------------------------------------------------------------------------------++data StoreName s = StoreName NixStore Text+ deriving stock (Show, Eq, Ord, Generic)+ deriving anyclass (NFData, Hashable)++mkStoreName :: NixStore -> FilePath -> Maybe (StoreName a)+mkStoreName ns path = do+ let ps = unNixStore ns+ guard $ ps `isPrefixOf` path+ let ds = splitDirectories (drop (length ps) path)+ sn <- listToMaybe ds+ return $ StoreName ns (toText sn)++storeNameToText :: StoreName a -> Text+storeNameToText (StoreName _ n) = n++storeNameToPath :: StoreName a -> FilePath+storeNameToPath (StoreName ns sn) = unNixStore ns </> toString sn++storeNameToShortText :: StoreName a -> Text+storeNameToShortText = snd . storeNameToSplitShortText++storeNameToSplitShortText :: StoreName a -> (Text, Text)+storeNameToSplitShortText txt =+ case T.span (/= '-') . T.pack $ storeNameToPath txt of+ (f, s) | Just (c, s'') <- T.uncons s -> (T.snoc f c, s'')+ e -> e++--------------------------------------------------------------------------------++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+ nixStore <- getNixStore+ -- See: https://github.com/utdemir/nix-tree/issues/12+ --+ -- > In Nix < 2.4, when you pass a .drv to path-info, it returns information about the store+ -- > derivation. However, when you do the same in 2.4, it "resolves" it and works on+ -- > the output of given derivation; to actually work on the derivation you need to pass+ -- > --derivation.+ isAtLeastNix24 <- (>= Just "2.4") <$> getNixVersion+ let (derivations, outputs) =+ partition+ (\i -> ".drv" `T.isSuffixOf` storeNameToText i)+ (NE.toList names)+ (++)+ <$> maybe (return []) (getPathInfo nixStore False) (NE.nonEmpty outputs)+ <*> maybe (return []) (getPathInfo nixStore (True && isAtLeastNix24)) (NE.nonEmpty derivations)+ where+ getNixVersion :: IO (Maybe Text)+ getNixVersion = do+ out <- decodeUtf8 . BL.toStrict <$> readProcessStdout_ (proc "nix" ["--version"])+ return . viaNonEmpty last $ T.splitOn " " out++getPathInfo :: NixStore -> Bool -> NonEmpty (StoreName s) -> IO [StorePath s (StoreName s) ()]+getPathInfo nixStore isDrv names = do+ infos <-+ decode @[NixPathInfoResult]+ <$> readProcessStdout_+ ( proc+ "nix"+ ( ["path-info", "--recursive", "--json"]+ ++ (if isDrv then ["--derivation"] else [])+ ++ 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 nixStore p)++ assertValidInfo (NixPathInfoValid pathinfo) = return pathinfo+ 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+ nixStore <- liftIO getNixStore++ let names' =+ fnames+ & toList+ & map (\f -> maybe (Left f) Right (mkStoreName nixStore f))+ & partitionEithers++ case names' of+ (errs@(_ : _), _) -> return (Left errs)+ ([], xs) -> case nonEmpty xs of+ Nothing -> error "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+ (error $ "invariant violation, StoreName not found: " <> show name)+ (HM.lookup name sePaths)++seAll :: StoreEnv s a -> NonEmpty (StorePath s (StoreName s) a)+seAll StoreEnv {sePaths} = case HM.elems sePaths of+ [] -> error "invariant violation: no paths"+ (x : xs) -> x :| xs++seGetRoots :: StoreEnv s a -> NonEmpty (StorePath s (StoreName s) a)+seGetRoots env@StoreEnv {seRoots} =+ fmap (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+ (error $ "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+ processed <- gets snd+ case name `HM.lookup` processed 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."
− src/PathStats.hs
@@ -1,137 +0,0 @@-module PathStats- ( PathStats (..),- calculatePathStats,- whyDepends,- shortestPathTo,- module StorePath,- )-where--import Data.List (minimumBy)-import qualified Data.List.NonEmpty as NE-import qualified Data.Map.Lazy as M-import qualified Data.Set as S-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 env =- seBottomUp $ \curr ->- IntermediatePathStats- { ipsAllRefs =- M.unions- ( M.fromList- [ (spName, const () <$> sp)- | sp@StorePath {spName} <- spRefs curr,- env 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 e =- seGetRoots e- & 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---- TODO: This can be precomputed.-shortestPathTo :: StoreEnv s a -> StoreName s -> NonEmpty (StorePath s (StoreName s) a)-shortestPathTo env name =- seBottomUp- ( \curr ->- let currOut = curr {spRefs = spName <$> spRefs curr}- in if spName curr == name- then Just (1 :: Int, currOut :| [])- else- spRefs curr- & fmap spPayload- & catMaybes- & \case- [] -> Nothing- xs -> case minimumBy (comparing fst) xs of- (c, p) -> Just (c + 1, currOut NE.<| p)- )- env- & seGetRoots- & fmap spPayload- & NE.toList- & catMaybes- & minimumBy (comparing fst)- & snd- & NE.reverse
− src/StorePath.hs
@@ -1,283 +0,0 @@-module StorePath- ( StoreName (..),- storeNameToPath,- storeNameToText,- storeNameToShortText,- storeNameToSplitShortText,- StorePath (..),- StoreEnv (..),- withStoreEnv,- seLookup,- seAll,- seGetRoots,- seBottomUp,- seFetchRefs,- getNixStore,- mkStoreName,- )-where--import Data.Aeson (FromJSON (..), Value (..), decode, (.:))-import qualified Data.ByteString.Lazy as BL-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import Data.List (partition)-import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T-import System.FilePath.Posix (addTrailingPathSeparator, splitDirectories, (</>))-import System.Process.Typed (proc, readProcessStdout_)--newtype NixStore = NixStore FilePath- deriving newtype (Show, Eq, Ord, NFData, Hashable)--getNixStore :: IO NixStore-getNixStore = do- let prog = "nix-instantiate"- args = ["--eval", "--expr", "(builtins.storeDir)", "--json"]- out <-- readProcessStdout_ (proc prog args)- <&> fmap addTrailingPathSeparator . decode @FilePath- <&> fmap NixStore- case out of- Nothing -> fail $ "Error interpreting output of: " ++ show (prog, args)- Just p -> return p------------------------------------------------------------------------------------data StoreName s = StoreName NixStore Text- deriving stock (Show, Eq, Ord, Generic)- deriving anyclass (NFData, Hashable)--mkStoreName :: NixStore -> FilePath -> Maybe (StoreName a)-mkStoreName ns@(NixStore ps) path = do- guard $ ps `isPrefixOf` path- let ds = splitDirectories (drop (length ps) path)- sn <- listToMaybe ds- return $ StoreName ns (toText sn)--storeNameToText :: StoreName a -> Text-storeNameToText (StoreName _ n) = n--storeNameToPath :: StoreName a -> FilePath-storeNameToPath (StoreName (NixStore ns) sn) = ns </> toString sn--storeNameToShortText :: StoreName a -> Text-storeNameToShortText = snd . storeNameToSplitShortText--storeNameToSplitShortText :: StoreName a -> (Text, Text)-storeNameToSplitShortText txt =- case T.span (/= '-') . T.pack $ storeNameToPath txt of- (f, s) | Just (c, s'') <- T.uncons s -> (T.snoc f c, s'')- e -> e------------------------------------------------------------------------------------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- nixStore <- getNixStore- -- See: https://github.com/utdemir/nix-tree/issues/12- --- -- > In Nix < 2.4, when you pass a .drv to path-info, it returns information about the store- -- > derivation. However, when you do the same in 2.4, it "resolves" it and works on- -- > the output of given derivation; to actually work on the derivation you need to pass- -- > --derivation.- isAtLeastNix24 <- (>= Just "2.4") <$> getNixVersion- let (derivations, outputs) =- partition- (\i -> ".drv" `T.isSuffixOf` storeNameToText i)- (NE.toList names)- (++)- <$> maybe (return []) (getPathInfo nixStore False) (NE.nonEmpty outputs)- <*> maybe (return []) (getPathInfo nixStore (True && isAtLeastNix24)) (NE.nonEmpty derivations)- where- getNixVersion :: IO (Maybe Text)- getNixVersion = do- out <- decodeUtf8 . BL.toStrict <$> readProcessStdout_ (proc "nix" ["--version"])- return . viaNonEmpty last $ T.splitOn " " out--getPathInfo :: NixStore -> Bool -> NonEmpty (StoreName s) -> IO [StorePath s (StoreName s) ()]-getPathInfo nixStore isDrv names = do- infos <-- decode @[NixPathInfoResult]- <$> readProcessStdout_- ( proc- "nix"- ( ["path-info", "--recursive", "--json"]- ++ (if isDrv then ["--derivation"] else [])- ++ 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 nixStore p)-- assertValidInfo (NixPathInfoValid pathinfo) = return pathinfo- 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- nixStore <- liftIO getNixStore-- let names' =- fnames- & toList- & map (\f -> maybe (Left f) Right (mkStoreName nixStore f))- & partitionEithers-- case names' of- (errs@(_ : _), _) -> return (Left errs)- ([], xs) -> case nonEmpty xs of- Nothing -> error "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- (error $ "invariant violation, StoreName not found: " <> show name)- (HM.lookup name sePaths)--seAll :: StoreEnv s a -> NonEmpty (StorePath s (StoreName s) a)-seAll StoreEnv {sePaths} = case HM.elems sePaths of- [] -> error "invariant violation: no paths"- (x : xs) -> x :| xs--seGetRoots :: StoreEnv s a -> NonEmpty (StorePath s (StoreName s) a)-seGetRoots env@StoreEnv {seRoots} =- fmap (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- (error $ "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- processed <- gets snd- case name `HM.lookup` processed 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."
test/Test.hs view
@@ -2,39 +2,11 @@ module Main where -import qualified Data.Map as Map-import qualified Data.Text as Text import Hedgehog-import qualified Hedgehog.Gen as Gen import Hedgehog.Main-import qualified Hedgehog.Range as Range-import InvertedIndex--prop_inverted_index :: Property-prop_inverted_index = withDiscards 10000 . withTests 10000 . property $ do- haystack <-- forAll $- Gen.map- (Range.linear 0 100)- ( (,)- <$> Gen.text (Range.linear 0 10) Gen.alphaNum- <*> Gen.int (Range.linear 0 100)- )-- needle <-- forAll $- (Gen.text (Range.linear 0 5) Gen.alphaNum)-- let ii = iiFromList (Map.toList haystack)- annotateShow ii-- let expected =- haystack- & Map.filterWithKey- (\t _ -> Text.toLower needle `Text.isInfixOf` Text.toLower t)- actual = iiSearch needle ii-- expected === actual+import qualified Test.Data.InvertedIndex main :: IO ()-main = defaultMain [checkParallel $$(discover)]+main =+ defaultMain . map checkParallel $+ [Test.Data.InvertedIndex.tests]
+ test/Test/Data/InvertedIndex.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.Data.InvertedIndex (tests) where++import Data.InvertedIndex+import qualified Data.Map as Map+import qualified Data.Text as Text+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++prop_inverted_index :: Property+prop_inverted_index = withDiscards 10000 . withTests 10000 . property $ do+ haystack <-+ forAll $+ Gen.map+ (Range.linear 0 100)+ ( (,)+ <$> Gen.text (Range.linear 0 10) Gen.alphaNum+ <*> Gen.int (Range.linear 0 100)+ )++ needle <-+ forAll $+ (Gen.text (Range.linear 0 5) Gen.alphaNum)++ let ii = iiFromList (Map.toList haystack)+ annotateShow ii++ let expected =+ haystack+ & Map.filterWithKey+ (\t _ -> Text.toLower needle `Text.isInfixOf` Text.toLower t)+ actual = iiSearch needle ii++ expected === actual++tests :: Group+tests = $$(discover)