module Yi.Buffer.HighLevel where
import Control.Monad.RWS.Strict (ask)
import Control.Monad.State hiding (forM, forM_, sequence_)
import Control.Applicative
import Control.Monad
import Control.Lens hiding ((-~), (+~), re, transform)
import Data.Char
import Data.List (isPrefixOf, sort, intersperse)
import Data.Maybe (fromMaybe, listToMaybe, catMaybes)
import qualified Data.Rope as R
import Data.Rope (Rope)
import Data.Time (UTCTime)
import Data.Tuple (swap)
import Yi.Buffer.Basic
import Yi.Buffer.Misc
import Yi.Buffer.Normal
import Yi.Buffer.Region
import Yi.Keymap (YiM, withBuffer)
import Yi.String
import Yi.Window
import Yi.Config.Misc (ScrollStyle(SingleLine))
import Yi.Utils
moveToSol :: BufferM ()
moveToSol = maybeMoveB Line Backward
moveToEol :: BufferM ()
moveToEol = maybeMoveB Line Forward
topB :: BufferM ()
topB = moveTo 0
botB :: BufferM ()
botB = moveTo =<< sizeB
leftOnEol :: BufferM ()
leftOnEol = savingPrefCol $ do
eol <- atEol
sol <- atSol
when (eol && not sol) leftB
moveXorSol :: Int -> BufferM ()
moveXorSol x = replicateM_ x $ do c <- atSol; unless c leftB
moveXorEol :: Int -> BufferM ()
moveXorEol x = replicateM_ x $ do c <- atEol; unless c rightB
nextWordB :: BufferM ()
nextWordB = moveB unitWord Forward
prevWordB :: BufferM ()
prevWordB = moveB unitWord Backward
gotoCharacterB :: Char -> Direction -> RegionStyle -> Bool -> BufferM ()
gotoCharacterB c dir style stopAtLineBreaks = do
start <- pointB
let predicate = if stopAtLineBreaks then (`elem` [c, '\n']) else (== c)
(move, moveBack) = if dir == Forward then (rightB, leftB) else (leftB, rightB)
doUntilB_ (predicate <$> readB) move
b <- readB
if stopAtLineBreaks && b == '\n'
then moveTo start
else when (style == Exclusive && b == c) moveBack
nextCInc :: Char -> BufferM ()
nextCInc c = gotoCharacterB c Forward Inclusive False
nextCInLineInc :: Char -> BufferM ()
nextCInLineInc c = gotoCharacterB c Forward Inclusive True
nextCExc :: Char -> BufferM ()
nextCExc c = gotoCharacterB c Forward Exclusive False
nextCInLineExc :: Char -> BufferM ()
nextCInLineExc c = gotoCharacterB c Forward Exclusive True
prevCInc :: Char -> BufferM ()
prevCInc c = gotoCharacterB c Backward Inclusive False
prevCInLineInc :: Char -> BufferM ()
prevCInLineInc c = gotoCharacterB c Backward Inclusive True
prevCExc :: Char -> BufferM ()
prevCExc c = gotoCharacterB c Backward Exclusive False
prevCInLineExc :: Char -> BufferM ()
prevCInLineExc c = gotoCharacterB c Backward Exclusive True
firstNonSpaceB :: BufferM ()
firstNonSpaceB = do moveToSol
untilB_ ((||) <$> atEol <*> ((not . isSpace) <$> readB)) rightB
lastNonSpaceB :: BufferM ()
lastNonSpaceB = do moveToEol
untilB_ ((||) <$> atSol <*> ((not . isSpace) <$> readB)) leftB
moveNonspaceOrSol :: BufferM ()
moveNonspaceOrSol = do prev <- readPreviousOfLnB
if all isSpace prev then moveToSol else firstNonSpaceB
isCurrentLineEmptyB :: BufferM Bool
isCurrentLineEmptyB = savingPointB $ moveToSol >> atEol
isCurrentLineAllWhiteSpaceB :: BufferM Bool
isCurrentLineAllWhiteSpaceB = savingPointB $ do
isEmpty <- isCurrentLineEmptyB
if isEmpty
then return False
else do
let go = do
eol <- atEol
if eol
then return True
else do
c <- readB
if isSpace c
then rightB >> go
else return False
moveToSol
go
nextNParagraphs :: Int -> BufferM ()
nextNParagraphs n = replicateM_ n $ moveB unitEmacsParagraph Forward
prevNParagraphs :: Int -> BufferM ()
prevNParagraphs n = replicateM_ n $ moveB unitEmacsParagraph Backward
goUnmatchedB :: Direction -> Char -> Char -> BufferM ()
goUnmatchedB dir cStart' cStop' = stepB >> readB >>= go (0::Int)
where go opened c | c == cStop && opened == 0 = return ()
| c == cStop = stepB >> readB >>= go (opened1)
| c == cStart = stepB >> readB >>= go (opened+1)
| otherwise = stepB >> readB >>= go opened
(stepB, cStart, cStop) | dir == Forward = (rightB, cStart', cStop')
| otherwise = (leftB, cStop', cStart')
atSol :: BufferM Bool
atSol = atBoundaryB Line Backward
atEol :: BufferM Bool
atEol = atBoundaryB Line Forward
atSof :: BufferM Bool
atSof = atBoundaryB Document Backward
atEof :: BufferM Bool
atEof = atBoundaryB Document Forward
atLastLine :: BufferM Bool
atLastLine = savingPointB $ do
moveToEol
(==) <$> sizeB <*> pointB
getLineAndCol :: BufferM (Int, Int)
getLineAndCol = (,) <$> curLn <*> curCol
getLineAndColOfPoint :: Point -> BufferM (Int, Int)
getLineAndColOfPoint p = savingPointB $ moveTo p >> getLineAndCol
readLnB :: BufferM String
readLnB = readUnitB Line
readCharB :: BufferM (Maybe Char)
readCharB = fmap listToMaybe (readUnitB Character)
readRestOfLnB :: BufferM String
readRestOfLnB = readRegionB =<< regionOfPartB Line Forward
readPreviousOfLnB :: BufferM String
readPreviousOfLnB = readRegionB =<< regionOfPartB Line Backward
hasWhiteSpaceBefore :: BufferM Bool
hasWhiteSpaceBefore = liftM isSpace (prevPointB >>= readAtB)
prevPointB :: BufferM Point
prevPointB = do
sof <- atSof
if sof then pointB
else do p <- pointB
return $ Point (fromPoint p 1)
nextPointB :: BufferM Point
nextPointB = do
eof <- atEof
if eof then pointB
else do p <- pointB
return $ Point (fromPoint p + 1)
readCurrentWordB :: BufferM String
readCurrentWordB = readUnitB unitWord
readPrevWordB :: BufferM String
readPrevWordB = readPrevUnitB unitViWordOnLine
bdeleteB :: BufferM ()
bdeleteB = deleteB Character Backward
killWordB :: BufferM ()
killWordB = deleteB unitWord Forward
bkillWordB :: BufferM ()
bkillWordB = deleteB unitWord Backward
uppercaseWordB :: BufferM ()
uppercaseWordB = transformB (fmap toUpper) unitWord Forward
lowercaseWordB :: BufferM ()
lowercaseWordB = transformB (fmap toLower) unitWord Forward
capitaliseWordB :: BufferM ()
capitaliseWordB = transformB capitalizeFirst unitWord Forward
switchCaseCharB :: BufferM ()
switchCaseCharB = transformB (fmap switchCaseChar) Character Forward
switchCaseChar :: Char -> Char
switchCaseChar c = if isUpper c then toLower c else toUpper c
deleteToEol :: BufferM ()
deleteToEol = deleteRegionB =<< regionOfPartB Line Forward
deleteLineForward :: BufferM ()
deleteLineForward =
do moveToSol
deleteToEol
deleteN 1
swapB :: BufferM ()
swapB = do eol <- atEol
when eol leftB
transposeB Character Forward
deleteTrailingSpaceB :: BufferM ()
deleteTrailingSpaceB = modifyRegionClever deleteSpaces =<< regionOfB Document
where deleteSpaces = mapLines $ reverse . dropWhile (`elem` " \t") . reverse
setSelectionMarkPointB :: Point -> BufferM ()
setSelectionMarkPointB p = flip setMarkPointB p =<< selMark <$> askMarks
getSelectionMarkPointB :: BufferM Point
getSelectionMarkPointB = getMarkPointB =<< selMark <$> askMarks
exchangePointAndMarkB :: BufferM ()
exchangePointAndMarkB = do m <- getSelectionMarkPointB
p <- pointB
setSelectionMarkPointB p
moveTo m
getBookmarkB :: String -> BufferM Mark
getBookmarkB = getMarkB . Just
data BufferFileInfo =
BufferFileInfo { bufInfoFileName :: FilePath
, bufInfoSize :: Int
, bufInfoLineNo :: Int
, bufInfoColNo :: Int
, bufInfoCharNo :: Point
, bufInfoPercent :: String
, bufInfoModified :: Bool
}
bufInfoB :: BufferM BufferFileInfo
bufInfoB = do
s <- sizeB
p <- pointB
m <- gets isUnchangedBuffer
l <- curLn
c <- curCol
nm <- gets identString
let bufInfo = BufferFileInfo { bufInfoFileName = nm
, bufInfoSize = fromIntegral s
, bufInfoLineNo = l
, bufInfoColNo = c
, bufInfoCharNo = p
, bufInfoPercent = getPercent p s
, bufInfoModified = not m
}
return bufInfo
upScreensB :: Int -> BufferM ()
upScreensB = scrollScreensB . negate
downScreensB :: Int -> BufferM ()
downScreensB = scrollScreensB
upScreenB :: BufferM ()
upScreenB = scrollScreensB (1)
downScreenB :: BufferM ()
downScreenB = scrollScreensB 1
scrollScreensB :: Int -> BufferM ()
scrollScreensB n = do
h <- askWindow height
scrollB $ n * max 0 (h 3)
scrollByB :: (Int -> Int) -> Int -> BufferM ()
scrollByB f n = do h <- askWindow height
scrollB $ n * f h
vimScrollB :: Int -> BufferM ()
vimScrollB n = do scrollB n
void $ lineMoveRel n
vimScrollByB :: (Int -> Int) -> Int -> BufferM ()
vimScrollByB f n = do h <- askWindow height
vimScrollB $ n * f h
scrollToCursorB :: BufferM ()
scrollToCursorB = do
MarkSet f i _ <- markLines
h <- askWindow height
let m = f + (h `div` 2)
scrollB $ i m
scrollCursorToTopB :: BufferM ()
scrollCursorToTopB = do
MarkSet f i _ <- markLines
scrollB $ i f
scrollCursorToBottomB :: BufferM ()
scrollCursorToBottomB = do
MarkSet _ i _ <- markLines
r <- winRegionB
t <- lineOf (regionEnd r 1)
scrollB $ i t
scrollB :: Int -> BufferM ()
scrollB n = do
MarkSet fr _ _ <- askMarks
savingPointB $ do
moveTo =<< getMarkPointB fr
void $ gotoLnFrom n
setMarkPointB fr =<< pointB
w <- askWindow wkey
(%=) pointFollowsWindowA (\old w' -> ((w == w') || old w'))
snapInsB :: BufferM ()
snapInsB = do
movePoint <- use pointFollowsWindowA
w <- askWindow wkey
when (movePoint w) $ do
r <- winRegionB
p <- pointB
moveTo $ max (regionStart r) $ min (regionEnd r) p
indexOfSolAbove :: Int -> BufferM Point
indexOfSolAbove n = pointAt $ gotoLnFrom (negate n)
data RelPosition = Above | Below | Within
deriving (Show)
pointScreenRelPosition :: Point -> Point -> Point -> RelPosition
pointScreenRelPosition p rs re
| rs > p && p > re = Within
| p < rs = Above
| p > re = Below
pointScreenRelPosition _ _ _ = Within
snapScreenB :: Maybe ScrollStyle ->BufferM Bool
snapScreenB style = do
movePoint <- use pointFollowsWindowA
w <- askWindow wkey
if movePoint w then return False else do
inWin <- pointInWindowB =<< pointB
if inWin then return False else do
h <- askWindow actualLines
r <- winRegionB
p <- pointB
let gap = case style of
Just SingleLine -> case pointScreenRelPosition p (regionStart r) (regionEnd r) of
Above -> 0
Below -> h 1
Within -> 0
_ -> h `div` 2
i <- indexOfSolAbove gap
f <- fromMark <$> askMarks
setMarkPointB f i
return True
downFromTosB :: Int -> BufferM ()
downFromTosB n = do
moveTo =<< getMarkPointB =<< fromMark <$> askMarks
replicateM_ n lineDown
upFromBosB :: Int -> BufferM ()
upFromBosB n = do
r <- winRegionB
moveTo (regionEnd r 1)
moveToSol
replicateM_ n lineUp
middleB :: BufferM ()
middleB = do
w <- ask
f <- fromMark <$> askMarks
moveTo =<< getMarkPointB f
replicateM_ (height w `div` 2) lineDown
pointInWindowB :: Point -> BufferM Bool
pointInWindowB p = nearRegion p <$> winRegionB
getRawestSelectRegionB :: BufferM Region
getRawestSelectRegionB = do
m <- getSelectionMarkPointB
p <- pointB
return $ mkRegion p m
getRawSelectRegionB :: BufferM Region
getRawSelectRegionB = do
s <- use highlightSelectionA
if s then getRawestSelectRegionB else do
p <- pointB
return $ mkRegion p p
getSelectRegionB :: BufferM Region
getSelectRegionB = do
regionStyle <- use regionStyleA
r <- getRawSelectRegionB
mkRegionOfStyleB (regionStart r) (regionEnd r) regionStyle
setSelectRegionB :: Region -> BufferM ()
setSelectRegionB region = do
setSelectionMarkPointB $ regionStart region
moveTo $ regionEnd region
extendSelectRegionB :: Region -> BufferM ()
extendSelectRegionB region = (setSelectRegionB . unionRegion region) =<< getSelectRegionB
deleteBlankLinesB :: BufferM ()
deleteBlankLinesB =
do isThisBlank <- isBlank <$> readLnB
when isThisBlank $ do
p <- pointB
void $ whileB (isBlank <$> getNextLineB Backward) lineUp
q <- pointB
deleteRegionB $ mkRegion p q
lineStreamB :: Direction -> BufferM [String]
lineStreamB dir = drop 1 . fmap rev . lines' . R.toString <$> (streamB dir =<< pointB)
where rev = case dir of
Forward -> id
Backward -> reverse
getMaybeNextLineB :: Direction -> BufferM (Maybe String)
getMaybeNextLineB dir = listToMaybe <$> lineStreamB dir
getNextLineB :: Direction -> BufferM String
getNextLineB dir = fromMaybe "" <$> getMaybeNextLineB dir
getNextLineWhichB :: Direction -> (String -> Bool) -> BufferM (Maybe String)
getNextLineWhichB dir cond = listToMaybe . filter cond <$> lineStreamB dir
getNextNonBlankLineB :: Direction -> BufferM String
getNextNonBlankLineB dir = fromMaybe "" <$> getNextLineWhichB dir (not . isBlank)
modifySelectionB :: (String -> String) -> BufferM ()
modifySelectionB = modifyExtendedSelectionB Character
modifyExtendedSelectionB :: TextUnit -> (String -> String) -> BufferM ()
modifyExtendedSelectionB unit transform
= modifyRegionB transform =<< unitWiseRegion unit =<< getSelectRegionB
linePrefixSelectionB :: String
-> BufferM ()
linePrefixSelectionB s =
modifyExtendedSelectionB Line $ skippingLast $ mapLines (s++)
where skippingLast f xs = f (init xs) ++ [last xs]
unLineCommentSelectionB :: String
-> String
-> BufferM ()
unLineCommentSelectionB s1 s2 =
modifyExtendedSelectionB Line $ mapLines unCommentLine
where
unCommentLine :: String -> String
unCommentLine line
| s1 `isPrefixOf` line = drop (length s1) line
| s2 `isPrefixOf` line = drop (length s2) line
| otherwise = line
toggleCommentSelectionB :: String -> String -> YiM ()
toggleCommentSelectionB insPrefix delPrefix = withBuffer $ do
l <- readUnitB Line
if delPrefix `isPrefixOf` l
then unLineCommentSelectionB insPrefix delPrefix
else linePrefixSelectionB insPrefix
justifySelectionWithTopB :: BufferM ()
justifySelectionWithTopB =
modifySelectionB justifyLines
where
justifyLines :: String -> String
justifyLines input =
case lines input of
[] -> ""
[ one ] -> one
(top : _) -> mapLines justifyLine input
where
topIndent = takeWhile isSpace top
justifyLine :: String -> String
justifyLine "" = ""
justifyLine l = topIndent ++ dropWhile isSpace l
replaceBufferContent :: String -> BufferM ()
replaceBufferContent newvalue = do
r <- regionOfB Document
replaceRegionB r newvalue
fillRegion :: Region -> BufferM ()
fillRegion = modifyRegionClever (unlines' . fillText 80)
fillParagraph :: BufferM ()
fillParagraph = fillRegion =<< regionOfB unitParagraph
sortLines :: BufferM ()
sortLines = modifyExtendedSelectionB Line (onLines sort)
revertB :: Rope -> UTCTime -> BufferM ()
revertB s now = do
r <- regionOfB Document
if R.length s <= smallBufferSize
then replaceRegionClever r (R.toString s)
else replaceRegionB' r s
markSavedB now
smallBufferSize :: Int
smallBufferSize = 1000000
shapeOfBlockRegionB :: Region -> BufferM (Point, [Int])
shapeOfBlockRegionB reg = savingPointB $ do
(l0, c0) <- getLineAndColOfPoint $ regionStart reg
(l1, c1) <- getLineAndColOfPoint $ regionEnd reg
let (left, top, bottom, right) = (min c0 c1, min l0 l1, max l0 l1, max c0 c1)
lengths <- forM [top .. bottom] $ \l -> do
void $ gotoLn l
moveToColB left
currentLeft <- curCol
if currentLeft /= left
then return 0
else do
moveToColB right
rightAtEol <- atEol
leftOnEol
currentRight <- curCol
return $ if currentRight == 0 && rightAtEol
then 0
else currentRight currentLeft + 1
startingPoint <- pointOfLineColB top left
return (startingPoint, lengths)
leftEdgesOfRegionB :: RegionStyle -> Region -> BufferM [Point]
leftEdgesOfRegionB Block reg = savingPointB $ do
(l0, _) <- getLineAndColOfPoint $ regionStart reg
(l1, _) <- getLineAndColOfPoint $ regionEnd reg
moveTo $ regionStart reg
fmap catMaybes $ forM [0 .. abs (l0 l1)] $ \i -> savingPointB $ do
void $ lineMoveRel i
p <- pointB
eol <- atEol
return (if not eol then Just p else Nothing)
leftEdgesOfRegionB _ r = return [regionStart r]
rightEdgesOfRegionB :: RegionStyle -> Region -> BufferM [Point]
rightEdgesOfRegionB LineWise reg = savingPointB $ do
lastEol <- do
moveTo $ regionEnd reg
moveToEol
pointB
let go acc p = do moveTo p
moveToEol
edge <- pointB
if edge > lastEol
then return $ reverse acc
else do
void $ lineMoveRel 1
go (edge:acc) =<< pointB
go [] (regionStart reg)
rightEdgesOfRegionB _ reg = savingPointB $ do
moveTo $ regionEnd reg
leftOnEol
fmap singleton pointB
splitBlockRegionToContiguousSubRegionsB :: Region -> BufferM [Region]
splitBlockRegionToContiguousSubRegionsB reg = savingPointB $ do
(start, lengths) <- shapeOfBlockRegionB reg
moveTo start
forM lengths $ \l -> do
p0 <- pointB
moveXorEol l
p1 <- pointB
let subRegion = mkRegion p0 p1
moveTo p0
void $ lineMoveRel 1
return subRegion
deleteRegionWithStyleB :: Region -> RegionStyle -> BufferM Point
deleteRegionWithStyleB reg Block = savingPointB $ do
(start, lengths) <- shapeOfBlockRegionB reg
moveTo start
forM_ (zip [1..] lengths) $ \(i, l) -> do
deleteN l
moveTo start
lineMoveRel i
return start
deleteRegionWithStyleB reg style = savingPointB $ do
effectiveRegion <- convertRegionToStyleB reg style
deleteRegionB effectiveRegion
return $! regionStart effectiveRegion
readRegionRopeWithStyleB :: Region -> RegionStyle -> BufferM Rope
readRegionRopeWithStyleB reg Block = savingPointB $ do
(start, lengths) <- shapeOfBlockRegionB reg
moveTo start
chunks <- forM lengths $ \l ->
if l == 0
then lineMoveRel 1 >> return R.empty
else do
p <- pointB
r <- readRegionB' $ mkRegion p (p +~ Size l)
void $ lineMoveRel 1
return r
return $ R.concat $ intersperse (R.fromString "\n") chunks
readRegionRopeWithStyleB reg style = readRegionB' =<< convertRegionToStyleB reg style
insertRopeWithStyleB :: Rope -> RegionStyle -> BufferM ()
insertRopeWithStyleB rope Block = savingPointB $ do
let ls = R.split (fromIntegral (ord '\n')) rope
advanceLine = do
bottom <- atLastLine
if bottom
then do
col <- curCol
moveToEol
newlineB
insertN $ replicate col ' '
else void $ lineMoveRel 1
sequence_ $ intersperse advanceLine $ fmap (savingPointB . insertN') ls
insertRopeWithStyleB rope LineWise = do
moveToSol
savingPointB $ insertN' rope
insertRopeWithStyleB rope _ = insertN' rope
flipRectangleB :: Point -> Point -> BufferM (Point, Point)
flipRectangleB p0 p1 = savingPointB $ do
(_, c0) <- getLineAndColOfPoint p0
(_, c1) <- getLineAndColOfPoint p1
case compare c0 c1 of
EQ -> return (p0, p1)
GT -> fmap swap $ flipRectangleB p1 p0
LT -> do
moveTo p0
moveXorEol $ c1 c0
flippedP0 <- pointB
return (flippedP0, p1 -~ Size (c1 c0))
movePercentageFileB :: Int -> BufferM ()
movePercentageFileB i = do
let f :: Double
f = case fromIntegral i / 100.0 of
x | x > 1.0 -> 1.0
| x < 0.0 -> 0.0
| otherwise -> x
lineCount <- lineCountB
void $ gotoLn $ floor (fromIntegral lineCount * f)
firstNonSpaceB
findMatchingPairB :: BufferM ()
findMatchingPairB = do
let go dir a b = goUnmatchedB dir a b >> return True
goToMatch = do
c <- readB
case c of '(' -> go Forward '(' ')'
')' -> go Backward '(' ')'
'{' -> go Forward '{' '}'
'}' -> go Backward '{' '}'
'[' -> go Forward '[' ']'
']' -> go Backward '[' ']'
_ -> otherChar
otherChar = do eof <- atEof
eol <- atEol
if eof || eol
then return False
else rightB >> goToMatch
p <- pointB
foundMatch <- goToMatch
unless foundMatch $ moveTo p