diff --git a/nix-tree.cabal b/nix-tree.cabal --- a/nix-tree.cabal +++ b/nix-tree.cabal @@ -1,31 +1,52 @@ +cabal-version: 2.4 + name: nix-tree synopsis: Interactively browse a Nix store paths dependencies description: A terminal curses application to browse a Nix store paths dependencies -version: 0.1.3.1 +version: 0.1.4 homepage: https://github.com/utdemir/nix-tree -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Utku Demir maintainer: Utku Demir copyright: Utku Demir category: Language.Nix build-type: Simple -cabal-version: >=1.10 extra-source-files: README.md -executable nix-tree - main-is: Main.hs - hs-source-dirs: src +common common-options + ghc-options: -threaded + -Wall -Wpartial-fields -Wincomplete-record-updates -Widentities + -Wunused-packages default-language: Haskell2010 + default-extensions: LambdaCase + OverloadedStrings + TupleSections + TypeApplications + GeneralizedNewtypeDeriving + DeriveGeneric + DeriveFunctor + DerivingStrategies + DeriveAnyClass + FlexibleInstances + DeriveLift + StandaloneDeriving + DataKinds + KindSignatures + NamedFieldPuns + RankNTypes + ScopedTypeVariables other-modules: PathStats StorePath App InvertedIndex Paths_nix_tree - ghc-options: -Wall -fno-warn-name-shadowing -threaded -threaded - build-depends: base >= 4.11 && < 5 + autogen-modules: Paths_nix_tree + mixins: base hiding (Prelude) + , protolude (Protolude as Prelude) + build-depends: base + , protolude , aeson - , async , brick , bytestring , containers @@ -34,11 +55,25 @@ , filepath , hashable , hrfsize - , lens - , parallel , protolude , text , transformers , typed-process , unordered-containers , vty + +executable nix-tree + import: common-options + main-is: Main.hs + hs-source-dirs: src + default-language: Haskell2010 + build-depends: base >= 4.11 && < 5 + +test-suite nix-tree-tests + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test/ src/ + main-is: Test.hs + ghc-options: -Wno-unused-packages + build-depends: base >=4.11 && < 5 + , hedgehog diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - module App (run, helpText) where import qualified Brick as B @@ -16,7 +11,6 @@ import qualified Graphics.Vty as V import InvertedIndex import PathStats -import Protolude import qualified System.HrfSize as HRF data Widgets @@ -81,7 +75,7 @@ Bool -> List s -> B.Widget Widgets -renderList isFocused list = +renderList isFocused = B.renderList ( \_ StorePath @@ -108,7 +102,6 @@ ) ) isFocused - list app :: B.App (AppEnv s) () Widgets app = @@ -208,6 +201,11 @@ selectPath (shortestPathTo (aeActualStoreEnv s) (spName path)) closed + -- help modal + (B.VtyEvent (V.EvKey k []), Just ModalHelp) + | k `elem` [V.KChar 'q', V.KEsc] -> + B.continue s {aeOpenModal = Nothing} + -- ignore otherwise _ -> B.continue s, B.appStartEvent = \s -> return s, @@ -322,13 +320,13 @@ } renderSearchModal :: Text -> Text -> B.GenericList Widgets Seq (Path s) -> B.Widget Widgets -renderSearchModal left right list = +renderSearchModal left right l = renderModal "Search" window where window = B.txt left B.<+> B.txt "|" B.<+> B.txt right B.<=> B.hBorder - B.<=> renderList True list + B.<=> renderList True l showAndUpdateSearch :: Text -> Text -> AppEnv s -> AppEnv s showAndUpdateSearch left right env@AppEnv {aeActualStoreEnv, aeInvertedIndex} = diff --git a/src/InvertedIndex.hs b/src/InvertedIndex.hs --- a/src/InvertedIndex.hs +++ b/src/InvertedIndex.hs @@ -1,10 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE NoImplicitPrelude #-} - module InvertedIndex ( InvertedIndex, iiFromList, @@ -17,7 +10,6 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text -import Protolude data InvertedIndex = InvertedIndex { iiElems :: Set Text, @@ -25,7 +17,7 @@ iiBigrams :: Map (Char, Char) (Set Text), iiTrigrams :: Map (Char, Char, Char) (Set Text) } - deriving (Generic) + deriving (Generic, Show) instance NFData InvertedIndex @@ -44,7 +36,7 @@ orig (setToMap (Set.singleton txt) chrs) -iiFromList :: [Text] -> InvertedIndex +iiFromList :: Foldable f => f Text -> InvertedIndex iiFromList = foldl (flip iiInsert) @@ -54,15 +46,15 @@ setToMap v = Map.fromDistinctAscList . map (,v) . Set.toAscList unigramsOf :: Text -> Set Char -unigramsOf txt = Set.fromList $ Text.unpack txt +unigramsOf = Set.fromList . Text.unpack . Text.toLower bigramsOf :: Text -> Set (Char, Char) -bigramsOf txt = case Text.unpack txt of +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 txt of +trigramsOf txt = case Text.unpack (Text.toLower txt) of p1@(_ : p2@(_ : p3)) -> Set.fromList $ zip3 p1 p2 p3 _ -> Set.empty @@ -73,10 +65,12 @@ | Text.length txt == 2 = using bigramsOf iiBigrams | otherwise = using trigramsOf iiTrigrams where + lowerTxt = Text.toLower txt using :: Ord a => (Text -> Set a) -> Map a (Set Text) -> Set Text using getGrams m = Map.intersection m (setToMap () (getGrams txt)) & Map.elems & \case [] -> Set.empty - (x : xs) -> foldl' Set.intersection x xs + x : xs -> foldl' Set.intersection x xs + & Set.filter (\t -> lowerTxt `Text.isInfixOf` Text.toLower t) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - module Main where import App @@ -10,7 +5,6 @@ import Data.Version (showVersion) import PathStats import Paths_nix_tree (version) -import Protolude import System.Directory (canonicalizePath, doesDirectoryExist, getHomeDirectory) import System.FilePath (()) diff --git a/src/PathStats.hs b/src/PathStats.hs --- a/src/PathStats.hs +++ b/src/PathStats.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} - module PathStats ( PathStats (..), calculatePathStats, @@ -16,7 +10,6 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map.Lazy as M import qualified Data.Set as S -import Protolude import StorePath data IntermediatePathStats s = IntermediatePathStats @@ -34,7 +27,7 @@ (StoreName s -> Bool) -> StoreEnv s () -> StoreEnv s (IntermediatePathStats s) -mkIntermediateEnv pred = +mkIntermediateEnv env = seBottomUp $ \curr -> IntermediatePathStats { ipsAllRefs = @@ -42,7 +35,7 @@ ( M.fromList [ (spName, const () <$> sp) | sp@StorePath {spName} <- spRefs curr, - pred spName + env spName ] : map (ipsAllRefs . spPayload) (spRefs curr) ) @@ -67,8 +60,8 @@ } where calculateEnvSize :: StoreEnv s (IntermediatePathStats s) -> Int - calculateEnvSize env = - seGetRoots env + calculateEnvSize e = + seGetRoots e & toList & map ( \sp@StorePath {spName, spPayload} -> diff --git a/src/StorePath.hs b/src/StorePath.hs --- a/src/StorePath.hs +++ b/src/StorePath.hs @@ -1,15 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE NoImplicitPrelude #-} - module StorePath ( StoreName (..), storeNameToPath, @@ -35,7 +23,6 @@ import Data.List (partition) import qualified Data.List.NonEmpty as NE import qualified Data.Text as T -import Protolude import System.FilePath.Posix (splitDirectories) import System.Process.Typed (proc, readProcessStdout_) @@ -93,22 +80,22 @@ out <- decodeUtf8 . BL.toStrict <$> readProcessStdout_ (proc "nix" ["--version"]) return . lastMay $ T.splitOn " " out - getPathInfo :: Bool -> NonEmpty (StoreName s) -> IO [StorePath s (StoreName s) ()] - getPathInfo isDrv names = do - infos <- - decode @[NixPathInfoResult] - <$> readProcessStdout_ - ( proc - "nix" - ( ["path-info", "--recursive", "--json"] - ++ (if isDrv then ["--derivation"] else []) - ++ map storeNameToPath (toList names) - ) +getPathInfo :: Bool -> NonEmpty (StoreName s) -> IO [StorePath s (StoreName s) ()] +getPathInfo isDrv names = do + infos <- + decode @[NixPathInfoResult] + <$> readProcessStdout_ + ( proc + "nix" + ( ["path-info", "--recursive", "--json"] + ++ (if isDrv then ["--derivation"] else []) + ++ map storeNameToPath (toList names) ) - >>= maybe (fail "Failed parsing nix path-info output.") return - >>= mapM assertValidInfo - mapM infoToStorePath infos - + ) + >>= maybe (fail "Failed parsing nix path-info output.") return + >>= mapM assertValidInfo + mapM infoToStorePath infos + where infoToStorePath NixPathInfo {npiPath, npiNarSize, npiReferences} = do name <- mkStoreNameIO npiPath refs <- filter (/= name) <$> mapM mkStoreNameIO npiReferences @@ -124,7 +111,8 @@ (fail $ "Failed parsing Nix store path: " ++ show p) return (mkStoreName p) - assertValidInfo (NixPathInfoValid pi) = return pi + + assertValidInfo (NixPathInfoValid pathinfo) = return pathinfo assertValidInfo (NixPathInfoInvalid path) = fail $ "Invalid path: " ++ path ++ ". Inconsistent /nix/store or ongoing GC." @@ -223,8 +211,8 @@ ) (StorePath s (StoreName s) b) go name = do - bs <- gets snd - case name `HM.lookup` bs of + processed <- gets snd + case name `HM.lookup` processed of Just sp -> return sp Nothing -> do sp@StorePath {spName, spRefs} <- unsafeLookup name <$> gets fst diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import qualified Data.Set as Set +import qualified Data.Text as Text +import Hedgehog +import qualified Hedgehog.Gen as Gen +import Hedgehog.Main +import qualified Hedgehog.Range as Range +import InvertedIndex + +prop_inverted_index :: Property +prop_inverted_index = withDiscards 10000 . withTests 10000 . property $ do + haystack <- + forAll $ + Gen.set + (Range.linear 0 100) + (Gen.text (Range.linear 0 10) Gen.alphaNum) + + needle <- + forAll $ + (Gen.text (Range.linear 0 5) Gen.alphaNum) + + let ii = iiFromList haystack + annotateShow ii + + let expected = + haystack + & Set.filter + (\t -> Text.toLower needle `Text.isInfixOf` Text.toLower t) + actual = iiSearch needle ii + + expected === actual + +main :: IO () +main = defaultMain [checkParallel $$(discover)]