diff --git a/src/Data/List/PointedList/Extras.hs b/src/Data/List/PointedList/Extras.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/PointedList/Extras.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Data.List.PointedList.Extras + ( filterr + , catMaybesr + ) where + +import Control.Monad (guard) +import Data.List.PointedList (PointedList(..)) +import qualified Data.Maybe as M (catMaybes) + +-- | filter a pointed list, preferring the right list as the new focus if the focus is lost. +filterr :: (a -> Bool) -> PointedList a -> Maybe (PointedList a) +filterr filt pl = catMaybesr $ fmap (\a -> guard (filt a) >> Just a) pl + +-- | catMaybes on a pointed list, preferring the right list as the new focus if the focus is lost. +catMaybesr :: forall a . PointedList (Maybe a) -> Maybe (PointedList a) +catMaybesr (PointedList mls mf mrs) = case mf of + Nothing -> shiftFocus rs ss + Just f -> pure $ PointedList rs f ss + where + rs, ss :: [a] + rs = M.catMaybes mls + ss = M.catMaybes mrs + + shiftFocus :: [a] -> [a] -> Maybe (PointedList a) + shiftFocus [] (f:rs) = pure $ PointedList [] f rs + shiftFocus (f:ls) [] = pure $ PointedList ls f [] + shiftFocus _ _ = Nothing + + diff --git a/src/Yi/Fuzzy.hs b/src/Yi/Fuzzy.hs --- a/src/Yi/Fuzzy.hs +++ b/src/Yi/Fuzzy.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE InstanceSigs #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | @@ -17,55 +17,68 @@ module Yi.Fuzzy (fuzzyOpen, fuzzyOpenWithDepth, defaultDepth) where -import Control.Applicative -import Control.Monad -import Control.Monad.Base -import Control.Monad.State (gets) -import Data.Binary -import Data.Default -import Data.List (isSuffixOf) -import qualified Data.Map.Strict as M -import Data.Monoid +import Control.Monad (void) +import Control.Monad.Base (liftBase) +import Control.Monad.State (gets) +import Data.Binary (Binary(..), Word8) +import Data.Default (Default(..)) +import Data.Foldable (Foldable(..)) +import Data.List (isSuffixOf) +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) +import Data.List.PointedList (PointedList(..)) +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import GHC.Natural (Natural) +import System.Directory (doesDirectoryExist, getDirectoryContents) +import System.FilePath (()) +import System.IO.Error (tryIOError) + import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Data.Typeable -import qualified Data.Vector as V -import GHC.Generics -import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.FilePath (()) -import System.IO.Error -import Yi -import Yi.Completion -import Yi.MiniBuffer +import qualified Data.Map.Strict as M +import qualified Data.List.PointedList as PL + +import Data.List.PointedList.Extras as PL + +import Yi +import Yi.Completion +import Yi.MiniBuffer +import Yi.Types +import Yi.Utils () import qualified Yi.Rope as R -import Yi.Types -import Yi.Utils () --- The following import is a hack which silences redundant import --- warnings on recent (4.8.0.0) base -import Prelude -- FuzzyState is stored in minibuffer's dynamic state data FuzzyState = FuzzyState - { _fsItems :: !(V.Vector FuzzyItem) - , fsSelectedIndex :: !(Maybe Int) - , fsNeedle :: !T.Text - } deriving (Show, Generic, Typeable) + { items :: !(Maybe (PointedList FuzzyItem)) + , search :: !Text + } deriving (Show, Generic, Typeable) data FuzzyItem - = FileItem { _filePath :: !FilePath } - | BufferItem { _bufferIdent :: !BufferId } - deriving (Show, Typeable) + = FileItem !Text + | BufferItem !BufferId + deriving (Typeable) --- TODO: make subsequenceMatch work on Text -itemToString :: FuzzyItem -> String -itemToString (FileItem x) = x -itemToString (BufferItem (MemBuffer x)) = T.unpack x -itemToString (BufferItem (FileBuffer x)) = x +instance Show FuzzyItem where + show :: FuzzyItem -> String + show i = case i of + FileItem _ -> "File " <> itemAsStr i + BufferItem _ -> "Buffer " <> itemAsStr i --- | The depth 'fuzzyOpen' should traverse by default. Currently --- __5__. -defaultDepth :: Int +itemAsTxt :: FuzzyItem -> Text +itemAsTxt f = case f of + FileItem x -> x + BufferItem (MemBuffer x) -> x + BufferItem (FileBuffer x) -> T.pack x + +itemAsStr :: FuzzyItem -> String +itemAsStr = T.unpack . itemAsTxt + +-- | The depth 'fuzzyOpen' should traverse by default. Currently __5__. +defaultDepth :: Natural defaultDepth = 5 -- | Fuzzy open the current directory. The depth searched is @@ -76,134 +89,134 @@ -- | Fuzzy-opens the directory to the specified depth. The depth needs -- to be at least @1@ for it to do anything meaningful. -fuzzyOpenWithDepth :: Int -> YiM () -fuzzyOpenWithDepth d = case () of - _ | d <= 0 -> printMsg "You need at least depth of 1 for fuzzyOpenWithDepth" - | otherwise -> do - fileList <- fmap (fmap FileItem) - (liftBase (getRecursiveContents d ".")) - bufList <- fmap (fmap (BufferItem . ident . attributes)) - (withEditor (gets (M.elems . buffers))) - promptRef <- withEditor (spawnMinibufferE "" (const localKeymap)) - let initialState = - FuzzyState (fileList <> V.fromList bufList) - (Just 0) - "" - withGivenBuffer promptRef $ do - putBufferDyn initialState - withEditor (renderE initialState) +fuzzyOpenWithDepth :: Natural -> YiM () +fuzzyOpenWithDepth d = do + fileList <- (fmap . fmap) (FileItem . T.pack) (liftBase $ getRecursiveContents d ".") + bufList <- (fmap . fmap) (BufferItem . ident . attributes) (withEditor (gets (M.elems . buffers))) + promptRef <- withEditor (spawnMinibufferE "" (const localKeymap)) --- shamelessly stolen from Chapter 9 of Real World Haskell + let initialState = FuzzyState (PL.fromList (filterNotCommon bufList <> fileList)) "" + withGivenBuffer promptRef $ putBufferDyn initialState + withEditor (renderE initialState) + where + filterNotCommon :: [FuzzyItem] -> [FuzzyItem] + filterNotCommon = filter ((\n -> not (n == "console" || n == "messages")) . itemAsTxt) + + -- takes about 3 seconds to traverse linux kernel, which is not too outrageous -- TODO: check if it works at all with cyclic links -- TODO: perform in background, limit file count or directory depth -getRecursiveContents :: Int -> FilePath -> IO (V.Vector FilePath) -getRecursiveContents d _ | d <= 0 = return mempty -getRecursiveContents d t = tryIOError (getDirectoryContents t) >>= \case - Left _ -> return mempty - Right names -> do - let properNames = filter predicate names +getRecursiveContents :: Natural -> FilePath -> IO [FilePath] +getRecursiveContents d t + | d == 0 = return mempty + | otherwise = do + x <- tryIOError (getDirectoryContents t) + case x of + Left _ -> return mempty + Right names -> do + paths <- mapM withName (filter isProperName names) + return $ mconcat paths + where + isProperName :: FilePath -> Bool + isProperName fileName = and + [ fileName `notElem` [".", "..", ".git", ".svn"] + , not (".hi" `isSuffixOf` fileName) + , not ("-boot" `isSuffixOf` fileName) + ] - predicate :: FilePath -> Bool - predicate fileName = and - [ fileName `notElem` [".", "..", ".git", ".svn"] - , not (".hi" `isSuffixOf` fileName) - , not ("-boot" `isSuffixOf` fileName) - ] - paths <- forM properNames $ \name -> do - let path = t name - isDirectory <- doesDirectoryExist path - if isDirectory - then getRecursiveContents (d - 1) path - else return $ V.singleton path - return $ mconcat paths + withName :: FilePath -> IO [FilePath] + withName name = do + let path = t name + isDirectory <- doesDirectoryExist path + if isDirectory then getRecursiveContents (d - 1) path else pure [path] localKeymap :: Keymap localKeymap = - choice - [ spec KEnter ?>>! openInThisWindow - , ctrlCh 't' ?>>! openInNewTab - , ctrlCh 's' ?>>! openInSplit - , spec KEsc ?>>! cleanupE - , ctrlCh 'g' ?>>! cleanupE - , ctrlCh 'h' ?>>! updatingB (deleteB Character Backward) - , spec KBS ?>>! updatingB (deleteB Character Backward) - , spec KDel ?>>! updatingB (deleteB Character Backward) - , ctrlCh 'a' ?>>! moveToSol - , ctrlCh 'e' ?>>! moveToEol - , spec KLeft ?>>! moveXorSol 1 - , spec KRight ?>>! moveXorEol 1 - , ctrlCh 'p' ?>>! modifyE decrementIndex - , spec KUp ?>>! modifyE decrementIndex - , ctrlCh 'n' ?>>! modifyE incrementIndex - , spec KDown ?>>! modifyE incrementIndex - , ctrlCh 'w' ?>>! updatingB (deleteB unitWord Backward) - , ctrlCh 'u' ?>>! updatingB (moveToSol >> deleteToEol) - , ctrlCh 'k' ?>>! updatingB deleteToEol - ] - <|| (insertChar >>! ((withCurrentBuffer updateNeedleB) >>= renderE)) - where updatingB :: BufferM () -> EditorM () - updatingB bufAction = withCurrentBuffer (bufAction >> updateNeedleB) >>= renderE + choice + [ spec KEnter ?>>! openInThisWindow + , ctrlCh 't' ?>>! openInNewTab + , ctrlCh 's' ?>>! openInSplit + , spec KEsc ?>>! cleanupE + , ctrlCh 'g' ?>>! cleanupE + , ctrlCh 'h' ?>>! updatingB (deleteB Character Backward) + , spec KBS ?>>! updatingB (deleteB Character Backward) + , spec KDel ?>>! updatingB (deleteB Character Backward) + , ctrlCh 'a' ?>>! moveToSol + , ctrlCh 'e' ?>>! moveToEol + , spec KLeft ?>>! moveXorSol 1 + , spec KRight ?>>! moveXorEol 1 + , ctrlCh 'p' ?>>! modifyE goPrevious + , ctrlCh 'n' ?>>! modifyE goNext + , spec KDown ?>>! modifyE goNext + , Event KTab [MShift] ?>>! modifyE goPrevious + , Event KTab [] ?>>! modifyE goNext + , ctrlCh 'w' ?>>! updatingB (deleteB unitWord Backward) + , ctrlCh 'u' ?>>! updatingB (moveToSol >> deleteToEol) + , ctrlCh 'k' ?>>! updatingB deleteToEol + ] + <|| (insertChar >>! (withCurrentBuffer updateNeedleB >>= renderE)) + where + updatingB :: BufferM () -> EditorM () + updatingB bufAction = withCurrentBuffer (bufAction >> updateNeedleB) >>= renderE updateNeedleB :: BufferM FuzzyState updateNeedleB = do - needle <- R.toText <$> readLnB - oldState <- getBufferDyn - let intermediateState = oldState { fsNeedle = needle } - newState = intermediateState - { fsSelectedIndex = - case V.toList (filteredItems intermediateState) of - [] -> Nothing - (_, index) : _ -> Just index - } - putBufferDyn newState - return newState + s <- R.toText <$> readLnB + oldState <- getBufferDyn + let newState = oldState `filterState` s + putBufferDyn newState + return newState + where + filterState :: FuzzyState -> Text -> FuzzyState + filterState old s = old { search = s, items = newItems } + where + newItems :: Maybe (PointedList FuzzyItem) + newItems = do + o <- items old + f <- filterItems s o + PL.moveTo 0 f -filteredItems :: FuzzyState -> (V.Vector (FuzzyItem, Int)) -filteredItems (FuzzyState items _ needle) = - V.filter (subsequenceMatch (T.unpack needle) . itemToString . fst) - (V.zip items (V.enumFromTo 0 (V.length items))) +filterItems :: Text -> PointedList FuzzyItem -> Maybe (PointedList FuzzyItem) +filterItems s zipper = PL.filterr (subsequenceTextMatch s . itemAsTxt) zipper + modifyE :: (FuzzyState -> FuzzyState) -> EditorM () modifyE f = do - prevState <- withCurrentBuffer getBufferDyn - let newState = f prevState - withCurrentBuffer (putBufferDyn newState) - renderE newState + prevState <- withCurrentBuffer getBufferDyn + let newState = f prevState + withCurrentBuffer (putBufferDyn newState) + renderE newState -incrementIndex :: FuzzyState -> FuzzyState -incrementIndex fs@(FuzzyState _ Nothing _) = fs -incrementIndex fs@(FuzzyState _ (Just index) _) = - let fitems = filteredItems fs - steps = V.zipWith (\x y -> (snd x, snd y)) fitems (V.tail fitems) - newIndex = case V.find ((== index) . fst) steps of - Nothing -> Just index - Just (_, nextIndex) -> Just nextIndex - in fs { fsSelectedIndex = newIndex } +goNext :: FuzzyState -> FuzzyState +goNext = changeIndex PL.next -decrementIndex :: FuzzyState -> FuzzyState -decrementIndex fs@(FuzzyState _ Nothing _) = fs -decrementIndex fs@(FuzzyState _ (Just index) _) = - let fitems = filteredItems fs - steps = V.zipWith (\x y -> (snd x, snd y)) (V.tail fitems) fitems - newIndex = case V.find ((== index) . fst) steps of - Nothing -> Just index - Just (_, prevIndex) -> Just prevIndex - in fs { fsSelectedIndex = newIndex } +goPrevious :: FuzzyState -> FuzzyState +goPrevious = changeIndex PL.previous +changeIndex :: (PointedList FuzzyItem -> Maybe (PointedList FuzzyItem)) -> FuzzyState -> FuzzyState +changeIndex dir fs = fs { items = items fs >>= dir } + renderE :: FuzzyState -> EditorM () -renderE fs@(FuzzyState _ selIndex _) = do - let content = V.toList (fmap renderItem (filteredItems fs)) - -- TODO justify to actual screen width - renderItem (item, itemIndex) = (T.justifyLeft 79 ' ' . mconcat) - [ (if Just itemIndex == selIndex then "* " else " ") - , renderItem' item - ] - renderItem' (FileItem x) = "File " <> T.pack x - renderItem' (BufferItem (MemBuffer x)) = "Buffer " <> x - renderItem' (BufferItem (FileBuffer x)) = "Buffer " <> T.pack x - setStatus (content, defaultStyle) +renderE (FuzzyState maybeZipper s) = do + case mcontent of + Nothing -> printMsg "No match found" + Just content -> setStatus (toList content, defaultStyle) + where + tshow :: Show s => s -> Text + tshow = T.pack . show + mcontent :: Maybe (NonEmpty Text) + mcontent = do + zipper <- maybeZipper + zipper' <- PL.withFocus <$> filterItems s zipper + nonEmpty . toList $ fmap (uncurry $ flip renderItem) zipper' + -- TODO justify to actual screen width + renderItem :: Bool -> FuzzyItem -> Text + renderItem isFocus fi = renderStar isFocus (T.justifyLeft 79 ' ' . T.pack . show $ fi) + + renderStar :: Bool -> (Text -> Text) + renderStar y = if y then ("* "<>) else (" "<>) + openInThisWindow :: YiM () openInThisWindow = openRoutine (return ()) @@ -215,22 +228,25 @@ openRoutine :: EditorM () -> YiM () openRoutine preOpenAction = do - FuzzyState items mselIndex _ <- withCurrentBuffer getBufferDyn - case mselIndex of - Nothing -> printMsg "Nothing selected" - Just selIndex -> do - let action = case items V.! selIndex of - FileItem x -> void (editFile x) - BufferItem x -> withEditor $ do - bufs <- gets (M.assocs . buffers) - case filter ((== x) . ident . attributes . snd) bufs of - [] -> error ("Couldn't find buffer" <> show x) - (bufRef, _) : _ -> switchToBufferE bufRef - withEditor $ do - cleanupE - preOpenAction - action + mzipper <- items <$> withCurrentBuffer getBufferDyn + case mzipper of + Nothing -> printMsg "Nothing selected" + Just (PointedList _ f _) -> do + withEditor $ do + cleanupE + preOpenAction + action f + where + action :: FuzzyItem -> YiM () + action fi = case fi of + FileItem x -> void (editFile (T.unpack x)) + BufferItem x -> withEditor $ do + bufs <- gets (M.assocs . buffers) + case filter ((==x) . ident . attributes . snd) bufs of + [] -> error ("Couldn't find " <> show x) + (bufRef, _):_ -> switchToBufferE bufRef + insertChar :: Keymap insertChar = textChar >>= write . insertB @@ -238,27 +254,23 @@ cleanupE = clrStatus >> closeBufferAndWindowE instance Binary FuzzyItem where - put (FileItem x) = put (0 :: Int) >> put x - put (BufferItem x) = put (1 :: Int) >> put x - get = do - tag :: Int <- get - case tag of - 0 -> liftM FileItem get - 1 -> liftM BufferItem get - _ -> error "Unexpected FuzzyItem Binary." + put (FileItem x) = put (0 :: Word8) >> put x + put (BufferItem x) = put (1 :: Word8) >> put x + get = do + tag :: Word8 <- get + case tag of + 0 -> FileItem <$> get + 1 -> BufferItem <$> get + _ -> error "Unexpected FuzzyItem Binary." instance Binary FuzzyState where - put (FuzzyState items index needle) = do - put (V.length items) - V.mapM_ put items - put index - put (T.encodeUtf8 needle) - get = do - itemCount <- get - items <- liftM V.fromList (replicateM itemCount get) - liftM2 (FuzzyState items) get (liftM T.decodeUtf8 get) + put (FuzzyState mzipper s) = do + put mzipper + put (T.encodeUtf8 s) + get = FuzzyState <$> get <*> fmap T.decodeUtf8 get + instance Default FuzzyState where - def = FuzzyState mempty Nothing mempty + def = FuzzyState Nothing mempty instance YiVariable FuzzyState diff --git a/yi-fuzzy-open.cabal b/yi-fuzzy-open.cabal --- a/yi-fuzzy-open.cabal +++ b/yi-fuzzy-open.cabal @@ -1,9 +1,5 @@ --- This file has been generated from package.yaml by hpack version 0.17.1. --- --- see: https://github.com/sol/hpack - name: yi-fuzzy-open -version: 0.16.0 +version: 0.17.0 synopsis: Fuzzy open plugin for yi description: This plugin tries to do what ctrl-p does for vim and helm does for emacs. category: Yi @@ -30,14 +26,16 @@ , directory >= 1.2.2 , filepath >= 1.4.0 , mtl >= 2.2 + , pointedlist >= 0.5 , text >= 1.2 , transformers-base >= 0.4.4 , vector >= 0.11 - , yi-core >= 0.16.0 + , yi-core >= 0.17.0 , yi-language >= 0.16.0 - , yi-rope >= 0.7 + , yi-rope >= 0.10 exposed-modules: Yi.Fuzzy other-modules: + Data.List.PointedList.Extras Paths_yi_fuzzy_open default-language: Haskell2010