module Yi.MiniBuffer ( spawnMinibufferE, withMinibufferFree, withMinibuffer
, withMinibufferGen, withMinibufferFin, noHint
, noPossibilities, mkCompleteFn, simpleComplete
, infixComplete, infixComplete', anyModeByName
, getAllModeNames, matchingBufferNames, anyModeByNameM
, anyModeName, (:::)(..), LineNumber, RegexTag
, FilePatternTag, ToKill, CommandArguments(..)
, commentRegion, promptingForBuffer, debugBufferContent
) where
import Control.Applicative
import Control.Concurrent
import Control.Lens hiding (act)
import Control.Monad
import Data.Foldable (find, toList)
import Data.IORef
import qualified Data.List.PointedList.Circular as PL
import Data.Maybe
import Data.Monoid (mempty)
import Data.Proxy
import Data.String (IsString)
import qualified Data.Text as T
import Data.Typeable
import System.CanonicalizePath (replaceShorthands)
import Yi.Buffer
import Yi.Completion (infixMatch, prefixMatch, containsMatch',
completeInList, completeInList')
import Yi.Config
import Yi.Core
import Yi.Editor
import Yi.History
import Yi.Keymap
import Yi.Keymap.Keys
import Yi.Monad
import qualified Yi.Rope as R
import Yi.Style (defaultStyle)
import Yi.String (commonTPrefix)
import Yi.Utils
import Yi.Window (bufkey)
debugBufferContent :: YiM ()
debugBufferContent = promptingForBuffer "buffer to trace:"
debugBufferContentUsing (\_ x -> x)
debugBufferContentUsing :: BufferRef -> YiM ()
debugBufferContentUsing b = do
mv <- io $ newIORef mempty
keepGoing <- io $ newIORef True
let delay = threadDelay 100000 >> readIORef keepGoing
void . forkAction delay NoNeedToRefresh $
findBuffer b >>= \case
Nothing -> io $ writeIORef keepGoing True
Just _ -> do
ns <- withGivenBuffer b elemsB :: YiM R.YiString
io $ readIORef mv >>= \c ->
when (c /= ns) (print ns >> void (writeIORef mv ns))
promptingForBuffer :: T.Text
-> (BufferRef -> YiM ())
-> ([BufferRef] -> [BufferRef] -> [BufferRef])
-> YiM ()
promptingForBuffer prompt act hh = do
openBufs <- fmap bufkey . toList <$> use windowsA
names <- withEditor $ do
bs <- toList . fmap bkey <$> getBufferStack
let choices = hh openBufs bs
prefix <- gets commonNamePrefix
forM choices $ \k ->
gets (shortIdentString (length prefix) . findBufferWith k)
withMinibufferFin prompt names (withEditor . getBufferWithName >=> act)
commentRegion :: YiM ()
commentRegion =
withCurrentBuffer (gets $ withMode0 modeToggleCommentSelection) >>= \case
Nothing ->
withMinibufferFree "No comment syntax is defined. Use: " $ \cString ->
withCurrentBuffer $ do
let toggle = toggleCommentB (R.fromText cString)
void toggle
modifyMode $ \x -> x { modeToggleCommentSelection = Just toggle }
Just b -> withCurrentBuffer b
spawnMinibufferE :: T.Text -> KeymapEndo -> EditorM BufferRef
spawnMinibufferE prompt kmMod = do
b <- stringToNewBuffer (MemBuffer prompt) mempty
withGivenBuffer b $
modifyMode $ \m -> m { modeKeymap = \kms -> kms { topKeymap = kmMod (insertKeymap kms)
} }
w <- newWindowE True b
windowsA %= PL.insertRight w
return b
withMinibuffer :: T.Text -> (T.Text -> YiM [T.Text]) -> (T.Text -> YiM ()) -> YiM ()
withMinibuffer prompt getPossibilities =
withMinibufferGen "" giveHint prompt completer (const $ return ())
where giveHint s = catMaybes . fmap (prefixMatch s) <$> getPossibilities s
completer = simpleComplete getPossibilities
mkCompleteFn :: (T.Text -> (T.Text -> Maybe T.Text)
-> [T.Text] -> EditorM T.Text)
-> (T.Text -> T.Text -> Maybe T.Text)
-> (T.Text -> YiM [T.Text])
-> T.Text
-> YiM T.Text
mkCompleteFn completeInListFn match getPossibilities s = do
possibles <- getPossibilities s
withEditor $ completeInListFn s (match s) possibles
simpleComplete :: (T.Text -> YiM [T.Text]) -> T.Text -> YiM T.Text
simpleComplete = mkCompleteFn completeInList prefixMatch
infixComplete' :: Bool -> (T.Text -> YiM [T.Text]) -> T.Text -> YiM T.Text
infixComplete' caseSensitive = mkCompleteFn completeInList' $ containsMatch' caseSensitive
infixComplete :: (T.Text -> YiM [T.Text]) -> T.Text -> YiM T.Text
infixComplete = infixComplete' True
noHint :: a -> YiM [a]
noHint = const $ return []
noPossibilities :: String -> YiM [ String ]
noPossibilities _s = return []
withMinibufferFree :: T.Text -> (T.Text -> YiM ()) -> YiM ()
withMinibufferFree prompt = withMinibufferGen "" noHint prompt
return (const $ return ())
withMinibufferGen :: T.Text -> (T.Text -> YiM [T.Text]) -> T.Text
-> (T.Text -> YiM T.Text) -> (T.Text -> YiM ())
-> (T.Text -> YiM ()) -> YiM ()
withMinibufferGen proposal getHint prompt completer onTyping act = do
initialBuffer <- gets currentBuffer
initialWindow <- use currentWindowA
let innerAction :: YiM ()
closeMinibuffer = closeBufferAndWindowE >>
windowsA %= fromJust . PL.find initialWindow
showMatchings = showMatchingsOf . R.toText =<< withCurrentBuffer elemsB
showMatchingsOf userInput =
printStatus =<< withDefaultStyle <$> getHint userInput
withDefaultStyle msg = (msg, defaultStyle)
typing = onTyping . R.toText =<< withCurrentBuffer elemsB
innerAction = do
lineString <- withEditor $ do
let bufToText = R.toText <$> withCurrentBuffer elemsB
historyFinishGen prompt bufToText
lineString <- bufToText
closeMinibuffer
switchToBufferE initialBuffer
return lineString
act lineString
up = historyMove prompt 1
down = historyMove prompt (1)
rebindings =
choice [oneOf [spec KEnter, ctrl $ char 'm'] >>! innerAction,
oneOf [spec KUp, meta $ char 'p'] >>! up,
oneOf [spec KDown, meta $ char 'n'] >>! down,
oneOf [spec KTab, ctrl $ char 'i']
>>! completionFunction completer >>! showMatchings,
ctrl (char 'g') ?>>! closeMinibuffer]
showMatchingsOf ""
withEditor $ do
historyStartGen prompt
void $ spawnMinibufferE (prompt `T.snoc` ' ')
(\bindings -> rebindings <|| (bindings >> write showMatchings
>> write typing))
withCurrentBuffer . replaceBufferContent . R.fromText
$ replaceShorthands proposal
withMinibufferFin :: T.Text -> [T.Text] -> (T.Text -> YiM ()) -> YiM ()
withMinibufferFin prompt possibilities act
= withMinibufferGen "" hinter prompt completer
(const $ return ()) (act . best)
where
hinter s = return $ match s
match s = filter (s `T.isInfixOf`) possibilities
best s
| s `elem` matches = s
| null matches = s
| otherwise = head matches
where matches = match s
completer s = return $ fromMaybe s $ commonTPrefix $ catMaybes (infixMatch s <$> possibilities)
completionFunction :: (T.Text -> YiM T.Text) -> YiM ()
completionFunction f = do
p <- withCurrentBuffer pointB
let r = mkRegion 0 p
text <- withCurrentBuffer $ readRegionB r
compl <- R.fromText <$> f (R.toText text)
withCurrentBuffer $ replaceRegionB r compl
class Promptable a where
getPromptedValue :: T.Text -> YiM a
getPrompt :: Proxy a -> T.Text
getMinibuffer :: Proxy a -> T.Text -> (T.Text -> YiM ()) -> YiM ()
getMinibuffer _ = withMinibufferFree
doPrompt :: forall a. Promptable a => (a -> YiM ()) -> YiM ()
doPrompt act = getMinibuffer witness (getPrompt witness `T.append` ":") (act <=< getPromptedValue)
where
witness = undefined
witness :: Proxy a
instance Promptable String where
getPromptedValue = return . T.unpack
getPrompt _ = "String"
instance Promptable Char where
getPromptedValue x = if T.null x
then error "Please supply a character."
else return $ T.head x
getPrompt _ = "Char"
instance Promptable Int where
getPromptedValue = return . read . T.unpack
getPrompt _ = "Integer"
instance Promptable T.Text where
getPromptedValue = return
getPrompt _ = "Text"
instance Promptable R.YiString where
getPromptedValue = return . R.fromText
getPrompt _ = "YiString"
getPromptedValueList :: [(T.Text, a)] -> T.Text -> YiM a
getPromptedValueList vs s = maybe (error "Invalid choice") return (lookup s vs)
getMinibufferList :: [(T.Text, a)] -> Proxy a -> T.Text
-> (T.Text -> YiM ()) -> YiM ()
getMinibufferList vs _ prompt = withMinibufferFin prompt (fmap fst vs)
enumAll :: (Enum a, Bounded a, Show a) => [(T.Text, a)]
enumAll = fmap (\v -> (T.pack $ show v, v)) [minBound..]
instance Promptable Direction where
getPromptedValue = getPromptedValueList enumAll
getPrompt _ = "Direction"
getMinibuffer = getMinibufferList enumAll
textUnits :: [(T.Text, TextUnit)]
textUnits =
[("Character", Character),
("Document", Document),
("Line", Line),
("Paragraph", unitParagraph),
("Word", unitWord),
("ViWord", unitViWord)
]
instance Promptable TextUnit where
getPromptedValue = getPromptedValueList textUnits
getPrompt _ = "Unit"
getMinibuffer = getMinibufferList textUnits
instance Promptable Point where
getPromptedValue s = Point <$> getPromptedValue s
getPrompt _ = "Point"
anyModeName :: AnyMode -> T.Text
anyModeName (AnyMode m) = modeName m
anyModeByNameM :: T.Text -> YiM (Maybe AnyMode)
anyModeByNameM n = find ((n==) . anyModeName) . modeTable <$> askCfg
anyModeByName :: T.Text -> YiM AnyMode
anyModeByName n = anyModeByNameM n >>= \case
Nothing -> fail $ "anyModeByName: no such mode: " ++ T.unpack n
Just m -> return m
getAllModeNames :: YiM [T.Text]
getAllModeNames = fmap anyModeName . modeTable <$> askCfg
instance Promptable AnyMode where
getPrompt _ = "Mode"
getPromptedValue = anyModeByName
getMinibuffer _ prompt act = do
names <- getAllModeNames
withMinibufferFin prompt names act
instance Promptable BufferRef where
getPrompt _ = "Buffer"
getPromptedValue = getBufferWithNameOrCurrent
getMinibuffer _ prompt act = do
bufs <- matchingBufferNames
withMinibufferFin prompt bufs act
matchingBufferNames :: YiM [T.Text]
matchingBufferNames = withEditor $ do
p <- gets commonNamePrefix
bs <- gets bufferSet
return $ fmap (shortIdentString $ length p) bs
instance (YiAction a x, Promptable r) => YiAction (r -> a) x where
makeAction f = YiA $ doPrompt (runAction . makeAction . f)
newtype (:::) t doc = Doc {fromDoc :: t} deriving (Eq, Typeable, Num, IsString)
instance Show x => Show (x ::: t) where
show (Doc d) = show d
instance (DocType doc, Promptable t) => Promptable (t ::: doc) where
getPrompt _ = typeGetPrompt (error "typeGetPrompt should not enter its argument" :: doc)
getPromptedValue x = Doc <$> getPromptedValue x
class DocType t where
typeGetPrompt :: t -> T.Text
data LineNumber
instance DocType LineNumber where
typeGetPrompt _ = "Line"
data ToKill
instance DocType ToKill where
typeGetPrompt _ = "kill buffer"
data RegexTag deriving Typeable
instance DocType RegexTag where
typeGetPrompt _ = "Regex"
data FilePatternTag deriving Typeable
instance DocType FilePatternTag where
typeGetPrompt _ = "File pattern"
newtype CommandArguments = CommandArguments [T.Text]
deriving (Show, Eq, Typeable)
instance Promptable CommandArguments where
getPromptedValue = return . CommandArguments . T.words
getPrompt _ = "Command arguments"