diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,7 +13,13 @@ * FileTree is now a record. * Some internal changes to get it to build on somewhat older versions of ghc. Tested with 8.2.2 -## 0.1.1.1 -- 20121-06-06 +## 0.1.1.1 -- 2021-06-06 * Removed the spurious dependency on containers. * Loosened some bounds on the packages. + +## 0.3 -- 2022-09-25 + +* Use a new chunked interface which gives much better code sharing and improves performance too. +* Various internal refactors. +* A lot of documentation either outdated/doesn't exist as a result and needs to be revamped. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -2,15 +2,17 @@ import qualified Talash.Brick as B import qualified Talash.Piped as P -import Intro +import qualified Talash.SimpleSearcher as S +import Prelude import System.Environment (getArgs) run :: [String] -> IO () run ("piped":xs) = P.run' xs run ("tui" :xs) = B.run' xs +run ["test"] = S.simpleSearcherTest run _ = putStrLn usageString -usageString :: Text +usageString :: String usageString = "talash is the demo program for the talash library. It has two set of subcommand:\n" <> "talash tui : for the terminal user interface, use 'talash tui help' for details.\n" <> "talash piped : for the piped interface, use 'talash piped help' for details.\n" diff --git a/src/Talash/Brick.hs b/src/Talash/Brick.hs --- a/src/Talash/Brick.hs +++ b/src/Talash/Brick.hs @@ -4,88 +4,36 @@ -- return a single selection but more complicated actions can be performed by using the `_hooks` which allow abitrary IO actions (due to `EventM` being a `MonadIO`) -- in response to input events. The most convenient function to use the brick app are `selected` and related functions. `runApp` provides some more flexibility. module Talash.Brick (-- * Types - Searcher (..) , SearchEvent (..) , SearchEnv (..) , SearchFunctions (..) , EventHooks (..) , AppTheme (..) , AppSettings (..) + Searcher (..) , SearchEvent (..) , SearchEnv (..) , EventHooks (..) , AppTheme (..) , AppSettings (..) , AppSettingsG (..) , CaseSensitivity (..) -- * The Brick App and Helpers - , searchApp , defSettings , searchFunctionsFuzzy , searchFunctionsOL , runApp , runAppFromHandle - , selected , selectedFromHandle , selectedFromHandleWith , selectedFromFileNamesSorted , selectedFromFiles , runSearch + , searchApp , defSettings , fuzzyFunctions , orderlessFunctions , runApp , runAppFromHandle , selected , selectedFromHandle + , selectedFromHandleWith , selectedFromFileNamesSorted , selectedFromFiles , selectedUsing , runSearch , makeChunks -- * Default program , run , run' -- * Lenses -- ** Searcher - , query , prevQuery , allMatches , matches , numMatches , wait + , queryEditor , allMatches , matches , numMatches -- ** SearchEvent , matchedTop , totalMatches , term -- ** SearchEnv - , searchFunctions , candidates , eventSource + , candidates , eventSource -- ** SearchFunctions - , makeMatcher , lister , displayer + , makeMatcher , match , display -- ** AppTheme , prompt , themeAttrs , borderStyle -- ** SearchSettings - , theme , hooks + , theme , hooks , defTheme , defHooks -- * Exposed Internals - , makeQuery , haltQuit , handleKeyEvent , handleSearch , editStep , replaceSearch , search , searcherWidget , initialSearcher - , searchWithMatcher , readVectorStdIn , readVectorHandle , readVectorHandleWith , emptyIndices) where + , handleKeyEvent , handleSearch , searcherWidget , initialSearcher , readVectorHandleWith) +where -import Control.Concurrent(forkIO , killThread, ThreadId) -import Data.IORef (IORef , newIORef , atomicModifyIORef' , atomicWriteIORef) -import qualified Data.Text as T -import Data.Vector (Vector , (!), force , generate , take, singleton , convert, enumFromN, unfoldr, unfoldrM , uniq , modify, concat) -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Sized as S +import Data.Monoid.Colorful as C +import Data.Vector (unsafeIndex , elemIndex) import GHC.Compact (Compact , compact , getCompact) -import Intro hiding (sort, on,replicate , take , modify) -import System.Environment (getArgs) +import qualified System.IO.Streams as I import Talash.Brick.Internal -import Talash.Core hiding (makeMatcher) import Talash.Files -import Talash.Internal -import Data.Monoid.Colorful as C - -data Searcher a = Searcher { -- | The editor to get the query from. - _query :: Editor Text Bool - -- | The last query which is saved to check if we should only search among the matches for it or all the candidates. - , _prevQuery :: Maybe Text - -- | An IORef containing the indices of the filtered candidates. These are in an IORef to make it easier to deal with them in a different thread - -- than the UI of the app. Maybe it should be moved to `SearchEnv` - , _allMatches :: IORef (U.Vector Int) - -- | The matches received split up as alternating sequences of match substrings and the gap between them. The first substring is always a gap - -- and can be empty, the rest should be no empty. - , _matches :: List Bool [Text] - -- | The (maximum possible) number of matches. This is the length of vector stored in `_allMatches` which also contains the indices of - -- which weren't matched in case enough matches were found before going through all the candidates. - , _numMatches :: Int - -- | ThreadId of the thread currently computing matches. Nothing if there is no such thread. - , _wait :: Maybe ThreadId - -- | Unused by default but can be used store extra state needed for any extension to the functionality. For example to have multiple - -- selections this can be set to a `Vector` that stores them. - , _extension :: a} deriving (Functor) -makeLenses ''Searcher - -data SearchEvent = SearchEvent { - -- | The matches received. - _matchedTop :: Vector [Text] , - -- | The (maximum possible) number of matches. See the note on `_numMatches`. - _totalMatches :: Int , - -- | The term which was searched for. - _term :: Maybe Text} -makeLenses ''SearchEvent - --- | The constant environment in which the search app runs. -data SearchEnv a = SearchEnv { _searchFunctions :: SearchFunctions a -- ^ The functions used to find and display matches. - , _candidates :: Vector Text -- ^ The vector of candidates. - , _eventSource :: BChan SearchEvent -- ^ The BChan from which the app receives search events. - } -makeLenses ''SearchEnv - --- | Event hooks are almost direct translations of the events from vty i.e. see `Event`. -data EventHooks a = EventHooks { keyHook :: Key -> [Modifier] -> a -> EventM Bool (Next a) - , pasteHook :: ByteString -> a -> EventM Bool (Next a) - , resizeHook :: Int -> Int -> a -> EventM Bool (Next a) - , mouseDownHook :: Int -> Int -> Button -> [Modifier] -> a -> EventM Bool (Next a) - , mouseUpHook :: Int -> Int -> Maybe Button -> a -> EventM Bool (Next a) - , focusLostHook :: a -> EventM Bool (Next a) - , focusGainedHook :: a -> EventM Bool (Next a)} +import Talash.Intro hiding (sort, on , take) data AppTheme = AppTheme { _prompt :: Text -- ^ The prompt to display next to the editor. , _themeAttrs :: [(AttrName, Attr)] -- ^ This is used to construct the `attrMap` for the app. By default the used attarNmaes are @@ -94,138 +42,91 @@ } makeLenses ''AppTheme -data AppSettings a b = AppSettings { _theme :: AppTheme - , _hooks :: ReaderT (SearchEnv a) EventHooks (Searcher b) -- ^ The event hooks which can make use of the search environment. - } -makeLenses ''AppSettings - -defHooks :: EventHooks a -defHooks = EventHooks (const . const continue) (const continue) (const . const continue) (const . const . const . const continue) - (const . const . const continue) continue continue --- This is a comment --- | Get the current query from the editor of the searcher. -makeQuery :: Searcher a -> Maybe Text -makeQuery s = headMay . getEditContents $ s ^. query - --- | Quit without any selection. -haltQuit :: Searcher a -> EventM n (Next (Searcher a)) -haltQuit = halt . ((matches . listSelectedL) .~ Nothing) - --- | Handling of keypresses. The default bindings are --- @Enter@ exits the app with the current selection. --- @Esc@ exits without any selection --- @Up@ , @Down@ , @PageUp@ and @PageDown@ move through the matches. --- All others keys are used for editing the query. See `handleEditorEvent` for details. -handleKeyEvent :: SearchEnv a -> Key -> [Modifier] -> Searcher b -> EventM Bool (Next (Searcher b)) -handleKeyEvent e@(SearchEnv fs v b) k m s - | k == KEnter , null m = halt s - | k == KEsc , null m = haltQuit s - | k `elem` [KUp , KDown , KPageUp , KPageDown] , null m = continue =<< handleEventLensed s matches handleListEvent (EvKey k m) - | otherwise = continue =<< liftIO . editStep e =<< handleEventLensed s query handleEditorEvent (EvKey k m) - --- | Handle a search event by updating `_numMatches` , `_matches` and `_wait`. -handleSearch :: Vector Text -> Searcher a -> SearchEvent -> EventM Bool (Next (Searcher a)) -handleSearch v s e = continue . (numMatches .~ e ^. totalMatches) . (matches %~ listReplace (e ^. matchedTop) Nothing) . (wait .~ Nothing) $ s +type AppSettings n a = AppSettingsG n a (Widget Bool) AppTheme -- | The brick widget used to display the editor and the search result. -searcherWidget :: Text -> Text -> Searcher a -> Widget Bool -searcherWidget p n s = joinBorders . border $ searchWidgetAux True p (s ^. query) (withAttr "Stats" . txt $ show (s ^. numMatches) <> "/" <> n) - <=> hBorder <=> joinBorders (listWithHighlights "➜ " id False (s ^. matches)) - --- | Handle the editing of the query by starting the computation of the matches in a new thread and storing the `ThreadId` in `_wait`. --- If the new query contains the last query then doesn't try to match the candidates that didn't match the last query, otherwise search among all the candidates. --- Might be possible to make the performance better by storing the indices of the filtered candidates for more than one previous query. -editStep :: SearchEnv a -> Searcher b -> IO (Searcher b) -editStep e@(SearchEnv f v b) s - | makeQuery s == (s ^. prevQuery) = pure s - | otherwise = (\w -> set wait (Just w) s') <$> replaceSearch isBigger e s' - where - isBigger = fromMaybe False $ T.isInfixOf <$> (s ^. prevQuery) <*> (headMay . getEditContents $ s ^. query) - s' = set prevQuery (makeQuery s) s - --- | The functions for generating a search event. It is executed in a separate thread via `forkIO` in `replaceSearch`. -search :: forall a. SearchFunctions a -> Vector Text -> Maybe Text -> IORef (U.Vector Int) -> IO SearchEvent -search fs v t r = (\(l , tm) -> SearchEvent tm l t) <$> atomicModifyIORef' r (searchWithMatcher fs v t) - --- | This function dispatches the computation of matches to a new thread and returns the new threadId. It also tries to kill the thread in which a previous computation --- was going on (Not sure if it actually accomplishes that, my understanding of exceptions is not good enough). -replaceSearch :: Bool -- ^ If True then search among all matches by writing a vector of all the indices into `_allMatches`. If False use `_allMatches` as is. - -> SearchEnv a -> Searcher b -> IO ThreadId -replaceSearch ib (SearchEnv fs v b) s = finally (forkIO . catch wrtev $ \ (_ :: AsyncException) -> pure ()) (maybe (pure ()) killThread (s ^. wait)) - where - wrtev = writeBChan b =<< search fs v (s ^. prevQuery) =<< mtchs - mtchs = if ib then pure $ s ^. allMatches else atomicWriteIORef (s ^. allMatches) (U.enumFromN 0 $ length v) $> (s ^. allMatches) +searcherWidget :: (KnownNat n , KnownNat m) => SearchEnv n a (Widget Bool) -> Text -> SearcherSized m a -> Widget Bool +searcherWidget env p s = joinBorders . border $ vBox [searchWidgetAux True p (s ^. queryEditor) (withAttr (attrName "Stats") . txt $ pack (show $ s ^. numMatches)) + , hBorder , listWithHighlights env "➜ " (s ^. matcher) False (s ^. matches)] defThemeAttrs :: [(AttrName, Attr)] -defThemeAttrs = [ (listSelectedAttr, withStyle (bg white) bold) , ("Prompt" , withStyle (white `on` blue) bold) - , ("Highlight" , withStyle (fg blue) bold) , ("Stats" , fg blue) , (borderAttr , fg cyan)] +defThemeAttrs = [ (listSelectedAttr, withStyle (bg white) bold) , (attrName "Prompt" , withStyle (white `on` blue) bold) + , (attrName "Highlight" , withStyle (fg blue) bold) , (attrName "Stats" , fg blue) , (borderAttr , fg cyan)] defTheme ::AppTheme defTheme = AppTheme {_prompt = "Find: " , _themeAttrs = defThemeAttrs , _borderStyle = unicodeRounded} -- | Default settings. Uses blue for various highlights and cyan for borders. All the hooks except keyHook which is `handleKeyEvent` are trivial. -defSettings :: AppSettings a b -defSettings = AppSettings defTheme (ReaderT (\e -> defHooks {keyHook = handleKeyEvent e})) +{-# INLINE defSettings#-} +defSettings :: KnownNat n => AppSettings n a +defSettings = AppSettings defTheme (ReaderT (\e -> defHooks {keyHook = handleKeyEvent e})) Proxy 4096 + (\r -> r ^. ocassion == QueryDone) -- | Tha app itself. `selected` and the related functions are probably more convenient for embedding into a larger program. -searchApp :: AppSettings a b -> SearchEnv a -> App (Searcher b) SearchEvent Bool -searchApp (AppSettings th hks) env@(SearchEnv _ v _) = App {appDraw = ad , appChooseCursor = showFirstCursor , appHandleEvent = he , appStartEvent = pure , appAttrMap = am} +searchApp ::KnownNat n => AppSettings n a -> SearchEnv n a (Widget Bool) -> App (Searcher a) (SearchEvent a) Bool +searchApp (AppSettings th hks _ _ _) env = App {appDraw = ad , appChooseCursor = showFirstCursor , appHandleEvent = he , appStartEvent = as , appAttrMap = am} where - ad = (:[]) . withBorderStyle (th ^. borderStyle) . searcherWidget (th ^. prompt) (show . length $ v) - am = const $ attrMap defAttr (th ^. themeAttrs) - hk = runReaderT hks env - he s (VtyEvent (EvKey k m)) = keyHook hk k m s - he s (VtyEvent (EvMouseDown i j b m)) = mouseDownHook hk i j b m s - he s (VtyEvent (EvMouseUp i j b )) = mouseUpHook hk i j b s - he s (VtyEvent (EvPaste b )) = pasteHook hk b s - he s (VtyEvent EvGainedFocus ) = focusGainedHook hk s - he s (VtyEvent EvLostFocus ) = focusLostHook hk s - he s (AppEvent e) = if e ^. term == s ^. prevQuery then handleSearch v s e else continue s - he s _ = continue s - --- | The initial state of the searcher. The editor is empty, the first @512@ elements of the vector are disaplyed as matches. -initialSearcher :: a -> Vector Text -> IORef (U.Vector Int) -> Searcher a -initialSearcher e v r = Searcher { _query = editorText True (Just 1) "" , _prevQuery = Nothing , _wait = Nothing - , _matches = list False ((:[]) <$> take 512 v) 0, _allMatches = r , _numMatches = length v , _extension = e} + ad (Searcher s) = (:[]) . withBorderStyle (th ^. borderStyle) . searcherWidget env (th ^. prompt) $ s + as = liftIO (sendQuery env "") + am = const $ attrMap defAttr (th ^. themeAttrs) + hk = runReaderT hks env + he (VtyEvent (EvKey k m)) = keyHook hk k m + he (VtyEvent (EvMouseDown i j b m)) = mouseDownHook hk i j b m + he (VtyEvent (EvMouseUp i j b )) = mouseUpHook hk i j b + he (VtyEvent (EvPaste b )) = pasteHook hk b + he (VtyEvent EvGainedFocus ) = focusGainedHook hk + he (VtyEvent EvLostFocus ) = focusLostHook hk + he (AppEvent e@(SearchEvent e')) = handleSearch e + he _ = pure () -- | Run app with given settings and return the final Searcher state. -runApp :: b -> AppSettings a b -> SearchFunctions a -> Vector Text -> IO (Searcher b) -runApp e s f v = (\b -> theMain (searchApp s (SearchEnv f v b)) b . initialSearcher e v =<< newIORef (U.enumFromN 0 . length $ v)) =<< newBChan 8 +runApp :: KnownNat n => AppSettings n a -> SearchFunctions a (Widget Bool) -> Chunks n -> IO (Searcher a) +runApp s f c = (\b -> (\env -> startSearcher env *> finally (theMain (searchApp s env) b . Searcher . initialSearcher env $ b) (stopSearcher env)) + =<< searchEnv f (s ^. maximumMatches) (generateSearchEvent (s ^. eventStrategy) b) c) =<< newBChan 8 -- | Run app with a vector that contains lines read from a handle and return the final Searcher state. -runAppFromHandle :: b -> AppSettings a b -> SearchFunctions a -> Handle -> IO (Searcher b) -runAppFromHandle e s f = runApp e s f . getCompact <=< compact . force <=< readVectorHandle +runAppFromHandle :: KnownNat n => AppSettings n a -> SearchFunctions a (Widget Bool) -> Handle -> IO (Searcher a) +runAppFromHandle s f = runApp s f . getCompact <=< compact . forceChunks <=< chunksFromHandle (s ^. chunkSize) +-- | Run app with a vector that contains lines read from a handle and return the final Searcher state. +runAppFromVector :: KnownNat n => AppSettings n a -> SearchFunctions a (Widget Bool) -> Vector Text -> IO (Searcher a) +runAppFromVector s f = runApp s f . getCompact <=< compact . forceChunks . makeChunks + -- | Run app and return the text of the selection if there is one else Nothing. -selected :: AppSettings a () -> SearchFunctions a -> Vector Text -> IO (Maybe Text) -selected s f = map (map (mconcat . snd) . listSelectedElement . (^. matches)) . runApp () s f . getCompact <=< compact . force +selected :: KnownNat n => AppSettings n a -> SearchFunctions a (Widget Bool) -> Chunks n -> IO (Maybe Text) +selected s f = (\c -> map (selectedElement c) . runApp s f $ c) . getCompact <=< compact . forceChunks -- | Same as `selected` but reads the vector from the supplied handle. -selectedFromHandle :: AppSettings a () -> SearchFunctions a -> Handle -> IO (Maybe Text) -selectedFromHandle s f = selected s f <=< readVectorHandle +selectedFromHandle :: KnownNat n => AppSettings n a -> SearchFunctions a (Widget Bool) -> Handle -> IO (Maybe Text) +selectedFromHandle s f = selected s f <=< chunksFromHandle (s ^. chunkSize) -- | Same as `selectedFromHandle` but allows for transforming the lines read and the final vector with supplied functions. See also `readVectorHandleWith`. -selectedFromHandleWith :: (Text -> Text) -> (Vector Text -> Vector Text) -> AppSettings a () -> SearchFunctions a -> Handle -> IO (Maybe Text) -selectedFromHandleWith w t s f = selected s f <=< readVectorHandleWith w t +selectedFromHandleWith :: KnownNat n => (Text -> Text) -> (Vector Text -> Vector Text) -> AppSettings n a -> SearchFunctions a (Widget Bool) -> Handle -> IO (Maybe Text) +selectedFromHandleWith w t s f = selected s f . makeChunks <=< readVectorHandleWith w t -- | Another variation on `selectedFromHandle`. See `fileNamesSorted` for what happens to read vector. -selectedFromFileNamesSorted :: AppSettings a () -> SearchFunctions a -> Handle -> IO (Maybe Text) -selectedFromFileNamesSorted s f = selected s f <=< fileNamesSorted +selectedFromFileNamesSorted :: KnownNat n => AppSettings n a -> SearchFunctions a (Widget Bool) -> Handle -> IO (Maybe Text) +selectedFromFileNamesSorted s f = selected s f . makeChunks <=< fileNamesSorted -- | Version of `selected` for file search using a simple implementation of searching file trees from "Talash.Files". Better to use either other -- libraries like @unix-recursive@ or external programs like @fd@ for more complicated tasks. -selectedFromFiles :: AppSettings a () -> SearchFunctions a -> [FindInDirs] -> IO (Maybe Text) -selectedFromFiles s f = selected s f . (flatten =<<) <=< findFilesInDirs +selectedFromFiles :: KnownNat n => AppSettings n a -> SearchFunctions a (Widget Bool) -> [FindInDirs] -> IO (Maybe Text) +selectedFromFiles s f = selected s f . forceChunks . makeChunks . (flatten =<<) <=< findFilesInDirs +selectedUsing :: KnownNat n => AppSettings n a -> SearchFunctions a (Widget Bool) -> (a -> Text) -> Vector a -> IO (Maybe a) +selectedUsing s f t v = map (map (unsafeIndex v) . (`elemIndex` w) =<<) . selected s f . makeChunks $ w + where + w = map t v + -- | A version of `selected` that puts the selected text on the stdout. -runSearch :: AppSettings a () -> SearchFunctions a -> IO () -runSearch s f = maybe (pure ()) putStrLn =<< selected s f =<< readVectorStdIn +runSearch :: AppSettings 64 a -> SearchFunctions a (Widget Bool) -> IO () +runSearch s f = maybe (pure ()) putStrLn =<< selected s f =<< chunksFromStream =<< I.decodeUtf8 =<< I.lines I.stdin -- | The backend for `run` run' :: [String] -> IO () -run' [] = runSearch defSettings searchFunctionsOL -run' ["fuzzy"] = runSearch defSettings searchFunctionsFuzzy -run' ["orderless"] = runSearch defSettings searchFunctionsOL +run' [] = runSearch defSettings (orderlessFunctions IgnoreCase) +run' ["fuzzy"] = runSearch defSettings (fuzzyFunctions IgnoreCase) +run' ["orderless"] = runSearch defSettings (orderlessFunctions IgnoreCase) run' xs = (\t -> C.printColored putStr t usageString) =<< C.getTerm usageString :: Colored Text diff --git a/src/Talash/Brick/Columns.hs b/src/Talash/Brick/Columns.hs --- a/src/Talash/Brick/Columns.hs +++ b/src/Talash/Brick/Columns.hs @@ -11,93 +11,30 @@ -- length. Otherwise this module provides a reduced version of the functions in "Talash.Brick". -- This module hasn't been tested on large data and will likely be slow. -module Talash.Brick.Columns (-- * Types - Searcher (..) , SearchEvent (..) , SearchEnv (..) , SearchFunctions (..) , EventHooks (..) , AppTheme (..) , AppSettings (..) +module Talash.Brick.Columns (-- -- * Types + Searcher (..) , SearchEvent (..) , SearchEnv (..) , EventHooks (..) , AppTheme (..) + , AppSettings (..) , AppSettingsG (..) , SearchFunctions , CaseSensitivity (..) -- * The Brick App and Helpers - , searchApp , defSettings , searchFunctionsFuzzy , searchFunctionsOL , selected , selectedIndex , runApp + , searchApp , defSettings , selected , selectedIndex , runApp -- * Lenses -- ** Searcher - , query , prevQuery , allMatches , matches , numMatches , wait + , query , prevQuery , allMatches , matches , numMatches -- ** SearchEvent , matchedTop , totalMatches , term -- ** SearchEnv , searchFunctions , candidates , eventSource - -- ** SearchFunctions - , makeMatcher , lister , displayer -- ** AppTheme , prompt , themeAttrs , borderStyle -- ** SearchSettings , theme , hooks -- * Exposed Internals - , makeQuery , haltQuit , handleKeyEvent , handleSearch , editStep , replaceSearch , search , searcherWidget , initialSearcher - , searchWithMatcher , partsColumns , emptyIndices , runApp' , selected' , selectedIndex' ) where + , handleKeyEvent , handleSearch , searcherWidget , initialSearcher , partsColumns , runApp' , selected' , selectedIndex') where -import Control.Concurrent(forkIO , killThread, ThreadId) -import Control.Exception (finally , catch, AsyncException) -import Data.IORef (IORef , newIORef , atomicModifyIORef' , atomicWriteIORef) import qualified Data.Text as T -import Data.Text.AhoCorasick.Automaton (CaseSensitivity (..)) -import qualified Data.Text.IO as T -import Data.Vector (Vector , (!), force , generate , take, singleton , convert, enumFromN, unfoldrM, indexed , elemIndex) -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Sized as S +import Data.Vector (elemIndex) import GHC.Compact (Compact , compact , getCompact) -import GHC.TypeNats -import Intro hiding (on ,replicate , take) -import System.Environment (getArgs) -import System.IO ( Handle , hIsEOF , isEOF, hClose, stdin) import Talash.Brick.Internal -import Talash.Core hiding (makeMatcher) - -data SearchFunctions a = SearchFunctions { _makeMatcher :: Text -> Maybe (Matcher a) - , _displayer :: forall n. KnownNat n => MatcherSized n a -> Text -> S.Vector n Int -> [[Text]] - , _lister :: forall n. KnownNat n => MatcherSized n a -> Vector Text -> U.Vector Int -> (U.Vector Int , U.Vector (Indices n))} -makeLenses ''SearchFunctions - -data Searcher a = Searcher { -- | The editor to get the query from. - _query :: Editor Text Bool - -- | The last query which is saved to check if we should only search among the matches for it or all the candidates. - , _prevQuery :: Maybe Text - -- | An IORef containing the indices of the filtered candidates. These are in an IORef to make it easier to deal with them in a different thread - -- than the UI of the app. Maybe it should be moved to `SearchEnv` - , _allMatches :: IORef (U.Vector Int) - -- | Each outer list reprsents a column. The inner list is the text for that column split up as an alternating sequences of match - -- substrings and the gap between them. The first substring is always a gap and can be empty, the rest should be no empty. - , _matches :: List Bool [[Text]] - -- | The (maximum possible) number of matches. This is the length of vector stored in `_allMatches` which also contains the indices of - -- which weren't matched in case enough matches were found before going through all the candidates. - , _numMatches :: Int - -- | ThreadId of the thread currently computing matches. Nothing if there is no such thread. - , _wait :: Maybe ThreadId - -- | Unused by default but can be used store extra state needed for any extension to the functionality. For example to have multiple - -- selections this can be set to a `Vector` that stores them. - , _extension :: a} deriving Functor -makeLenses ''Searcher - -data SearchEvent = SearchEvent { - -- | The matches received. - _matchedTop :: Vector [[Text]] , - -- | The (maximum possible) number of matches. See the note on `_numMatches`. - _totalMatches :: Int , - -- | The term which was searched for. - _term :: Maybe Text} -makeLenses ''SearchEvent - --- | The constant environment in which they search app runs. -data SearchEnv a = SearchEnv { _searchFunctions :: SearchFunctions a -- ^ The functions used to find and display matches. - , _candidates :: Vector Text -- ^ The vector of candidates. - , _eventSource :: BChan SearchEvent -- ^ The BChan from which the app receives search events. - } -makeLenses ''SearchEnv - --- | Event hooks are almost direct translations of the events from vty i.e. see `Event`. -data EventHooks a = EventHooks { keyHook :: Key -> [Modifier] -> a -> EventM Bool (Next a) - , pasteHook :: ByteString -> a -> EventM Bool (Next a) - , resizeHook :: Int -> Int -> a -> EventM Bool (Next a) - , mouseDownHook :: Int -> Int -> Button -> [Modifier] -> a -> EventM Bool (Next a) - , mouseUpHook :: Int -> Int -> Maybe Button -> a -> EventM Bool (Next a) - , focusLostHook :: a -> EventM Bool (Next a) - , focusGainedHook :: a -> EventM Bool (Next a)} +import Talash.Intro hiding (on ,replicate , take) data AppTheme = AppTheme { _prompt :: Text -- ^ The prompt to display next to the editor. , _columnAttrs :: [AttrName] -- ^ The attrNames to use for each column. Must have the same length or greater length than the number of columns. @@ -110,120 +47,45 @@ } makeLenses ''AppTheme -data AppSettings a b = AppSettings { _theme :: AppTheme - , _hooks :: ReaderT (SearchEnv a) EventHooks (Searcher b) -- ^ The event hooks which can make use of the search environment. - } -makeLenses ''AppSettings - -defHooks :: EventHooks a -defHooks = EventHooks (const . const continue) (const continue) (const . const continue) (const . const . const . const continue) - (const . const . const continue) continue continue - -emptyIndices :: Int -> U.Vector (Indices 0) -emptyIndices n = U.generate n ( , S.empty) - --- | Get the current query from the editor of the searcher. -makeQuery :: Searcher a -> Maybe Text -makeQuery s = headMay . getEditContents $ s ^. query - --- | Handling of keypresses. The default bindings are --- @Enter@ exits the app with the current selection. --- @Esc@ exits without any selection --- @Up@ , @Down@ , @PageUp@ and @PageDown@ move through the matches. --- All others keys are used for editing the query. See `handleEditorEvent` for details. -handleKeyEvent :: SearchEnv a -> Key -> [Modifier] -> Searcher b -> EventM Bool (Next (Searcher b)) -handleKeyEvent env k m s - | k == KEnter && null m = halt s - | k == KEsc && null m = haltQuit s - | elem k [KUp , KDown , KPageUp , KPageDown] && null m = continue =<< handleEventLensed s matches handleListEvent (EvKey k m) - | otherwise = continue =<< liftIO . editStep env =<< handleEventLensed s query handleEditorEvent (EvKey k m) +type AppSettings n a = AppSettingsG n a Text AppTheme --- | Handle a search event by updating `_numMatches` , `_matches` and `_wait`. -handleSearch :: Vector Text -> Searcher a -> SearchEvent -> EventM Bool (Next (Searcher a)) -handleSearch v s e = continue . (numMatches .~ e ^. totalMatches) . (matches %~ listReplace (e ^. matchedTop) Nothing) . (wait .~ Nothing) $ s +data ColumnsIso a = ColumnsIso { _toColumns :: a -> [Text] , _fromColumns :: [Text] -> a} +makeLenses ''ColumnsIso -- | The brick widget used to display the editor and the search result. -searcherWidget :: [AttrName] -> [Int] -> Text -> Text -> Searcher a -> Widget Bool -searcherWidget as ls p n s = joinBorders . border $ searchWidgetAux True p (s ^. query) (withAttr "Stats" . txt $ show (s ^. numMatches) <> "/" <> n) - <=> hBorder <=> joinBorders (columnsListWithHighlights "➜ " id as ls False (s ^. matches)) - --- | Quit without any selection. -haltQuit :: Searcher a -> EventM n (Next (Searcher a)) -haltQuit = halt . ((matches . listSelectedL) .~ Nothing) - --- | Handle the editing of the query by starting the computation of the matches in a new thread and storing the `ThreadId` in `_wait`. --- If the new query contains the last query then doesn't try to match the candidates that didn't match the last query, otherwise search among all the candidates. --- Might be possible to make the performance better by storing the indices of the filtered candidates for more than one previous query. -editStep :: SearchEnv a -> Searcher b -> IO (Searcher b) -editStep env s - | makeQuery s == (s ^. prevQuery) = pure s - | otherwise = (\w -> set wait (Just w) s') <$> replaceSearch isBigger env s' - where - isBigger = fromMaybe False $ T.isInfixOf <$> (s ^. prevQuery) <*> (headMay . getEditContents $ s ^. query) - s' = set prevQuery (makeQuery s) s - --- | The functions for generating a search event. It is executed in a separate thread via `forkIO` in `replaceSearch`. -search :: SearchFunctions a -> Vector Text -> Maybe Text -> IORef (U.Vector Int) -> IO SearchEvent -search fs v t r = (\(l , tm) -> SearchEvent tm l t) <$> atomicModifyIORef' r (searchWithMatcher fs v t) - --- | searchWithMatcher carries out one step of the search. Note that the search can stops before going through the whole vector of text. In that case the returned --- vector of indices should contain not only the indices matched candidates but also the indices of candidates that weren't tested for a match. -searchWithMatcher :: SearchFunctions a -> Vector Text -> Maybe Text -> U.Vector Int -> (U.Vector Int , (Int , Vector [[Text]])) -searchWithMatcher fs v t s = maybe nc go ((fs ^. makeMatcher) =<< t) - where - nc = (U.enumFromN 0 (length v) , (0 , force . map (\i -> map (:[]) . T.lines $ v ! (i ^. _1)) . convert . emptyIndices . min 512 . length $ v)) - go (Matcher f') = (iv , (U.length iv , force . map (\i -> (fs ^. displayer) f' (v ! (i ^. _1)) (i ^. _2)) . convert $ mv)) - where - (iv , mv) = (fs ^. lister) f' v s - --- | This function dispatches the computation of matches to a new thread and returns the new threadId. It also tries to kill the thread in which a previous computation --- was going on (Not sure if it actually accomplishes that, my understanding of exceptions is not good enough). -replaceSearch :: Bool -> SearchEnv a -> Searcher b -> IO ThreadId -replaceSearch ib (SearchEnv fs v b) s = finally (forkIO . catch wrtev $ \ (_ :: AsyncException) -> pure ()) (maybe (pure ()) killThread (s ^. wait)) - where - wrtev = writeBChan b =<< search fs v (s ^. prevQuery) =<< mtchs - mtchs = if ib then pure $ s ^. allMatches else atomicWriteIORef (s ^. allMatches) (U.enumFromN 0 $ length v) $> (s ^. allMatches) +searcherWidget :: (KnownNat n , KnownNat m) => AppTheme -> SearchEnv n a Text -> SearcherSized m a -> Widget Bool +searcherWidget t env s = joinBorders . border $ searchWidgetAux True (t ^. prompt) (s ^. queryEditor) (withAttr (attrName "Stats") . txt $ (T.pack . show $ s ^. numMatches)) + <=> hBorder <=> joinBorders (makeColumns env "➜ " (t ^. columnAttrs) (t ^. columnLimits) (s ^. matcher) False (s ^. matches)) defThemeAttrs :: [(AttrName, Attr)] -defThemeAttrs = [ (listSelectedAttr, withStyle (bg white) bold) , ("Prompt" , withStyle (white `on` blue) bold) - , ("Highlight" , withStyle (fg blue) bold) , ("Stats" , fg blue) , (borderAttr , fg cyan)] +defThemeAttrs = [ (listSelectedAttr, withStyle (bg white) bold) , (attrName "Prompt" , withStyle (white `on` blue) bold) + , (attrName "Highlight" , withStyle (fg blue) bold) , (attrName "Stats" , fg blue) , (borderAttr , fg cyan)] defTheme ::AppTheme defTheme = AppTheme {_prompt = "Find: " , _columnAttrs = repeat mempty , _columnLimits = repeat 50 , _themeAttrs = defThemeAttrs , _borderStyle = unicodeRounded} -- | Default settings. Uses blue for various highlights and cyan for borders. All the hooks except keyHook which is `handleKeyEvent` are trivial. -defSettings :: AppSettings a b -defSettings = AppSettings defTheme (ReaderT (\e -> defHooks {keyHook = handleKeyEvent e})) +{-# INLINE defSettings#-} +defSettings :: KnownNat n => AppSettings n a +defSettings = AppSettings defTheme (ReaderT (\e -> defHooks {keyHook = handleKeyEvent e})) Proxy 1024 (\r -> r ^. ocassion == QueryDone) -- | Tha app itself. `selected` and the related functions are probably more convenient for embedding into a larger program. -searchApp :: AppSettings a b -> SearchEnv a -> App (Searcher b) SearchEvent Bool -searchApp (AppSettings th hks) env@(SearchEnv fs v b) = App {appDraw = ad , appChooseCursor = showFirstCursor , appHandleEvent = he , appStartEvent = pure , appAttrMap = am} +searchApp :: KnownNat n => AppSettings n a -> SearchEnv n a Text -> App (Searcher a) (SearchEvent a) Bool +searchApp (AppSettings th hks _ _ _) env = App {appDraw = ad , appChooseCursor = showFirstCursor , appHandleEvent = he , appStartEvent = as , appAttrMap = am} where - ad = (:[]) . withBorderStyle (th ^. borderStyle) . searcherWidget (th ^. columnAttrs) (th ^. columnLimits) (th ^. prompt) (show . length $ v) - am = const $ attrMap defAttr (th ^. themeAttrs) - hk = runReaderT hks env - he s (VtyEvent (EvKey k m)) = keyHook hk k m s - he s (VtyEvent (EvMouseDown i j b m)) = mouseDownHook hk i j b m s - he s (VtyEvent (EvMouseUp i j b )) = mouseUpHook hk i j b s - he s (VtyEvent (EvPaste b )) = pasteHook hk b s - he s (VtyEvent EvGainedFocus ) = focusGainedHook hk s - he s (VtyEvent EvLostFocus ) = focusLostHook hk s - he s (AppEvent e) = if e ^. term == s ^. prevQuery then handleSearch v s e else continue s - he s _ = continue s - --- | The initial state of the searcher. -initialSearcher :: a -> Vector Text -> IORef (U.Vector Int) -> Searcher a -initialSearcher e v r = Searcher { _query = editorText True (Just 1) "" , _prevQuery = Nothing , _wait = Nothing - , _matches = list False (map (:[]) . T.lines <$> take 512 v) 0, _allMatches = r , _numMatches = length v , _extension = e} - --- | Search functions suitable for fuzzy matching. The candidate @c@ will match the query @s@ if @c@ contains all the characters in @s@ in order. In general there --- can be several ways of matching. This tries to find a match with minimum number of parts of. It does not find the minimum number of parts, if that requires --- reducing the extent of the partial match during search. E.g. matching @"as"@ against @"talash"@ the split will be @["tal","as","h"]@ and not --- @["t","a","la","s","h"]@. While matching @"talash best match testing hat"@ against @"tea"@ will not result in @["talash best match ","te","sting h","a","t"]@ since --- @"te"@ occurs only after we have match all three letters and we can't know if we will find the @"a"@ without going through the string. -searchFunctionsFuzzy :: SearchFunctions MatchPart -searchFunctionsFuzzy = SearchFunctions (fuzzyMatcher IgnoreCase) (\m t -> partsColumns . parts (S.fromSized <$> sizes m) t . S.fromSized) (searchSome (fuzzySettings 512)) + ad (Searcher s) = (:[]) . withBorderStyle (th ^. borderStyle) . searcherWidget th env $ s + as = liftIO (sendQuery env "") + am = const $ attrMap defAttr (th ^. themeAttrs) + hk = runReaderT hks env + he (VtyEvent (EvKey k m)) = keyHook hk k m + he (VtyEvent (EvMouseDown i j b m)) = mouseDownHook hk i j b m + he (VtyEvent (EvMouseUp i j b )) = mouseUpHook hk i j b + he (VtyEvent (EvPaste b )) = pasteHook hk b + he (VtyEvent EvGainedFocus ) = focusGainedHook hk + he (VtyEvent EvLostFocus ) = focusLostHook hk + he (AppEvent e) = handleSearch e + he _ = pure () -- | This function reconstructs the columns from the parts returned by the search by finding the newlines. partsColumns :: [Text] -> [[Text]] @@ -235,32 +97,36 @@ s' = tailDef [] s hs = maybe ([] , Nothing) (bimap (:[]) (T.stripPrefix "\n") . T.breakOn "\n") . headMay $ s --- | Search functions that match the words in i.e. space separated substring in any order. "talash best" will match "be as" with the split --- ["tal","as","h","be","st"] but "talash best" will not match "bet". -searchFunctionsOL :: SearchFunctions Int -searchFunctionsOL = SearchFunctions (orderlessMatcher IgnoreCase) (\m t -> partsColumns . partsOrderless (S.fromSized <$> sizes m) t . S.fromSized) - (searchSome (orderlessSettings 512)) +makeColumns :: (Ord n , Show n , KnownNat m , KnownNat l) => SearchEnv l a Text -> Text -> [AttrName] -> [Int] + -> MatcherSized m a -> Bool -> GenericList n MatchSetG (ScoredMatchSized m) -> Widget n +makeColumns env c as ls m = renderList (columnsWithHighlights c mp as ls) + where + mp s = partsColumns $ (env ^. searchFunctions . display) (const id) m ((env ^. candidates) ! chunkIndex s) (matchData s) -- | The \'raw\' version of `runApp` taking a vector of text with columns separated by newlines. -runApp' :: b -> AppSettings a b -> SearchFunctions a -> Vector Text -> IO (Searcher b) -runApp' e s f v = (\b -> theMain (searchApp s (SearchEnv f v b)) b . initialSearcher e v =<< newIORef (U.enumFromN 0 . length $ v)) =<< newBChan 8 +runApp' :: KnownNat n => AppSettings n a -> SearchFunctions a Text -> Chunks n -> IO (Searcher a) +runApp' s f c = (\b -> (\env -> startSearcher env *> finally (theMain (searchApp s env) b . Searcher . initialSearcher env $ b) (stopSearcher env)) + =<< searchEnv f (s ^. maximumMatches) (generateSearchEvent (s ^. eventStrategy) b) c) =<< newBChan 8 --- | Run app with given settings and return the final Searcher state. -runApp :: b -> AppSettings a b -> SearchFunctions a -> Vector [Text] -> IO (Searcher b) -runApp e s f = runApp' e s f . map T.unlines +-- -- | Run app with given settings and return the final Searcher state. +runApp :: KnownNat n => AppSettings n a -> SearchFunctions a Text -> Vector [Text] -> IO (Searcher a) +runApp s f = runApp' s f . makeChunks . map T.unlines -- | The \'raw\' version of `selected` taking a vector of text with columns separated by newlines. -selected' :: AppSettings a () -> SearchFunctions a -> Vector Text -> IO (Maybe [Text]) -selected' s f = map (map (map mconcat . snd) . listSelectedElement . (^. matches)) . runApp' () s f . getCompact <=< compact . force +selected' :: KnownNat n => AppSettings n a -> SearchFunctions a Text -> Chunks n -> IO (Maybe [Text]) +selected' s f = (\c -> map (map T.lines . selectedElement c) . runApp' s f $ c) . getCompact <=< compact . forceChunks -- | Run app and return the the selection if there is one else Nothing. -selected :: AppSettings a () -> SearchFunctions a -> Vector [Text] -> IO (Maybe [Text]) -selected s f = selected' s f . map T.unlines +selected :: KnownNat n => AppSettings n a -> SearchFunctions a Text -> Vector [Text] -> IO (Maybe [Text]) +selected s f = selected' s f . makeChunks . map T.unlines +selectedIso :: KnownNat n => ColumnsIso a -> AppSettings n b -> SearchFunctions b Text -> Vector a -> IO (Maybe a) +selectedIso (ColumnsIso from to) s f = map (map to) . selected' s f . makeChunks . map (T.unlines . from) + -- | The \'raw\' version of `selectedIndex` taking a vector of text with columns separated by newlines. -selectedIndex' :: AppSettings a () -> SearchFunctions a -> Vector Text -> IO (Maybe Int) -selectedIndex' s f v = ((`elemIndex` v) . T.unlines =<<) <$> selected' s f v +selectedIndex' :: KnownNat n => AppSettings n a -> SearchFunctions a Text -> Vector Text -> IO (Maybe Int) +selectedIndex' s f v = ((`elemIndex` v) . T.unlines =<<) <$> selected' s f (makeChunks v) -- | Returns the index of selected candidate in the vector of candidates. Note: it uses `elemIndex` which is O\(N\). -selectedIndex :: AppSettings a () -> SearchFunctions a -> Vector [Text] -> IO (Maybe Int) +selectedIndex :: KnownNat n => AppSettings n a -> SearchFunctions a Text -> Vector [Text] -> IO (Maybe Int) selectedIndex s f = selectedIndex' s f . map T.unlines diff --git a/src/Talash/Brick/Internal.hs b/src/Talash/Brick/Internal.hs --- a/src/Talash/Brick/Internal.hs +++ b/src/Talash/Brick/Internal.hs @@ -1,25 +1,98 @@ -module Talash.Brick.Internal (twoColumnText , columns , searchWidget , searchWidgetAux , headingAndBody , listWithHighlights , columnsListWithHighlights - , theMain , module Export) where +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ExistentialQuantification #-} +module Talash.Brick.Internal (twoColumnText , columns , searchWidget , searchWidgetAux , headingAndBody , listWithHighlights , columnsWithHighlights + , MatchSetG (..) , Searcher (..) , SearchEvent (..) , SearchEnv (..) , EventHooks (..) , AppSettingsG (..) + , SearchEventSized (..) , SearcherSized (..) + , queryEditor , matches , matcher , numMatches , eventSource , theme , hooks , chunkSize , maximumMatches , eventStrategy + , matchedTop , totMatches , term , getQuery , defHooks , theMain , initialSearcher , generateSearchEvent + , handleKeyEvent , handleSearch , selectedElement , renderList , module Export) where + import Brick as Export import Brick.BChan as Export (BChan , newBChan , writeBChan) -import Brick.Markup as Export (Markup , (@?) , markup, GetAttr) import Brick.Widgets.Border as Export (border, vBorder, hBorder, borderAttr) import Brick.Widgets.Border.Style as Export import Brick.Widgets.Center as Export (vCenter, center) import Brick.Widgets.Edit as Export (editor , editorText, renderEditor, Editor, handleEditorEvent, getEditContents, applyEdit ) -import Brick.Widgets.List as Export (List, list ,handleListEvent, handleListEventVi, listAttr, listSelectedAttr, listSelectedElement , listSelectedL - ,listReplace , renderListWithIndex, renderList , listElements, GenericList (listElements, listSelected)) -import Data.Text.Markup as Export (toText) +import Brick.Widgets.List as Export (Splittable (..) , List, list ,handleListEvent, handleListEventVi, listAttr, listSelectedAttr, listSelectedElement , listSelectedL + , listReplace , listElements, GenericList (listElements, listSelected) , listMoveUp , listMoveDown , slice) +import qualified Brick.Widgets.List as L +import qualified Data.Set as DS +import qualified Data.Text as T +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Sized as S import Graphics.Vty as Export (defAttr, cyan, white, blue, withStyle, bold, brightMagenta, black, magenta, brightBlue, Attr, defaultConfig, mkVty, green, standardIOConfig) -import Graphics.Vty.Config (Config(inputFd)) -import Graphics.Vty.Input.Events as Export -import Intro -import Lens.Micro as Export (ASetter' , over, set, (^.) , _1 , _2 , _3 , (.~) , (?~) , (%~)) +import qualified Graphics.Vty as V +import Graphics.Vty.Config (inputFd) +import Graphics.Vty.Input.Events as Export +import Lens.Micro (_head , (^?)) import Lens.Micro.TH as Export ( makeLenses ) import System.Posix.IO import System.Posix.Terminal +import Talash.Chunked as Export +import Talash.Intro +newtype MatchSetG a = MatchSetG (DS.Set a) deriving Foldable + +instance Splittable MatchSetG where + splitAt n (MatchSetG s) = (MatchSetG p , MatchSetG q) + where + (p,q) = DS.splitAt n s + +data SearchEventSized n a = SearchEventSized { _matcherEv :: {-# UNPACK #-} !(MatcherSized n a) + -- | The (maximum possible) number of matches. See the note on `_numMatches`. + , _totMatches :: {-# UNPACK #-} !Int + -- | The term which was searched for. + , _term :: {-# UNPACK #-} !Text + , -- | The matches received. + _matchedTop :: !(MatchSetSized n)} +makeLenses ''SearchEventSized + +data SearchEvent a = forall n. KnownNat n => SearchEvent (SearchEventSized n a) + +data SearcherSized n a = SearcherSized { -- | The editor to get the query from. + _queryEditor :: Editor Text Bool + , _matches :: GenericList Bool MatchSetG (ScoredMatchSized n) + , _matcher :: MatcherSized n a + , _numMatches :: Int + , _eventSource :: BChan (SearchEvent a) -- ^ The BChan from which the app receives search events. + } +makeLenses ''SearcherSized + +data Searcher a = forall n. KnownNat n => Searcher {getSearcher :: SearcherSized n a} + +{-# INLINE generateSearchEvent #-} +generateSearchEvent :: forall m a b c. KnownNat m => (SearchReport -> Bool) -> BChan (SearchEvent a) -> c -> SearchReport -> MatcherSized m a -> MatchSetSized m -> IO () +generateSearchEvent p b _ = go + where + go r m = when (p r) . writeBChan b . SearchEvent . SearchEventSized m (r ^. nummatches) (r ^. searchedTerm) + +-- | Event hooks are almost direct translations of the events from vty i.e. see `Event`. +data EventHooks a = EventHooks { keyHook :: Key -> [Modifier] -> EventM Bool a () + , pasteHook :: ByteString -> EventM Bool a () + , resizeHook :: Int -> Int -> EventM Bool a () + , mouseDownHook :: Int -> Int -> Button -> [Modifier] -> EventM Bool a () + , mouseUpHook :: Int -> Int -> Maybe Button -> EventM Bool a () + , focusLostHook :: EventM Bool a () + , focusGainedHook :: EventM Bool a ()} + +data AppSettingsG (n :: Nat) a b t = AppSettings { _theme :: t + , _hooks :: ReaderT (SearchEnv n a b) EventHooks (Searcher a) -- ^ The event hooks which can make use of the search environment. + , _chunkSize :: Proxy n + , _maximumMatches :: Int + , _eventStrategy :: SearchReport -> Bool} +makeLenses ''AppSettingsG + +defHooks :: EventHooks a +defHooks = EventHooks (const . const (pure ())) (const (pure ())) (const . const (pure ())) (const . const . const . const (pure ())) + (const . const . const (pure ())) (pure ()) (pure ()) + +getQuery :: SearcherSized n a -> Text +getQuery s = fromMaybe "" . listToMaybe . getEditContents $ s ^. queryEditor + twoColumnText :: Int -> Text -> Text -> Widget n twoColumnText n t1 t2 = joinBorders . vLimit 1 $ go n t1 <+> go 100 t2 where @@ -29,24 +102,103 @@ columns f as ls = vLimit 1 . hBox . zipWith3 (\a l t -> hLimitPercent l $ (padRight (Pad 2) . withAttr a . f $ t) <+> fill ' ') as ls searchWidget :: (Ord n , Show n) => Bool -> Text -> Editor Text n -> Widget n -searchWidget b p e = withAttr "Prompt" (padLeftRight 2 . txt $ p) <+> padLeftRight 2 (renderEditor (hBox . map txt) b e) +searchWidget b p e = hBox [withAttr (attrName "Prompt") (padLeftRight 2 . txt $ p) , padLeftRight 2 (renderEditor (hBox . map txt) b e)] searchWidgetAux :: (Ord n , Show n) => Bool -> Text -> Editor Text n -> Widget n -> Widget n -searchWidgetAux b p e w = withAttr "Prompt" (padLeftRight 2 . txt $ p) <+> padLeftRight 2 (renderEditor (hBox . map txt) b e) <+> w +searchWidgetAux b p e w = hBox [withAttr (attrName "Prompt") (padLeftRight 2 . txt $ p) , padLeftRight 2 (renderEditor (hBox . map txt) b e) , w] -highlightAlternate :: Foldable f => (a -> Widget n) -> f a -> Widget n -highlightAlternate f = fst . foldl' (\(!w , !b) !n -> (w <+> if b then withAttr "Highlight" (f n) else f n , not b)) (emptyWidget , False) +highlightAlternate :: (a -> Widget n) -> [a] -> Widget n +highlightAlternate f = hBox . zipWith (\b e -> if b then withAttr (attrName "Highlight") (f e) else f e) (cycle [False , True]) headingAndBody :: Text -> Text -> Widget n -headingAndBody h b = withAttr "Heading" (txt h) <=> txtWrap b +headingAndBody h b = withAttr (attrName "Heading") (txt h) <=> txtWrap b -listWithHighlights :: (Foldable f , Ord n , Show n) => Text -> (a -> f Text) -> Bool -> List n a -> Widget n -listWithHighlights c f = renderList (\s e -> vLimit 1 . (txt (if s then c else " ") <+>) . (<+> fill ' ') . highlightAlternate txt . f $! e) +listWithHighlights :: (Ord n , Show n , KnownNat m , KnownNat l) => SearchEnv l a (Widget n) -> Text + -> MatcherSized m a -> Bool -> GenericList n MatchSetG (ScoredMatchSized m) -> Widget n +listWithHighlights env c m = renderList (\s e -> hBox [txtLine (if s then c else " ") , hBox . go $! e]) + where + go (ScoredMatchSized _ i v) = (env ^. searchFunctions . display) (\b e -> if b then withAttr (attrName "Highlight") (txtLine e) else txtLine e) m ((env ^. candidates) ! i) v -columnsListWithHighlights :: (Foldable f , Ord n , Show n) => Text -> (a -> [f Text]) -> [AttrName] -> [Int] -> Bool -> List n a -> Widget n -columnsListWithHighlights c f as ls = renderList (\s e -> (txt (if s then c else " ") <+>) . columns (highlightAlternate txt) as ls . f $! e) +columnsWithHighlights :: Text -> (a -> [[Text]]) -> [AttrName] -> [Int] -> Bool -> a -> Widget n +columnsWithHighlights c f as ls s e = (txt (if s then c else " ") <+>) . columns (highlightAlternate txt) as ls . f $! e theMain :: Ord n => App b e n -> BChan e -> b -> IO b theMain a b s = (\v -> customMain v (pure v) (Just b) a s) =<< mkVty =<<(\c -> (\fd -> c {inputFd = Just fd}) <$> termFd) =<< standardIOConfig where termFd = (\f -> openFd f ReadOnly Nothing (OpenFileFlags False False False False False)) =<< getControllingTerminalName + +drawListElements :: (Ord n, Show n, Foldable t, Splittable t) => (Int -> Bool -> a -> Widget n) -> Bool -> GenericList n t a -> Widget n +drawListElements drawElem foc l = + Widget Greedy Greedy $ do + c <- getContext + let es = slice start (numPerHeight * 2) (l^. L.listElementsL) + idx = fromMaybe 0 (l^. L.listSelectedL) + start = max 0 $ idx - numPerHeight + 1 + numPerHeight = 1 + (c^.availHeightL - 1) `div` (l^. L.listItemHeightL) + off = start * (l^. L.listItemHeightL) + drawElement j e = + let isSelected = Just j == l^.listSelectedL + elemWidget = drawElem j isSelected e + selItemAttr = withDefAttr listSelectedAttr + makeVisible = if isSelected + then visible . selItemAttr + else id + in makeVisible elemWidget + render $ viewport (l^. L.listNameL) Vertical $ + translateBy (Location (0, off)) $ vBox . zipWith drawElement [start ..] . toList $ es + +selectedElementInternal :: (Foldable t, Splittable t) => GenericList n t a -> Maybe (Int, a) +selectedElementInternal l = do + sel <- l^.listSelectedL + let (_, xs) = L.splitAt sel (l ^. L.listElementsL) + (sel,) <$> toList xs ^? _head + +{-# INLINE renderListWithIndex #-} +renderListWithIndex :: (Ord n, Show n, Foldable t, Splittable t) => (Int -> Bool -> a -> Widget n) -> Bool -> GenericList n t a -> Widget n +renderListWithIndex drawElem foc = withDefAttr listAttr . drawListElements drawElem foc + +renderList :: (Foldable t, Splittable t, Ord n, Show n) => (Bool -> e -> Widget n) -> Bool -> GenericList n t e -> Widget n +renderList drawElem = renderListWithIndex $ const drawElem + +handleQuery :: KnownNat n => SearchEnv n a c -> Key -> [Modifier] -> Searcher b -> EventM Bool (Searcher b) () +handleQuery env k m (Searcher s) = put . Searcher =<< editStep =<< (nestEventM' s . zoom queryEditor . handleEditorEvent . VtyEvent $ EvKey k m) + where + editStep ns = sendStep (getQuery ns) $> ns + sendStep nq = unless (nq == getQuery s) $ liftIO (sendQuery env nq) + +-- | Handling of keypresses. The default bindings are +-- @Enter@ exits the app with the current selection. +-- @Esc@ exits without any selection +-- @Up@ , @Down@ , @PageUp@ and @PageDown@ move through the matches. +-- All others keys are used for editing the query. See `handleEditorEvent` for details. +{-# INLINE handleKeyEvent #-} +handleKeyEvent :: (KnownNat n) => SearchEnv n a c -> Key -> [Modifier] -> EventM Bool (Searcher b) () +handleKeyEvent env k m + | k == KEnter , null m = halt + | k == KEsc , null m = modify (\(Searcher s) -> Searcher . ((matches . listSelectedL) .~ Nothing) $ s) >> halt + | k == KChar '\t' , null m = modify (\(Searcher s) -> Searcher . over matches listMoveDown $ s) + | k == KBackTab , null m = modify (\(Searcher s) -> Searcher . over matches listMoveUp $ s) + | k `elem` [KUp , KDown , KPageUp , KPageDown] , null m = (\(Searcher s) -> put . Searcher =<< (nestEventM' s . zoom matches . handleListEvent $ EvKey k m)) =<< get + | otherwise = handleQuery env k m =<< get + +-- | The initial state of the searcher. The editor is empty. +initialSearcher :: SearchEnv n a c -> BChan (SearchEvent a) -> SearcherSized 0 a +initialSearcher env = SearcherSized (editorText True (Just 1) "") (list False (MatchSetG DS.empty) 0) emptyMatcher 0 + +{-# INLINE handleSearchSized #-} +handleSearchSized :: (KnownNat n , KnownNat m) => SearcherSized n a -> SearchEventSized m a -> SearcherSized m a +handleSearchSized s e = SearcherSized (s ^. queryEditor) (list False (MatchSetG (e ^. matchedTop)) 0) + (e ^. matcherEv) (e ^. totMatches) (s ^. eventSource) + +{-# INLINE handleSearch #-} +handleSearch :: SearchEvent a -> EventM Bool (Searcher a) () +handleSearch (SearchEvent e) = modify (\(Searcher s) -> if (e ^. term == getQuery s) then Searcher (handleSearchSized s e) else Searcher s) + +selectedElement :: KnownNat n => Chunks n -> Searcher a -> Maybe Text +selectedElement c (Searcher s) = (map ((c !) . chunkIndex . snd) . selectedElementInternal . (^. matches)) s + +txtLine :: Text -> Widget n +txtLine s = + Widget Fixed Fixed $ do + c <- getContext + return $ (imageL .~ (V.text' (c^.attrL) s)) emptyResult diff --git a/src/Talash/Chunked.hs b/src/Talash/Chunked.hs new file mode 100644 --- /dev/null +++ b/src/Talash/Chunked.hs @@ -0,0 +1,202 @@ +-- | +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} + +module Talash.Chunked (module Talash.Chunked , module Export) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar +import Data.Bit +import qualified Data.Set as DS +import qualified Data.Text as T +import Data.Text.AhoCorasick.Automaton as Export (CaseSensitivity(..)) +import qualified Data.Vector as V +import Data.Vector.Algorithms.Intro (sort) +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Sized as SV +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as M +import qualified Data.Vector.Unboxed.Mutable.Sized as MS +import qualified Data.Vector.Unboxed.Sized as S +import Lens.Micro.TH (makeLenses) +import qualified System.IO.Streams as I +import Talash.Core as Export hiding (match , makeMatcher) +import Talash.Intro hiding (splitAt) +import Talash.ScoredMatch as Export + +newtype Chunks (n:: Nat) = Chunks { chunks :: V.Vector (SV.Vector n Text)} deriving (Eq , Ord , Show) +type MatchSetSized n = DS.Set (ScoredMatchSized n) + +data Ocassion = ChunkSearched | QueryDone | NewQuery | SearchDone deriving (Eq , Ord , Show) + +data SearchStateSized (n :: Nat) a = SearchStateSized { _currentQuery :: {-# UNPACK #-} !Text + , _prevQuery :: {-# UNPACK #-} !Text + , _chunkNumber :: {-# UNPACK #-} !Int + , _totalMatches :: {-# UNPACK #-} !Int + , _newMatches :: !Bool + , _done :: !Bool + , _matchSet :: !(MatchSetSized n)} +makeLenses ''SearchStateSized + +data SearchFunctions a b = SearchFunctions { _makeMatcher :: Text -> Matcher a + , _match :: forall n. KnownNat n => MatcherSized n a -> Text -> Maybe (MatchFull n) + -- | Given the matcher @m@, the matched string @t@ and the indices of matches in @t@ divide @t@ in alternating strings that are a matches + -- and the gap between these matches. The first of these is always a gap and can be empty. The rest should be non empty. + , _display :: forall n. KnownNat n => (Bool -> Text -> b) -> MatcherSized n a -> Text -> S.Vector n Int -> [b] } +makeLenses ''SearchFunctions + +data SearchReport = SearchReport { _ocassion :: Ocassion , _hasNewMatches :: Bool , _nummatches :: Int , _searchedTerm :: Text} +makeLenses ''SearchReport + +-- | The constant environment in which the search runs. +data SearchEnv n a b = SearchEnv { _searchFunctions :: SearchFunctions a b -- ^ The functions used to find and display matches. + , _send :: forall n m. (KnownNat n , KnownNat m) => Chunks n -> SearchReport -> MatcherSized m a -> MatchSetSized m -> IO () + , _maxMatches :: Int + , _candidates :: Chunks n + , _query :: MVar (Maybe Text) + , _allMatches :: M.IOVector (S.Vector n Bit) } +makeLenses ''SearchEnv + +{-# INLINABLE (!) #-} +(!) :: KnownNat n => Chunks n -> ChunkIndex -> Text +(!) (Chunks v) (ChunkIndex i j) = V.unsafeIndex (SV.fromSized $ V.unsafeIndex v i) j + +{-# INLINE getChunk #-} +getChunk :: Int -> Chunks n -> SV.Vector n Text +getChunk i (Chunks f) = V.unsafeIndex f i + +{-# INLINE matchChunk #-} +matchChunk :: forall n m a. (KnownNat n , KnownNat m) => (MatcherSized n a -> Text -> Maybe (MatchFull n)) -> MatcherSized n a -> Int -> SV.Vector m Text + -> S.Vector m Bit -> (S.Vector m Bit , MatchSetSized n) +matchChunk fun m ci v i = runST $ matchChunkM fun m ci v i + +{-# INLINEABLE matchChunkM #-} +matchChunkM :: forall n m a s. (KnownNat n , KnownNat m) => (MatcherSized n a -> Text -> Maybe (MatchFull n)) -> MatcherSized n a -> Int -> SV.Vector m Text + -> S.Vector m Bit -> ST s (S.Vector m Bit , MatchSetSized n) +matchChunkM fun m = go + where + go ci v i = doMatching =<< MS.replicate (Bit False) + where + nzero = natVal (Proxy :: Proxy n) == 0 + doMatching mbv = freezeAndDone =<< U.ifoldM' collectAndWrite DS.empty (S.fromSized i) + where + umbv = MS.fromSized mbv + freezeAndDone mset = ( , mset) <$> S.unsafeFreeze mbv + collectAndWrite x _ (Bit False) = pure x + collectAndWrite x j (Bit True) + | Nothing <- res = pure x + | Just mtch <- res = unsafeFlipBit umbv j $> DS.insert (conv mtch) x + where + res + | nzero = if SV.unsafeIndex v j == "" then Nothing else fun m . SV.unsafeIndex v $ j + | otherwise = fun m . SV.unsafeIndex v $ j + conv (MatchFull k w) = ScoredMatchSized (Down k) (ChunkIndex ci j) w + +{-# INLINABLE resetMatches #-} +resetMatches :: forall n m a b. KnownNat n => SearchEnv n a b -> SearchStateSized m a -> IO () +resetMatches env state + | T.isInfixOf (state ^. prevQuery) (state ^. currentQuery) = pure () + | otherwise = M.set (env ^. allMatches) (S.replicate 1) + +{-# INLINABLE searchNextChunk #-} +searchNextChunk :: (KnownNat n , KnownNat m) => SearchEnv n a b -> MatcherSized m a -> SearchStateSized m a -> IO (SearchStateSized m a) +searchNextChunk env matcher state = nextstate . getMatches =<< M.read (env ^. allMatches) i + where + i = state ^. chunkNumber + getMatches = matchChunk (env ^. searchFunctions . match) matcher i (getChunk i (env ^. candidates)) + nextstate (js , mtchs) = M.write (env ^. allMatches) i js $> (over chunkNumber (+ 1) . updateAndSend . mergedMatches (state ^. matchSet) $ mtchs) + where + mergedMatches curr new = if not (DS.null new) && (DS.size curr < env ^. maxMatches || DS.lookupMax curr > DS.lookupMin new) + then Just . DS.take (env ^. maxMatches) . DS.union curr $ new else Nothing + updateAndSend = over totalMatches (+ DS.size mtchs) . maybe (set newMatches False state) (\mset -> set newMatches True (set matchSet mset state)) + +matcherLoop :: (KnownNat n , KnownNat m) => SearchEnv n a b -> Text -> Text -> MatcherSized m a -> IO (Maybe Text) +matcherLoop env qry prev matcher = resetMatches env initstate *> loop initstate + where + initstate = SearchStateSized qry prev 0 0 False False DS.empty + loop state = step =<< tryTakeMVar (env ^. query) + where + step x + | Just Nothing <- x = doSend SearchDone $> Nothing + | inrange , Nothing <- x = doSend ChunkSearched *> (loop =<< searchNextChunk env matcher state) + | Just (Just t) <- x = doSend NewQuery $> Just t + | otherwise = doSend QueryDone *> takeMVar (env ^. query) + where + report b = SearchReport b (state ^. newMatches) (state ^. totalMatches) qry + doSend b = (env ^. send) (env ^. candidates) (report b) matcher (state ^. matchSet) + inrange = state ^. chunkNumber < (V.length . chunks $ env ^. candidates) + +searchEnv :: KnownNat n => SearchFunctions a b -> Int -> (forall n m. (KnownNat n , KnownNat m) => Chunks n -> SearchReport -> MatcherSized m a -> MatchSetSized m -> IO ()) + -> Chunks n -> IO (SearchEnv n a b) +searchEnv funs n sender chks = SearchEnv funs sender n chks <$> newEmptyMVar <*> M.replicate (V.length . chunks $ chks) (S.replicate 1) + +searchLoop :: KnownNat n => SearchEnv n a b -> IO () +searchLoop env = maybe (pure ()) (loop "") =<< takeMVar (env ^. query) + where + loop prev qry + | (Matcher m) <- (env ^. searchFunctions . makeMatcher) qry = maybe (pure ()) (loop qry) =<< matcherLoop env qry prev m + +fuzzyFunctions :: CaseSensitivity -> SearchFunctions MatchPart b +fuzzyFunctions c = SearchFunctions (fuzzyMatcher c) fuzzyMatchSized fuzzyMatchPartsAs + +orderlessFunctions :: CaseSensitivity -> SearchFunctions Int b +orderlessFunctions c = SearchFunctions (orderlessMatcher c) orderlessMatchSized orderlessMatchPartsAs + +{-# INLINABLE makeChunks #-} +makeChunks :: forall n. KnownNat n => V.Vector Text -> Chunks n +makeChunks v = Chunks $ V.generate numchunks (SV.force . fromJust . SV.toSized . chunk) + where + n = fromInteger $ natVal (Proxy :: Proxy n) + (numchunks , remainder) = bimap (+ 1) (+ 1) . divMod (length v - 1) $ n + chunk i + | i + 1 < numchunks = V.slice (i*n) n v + | otherwise = V.slice (i*n) remainder v <> V.replicate (n - remainder) "" + +{-# INLINE makeChunksP #-} +makeChunksP :: KnownNat n => Proxy n -> V.Vector Text -> Chunks n +makeChunksP _ = makeChunks + +{-# INLINEABLE setToVectorST #-} +setToVectorST :: (a -> b) -> DS.Set a -> ST s (V.Vector b) +setToVectorST f s = go =<< MV.unsafeNew (DS.size s) + where + go mv = foldM_ (\i e -> MV.unsafeWrite mv i (f e) $> i + 1) 0 s *> V.unsafeFreeze mv + +startSearcher :: KnownNat n => SearchEnv n a b -> IO () +startSearcher = void . forkIO . searchLoop + +sendQuery :: KnownNat n => SearchEnv n a b -> Text -> IO () +sendQuery env = putMVar (env ^. query) . Just + +stopSearcher :: KnownNat n => SearchEnv n a b -> IO () +stopSearcher env = putMVar (env ^. query) Nothing + +concatChunks :: KnownNat n => Int -> Chunks n -> V.Vector Text +concatChunks i (Chunks c) = V.concatMap SV.fromSized . V.take i $ c + +forceChunks :: KnownNat n => Chunks n -> Chunks n +forceChunks (Chunks v) = Chunks . V.force $ v + +chunksFromStream :: forall n. KnownNat n => I.InputStream Text -> IO (Chunks n) +chunksFromStream i = Chunks <$> (I.toVector =<< I.mapMaybe (\v -> map SV.force . SV.toSized $ v V.++ V.replicate (n - length v) "") =<< I.chunkVector n i) + where + n = fromInteger $ natVal (Proxy :: Proxy n) + +{-# INLINE chunksFromStreamP #-} +chunksFromStreamP :: forall n. KnownNat n => Proxy n -> I.InputStream Text -> IO (Chunks n) +chunksFromStreamP _ = chunksFromStream + +{-# INLINABLE chunksFromHandle #-} +chunksFromHandle :: KnownNat n => Proxy n -> Handle -> IO (Chunks n) +chunksFromHandle p = chunksFromStreamP p <=< I.decodeUtf8 <=< I.lines <=< I.handleToInputStream + +readVectorHandleWith :: (Text -> Text) -- ^ The function to transform the candidates. + -> (V.Vector Text -> V.Vector Text) -- ^ The function to apply to the constructed vector before compacting. + -> Handle -- ^ The handle to read from + -> IO (V.Vector Text) +readVectorHandleWith f t = map t . I.toVector <=< I.map f <=< I.decodeUtf8 <=< I.lines <=< I.handleToInputStream + +fileNamesSorted :: Handle -> IO (V.Vector Text) +fileNamesSorted = readVectorHandleWith (T.takeWhileEnd (/= '/')) (V.uniq . V.modify sort) diff --git a/src/Talash/Core.hs b/src/Talash/Core.hs --- a/src/Talash/Core.hs +++ b/src/Talash/Core.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS_GHC -Wno-duplicate-exports #-} -- | This modules provides the function `searchSome` for searching the candidates provided by `Vector` `Text`. The information about the location of matches -- is stored in a length-tagged unboxed vector `S.Vector`. Such vectors have an `Unbox` instances which allows us to store the collection of such mathces in an -- unboxed `U.Vector`. This significantly reduces the memory usage and pressure on garbage collector. As a result the matchers used by this function are tagged @@ -9,27 +10,23 @@ module Talash.Core ( -- * Types MatcherSized (..) , Matcher (..) , MatchState (..) , MatchPart (..) , MatchFull (..) , SearchSettings (..) , Indices -- * Matchers and matching - , makeMatcher + , makeMatcher , emptyMatcher -- ** Fuzzy style - , fuzzyMatcherSized , fuzzyMatcher , fuzzyMatchSized , fuzzyMatch + , fuzzyMatcherSized , fuzzyMatcher , fuzzyMatchSized , fuzzyMatch , fuzzyMatchParts , fuzzyMatchPartsAs -- ** Orderless Style - , orderlessMatcherSized , orderlessMatcher , orderlessMatchSized , orderlessMatch + , orderlessMatcherSized , orderlessMatcher , orderlessMatchSized , orderlessMatch , orderlessMatchParts , orderlessMatchPartsAs -- * Search - , fuzzySettings , orderlessSettings , searchSome , parts , partsOrderless , minify) where + , fuzzySettings , orderlessSettings , parts , partsAs , partsOrderless , partsOrderlessAs , minify) where -import Control.Monad.ST (ST, runST) import qualified Data.Text as T import Data.Text.AhoCorasick.Automaton -import Data.Text.Utf16 -import qualified Data.Vector as V +import Data.Text.Utf8 hiding (indices) import qualified Data.Vector.Algorithms.Intro as V import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as M import qualified Data.Vector.Unboxed.Sized as S import GHC.TypeNats -import Prelude (fromIntegral) -import Intro -import Lens.Micro (_1 , _2 , (^.)) +import Talash.Intro hiding (someNatVal) -- | The MatcherSized type consists of a state machine for matching a fixed number of needles. The number of matches needed is encoded in the Nat parameterzing -- the type. Here the purpose is to improve the memory consumption by utlizing the `Unbox` instance for sized tagged unboxed vectors from @@ -99,13 +96,12 @@ {-# INLINEABLE matchStepFuzzy #-} matchStepFuzzy :: KnownNat n => Either Int (S.Vector n Int) -> MatchState n () -> Match MatchPart -> Next (MatchState n ()) -matchStepFuzzy l s@(MatchState !f !m _) (Match !i (MatchPart !b !e)) - | e - b == either id S.length l - 1 = Done $ updateMatch (codeUnitIndex i) l s b e () - | f + 1 == b = Step $ updateMatch (codeUnitIndex i) l s b e () - | f >= b && e > f && monotonic = Step $ updateMatch (codeUnitIndex i) l s b e () - | otherwise = Step s +matchStepFuzzy l s@(MatchState !f !m _) (Match (CodeUnitIndex !i) (MatchPart !b !e)) + | e - b == either id S.length l - 1 = Done $ updateMatch i l s b e () + | (b == 0 && f == (-1)) || (f + 1 == b && S.unsafeIndex m f + e < i + b) || (f >= b && e > f && monotonic) = Step $ updateMatch i l s b e () + | otherwise = Step s where - monotonic = S.unsafeIndex m f <= codeUnitIndex i - either (const $ e-f) (U.sum . U.slice f (e-f) . S.fromSized) l + monotonic = S.unsafeIndex m f + either (const $ e-f) (U.sum . U.slice f (e-f) . S.fromSized) l <= i {-# INLINEABLE matchStepOrderless #-} matchStepOrderless :: KnownNat n => Either Int (S.Vector n Int) -> MatchState n (Int , Int) -> Match Int -> Next (MatchState n (Int , Int)) @@ -119,24 +115,18 @@ kConsecutive :: Int -> Text -> [Text] kConsecutive k t = map (T.take k) . take (1 + T.length t - k) . T.tails $ t -{-# INLINE run #-} -run :: CaseSensitivity -> a -> (a -> Match v -> Next a) -> AcMachine v -> Text -> a -run IgnoreCase = runLower -run CaseSensitive = runText - -- | A general function to construct a Matcher. Returns Nothing if the string is empty or if the number of needles turns out to be non-positive makeMatcher :: forall a. CaseSensitivity -> (Text -> Int) -- ^ The function to determine the number of needles from the query string. -- The proxy argument is instantiated at the resulting value. -> (forall n. KnownNat n => Proxy n -> CaseSensitivity -> Text -> MatcherSized n a) -- ^ The functions for constructing the matcher -> Text -- ^ The query string - -> Maybe (Matcher a) -- ^ Nothing if the string is empty or if the number of needles turns out to be non-positive + -> Matcher a -- ^ Nothing if the string is empty or if the number of needles turns out to be non-positive makeMatcher c lenf matf t - | T.null t || lenf t <= 0 = Nothing - | SomeNat p <- someNatVal . fromIntegral. lenf $ t = Just . Matcher . matf p c $ t + | SomeNat p <- someNatVal . fromIntegral. lenf $ t = Matcher . matf p c $ t {-# INLINE withSensitivity #-} withSensitivity :: CaseSensitivity -> Text -> Text -withSensitivity IgnoreCase = lowerUtf16 +withSensitivity IgnoreCase = lowerUtf8 withSensitivity CaseSensitive = id -- | Constructs the matcher for fuzzy matching. The needles are all possible contigous subtrings of the string being matched. The Nat @n@ must be instantiated at the @@ -145,39 +135,49 @@ -- the optimal way for this kind of matching but in practice it seems fast enough. fuzzyMatcherSized :: KnownNat n => p n -> CaseSensitivity -> Text -> MatcherSized n MatchPart fuzzyMatcherSized _ c t = MatcherSized {caseSensitivity = c , machina = build . concatMap go $ [T.length t , T.length t - 1 .. 1] - , sizes = if S.sum sz == S.length sz then Left (S.length sz) else Right sz } + , sizes = if S.sum sz == S.length sz then Left (S.length sz) else Right sz } where - sz = fromMaybe (S.replicate 1) . S.fromList . map (length . unpackUtf16 . withSensitivity c . T.singleton) . T.unpack $ t - go !k = zipWith (\t' l -> (unpackUtf16 . withSensitivity c $ t' , MatchPart l (l + k -1))) (kConsecutive k t) [0 ..] + sz = fromMaybe (S.replicate 1) . S.fromList . map (length . unpackUtf8 . withSensitivity c . T.singleton) . T.unpack $ t + go !k = zipWith (\t' l -> (withSensitivity c t' , MatchPart l (l + k -1))) (kConsecutive k t) [0 ..] -- | Unsized version of fuzzyMatcherSized -fuzzyMatcher :: CaseSensitivity -> Text -> Maybe (Matcher MatchPart) +fuzzyMatcher :: CaseSensitivity -> Text -> Matcher MatchPart fuzzyMatcher c = makeMatcher c T.length fuzzyMatcherSized +{-# INLINE emptyMatcher #-} +emptyMatcher :: MatcherSized 0 a +emptyMatcher = MatcherSized IgnoreCase (build []) (Left 0) + -- | Constructs the matcher for orderless matching, the needles are the words from the query string and the proxy argument should be instantiated at the -- number of words. orderlessMatcherSized :: KnownNat n => p n -> CaseSensitivity -> Text -> MatcherSized n Int -orderlessMatcherSized _ c t = MatcherSized {caseSensitivity = c , machina = build . zip (unpackUtf16 <$> wrds) $ [0 ..] - , sizes = Right . fromMaybe (S.replicate 1) . S.fromList . map (codeUnitIndex . lengthUtf16) $ wrds } +orderlessMatcherSized _ c t = MatcherSized {caseSensitivity = c , machina = build . zip wrds $ [0 ..] + , sizes = Right . fromMaybe (S.replicate 1) . S.fromList . map (codeUnitIndex . lengthUtf8) $ wrds } where wrds = withSensitivity c <$> T.words t -- | Unsized version of orderlessMatcherSized -orderlessMatcher :: CaseSensitivity -> Text -> Maybe (Matcher Int) +orderlessMatcher :: CaseSensitivity -> Text -> Matcher Int orderlessMatcher c = makeMatcher c (length . T.words) orderlessMatcherSized {-# INLINEABLE fuzzyMatchSized#-} fuzzyMatchSized :: KnownNat n => MatcherSized n MatchPart -> Text -> Maybe (MatchFull n) -fuzzyMatchSized (MatcherSized c m l) = full . run c (MatchState (-1) (S.replicate 0) ()) (matchStepFuzzy l) m +fuzzyMatchSized (MatcherSized c m l) = full . runWithCase c (MatchState (-1) (S.replicate 0) ()) (matchStepFuzzy l) m where - full (MatchState !e !u _) = if e + 1 == S.length u then Just $ MatchFull (matchScore l u) u else Nothing + full s@(MatchState !e !u _) = if e + 1 == S.length u then Just $ MatchFull (matchScore l u) u else Nothing fuzzyMatch :: Matcher MatchPart -> Text -> Maybe [Text] fuzzyMatch (Matcher m) t = parts (S.fromSized <$> sizes m) t . S.fromSized . indices <$> fuzzyMatchSized m t +fuzzyMatchParts :: KnownNat n => MatcherSized n MatchPart -> Text -> S.Vector n Int -> [Text] +fuzzyMatchParts m t = parts (S.fromSized <$> sizes m) t . S.fromSized + +fuzzyMatchPartsAs :: KnownNat n => (Bool -> Text -> a) -> MatcherSized n MatchPart -> Text -> S.Vector n Int -> [a] +fuzzyMatchPartsAs f m t = partsAs f (S.fromSized <$> sizes m) t . S.fromSized + {-# INLINEABLE orderlessMatchSized#-} orderlessMatchSized :: KnownNat n => MatcherSized n Int -> Text -> Maybe (MatchFull n) -orderlessMatchSized (MatcherSized c m l) = full . run c (MatchState 0 (S.replicate 0) (0,0)) (matchStepOrderless l) m +orderlessMatchSized (MatcherSized c m l) = full . runWithCase c (MatchState 0 (S.replicate 0) (0,0)) (matchStepOrderless l) m where ln = either id S.length l full u = if endLocation u == ln then Just $ MatchFull 0 (partialMatch u) else Nothing @@ -185,22 +185,45 @@ orderlessMatch :: Matcher Int -> Text -> Maybe [Text] orderlessMatch (Matcher m) t = partsOrderless (S.fromSized <$> sizes m) t . S.fromSized . indices <$> orderlessMatchSized m t +orderlessMatchParts :: KnownNat n => MatcherSized n Int -> Text -> S.Vector n Int -> [Text] +orderlessMatchParts m t = partsOrderless (S.fromSized <$> sizes m) t . S.fromSized + +orderlessMatchPartsAs :: KnownNat n => (Bool -> Text -> a) -> MatcherSized n Int -> Text -> S.Vector n Int -> [a] +orderlessMatchPartsAs f m t = partsOrderlessAs f (S.fromSized <$> sizes m) t . S.fromSized + -- | The parts of a string resulting from a match using the fuzzy matcher. parts :: Either Int (U.Vector Int) -- ^ The information about the lengths of different needles. -> Text -- ^ The candidate string that has been matched -> U.Vector Int -- ^ The vector recording the positions of the needle in the matched string. -> [Text] -- ^ The candidate string split up according to the match -parts v t = done . foldl' cut ([] , lengthUtf16 t) . minify v +parts v t u + | U.null u = [t] + |otherwise = done . foldl' cut ([] , lengthUtf8 t) . minify v $ u where - done (ms , cp) = unsafeSliceUtf16 0 cp t : ms - cut (!ms , !cp) !cc = (unsafeSliceUtf16 cc (cp - cc) t : ms , cc ) + done (ms , cp) = unsafeSliceUtf8 0 cp t : ms + cut (!ms , !cp) !cc = (unsafeSliceUtf8 cc (cp - cc) t : ms , cc ) +partsAs :: (Bool -> Text -> a) -> Either Int (U.Vector Int) -> Text -> U.Vector Int -> [a] +partsAs f = go + where + go v t u + | U.null u = [f False t] + |otherwise = done . foldl' cut ([] , lengthUtf8 t , False) . minify v $ u + where + done (ms , cp, b) = f b (unsafeSliceUtf8 0 cp t) : ms + cut (!ms , !cp , !b) !cc = (f b (unsafeSliceUtf8 cc (cp - cc) t) : ms , cc , not b) + -- | The parts of a string resulting from a match using the orderless matcher. See parts for an explanation of arguments. partsOrderless :: Either Int (U.Vector Int) -> Text -> U.Vector Int -> [Text] partsOrderless v t u = parts (map (`U.backpermute` fst up) v) t (snd up) where up = U.unzip . U.modify (V.sortBy (comparing snd)) . U.imap (,) $ u +partsOrderlessAs :: (Bool -> Text -> a) -> Either Int (U.Vector Int) -> Text -> U.Vector Int -> [a] +partsOrderlessAs f v t u = partsAs f (map (`U.backpermute` fst up) v) t (snd up) + where + up = U.unzip . U.modify (V.sortBy (comparing snd)) . U.imap (,) $ u + {-# INLINE eIndexU #-} eIndexU :: Int -> Either a (U.Vector Int) -> Int eIndexU i = either (const 1) (`U.unsafeIndex` i) @@ -213,6 +236,7 @@ where a = U.unsafeHead s go (!l , s) !i !c = if c - l <= eIndexU (i+1) v then (c , s) else (c , c - eIndexU (i+1) v : l : s ) + -- | The default ordering used in this module to sort matches within a given bucket. Prefers the matche for which the last part is closest to the end. To tie -- break prefers the shorter matched string. defOrdering :: Text -> S.Vector n Int -> Text -> S.Vector n Int -> Ordering @@ -234,50 +258,3 @@ -- @["tal","as","h","be","st"]@ but @"talash best"@ will not match @"bet"@. orderlessSettings :: KnownNat n => Int -> SearchSettings (MatcherSized n Int) n orderlessSettings n = SearchSettings {match = orderlessMatchSized , fullscore = const 0, maxFullMatches = n , orderAs = defOrdering} - --- | Given a matcher, search for matches in a vector of text. This function only searches for matches among the strings at indices which are in 3rd argument. -searchSome :: forall a n. KnownNat n => SearchSettings a n -- ^ The configuration for finding matches - -> a -- ^ The matcher - -> V.Vector Text -- ^ The vector of candidates - -> U.Vector Int -- ^ The subset of indices of candidates to search from - -> (U.Vector Int , U.Vector (Indices n)) -- ^ The new set of filtered indices in the vector and the vector containing the indices for each match found. -searchSome config !t v i = runST $ uncurry (searchSomeST config t v i) - =<< ((,) <$> M.unsafeNew (U.length i) - <*> V.replicateM (fullscore config t + 1) (M.unsafeNew (min (U.length i) $ maxFullMatches config))) - --- This functions is somewhat ridiculous and probably over optimized. Its only purpose is to be used in searchSome. searchSome can more simply be written as --- a mapMaybe followed by a sort but this doesn't allow for a early termination of matching once we have found enough matches. A streaming solution will probably --- be simpler for generating the candidates but will still need to be read into a vector and sorted so for now this works and is fast enough. -searchSomeST :: forall s a n. KnownNat n => SearchSettings a n -- ^ - -> a -> V.Vector Text -> U.Vector Int -> M.STVector s Int -- ^ The mutable vector into which we write the new filtered indices - -> V.Vector (M.STVector s (Indices n)) -- ^ The vector @mv@ containing the buckets i.e. mutable vectors one for each possible score gathering the matches - -> ST s (U.Vector Int , U.Vector (Indices n)) -- ^ The final vector of filtered indices and the vector of -searchSomeST config !t v i mi mv = end =<< U.foldM' go (0, U.replicate (fullscore config t + 1) 0) i - where - -- If we don't have enough matches with the highest score, @cc@ goes through other score in the decreasing order filling up the bucket of highest order. - -- Stopping when either the bucket is full or else we have run through all the scores. Before filling each bucket is sorted according the ordering supplied - -- by the configuration. Once the filling is done this bucket is frozen see `sortTake` and returned along with the frozen vector of filtered indcies see `end`. - end (l , u) = (,) <$> (U.unsafeFreeze . M.unsafeTake l $ mi) <*> sortTake u - sortTake u = (\l -> U.unsafeFreeze . M.unsafeTake l $ msv) =<< (doSort (-1) (U.unsafeLast u) *> U.ifoldM' cc (U.unsafeLast u) (U.reverse . U.unsafeInit $ u)) - msv = V.unsafeLast mv - cc r ix n - | r >= maxFullMatches config = pure r - | r + n <= maxFullMatches config = doSort ix n *> doFill r (fullscore config t - 1 - ix) n $> r + n - | otherwise = doSort ix n *> doFill r (fullscore config t - 1 - ix) (maxFullMatches config - r) $> maxFullMatches config - doFill r ix n = traverse_ (\k -> M.unsafeWrite msv (r+k) =<< M.unsafeRead (V.unsafeIndex mv ix) k) [0 .. n-1] - doSort ix = V.sortByBounds cmfn (V.unsafeIndex mv (fullscore config t - 1 - ix)) 0 - cmfn (!i1,!s1) (!i2,!s2) = orderAs config (V.unsafeIndex v i1) s1 (V.unsafeIndex v i2) s2 - bstMch = match config t . V.unsafeIndex v - bign = (>= maxFullMatches config) - -- The idx is the number of total number of matches that have been written up to now. nf is the vector carrying the same information for each bucket. - -- elm is current index to check for a match. So we check if v ! elem is a match, if it is we write the match into the appropriate bucket and elem into - -- the vector of filtered indices and increment idx and the appropriate index of nf. If we have already reached the needed number of matches of full score - -- we instead just skip matching and write idx into the vector of filtered indices. - go (!idx , !nf) !elm - | bign (U.last nf) = M.unsafeWrite mi idx elm $> (idx + 1 , nf) - | Just !mch <- bstMch elm , bign (U.unsafeIndex nf (scored mch)) = M.unsafeWrite mi idx elm $> (idx + 1 , nf) - | Just (MatchFull !s !ixs) <- bstMch elm = M.unsafeWrite mi idx elm *> wrt s ixs $> inc s - | otherwise = pure (idx , nf) - where - wrt s ixs = M.unsafeWrite (V.unsafeIndex mv s) (U.unsafeIndex nf s) (elm , ixs) - inc s = (idx + 1 , U.modify (\mu -> M.unsafeModify mu (+1) s) nf) diff --git a/src/Talash/Files.hs b/src/Talash/Files.hs --- a/src/Talash/Files.hs +++ b/src/Talash/Files.hs @@ -13,10 +13,11 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V -import Intro +import qualified Data.Vector.Algorithms.Intro as V import System.Posix.Directory.ByteString import System.Posix.Env.ByteString import System.Posix.Files.ByteString +import Talash.Intro -- Configruation for the search when recursivley constructing the file tree. data Conf = Conf { @@ -29,16 +30,15 @@ -- is just the part of the filename after the last '.' i.e this module doesn't handle multiple extensions. data FindConf = Find !(S.HashSet ByteString) | Ignore !(S.HashSet ByteString) deriving Show - data FindInDirs = FindInDirs { -- | The configuration of finding or excluding the extensions for this set of directories. confLocal :: FindConf , -- | The list of directories to which this configuration should apply. dirsLocal :: [ByteString]} -data FileTree a = Dir { rootDir :: a -- ^ The root directory - , dirFiles :: (V.Vector a) -- ^ The files in the root directory that are not subdirectories - , subDirs :: (V.Vector (FileTree a))} -- ^ The vector of trees formed by subdirectories +data FileTree a = Dir { rootDir :: a -- ^ The root directory + , dirFiles :: V.Vector a -- ^ The files in the root directory that are not subdirectories + , subDirs :: V.Vector (FileTree a)} -- ^ The vector of trees formed by subdirectories deriving (Eq , Show) -- | Default configuration, include every file and search directory. @@ -49,20 +49,18 @@ -- the Right elements are subdirectories that pass the `filterPath` test. {-# INLINEABLE dirContentsWith #-} dirContentsWith :: Conf -> ByteString -> IO (V.Vector (Either ByteString ByteString)) -dirContentsWith c d = bracket (openDirStream d) closeDirStream (V.unfoldrM (\s -> map (\d -> if d == Left "" then Nothing else Just (d , s)) . go $ s)) +dirContentsWith c d = bracket (openDirStream d) closeDirStream (\s -> V.unfoldrM (map (map ( , s)) . go) s) where go s = nm =<< readDirStream s where nm f - | f == "" = pure (Left "") + | f == "" = pure Nothing | otherwise = hr =<< getSymbolicLinkStatus f where - hr fs - | isDirectory fs = hd - | otherwise = ifM (includeFile c fs f) (pure . Left $ f) (go s) - hd - | filterPath c f && f /= "." && f /= ".." = ifM (fileAccess f True False False) (pure . Right $ f) (go s) - | otherwise = go s + hr fs = det (isDirectory fs && filterPath c f && f /= "." && f /= "..") =<< includeFile c fs f + det True _ = pure . Just . Right $ f + det False True = pure . Just . Left $ f + det _ _ = go s -- | Constructs the file tree with the given the second argument at the root according to the given configuration. {-# INLINEABLE fileTreeWith #-} @@ -70,6 +68,7 @@ fileTreeWith c d = bracket getWorkingDirectory changeWorkingDirectory (const $ changeWorkingDirectory d *> (go =<< dirContentsWith c ".")) where go v = (\(a , b) -> Dir (T.decodeUtf8 d) a <$!> V.mapM (fileTreeWith c) b) . V.partitionWith (first T.decodeUtf8) $ v + cex (_ :: SomeException) = pure $ Dir (T.decodeUtf8 d) mempty mempty -- | Collapses the directories with only subdirectory and no other files. {-# INLINEABLE minify #-} @@ -111,7 +110,6 @@ | Find es <- c = defConf {includeFile = \ !s !n -> pure $ isRegularFile s && S.member (ext n) es} | Ignore es <- c = defConf {includeFile = \ !s !n -> pure $ isRegularFile s && not (S.member (ext n) es)} - -- | Like `findWithExts` but applied to mutliple lists of directories each with their own configuration of extensions. {-# INLINABLE findFilesInDirs #-} findFilesInDirs :: [FindInDirs] -> IO (V.Vector (FileTree Text)) @@ -119,6 +117,8 @@ -- | Find all the executables in PATH executables :: IO (V.Vector Text) -executables = foldr (\a t -> t <> map (V.map (T.takeWhileEnd (/= '/')) . flatten) (fileTreeWith cl a)) (pure V.empty) . B.split ':' =<< getEnvDefault "PATH" "" +executables = map (V.uniq . V.modify V.sort) . foldr merge (pure V.empty) . B.split ':' =<< getEnvDefault "PATH" "" where - cl = defConf { filterPath = const False , includeFile = \ s p -> map ((isRegularFile s || isSymbolicLink s) &&) . fileAccess p False False $ True} + cl = defConf { filterPath = const False , includeFile = \ s _ -> pure $ (isRegularFile s || isSymbolicLink s) + && (ownerExecuteMode == intersectFileModes (fileMode s) ownerExecuteMode)} + merge a t = t <> map (V.map (T.takeWhileEnd (/= '/')) . flatten) (fileTreeWith cl a) diff --git a/src/Talash/Internal.hs b/src/Talash/Internal.hs deleted file mode 100644 --- a/src/Talash/Internal.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExistentialQuantification #-} - -module Talash.Internal ( -- * Search - SearchFunctions(..) , makeMatcher , lister , displayer , searchFunctionsFuzzy , searchFunctionsOL , searchWithMatcher - -- * Help for reading vectors - , readVectorStdIn , fileNamesSorted , readVectorHandle , readVectorHandleWith, emptyIndices - -- * Exports - , module Export ) where - -import Control.Exception as Export (finally , catch, bracket , AsyncException) -import qualified Data.Text as T -import Data.Text.AhoCorasick.Automaton (CaseSensitivity (..)) -import qualified Data.Text.IO as T -import Data.Vector (Vector , (!), force , generate , take, singleton , convert, enumFromN, unfoldr, unfoldrM , uniq , modify, concat) -import Data.Vector.Algorithms.Intro (sort) -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Sized as S -import GHC.Compact (Compact , compact , getCompact) -import GHC.TypeNats -import Intro hiding (sort, take , modify) -import Lens.Micro as Export (ASetter' , over, set, (^.) , _1 , _2 , _3 , (.~) , (?~) , (%~)) -import Lens.Micro.TH as Export ( makeLenses ) -import System.IO as Export ( Handle , hIsEOF , isEOF, hClose, stdin) -import Talash.Core hiding (makeMatcher) - -data SearchFunctions a = SearchFunctions { - -- | Construct the matcher given the string to match. - _makeMatcher :: Text -> Maybe (Matcher a) , - -- | Obtain the result for searching. - _lister :: forall n. KnownNat n => MatcherSized n a -- The n will be determined by the SomeMatcher constructed above - -> Vector Text -- The vector holding the candidates - -> U.Vector Int -- An unboxed vector of indices. Only these indices will be matched against the matcher - -> (U.Vector Int , U.Vector (Indices n)) , - -- | Given the matcher @m@, the matched string @t@ and the indices of matches in @t@ divide @t@ in alternating strings that are a matches - -- and the gap between these matches. The first of these is always a gap and can be empty. The rest should be non empty. - _displayer :: forall n. KnownNat n => MatcherSized n a -> Text -> S.Vector n Int -> [Text] } -makeLenses ''SearchFunctions - -emptyIndices :: Int -> U.Vector (Indices 0) -emptyIndices n = U.generate n ( , S.empty) - --- | searchWithMatcher carries out one step of the search. Note that the search can stops before going through the whole vector of text. In that case the returned --- vector of indices should contain not only the indices matched candidates but also the indices of candidates that weren't tested for a match. -searchWithMatcher :: SearchFunctions a -- ^ The configuration to use to carry out the search. - -> Vector Text -- ^ The vector @v@ of candidates. - -> Maybe Text -- ^ The query string - -> U.Vector Int -- ^ The subset of indices of @v@ to search against. If input changes from @talas@ to @talash@ we only search among candidates that matched @talas@. - -> (U.Vector Int , (Int , Vector [Text])) -- ^ The indices of the matched candidates (see the note above) and the matched candidates broken up according to the match. -searchWithMatcher fs v t s = maybe nc go ((fs ^. makeMatcher) =<< t) - where - nc = (U.enumFromN 0 (length v) , (0 , force . map (\i -> [v ! (i ^. _1)]) . convert . emptyIndices . min 512 . length $ v)) - go (Matcher f') = (iv , (U.length iv , force . map (\i -> (fs ^. displayer) f' (v ! (i ^. _1)) (i ^. _2)) . convert $ mv)) - where - (iv , mv) = (fs ^. lister) f' v s - --- | Read a vector of newline separated candidates from the stdin. -readVectorStdIn :: IO (Vector Text) -readVectorStdIn = finally (unfoldrM (const . ifM isEOF (pure Nothing) . map (\ !l -> Just (l , ())) $ T.getLine) ()) (hClose stdin) - --- | Read a vector of newline separated candidates from a handle. -readVectorHandle :: Handle -> IO (Vector Text) -readVectorHandle h = finally (unfoldrM (const . ifM (hIsEOF h) (pure Nothing) . map (\ !l -> Just (l , ())) $ T.hGetLine h) ()) (hClose h) - --- | A generalized version of readVectorHandle allowing for the transformation of candidates and the resulting vector. See fileNamesSorted for an example of use. -readVectorHandleWith :: (Text -> Text) -- ^ The function to transform the candidates. - -> (Vector Text -> Vector Text) -- ^ The function to apply to the constructed vector before compacting. - -> Handle -- ^ The handle to read from - -> IO (Vector Text) -readVectorHandleWith f t h = finally (t <$> unfoldrM (const . ifM (hIsEOF h) (pure Nothing) . map (\ !l -> Just (f $! l , ())) $ T.hGetLine h) ()) - (hClose h) - --- | Read a vector of filenames from the handle, get the basename by removing the path of the directory. Finally sort and deduplicate the resulting filenames. --- Useful to get the list of executables from PATH for example. -fileNamesSorted :: Handle -> IO (Vector Text) -fileNamesSorted = readVectorHandleWith (T.takeWhileEnd (/= '/')) (uniq . modify sort) - --- | Search functions suitable for fuzzy matching. The candidate @c@ will match the query @s@ if @c@ contains all the characters in @s@ in order. In general there --- can be several ways of matching. This tries to find a match with the minimum number of parts. It does not find the minimum number of parts, if that requires --- reducing the extent of the partial match during search. E.g. matching @"as"@ against @"talash"@ the split will be @["tal","as","h"]@ and not --- @["t","a","la","s","h"]@. While matching @"talash best match testing hat"@ against @"tea"@ will not result in @["talash best match ","te","sting h","a","t"]@ since --- @"te"@ occurs only after we have match all three letters and we can't know if we will find the @"a"@ without going through the string. -searchFunctionsFuzzy :: SearchFunctions MatchPart -searchFunctionsFuzzy = SearchFunctions (fuzzyMatcher IgnoreCase) (searchSome (fuzzySettings 512)) (\m t -> parts (S.fromSized <$> sizes m) t . S.fromSized) - --- | Search functions that match the words in i.e. space separated substring in any order. @"talash best"@ will match @"be as"@ with the split --- @["tal","as","h","be","st"]@ but "talash best" will not match @"bet"@. -searchFunctionsOL :: SearchFunctions Int -searchFunctionsOL = SearchFunctions (orderlessMatcher IgnoreCase) (searchSome (orderlessSettings 512)) (\m t -> partsOrderless (S.fromSized <$> sizes m) t . S.fromSized) - --- testSearch :: IO () --- testSearch = (\v -> traverse_ print . take 64 . snd . snd . searchWithMatcher searchFunctionsFuzzy v (Just "figrun") . U.enumFromN 0 . length $ v) . getCompact --- =<< readVectorStdIn diff --git a/src/Talash/Intro.hs b/src/Talash/Intro.hs new file mode 100644 --- /dev/null +++ b/src/Talash/Intro.hs @@ -0,0 +1,33 @@ +-- | + +module Talash.Intro (map , module Export) where + +import Control.Exception as Export +import Control.Monad as Export +import Control.Monad.Extra as Export +import Control.Monad.Reader as Export +import Control.Monad.ST as Export (ST, runST) +import Data.Bifunctor as Export +import Data.ByteString as Export (ByteString) +import Data.Either as Export +import Data.Foldable as Export +import Data.Functor as Export +import Data.List as Export (unfoldr) +import Data.Maybe as Export +import Data.Ord as Export +import Data.Proxy as Export +import Data.Text as Export (Text , pack , unpack) +import Data.Text.Encoding as Export +import Data.Text.IO as Export (putStr , putStrLn) +import Data.Vector as Export (Vector) +import GHC.TypeLits as Export hiding (TypeError) +import Lens.Micro as Export (ASetter' , over, set, (^.) , _1 , _2 , _3 , (.~) , (?~) , (%~) , to) +import Prelude as Export hiding ((>>) , map , putStr , putStrLn) +import Safe as Export +import System.Environment as Export +import System.IO as Export hiding (putStr , putStrLn) +import Text.Read as Export hiding (lift , list , get) + +{-# INLINE map #-} +map :: Functor f => (a -> b) -> f a -> f b +map = fmap diff --git a/src/Talash/Piped.hs b/src/Talash/Piped.hs --- a/src/Talash/Piped.hs +++ b/src/Talash/Piped.hs @@ -5,103 +5,78 @@ -- `askSearcher`. One motivation for this is be able to use this library as search backend for some searches in Emacs (though the implementation may have to wait -- for a massive improvement in my elisp skills). module Talash.Piped ( -- * Types and Lenses - SearchResult (..) , query , allMatches , matches , IOPipes (..) - , SearchFunctions (..) , makeMatcher , lister , displayer , searchFunctionsOL , searchFunctionsFuzzy - -- * Searcher - , searchLoop , runSearch , runSearchStdIn , runSearchStdInDef , runSearchStdInColor , showMatch , showMatchColor - -- * Seeker + PipedSearcher (..) , query , allMatches , CaseSensitivity (..) + -- -- * Searcher + , searchLoop , runSearch , runSearchStdIn , runSearchStdInDef , showMatchColor + -- -- * Seeker , askSearcher - -- * Default program + -- -- * Default program , run , run' - -- * Exposed Internals - , response , event , withIOPipes , send , recieve - , searchWithMatcher , readVectorStdIn , readVectorHandle , readVectorHandleWith , emptyIndices) where + -- -- * Exposed Internals + , withNamedPipes , send , recieve) +where import qualified Data.ByteString.Char8 as B import Data.Monoid.Colorful import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U import GHC.Compact -import Intro import System.Directory import System.Environment (getArgs) import System.Exit import System.IO hiding (print , putStrLn , putStr) import System.Posix.Files import System.Posix.Process -import Talash.Core hiding (makeMatcher) -import Talash.Internal - -data SearchResult = SearchResult { _query :: Maybe Text -- ^ The query that was searched for. - , _allMatches :: U.Vector Int -- ^ The vector contaning the filtered indices of the candidates using the query. - , _matches :: V.Vector [Text] -- ^ The matches obtained using the query. - } deriving (Show , Eq) -makeLenses ''SearchResult +import Talash.Chunked hiding (makeMatcher , send) +import Talash.Intro +import Lens.Micro.TH (makeLenses) -data IOPipes = IOPipes { input :: Handle -- ^ The handle to the named piped on which the server receives input to search for. - , output :: Handle -- ^ The handle to the named piped on which the searcher outputs the search results. - } +data PipedSearcher = PipedSearcher { _inputHandle :: Handle + , _outputHandle :: Handle + , _maximumMatches :: Int + , _printStrategy :: SearchReport -> Bool + , _printer :: Handle -> [Text] -> IO ()} +makeLenses ''PipedSearcher -response :: SearchFunctions a -- ^ The functions determining how to much. - -> V.Vector Text -- ^ The vector of candidates. - -> Text -- ^ The text to match - -> SearchResult -- ^ The last result result. This is used to determine which candidates to search among. - -> SearchResult -response f v t s - | maybe False (`T.isInfixOf` t) (s ^. query) = go . searchWithMatcher f v (Just t) $ s ^. allMatches - | otherwise = go . searchWithMatcher f v (Just t) $ U.enumFromN 0 (V.length v) +printMatches :: forall n m a. (KnownNat n , KnownNat m) => SearchFunctions a Text -> PipedSearcher -> Chunks n + -> SearchReport -> MatcherSized m a -> MatchSetSized m -> IO () +printMatches funcs searcher store r m s = when ((searcher ^. printStrategy) r) (T.hPutStrLn out (T.pack . show $ r ^. nummatches) *> traverse_ doPrint s *> hFlush out) where - go (a , (_ , m)) = SearchResult (Just t) a m + out = searcher ^. outputHandle + doPrint (ScoredMatchSized _ c v) = (searcher ^. printer) out . (funcs ^. display) (const id) m (store ! c) $ v --- | One search event consisiting of the searcher reading a bytestring from the input named pipe. If the bytestring is empty the searcher exists. If not it --- outputs the search results to the output handle and also returns them. --- --- The first line of the output of results is the query. The second is an decimal integer @n@ which is the number of results to follow. There are @n@ more lines each --- contaning a result presented according the function supplied. -event :: SearchFunctions a -> (Handle -> [Text] -> IO ()) -- ^ The functions that determines how a results is presented. Must not introduce newlines. - -> IOPipes -- ^ The handles to the named pipes - -> V.Vector Text -- ^ The candidates - -> SearchResult -- ^ The last search result - -> IO (Maybe SearchResult) -- ^ The final result. The Nothing is for the case if the input was empty signalling that the searcher should exit. -event f g (IOPipes i o) v s = (\t -> if T.null t then pure Nothing else go t) . T.strip . decodeStringLenient =<< B.hGetLine i - where - go t = (\s' -> pream s' *> V.mapM_ (g o) (s' ^. matches) *> hFlush o $> Just s') . response f v t $ s - pream s' = B.hPutStrLn o (encodeString . fromMaybe "" $ s' ^. query) *> B.hPutStrLn o (show . V.length $ s' ^. matches) +pipedEnv :: KnownNat n => SearchFunctions a Text -> PipedSearcher -> Chunks n -> IO (SearchEnv n a Text) +pipedEnv funcs searcher = searchEnv funcs (searcher ^. maximumMatches) (printMatches funcs searcher) --- | Starts with the dummy `initialSearchResult` and handles `event` in a loop until the searcher receives an empty input and exits. -searchLoop :: SearchFunctions a -> (Handle -> [Text] -> IO ()) -> V.Vector Text -> IO () -searchLoop f g v = withIOPipes (\p -> go p . Just . initialSearchResult $ v) +search :: KnownNat n => IO () -> Handle -> SearchEnv n a b -> IO () +search fin inp env = finally (startSearcher env *> (loop =<< T.hGetLine inp)) fin where - go p = maybe (pure ()) (go p <=< event f g p v) - --- | The dummy `SearchResult` use as the initial value. Contains an empty query, all the indices and no matches. -initialSearchResult :: V.Vector Text -> SearchResult -initialSearchResult v = SearchResult Nothing (U.enumFromN 0 (V.length v)) V.empty - --- | Outputs the parts of a matching candidate to handle as space separated double quoted strings alternating between a match and a gap. The first text is --- always a gap and can be empty the rest should be non-empty -showMatch :: Handle -> [Text] -> IO () -showMatch o = B.hPutStrLn o . foldl' (\b n -> b <> " \"" <> encodeString n <> "\" ") "" + loop "" = stopSearcher env + loop query = sendQuery env query *> (loop =<< T.hGetLine inp) -- | Outputs a matching candidate for the terminal with the matches highlighted in blue. Uses the `Colored` `Text` monoid from `colorful-monoids` for coloring. showMatchColor :: Handle -> [Text] -> IO () -showMatchColor o t = (hPrintColored (\h -> B.hPutStr h . encodeString) o Term8 . fst . foldl' go (Value "" , False) $ t) *> B.hPutStrLn o "" +showMatchColor o t = (hPrintColored (\h -> B.hPutStr h . encodeUtf8) o Term8 . fst . foldl' go (Value "" , False) $ t) *> B.hPutStrLn o "" where go (c , False) n = (c <> Value n , True) - go (c , True ) n = (c <> Fg Blue (Value n) , False) + go (c , True ) n = (c <> Style Bold (Fg Blue (Value n)) , False) +defSearcher :: Handle -> Handle -> PipedSearcher +defSearcher ih oh = PipedSearcher ih oh 4096 (\r -> r ^. ocassion == QueryDone) showMatchColor + -- | Run an IO action that needs two handles to named pipes by creating two named pipes, opening the handles to them performing the action -- and then cleaning up by closing the handles and deleting the named pipes created. The names of the pipes are printed on the stdout and are of the -- form @\/tmp\/talash-input-pipe@ or @\/tmp\/talash-input-pipe\@ where n is an integer for the input-pipe and @\/tmp\/talash-output-pipe@ or -- @\/tmp\/talash-output-pipe\@ for the output pipe. The integer @n@ will be the same for both. -withIOPipes :: (IOPipes -> IO a) -> IO a -withIOPipes f = doAct =<< openP =<< ifM ((||) <$> fileExist i <*> fileExist o) (go 1) ((,) <$> mkp i <*> mkp o) +withNamedPipes :: (IO () -> Handle -> Handle -> IO a) -> IO a +withNamedPipes f = doAct =<< openP =<< ifM ((||) <$> fileExist i <*> fileExist o) (go 1) ((,) <$> mkp i <*> mkp o) where i = "/tmp/talash-input-pipe" o = "/tmp/talash-output-pipe" - doAct (fi , fo , p@(IOPipes ip op)) = finally (f p) (hClose ip *> hClose op *> removeFile fi *> removeFile fo) - openP (ip , op) = (\h g -> (ip , op , IOPipes h g)) <$> openFile ip ReadWriteMode <*> openFile op ReadWriteMode + doAct (fi , fo , ih , oh) = f (hClose ih *> hClose oh *> removeFile fi *> removeFile fo) ih oh + openP (ip , op) = (\ih oh -> (ip , op , ih , oh)) <$> openFile ip ReadWriteMode <*> openFile op ReadWriteMode mkp p = createNamedPipe p stdFileMode *> print p $> p go n = ifM ((||) <$> fileExist i' <*> fileExist o') (go $ n + 1) ((,) <$> mkp i' <*> mkp o') where @@ -109,29 +84,25 @@ o' = o <> show n -- | Run search create a new session for the searcher to run in, forks a process in which the `searchLoop` is run in the background and exits. -runSearch :: SearchFunctions a -> (Handle -> [Text] -> IO ()) -> V.Vector Text -> IO () -runSearch f g v = createSession *> forkProcess (searchLoop f g v) *> exitImmediately ExitSuccess +runSearch :: KnownNat n => IO () -> SearchFunctions a Text -> PipedSearcher -> Chunks n -> IO () +runSearch fin funcs searcher c = createSession *> forkProcess (search fin (searcher ^. inputHandle) =<< pipedEnv funcs searcher c) *> exitImmediately ExitSuccess -- | Version of `runSearch` in which the vector of candidates is built by reading lines from stdin. -runSearchStdIn :: SearchFunctions a -> (Handle -> [Text] -> IO ()) -> IO () -runSearchStdIn f g = runSearch f g . getCompact =<< compact . V.force =<< readVectorStdIn +runSearchStdIn :: KnownNat n => Proxy n -> IO () -> SearchFunctions a Text -> PipedSearcher -> IO () +runSearchStdIn p fin funcs searcher = runSearch fin funcs searcher . getCompact =<< compact . forceChunks =<< chunksFromHandle p stdin -- | Version of `runSearchStdIn` which uses `showMatch` to put the output on the handle. -runSearchStdInDef :: SearchFunctions a -> IO () -runSearchStdInDef f = runSearchStdIn f showMatch - --- | Version of `runSearchStdIn` for viewing the matches on a terminal which uses `showMatchColor` to put the output on the handle. -runSearchStdInColor :: SearchFunctions a -> IO () -runSearchStdInColor f = runSearchStdIn f showMatchColor +runSearchStdInDef :: SearchFunctions a Text -> IO () +runSearchStdInDef funcs = withNamedPipes (\fin ih -> runSearchStdIn (Proxy :: Proxy 32) fin funcs . defSearcher ih) -- runSearchStdIn f showMatch -- Send a query to the searcher by writing the text in the second argument to the named-pipe with path given by the first argument. -- Does not check if the file is a named pipe. send :: String -> Text -> IO () -send i q = ifM (fileExist i) (withFile i WriteMode (`B.hPutStrLn` encodeString q)) (putStrLn . convertString $ "the named pipe" <> i <> " does not exist") +send i q = ifM (fileExist i) (withFile i WriteMode (`B.hPutStrLn` encodeUtf8 q)) (putStrLn $ "the named pipe" <> T.pack i <> " does not exist") -- Read the results from the searcher from the named pipe with the path given as the argument. Does not check if the file exists or is a named pipe. recieve :: String -> IO () -recieve o = withFile o ReadMode (\h -> B.hGetLine h *> (go h . readMaybe . B.unpack =<< B.hGetLine h)) +recieve o = withFile o ReadMode (\h -> (go h . readMaybe . B.unpack =<< B.hGetLine h)) where go h = maybe (putStrLn "Couldn't read the number of results.") (\n -> replicateM_ n (B.putStrLn =<< B.hGetLine h)) @@ -144,12 +115,12 @@ -- | run' is the backend of `run` which is just `run\' =<< getArgs` run' :: [String] -> IO () -run' ["load"] = runSearchStdInColor searchFunctionsOL -run' ["load" , "fuzzy"] = runSearchStdInColor searchFunctionsFuzzy -run' ["load" , "orderless"] = runSearchStdInColor searchFunctionsOL -run' ["find" , x] = askSearcher "/tmp/talash-input-pipe" "/tmp/talash-output-pipe" . convertString $ x -run' ["find" , n , x] = askSearcher ("/tmp/talash-input-pipe" <> n) ("/tmp/talash-output-pipe" <> n) . convertString $ x -run' ["find" , i , o , x] = askSearcher i o . convertString $ x +run' ["load"] = runSearchStdInDef (orderlessFunctions IgnoreCase) +run' ["load" , "fuzzy"] = runSearchStdInDef (fuzzyFunctions IgnoreCase) +run' ["load" , "orderless"] = runSearchStdInDef (orderlessFunctions IgnoreCase) +run' ["find" , x] = askSearcher "/tmp/talash-input-pipe" "/tmp/talash-output-pipe" . T.pack $ x +run' ["find" , n , x] = askSearcher ("/tmp/talash-input-pipe" <> n) ("/tmp/talash-output-pipe" <> n) . T.pack $ x +run' ["find" , i , o , x] = askSearcher i o . T.pack $ x run' ["exit"] = askSearcher "/tmp/talash-input-pipe" "/tmp/talash-output-pipe" "" run' ["exit" , n] = askSearcher ("/tmp/talash-input-pipe" <> n) ("/tmp/talash-output-pipe" <> n) "" run' ["exit" , i , o] = askSearcher i o "" diff --git a/src/Talash/ScoredMatch.hs b/src/Talash/ScoredMatch.hs new file mode 100644 --- /dev/null +++ b/src/Talash/ScoredMatch.hs @@ -0,0 +1,39 @@ +-- | +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + + +module Talash.ScoredMatch (ChunkIndex (..) , ScoredMatchSized (..) , emptyMatch) where + +import Talash.Intro +import Data.Vector.Unboxed.Deriving +import GHC.TypeNats +import qualified Data.Vector.Unboxed.Sized as S + +data ChunkIndex = ChunkIndex {number :: {-# UNPACK #-} !Int , index :: {-# UNPACK #-} !Int} deriving (Eq , Ord , Show) + +derivingUnbox "ChunkIndex" + [t| ChunkIndex -> (Int , Int) |] + [|\(ChunkIndex i j) -> (i,j)|] + [|\(i,j) -> ChunkIndex i j|] + +data ScoredMatchSized (n::Nat) = ScoredMatchSized { score :: {-# UNPACK #-} !(Down Int), chunkIndex :: {-# UNPACK #-} !ChunkIndex + , matchData :: {-# UNPACK #-} !(S.Vector n Int)} deriving (Show) + +derivingUnbox "ScoredMatchSized" + [t| forall (n::Nat). KnownNat n => ScoredMatchSized n -> (Int , Int , Int , S.Vector n Int) |] + [| \(ScoredMatchSized (Down s) (ChunkIndex i j) m) -> (s, i , j , m) |] + [| \(s, i , j , m) -> ScoredMatchSized (Down s) (ChunkIndex i j) m |] + +instance Eq (ScoredMatchSized n) where + (ScoredMatchSized s i _) == (ScoredMatchSized t j _) = s == t && i == j + +instance Ord (ScoredMatchSized n) where + compare (ScoredMatchSized s i _) (ScoredMatchSized t j _) = compare (s,i) (t,j) + +emptyMatch :: Int -> Int -> ScoredMatchSized 0 +emptyMatch i j = ScoredMatchSized 0 (ChunkIndex i j) S.empty diff --git a/src/Talash/SimpleSearcher.hs b/src/Talash/SimpleSearcher.hs new file mode 100644 --- /dev/null +++ b/src/Talash/SimpleSearcher.hs @@ -0,0 +1,80 @@ +-- | + +module Talash.SimpleSearcher where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar +import qualified Data.ByteString.Char8 as B +import Data.Monoid.Colorful +import qualified Data.Text as T +import Data.Text.AhoCorasick.Automaton (CaseSensitivity(..)) +import qualified Data.Vector as V +import GHC.TypeLits +import Lens.Micro +import qualified System.IO.Streams as I +import Talash.Chunked +import Talash.Core hiding (match , makeMatcher) +import Talash.Files +import Talash.Intro hiding (splitAt) +import Talash.ScoredMatch +import GHC.Compact (Compact , compact , getCompact) + +data SimpleSearcher = SimpleSearcher {terms :: [Text] , sleepTime :: Int , matchesToPrint :: Int} + +-- | Outputs a matching candidate for the terminal with the matches highlighted in blue. Uses the `Colored` `Text` monoid from `colorful-monoids` for coloring. +showMatchColor :: Handle -> [Text] -> IO () +showMatchColor o t = (hPrintColored (\h -> B.hPutStr h . encodeUtf8) o Term8 . fst . foldl' go (Value "" , False) $ t) *> B.hPutStrLn o "" + where + go (c , False) n = (c <> Value n , True) + go (c , True ) n = (c <> Style Bold (Fg Blue (Value n)) , False) + +printMatches :: forall n m a. (KnownNat n , KnownNat m) => SearchFunctions a Text -> Chunks n -> SearchReport -> MatcherSized m a -> MatchSetSized m -> IO () +printMatches funcs store r m s = when (o == QueryDone || o == NewQuery) (putStrLn $ (T.pack . show $ n) <> " Matches for this round.\n") + where + o = r ^. ocassion + n = r ^. nummatches + +printMatchesMvar :: forall n m a. (KnownNat n , KnownNat m) => SearchFunctions a Text -> MVar () -> Chunks n -> SearchReport -> MatcherSized m a -> MatchSetSized m -> IO () +printMatchesMvar funcs v store r m s = when (r ^. ocassion == QueryDone) (putMVar v () *> putStrLn ((T.pack . show $ r ^. nummatches) <> " matches for this round.") + *> traverse_ (\(ScoredMatchSized _ c v) -> showMatchColor stdout . (funcs ^. display) (const id) m (store ! c) $ v) s) + +simpleFuzzyEnv :: KnownNat n => Int -> Proxy n -> V.Vector Text -> IO (SearchEnv n MatchPart Text) +simpleFuzzyEnv n _ = searchEnv (fuzzyFunctions IgnoreCase) n (printMatches (fuzzyFunctions IgnoreCase)) . makeChunks + +simpleFuzzyEnvM :: KnownNat n => MVar () -> Int -> Proxy n -> V.Vector Text -> IO (SearchEnv n MatchPart Text) +simpleFuzzyEnvM m n _ = searchEnv (fuzzyFunctions IgnoreCase) n (printMatchesMvar (fuzzyFunctions IgnoreCase) m) . makeChunks + +simpleFuzzyEnvMI :: KnownNat n => MVar () -> Int -> Proxy n -> Chunks n -> IO (SearchEnv n MatchPart Text) +simpleFuzzyEnvMI m n _ = searchEnv (fuzzyFunctions IgnoreCase) n (printMatchesMvar (fuzzyFunctions IgnoreCase) m) + +runSimpleSearcherWithEnv :: KnownNat n => SimpleSearcher -> SearchEnv n MatchPart Text -> IO () +runSimpleSearcherWithEnv s env = forkIO (searchLoop env) *> traverse_ (doSearch . Just) (terms s) *> doSearch Nothing + where + doSearch term = putMVar (env ^. query) term *> threadDelay (sleepTime s) + +runSimpleSearcher :: KnownNat n => Proxy n -> SimpleSearcher -> V.Vector Text -> IO () +runSimpleSearcher p s v = runSimpleSearcherWithEnv s =<< simpleFuzzyEnv (matchesToPrint s) p v + +runSimpleSearcherWithEnvM :: KnownNat n => SimpleSearcher -> MVar () -> SearchEnv n MatchPart Text -> IO () +runSimpleSearcherWithEnvM s v env = forkIO (searchLoop env) *> traverse_ doSearch (terms s) *> putMVar (env ^. query) Nothing + where + doSearch term = unless (term == "") $ putMVar (env ^. query) (Just term) *> takeMVar v + +runSimpleSearcherM :: KnownNat n => Proxy n -> SimpleSearcher -> V.Vector Text -> IO () +runSimpleSearcherM p s v = (\mvar -> runSimpleSearcherWithEnvM s mvar =<< simpleFuzzyEnvM mvar (matchesToPrint s) p v) =<< newEmptyMVar + +runSimpleSearcherMI :: KnownNat n => Proxy n -> SimpleSearcher -> Chunks n -> IO () +runSimpleSearcherMI p s v = (\mvar -> runSimpleSearcherWithEnvM s mvar =<< simpleFuzzyEnvMI mvar (matchesToPrint s) p v) =<< newEmptyMVar + +testVector :: IO (V.Vector Text) +testVector = I.toVector =<< I.decodeUtf8 =<< I.lines I.stdin + +simpleSearcherTest :: IO () +simpleSearcherTest = runSimpleSearcherMI (Proxy :: Proxy 64) + (SimpleSearcher [ "m" , "ma" , "mal" , "malda" , "maldac" , "maldace" , "maldacen" , "maldacena" , "maldacenaf" , "maldacenafi" , "maldacenafiv" , "maldacenafive" + , "maldacenafiv" + , "w" , "wi" , "wit" , "witt" , "witte" , "witten" , "f" , "fr" , "fra" , "fran" , "franc" , "franco" + , "c" , "cl" , "clo" , "clos" , "closs" , "closse" , "closset" , "s" , "se" , "sen" + ] 25000 256) + . forceChunks =<< chunksFromStream =<< I.decodeUtf8 =<< I.lines I.stdin +-- simpleSearcherTest = runSimpleSearcher (Proxy :: Proxy 32) (SimpleSearcher ["suse", "linux" , "binary" , "close" , "Witten" , "Maldacena" , "Franco" , "Closset"] 100000 1024) =<< testVector diff --git a/talash.cabal b/talash.cabal --- a/talash.cabal +++ b/talash.cabal @@ -1,6 +1,8 @@ cabal-version: 2.4 name: talash -version: 0.1.1.1 +version: 0.3.0 +Homepage: https://github.com/aikrahguzar/talash +Bug-reports: https://github.com/aikrahguzar/talash/issues -- A short (one-line) description of the package. synopsis: Line oriented fast enough text search @@ -20,13 +22,7 @@ . The is also a demo executable for both the brick app and piped version that gets the candidates for the @stdin@. Use @talash help@ for usage information. . - Some care has been taken to make the searcher performant. On my laptop searching using the tui app to search all files in my @\/usr\/local@ with - @60K@ items, the search results appear almost instantly. Searching among about @340K@ files in @\/usr\/share@ there is some but bearable lag - between the keypresses and the search results. While searching between @1264K@ files, that @fd@ finds from @\/@ there is a lag of a second or so - before the results appear. The three scenarios consume about @50 MiB@ , @130 MiB@ and @500 MiB@ of memory respectively which is almost entirely due - to the @Vector Text@ storing the candidates. - . - The nice string matching interface provided by [alfred-margaret](https:\/\/hackage.haskell.org\/package\/alfred-margaret) is responsible for a + Some care has been taken to make the searcher performant. The nice string matching interface provided by [alfred-margaret](https:\/\/hackage.haskell.org\/package\/alfred-margaret) is responsible for a big part of the performance. While [vector-sized](https:\/\/hackage.haskell.org\/package\/vector-sized) is responsible for most of memory efficieny. Performance can potentially be further improved by using all the cores but it is good enough for my typical use cases of searching among a few thousand or at most a few tens of thousands of candidates. As a result parallel matching is unlikely to be implemented. @@ -45,7 +41,7 @@ author: Rahguzar -- An email address to which users can send suggestions, bug reports, and patches. -maintainer: aikrahguzar@gmail.com +maintainer: rahguzar@zohomail.eu -- A copyright notice. -- copyright: @@ -56,31 +52,40 @@ exposed-modules: Talash.Brick Talash.Brick.Columns + Talash.Chunked Talash.Core Talash.Files + Talash.SimpleSearcher Talash.Piped -- Modules included in this library but not exported. - other-modules: Talash.Internal Talash.Brick.Internal + other-modules: Talash.Brick.Internal Talash.ScoredMatch Talash.Intro default-extensions: DeriveGeneric OverloadedStrings NoImplicitPrelude BangPatterns TupleSections ScopedTypeVariables DeriveFunctor DataKinds KindSignatures - other-extensions: TemplateHaskell ExistentialQuantification RankNTypes + other-extensions: TemplateHaskell ExistentialQuantification RankNTypes GeneralizedNewtypeDeriving build-depends:base >= 4.10.1 && < 5, - alfred-margaret ^>= 1.1.1.0, - brick >= 0.60 && < 0.70, - bytestring >= 0.10.8 && < 0.11, + alfred-margaret ^>= 2.0, + bitvec, + brick >= 1.0 && < 1.2, + bytestring >= 0.10.8 && < 0.12, colorful-monoids >= 0.2.1 && < 0.3, + containers, + directory, + extra, ghc-compact >= 0.1.0 && < 0.3, - directory >= 1.3.6 && < 1.4, - intro >= 0.4.0 && < 0.10, + io-streams, microlens >= 0.4.0 && < 0.5, microlens-th >= 0.4.0 && < 0.5, - text >= 1.2.3 && < 1.3, + mtl, + primitive, + safe, + text ^>= 2.0, unix >= 2.7.2 && < 2.8, unordered-containers >= 0.2.9 && < 0.3, vector ^>= 0.12.1, vector-algorithms ^>= 0.8.0.3, vector-sized >= 1.4.0 && < 1.5, - vty ^>= 5.33 + vector-th-unbox, + vty >= 5.36 ghc-options: hs-source-dirs: src @@ -93,7 +98,6 @@ -- other-modules: build-depends: base >= 4.10.1 && < 5, - intro >= 0.4.0 && < 0.10, talash ghc-options: -threaded -rtsopts