module Yi.Buffer.Implementation
( UIUpdate (..)
, Update (..)
, updateIsDelete
, Point
, Mark, MarkValue(..)
, Size
, Direction (..)
, BufferImpl
, Overlay (..)
, mkOverlay
, overlayUpdate
, applyUpdateI
, isValidUpdate
, reverseUpdateI
, nelemsBI
, sizeBI
, newBI
, solPoint
, solPoint'
, eolPoint'
, charsFromSolBI
, regexRegionBI
, getMarkDefaultPosBI
, modifyMarkBI
, getMarkValueBI
, getMarkBI
, newMarkBI
, deleteMarkValueBI
, setSyntaxBI
, addOverlayBI
, delOverlayBI
, delOverlaysOfOwnerBI
, getOverlaysOfOwnerBI
, updateSyntax
, getAst, focusAst
, strokesRangesBI
, getStream
, getIndexedStream
, lineAt
, SearchExp
, markPointAA
, markGravityAA
, mem
) where
import Control.Applicative
import Data.Array
import Data.Binary
#if __GLASGOW_HASKELL__ < 708
import Data.DeriveTH
#else
import GHC.Generics (Generic)
#endif
import Data.Function
import Data.List (groupBy)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Yi.Rope (YiString)
import qualified Yi.Rope as R
import qualified Data.Set as Set
import Data.Typeable
import Yi.Buffer.Basic
import Yi.Regex
import Yi.Region
import Yi.Style
import Yi.Syntax
import Yi.Utils
data MarkValue = MarkValue { markPoint :: !Point
, markGravity :: !Direction}
deriving (Ord, Eq, Show, Typeable)
makeLensesWithSuffix "AA" ''MarkValue
#if __GLASGOW_HASKELL__ < 708
$(derive makeBinary ''MarkValue)
#else
deriving instance Generic MarkValue
instance Binary MarkValue
#endif
type Marks = M.Map Mark MarkValue
data HLState syntax = forall cache. HLState !(Highlighter cache syntax) !cache
data Overlay = Overlay
{ overlayOwner :: R.YiString
, _overlayBegin :: MarkValue
, _overlayEnd :: MarkValue
, _overlayStyle :: StyleName
, overlayAnnotation :: R.YiString
}
instance Eq Overlay where
Overlay a b c _ msg == Overlay a' b' c' _ msg' =
a == a' && b == b' && c == c' && msg == msg'
instance Ord Overlay where
compare (Overlay a b c _ msg) (Overlay a' b' c' _ msg')
= mconcat
[ compare a a'
, compare b b'
, compare c c'
, compare msg msg'
]
data BufferImpl syntax = FBufferData
{ mem :: !YiString
, marks :: !Marks
, markNames :: !(M.Map String Mark)
, hlCache :: !(HLState syntax)
, overlays :: !(Set.Set Overlay)
, dirtyOffset :: !Point
} deriving Typeable
dummyHlState :: HLState syntax
dummyHlState = HLState noHighlighter (hlStartState noHighlighter)
instance Binary (BufferImpl ()) where
put b = put (mem b) >> put (marks b) >> put (markNames b)
get = FBufferData <$> get <*> get <*> get <*> pure dummyHlState <*> pure Set.empty <*> pure 0
data Update = Insert {updatePoint :: !Point, updateDirection :: !Direction, insertUpdateString :: !YiString}
| Delete {updatePoint :: !Point, updateDirection :: !Direction, deleteUpdateString :: !YiString}
deriving (Show, Typeable)
#if __GLASGOW_HASKELL__ < 708
$(derive makeBinary ''Update)
#else
deriving instance Generic Update
instance Binary Update
#endif
updateIsDelete :: Update -> Bool
updateIsDelete Delete {} = True
updateIsDelete Insert {} = False
updateString :: Update -> YiString
updateString (Insert _ _ s) = s
updateString (Delete _ _ s) = s
updateSize :: Update -> Size
updateSize = Size . fromIntegral . R.length . updateString
data UIUpdate = TextUpdate !Update
| StyleUpdate !Point !Size
#if __GLASGOW_HASKELL__ < 708
$(derive makeBinary ''UIUpdate)
#else
deriving instance Generic UIUpdate
instance Binary UIUpdate
#endif
newBI :: YiString -> BufferImpl ()
newBI s = FBufferData s M.empty M.empty dummyHlState Set.empty 0
insertChars :: YiString -> YiString -> Point -> YiString
insertChars p cs (Point i) = left `R.append` cs `R.append` right
where (left, right) = R.splitAt i p
deleteChars :: YiString -> Point -> Size -> YiString
deleteChars p (Point i) (Size n) = left `R.append` right
where (left, rest) = R.splitAt i p
right = R.drop n rest
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'
where p' = max from (p +~ by)
mapOvlMarks :: (MarkValue -> MarkValue) -> Overlay -> Overlay
mapOvlMarks f (Overlay _owner s e v msg) = Overlay _owner (f s) (f e) v msg
sizeBI :: BufferImpl syntax -> Point
sizeBI = Point . R.length . mem
nelemsBI :: Int -> Point -> BufferImpl syntax -> YiString
nelemsBI n (Point i) = R.take n . R.drop i . mem
getStream :: Direction -> Point -> BufferImpl syntax -> YiString
getStream Forward (Point i) = R.drop i . mem
getStream Backward (Point i) = R.reverse . R.take i . mem
getIndexedStream :: Direction -> Point -> BufferImpl syntax -> [(Point,Char)]
getIndexedStream Forward (Point p) = zip [Point p..] . R.toString . R.drop p . mem
getIndexedStream Backward (Point p) = zip (dF (pred (Point p))) . R.toReverseString . R.take p . mem
where
dF n = n : dF (pred n)
mkOverlay :: R.YiString -> Region -> StyleName -> R.YiString -> Overlay
mkOverlay owner r =
Overlay owner
(MarkValue (regionStart r) Backward)
(MarkValue (regionEnd r) Forward)
overlayUpdate :: Overlay -> UIUpdate
overlayUpdate (Overlay _owner (MarkValue s _) (MarkValue e _) _ _ann) =
StyleUpdate s (e ~- s)
addOverlayBI :: Overlay -> BufferImpl syntax -> BufferImpl syntax
addOverlayBI ov fb = fb{overlays = Set.insert ov (overlays fb)}
delOverlayBI :: Overlay -> BufferImpl syntax -> BufferImpl syntax
delOverlayBI ov fb = fb{overlays = Set.delete ov (overlays fb)}
delOverlaysOfOwnerBI :: R.YiString -> BufferImpl syntax -> BufferImpl syntax
delOverlaysOfOwnerBI owner fb =
fb{overlays = Set.filter ((/= owner) . overlayOwner) (overlays fb)}
getOverlaysOfOwnerBI :: R.YiString -> BufferImpl syntax -> Set.Set Overlay
getOverlaysOfOwnerBI owner fb =
Set.filter ((== owner) . overlayOwner) (overlays fb)
strokesRangesBI :: (Point -> Point -> Point -> [Stroke]) ->
Maybe SearchExp -> Region -> Point -> BufferImpl syntax -> [[Stroke]]
strokesRangesBI getStrokes regex rgn point fb = result
where
i = regionStart rgn
j = regionEnd rgn
dropBefore = dropWhile (\s ->spanEnd s <= i)
takeIn = takeWhile (\s -> spanBegin s <= j)
groundLayer = [Span i mempty j]
syntaxHlLayer = filter (\(Span b _m a) -> b /= a) $ getStrokes point i j
layers2 = map (map overlayStroke) $ groupBy ((==) `on` overlayOwner) $ 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 _owner sm em a _msg) =
Span (markPoint sm) a (markPoint em)
clampStroke (Span l x r) = Span (max i l) x (min j r)
hintStroke r = Span (regionStart r) (if point `nearRegion` r then strongHintStyle else hintStyle) (regionEnd r)
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 <= R.length (mem b)
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)}
where (p', amount) = case u of
Insert pnt _ cs -> (insertChars p cs pnt, sz)
Delete pnt _ _ -> (deleteChars p pnt sz, negate sz)
sz = updateSize u
shift = shiftMarkValue (updatePoint u) amount
p = mem fb
reverseUpdateI :: Update -> Update
reverseUpdateI (Delete p dir cs) = Insert p (reverseDir dir) cs
reverseUpdateI (Insert p dir cs) = Delete p (reverseDir dir) cs
lineAt :: Point
-> BufferImpl syntax -> Int
lineAt (Point p) fb = 1 + R.countNewLines (R.take p $ mem fb)
solPoint :: Int -> BufferImpl syntax -> Point
solPoint line fb = Point $ R.length $ fst $ R.splitAtLine (line 1) (mem fb)
eolPoint' :: Point
-> BufferImpl syntax
-> Point
eolPoint' p@(Point ofs) fb = Point . checkEol . fst . R.splitAtLine ln $ mem fb
where
ln = lineAt p fb
checkEol t =
let l' = R.length t
in case R.last t of
Just '\n' | l' > ofs -> l' 1
_ -> l'
solPoint' :: Point -> BufferImpl syntax -> Point
solPoint' point fb = solPoint (lineAt point fb) fb
charsFromSolBI :: Point -> BufferImpl syntax -> YiString
charsFromSolBI pnt fb = nelemsBI (fromIntegral $ pnt sol) sol fb
where sol = solPoint' pnt fb
regexRegionBI :: SearchExp -> Region -> forall syntax. BufferImpl syntax -> [Region]
regexRegionBI se r fb = case dir of
Forward -> fmap (fmapRegion addPoint . matchedRegion) $ matchAll' $ R.toString bufReg
Backward -> fmap (fmapRegion subPoint . matchedRegion) $ matchAll' $ R.toReverseString bufReg
where matchedRegion arr = let (off,len) = arr!0 in mkRegion (Point off) (Point (off+len))
addPoint (Point x) = Point (p + x)
subPoint (Point x) = Point (q x)
matchAll' = matchAll (searchRegex dir se)
dir = regionDirection r
Point p = regionStart r
Point q = regionEnd r
Size s = regionSize r
bufReg = R.take s . R.drop p $ mem fb
newMarkBI :: MarkValue -> BufferImpl syntax -> (BufferImpl syntax, Mark)
newMarkBI initialValue fb =
let maxId = fromMaybe 0 $ markId . fst . fst <$> M.maxViewWithKey (marks fb)
newMark = Mark $ maxId + 1
fb' = fb { marks = M.insert newMark initialValue (marks fb)}
in (fb', newMark)
getMarkValueBI :: Mark -> BufferImpl syntax -> Maybe MarkValue
getMarkValueBI m (FBufferData { marks = marksMap } ) = M.lookup m marksMap
deleteMarkValueBI :: Mark -> BufferImpl syntax -> BufferImpl syntax
deleteMarkValueBI m fb = fb { marks = M.delete m (marks fb) }
getMarkBI :: String -> BufferImpl syntax -> Maybe Mark
getMarkBI name FBufferData {markNames = nms} = M.lookup name nms
modifyMarkBI :: Mark -> (MarkValue -> MarkValue) -> (forall syntax. BufferImpl syntax -> BufferImpl syntax)
modifyMarkBI m f fb = fb {marks = mapAdjust' f m (marks fb)}
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 -> getIndexedStream Forward idx fb)
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 :: WindowRef -> BufferImpl syntax -> syntax
getAst w FBufferData {hlCache = HLState (SynHL {hlGetTree = gt}) cache} = gt cache w
focusAst :: M.Map WindowRef Region -> BufferImpl syntax -> BufferImpl syntax
focusAst r b@FBufferData {hlCache = HLState s@(SynHL {hlFocus = foc}) cache} = b {hlCache = HLState s (foc r cache)}