{-# LANGUAGE PatternGuards, ExistentialQuantification, DeriveDataTypeable, Rank2Types, FlexibleContexts, FlexibleInstances #-} -- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons -- Copyright (c) 2007-8 JP Bernardy -- | 'Buffer' implementation, wrapping ByteRope module Yi.Buffer.Implementation ( UIUpdate (..) , Update (..) , updateIsDelete , Point , Mark, MarkValue(..) , dummyFromMark , dummyToMark , staticInsMark , staticSelMark , Size , Direction (..) , BufferImpl , Overlay, OvlLayer (..) , mkOverlay , overlayUpdate , moveToI , applyUpdateI , isValidUpdate , applyUpdateWithMoveI , reverseUpdateI , pointBI , nelemsBI , nelemsBI' , sizeBI , curLnI , newBI , gotoLnRelI -- , offsetFromSolBI , charsFromSolBI , searchBI , regexRegionBI , getMarkBI , modifyMarkBI , getMarkValueBI , newMarkBI , setSyntaxBI , addOverlayBI , delOverlayBI , delOverlayLayer , inBounds , findNextChar , updateSyntax , getAst , strokesRangesBI , toIndexedString , getStream , getIndexedStream , newLine , SearchExp ) where import Yi.Prelude import Prelude (take, takeWhile, dropWhile, map, length, reverse) import Yi.Syntax import qualified Data.Map as M import Data.Binary import Data.Maybe import Data.Monoid import Yi.Style import Control.Monad import Yi.Regex import qualified Data.ByteRope as F import Data.ByteRope (ByteRope) import qualified Data.ByteString.Lazy as LazyB import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8 import qualified Codec.Binary.UTF8.Generic as UF8Codec import Yi.Buffer.Basic import Data.Array import Data.Char import Data.Maybe import Data.List (groupBy, drop) import Data.Word import qualified Data.Set as Set import Data.Typeable import Yi.Region data MarkValue = MarkValue {markPoint :: !Point, markGravity :: !Direction} deriving (Ord, Eq, Show, Typeable {-! Binary !-}) type Marks = M.Map Mark MarkValue data HLState syntax = forall cache. HLState !(Highlighter cache syntax) !cache data OvlLayer = UserLayer | HintLayer deriving (Ord, Eq) data Overlay = Overlay { overlayLayer :: OvlLayer, overlayBegin :: MarkValue, overlayEnd :: MarkValue, overlayStyle :: StyleName } instance Eq Overlay where Overlay a b c _ == Overlay a' b' c' _ = a == a' && b == b' && c == c' instance Ord Overlay where compare (Overlay a b c _) (Overlay a' b' c' _) = compare a a' `mappend` compare b b' `mappend` compare c c' data BufferImpl syntax = FBufferData { mem :: !ByteRope -- ^ buffer text , marks :: !Marks -- ^ Marks for this buffer , markNames :: !(M.Map String Mark) , hlCache :: !(HLState syntax) -- ^ syntax highlighting state , overlays :: !(Set.Set Overlay) -- ^ set of (non overlapping) visual overlay regions , dirtyOffset :: !Point -- ^ Lowest modified offset since last recomputation of syntax } deriving Typeable -- Atm we can't store overlays because stylenames are functions (can't be serialized) -- TODO: ideally I'd like to get rid of overlays entirely; although we could imagine them storing mere styles. instance Binary (BufferImpl ()) where put b = put (mem b) >> put (marks b) >> put (markNames b) get = pure FBufferData <*> get <*> get <*> get <*> pure dummyHlState <*> pure Set.empty <*> pure 0 -- | Mutation actions (also used the undo or redo list) -- -- For the undo/redo, we use the /partial checkpoint/ (Berlage, pg16) strategy to store -- just the components of the state that change. -- -- Note that the update direction is only a hint for moving the cursor -- (mainly for undo purposes); the insertions and deletions are always -- applied Forward. data Update = Insert {updatePoint :: !Point, updateDirection :: !Direction, insertUpdateString :: !LazyB.ByteString} | Delete {updatePoint :: !Point, updateDirection :: !Direction, deleteUpdateString :: !LazyB.ByteString} -- Note that keeping the text does not cost much: we keep the updates in the undo list; -- if it's a "Delete" it means we have just inserted the text in the buffer, so the update shares -- the data with the buffer. If it's an "Insert" we have to keep the data any way. deriving (Show, Typeable {-! Binary !-}) updateIsDelete :: Update -> Bool updateIsDelete Delete {} = True updateIsDelete Insert {} = False updateString :: Update -> LazyUTF8.ByteString updateString (Insert _ _ s) = s updateString (Delete _ _ s) = s updateSize :: Update -> Size updateSize = Size . fromIntegral . LazyB.length . updateString data UIUpdate = TextUpdate !Update | StyleUpdate !Point !Size deriving ({-! Binary !-}) -------------------------------------------------- -- Low-level primitives. dummyHlState = (HLState noHighlighter (hlStartState noHighlighter)) -- | New FBuffer filled from string. newBI :: LazyB.ByteString -> BufferImpl () newBI s = FBufferData (F.fromLazyByteString s) mks M.empty dummyHlState Set.empty 0 where mks = M.fromList [ (staticInsMark, MarkValue 0 insertGravity) , (staticSelMark, MarkValue 0 selectionGravity) , (dummyFromMark, MarkValue 0 Backward) , (dummyToMark, MarkValue 0 Forward) ] -- | read @n@ chars from buffer @b@, starting at @i@ readChars :: ByteRope -> Int -> Point -> String readChars p n (Point i) = take n $ LazyUTF8.toString $ F.toLazyByteString $ F.drop i $ p {-# INLINE readChars #-} -- | read @n@ bytes from buffer @b@, starting at @i@ readChunk :: ByteRope -> Size -> Point -> ByteRope readChunk p (Size n) (Point i) = F.take n $ F.drop i $ p -- | Write string into buffer. insertChars :: ByteRope -> ByteRope -> Point -> ByteRope insertChars p cs (Point i) = left `F.append` cs `F.append` right where (left,right) = F.splitAt i p {-# INLINE insertChars #-} -- | Write string into buffer. deleteChars :: ByteRope -> Point -> Size -> ByteRope deleteChars p (Point i) (Size n) = left `F.append` right where (left,rest) = F.splitAt i p right = F.drop n rest {-# INLINE deleteChars #-} -- | calculate whether a move is in bounds. -- Note that one can move to 1 char past the end of the buffer. inBounds :: Point -> Point -> Point inBounds i end | i <= 0 = 0 | i > end = max 0 end | otherwise = i {-# INLINE inBounds #-} ------------------------------------------------------------------------ -- Mid-level insert/delete -- | Shift a mark position, supposing an update at a given point, by a given amount. -- Negative amount represent deletions. shiftMarkValue :: Point -> Size -> MarkValue -> MarkValue shiftMarkValue from by (MarkValue p gravity) = MarkValue shifted gravity where shifted | p < from = p | p == from = case gravity of Backward -> p Forward -> p' | otherwise {- p > from -} = p' where p' = max from (p +~ by) mapOvlMarks :: (MarkValue -> MarkValue) -> Overlay -> Overlay mapOvlMarks f (Overlay l s e v) = Overlay l (f s) (f e) v ------------------------------------- -- * "high-level" (exported) operations -- | Point of EOF sizeBI :: BufferImpl syntax -> Point sizeBI fb = Point $ F.length $ mem fb -- | Extract the current point pointBI :: BufferImpl syntax -> Point pointBI fb = markPoint ((marks fb) M.! staticInsMark) {-# INLINE pointBI #-} -- | Return @n@ Chars starting at @i@ of the buffer as a list nelemsBI :: Int -> Point -> BufferImpl syntax -> String nelemsBI n i fb = readChars (mem fb) n i nelemsBI' :: Size -> Point -> BufferImpl syntax -> String nelemsBI' n i fb = LazyUTF8.toString $ F.toLazyByteString $ readChunk (mem fb) n i getStream :: Direction -> Point -> BufferImpl syntax -> LazyUTF8.ByteString getStream Forward (Point i) fb = F.toLazyByteString $ F.drop i $ mem $ fb getStream Backward (Point i) fb = F.toReverseLazyByteString $ F.take i $ mem $ fb getIndexedStream :: Direction -> Point -> BufferImpl syntax -> [(Point,Char)] getIndexedStream Forward (Point i) fb = toIndexedString Forward (Point i) $ F.toLazyByteString $ F.drop i $ mem $ fb getIndexedStream Backward (Point i) fb = toIndexedString Backward (Point i) $ F.toReverseLazyByteString $ F.take i $ mem $ fb -- | Create an "overlay" for the style @sty@ between points @s@ and @e@ mkOverlay :: OvlLayer -> Region -> StyleName -> Overlay mkOverlay l r s = Overlay l (MarkValue (regionStart r) Backward) (MarkValue (regionEnd r) Forward) s -- | Obtain a style-update for a specific overlay overlayUpdate :: Overlay -> UIUpdate overlayUpdate (Overlay _l (MarkValue s _) (MarkValue e _) _) = StyleUpdate s (e ~- s) -- | Add a style "overlay" between the given points. addOverlayBI :: Overlay -> BufferImpl syntax -> BufferImpl syntax addOverlayBI ov fb = fb{overlays = Set.insert ov (overlays fb)} -- | Remove a previously added "overlay" delOverlayBI :: Overlay -> BufferImpl syntax -> BufferImpl syntax delOverlayBI ov fb = fb{overlays = Set.delete ov (overlays fb)} delOverlayLayer :: OvlLayer -> BufferImpl syntax -> BufferImpl syntax delOverlayLayer layer fb = fb{overlays = Set.filter ((/= layer) . overlayLayer) (overlays fb)} -- FIXME: this can be really inefficient. -- | Return style information for the range @(i,j)@ Style information -- is derived from syntax highlighting, active overlays and current regexp. The -- returned list contains tuples @(l,s,r)@ where every tuple is to -- be interpreted as apply the style @s@ from position @l@ to @r@ in -- the buffer. In each list, the strokes are guaranteed to be -- ordered and non-overlapping. The lists of strokes are ordered by -- decreasing priority: the 1st layer should be "painted" on top. strokesRangesBI :: Maybe SearchExp -> Region -> BufferImpl syntax -> [[Stroke]] strokesRangesBI regex rgn fb@(FBufferData {hlCache = HLState hl cache}) = result where i = regionStart rgn j = regionEnd rgn dropBefore = dropWhile (\(_l,_s,r) -> r <= i) takeIn = takeWhile (\(l,_s,_r) -> l <= j) groundLayer = [(i,mempty,j)] syntaxHlLayer = hlGetStrokes hl point i j $ hlGetTree hl cache layers2 = map (map overlayStroke) $ groupBy ((==) `on` overlayLayer) $ Set.toList $ overlays fb layer3 = case regex of Just re -> takeIn $ map hintStroke $ regexRegionBI re (mkRegion i j) fb Nothing -> [] result = map (map clampStroke . takeIn . dropBefore) (layer3 : layers2 ++ [syntaxHlLayer, groundLayer]) overlayStroke (Overlay _ sm em a) = (markPoint sm, a, markPoint em) point = pointBI fb clampStroke (l,x,r) = (max i l, x, min j r) hintStroke r = (regionStart r,if point `nearRegion` r then strongHintStyle else hintStyle,regionEnd r) ------------------------------------------------------------------------ -- Point based editing -- | Move point in buffer to the given index moveToI :: Point -> BufferImpl syntax -> BufferImpl syntax moveToI i fb = fb {marks = M.insert staticInsMark (MarkValue (inBounds i (Point end)) insertGravity) $ marks fb} where end = F.length (mem fb) {-# INLINE moveToI #-} findNextChar :: Int -> Point -> BufferImpl syntax -> Point findNextChar m p fb | m < 0 = case drop (0 - 1 - m) (getIndexedStream Backward p fb) of [] -> 0 (i,_):_ -> i | otherwise = case drop m (getIndexedStream Forward p fb) of [] -> sizeBI fb (i,_):_ -> i -- | Checks if an Update is valid isValidUpdate :: Update -> BufferImpl syntax -> Bool isValidUpdate u b = case u of (Delete p _ _) -> check p && check (p +~ updateSize u) (Insert p _ _) -> check p where check (Point x) = x >= 0 && x <= F.length (mem b) -- | Apply a /valid/ update applyUpdateI :: Update -> BufferImpl syntax -> BufferImpl syntax applyUpdateI u fb = touchSyntax (updatePoint u) $ fb {mem = p', marks = M.map shift (marks fb), overlays = Set.map (mapOvlMarks shift) (overlays fb)} -- FIXME: this is inefficient; find a way to use mapMonotonic -- (problem is that marks can have different gravities) where (p', amount) = case u of Insert pnt _ cs -> (insertChars p (F.fromLazyByteString cs) pnt, sz) Delete pnt _ _ -> (deleteChars p pnt sz, negate sz) sz = updateSize u shift = shiftMarkValue (updatePoint u) amount p = mem fb -- FIXME: remove collapsed overlays -- | Apply a /valid/ update and also move point in buffer to update position applyUpdateWithMoveI :: Update -> BufferImpl syntax -> BufferImpl syntax applyUpdateWithMoveI u = case updateDirection u of Forward -> apply . move Backward -> move . apply where move = moveToI (updatePoint u) apply = applyUpdateI u -- | Reverse the given update reverseUpdateI :: Update -> Update reverseUpdateI (Delete p dir cs) = Insert p (reverseDir dir) cs reverseUpdateI (Insert p dir cs) = Delete p (reverseDir dir) cs ------------------------------------------------------------------------ -- Line based editing ord' :: Char -> Word8 ord' = fromIntegral . ord newLine :: Word8 newLine = ord' '\n' curLnI :: BufferImpl syntax -> Int curLnI fb = 1 + F.count newLine (F.take (fromPoint $ pointBI fb) (mem fb)) -- | Go to line number @n@, relatively from this line. @0@ will go to -- the start of this line. Returns the actual line difference we went -- to (which may be not be the requested one, if it was out of range) -- Note that the line-difference returned will be negative if we are -- going backwards to previous lines (that is if @n@ was negative). gotoLnRelI :: Int -> BufferImpl syntax -> (BufferImpl syntax, Int) gotoLnRelI n fb = (moveToI (Point newPoint) fb, difference) where -- The text of the buffer s = mem fb -- The current point that we are at in the buffer. Point point = pointBI fb (difference, newPoint) -- Important that we go up if it is 0 since findDownLine -- fails for zero. | n <= 0 = findUpLine 0 n upLineStarts | otherwise = findDownLine 1 n downLineStarts -- The offsets of all line beginnings above the current point. upLineStarts = map (+1) ((F.elemIndicesEnd newLine) (F.take point s)) ++ [0] -- Go up to find the line we wish for the returned value is a pair -- consisting of the point of the start of the line to which we move -- and the difference in lines we have moved (negative here if we move at all) findUpLine :: Int -> Int -> [ Int ] -> (Int, Int) findUpLine acc _ [x] = (acc, x) findUpLine acc 0 (x:_) = (acc, x) findUpLine acc l (_:xs) = findUpLine (acc - 1) (l + 1) xs findUpLine _ _ [] = error $ "we append [0] to the end of upLineStarts" ++ " hence this cannot happen." -- The offsets of all the line beginnings below the current point -- so we drop everything before the point, find all the indices of -- the newlines from there and add the point (plus 1) to them. downLineStarts = map (+(1 + point)) ((F.elemIndices newLine) (F.drop point s)) -- Go down to find the line we wish for, the returned value is a pair -- consisting of the point of the start of the line to which we move -- and the number of lines we have actually moved. -- Note: that this doesn't work if the number of lines to move down -- is zero. findDownLine :: Int -> Int -> [ Int ] -> (Int, Int) -- try to go forward, but there is no such line -- this cannot happen on a recursive call so it can only happen if -- we started on the last line, so we return the current point. findDownLine acc _ [] = (acc, point) findDownLine acc _ [x] = (acc, x) findDownLine acc 1 (x:_) = (acc, x) findDownLine acc l (_:xs) = findDownLine (acc + 1) (l - 1) xs -- | Return index of next string in buffer that matches argument searchBI :: Direction -> String -> BufferImpl syntax -> Maybe Point searchBI dir s fb = fmap Point $ case dir of Forward -> fmap (pnt +) $ F.findSubstring (UTF8.fromString s) $ F.drop pnt ptr Backward -> listToMaybe $ reverse $ F.findSubstrings (UTF8.fromString s) $ F.take (pnt + length s) ptr -- FIXME: backward search is inefficient. where Point pnt = pointBI fb -- pnt == current point ptr = mem fb offsetToEolBI fb = Size $ case (F.elemIndices newLine) (F.drop point s) of [] -> F.length s - point (x:_) -> x where s = mem fb Point point = pointBI fb offsetFromSolBI :: BufferImpl syntax -> Size offsetFromSolBI fb = Size (pnt - maybe 0 (1 +) (F.elemIndexEnd newLine (F.take pnt ptr))) where Point pnt = pointBI fb ptr = mem fb charsFromSolBI :: BufferImpl syntax -> String charsFromSolBI fb = LazyUTF8.toString $ F.toLazyByteString $ readChunk ptr (Size (pnt - sol)) (Point sol) where sol = maybe 0 (1 +) (F.elemIndexEnd newLine (F.take pnt ptr)) Point pnt = pointBI fb ptr = mem fb -- | Return indices of all strings in buffer matching regex, inside the given region. regexRegionBI :: SearchExp -> Region -> forall syntax. BufferImpl syntax -> [Region] regexRegionBI (_,re) r fb = mayReverse (regionDirection r) $ fmap (fmapRegion addPoint . matchedRegion) $ matchAll re $ F.toLazyByteString $ F.take s $ F.drop p $ mem fb -- FIXME: lazy backward search is very inefficient with large regions. where matchedRegion arr = let (off,len) = arr!0 in mkRegion (Point off) (Point (off+len)) addPoint (Point x) = Point (p + x) Point p = regionStart r Size s = regionSize r newMarkBI :: MarkValue -> BufferImpl syntax -> (BufferImpl syntax, Mark) newMarkBI initialValue fb = let (Mark maxId, _) = M.findMax (marks fb) newMark = Mark $ maxId + 1 fb' = fb { marks = M.insert newMark initialValue (marks fb)} in (fb', newMark) getMarkValueBI :: Mark -> BufferImpl syntax -> MarkValue getMarkValueBI m (FBufferData { marks = marksMap } ) = M.findWithDefault (marksMap M.! staticInsMark) m marksMap -- We look up mark m in the marks, the default value to return -- if mark m is not set, is the staticInsMark -- | Modify a mark value. modifyMarkBI :: Mark -> (MarkValue -> MarkValue) -> (forall syntax. BufferImpl syntax -> BufferImpl syntax) modifyMarkBI m f fb = fb {marks = mapAdjust' f m (marks fb)} -- NOTE: we must insert the value strictly otherwise we can hold to whatever structure the value of the mark depends on. -- (often a whole buffer) setSyntaxBI :: ExtHL syntax -> BufferImpl oldSyntax -> BufferImpl syntax setSyntaxBI (ExtHL e) fb = touchSyntax 0 $ fb {hlCache = HLState e (hlStartState e)} touchSyntax :: Point -> BufferImpl syntax -> BufferImpl syntax touchSyntax touchedIndex fb = fb { dirtyOffset = min touchedIndex (dirtyOffset fb)} updateSyntax :: BufferImpl syntax -> BufferImpl syntax updateSyntax fb@FBufferData {dirtyOffset = touchedIndex, hlCache = HLState hl cache} | touchedIndex == maxBound = fb | otherwise = fb {dirtyOffset = maxBound, hlCache = HLState hl (hlRun hl getText touchedIndex cache) } where getText = Scanner 0 id (error "getText: no character beyond eof") (\idx -> toIndexedString Forward idx (F.toLazyByteString (F.drop (fromPoint idx) (mem fb)))) toIndexedString :: Direction -> Point -> LazyB.ByteString -> [(Point, Char)] toIndexedString dir p = (case dir of Forward -> toIndexedStringForward Backward -> toIndexedStringBackward) p . LazyB.unpack toIndexedStringForward :: Point -> [Word8] -> [(Point, Char)] toIndexedStringForward curIdx bs = case UF8Codec.decode bs of Nothing -> [] Just (c,n) -> let newIndex = curIdx + (fromIntegral n) in (curIdx,c) : (newIndex `seq` (toIndexedStringForward newIndex (drop n bs))) toIndexedStringBackward :: Point -> [Word8] -> [(Point,Char)] toIndexedStringBackward curIdx bs = case UF8Codec.decode (reverse $ decodeBack bs) of Nothing -> [] Just (c,n) -> let newIndex = curIdx - (fromIntegral n) in (newIndex,c) : (newIndex `seq` (toIndexedStringBackward newIndex (drop n bs))) decodeBack :: [Word8] -> [Word8] decodeBack [] = [] decodeBack (x:xs) | x < 128 || x > 192 = [x] -- beginning of char: take it and stop | otherwise = x : decodeBack xs -- continue insertGravity, selectionGravity :: Direction insertGravity = Forward selectionGravity = Backward ------------------------------------------------------------------------ -- | Returns the requested mark, creating a new mark with that name (at point) if needed getMarkBI :: Maybe String -> BufferImpl syntax -> (BufferImpl syntax, Mark) getMarkBI name b = getMarkDefaultPosBI name (pointBI b) b -- | Returns the requested mark, creating a new mark with that name (at the supplied position) if needed getMarkDefaultPosBI :: Maybe String -> Point -> BufferImpl syntax -> (BufferImpl syntax, Mark) getMarkDefaultPosBI name defaultPos fb@FBufferData {marks = mks, markNames = nms} = case flip M.lookup nms =<< name of Just m' -> (fb, m') Nothing -> let newMark = Mark (1 + max 1 (markId $ fst (M.findMax mks))) nms' = case name of Nothing -> nms Just nm -> M.insert nm newMark nms mks' = M.insert newMark (MarkValue defaultPos Forward) mks in (fb {marks = mks', markNames = nms'}, newMark) getAst :: BufferImpl syntax -> syntax getAst FBufferData {hlCache = HLState (SynHL {hlGetTree = gt}) cache} = gt cache -------------------------------------------------------- -- DERIVES GENERATED CODE -- DO NOT MODIFY BELOW THIS LINE -- CHECKSUM: 1150468583 instance Binary MarkValue where put (MarkValue x1 x2) = return () >> (put x1 >> put x2) get = case 0 of 0 -> ap (ap (return MarkValue) get) get instance Binary Update where put (Insert x1 x2 x3) = putWord8 0 >> (put x1 >> (put x2 >> put x3)) put (Delete x1 x2 x3) = putWord8 1 >> (put x1 >> (put x2 >> put x3)) get = getWord8 >>= (\tag_ -> case tag_ of 0 -> ap (ap (ap (return Insert) get) get) get 1 -> ap (ap (ap (return Delete) get) get) get) instance Binary UIUpdate where put (TextUpdate x1) = putWord8 0 >> put x1 put (StyleUpdate x1 x2) = putWord8 1 >> (put x1 >> put x2) get = getWord8 >>= (\tag_ -> case tag_ of 0 -> ap (return TextUpdate) get 1 -> ap (ap (return StyleUpdate) get) get)