talash (empty) → 0.1.0.0
raw patch · 10 files changed
+1358/−0 lines, 10 filesdep +alfred-margaretdep +basedep +brick
Dependencies added: alfred-margaret, base, brick, bytestring, colorful-monoids, containers, directory, ghc-compact, intro, microlens, microlens-th, talash, text, unix, unordered-containers, vector, vector-algorithms, vector-sized, vty
Files
- CHANGELOG.md +5/−0
- app/Main.hs +18/−0
- src/Talash/Brick.hs +241/−0
- src/Talash/Brick/Columns.hs +266/−0
- src/Talash/Brick/Internal.hs +52/−0
- src/Talash/Core.hs +282/−0
- src/Talash/Files.hs +123/−0
- src/Talash/Internal.hs +94/−0
- src/Talash/Piped.hs +176/−0
- talash.cabal +101/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for Search++## 0.1.0.0 -- 2021-05-28++* First version. Released on an unsuspecting world.
+ app/Main.hs view
@@ -0,0 +1,18 @@+module Main where++import qualified Talash.Brick as B+import qualified Talash.Piped as P+import System.Environment (getArgs)++run :: [String] -> IO ()+run ("piped":xs) = P.run' xs+run ("tui" :xs) = B.run' xs+run _ = putStrLn usageString++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"++main :: IO ()+main = run =<< getArgs
+ src/Talash/Brick.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE TemplateHaskell #-}++-- | A simple brick app to search among the candidates from a vector of text and get the selection. By default the app doesn't do anything except+-- 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 (..)+ -- * The Brick App and Helpers+ , searchApp , defSettings , searchFunctionsFuzzy , searchFunctionsOL , runApp , runAppFromHandle+ , selected , selectedFromHandle , selectedFromHandleWith , selectedFromFileNamesSorted , selectedFromFiles , runSearch+ -- * Default program+ , run , run'+ -- * Lenses+ -- ** Searcher+ , query , prevQuery , allMatches , matches , numMatches , wait+ -- ** 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 , readVectorStdIn , readVectorHandle , readVectorHandleWith , emptyIndices) 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 GHC.Compact (Compact , compact , getCompact)+import Intro hiding (sort, on,replicate , take , modify)+import System.Environment (getArgs)+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)}++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+ -- `listSelectedAttr` , `borderAttr` , \"Prompt\" , \"Highlight\" and \"Stats\"+ , _borderStyle :: BorderStyle -- ^ The border style to use. By default `unicodeRounded`+ }+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++-- | 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)++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)]++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}))++-- | 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}+ 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}++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | The backend for `run`+run' :: [String] -> IO ()+run' [] = runSearch defSettings searchFunctionsOL+run' ["fuzzy"] = runSearch defSettings searchFunctionsFuzzy+run' ["orderless"] = runSearch defSettings searchFunctionsOL+run' xs = (\t -> C.printColored putStr t usageString) =<< C.getTerm++usageString :: Colored Text+usageString = "talash tui is a set of command for a tui searcher/selector interface. It reads the input from the stdin to generate candidates to search for,"+ <> " one from each line and outputs the selected candidate (if there is one) on the stdout.\n"+ <> C.Fg C.Blue "talash tui" <> ": Run the tui with the default orderless style of searching.\n"+ <> C.Fg C.Blue "talash tui fuzzy" <> ": Run the tui with fuzzy style for searching.\n"+ <> C.Fg C.Blue "talash tui orderless" <> ": Run the tui with the default orderless style of searching.\n"++-- | Defualt program for the brick app that reads candidates from stdin and prints the selected text to the stdout. Can be called from the executable with+-- @talash tui@ which uses the orderless style. The search style can be set explicitly by calling @talash tui fuzzy@ or @talash tui orderless@+run :: IO ()+run = run' =<< getArgs
+ src/Talash/Brick/Columns.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ExistentialQuantification #-}++-- | This module is a quick hack to enable representation of data with columns of text. We use the fact the since the candidates are supposed to fit in a line,+-- they can't have a newlines but text with newlines can otherwise be searched normally. We use this here to separate columns by newlines. Like in+-- "Talash.Brick" the candidates comes from vector of text. Each such text consists of a fixed number of lines each representing a column. We match against such+-- text and `partsColumns` then uses the newlines to reconstruct the columns and the parts of the match within each column. This trick of using newline saves us+-- from dealing with the partial state of the match when we cross a column but there is probably a better way . The function `runApp` , `selected` and+-- `selectedIndex` hide this and instead take as argument a `Vector` [`Text`] with each element of the list representing a column. Each list must have the same+-- 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 (..)+ -- * The Brick App and Helpers+ , searchApp , defSettings , searchFunctionsFuzzy , searchFunctionsOL , selected , selectedIndex , runApp+ -- * Lenses+ -- ** Searcher+ , query , prevQuery , allMatches , matches , numMatches , wait+ -- ** 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++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 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)}++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.+ , _columnLimits :: [Int] -- ^ The area to limit each column to. This has a really naive and unituitive implementation. Each Int+ -- must be between 0 and 100 and refers to the percentage of the width the widget for a column will occupy+ -- from the space left over after all the columns before it have been rendered.+ , _themeAttrs :: [(AttrName, Attr)] -- ^ This is used to construct the `attrMap` for the app. By default the used attarNmaes are+ -- `listSelectedAttr` , `borderAttr` , @"Prompt"@ , @"Highlight"@ and @"Stats"@+ , _borderStyle :: BorderStyle -- ^ The border style to use. By default `unicodeRounded`+ }+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)++-- | 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++-- | 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)++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)]++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}))++-- | 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}+ 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))++-- | This function reconstructs the columns from the parts returned by the search by finding the newlines.+partsColumns :: [Text] -> [[Text]]+partsColumns = initDef [] . unfoldr (\l -> if null l then Nothing else Just . go $ l)+ where+ go x = bimap (f <>) (maybe s' (: s')) hs+ where+ (f , s) = break (T.isInfixOf "\n") x+ 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))++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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 s f = selectedIndex' s f . map T.unlines
+ src/Talash/Brick/Internal.hs view
@@ -0,0 +1,52 @@+module Talash.Brick.Internal (twoColumnText , columns , searchWidget , searchWidgetAux , headingAndBody , listWithHighlights , columnsListWithHighlights+ , theMain , 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 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 Lens.Micro.TH as Export ( makeLenses )+import System.Posix.IO+import System.Posix.Terminal++twoColumnText :: Int -> Text -> Text -> Widget n+twoColumnText n t1 t2 = joinBorders . vLimit 1 $ go n t1 <+> go 100 t2+ where+ go m t = hLimitPercent m $ padLeftRight 2 (txt t) <+> fill ' '++columns :: (a -> Widget n) -> [AttrName] -> [Int] -> [a] -> Widget n+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)++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++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)++headingAndBody :: Text -> Text -> Widget n+headingAndBody h b = withAttr "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)++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)++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
+ src/Talash/Core.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+-- | 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+-- with the number @n@ of needles need to be matched and are provided by `MatcherSized`. An unsized interface is provided by `Matcher` which is existenially+-- quantified over the number of needles. Functions for constructing matching and matchers have both a sized and unsized version.++module Talash.Core ( -- * Types+ MatcherSized (..) , Matcher (..) , MatchState (..) , MatchPart (..) , MatchFull (..) , SearchSettings (..) , Indices+ -- * Matchers and matching+ , makeMatcher+ -- ** Fuzzy style+ , fuzzyMatcherSized , fuzzyMatcher , fuzzyMatchSized , fuzzyMatch+ -- ** Orderless Style+ , orderlessMatcherSized , orderlessMatcher , orderlessMatchSized , orderlessMatch+ -- * Search+ , fuzzySettings , orderlessSettings , searchSome , parts , partsOrderless , 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 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 Intro+import Lens.Micro (_1 , _2 , (^.))++-- | 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+-- (vector-sized)[https://hackage.haskell.org/package/vector-sized] package. This significantly reduces the memory consumption. At least in the present+-- implementation there is no benefit for correctness and dealing with the length tag is occasionally annoying.+data MatcherSized (n :: Nat) a = MatcherSized {+ caseSensitivity :: CaseSensitivity ,+ -- | An AhoCorasick state machine from the alfred-margaret package which does the actual string matching+ machina :: {-# UNPACK #-} !(AcMachine a) ,+ -- | The sizes of the /basic/ needles in code unit indices. The Left Int case is for when the length of all the+ -- needles is 1 with Int the number of needles.+ sizes :: !(Either Int (S.Vector n Int))}++-- | The existential version of MatcherSized+data Matcher a = forall n. KnownNat n => Matcher (MatcherSized n a)++-- | The matching process essentially takes the form of a fold with possible early termination over the matches produced. See the runLower from the+-- alfred-margaret. Here MatchState is the return type of this fold and essentially it records the positions of the matches. Here like in alfred-margaret+-- position is the code unit index of the first code unit beyond the match. We can't use the CodeUnitIndex here because it doesn't have an unbox instance.+data MatchState (n :: Nat) a = MatchState {+ -- | This is used to record the present extent of the match. What extent means is different to different matching styles.+ endLocation :: {-# UNPACK #-} !Int ,+ -- | The vector recording the position of the matches.+ partialMatch :: {-# UNPACK #-} !(S.Vector n Int) ,+ -- | Any auxiliary information needed to describe the state of the match.+ aux :: !a} deriving Show++data MatchPart = MatchPart {matchBegin :: {-# UNPACK #-} !Int , matchEnd :: {-# UNPACK #-} !Int} deriving Show++-- | The full match consisting of a score for the match and vector consisting of the positions of the match. The score is intended as for bucketing and as a+-- result shouldn't be two large and must be non-negative . For the fuzzy style in this module @n@ contiguous matches contribute @n-1@ to the score. The+-- scores thus range from @0@ to @n-1@ where @n@ is the length of the string to be matched. For orderless style this score is always @0@.+data MatchFull (n :: Nat) = MatchFull {scored :: {-# UNPACK #-} !Int , indices :: {-# UNPACK #-} !(S.Vector n Int)} deriving Show++-- | The configuration for a search style with n needles and matcher of type a+data SearchSettings a (n :: Nat) = SearchSettings {+ -- | Given the matcher and the candidate text, find a match or return Nothing if there is none.+ match :: a -> Text -> Maybe (MatchFull n) ,+ -- | The maximum score for a given matcher. It determines the number of buckets.+ fullscore :: a -> Int ,+ -- | Maximum number of matches with full score to produce.+ maxFullMatches :: Int ,+ -- | The ordering to sort the matches within a given bucket. It is run with two candidates and their corresponding matches.+ orderAs :: Text -> S.Vector n Int -> Text -> S.Vector n Int -> Ordering}++-- | Type synonym for the index of a candidate in the backing vector along with the positions of the matches for it.+type Indices (n :: Nat) = (Int , S.Vector n Int)++-- | Unsafe, use with care. eIndex i return 1 for Left and for Right the element at @i@-th position in the vector. The vector must have at least @i+1@ elements.+-- This uses unsafeIndex so no bound checks are performed.+{-# INLINE eIndex #-}+eIndex :: KnownNat n => Int -> Either a (S.Vector n Int) -> Int+eIndex i = either (const 1) (`S.unsafeIndex` i)++{-# INLINEABLE updateMatch #-}+updateMatch :: KnownNat n => Int -> Either Int (S.Vector n Int) -> MatchState n a -> Int -> Int -> a -> MatchState n a+updateMatch !c l (MatchState !f !m _) !b !e !a = MatchState e (S.withVectorUnsafe (U.modify doWrites) m) a+ where+ doWrites s = void $ foldlM (\d i -> M.unsafeWrite s i d $> d - eIndex i l) c [e , e-1 .. b]++-- | The score for a fuzzy match.+{-# INLINE matchScore #-}+matchScore :: KnownNat n => Either Int (S.Vector n Int) -> S.Vector n Int -> Int+matchScore u v+ | S.length v == 0 = 0+ | v' <- S.fromSized v = U.ifoldl' (\ !s !i !cc -> if cc - U.unsafeIndex v' i == eIndex i u then s+1 else s ) 0 . U.tail $ v'++{-# 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+ where+ monotonic = S.unsafeIndex m f <= codeUnitIndex i - either (const $ e-f) (U.sum . U.slice f (e-f) . S.fromSized) l++{-# INLINEABLE matchStepOrderless #-}+matchStepOrderless :: KnownNat n => Either Int (S.Vector n Int) -> MatchState n (Int , Int) -> Match Int -> Next (MatchState n (Int , Int))+matchStepOrderless !lv s@(MatchState r !m (!lm , !li)) (Match (CodeUnitIndex !c) !i)+ | S.unsafeIndex m i == 0 && c - eIndex i lv >= li = go $ MatchState (r+1) (S.withVectorUnsafe (U.modify (\mv -> M.unsafeWrite mv i c)) m) (i , c)+ | S.unsafeIndex m i == 0 && eIndex lm lv < eIndex i lv = Step $ MatchState r (S.withVectorUnsafe (U.modify (\mv -> M.unsafeWrite mv i c *> M.write mv lm 0)) m) (i , c)+ | otherwise = Step s+ where+ go = if r == S.length m - 1 then Done else Step++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+makeMatcher c lenf matf t+ | T.null t || lenf t <= 0 = Nothing+ | SomeNat p <- someNatVal . fromIntegralUnsafe . lenf $ t = Just . Matcher . matf p c $ t++{-# INLINE withSensitivity #-}+withSensitivity :: CaseSensitivity -> Text -> Text+withSensitivity IgnoreCase = lowerUtf16+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+-- length @n@ of the query string. They are n choose 2 such substrings, so to the complexity of matching is \(O(m + n^2)\) where @m@ is the length of candidate string.+-- This is a rough (and probably wrong) estimate as the updating the matchstate for each found match is not a constant time operation. Not sure if Aho Corasick is+-- 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 }+ 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 ..]++-- | Unsized version of fuzzyMatcherSized+fuzzyMatcher :: CaseSensitivity -> Text -> Maybe (Matcher MatchPart)+fuzzyMatcher c = makeMatcher c T.length fuzzyMatcherSized++-- | 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 }+ where+ wrds = withSensitivity c <$> T.words t++-- | Unsized version of orderlessMatcherSized+orderlessMatcher :: CaseSensitivity -> Text -> Maybe (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+ where+ full (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++{-# 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+ where+ ln = either id S.length l+ full u = if endLocation u == ln then Just $ MatchFull 0 (partialMatch u) else Nothing++orderlessMatch :: Matcher Int -> Text -> Maybe [Text]+orderlessMatch (Matcher m) t = partsOrderless (S.fromSized <$> sizes m) t . S.fromSized . indices <$> orderlessMatchSized m t++-- | 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+ where+ done (ms , cp) = unsafeSliceUtf16 0 cp t : ms+ cut (!ms , !cp) !cc = (unsafeSliceUtf16 cc (cp - cc) t : ms , cc )++-- | 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++{-# INLINE eIndexU #-}+eIndexU :: Int -> Either a (U.Vector Int) -> Int+eIndexU i = either (const 1) (`U.unsafeIndex` i)++-- | Shorten a match by collapsing the contiguous sub-matches together.+minify :: Either Int (U.Vector Int) -> U.Vector Int -> [CodeUnitIndex]+minify v s+ | U.length s == 1 = map CodeUnitIndex [a , a - eIndexU 0 v]+ | otherwise = map CodeUnitIndex . (U.last s :) . snd . U.ifoldl' go (a , [a - eIndexU 0 v]) . U.tail $ s+ 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+defOrdering t1 s1 t2 s2+ | el == EQ = compare (T.length t1) (T.length t2)+ | otherwise = el+ where+ el = compare (T.length t1 - U.maximum (S.fromSized s1)) (T.length t2 - U.maximum (S.fromSized s2))++-- | Search functions suitable for fuzzy matching. The candidate @c@ will match 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.+fuzzySettings :: KnownNat n => Int -> SearchSettings (MatcherSized n MatchPart) n+fuzzySettings !m = SearchSettings { match = fuzzyMatchSized , fullscore = \t -> either id S.length (sizes t) - 1 , maxFullMatches = m , orderAs = defOrdering}++-- | 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"@.+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)
+ src/Talash/Files.hs view
@@ -0,0 +1,123 @@+-- | A potentially too simple interface for getting candidates for search from file trees. Doesn't follow symbolic links. For a better solution to this use+-- [unix-recursive](https://hackage.haskell.org/package/unix-recursive).+module Talash.Files (-- * Types+ Conf (..) , FindConf (..) , FindInDirs (..) , FileTree (..)+ -- * File Collection+ , defConf , withExts , ignoreExts , findWithExts , findFilesInDirs , executables+ -- * Internal Details+ , dirContentsWith , fileTreeWith , minify , flatten , ext) where++import Control.Exception+import qualified Data.ByteString.Char8 as B+import qualified Data.HashSet as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V+import Intro+import System.Posix.Directory.ByteString+import System.Posix.Env.ByteString+import System.Posix.Files.ByteString++-- Configruation for the search when recursivley constructing the file tree.+data Conf = Conf {+ -- | Test for whether to include a file in the file tree. The second argument is the base name of the file.+ includeFile :: FileStatus -> ByteString -> IO Bool ,+ -- | Test used to determine whether to enter a directory to search for files.+ filterPath :: ByteString -> Bool }++-- | A simple type to represent a search either for a specific set of extensions or esle for excluding a specific set of extensions. An extension here+-- 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 !a -- ^ The root directory+ !(V.Vector a) -- ^ The files in the root directory that are not subdirectories+ !(V.Vector (FileTree a)) -- ^ The vector of trees formed by subdirectories+ deriving (Eq , Show)++-- | Default configuration, include every file and search directory.+defConf :: Conf+defConf = Conf (const . const $ pure True) (const True)++-- | Given the configuration and a directory returns a vector where the Left elements are the files in the directory that pass the `includeFile` test while+-- 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))+ where+ go s = nm =<< readDirStream s+ where+ nm f+ | f == "" = pure (Left "")+ | 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++-- | Constructs the file tree with the given the second argument at the root according to the given configuration.+{-# INLINEABLE fileTreeWith #-}+fileTreeWith :: Conf -> ByteString -> IO (FileTree Text)+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++-- | Collapses the directories with only subdirectory and no other files.+{-# INLINEABLE minify #-}+minify :: FileTree Text -> FileTree Text+minify (Dir d f t)+ | f == V.empty && V.length t == 1 = (\(Dir d' f' t') -> Dir (d <> d') f' t') (V.unsafeHead t)+ | otherwise = Dir d f . V.map minify $ t++-- | Flattens the fileTree by completing the paths of the file relative to that of root directory.+{-# INLINEABLE flatten #-}+flatten :: FileTree Text -> V.Vector Text+flatten (Dir d f t) = V.concatMap go t <> V.map ((d <> "/") <>) f+ where+ go (Dir d' !f' t') = flatten (Dir (d <> "/" <> d') f' t')++{-# INLINABLE withExts #-}+withExts :: [ByteString] -- ^ The set of extensions to search for+ -> FindConf+withExts = Find . S.fromList++{-# INLINABLE ignoreExts #-}+ignoreExts :: [ByteString] -- ^ The set of extensions to ignore.+ -> FindConf+ignoreExts = Ignore . S.fromList++-- | The last extension of a file. Returns empty bytestring if there is none.+{-# INLINABLE ext #-}+ext :: ByteString -> ByteString+ext c = if e == c then mempty else e+ where+ e = B.takeWhileEnd (/= '.') c++-- | Find files in the given set of directories that either have a specific extension (`Find` case) or else excluding a certain set of extensiosn (`Ignore` case).+{-# INLINE findWithExts #-}+findWithExts :: FindInDirs -> IO (V.Vector (FileTree Text))+findWithExts (FindInDirs c d) = V.mapM (fileTreeWith ch) . V.fromList $ d+ where+ ch+ | 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))+findFilesInDirs = foldr (\a t -> t <> findWithExts a) (pure mempty)+-- | 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" ""+ where+ cl = defConf { filterPath = const False , includeFile = \ s p -> map ((isRegularFile s || isSymbolicLink s) &&) . fileAccess p False False $ True}
+ src/Talash/Internal.hs view
@@ -0,0 +1,94 @@+{-# 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
+ src/Talash/Piped.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE TemplateHaskell #-}+-- | This module provides a split searcher and seeker, a simple server-client version of the search in which searcher runs in the background and can communicate+-- with clients using named pipes. The searcher reads input as a UTF8 encoded bytestring from one named pipe and outputs the search results to another named+-- pipe. It quits when it receives an empty bytestring as input. The main function for starting the server is `runSearch` while a simple client is provided by+-- `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+ , askSearcher+ -- * Default program+ , run , run'+ -- * Exposed Internals+ , response , event , withIOPipes , send , recieve+ , searchWithMatcher , readVectorStdIn , readVectorHandle , readVectorHandleWith , emptyIndices) where++import qualified Data.ByteString.Char8 as B+import Data.Monoid.Colorful+import qualified Data.Text 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++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.+ }++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)+ where+ go (a , (_ , m)) = SearchResult (Just t) a m++-- | 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 = (\b -> if B.null b then pure Nothing else go . decodeStringLenient $ b) . B.strip =<< 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)++-- | 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)+ 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 <> "\" ") ""++-- | 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 ""+ where+ go (c , False) n = (c <> Value n , True)+ go (c , True ) n = (c <> Fg Blue (Value n) , False)++-- | 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\<n\>@ where n is an integer for the input-pipe and @\/tmp\/talash-output-pipe@ or+-- @\/tmp\/talash-output-pipe\<n\>@ 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)+ 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+ mkp p = createNamedPipe p stdFileMode *> print p $> p+ go n = ifM ((||) <$> fileExist i' <*> fileExist o') (go $ n + 1) ((,) <$> mkp i' <*> mkp o')+ where+ i' = i <> show n+ 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++-- | 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++-- | 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++-- 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")++-- 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))+ where+ go h = maybe (putStrLn "Couldn't read the number of results.") (\n -> replicateM_ n (B.putStrLn =<< B.hGetLine h))++-- Do one round of sending a qeury to the searcher and receiving the results.+askSearcher :: String -- ^ Path to the input named pipe to which to write the query.+ -> String -- ^ Path to the output named pipe from which to read the results.+ -> Text -- ^ Th qeury itself.+ -> IO ()+askSearcher ip op q = if q == "" then send ip q else send ip q *> recieve op++-- | 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' ["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 ""+run' xs = (\t -> printColored putStr t usageString) =<< getTerm++usageString :: Colored Text+usageString = "talash piped is a set of commands for loading data into a talash instance or searching from a running one. \n"+ <> "The input pipe for default instance is at " <> Fg Green " /tmp/talash-input-pipe " <> " and the output pipe is at " <> Fg Green " /tmp/talash-output-pipe \n"+ <> "The input and output pipes for the <n>-th default instances are at " <> Fg Green " /tmp/talash-input-pipe<n> and " <> Fg Green " /tmp/talash-output-pipe<n> \n"+ <> Fg Blue " talash piped load" <> " : loads the candidates from the stdin (uses orderless style) for later searches. \n"+ <> Fg Blue " talash piped load fuzzy" <> " : loads the candidates and uses fuzzy style for search \n"+ <> Fg Blue " talash piped load orderless" <> " : loads the candidates and uses orderless style for search \n"+ <> "All the load command print the input and output pipes for their instances on the stdout."+ <> Fg Blue " talash piped find <x>" <> " : prints the search results for query <x> from the already running default instance \n"+ <> Fg Blue " talash piped find <i> <o> x" <> " : prints the search results for query <x> from the instance with input pipe <i> and output pipe <o>\n"+ <> Fg Blue " talash piped find <n> <x>" <> " : prints the search results for query <x> from the <n>-th default instance.\n"+ <> Fg Blue " talash piped exit" <> " : causes the default instance to exit and deletes its pipes.\n"+ <> Fg Blue " talash piped exit <n>" <> " : causes the <n>-th instance to exit and deletes its pipes.\n"+ <> Fg Blue " talash piped exit <i> <o>" <> " : causes the instance at pipes <i> and <o> to exist and deletes the pipes.\n"+ <> " A running instance also exits on the usage of a find command with empty query. \n"++-- | run is a small demo program for the piped search. Run `talash piped` to see usage information.+run :: IO ()+run = run' =<< getArgs
+ talash.cabal view
@@ -0,0 +1,101 @@+cabal-version: 2.4+name: talash+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: Line oriented fast enough text search++-- A longer description of the package.+description: .+ This library provides searching a large number of candidates against a query using a given style. Two styles are provided. The default+ is orderless style in which a match occurs if the words in the query all occur in the candidate regardless of the order of their occurrence.+ A fuzzy style is also provided in which a candidate matches if all the characters of the query occur in it in order.+ .+ There is also a TUI searcher\/selector interface provided using a [brick](https:\/\/hackage.haskell.org\/package\/brick) app. Like an extremely+ barebones version of @fzf@ and mostly intended to be a starting point that has to be configured according to the needs or else it can be embedded into other+ applications to provide a selection interface.+ .+ There is also a piped searcher\/seeker provided in which searcher runs in the background and can be used by a seeker communicating with it using named+ pipes.+ .+ 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+ 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.+ .+ The package is lightly maintained, bugs reports are welcome but any action on them will be slow. Patches are welcome for 1. bugfixes+ 2. simple performance improvements 3. Adding mouse bindings to tui 4. New search styles, especially a better fuzzy one, that matches each word in+ the query fuzzily but the words themselves can be matched in any order (I am not sure what is a sensible implementation of this).++-- A URL where users can report bugs.+-- bug-reports:++-- The license under which the package is released.+license: GPL-3.0-only++-- The package author(s).+author: Rahguzar++-- An email address to which users can send suggestions, bug reports, and patches.+maintainer: aikrahguzar@gmail.com++-- A copyright notice.+-- copyright:+category: search, tui+extra-source-files: CHANGELOG.md++library+ exposed-modules:+ Talash.Brick+ Talash.Brick.Columns+ Talash.Core+ Talash.Files+ Talash.Piped++ -- Modules included in this library but not exported.+ other-modules: Talash.Internal Talash.Brick.Internal+ default-extensions: DeriveGeneric OverloadedStrings NoImplicitPrelude BangPatterns TupleSections ScopedTypeVariables DeriveFunctor DataKinds KindSignatures+ other-extensions: TemplateHaskell ExistentialQuantification RankNTypes+ build-depends:base >= 4.14.1 && < 5,+ alfred-margaret ^>= 1.1.1.0,+ brick >= 0.60 && < 0.70,+ bytestring >= 0.10.12 && < 0.11,+ colorful-monoids >= 0.2.1 && < 0.3,+ ghc-compact >= 0.1.0 && < 0.3,+ containers >= 0.6.2 && < 0.7,+ directory >= 1.3.6 && < 1.4,+ intro ^>= 0.9.0.0,+ microlens ^>= 0.4.12.0,+ microlens-th ^>= 0.4.3.9,+ text ^>= 1.2.4.1,+ unix >= 2.7.2 && < 2.8,+ unordered-containers >= 0.2.13 && < 0.3,+ vector ^>= 0.12.3.0,+ vector-algorithms ^>= 0.8.0.4,+ vector-sized >= 1.4.3 && < 1.5,+ vty ^>= 5.33++ ghc-options:+ hs-source-dirs: src+ default-language: Haskell2010++executable talash+ main-is: Main.hs++ -- Modules included in this executable, other than Main.+ -- other-modules:+ build-depends:+ base >= 4.14.1 && < 5,+ talash++ ghc-options: -threaded -rtsopts+ hs-source-dirs: app+ default-language: Haskell2010