yi-core-0.13: src/Yi/Buffer/Misc.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-- |
-- Module : Yi.Buffer.Misc
-- License : GPL-2
-- Maintainer : yi-devel@googlegroups.com
-- Stability : experimental
-- Portability : portable
--
-- The 'Buffer' module defines monadic editing operations over one-dimensional
-- buffers, maintaining a current /point/.
module Yi.Buffer.Misc
( FBuffer (FBuffer, bmode)
, BufferM (..)
, WinMarks, MarkSet (..)
, bkey
, getMarks
, runBuffer
, runBufferFull
, runBufferDummyWindow
, screenTopLn
, screenMidLn
, screenBotLn
, curLn
, curCol
, colOf
, lineOf
, lineCountB
, sizeB
, pointB
, pointOfLineColB
, solPointB
, eolPointB
, markLines
, moveTo
, moveToColB
, moveToLineColB
, lineMoveRel
, lineUp
, lineDown
, newB
, MarkValue (..)
, Overlay
(overlayAnnotation, overlayBegin, overlayEnd, overlayOwner, overlayStyle)
, mkOverlay
, gotoLn
, gotoLnFrom
, leftB
, rightB
, moveN
, leftN
, rightN
, insertN
, insertNAt
, insertB
, deleteN
, nelemsB
, writeB
, writeN
, newlineB
, deleteNAt
, readB
, elemsB
, undosA
, undoB
, redoB
, getMarkB
, setMarkHereB
, setNamedMarkHereB
, mayGetMarkB
, getMarkValueB
, markPointA
, modifyMarkB
, newMarkB
, deleteMarkB
, getVisibleSelection
, setVisibleSelection
, isUnchangedBuffer
, setAnyMode
, setMode
, setMode0
, modifyMode
, regexRegionB
, regexB
, readAtB
, getModeLine
, getPercent
, setInserting
, savingPrefCol
, forgetPreferCol
, movingToPrefCol
, movingToPrefVisCol
, preferColA
, markSavedB
, retroactivelyAtSavePointB
, addOverlayB
, delOverlayB
, delOverlaysOfOwnerB
, getOverlaysOfOwnerB
, isPointInsideOverlay
, savingExcursionB
, savingPointB
, savingPositionB
, pendingUpdatesA
, highlightSelectionA
, rectangleSelectionA
, readOnlyA
, insertingA
, pointFollowsWindowA
, revertPendingUpdatesB
, askWindow
, clearSyntax
, focusSyntax
, Mode (..)
, modeNameA
, modeAppliesA
, modeHLA
, modePrettifyA
, modeKeymapA
, modeIndentA
, modeAdjustBlockA
, modeFollowA
, modeIndentSettingsA
, modeToggleCommentSelectionA
, modeGetStrokesA
, modeOnLoadA
, modeGotoDeclarationA
, modeModeLineA
, AnyMode (..)
, IndentBehaviour (..)
, IndentSettings (..)
, expandTabsA
, tabSizeA
, shiftWidthA
, modeAlwaysApplies
, modeNeverApplies
, emptyMode
, withModeB
, withMode0
, onMode
, withSyntaxB
, withSyntaxB'
, keymapProcessA
, strokesRangesB
, streamB
, indexedStreamB
, askMarks
, pointAt
, SearchExp
, lastActiveWindowA
, putBufferDyn
, getBufferDyn
, shortIdentString
, identString
, miniIdentString
, identA
, directoryContentA
, BufferId (..)
, file
, lastSyncTimeA
, replaceCharB
, replaceCharWithBelowB
, replaceCharWithAboveB
, insertCharWithBelowB
, insertCharWithAboveB
, pointAfterCursorB
, destinationOfMoveB
, withEveryLineB
, startUpdateTransactionB
, commitUpdateTransactionB
, applyUpdate
, betweenB
, decreaseFontSize
, increaseFontSize
, indentSettingsB
, fontsizeVariationA
, encodingConverterNameA
, stickyEolA
) where
import Prelude hiding (foldr, mapM, notElem)
import Lens.Micro.Platform (Lens', lens, (%~), (^.), use, (.=), (%=), view)
import Control.Monad.RWS.Strict (Endo (Endo, appEndo),
MonadReader (ask), MonadState,
MonadWriter (tell),
asks, gets, join, modify,
replicateM_, runRWS, void,
when, (<>))
import Data.Binary (Binary (..), Get)
import Data.Char (ord)
import Data.Default (Default (def))
import Data.DynamicState.Serializable (getDyn, putDyn)
import Data.Foldable (Foldable (foldr), forM_, notElem)
import qualified Data.Map as M (Map, empty, insert, lookup)
import Data.Maybe (fromMaybe, isNothing)
import qualified Data.Set as Set (Set)
import qualified Data.Text as T (Text, concat, justifyRight, pack, snoc, unpack)
import qualified Data.Text.Encoding as E (decodeUtf8, encodeUtf8)
import Data.Time (UTCTime (UTCTime))
import Data.Traversable (Traversable (mapM), forM)
import Numeric (showHex)
import System.FilePath (joinPath, splitPath)
import Yi.Buffer.Basic (BufferRef, Point (..), Size (Size), WindowRef)
import Yi.Buffer.Implementation
import Yi.Buffer.Undo
import Yi.Interact as I (P (End))
import Yi.Monad (getsAndModify)
import Yi.Region (Region, mkRegion)
import Yi.Rope (YiString)
import qualified Yi.Rope as R
import Yi.Syntax (ExtHL (ExtHL), Stroke, noHighlighter)
import Yi.Types
import Yi.Utils (SemiNum ((+~)), makeClassyWithSuffix, makeLensesWithSuffix)
import Yi.Window (Window (width, wkey, actualLines), dummyWindow)
uses l f = f <$> use l
-- In addition to Buffer's text, this manages (among others):
-- * Log of updates mades
-- * Undo
makeClassyWithSuffix "A" ''Attributes
instance HasAttributes FBuffer where
attributesA = lens attributes (\(FBuffer f1 f2 _) a -> FBuffer f1 f2 a)
-- | Gets a short identifier of a buffer. If we're given a 'MemBuffer'
-- then just wraps the buffer name like so: @*name*@. If we're given a
-- 'FileBuffer', it drops the the number of characters specified.
--
-- >>> shortIdentString 3 (MemBuffer "hello")
-- "*hello*"
-- >>> shortIdentString 3 (FileBuffer "hello")
-- "lo"
shortIdentString :: Int -- ^ Number of characters to drop from FileBuffer names
-> FBuffer -- ^ Buffer to work with
-> T.Text
shortIdentString dl b = case b ^. identA of
MemBuffer bName -> "*" <> bName <> "*"
FileBuffer fName -> T.pack . joinPath . drop dl $ splitPath fName
-- | Gets the buffer's identifier string, emphasising the 'MemBuffer':
--
-- >>> identString (MemBuffer "hello")
-- "*hello*"
-- >>> identString (FileBuffer "hello")
-- "hello"
identString :: FBuffer -> T.Text
identString b = case b ^. identA of
MemBuffer bName -> "*" <> bName <> "*"
FileBuffer fName -> T.pack fName
-- TODO: proper instance + de-orphan
instance Show FBuffer where
show b = Prelude.concat [ "Buffer #", show (bkey b)
, " (", T.unpack (identString b), ")" ]
miniIdentString :: FBuffer -> T.Text
miniIdentString b = case b ^. identA of
MemBuffer bufName -> bufName
FileBuffer _ -> "MINIFILE:"
-- unfortunately the dynamic stuff can't be read.
instance Binary FBuffer where
put (FBuffer binmode r attributes_) =
let strippedRaw :: BufferImpl ()
strippedRaw = setSyntaxBI (modeHL emptyMode) r
in do
put binmode
put strippedRaw
put attributes_
get =
FBuffer <$> get <*> getStripped <*> get
where getStripped :: Get (BufferImpl ())
getStripped = get
-- | update the syntax information (clear the dirty "flag")
clearSyntax :: FBuffer -> FBuffer
clearSyntax = modifyRawbuf updateSyntax
queryRawbuf :: (forall syntax. BufferImpl syntax -> x) -> FBuffer -> x
queryRawbuf f (FBuffer _ fb _) = f fb
modifyRawbuf :: (forall syntax. BufferImpl syntax -> BufferImpl syntax) -> FBuffer -> FBuffer
modifyRawbuf f (FBuffer f1 f2 f3) = FBuffer f1 (f f2) f3
queryAndModifyRawbuf :: (forall syntax. BufferImpl syntax -> (BufferImpl syntax,x)) ->
FBuffer -> (FBuffer, x)
queryAndModifyRawbuf f (FBuffer f1 f5 f3) =
let (f5', x) = f f5
in (FBuffer f1 f5' f3, x)
file :: FBuffer -> Maybe FilePath
file b = case b ^. identA of
FileBuffer f -> Just f
MemBuffer _ -> Nothing
highlightSelectionA :: Lens' FBuffer Bool
highlightSelectionA = selectionStyleA .
lens highlightSelection (\e x -> e { highlightSelection = x })
rectangleSelectionA :: Lens' FBuffer Bool
rectangleSelectionA = selectionStyleA .
lens rectangleSelection (\e x -> e { rectangleSelection = x })
-- | Just stores the mode name.
instance Binary (Mode syntax) where
put = put . E.encodeUtf8 . modeName
get = do
n <- E.decodeUtf8 <$> get
return (emptyMode {modeName = n})
-- | Increases the font size in the buffer by specified number. What
-- this number actually means depends on the front-end.
increaseFontSize :: Int -> BufferM ()
increaseFontSize x = fontsizeVariationA %= \fs -> max 1 (fs + x)
-- | Decreases the font size in the buffer by specified number. What
-- this number actually means depends on the front-end.
decreaseFontSize :: Int -> BufferM ()
decreaseFontSize x = fontsizeVariationA %= \fs -> max 1 (fs - x)
-- | Given a buffer, and some information update the modeline
--
-- N.B. the contents of modelines should be specified by user, and
-- not hardcoded.
getModeLine :: [T.Text] -> BufferM T.Text
getModeLine prefix = withModeB (`modeModeLine` prefix)
defaultModeLine :: [T.Text] -> BufferM T.Text
defaultModeLine prefix = do
col <- curCol
pos <- pointB
ln <- curLn
p <- pointB
s <- sizeB
curChar <- readB
ro <-use readOnlyA
modeNm <- gets (withMode0 modeName)
unchanged <- gets isUnchangedBuffer
enc <- use encodingConverterNameA >>= return . \case
Nothing -> mempty :: T.Text
Just cn -> T.pack $ R.unCn cn
let pct
| pos == 0 || s == 0 = " Top"
| pos == s = " Bot"
| otherwise = getPercent p s
changed = if unchanged then "-" else "*"
readOnly' = if ro then "%" else changed
hexxed = T.pack $ showHex (ord curChar) ""
hexChar = "0x" <> T.justifyRight 2 '0' hexxed
toT = T.pack . show
nm <- gets $ shortIdentString (length prefix)
return $ T.concat [ enc, " ", readOnly', changed, " ", nm
, " ", hexChar, " "
, "L", T.justifyRight 5 ' ' (toT ln)
, " "
, "C", T.justifyRight 3 ' ' (toT col)
, " ", pct , " ", modeNm , " ", toT $ fromPoint p
]
-- | Given a point, and the file size, gives us a percent string
getPercent :: Point -> Point -> T.Text
getPercent a b = T.justifyRight 3 ' ' (T.pack $ show p) `T.snoc` '%'
where p = ceiling (aa / bb * 100.0 :: Double) :: Int
aa = fromIntegral a :: Double
bb = fromIntegral b :: Double
queryBuffer :: (forall syntax. BufferImpl syntax -> x) -> BufferM x
queryBuffer = gets . queryRawbuf
modifyBuffer :: (forall syntax. BufferImpl syntax -> BufferImpl syntax) -> BufferM ()
modifyBuffer = modify . modifyRawbuf
queryAndModify :: (forall syntax. BufferImpl syntax -> (BufferImpl syntax,x)) -> BufferM x
queryAndModify = getsAndModify . queryAndModifyRawbuf
-- | Adds an "overlay" to the buffer
addOverlayB :: Overlay -> BufferM ()
addOverlayB ov = do
pendingUpdatesA %= (++ [overlayUpdate ov])
modifyBuffer $ addOverlayBI ov
getOverlaysOfOwnerB :: R.YiString -> BufferM (Set.Set Overlay)
getOverlaysOfOwnerB owner = queryBuffer (getOverlaysOfOwnerBI owner)
-- | Remove an existing "overlay"
delOverlayB :: Overlay -> BufferM ()
delOverlayB ov = do
pendingUpdatesA %= (++ [overlayUpdate ov])
modifyBuffer $ delOverlayBI ov
delOverlaysOfOwnerB :: R.YiString -> BufferM ()
delOverlaysOfOwnerB owner =
modifyBuffer $ delOverlaysOfOwnerBI owner
isPointInsideOverlay :: Point -> Overlay -> Bool
isPointInsideOverlay point overlay =
let Overlay _ (MarkValue start _) (MarkValue finish _) _ _ = overlay
in start <= point && point <= finish
-- | Execute a @BufferM@ value on a given buffer and window. The new state of
-- the buffer is returned alongside the result of the computation.
runBuffer :: Window -> FBuffer -> BufferM a -> (a, FBuffer)
runBuffer w b f =
let (a, _, b') = runBufferFull w b f
in (a, b')
getMarks :: Window -> BufferM (Maybe WinMarks)
getMarks = gets . getMarksRaw
getMarksRaw :: Window -> FBuffer -> Maybe WinMarks
getMarksRaw w b = M.lookup (wkey w) (b ^. winMarksA)
runBufferFull :: Window -> FBuffer -> BufferM a -> (a, [Update], FBuffer)
runBufferFull w b f =
let (a, b', updates) = runRWS (fromBufferM f') w b
f' = do
ms <- getMarks w
when (isNothing ms) $ do
-- this window has no marks for this buffer yet; have to create them.
newMarkValues <- if wkey (b ^. lastActiveWindowA) == def
then return
-- no previous window, create some marks from scratch.
MarkSet { insMark = MarkValue 0 Forward,
selMark = MarkValue 0 Backward, -- sel
fromMark = MarkValue 0 Backward } -- from
else do
Just mrks <- uses winMarksA (M.lookup $ wkey (b ^. lastActiveWindowA))
forM mrks getMarkValueB
newMrks <- forM newMarkValues newMarkB
winMarksA %= M.insert (wkey w) newMrks
lastActiveWindowA .= w
f
in (a, updates, pendingUpdatesA %~ (++ fmap TextUpdate updates) $ b')
getMarkValueRaw :: Mark -> FBuffer -> MarkValue
getMarkValueRaw m = fromMaybe (MarkValue 0 Forward) . queryRawbuf (getMarkValueBI m)
getMarkValueB :: Mark -> BufferM MarkValue
getMarkValueB = gets . getMarkValueRaw
newMarkB :: MarkValue -> BufferM Mark
newMarkB v = queryAndModify $ newMarkBI v
deleteMarkB :: Mark -> BufferM ()
deleteMarkB m = modifyBuffer $ deleteMarkValueBI m
-- | Execute a @BufferM@ value on a given buffer, using a dummy window. The new state of
-- the buffer is discarded.
runBufferDummyWindow :: FBuffer -> BufferM a -> a
runBufferDummyWindow b = fst . runBuffer (dummyWindow $ bkey b) b
-- | Mark the current point in the undo list as a saved state.
markSavedB :: UTCTime -> BufferM ()
markSavedB t = do undosA %= setSavedFilePointU
lastSyncTimeA .= t
bkey :: FBuffer -> BufferRef
bkey = view bkey__A
isUnchangedBuffer :: FBuffer -> Bool
isUnchangedBuffer = isAtSavedFilePointU . view undosA
startUpdateTransactionB :: BufferM ()
startUpdateTransactionB = do
transactionPresent <- use updateTransactionInFlightA
if transactionPresent
then error "Already started update transaction"
else do
undosA %= addChangeU InteractivePoint
updateTransactionInFlightA .= True
commitUpdateTransactionB :: BufferM ()
commitUpdateTransactionB = do
transactionPresent <- use updateTransactionInFlightA
if not transactionPresent
then error "Not in update transaction"
else do
updateTransactionInFlightA .= False
transacAccum <- use updateTransactionAccumA
updateTransactionAccumA .= []
undosA %= (appEndo . mconcat) (Endo . addChangeU . AtomicChange <$> transacAccum)
undosA %= addChangeU InteractivePoint
undoRedo :: (forall syntax. Mark -> URList -> BufferImpl syntax
-> (BufferImpl syntax, (URList, [Update])))
-> BufferM ()
undoRedo f = do
isTransacPresent <- use updateTransactionInFlightA
if isTransacPresent
then error "Can't undo while undo transaction is in progress"
else do
m <- getInsMark
ur <- use undosA
(ur', updates) <- queryAndModify (f m ur)
undosA .= ur'
tell updates
undoB :: BufferM ()
undoB = undoRedo undoU
redoB :: BufferM ()
redoB = undoRedo redoU
-- | Undo all updates that happened since last save,
-- perform a given action and redo all updates again.
-- Given action must not modify undo history.
retroactivelyAtSavePointB :: BufferM a -> BufferM a
retroactivelyAtSavePointB action = do
(undoDepth, result) <- go 0
replicateM_ undoDepth redoB
return result
where
go step = do
atSavedPoint <- gets isUnchangedBuffer
if atSavedPoint
then (step,) <$> action
else undoB >> go (step + 1)
-- | Analogous to const, but returns a function that takes two parameters,
-- rather than one.
const2 :: t -> t1 -> t2 -> t
const2 x _ _ = x
-- | Mode applies function that always returns True.
modeAlwaysApplies :: a -> b -> Bool
modeAlwaysApplies = const2 True
-- | Mode applies function that always returns False.
modeNeverApplies :: a -> b -> Bool
modeNeverApplies = const2 False
emptyMode :: Mode syntax
emptyMode = Mode
{
modeName = "empty",
modeApplies = modeNeverApplies,
modeHL = ExtHL noHighlighter,
modePrettify = const $ return (),
modeKeymap = id,
modeIndent = \_ _ -> return (),
modeAdjustBlock = \_ _ -> return (),
modeFollow = const emptyAction,
modeIndentSettings = IndentSettings
{ expandTabs = True
, tabSize = 8
, shiftWidth = 4
},
modeToggleCommentSelection = Nothing,
modeGetStrokes = \_ _ _ _ -> [],
modeOnLoad = return (),
modeGotoDeclaration = return (),
modeModeLine = defaultModeLine
}
-- | Create buffer named @nm@ with contents @s@
newB :: BufferRef -> BufferId -> YiString -> FBuffer
newB unique nm s =
FBuffer { bmode = emptyMode
, rawbuf = newBI s
, attributes =
Attributes { ident = nm
, bkey__ = unique
, undos = emptyU
, preferCol = Nothing
, preferVisCol = Nothing
, stickyEol = False
, bufferDynamic = mempty
, pendingUpdates = []
, selectionStyle = SelectionStyle False False
, keymapProcess = I.End
, winMarks = M.empty
, lastActiveWindow = dummyWindow unique
, lastSyncTime = epoch
, readOnly = False
, directoryContent = False
, inserting = True
, pointFollowsWindow = const False
, updateTransactionInFlight = False
, updateTransactionAccum = []
, fontsizeVariation = 0
, encodingConverterName = Nothing
} }
epoch :: UTCTime
epoch = UTCTime (toEnum 0) (toEnum 0)
-- | Point of eof
sizeB :: BufferM Point
sizeB = queryBuffer sizeBI
-- | Extract the current point
pointB :: BufferM Point
pointB = use . markPointA =<< getInsMark
nelemsB :: Int -> Point -> BufferM YiString
nelemsB n i = R.take n <$> streamB Forward i
streamB :: Direction -> Point -> BufferM YiString
streamB dir i = queryBuffer $ getStream dir i
indexedStreamB :: Direction -> Point -> BufferM [(Point,Char)]
indexedStreamB dir i = queryBuffer $ getIndexedStream dir i
strokesRangesB :: Maybe SearchExp -> Region -> BufferM [[Stroke]]
strokesRangesB regex r = do
p <- pointB
getStrokes <- withSyntaxB modeGetStrokes
queryBuffer $ strokesRangesBI getStrokes regex r p
------------------------------------------------------------------------
-- Point based operations
-- | Move point in buffer to the given index
moveTo :: Point -> BufferM ()
moveTo x = do
forgetPreferCol
maxP <- sizeB
let p = case () of
_ | x < 0 -> Point 0
| x > maxP -> maxP
| otherwise -> x
(.= p) . markPointA =<< getInsMark
------------------------------------------------------------------------
setInserting :: Bool -> BufferM ()
setInserting = (insertingA .=)
checkRO :: BufferM Bool
checkRO = do
ro <- use readOnlyA
when ro (fail "Read Only Buffer")
return ro
applyUpdate :: Update -> BufferM ()
applyUpdate update = do
ro <- checkRO
valid <- queryBuffer (isValidUpdate update)
when (not ro && valid) $ do
forgetPreferCol
let reversed = reverseUpdateI update
modifyBuffer (applyUpdateI update)
isTransacPresent <- use updateTransactionInFlightA
if isTransacPresent
then updateTransactionAccumA %= (reversed:)
else undosA %= addChangeU (AtomicChange reversed)
tell [update]
-- otherwise, just ignore.
-- | Revert all the pending updates; don't touch the point.
revertPendingUpdatesB :: BufferM ()
revertPendingUpdatesB = do
updates <- use pendingUpdatesA
modifyBuffer (flip (foldr (\u bi -> applyUpdateI (reverseUpdateI u) bi)) [u | TextUpdate u <- updates])
-- | Write an element into the buffer at the current point.
writeB :: Char -> BufferM ()
writeB c = do
deleteN 1
insertB c
-- | Write the list into the buffer at current point.
writeN :: YiString -> BufferM ()
writeN cs = do
off <- pointB
deleteNAt Forward (R.length cs) off
insertNAt cs off
-- | Insert newline at current point.
newlineB :: BufferM ()
newlineB = insertB '\n'
------------------------------------------------------------------------
-- | Insert given 'YiString' at specified point, extending size of the
-- buffer.
insertNAt :: YiString -> Point -> BufferM ()
insertNAt rope pnt = applyUpdate (Insert pnt Forward rope)
-- | Insert the 'YiString' at current point, extending size of buffer
insertN :: YiString -> BufferM ()
insertN cs = pointB >>= insertNAt cs
-- | Insert the char at current point, extending size of buffer
--
-- Implementation note: This just 'insertB's a 'R.singleton'. This
-- seems sub-optimal because we should be able to do much better
-- without spewing chunks of size 1 everywhere. This approach is
-- necessary however so an 'Update' can be recorded. A possible
-- improvement for space would be to have ‘yi-rope’ package optimise
-- for appends with length 1.
insertB :: Char -> BufferM ()
insertB = insertN . R.singleton
------------------------------------------------------------------------
-- | @deleteNAt n p@ deletes @n@ characters forwards from position @p@
deleteNAt :: Direction -> Int -> Point -> BufferM ()
deleteNAt _ 0 _ = return ()
deleteNAt dir n pos = do
els <- R.take n <$> streamB Forward pos
applyUpdate $ Delete pos dir els
------------------------------------------------------------------------
-- Line based editing
-- | Return the current line number
curLn :: BufferM Int
curLn = do
p <- pointB
queryBuffer (lineAt p)
-- | Top line of the screen
screenTopLn :: BufferM Int
screenTopLn = do
p <- use . markPointA =<< fromMark <$> askMarks
queryBuffer (lineAt p)
-- | Middle line of the screen
screenMidLn :: BufferM Int
screenMidLn = (+) <$> screenTopLn <*> (div <$> screenLines <*> pure 2)
-- | Bottom line of the screen
screenBotLn :: BufferM Int
screenBotLn = (+) <$> screenTopLn <*> screenLines
-- | Amount of lines in the screen
screenLines :: BufferM Int
screenLines = pred <$> askWindow actualLines
-- | Return line numbers of marks
markLines :: BufferM (MarkSet Int)
markLines = mapM getLn =<< askMarks
where getLn m = use (markPointA m) >>= lineOf
-- | Go to line number @n@. @n@ is indexed from 1. Returns the
-- actual line we went to (which may be not be the requested line,
-- if it was out of range)
gotoLn :: Int -> BufferM Int
gotoLn x = do
moveTo 0
succ <$> gotoLnFrom (x - 1)
---------------------------------------------------------------------
setMode0 :: forall syntax. Mode syntax -> FBuffer -> FBuffer
setMode0 m (FBuffer _ rb at) = FBuffer m (setSyntaxBI (modeHL m) rb) at
modifyMode0 :: (forall syntax. Mode syntax -> Mode syntax) -> FBuffer -> FBuffer
modifyMode0 f (FBuffer m rb f3) = FBuffer m' (setSyntaxBI (modeHL m') rb) f3
where m' = f m
-- | Set the mode
setAnyMode :: AnyMode -> BufferM ()
setAnyMode (AnyMode m) = setMode m
setMode :: Mode syntax -> BufferM ()
setMode m = do
modify (setMode0 m)
-- reset the keymap process so we use the one of the new mode.
keymapProcessA .= I.End
modeOnLoad m
-- | Modify the mode
modifyMode :: (forall syntax. Mode syntax -> Mode syntax) -> BufferM ()
modifyMode f = do
modify (modifyMode0 f)
-- reset the keymap process so we use the one of the new mode.
keymapProcessA .= I.End
onMode :: (forall syntax. Mode syntax -> Mode syntax) -> AnyMode -> AnyMode
onMode f (AnyMode m) = AnyMode (f m)
withMode0 :: (forall syntax. Mode syntax -> a) -> FBuffer -> a
withMode0 f FBuffer {bmode = m} = f m
withModeB :: (forall syntax. Mode syntax -> BufferM a) -> BufferM a
withModeB = join . gets . withMode0
withSyntax0 :: (forall syntax. Mode syntax -> syntax -> a) -> WindowRef -> FBuffer -> a
withSyntax0 f wk (FBuffer bm rb _attrs) = f bm (getAst wk rb)
withSyntaxB :: (forall syntax. Mode syntax -> syntax -> a) -> BufferM a
withSyntaxB f = withSyntax0 f <$> askWindow wkey <*> use id
focusSyntax :: M.Map WindowRef Region -> FBuffer -> FBuffer
focusSyntax r = modifyRawbuf (focusAst r)
withSyntaxB' :: (forall syntax. Mode syntax -> syntax -> BufferM a) -> BufferM a
withSyntaxB' = join . withSyntaxB
-- | Return indices of strings in buffer matched by regex in the
-- given region.
regexRegionB :: SearchExp -> Region -> BufferM [Region]
regexRegionB regex region = queryBuffer $ regexRegionBI regex region
-- | Return indices of next string in buffer matched by regex in the
-- given direction
regexB :: Direction -> SearchExp -> BufferM [Region]
regexB dir rx = do
p <- pointB
s <- sizeB
regexRegionB rx (mkRegion p (case dir of Forward -> s; Backward -> 0))
---------------------------------------------------------------------
modifyMarkRaw :: Mark -> (MarkValue -> MarkValue) -> FBuffer -> FBuffer
modifyMarkRaw m f = modifyRawbuf $ modifyMarkBI m f
modifyMarkB :: Mark -> (MarkValue -> MarkValue) -> BufferM ()
modifyMarkB = (modify .) . modifyMarkRaw
setMarkHereB :: BufferM Mark
setMarkHereB = getMarkB Nothing
setNamedMarkHereB :: String -> BufferM ()
setNamedMarkHereB name = do
p <- pointB
getMarkB (Just name) >>= (.= p) . markPointA
-- | Highlight the selection
setVisibleSelection :: Bool -> BufferM ()
setVisibleSelection = (highlightSelectionA .=)
-- | Whether the selection is highlighted
getVisibleSelection :: BufferM Bool
getVisibleSelection = use highlightSelectionA
getInsMark :: BufferM Mark
getInsMark = insMark <$> askMarks
askMarks :: BufferM WinMarks
askMarks = do
Just ms <- getMarks =<< ask
return ms
getMarkB :: Maybe String -> BufferM Mark
getMarkB m = do
p <- pointB
queryAndModify (getMarkDefaultPosBI m p)
mayGetMarkB :: String -> BufferM (Maybe Mark)
mayGetMarkB m = queryBuffer (getMarkBI m)
-- | Move point by the given number of characters.
-- A negative offset moves backwards a positive one forward.
moveN :: Int -> BufferM ()
moveN n = do
s <- sizeB
moveTo =<< min s . max 0 . (+~ Size n) <$> pointB
-- | Move point -1
leftB :: BufferM ()
leftB = leftN 1
-- | Move cursor -n
leftN :: Int -> BufferM ()
leftN n = moveN (-n)
-- | Move cursor +1
rightB :: BufferM ()
rightB = rightN 1
-- | Move cursor +n
rightN :: Int -> BufferM ()
rightN = moveN
-- ---------------------------------------------------------------------
-- Line based movement and friends
-- | Move point down by @n@ lines. @n@ can be negative.
-- Returns the actual difference in lines which we moved which
-- may be negative if the requested line difference is negative.
lineMoveRel :: Int -> BufferM Int
lineMoveRel = movingToPrefCol . gotoLnFrom
movingToPrefCol :: BufferM a -> BufferM a
movingToPrefCol f = do
prefCol <- use preferColA
targetCol <- maybe curCol return prefCol
r <- f
moveToColB targetCol
preferColA .= Just targetCol
return r
-- | Moves to a visual column within the current line as shown
-- on the editor (ie, moving within the current width of a
-- single visual line)
movingToPrefVisCol :: BufferM a -> BufferM a
movingToPrefVisCol f = do
prefCol <- use preferVisColA
targetCol <- maybe curVisCol return prefCol
r <- f
moveToVisColB targetCol
preferVisColA .= Just targetCol
return r
moveToColB :: Int -> BufferM ()
moveToColB targetCol = do
solPnt <- solPointB =<< pointB
chrs <- R.toString <$> nelemsB targetCol solPnt
is <- indentSettingsB
let cols = scanl (colMove is) 0 chrs -- columns corresponding to the char
toSkip = takeWhile (\(char,col) -> char /= '\n' && col < targetCol) (zip chrs cols)
moveTo $ solPnt +~ fromIntegral (length toSkip)
moveToVisColB :: Int -> BufferM ()
moveToVisColB targetCol = do
col <- curCol
wid <- width <$> use lastActiveWindowA
let jumps = col `div` wid
moveToColB $ jumps * wid + targetCol
moveToLineColB :: Int -> Int -> BufferM ()
moveToLineColB line col = gotoLn line >> moveToColB col
pointOfLineColB :: Int -> Int -> BufferM Point
pointOfLineColB line col = savingPointB $ moveToLineColB line col >> pointB
forgetPreferCol :: BufferM ()
forgetPreferCol = preferColA .= Nothing >> preferVisColA .= Nothing
savingPrefCol :: BufferM a -> BufferM a
savingPrefCol f = do
pc <- use preferColA
pv <- use preferVisColA
result <- f
preferColA .= pc
preferVisColA .= pv
return result
-- | Move point up one line
lineUp :: BufferM ()
lineUp = void (lineMoveRel (-1))
-- | Move point down one line
lineDown :: BufferM ()
lineDown = void (lineMoveRel 1)
-- | Return the contents of the buffer.
elemsB :: BufferM YiString
elemsB = queryBuffer mem
-- | Returns the contents of the buffer between the two points.
--
-- If the @startPoint >= endPoint@, empty string is returned. If the
-- points are out of bounds, as much of the content as possible is
-- taken: you're not guaranteed to get @endPoint - startPoint@
-- characters.
betweenB :: Point -- ^ Point to start at
-> Point -- ^ Point to stop at
-> BufferM YiString
betweenB (Point s) (Point e) =
if s >= e
then return (mempty :: YiString)
else snd . R.splitAt s . fst . R.splitAt e <$> elemsB
-- | Read the character at the current point
readB :: BufferM Char
readB = pointB >>= readAtB
-- | Read the character at the given index
-- This is an unsafe operation: character NUL is returned when out of bounds
readAtB :: Point -> BufferM Char
readAtB i = R.head <$> nelemsB 1 i >>= return . \case
Nothing -> '\0'
Just c -> c
replaceCharB :: Char -> BufferM ()
replaceCharB c = do
writeB c
leftB
replaceCharWithBelowB :: BufferM ()
replaceCharWithBelowB = replaceCharWithVerticalOffset 1
replaceCharWithAboveB :: BufferM ()
replaceCharWithAboveB = replaceCharWithVerticalOffset (-1)
insertCharWithBelowB :: BufferM ()
insertCharWithBelowB = maybe (return ()) insertB =<< maybeCharBelowB
insertCharWithAboveB :: BufferM ()
insertCharWithAboveB = maybe (return ()) insertB =<< maybeCharAboveB
replaceCharWithVerticalOffset :: Int -> BufferM ()
replaceCharWithVerticalOffset offset =
maybe (return ()) replaceCharB =<< maybeCharWithVerticalOffset offset
maybeCharBelowB :: BufferM (Maybe Char)
maybeCharBelowB = maybeCharWithVerticalOffset 1
maybeCharAboveB :: BufferM (Maybe Char)
maybeCharAboveB = maybeCharWithVerticalOffset (-1)
maybeCharWithVerticalOffset :: Int -> BufferM (Maybe Char)
maybeCharWithVerticalOffset offset = savingPointB $ do
l0 <- curLn
c0 <- curCol
void $ lineMoveRel offset
l1 <- curLn
c1 <- curCol
curChar <- readB
return $ if c0 == c1
&& l0 + offset == l1
&& curChar `notElem` ("\n\0" :: String)
then Just curChar
else Nothing
-- | Delete @n@ characters forward from the current point
deleteN :: Int -> BufferM ()
deleteN n = pointB >>= deleteNAt Forward n
------------------------------------------------------------------------
-- | Gives the 'IndentSettings' for the current buffer.
indentSettingsB :: BufferM IndentSettings
indentSettingsB = withModeB $ return . modeIndentSettings
-- | Current column.
-- Note that this is different from offset or number of chars from sol.
-- (This takes into account tabs, unicode chars, etc.)
curCol :: BufferM Int
curCol = colOf =<< pointB
-- | Current column, visually.
curVisCol :: BufferM Int
curVisCol = rem <$> curCol <*> (width <$> use lastActiveWindowA)
colOf :: Point -> BufferM Int
colOf p = do
is <- indentSettingsB
R.foldl' (colMove is) 0 <$> queryBuffer (charsFromSolBI p)
lineOf :: Point -> BufferM Int
lineOf p = queryBuffer $ lineAt p
lineCountB :: BufferM Int
lineCountB = lineOf =<< sizeB
-- | Decides which column we should be on after the given character.
colMove :: IndentSettings -> Int -> Char -> Int
colMove is col '\t' | tabSize is > 1 = col + tabSize is
colMove _ col _ = col + 1
-- | Returns start of line point for a given point @p@
solPointB :: Point -> BufferM Point
solPointB p = queryBuffer $ solPoint' p
-- | Returns end of line for given point.
eolPointB :: Point -> BufferM Point
eolPointB p = queryBuffer $ eolPoint' p
-- | Go to line indexed from current point
-- Returns the actual moved difference which of course
-- may be negative if the requested difference was negative.
gotoLnFrom :: Int -> BufferM Int
gotoLnFrom x = do
l <- curLn
p' <- queryBuffer $ solPoint (l + x)
moveTo p'
l' <- curLn
return (l' - l)
-- | Access to a value into the extensible state, keyed by its type.
-- This allows you to retrieve inside a 'BufferM' monad, ie:
--
-- > value <- getBufferDyn
getBufferDyn :: forall m a. (Default a, YiVariable a, MonadState FBuffer m, Functor m) => m a
getBufferDyn = fromMaybe (def :: a) <$> getDyn (use bufferDynamicA) (bufferDynamicA .=)
-- | Access to a value into the extensible state, keyed by its type.
-- This allows you to save inside a 'BufferM' monad, ie:
--
-- > putBufferDyn updatedvalue
putBufferDyn :: (YiVariable a, MonadState FBuffer m, Functor m) => a -> m ()
putBufferDyn = putDyn (use bufferDynamicA) (bufferDynamicA .=)
-- | perform a @BufferM a@, and return to the current point. (by using a mark)
savingExcursionB :: BufferM a -> BufferM a
savingExcursionB f = do
m <- getMarkB Nothing
res <- f
moveTo =<< use (markPointA m)
return res
markPointA :: Mark -> Lens' FBuffer Point
markPointA mark = lens getter setter where
getter b = markPoint $ getMarkValueRaw mark b
setter b pos = modifyMarkRaw mark (\v -> v {markPoint = pos}) b
-- | Perform an @BufferM a@, and return to the current point.
savingPointB :: BufferM a -> BufferM a
savingPointB f = savingPrefCol $ do
p <- pointB
res <- f
moveTo p
return res
-- | Perform an @BufferM a@, and return to the current line and column
-- number. The difference between this and 'savingPointB' is that here
-- we attempt to return to the specific line and column number, rather
-- than a specific number of characters from the beginning of the
-- buffer.
--
-- In case the column is further away than EOL, the point is left at
-- EOL: 'moveToLineColB' is used internally.
savingPositionB :: BufferM a -> BufferM a
savingPositionB f = savingPrefCol $ do
(c, l) <- (,) <$> curCol <*> curLn
res <- f
moveToLineColB l c
return res
pointAt :: BufferM a -> BufferM Point
pointAt f = savingPointB (f *> pointB)
pointAfterCursorB :: Point -> BufferM Point
pointAfterCursorB p = pointAt $ do
moveTo p
rightB
-- | What would be the point after doing the given action?
-- The argument must not modify the buffer.
destinationOfMoveB :: BufferM a -> BufferM Point
destinationOfMoveB f = savingPointB (f >> pointB)
-------------
-- Window
askWindow :: (Window -> a) -> BufferM a
askWindow = asks
withEveryLineB :: BufferM () -> BufferM ()
withEveryLineB action = savingPointB $ do
lineCount <- lineCountB
forM_ [1 .. lineCount] $ \l -> do
void $ gotoLn l
action
makeLensesWithSuffix "A" ''IndentSettings
makeLensesWithSuffix "A" ''Mode