{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-- |
-- Module : Yi.Fuzzy
-- License : GPL-2
-- Maintainer : yi-devel@googlegroups.com
-- Stability : experimental
-- Portability : portable
-- TODO if need arises: factor out generic part that captures a pattern of
-- having an interactive minibuffer and a window that just renders some state.
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 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 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)
data FuzzyItem
= FileItem { _filePath :: !FilePath }
| BufferItem { _bufferIdent :: !BufferId }
deriving (Show, 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
-- | The depth 'fuzzyOpen' should traverse by default. Currently
-- __5__.
defaultDepth :: Int
defaultDepth = 5
-- | Fuzzy open the current directory. The depth searched is
-- 'defaultDepth', use fuzzyOpenWithDepth if you want to customise
-- this.
fuzzyOpen :: YiM ()
fuzzyOpen = fuzzyOpenWithDepth defaultDepth
-- | 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)
-- shamelessly stolen from Chapter 9 of Real World Haskell
-- 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
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
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
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
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)))
modifyE :: (FuzzyState -> FuzzyState) -> EditorM ()
modifyE f = do
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 }
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 }
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)
openInThisWindow :: YiM ()
openInThisWindow = openRoutine (return ())
openInSplit :: YiM ()
openInSplit = openRoutine splitE
openInNewTab :: YiM ()
openInNewTab = openRoutine newTabE
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
insertChar :: Keymap
insertChar = textChar >>= write . insertB
cleanupE :: EditorM ()
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."
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)
instance Default FuzzyState where
def = FuzzyState mempty Nothing mempty
instance YiVariable FuzzyState