diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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') diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,24 +3,30 @@ ![Build Status](https://github.com/utdemir/nix-tree/workflows/nix-build/badge.svg) [![Packaging status](https://repology.org/badge/vertical-allrepos/haskell:nix-tree.svg)](https://repology.org/project/haskell:nix-tree/versions) -Interactively browse the dependency graph of your Nix derivations. +Interactively browse dependency graphs of Nix derivations. [![asciicast](https://asciinema.org/a/cnilbmPXW51g97hdNJZcM5F6h.svg)](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 '' -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) diff --git a/nix-tree.cabal b/nix-tree.cabal --- a/nix-tree.cabal +++ b/nix-tree.cabal @@ -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 diff --git a/src/App.hs b/src/App.hs deleted file mode 100644 --- a/src/App.hs +++ /dev/null @@ -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" diff --git a/src/Clipboard.hs b/src/Clipboard.hs deleted file mode 100644 --- a/src/Clipboard.hs +++ /dev/null @@ -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) diff --git a/src/Data/InvertedIndex.hs b/src/Data/InvertedIndex.hs new file mode 100644 --- /dev/null +++ b/src/Data/InvertedIndex.hs @@ -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 diff --git a/src/InvertedIndex.hs b/src/InvertedIndex.hs deleted file mode 100644 --- a/src/InvertedIndex.hs +++ /dev/null @@ -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 diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -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 diff --git a/src/NixTree/App.hs b/src/NixTree/App.hs new file mode 100644 --- /dev/null +++ b/src/NixTree/App.hs @@ -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" diff --git a/src/NixTree/Clipboard.hs b/src/NixTree/Clipboard.hs new file mode 100644 --- /dev/null +++ b/src/NixTree/Clipboard.hs @@ -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) diff --git a/src/NixTree/Main.hs b/src/NixTree/Main.hs new file mode 100644 --- /dev/null +++ b/src/NixTree/Main.hs @@ -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 diff --git a/src/NixTree/PathStats.hs b/src/NixTree/PathStats.hs new file mode 100644 --- /dev/null +++ b/src/NixTree/PathStats.hs @@ -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 diff --git a/src/NixTree/StorePath.hs b/src/NixTree/StorePath.hs new file mode 100644 --- /dev/null +++ b/src/NixTree/StorePath.hs @@ -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." diff --git a/src/PathStats.hs b/src/PathStats.hs deleted file mode 100644 --- a/src/PathStats.hs +++ /dev/null @@ -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 diff --git a/src/StorePath.hs b/src/StorePath.hs deleted file mode 100644 --- a/src/StorePath.hs +++ /dev/null @@ -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." diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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] diff --git a/test/Test/Data/InvertedIndex.hs b/test/Test/Data/InvertedIndex.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/InvertedIndex.hs @@ -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)