{-# LANGUAGE PatternGuards, ExistentialQuantification #-}

-- Copyright (c) 2004-5, 7-8 Don Stewart - http://www.cse.unsw.edu.au/~dons

-- | 'Buffer' implementation, wrapping ByteString.
module Yi.Buffer.Implementation
  ( Update     ( .. )
  , Point
  , Mark
  , Size
  , Direction (..)
  , BufferImpl
  , moveToI
  , applyUpdateI
  , isValidUpdate
  , pointBI
  , nelemsBI
  , sizeBI
  , curLnI
  , newBI
  , gotoLnRelI
  , offsetFromSolBI
  , searchBI
  , regexBI
  , getMarkBI
  , getMarkPointBI
  , setMarkPointBI
  , unsetMarkBI
  , getSelectionMarkBI
  , nelemsBIH
  , styleRangesBI
  , setSyntaxBI
  , addOverlayBI
  , inBounds
)
where

import Yi.Syntax

import qualified Data.Map as M
import Yi.Style

import Control.Monad
import Control.Arrow (second)

import Text.Regex.Base
import Text.Regex.Posix

import qualified Yi.FingerString as F
import Yi.FingerString (FingerString)
import qualified Data.ByteString.Char8 as B

import Data.Array
import Data.Maybe


-- | Direction of movement inside a buffer
data Direction = Backward
               | Forward
                 deriving Eq

type Point = Int
type Size  = Int

newtype Mark = Mark {markId::Int} deriving (Eq, Ord, Show)
pointMark, markMark :: Mark
pointMark = Mark 0 -- 'point' - the insertion point mark
markMark = Mark 1 -- 'mark' - the selection mark

data MarkValue = MarkValue {markPosition::Int, _markIsLeftBound::Bool}
               deriving (Eq, Show)

type Marks = M.Map Mark MarkValue

type BufferImpl = FBufferData

data HLState = forall a. Eq a => HLState !(Highlighter a)

-- ---------------------------------------------------------------------
--
-- | The buffer text itself is stored as ByteString.
--
-- Problems with this implementation:
-- * Does not support unicode
-- * Is not optimized (O(n) operations)
--

data FBufferData =
        FBufferData { mem        :: !FingerString          -- ^ buffer text
                    , marks      :: !Marks                 -- ^ Marks for this buffer
                    , _markNames :: !(M.Map String Mark)
                    , hlcache    :: !(Maybe HLState)       -- ^ syntax highlighting state
                    , overlays   :: ![(MarkValue, MarkValue, Style)] -- ^ list of visual overlay regions
                    -- Overlays should not use Mark, but directly Point
                    }


--
-- | Mutation actions (from the undo or redo list)
--
-- We use the /partial checkpoint/ (Berlage, pg16) strategy to store
-- just the components of the state that change.
--

data Update = Insert {updatePoint :: !Point, insertUpdateString :: !String} -- FIXME: use ByteString
            | Delete {updatePoint :: !Point, deleteUpdateSize :: !Size}
              deriving Show


--------------------------------------------------
-- Low-level primitives.

-- | New FBuffer filled from string.
newBI :: String -> FBufferData
newBI s = FBufferData (F.fromString s) mks M.empty Nothing []
    where
    mks = M.fromList [(pointMark, MarkValue 0 pointLeftBound)]

-- | read @n@ chars from buffer @b@, starting at @i@
readChars :: FingerString -> Int -> Int -> FingerString
readChars p n i = F.take n $ F.drop i $ p
{-# INLINE readChars #-}

-- | Write string into buffer.
insertChars :: FingerString -> FingerString -> Int -> FingerString
insertChars p cs i = left `F.append` cs `F.append` right
    where (left,right) = F.splitAt i p
{-# INLINE insertChars #-}


-- | Write string into buffer.
deleteChars :: FingerString -> Int -> Int -> FingerString
deleteChars p i 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 :: Int -> Int -> Int
inBounds i end | i <= 0    = 0
               | i > end   = max 0 end
               | otherwise = i
{-# INLINE inBounds #-}

------------------------------------------------------------------------
-- Mid-level insert/delete

shiftMarkValue :: Point -> Size -> MarkValue -> MarkValue
shiftMarkValue from by (MarkValue p leftBound) = MarkValue shifted leftBound
    where shifted | p < from  = p
                  | p == from = if leftBound then p else p'
                  | otherwise {- p > from -} = p'
              where p' = max from (p + by)


mapOvlMarks :: (a -> b) -> (a, a, v) -> (b, b, v)
mapOvlMarks f (s,e,v) = (f s, f e, v)

-------------------------------------
-- * "high-level" (exported) operations

-- | Number of characters in the buffer
sizeBI :: BufferImpl -> Int
sizeBI (FBufferData p _ _ _ _) = F.length p

-- | Extract the current point
pointBI :: BufferImpl -> Int
pointBI (FBufferData _ mks _ _ _) = markPosition (mks M.! pointMark)
{-# INLINE pointBI #-}

-- | Return @n@ elems starting at @i@ of the buffer as a list
nelemsBI :: Int -> Int -> BufferImpl -> String
nelemsBI n i (FBufferData b _ _ _ _) =
        let i' = inBounds i (F.length b)
            n' = min (F.length b - i') n
        in F.toString $ readChars b n' i'


-- | Add a style "overlay" between the given points.
addOverlayBI :: Point -> Point -> Style -> BufferImpl -> BufferImpl
addOverlayBI s e sty fb =
    let sm = MarkValue s True
        em = MarkValue e False
    in fb{overlays=(sm,em,sty) : overlays fb}

-- | Return @n@ elems starting at @i@ of the buffer as a list.
-- This routine also does syntax highlighting and applies overlays.
nelemsBIH :: Int -> Int -> BufferImpl -> [(Char,Style)]
nelemsBIH n i fb = helper i defaultStyle (styleRangesBI n i fb) (nelemsBI n i fb)
  where
    helper _   sty [] cs = setSty sty cs
    helper pos sty ((end,sty'):xs) cs = setSty sty left ++ helper end sty' xs right
        where (left, right) = splitAt (end - pos) cs
    setSty sty cs = [(c,sty) | c <- cs]

-- | Return style information for the range of @n@ characters starting
--   at @i@. Style information is derived from syntax highlighting and
--   active overlays.
--   The returned list contains tuples (@p@,@s@) where every tuple is to
--   be interpreted as apply the style @s@ from position @p@ in the buffer.
--   In the final element @p@ = @n@ + @i@.
styleRangesBI :: Int -> Int -> BufferImpl -> [(Int, Style)]
styleRangesBI n i fb = fun fb
  where
    -- The first case is to handle when no 'Highlighter a' has
    -- been assigned to the buffer (via eg 'setSyntaxBI bi "haskell"')
    fun bd@(FBufferData b _ _ Nothing _) =
           let e = F.length b
               i' = inBounds i e
               n' = min (e-i') n
               cas = [(0, defaultStyle),(e, defaultStyle)]
           in cutRanges n' i' (overlay bd cas)
    -- in this, second, case 'hl' will be bound to a 'Highlighter a'
    -- eg Yi.Syntax.Haskell.highlighter (see Yi.Syntax for defn of Highlighter) which
    -- uses '(Data.ByteString.Char8.ByteString, Int)' as its parameterized state
    fun bd@(FBufferData b _ _ (Just (HLState hl)) _) =

      let (finst,colors_) = hlColorize hl (F.toLazyByteString b) (hlStartState hl)
          colors = colors_ ++ hlColorizeEOF hl finst
      in cutRanges n i (overlay bd (makeRanges 0 colors))

    -- The parser produces a list of token sizes, convert them to buffer indices
    makeRanges :: Int -> [(Int,Style)] -> [(Int, Style)]
    makeRanges o [] = [(o,defaultStyle)]
    makeRanges o ((m,c):cs) = (o, c):makeRanges (o + m) cs

    -- Split the range list so that all split points less then x
    -- is in the left and all greater or equal in the right.
    -- Insert a new switch at x if there is none. If the new
    -- switch is left of existing switches, use a as default attribute
    splitRangesDefault :: a -> Int -> [(Int, a)] -> ([(Int, a)], [(Int, a)])
    splitRangesDefault a x [] = ([], [(x,a)])
    splitRangesDefault a x ((y,b):ys) =
      case x `compare` y of
        LT -> ([], (x,a):(y,b):ys)
        EQ -> ([], (y,b):ys)
        GT -> let (ls, rs) = splitRangesDefault b x ys in ((y,b):ls, rs)

    splitRanges :: Int -> [(Int, Style)] -> ([(Int, Style)], [(Int, Style)])
    splitRanges = splitRangesDefault defaultStyle

    cutRanges :: Int -> Int -> [(Int, Style)] -> [(Int, Style)]
    cutRanges m j = takeRanges (j+m) . snd . splitRanges j
      where takeRanges k xs = let (ls, r:_) = splitRanges k xs in ls ++ [r]

    overlayRanges :: Int -> Int -> Style -> [(Int, Style)] -> [(Int, Style)]
    overlayRanges l h a rs = left ++ adjusted ++ right
      where
        (left, rest)    = splitRanges l rs
        (center, right) = splitRanges h rest
        adjusted        = fmap (\(m,b) -> (m, attrOver a b)) center


    overlay :: FBufferData -> [(Int, Style)] -> [(Int, Style)]
    overlay bd rs =
      foldr (\(sm, em, a) -> overlayRanges (markPosition sm) (markPosition em) a) rs (overlays bd)

    --attrOver att1 att2 = att1 .|. (att2 .&. 0xFFFF0000) -- Overwrite colors, keep attrs (bold, underline etc)
    attrOver att1 _att2 = att1 -- Until Vty exposes interface for attr merging....


------------------------------------------------------------------------
-- Point based editing

-- | Move point in buffer to the given index
moveToI :: Int -> BufferImpl -> BufferImpl
moveToI i (FBufferData ptr mks nms hl ov) =
                 FBufferData ptr (M.insert pointMark (MarkValue (inBounds i end) pointLeftBound) mks) nms hl ov
    where end = F.length ptr
{-# INLINE moveToI #-}

-- | Checks if an Update is valid
isValidUpdate :: Update -> BufferImpl -> Bool
isValidUpdate u b = case u of
                    (Delete p n)   -> check p && check (p + n)
                    (Insert p _)   -> check p
    where check x = x >= 0 && x <= F.length (mem b)


-- | Apply a /valid/ update
applyUpdateI :: Update -> BufferImpl -> BufferImpl
applyUpdateI u (FBufferData p mks nms hl ov) = FBufferData p' (M.map shift mks) nms hl (map (mapOvlMarks shift) ov)
    where (p', amount) = case u of
                           Insert pnt cs  -> (insertChars p (F.fromString cs) pnt, length cs)
                           Delete pnt len -> (deleteChars p pnt len, negate len)
          shift = shiftMarkValue (updatePoint u) amount
          -- FIXME: remove collapsed overlays

------------------------------------------------------------------------
-- Line based editing

curLnI :: BufferImpl -> Int
curLnI fb@(FBufferData ptr _ _ _ _) = 1 + F.count '\n' (F.take (pointBI fb) ptr)

-- | 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)
gotoLnRelI :: Int -> BufferImpl -> (BufferImpl, Int)
gotoLnRelI n fb = (moveToI np fb, max 1 n')
    where
     s = mem fb
     point = pointBI fb
     (n', np) = if n <= 0
      then
        let lineStarts = map (+1) ((F.elemIndicesEnd '\n') (F.take point s)) ++ [0]
            findLine acc _ [x]    = (acc, x)
            findLine acc 0 (x:_)  = (acc, x)
            findLine acc l (_:xs) = findLine (acc - 1) (l + 1) xs
            findLine _ _ []       =
              error "lineStarts ends with 0 : ... this cannot happen"
        in findLine 0 n lineStarts
      else
        let lineStarts = map (+1) ((F.elemIndices '\n') (F.drop point s))
            findLine acc _ []     = (acc, 0) -- try to go forward, but there is no such line.
            findLine acc _ [x]    = (acc + 1, x)
            findLine acc 1 (x:_)  = (acc, x)
            findLine acc l (_:xs) = findLine (acc + 1) (l - 1) xs
        in second (point +) (findLine 0 n lineStarts)

-- | Return index of next string in buffer that matches argument
searchBI :: Direction -> String -> BufferImpl -> Maybe Int
searchBI dir s fb@(FBufferData ptr _ _ _ _) = case dir of
      Forward -> fmap (+ pnt) $ F.findSubstring (B.pack s) $ F.drop pnt ptr
      Backward -> listToMaybe $ reverse $ F.findSubstrings (B.pack s) $ F.take (pnt + length s) ptr
    where pnt = pointBI fb -- pnt == current point

offsetFromSolBI :: BufferImpl -> Int
offsetFromSolBI fb@(FBufferData ptr _ _ _ _) = pnt - maybe 0 (1 +) (F.elemIndexEnd '\n' (F.take pnt ptr))
    where pnt = pointBI fb


-- | Return indices of next string in buffer matched by regex
regexBI :: Regex -> BufferImpl -> Maybe (Int,Int)
regexBI re fb@(FBufferData ptr _ _ _ _) =
    let p = pointBI fb
        mmatch = matchOnce re (F.toByteString $ F.drop p ptr)
    in case mmatch of
         Just arr | ((off,len):_) <- elems arr -> Just (p+off,p+off+len)
         _ -> Nothing

getSelectionMarkBI :: BufferImpl -> Mark
getSelectionMarkBI _ = markMark -- FIXME: simplify this.

-- | Returns ths position of the 'point' mark if the requested mark is unknown (or unset)
getMarkPointBI :: Mark -> BufferImpl -> Point
getMarkPointBI m fb = markPosition (getMark fb m)

getMark :: BufferImpl -> Mark -> MarkValue
getMark (FBufferData { marks = marksMap } ) m = M.findWithDefault (marksMap M.! pointMark) m marksMap
                 -- We look up mark m in the marks, the default value to return
                 -- if mark m is not set, is the pointMark

-- | Set a mark point
setMarkPointBI :: Mark -> Point -> BufferImpl -> BufferImpl
setMarkPointBI m pos fb = fb {marks = M.insert m (MarkValue pos (if m == markMark then markLeftBound else False)) (marks fb)}

{-
  We must allow the unsetting of this mark, this will have the property
  that the point will always be returned as the mark.
-}
unsetMarkBI :: BufferImpl -> BufferImpl
unsetMarkBI fb = fb { marks = (M.delete markMark (marks fb)) }

-- Formerly the highlighters table was directly used
-- 'Yi.Syntax.Table.highlighters'. However avoiding to depends on all
-- highlighters implementation speed up compilation a lot when working on a
-- syntax highlighter.
setSyntaxBI :: ExtHL -> BufferImpl -> BufferImpl
setSyntaxBI (ExtHL e) fb = fb { hlcache = HLState `fmap` e }

pointLeftBound, markLeftBound :: Bool
pointLeftBound = False
markLeftBound = True

------------------------------------------------------------------------

-- | Returns the requested mark, creating a new mark with that name (at point) if needed
getMarkBI :: Maybe String -> BufferImpl -> (BufferImpl, 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 -> Int -> BufferImpl -> (BufferImpl, Mark)
getMarkDefaultPosBI name defaultPos fb@(FBufferData ptr mks nms hl ov) =
  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 False) mks
           in (FBufferData ptr mks' nms' hl ov, newMark)