diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # nix-tree -![Build Status](https://github.com/utdemir/nix-tree/workflows/nix-build/badge.svg) +[![Build Status](https://github.com/utdemir/nix-tree/actions/workflows/build.yaml/badge.svg)](https://github.com/utdemir/nix-tree/actions/workflows/build.yaml) [![Packaging status](https://repology.org/badge/vertical-allrepos/haskell:nix-tree.svg?exclude_unsupported=1)](https://repology.org/project/haskell:nix-tree/versions) Interactively browse dependency graphs of Nix derivations. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/app/NixTree/BrickApp.hs b/app/NixTree/BrickApp.hs new file mode 100644 --- /dev/null +++ b/app/NixTree/BrickApp.hs @@ -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" diff --git a/app/NixTree/Clipboard.hs b/app/NixTree/Clipboard.hs new file mode 100644 --- /dev/null +++ b/app/NixTree/Clipboard.hs @@ -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) 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.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 diff --git a/src/Data/InvertedIndex.hs b/src/Data/InvertedIndex.hs deleted file mode 100644 --- a/src/Data/InvertedIndex.hs +++ /dev/null @@ -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 diff --git a/src/NixTree/App.hs b/src/NixTree/App.hs deleted file mode 100644 --- a/src/NixTree/App.hs +++ /dev/null @@ -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" diff --git a/src/NixTree/Clipboard.hs b/src/NixTree/Clipboard.hs deleted file mode 100644 --- a/src/NixTree/Clipboard.hs +++ /dev/null @@ -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) diff --git a/src/NixTree/Data/InvertedIndex.hs b/src/NixTree/Data/InvertedIndex.hs new file mode 100644 --- /dev/null +++ b/src/NixTree/Data/InvertedIndex.hs @@ -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 diff --git a/src/NixTree/Main.hs b/src/NixTree/Main.hs deleted file mode 100644 --- a/src/NixTree/Main.hs +++ /dev/null @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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] diff --git a/test/Test/Data/InvertedIndex.hs b/test/Test/Data/InvertedIndex.hs deleted file mode 100644 --- a/test/Test/Data/InvertedIndex.hs +++ /dev/null @@ -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) diff --git a/test/Test/NixTree/Data/InvertedIndex.hs b/test/Test/NixTree/Data/InvertedIndex.hs new file mode 100644 --- /dev/null +++ b/test/Test/NixTree/Data/InvertedIndex.hs @@ -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)