nix-tree 0.6.3 → 0.7.0
raw patch · 14 files changed
+978/−967 lines, 14 filesdep +nix-treedep ~base
Dependencies added: nix-tree
Dependency ranges changed: base
Files
- CHANGELOG.md +9/−2
- README.md +1/−1
- app/Main.hs +161/−0
- app/NixTree/BrickApp.hs +622/−0
- app/NixTree/Clipboard.hs +45/−0
- nix-tree.cabal +23/−19
- src/Data/InvertedIndex.hs +0/−76
- src/NixTree/App.hs +0/−622
- src/NixTree/Clipboard.hs +0/−45
- src/NixTree/Data/InvertedIndex.hs +76/−0
- src/NixTree/Main.hs +0/−161
- test/Test.hs +2/−2
- test/Test/Data/InvertedIndex.hs +0/−39
- test/Test/NixTree/Data/InvertedIndex.hs +39/−0
CHANGELOG.md view
@@ -1,7 +1,14 @@ # Changelog -## 0.6.3 - 2025-05-18:+## 0.7.0 - 2025-10-13: +* feat: Now available as a Haskell library (thanks @MangoIV (issue: [#84]), @blackheaven (PR: [#129]))++[#84]: https://github.com/utdemir/nix-tree/issues/84+[#129]: https://github.com/utdemir/nix-tree/pull/129++## 0.6.3 - 2025-05-18:+ * feat: Disambiguate store paths with the same name (thanks @lf-, issue: [#119]) ## 0.6.2 - 2025-02-25:@@ -9,7 +16,7 @@ * fix: Fix a failure when the store path does not have a signature. (thanks @minhtrancccp, issue [#114]) * chore: Update flake description to remove deprecated 'defaultPackage' field (thanks @minhtrancccp, issue [#113]) -#[113]: https://github.com/utdemir/nix-tree/issues/113+[#113]: https://github.com/utdemir/nix-tree/issues/113 [#114]: https://github.com/utdemir/nix-tree/issues/114 ## 0.6.1 - 2025-01-25:
README.md view
@@ -1,6 +1,6 @@ # nix-tree -+[](https://github.com/utdemir/nix-tree/actions/workflows/build.yaml) [](https://repology.org/project/haskell:nix-tree/versions) Interactively browse dependency graphs of Nix derivations.
+ app/Main.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE CPP #-}++module Main where++import Control.Concurrent.Async+import Control.Exception (evaluate)+import NixTree.BrickApp+import NixTree.PathStats+import qualified Options.Applicative as Opts+import qualified Options.Applicative.Help.Pretty as Opts+import System.Directory (XdgDirectory (XdgState), doesDirectoryExist, getHomeDirectory, getXdgDirectory, pathIsSymbolicLink)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.IO (hPutStrLn)+import System.ProgressBar hiding (msg)++version :: Text+version = VERSION_nix_tree++data Opts = Opts+ { oInstallables :: [Installable],+ oStore :: Maybe String,+ oFile :: Maybe FilePath,+ oVersion :: Bool,+ oDerivation :: Bool,+ oImpure :: Bool,+ oDot :: Bool+ }++optsParser :: Opts.ParserInfo Opts+optsParser =+ Opts.info (parser <**> Opts.helper) $+ mconcat+ [ Opts.progDesc "Interactively browse dependency graphs of Nix derivations.",+ Opts.fullDesc,+ Opts.footerDoc (Just keybindingsHelp)+ ]+ where+ parser :: Opts.Parser Opts+ parser =+ Opts+ <$> many+ ( Installable+ <$> Opts.strArgument @Text+ ( Opts.metavar "INSTALLABLE"+ <> Opts.helpDoc+ ( Just $+ Opts.vsep+ [ "A store path or a flake reference.",+ "Paths default to \"~/.nix-profile\" and \"/var/run/current-system\""+ ]+ )+ )+ )+ <*> optional+ ( Opts.strOption+ ( Opts.long "store"+ <> Opts.metavar "STORE"+ <> Opts.helpDoc+ ( Just $+ Opts.vsep+ [ "The URL of the Nix store, e.g. \"daemon\" or \"https://cache.nixos.org\"",+ "See \"nix help-stores\" for supported store types and settings."+ ]+ )+ )+ )+ <*> optional+ ( Opts.strOption+ ( Opts.long "file"+ <> Opts.metavar "FILE"+ <> Opts.helpDoc+ ( Just $ Opts.vsep ["Interpret installables as attribute paths relative to the Nix expression stored in file."]+ )+ )+ )+ <*> Opts.switch (Opts.long "version" <> Opts.help "Show the nix-tree version")+ <*> Opts.switch (Opts.long "derivation" <> Opts.help "Operate on the store derivation rather than its outputs")+ <*> Opts.switch (Opts.long "impure" <> Opts.help "Allow access to mutable paths and repositories")+ <*> Opts.switch (Opts.long "dot" <> Opts.help "Print the dependency graph in dot format")++ keybindingsHelp :: Opts.Doc+ keybindingsHelp =+ Opts.vsep+ [ "Keybindings:",+ Opts.indent 2 . Opts.vsep $ map Opts.pretty (lines helpText)+ ]++showAndFail :: Text -> IO a+showAndFail msg = do+ hPutStrLn stderr . toString $ "Error: " <> msg+ exitWith (ExitFailure 1)++isValidRoot :: FilePath -> IO Bool+isValidRoot path = do+ isExistingDirectory <- doesDirectoryExist path+ if isExistingDirectory+ then -- We need to check that it's a symlink (presumably to nix store),+ -- because if it is just a directory, nix will try to interpret it as a flake.+ -- We do doesDirectoryExist before pathIsSymbolicLink,+ -- because the latter will fail if the path does not exist.+ pathIsSymbolicLink path+ else return False++main :: IO ()+main = do+ opts <-+ Opts.customExecParser+ (Opts.prefs $ Opts.columns 120)+ optsParser++ when (opts & oVersion) $ do+ putTextLn $ "nix-tree " <> version+ exitSuccess++ installables <- case opts & oInstallables of+ p : ps ->+ return $ p :| ps+ [] -> do+ home <- getHomeDirectory+ nixXdgDirectory <- getXdgDirectory XdgState "nix/profile"+ homeManagerDirectory <- getXdgDirectory XdgState "nix/profiles/home-manager"+ roots <-+ filterM+ isValidRoot+ [ home </> ".nix-profile",+ nixXdgDirectory,+ homeManagerDirectory,+ "/var/run/current-system"+ ]+ case roots of+ [] -> showAndFail "No store path given."+ p : ps -> return . fmap (Installable . toText) $ p :| ps++ let seo =+ StoreEnvOptions+ { seoIsDerivation = opts & oDerivation,+ seoIsImpure = opts & oImpure,+ seoStoreURL = opts & oStore,+ seoFile = opts & oFile+ }++ withStoreEnv seo installables $ \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))++ if opts & oDot+ then putTextLn $ storeEnvToDot env+ else run env++chunks :: Int -> [a] -> [[a]]+chunks _ [] = []+chunks n xs =+ let (ys, zs) = splitAt n xs+ in ys : chunks n zs
+ app/NixTree/BrickApp.hs view
@@ -0,0 +1,622 @@+module NixTree.BrickApp (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 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 Lens.Micro (Traversal', _Just)+import qualified NixTree.Clipboard as Clipboard+import NixTree.Data.InvertedIndex+import NixTree.PathStats+import qualified System.Clock as Clock+import qualified System.HrfSize as HRF++sortOrderChangeHighlightPeriod :: Clock.TimeSpec+sortOrderChangeHighlightPeriod = Clock.TimeSpec 0 (500 * 1_000_000)++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))+ | ModalSearch Text Text (B.GenericList Widgets Seq Path)++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 PathStats,+ aeInvertedIndex :: InvertedIndex Path,+ aePrevPane :: List,+ aeCurrPane :: List,+ aeNextPane :: List,+ aeParents :: [List],+ aeOpenModal :: Maybe (Modal s),+ aeSortOrder :: SortOrder,+ aeSortOrderLastChanged :: Clock.TimeSpec,+ aeCurrTime :: Clock.TimeSpec+ }++type Path = StorePath StoreName PathStats++type List = B.GenericList Widgets Seq Path++data SortOrder+ = SortOrderAlphabetical+ | SortOrderClosureSize+ | SortOrderAddedSize+ deriving (Show, Eq, Enum, Bounded)++B.suffixLenses ''AppEnv++_ModalWhyDepends :: Traversal' (Modal s) (B.GenericList Widgets Seq (NonEmpty Path))+_ModalWhyDepends f m = case m of+ ModalWhyDepends l -> ModalWhyDepends <$> f l+ _ -> pure m++compareBySortOrder :: SortOrder -> Path -> Path -> 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 = B.attrName "terminal"+attrUnderlined = B.attrName "underlined"++run :: StoreEnv PathStats -> 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+ (_, vty) <- B.customMainWithDefaultVty (Just chan) app appEnv+ V.shutdown vty++ return ()++renderList ::+ Maybe SortOrder ->+ Bool ->+ List ->+ B.Widget Widgets+renderList highlightSort =+ B.renderList+ ( \_+ StorePath+ { spName,+ spPayload = PathStats {psTotalSize, psAddedSize, psDisambiguationChars},+ spRefs,+ spSignatures+ } ->+ let color =+ if null spRefs+ then B.withAttr attrTerminal+ else identity+ in color $+ B.hBox+ [ if null spSignatures+ then B.txt " "+ else B.txt "✓ ",+ B.txt (storeNameToShortTextWithDisambiguation psDisambiguationChars 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 ")"+ ]+ ]+ )+ 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 = \_ _ -> Nothing,+ B.appHandleEvent = \e -> do+ s <- get+ case (e, aeOpenModal s) of+ -- main screen+ (B.VtyEvent (V.EvKey k []), Nothing)+ | k `elem` [V.KChar 'q', V.KEsc] ->+ B.halt+ (B.VtyEvent (V.EvKey (V.KChar '?') []), Nothing) ->+ put s {aeOpenModal = Just (ModalNotice helpNotice)}+ (B.VtyEvent (V.EvKey (V.KChar 'w') []), Nothing) -> do+ B.hScrollToBeginning (B.viewportScroll WidgetWhyDependsViewport)+ modify showWhyDepends+ (B.VtyEvent (V.EvKey (V.KChar '/') []), Nothing) ->+ modify $ showAndUpdateSearch "" ""+ (B.VtyEvent (V.EvKey (V.KChar 'y') []), Nothing) -> do+ liftIO (yankToClipboard $ spName (selectedPath s))+ >>= \case+ Right () -> return ()+ Left n -> put s {aeOpenModal = Just (ModalNotice n)}+ (B.VtyEvent (V.EvKey (V.KChar 's') []), Nothing) ->+ put $+ s+ { aeSortOrder = succCycle (aeSortOrder s),+ aeSortOrderLastChanged = aeCurrTime s+ }+ & sortPanes+ (B.VtyEvent (V.EvKey k []), Nothing)+ | k `elem` [V.KChar 'h', V.KLeft] ->+ modify moveLeft+ (B.VtyEvent (V.EvKey k []), Nothing)+ | k `elem` [V.KChar 'j', V.KDown, V.KChar '\t'] ->+ move B.listMoveDown+ (B.VtyEvent (V.EvKey k []), Nothing)+ | k `elem` [V.KChar 'k', V.KUp, V.KBackTab] ->+ move B.listMoveUp+ (B.VtyEvent (V.EvKey k []), Nothing)+ | k `elem` [V.KChar 'l', V.KRight] ->+ modify moveRight+ (B.VtyEvent (V.EvKey V.KPageUp []), Nothing) ->+ moveF B.listMovePageUp+ (B.VtyEvent (V.EvKey V.KPageDown []), Nothing) ->+ moveF B.listMovePageDown+ -- why-depends modal+ (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends _))+ | k `elem` [V.KChar 'q', V.KEsc] ->+ put s {aeOpenModal = Nothing}+ (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends _))+ | k `elem` [V.KChar 'h', V.KLeft] ->+ B.hScrollBy (B.viewportScroll WidgetWhyDependsViewport) (-1)+ (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends l))+ | k `elem` [V.KChar 'j', V.KDown, V.KChar '\t'] ->+ put s {aeOpenModal = Just $ ModalWhyDepends (B.listMoveDown l)}+ (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends l))+ | k `elem` [V.KChar 'k', V.KUp, V.KBackTab] ->+ put s {aeOpenModal = Just $ ModalWhyDepends (B.listMoveUp l)}+ (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends _))+ | k `elem` [V.KChar 'l', V.KRight] ->+ B.hScrollBy (B.viewportScroll WidgetWhyDependsViewport) 1+ (B.VtyEvent (V.EvKey V.KPageUp []), Just (ModalWhyDepends _)) ->+ B.zoom (aeOpenModalL . _Just . _ModalWhyDepends) B.listMovePageUp+ (B.VtyEvent (V.EvKey V.KPageDown []), Just (ModalWhyDepends _)) ->+ B.zoom (aeOpenModalL . _Just . _ModalWhyDepends) B.listMovePageDown+ (B.VtyEvent (V.EvKey V.KEnter []), Just (ModalWhyDepends l)) ->+ let closed = s {aeOpenModal = Nothing}+ in case B.listSelectedElement l of+ Nothing -> put closed+ Just (_, path) -> put $ selectPath path closed+ -- search modal+ (B.VtyEvent (V.EvKey V.KEsc []), Just (ModalSearch {})) ->+ put s {aeOpenModal = Nothing}+ (B.VtyEvent (V.EvKey k []), Just (ModalSearch l r xs))+ | k `elem` [V.KDown, V.KChar '\t'] ->+ put 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] ->+ put s {aeOpenModal = Just $ ModalSearch l r (B.listMoveUp xs)}+ (B.VtyEvent (V.EvKey V.KLeft []), Just (ModalSearch l r xs)) ->+ put+ 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)) ->+ put+ 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 ->+ modify (showAndUpdateSearch (l <> T.singleton c) r)+ (B.VtyEvent (V.EvKey V.KBS []), Just (ModalSearch l r _)) ->+ modify (showAndUpdateSearch (T.dropEnd 1 l) r)+ (B.VtyEvent (V.EvKey V.KEnter []), Just (ModalSearch _ _ xs)) ->+ let closed = s {aeOpenModal = Nothing}+ in case B.listSelectedElement xs of+ Nothing -> put closed+ Just (_, path) ->+ put $+ selectPath+ (shortestPathTo (aeActualStoreEnv s) (spName path))+ closed+ -- notices+ (B.VtyEvent (V.EvKey k []), Just (ModalNotice _))+ | k `elem` [V.KChar 'q', V.KEsc] ->+ put s {aeOpenModal = Nothing}+ -- handle our events+ (B.AppEvent (EventTick t), _) ->+ let new = s {aeCurrTime = t}+ in do+ put new+ unless (timePassedSinceSortOrderChange new <= sum (replicate 2 sortOrderChangeHighlightPeriod)) B.continueWithoutRedraw+ -- ignore otherwise+ _ ->+ return (),+ B.appStartEvent = return (),+ 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 -> 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."]+ )++timePassedSinceSortOrderChange :: AppEnv s -> Clock.TimeSpec+timePassedSinceSortOrderChange env = Clock.diffTimeSpec (aeCurrTime env) (aeSortOrderLastChanged env)++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 =+ if timePassedSinceSortOrderChange env < sortOrderChangeHighlightPeriod+ then Just (aeSortOrder env)+ else Nothing++renderInfoPane :: AppEnv s -> B.Widget Widgets+renderInfoPane env =+ let selected = selectedPath env+ immediateParents = psImmediateParents $ spPayload selected+ signatures = spSignatures 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 $+ "Signatures: "+ <> if null signatures+ then "✗"+ else+ ( signatures+ & map npsKeyName+ & T.intercalate ", "+ ),+ 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 modal",+ "/ : Open search modal",+ "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) ->+ 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 -> 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 -> List) -> B.EventM n (AppEnv s) ()+move = moveF . modify++moveF :: B.EventM n List () -> B.EventM n (AppEnv s) ()+moveF f = do+ B.zoom aeCurrPaneL f+ modify repopulateNextPane++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 -> List+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+selectedPath = NE.head . selectedPaths++selectedPaths :: AppEnv s -> NonEmpty Path+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 -> 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 ->+ Maybe Path ->+ B.GenericList n Seq Path+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"
+ app/NixTree/Clipboard.hs view
@@ -0,0 +1,45 @@+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.runProcess+ & timeout 1_000_000+ & try+ <&> \case+ Right (Just ExitSuccess) -> Right ()+ Right (Just (ExitFailure e)) ->+ Left $ "failed with exit code " <> show e+ 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)
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.6.3+version: 0.7.0 homepage: https://github.com/utdemir/nix-tree license: BSD-3-Clause license-file: LICENSE@@ -38,46 +38,50 @@ NumericUnderscores MultiWayIf TemplateHaskell- other-modules: NixTree.PathStats- NixTree.StorePath- NixTree.App- Data.InvertedIndex- NixTree.Clipboard mixins: base hiding (Prelude) , relude (Relude as Prelude)- build-depends: base+ build-depends: base >=4.11 && < 5 , relude- , aeson- , brick >= 2.1- , bytestring , containers , clock , filepath , hrfsize , text , typed-process- , unordered-containers , vty , directory , optparse-applicative , microlens++library+ import: common-options+ hs-source-dirs: src+ exposed-modules: NixTree.PathStats+ NixTree.StorePath+ NixTree.Data.InvertedIndex+ build-depends: aeson+ , bytestring+ , unordered-containers , dot executable nix-tree import: common-options ghc-options: -Wunused-packages -threaded -with-rtsopts=-N- main-is: NixTree/Main.hs- hs-source-dirs: src+ main-is: Main.hs+ hs-source-dirs: app+ other-modules: NixTree.BrickApp+ NixTree.Clipboard default-language: Haskell2010- build-depends: base >= 4.11 && < 5- , terminal-progress-bar+ build-depends: terminal-progress-bar , async+ , brick >= 2.1+ , nix-tree test-suite nix-tree-tests import: common-options type: exitcode-stdio-1.0- hs-source-dirs: test/ src/- other-modules: Test.Data.InvertedIndex+ hs-source-dirs: test+ other-modules: Test.NixTree.Data.InvertedIndex main-is: Test.hs- build-depends: base >=4.11 && < 5- , hedgehog+ build-depends: hedgehog+ , nix-tree
− src/Data/InvertedIndex.hs
@@ -1,76 +0,0 @@-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/NixTree/App.hs
@@ -1,622 +0,0 @@-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 Lens.Micro (Traversal', _Just)-import qualified NixTree.Clipboard as Clipboard-import NixTree.PathStats-import qualified System.Clock as Clock-import qualified System.HrfSize as HRF--sortOrderChangeHighlightPeriod :: Clock.TimeSpec-sortOrderChangeHighlightPeriod = Clock.TimeSpec 0 (500 * 1_000_000)--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))- | ModalSearch Text Text (B.GenericList Widgets Seq Path)--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 PathStats,- aeInvertedIndex :: InvertedIndex Path,- aePrevPane :: List,- aeCurrPane :: List,- aeNextPane :: List,- aeParents :: [List],- aeOpenModal :: Maybe (Modal s),- aeSortOrder :: SortOrder,- aeSortOrderLastChanged :: Clock.TimeSpec,- aeCurrTime :: Clock.TimeSpec- }--type Path = StorePath StoreName PathStats--type List = B.GenericList Widgets Seq Path--data SortOrder- = SortOrderAlphabetical- | SortOrderClosureSize- | SortOrderAddedSize- deriving (Show, Eq, Enum, Bounded)--B.suffixLenses ''AppEnv--_ModalWhyDepends :: Traversal' (Modal s) (B.GenericList Widgets Seq (NonEmpty Path))-_ModalWhyDepends f m = case m of- ModalWhyDepends l -> ModalWhyDepends <$> f l- _ -> pure m--compareBySortOrder :: SortOrder -> Path -> Path -> 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 = B.attrName "terminal"-attrUnderlined = B.attrName "underlined"--run :: StoreEnv PathStats -> 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- (_, vty) <- B.customMainWithDefaultVty (Just chan) app appEnv- V.shutdown vty-- return ()--renderList ::- Maybe SortOrder ->- Bool ->- List ->- B.Widget Widgets-renderList highlightSort =- B.renderList- ( \_- StorePath- { spName,- spPayload = PathStats {psTotalSize, psAddedSize, psDisambiguationChars},- spRefs,- spSignatures- } ->- let color =- if null spRefs- then B.withAttr attrTerminal- else identity- in color $- B.hBox- [ if null spSignatures- then B.txt " "- else B.txt "✓ ",- B.txt (storeNameToShortTextWithDisambiguation psDisambiguationChars 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 ")"- ]- ]- )- 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 = \_ _ -> Nothing,- B.appHandleEvent = \e -> do- s <- get- case (e, aeOpenModal s) of- -- main screen- (B.VtyEvent (V.EvKey k []), Nothing)- | k `elem` [V.KChar 'q', V.KEsc] ->- B.halt- (B.VtyEvent (V.EvKey (V.KChar '?') []), Nothing) ->- put s {aeOpenModal = Just (ModalNotice helpNotice)}- (B.VtyEvent (V.EvKey (V.KChar 'w') []), Nothing) -> do- B.hScrollToBeginning (B.viewportScroll WidgetWhyDependsViewport)- modify showWhyDepends- (B.VtyEvent (V.EvKey (V.KChar '/') []), Nothing) ->- modify $ showAndUpdateSearch "" ""- (B.VtyEvent (V.EvKey (V.KChar 'y') []), Nothing) -> do- liftIO (yankToClipboard $ spName (selectedPath s))- >>= \case- Right () -> return ()- Left n -> put s {aeOpenModal = Just (ModalNotice n)}- (B.VtyEvent (V.EvKey (V.KChar 's') []), Nothing) ->- put $- s- { aeSortOrder = succCycle (aeSortOrder s),- aeSortOrderLastChanged = aeCurrTime s- }- & sortPanes- (B.VtyEvent (V.EvKey k []), Nothing)- | k `elem` [V.KChar 'h', V.KLeft] ->- modify moveLeft- (B.VtyEvent (V.EvKey k []), Nothing)- | k `elem` [V.KChar 'j', V.KDown, V.KChar '\t'] ->- move B.listMoveDown- (B.VtyEvent (V.EvKey k []), Nothing)- | k `elem` [V.KChar 'k', V.KUp, V.KBackTab] ->- move B.listMoveUp- (B.VtyEvent (V.EvKey k []), Nothing)- | k `elem` [V.KChar 'l', V.KRight] ->- modify moveRight- (B.VtyEvent (V.EvKey V.KPageUp []), Nothing) ->- moveF B.listMovePageUp- (B.VtyEvent (V.EvKey V.KPageDown []), Nothing) ->- moveF B.listMovePageDown- -- why-depends modal- (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends _))- | k `elem` [V.KChar 'q', V.KEsc] ->- put s {aeOpenModal = Nothing}- (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends _))- | k `elem` [V.KChar 'h', V.KLeft] ->- B.hScrollBy (B.viewportScroll WidgetWhyDependsViewport) (-1)- (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends l))- | k `elem` [V.KChar 'j', V.KDown, V.KChar '\t'] ->- put s {aeOpenModal = Just $ ModalWhyDepends (B.listMoveDown l)}- (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends l))- | k `elem` [V.KChar 'k', V.KUp, V.KBackTab] ->- put s {aeOpenModal = Just $ ModalWhyDepends (B.listMoveUp l)}- (B.VtyEvent (V.EvKey k []), Just (ModalWhyDepends _))- | k `elem` [V.KChar 'l', V.KRight] ->- B.hScrollBy (B.viewportScroll WidgetWhyDependsViewport) 1- (B.VtyEvent (V.EvKey V.KPageUp []), Just (ModalWhyDepends _)) ->- B.zoom (aeOpenModalL . _Just . _ModalWhyDepends) B.listMovePageUp- (B.VtyEvent (V.EvKey V.KPageDown []), Just (ModalWhyDepends _)) ->- B.zoom (aeOpenModalL . _Just . _ModalWhyDepends) B.listMovePageDown- (B.VtyEvent (V.EvKey V.KEnter []), Just (ModalWhyDepends l)) ->- let closed = s {aeOpenModal = Nothing}- in case B.listSelectedElement l of- Nothing -> put closed- Just (_, path) -> put $ selectPath path closed- -- search modal- (B.VtyEvent (V.EvKey V.KEsc []), Just (ModalSearch {})) ->- put s {aeOpenModal = Nothing}- (B.VtyEvent (V.EvKey k []), Just (ModalSearch l r xs))- | k `elem` [V.KDown, V.KChar '\t'] ->- put 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] ->- put s {aeOpenModal = Just $ ModalSearch l r (B.listMoveUp xs)}- (B.VtyEvent (V.EvKey V.KLeft []), Just (ModalSearch l r xs)) ->- put- 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)) ->- put- 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 ->- modify (showAndUpdateSearch (l <> T.singleton c) r)- (B.VtyEvent (V.EvKey V.KBS []), Just (ModalSearch l r _)) ->- modify (showAndUpdateSearch (T.dropEnd 1 l) r)- (B.VtyEvent (V.EvKey V.KEnter []), Just (ModalSearch _ _ xs)) ->- let closed = s {aeOpenModal = Nothing}- in case B.listSelectedElement xs of- Nothing -> put closed- Just (_, path) ->- put $- selectPath- (shortestPathTo (aeActualStoreEnv s) (spName path))- closed- -- notices- (B.VtyEvent (V.EvKey k []), Just (ModalNotice _))- | k `elem` [V.KChar 'q', V.KEsc] ->- put s {aeOpenModal = Nothing}- -- handle our events- (B.AppEvent (EventTick t), _) ->- let new = s {aeCurrTime = t}- in do- put new- unless (timePassedSinceSortOrderChange new <= sum (replicate 2 sortOrderChangeHighlightPeriod)) B.continueWithoutRedraw- -- ignore otherwise- _ ->- return (),- B.appStartEvent = return (),- 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 -> 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."]- )--timePassedSinceSortOrderChange :: AppEnv s -> Clock.TimeSpec-timePassedSinceSortOrderChange env = Clock.diffTimeSpec (aeCurrTime env) (aeSortOrderLastChanged env)--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 =- if timePassedSinceSortOrderChange env < sortOrderChangeHighlightPeriod- then Just (aeSortOrder env)- else Nothing--renderInfoPane :: AppEnv s -> B.Widget Widgets-renderInfoPane env =- let selected = selectedPath env- immediateParents = psImmediateParents $ spPayload selected- signatures = spSignatures 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 $- "Signatures: "- <> if null signatures- then "✗"- else- ( signatures- & map npsKeyName- & T.intercalate ", "- ),- 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 modal",- "/ : Open search modal",- "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) ->- 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 -> 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 -> List) -> B.EventM n (AppEnv s) ()-move = moveF . modify--moveF :: B.EventM n List () -> B.EventM n (AppEnv s) ()-moveF f = do- B.zoom aeCurrPaneL f- modify repopulateNextPane--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 -> List-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-selectedPath = NE.head . selectedPaths--selectedPaths :: AppEnv s -> NonEmpty Path-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 -> 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 ->- Maybe Path ->- B.GenericList n Seq Path-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
@@ -1,45 +0,0 @@-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.runProcess- & timeout 1_000_000- & try- <&> \case- Right (Just ExitSuccess) -> Right ()- Right (Just (ExitFailure e)) ->- Left $ "failed with exit code " <> show e- 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/Data/InvertedIndex.hs view
@@ -0,0 +1,76 @@+module NixTree.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/NixTree/Main.hs
@@ -1,161 +0,0 @@-{-# LANGUAGE CPP #-}--module Main where--import Control.Concurrent.Async-import Control.Exception (evaluate)-import NixTree.App-import NixTree.PathStats-import qualified Options.Applicative as Opts-import qualified Options.Applicative.Help.Pretty as Opts-import System.Directory (XdgDirectory (XdgState), doesDirectoryExist, getHomeDirectory, getXdgDirectory, pathIsSymbolicLink)-import System.Exit (ExitCode (..))-import System.FilePath ((</>))-import System.IO (hPutStrLn)-import System.ProgressBar hiding (msg)--version :: Text-version = VERSION_nix_tree--data Opts = Opts- { oInstallables :: [Installable],- oStore :: Maybe String,- oFile :: Maybe FilePath,- oVersion :: Bool,- oDerivation :: Bool,- oImpure :: Bool,- oDot :: Bool- }--optsParser :: Opts.ParserInfo Opts-optsParser =- Opts.info (parser <**> Opts.helper) $- mconcat- [ Opts.progDesc "Interactively browse dependency graphs of Nix derivations.",- Opts.fullDesc,- Opts.footerDoc (Just keybindingsHelp)- ]- where- parser :: Opts.Parser Opts- parser =- Opts- <$> many- ( Installable- <$> Opts.strArgument @Text- ( Opts.metavar "INSTALLABLE"- <> Opts.helpDoc- ( Just $- Opts.vsep- [ "A store path or a flake reference.",- "Paths default to \"~/.nix-profile\" and \"/var/run/current-system\""- ]- )- )- )- <*> optional- ( Opts.strOption- ( Opts.long "store"- <> Opts.metavar "STORE"- <> Opts.helpDoc- ( Just $- Opts.vsep- [ "The URL of the Nix store, e.g. \"daemon\" or \"https://cache.nixos.org\"",- "See \"nix help-stores\" for supported store types and settings."- ]- )- )- )- <*> optional- ( Opts.strOption- ( Opts.long "file"- <> Opts.metavar "FILE"- <> Opts.helpDoc- ( Just $ Opts.vsep ["Interpret installables as attribute paths relative to the Nix expression stored in file."]- )- )- )- <*> Opts.switch (Opts.long "version" <> Opts.help "Show the nix-tree version")- <*> Opts.switch (Opts.long "derivation" <> Opts.help "Operate on the store derivation rather than its outputs")- <*> Opts.switch (Opts.long "impure" <> Opts.help "Allow access to mutable paths and repositories")- <*> Opts.switch (Opts.long "dot" <> Opts.help "Print the dependency graph in dot format")-- keybindingsHelp :: Opts.Doc- keybindingsHelp =- Opts.vsep- [ "Keybindings:",- Opts.indent 2 . Opts.vsep $ map Opts.pretty (lines helpText)- ]--showAndFail :: Text -> IO a-showAndFail msg = do- hPutStrLn stderr . toString $ "Error: " <> msg- exitWith (ExitFailure 1)--isValidRoot :: FilePath -> IO Bool-isValidRoot path = do- isExistingDirectory <- doesDirectoryExist path- if isExistingDirectory- then -- We need to check that it's a symlink (presumably to nix store),- -- because if it is just a directory, nix will try to interpret it as a flake.- -- We do doesDirectoryExist before pathIsSymbolicLink,- -- because the latter will fail if the path does not exist.- pathIsSymbolicLink path- else return False--main :: IO ()-main = do- opts <-- Opts.customExecParser- (Opts.prefs $ Opts.columns 120)- optsParser-- when (opts & oVersion) $ do- putTextLn $ "nix-tree " <> version- exitSuccess-- installables <- case opts & oInstallables of- p : ps ->- return $ p :| ps- [] -> do- home <- getHomeDirectory- nixXdgDirectory <- getXdgDirectory XdgState "nix/profile"- homeManagerDirectory <- getXdgDirectory XdgState "nix/profiles/home-manager"- roots <-- filterM- isValidRoot- [ home </> ".nix-profile",- nixXdgDirectory,- homeManagerDirectory,- "/var/run/current-system"- ]- case roots of- [] -> showAndFail "No store path given."- p : ps -> return . fmap (Installable . toText) $ p :| ps-- let seo =- StoreEnvOptions- { seoIsDerivation = opts & oDerivation,- seoIsImpure = opts & oImpure,- seoStoreURL = opts & oStore,- seoFile = opts & oFile- }-- withStoreEnv seo installables $ \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))-- if opts & oDot- then putTextLn $ storeEnvToDot env- else run env--chunks :: Int -> [a] -> [[a]]-chunks _ [] = []-chunks n xs =- let (ys, zs) = splitAt n xs- in ys : chunks n zs
test/Test.hs view
@@ -4,9 +4,9 @@ import Hedgehog import Hedgehog.Main-import qualified Test.Data.InvertedIndex+import qualified Test.NixTree.Data.InvertedIndex main :: IO () main = defaultMain . map checkParallel $- [Test.Data.InvertedIndex.tests]+ [Test.NixTree.Data.InvertedIndex.tests]
− test/Test/Data/InvertedIndex.hs
@@ -1,39 +0,0 @@-{-# 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)
+ test/Test/NixTree/Data/InvertedIndex.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.NixTree.Data.InvertedIndex (tests) where++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+import NixTree.Data.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++tests :: Group+tests = $$(discover)