diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for Search + +## 0.1.0.0 -- 2021-05-28 + +* First version. Released on an unsuspecting world. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/src/Talash/Brick.hs b/src/Talash/Brick.hs new file mode 100644 --- /dev/null +++ b/src/Talash/Brick.hs @@ -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 diff --git a/src/Talash/Brick/Columns.hs b/src/Talash/Brick/Columns.hs new file mode 100644 --- /dev/null +++ b/src/Talash/Brick/Columns.hs @@ -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 diff --git a/src/Talash/Brick/Internal.hs b/src/Talash/Brick/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Talash/Brick/Internal.hs @@ -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 diff --git a/src/Talash/Core.hs b/src/Talash/Core.hs new file mode 100644 --- /dev/null +++ b/src/Talash/Core.hs @@ -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) diff --git a/src/Talash/Files.hs b/src/Talash/Files.hs new file mode 100644 --- /dev/null +++ b/src/Talash/Files.hs @@ -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} diff --git a/src/Talash/Internal.hs b/src/Talash/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Talash/Internal.hs @@ -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 diff --git a/src/Talash/Piped.hs b/src/Talash/Piped.hs new file mode 100644 --- /dev/null +++ b/src/Talash/Piped.hs @@ -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\@ 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) + 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 -th default instances are at " <> Fg Green " /tmp/talash-input-pipe and " <> Fg Green " /tmp/talash-output-pipe \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 " <> " : prints the search results for query from the already running default instance \n" + <> Fg Blue " talash piped find x" <> " : prints the search results for query from the instance with input pipe and output pipe \n" + <> Fg Blue " talash piped find " <> " : prints the search results for query from the -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 " <> " : causes the -th instance to exit and deletes its pipes.\n" + <> Fg Blue " talash piped exit " <> " : causes the instance at pipes and 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 diff --git a/talash.cabal b/talash.cabal new file mode 100644 --- /dev/null +++ b/talash.cabal @@ -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