module Yi.Buffer.HighLevel where
import Prelude (FilePath)
import Yi.Prelude
import Control.Monad.RWS.Strict (ask)
import Control.Monad.State hiding (forM, forM_, sequence_)
import Data.Char
import Data.List (isPrefixOf, sort, lines, drop, filter, length,
takeWhile, dropWhile, reverse, map, intersperse, zip)
import Data.Maybe (fromMaybe, listToMaybe, catMaybes)
import Data.Ord
import qualified Data.Rope as R
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.String
import Yi.Window
import Yi.Config.Misc (ScrollStyle(SingleLine))
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; when (not c) leftB
moveXorEol :: Int -> BufferM ()
moveXorEol x = replicateM_ x $ do c <- atEol; when (not 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 and . map 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 = prevPointB >>= readAtB >>= return . isSpace
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
discard $ 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
discard $ gotoLnFrom n
setMarkPointB fr =<< pointB
w <- askWindow wkey
modA pointFollowsWindowA (\old w' -> if w == w' then True else old w')
snapInsB :: BufferM ()
snapInsB = do
movePoint <- getA 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 <- getA 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 <- getA highlightSelectionA
if s then getRawestSelectRegionB else do
p <- pointB
return $ mkRegion p p
getSelectRegionB :: BufferM Region
getSelectRegionB = do
regionStyle <- getA 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
discard $ 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
| isPrefixOf s1 line = drop (length s1) line
| isPrefixOf s2 line = drop (length s2) line
| otherwise = line
toggleCommentSelectionB :: String -> String -> BufferM ()
toggleCommentSelectionB insPrefix delPrefix = 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
discard $ 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
discard $ lineMoveRel i
p <- pointB
eol <- atEol
if not eol
then return $ Just p
else return 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
discard $ 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
discard $ 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)
discard $ 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 discard $ 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
discard $ 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