module Yi.Keymap.Emacs.Utils
( UnivArgument
, argToInt
, askQuitEditor
, askSaveEditor
, modifiedQuitEditor
, withMinibuffer
, queryReplaceE
, isearchKeymap
, cabalConfigureE
, cabalBuildE
, reloadProjectE
, executeExtendedCommandE
, evalRegionE
, readUniversalArg
, scrollDownE
, scrollUpE
, switchBufferE
, killBufferE
, insertNextC
, findFile
, findFileReadOnly
, findFileNewTab
, promptFile
, promptTag
, justOneSep
, joinLinesE
, countWordsRegion
)
where
import Control.Applicative (Alternative ((<|>), many, some), Applicative (pure), optional, (<$>))
import Control.Lens (use, (.=))
import Control.Monad (filterM, replicateM_, void)
import Control.Monad.Base ()
import Data.List ((\\))
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import qualified Data.Text as T (Text, concat, null, pack, singleton, snoc, unpack, unwords)
import System.FilePath (takeDirectory, takeFileName, (</>))
import System.FriendlyPath ()
import Yi.Buffer
import Yi.Command (cabalBuildE, cabalConfigureE, reloadProjectE)
import Yi.Core (quitEditor)
import Yi.Editor
import Yi.Eval (execEditorAction, getAllNamesInScope)
import Yi.File (deservesSave, editFile, fwriteBufferE, openingNewFile)
import Yi.Keymap (Keymap, KeymapM, YiM, write)
import Yi.Keymap.Keys
import Yi.MiniBuffer
import Yi.Misc (promptFile)
import Yi.Monad (gets)
import Yi.Rectangle (getRectangle)
import Yi.Regex (makeSearchOptsM)
import qualified Yi.Rope as R (countNewLines, fromText, length, replicateChar, toText, words)
import Yi.Search
import Yi.String (showT)
import Yi.Tag
import Yi.Utils (io)
type UnivArgument = Maybe Int
askQuitEditor :: YiM ()
askQuitEditor = askIndividualSave True =<< getModifiedBuffers
askSaveEditor :: YiM ()
askSaveEditor = askIndividualSave False =<< getModifiedBuffers
getModifiedBuffers :: YiM [FBuffer]
getModifiedBuffers = filterM deservesSave =<< gets bufferSet
askIndividualSave :: Bool -> [FBuffer] -> YiM ()
askIndividualSave True [] = modifiedQuitEditor
askIndividualSave False [] = return ()
askIndividualSave hasQuit allBuffers@(firstBuffer : others) =
void (withEditor (spawnMinibufferE saveMessage (const askKeymap)))
where
saveMessage = T.concat [ "do you want to save the buffer: "
, bufferName
, "? (y/n/", if hasQuit then "q/" else "", "c/!)"
]
bufferName = identString firstBuffer
askKeymap = choice ([ char 'n' ?>>! noAction
, char 'y' ?>>! yesAction
, char '!' ?>>! allAction
, oneOf [char 'c', ctrl $ char 'g']
>>! closeBufferAndWindowE
] ++ [char 'q' ?>>! quitEditor | hasQuit])
yesAction = do void $ fwriteBufferE (bkey firstBuffer)
withEditor closeBufferAndWindowE
continue
noAction = do withEditor closeBufferAndWindowE
continue
allAction = do mapM_ fwriteBufferE $ fmap bkey allBuffers
withEditor closeBufferAndWindowE
askIndividualSave hasQuit []
continue = askIndividualSave hasQuit others
modifiedQuitEditor :: YiM ()
modifiedQuitEditor =
do modifiedBuffers <- getModifiedBuffers
if null modifiedBuffers
then quitEditor
else withEditor $ void (spawnMinibufferE modifiedMessage (const askKeymap))
where
modifiedMessage = "Modified buffers exist really quit? (y/n)"
askKeymap = choice [ char 'n' ?>>! noAction
, char 'y' ?>>! quitEditor
]
noAction = closeBufferAndWindowE
selfSearchKeymap :: Keymap
selfSearchKeymap = do
Event (KASCII c) [] <- anyEvent
write . isearchAddE $ T.singleton c
searchKeymap :: Keymap
searchKeymap = selfSearchKeymap <|> choice
[
ctrl (char 'r') ?>>! isearchPrevE
, ctrl (char 's') ?>>! isearchNextE
, ctrl (char 'w') ?>>! isearchWordE
, meta (char 'p') ?>>! isearchHistory 1
, meta (char 'n') ?>>! isearchHistory (1)
, spec KBS ?>>! isearchDelE
]
isearchKeymap :: Direction -> Keymap
isearchKeymap dir =
do write $ isearchInitE dir
void $ many searchKeymap
choice [ ctrl (char 'g') ?>>! isearchCancelE
, oneOf [ctrl (char 'm'), spec KEnter]
>>! isearchFinishWithE resetRegexE
]
<|| write isearchFinishE
queryReplaceE :: YiM ()
queryReplaceE = withMinibufferFree "Replace:" $ \replaceWhat ->
withMinibufferFree "With:" $ \replaceWith -> do
b <- gets currentBuffer
win <- use currentWindowA
let repStr = R.fromText replaceWith
replaceKm =
choice [ char 'n' ?>>! qrNext win b re
, char '!' ?>>! qrReplaceAll win b re repStr
, oneOf [char 'y', char ' '] >>! qrReplaceOne win b re repStr
, oneOf [char 'q', ctrl (char 'g')] >>! qrFinish
]
Right re = makeSearchOptsM [] (T.unpack replaceWhat)
question = T.unwords [ "Replacing", replaceWhat
, "with", replaceWith, " (y,n,q,!):"
]
withEditor $ do
setRegexE re
void $ spawnMinibufferE question (const replaceKm)
qrNext win b re
executeExtendedCommandE :: YiM ()
executeExtendedCommandE = withMinibuffer "M-x" scope act
where
act = execEditorAction . T.unpack
scope = const $ map T.pack <$> getAllNamesInScope
evalRegionE :: YiM ()
evalRegionE = do
void $ withCurrentBuffer (getSelectRegionB >>= readRegionB)
return ()
insertNextC :: UnivArgument -> KeymapM ()
insertNextC a = do c <- anyEvent
write $ replicateM_ (argToInt a) $ insertB (eventToChar c)
argToInt :: UnivArgument -> Int
argToInt = fromMaybe 1
digit :: (Event -> Event) -> KeymapM Char
digit f = charOf f '0' '9'
tt :: KeymapM Char
tt = do
Event (KASCII c) _ <- foldr1 (<|>) $ fmap (event . metaCh ) ['0'..'9']
return c
readUniversalArg :: KeymapM (Maybe Int)
readUniversalArg = optional ((ctrlCh 'u' ?>> (read <$> some (digit id) <|> pure 4)) <|> (read <$> some tt))
findFileAndDo :: T.Text
-> BufferM a
-> YiM ()
findFileAndDo prompt act = promptFile prompt $ \filename -> do
printMsg $ "loading " <> filename
openingNewFile (T.unpack filename) act
findFile :: YiM ()
findFile = findFileAndDo "find file:" $ return ()
findFileReadOnly :: YiM ()
findFileReadOnly = findFileAndDo "find file (read only):" $ readOnlyA .= True
findFileNewTab :: YiM ()
findFileNewTab = promptFile "find file (new tab): " $ \filename -> do
withEditor newTabE
printMsg $ "loading " <> filename
void . editFile $ T.unpack filename
scrollDownE :: UnivArgument -> BufferM ()
scrollDownE a = case a of
Nothing -> downScreenB
Just n -> scrollB n
scrollUpE :: UnivArgument -> BufferM ()
scrollUpE a = case a of
Nothing -> upScreenB
Just n -> scrollB (negate n)
switchBufferE :: YiM ()
switchBufferE = promptingForBuffer "switch to buffer:"
(withEditor . switchToBufferE) (\o b -> (b \\ o) ++ o)
killBufferE :: YiM ()
killBufferE = promptingForBuffer "kill buffer:" k (\o b -> o ++ (b \\ o))
where
k :: BufferRef -> YiM ()
k b = do
buf <- withEditor . gets $ findBufferWith b
ch <- deservesSave buf
let askKeymap = choice [ char 'n' ?>>! closeBufferAndWindowE
, char 'y' ?>>! delBuf >> closeBufferAndWindowE
, ctrlCh 'g' ?>>! closeBufferAndWindowE
]
delBuf = deleteBuffer b
question = identString buf <> " changed, close anyway? (y/n)"
withEditor $
if ch
then void $ spawnMinibufferE question (const askKeymap)
else delBuf
justOneSep :: UnivArgument -> BufferM ()
justOneSep u = readB >>= \c ->
pointB >>= \point -> case point of
Point 0 -> if isSep c then deleteSeparators else insertMult c
Point x ->
if isSep c
then deleteSeparators
else readAtB (Point $ x 1) >>= \d ->
if isSep d
then moveB Character Backward >> deleteSeparators
else insertMult ' '
where
isSep c = c /= '\n' && isAnySep c
insertMult c = insertN $ R.replicateChar (maybe 1 (max 1) u) c
deleteSeparators = do
genMaybeMoveB unitSepThisLine (Backward, InsideBound) Backward
moveB Character Forward
doIfCharB isSep $ deleteB unitSepThisLine Forward
joinLinesE :: UnivArgument -> BufferM ()
joinLinesE Nothing = return ()
joinLinesE (Just _) = do
moveB VLine Forward
moveToSol >> transformB (const " ") Character Backward >> justOneSep Nothing
maybeList :: [a] -> [a] -> [a]
maybeList def [] = def
maybeList _ ls = ls
maybeTag :: Tag -> T.Text -> Tag
maybeTag def t = if T.null t then def else Tag t
promptTag :: YiM ()
promptTag = do
defaultTag <- withCurrentBuffer $ Tag . R.toText <$> readUnitB unitWord
tagTable <- withEditor getTags
let hinter = return . take 10 . maybe (fail . T.unpack) hintTags tagTable
let completer = return . maybe id completeTag tagTable
p = "Find tag: (default " <> _unTag defaultTag `T.snoc` ')'
withMinibufferGen "" hinter p completer (const $ return ()) $
gotoTag . maybeTag defaultTag
gotoTag :: Tag -> YiM ()
gotoTag tag =
visitTagTable $ \tagTable ->
case lookupTag tag tagTable of
[] -> printMsg $ "No tags containing " <> _unTag tag
(filename, line):_ -> openingNewFile filename $ gotoLn line
visitTagTable :: (TagTable -> YiM ()) -> YiM ()
visitTagTable act = do
posTagTable <- withEditor getTags
case posTagTable of
Just tagTable -> act tagTable
Nothing -> promptFile "Visit tags table: (default tags)" $ \path -> do
let p = T.unpack path
filename = maybeList "tags" $ takeFileName p
tagTable <- io $ importTagTable $ takeDirectory p </> filename
withEditor $ setTags tagTable
act tagTable
countWordsRegion :: YiM ()
countWordsRegion = do
(l, w, c) <- withEditor $ do
t <- withCurrentBuffer $ getRectangle >>= \(reg, _, _) -> readRegionB reg
let nls = R.countNewLines t
return (if nls == 0 then 1 else nls, length $ R.words t, R.length t)
printMsg $ T.unwords [ "Region has", showT l, p l "line" <> ","
, showT w, p w "word" <> ", and"
, showT c, p w "character" <> "."
]
where
p x w = if x == 1 then w else w <> "s"