{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# 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 , 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 , stickyEolA , queryBuffer ) where import Prelude hiding (foldr, mapM, notElem) import Control.Applicative (liftA2) import Control.Monad (when, void, replicateM_, join) import Data.Monoid import Control.Monad.Reader import Control.Monad.State.Strict hiding (get, put) 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.Strict as M (Map, empty, insert, lookup) import Data.Maybe (fromMaybe, isNothing) import qualified Data.Sequence as S 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 Lens.Micro.Platform (Lens', lens, (&), (.~), (%~), (^.), use, (.=), (%=), view) 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, uses) 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) -- 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 number of path components. -- -- >>> let memBuf = newB (BufferRef 0) (MemBuffer "foo/bar/hello") "" -- >>> shortIdentString 2 memBuf -- "*foo/bar/hello*" -- >>> let fileBuf = newB (BufferRef 0) (FileBuffer "foo/bar/hello") "" -- >>> shortIdentString 2 fileBuf -- "hello" 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': -- -- >>> let memBuf = newB (BufferRef 0) (MemBuffer "foo/bar/hello") "" -- >>> identString memBuf -- "*foo/bar/hello*" -- >>> let fileBuf = newB (BufferRef 0) (FileBuffer "foo/bar/hello") "" -- >>> identString fileBuf -- "foo/bar/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 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 [ 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 x = gets (queryRawbuf x) modifyBuffer :: (forall syntax. BufferImpl syntax -> BufferImpl syntax) -> BufferM () modifyBuffer x = modify' (modifyRawbuf x) queryAndModify :: (forall syntax. BufferImpl syntax -> (BufferImpl syntax,x)) -> BufferM x queryAndModify x = getsAndModify (queryAndModifyRawbuf x) -- | Adds an "overlay" to the buffer addOverlayB :: Overlay -> BufferM () addOverlayB ov = do pendingUpdatesA %= (S.|> 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 %= (S.|> 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, S.Seq Update, FBuffer) runBufferFull w b f = let (a, b') = runState (runReaderT (fromBufferM f') w) b updates = b' ^. updateStreamA -- We're done running BufferM, don't store updates in editor -- state. !newSt = b' & updateStreamA .~ mempty 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 %~ (S.>< fmap TextUpdate updates) $ newSt) 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 when (not transactionPresent) $ 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 .= mempty undosA %= (appEndo . foldr (<>) mempty) (Endo . addChangeU . AtomicChange <$> transacAccum) undosA %= addChangeU InteractivePoint undoRedo :: (forall syntax. Mark -> URList -> BufferImpl syntax -> (BufferImpl syntax, (URList, S.Seq 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' updateStreamA %= (<> 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 (), 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 = mempty , selectionStyle = SelectionStyle False False , keymapProcess = I.End , winMarks = M.empty , lastActiveWindow = dummyWindow unique , lastSyncTime = epoch , readOnly = False , directoryContent = False , inserting = True , pointFollowsWindow = mempty , updateTransactionInFlight = False , updateTransactionAccum = mempty , fontsizeVariation = 0 , updateStream = mempty } } 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 runp <- liftA2 (&&) (not <$> checkRO) (queryBuffer (isValidUpdate update)) when runp $ do forgetPreferCol modifyBuffer (applyUpdateI update) isTransacPresent <- use updateTransactionInFlightA if isTransacPresent then updateTransactionAccumA %= (reverseUpdateI update S.<|) else undosA %= addChangeU (AtomicChange $ reverseUpdateI update) updateStreamA %= (S.|> update) -- | Revert all the pending updates; don't touch the point. revertPendingUpdatesB :: BufferM () revertPendingUpdatesB = do updates <- use pendingUpdatesA modifyBuffer $ \stx -> let applyTextUpdate (TextUpdate u) bi = applyUpdateI (reverseUpdateI u) bi applyTextUpdate _ bi = bi in foldr applyTextUpdate stx 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 x = join (gets (withMode0 x)) 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' x = join (withSyntaxB x) -- | 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 = do preferColA .= Nothing preferVisColA .= Nothing !st <- gets id return $! (st `seq` ()) 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