--
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of
-- the License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
--

--
-- | An interface to a one dimensional mutable 'Buffer', providing
-- cursor movement and editing commands
--

v v v v v v v
module Yi.Buffer ( FBuffer (..), BufferM, runBuffer, keyB, curLn, nameB, indexOfEol,
^ ^ ^ ^ ^ ^ ^
                   sizeB, pointB, moveToSol, moveTo, lineUp, lineDown,
v v v v v v v
                   hPutB, hNewB, newB, finaliseB, Point, Mark, BufferMode(..),
*************
v v v v v v v
                   hPutB, hNewB, newB, finaliseB, Point, Mark,
^ ^ ^ ^ ^ ^ ^
^ ^ ^ ^ ^ ^ ^
                   moveToEol, gotoLn, gotoLnFrom, offsetFromSol,
                   atSol, atEol, atSof, atEof, leftB, rightB,
                   moveXorEol, moveXorSol, insertN, deleteN,
                   deleteToEol, indexOfSol, nelemsB, writeB, getfileB,
                   setfileB, deleteNAt, readB, elemsB, undo, redo,
                   getMarkB, getSelectionMarkB, getMarkPointB, setMarkPointB, unsetMarkB, 
                   isUnchangedB, setSyntaxB, regexB, searchB, readAtB,
                   getModeLine, getPercent, forgetPreferCol, setBufferKeymap, restartBufferThread,
                   clearUndosB
                    ) where

v v v v v v v
import Prelude hiding ( error )
*************
import Prelude hiding ( error )
import System.FilePath
^ ^ ^ ^ ^ ^ ^
import Text.Regex.Posix.Wrap    ( Regex  )
import Yi.FastBuffer
import Yi.Undo

import Yi.Debug
import Data.IORef
import Data.Unique              ( newUnique, Unique, hashUnique )
import Yi.Event
import Yi.Keymap
import Control.Concurrent 
import Control.Monad
v v v v v v v
import Control.Monad.Reader
^ ^ ^ ^ ^ ^ ^
import Control.Exception

--
-- | The 'Buffer' class defines editing operations over one-dimensional`
-- mutable buffers, which maintain a current /point/.
--

data BufferMode = ReadOnly | ReadWrite

v v v v v v v
^ ^ ^ ^ ^ ^ ^
data FBuffer =
        FBuffer { name   :: !String                  -- ^ immutable buffer name
                , bkey   :: !Unique                  -- ^ immutable unique key
                , file   :: !(MVar (Maybe FilePath)) -- ^ maybe a filename associated with this buffer
                , undos  :: !(MVar URList)           -- ^ undo/redo list
                , rawbuf :: !BufferImpl
                , bmode  :: !(MVar BufferMode)       -- ^ a read-only bit
                , preferCol :: !(IORef (Maybe Int))  -- ^ prefered column to arrive at when we do a lineDown / lineUp
                , bufferInput  :: !(Chan Event)      -- ^ input stream
                , bufferThread :: !(Maybe ThreadId)  -- ^ Id of the thread running the buffer's keymap. 
                , bufferKeymap :: !(IORef KeymapMod) -- ^ Buffer's local keymap modification
                , bufferKeymapRestartable :: !(MVar ()) -- ^ Put () in this MVar to mark the buffer ready to restart.
                                             -- FIXME: the bufferKeymap should really be an MVar, and that can be used to sync.
                }

v v v v v v v
type BufferM a = ReaderT FBuffer IO a

^ ^ ^ ^ ^ ^ ^
instance Eq FBuffer where
   FBuffer { bkey = u } == FBuffer { bkey = v } = u == v

instance Show FBuffer where
    showsPrec _ (FBuffer { bkey = u, name = f }) = showString $ "Buffer #" ++ show (hashUnique u) ++ " (" ++ show f ++ ")"

-- | Given a buffer, and some information update the modeline
--
-- N.B. the contents of modelines should be specified by user, and
-- not hardcoded.
--
v v v v v v v
getModeLine :: BufferM String
getModeLine = do
    col <- offsetFromSol
    pos <- pointB
    ln <- curLn
    p <- indexOfEol
    s <- sizeB
    unchanged <- isUnchangedB
^ ^ ^ ^ ^ ^ ^
    let pct = if pos == 1 then "Top" else getPercent p s
        chg = if unchanged then "-" else "*"
v v v v v v v
    nm <- nameB
^ ^ ^ ^ ^ ^ ^
    return $ 
v v v v v v v
           chg ++ " "
           ++ nm ++ 
*************
           chg ++ " " ++
           "\"" ++ nm ++ "\"" ++ 
^ ^ ^ ^ ^ ^ ^
           replicate 5 ' ' ++
           "L" ++ show ln ++ "  " ++ "C" ++ show col ++ 
           replicate 2 ' ' ++ pct

--
-- | Give a point, and the file size, gives us a percent string
--
getPercent :: Int -> Int -> String
getPercent a b = show p ++ "%"
    where p = ceiling ((fromIntegral a) / (fromIntegral b) * 100 :: Double) :: Int


v v v v v v v
v v v v v v v
withImpl :: (BufferImpl -> IO x) -> (BufferM x)
withImpl f = do b <- ask; lift $ f (rawbuf b)

withImpl1 :: (BufferImpl -> a -> IO x) -> (a -> BufferM x)
withImpl1 f a = do b <- ask; lift $ f (rawbuf b) a

withImpl2 :: (BufferImpl -> a -> b -> IO x) -> (a -> b -> BufferM x)
withImpl2 f a b = do x <- ask; lift $ f (rawbuf x) a b

runBuffer = flip runReaderT
^ ^ ^ ^ ^ ^ ^
*************
withImpl :: (BufferImpl -> IO x) -> (BufferM x)
withImpl f = do b <- ask; lift $ f (rawbuf b)

withImpl1 :: (BufferImpl -> a -> IO x) -> (a -> BufferM x)
withImpl1 f a = do b <- ask; lift $ f (rawbuf b) a

withImpl2 :: (BufferImpl -> a -> b -> IO x) -> (a -> b -> BufferM x)
withImpl2 f a b = do x <- ask; lift $ f (rawbuf x) a b

runBuffer :: FBuffer -> BufferM a -> IO a
runBuffer = flip runReaderT
^ ^ ^ ^ ^ ^ ^

hNewB :: FilePath -> IO FBuffer
v v v v v v v
hNewB fp = do
  s <- readFile fp
  b <- newB (takeFileName fp) s -- FIXME: Here we should somehow insure that no 2 buffers get the same name
  runBuffer b (setfileB fp)
*************
hNewB nm = do 
  s <- readFile nm
  b <- newB nm s
  runBuffer b (setfileB nm)
^ ^ ^ ^ ^ ^ ^
  return b

v v v v v v v
hPutB :: BufferM ()
hPutB = do
  mf <- getfileB
  case mf of
    Nothing -> error "buffer not associated with a file"
    Just f  -> lift . writeFile f =<< elemsB
  clearUndosB

*************
hPutB :: BufferM ()
hPutB = do
  mf <- getfileB
  case mf of
    Nothing -> error "buffer not associated with a file"
    Just f  -> lift . writeFile f =<< elemsB
  markUnchangedB
^ ^ ^ ^ ^ ^ ^

v v v v v v v
clearUndosB :: BufferM ()
clearUndosB = do b <- ask; lift $ modifyMVar_ (undos b) (\_ -> return emptyUR) -- Clear the undo list, so the changed "flag" is reset.
*************
markUnchangedB :: BufferM ()
markUnchangedB = do b <- ask; lift $ modifyMVar_ (undos b) (\_ -> return emptyUR) -- Clear the undo list, so the changed "flag" is reset.
^ ^ ^ ^ ^ ^ ^

v v v v v v v
nameB :: BufferM String
nameB = asks name
^ ^ ^ ^ ^ ^ ^

v v v v v v v
getfileB :: BufferM (Maybe FilePath)
getfileB = do (FBuffer { file = mvf }) <- ask; lift $ readMVar mvf
*************
getfileB :: BufferM (Maybe FilePath)
getfileB = do (FBuffer { file = mvf }) <- ask; lift $ readMVar mvf

setfileB :: FilePath -> BufferM ()
setfileB f = do (FBuffer { file = mvf }) <- ask; lift $ modifyMVar_ mvf $ const $ return (Just f)
^ ^ ^ ^ ^ ^ ^

v v v v v v v
*************
setfileB :: FilePath -> BufferM ()
setfileB f = do (FBuffer { file = mvf }) <- ask; lift $ modifyMVar_ mvf $ const $ return (Just f)

^ ^ ^ ^ ^ ^ ^
keyB :: FBuffer -> Unique
keyB (FBuffer { bkey = u }) = u


v v v v v v v
isUnchangedB :: BufferM Bool
isUnchangedB = do
  b <- ask
  ur <- lift $ readMVar $ undos b
^ ^ ^ ^ ^ ^ ^
  return $ isEmptyUList ur

v v v v v v v
undo :: BufferM ()
undo = do fb@(FBuffer { undos = mv }) <- ask; lift $ modifyMVar_ mv (undoUR (rawbuf fb))
^ ^ ^ ^ ^ ^ ^

v v v v v v v
redo :: BufferM ()
redo = do fb@(FBuffer { undos = mv }) <- ask; lift $ modifyMVar_ mv (redoUR (rawbuf fb))
^ ^ ^ ^ ^ ^ ^

-- | Create buffer named @nm@ with contents @s@
newB :: String -> [Char] -> IO FBuffer
newB nm s = do 
    pc <- newIORef Nothing
    mv <- newBI s
    mv' <- newMVar emptyUR
    mvf <- newMVar Nothing      -- has name, not connected to a file
    rw  <- newMVar ReadWrite
    u   <- newUnique
    ch  <- newChan
    km <- newIORef id
    r <- newEmptyMVar
    let result = FBuffer { name   = nm
                         , bkey   = u
                         , file   = mvf
                         , undos  = mv'
                         , rawbuf = mv
                         , bmode  = rw
                         , preferCol = pc 
                         , bufferInput = ch
                         , bufferThread = Nothing
                         , bufferKeymap = km
                         , bufferKeymapRestartable = r
                         }
    return result                    


setBufferKeymap :: FBuffer -> KeymapMod -> IO ()
setBufferKeymap b km = do 
  writeIORef (bufferKeymap b) km
  restartBufferThread b
  logPutStrLn $ "Changed keymap for buffer " ++ show b

restartBufferThread :: FBuffer -> IO ()
restartBufferThread b = do
  logPutStrLn $ "Waiting for buffer thread to start " ++ show b
  takeMVar (bufferKeymapRestartable b) 
  maybe (return ()) (flip throwDynTo "Keymap change") (bufferThread b)

-- | Free any resources associated with this buffer
v v v v v v v
finaliseB :: BufferM ()
finaliseB = do 
  b <- ask; lift $ maybe (return ()) killThread (bufferThread b)
  withImpl finaliseBI
^ ^ ^ ^ ^ ^ ^

-- | Number of characters in the buffer
v v v v v v v
sizeB :: BufferM Int
sizeB = withImpl sizeBI
^ ^ ^ ^ ^ ^ ^

-- | Extract the current point
v v v v v v v
pointB :: BufferM Int
pointB = withImpl pointBI
^ ^ ^ ^ ^ ^ ^

-- | Return @n@ elems starting at @i@ of the buffer as a list
v v v v v v v
nelemsB :: Int -> Int -> BufferM [Char]
nelemsB = withImpl2 nelemsBI
^ ^ ^ ^ ^ ^ ^

------------------------------------------------------------------------
-- Point based operations

-- | Move point in buffer to the given index
v v v v v v v
moveTo :: Int -> BufferM ()
moveTo x = do 
  forgetPreferCol
  withImpl1 moveToI x
^ ^ ^ ^ ^ ^ ^

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

-- | Write an element into the buffer at the current point
-- This is an unsafe operation, no bounds checks are performed
-- TODO: undo is not atomic!
v v v v v v v
writeB :: Char -> BufferM ()
writeB c = do 
  FBuffer { undos = uv } <- ask
  forgetPreferCol
  off <- pointB
  oldc <- nelemsB 1 off
  lift $ modifyMVar_ uv $ \u -> do
^ ^ ^ ^ ^ ^ ^
    let u'  = addUR u  (Insert off oldc)
        u'' = addUR u' (Delete off 1)
    return u''
v v v v v v v
  withImpl1 writeBI c
^ ^ ^ ^ ^ ^ ^

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

-- | Insert the list at current point, extending size of buffer
v v v v v v v
insertN :: [Char] -> BufferM ()
insertN [] = return ()
insertN cs = do 
  FBuffer { undos = uv } <- ask
  forgetPreferCol
  pnt <- pointB
  lift $ modifyMVar_ uv $ \ur -> return $ addUR ur (Delete pnt (length cs))
  withImpl1 insertNI cs
^ ^ ^ ^ ^ ^ ^

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

-- | @deleteNAt b n p@ deletes @n@ characters at position @p@
v v v v v v v
deleteNAt :: Int -> Int -> BufferM ()
deleteNAt 0 _ = return ()
deleteNAt n pos = do
       FBuffer { undos = uv } <- ask
       forgetPreferCol
       text <- nelemsB n pos
       lift $ modifyMVar_ uv $ \ur -> return $ addUR ur (Insert pos text)
       withImpl2 deleteNAtI n pos
^ ^ ^ ^ ^ ^ ^

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

-- | Return the current line number
v v v v v v v
curLn :: BufferM Int
curLn = withImpl curLnI 
^ ^ ^ ^ ^ ^ ^

-- | 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)
v v v v v v v
gotoLn :: Int -> BufferM Int
gotoLn = withImpl1 gotoLnI
^ ^ ^ ^ ^ ^ ^

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

-- | Return index of next string in buffer that matches argument
v v v v v v v
searchB :: [Char] -> BufferM (Maybe Int)
searchB = withImpl1 searchBI
^ ^ ^ ^ ^ ^ ^

-- | Set name of syntax highlighting mode
v v v v v v v
setSyntaxB :: [Char] -> BufferM ()
setSyntaxB = withImpl1 setSyntaxBI
^ ^ ^ ^ ^ ^ ^

-- | Return indices of next string in buffer matched by regex
v v v v v v v
regexB :: Regex -> BufferM (Maybe (Int,Int))
regexB = withImpl1 regexBI
^ ^ ^ ^ ^ ^ ^

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

-- | Set a mark in this buffer
v v v v v v v
setMarkPointB :: Mark -> Int -> BufferM ()
setMarkPointB = withImpl2 setMarkPointBI
^ ^ ^ ^ ^ ^ ^

v v v v v v v
getMarkPointB :: Mark -> BufferM Int
getMarkPointB = withImpl1 getMarkPointBI
^ ^ ^ ^ ^ ^ ^

v v v v v v v
unsetMarkB :: BufferM ()
unsetMarkB = withImpl unsetMarkBI
^ ^ ^ ^ ^ ^ ^

v v v v v v v
getMarkB :: Maybe String -> BufferM Mark
getMarkB = withImpl1 getMarkBI
*************
v v v v v v v
getMarkB = withImpl1 getMarkBI
^ ^ ^ ^ ^ ^ ^
^ ^ ^ ^ ^ ^ ^

v v v v v v v
getSelectionMarkB :: BufferM Mark
getSelectionMarkB = withImpl getSelectionMarkBI
*************
v v v v v v v
getSelectionMarkB = withImpl getSelectionMarkBI
^ ^ ^ ^ ^ ^ ^
^ ^ ^ ^ ^ ^ ^

-- | Move point -1
v v v v v v v
leftB :: BufferM ()
leftB = leftN 1
^ ^ ^ ^ ^ ^ ^

-- | Move cursor -n
v v v v v v v
leftN :: Int -> BufferM ()
leftN n = pointB >>= \p -> moveTo (p - n)
^ ^ ^ ^ ^ ^ ^

-- | Move cursor +1
v v v v v v v
rightB :: BufferM ()
rightB = rightN 1
^ ^ ^ ^ ^ ^ ^

-- | Move cursor +n
v v v v v v v
rightN :: Int -> BufferM ()
rightN n = pointB >>= \p -> moveTo (p + n)
^ ^ ^ ^ ^ ^ ^

-- ---------------------------------------------------------------------
-- Line based movement and friends

v v v v v v v
readPrefCol :: BufferM (Maybe Int)
readPrefCol = lift . readIORef =<< asks preferCol

setPrefCol :: Maybe Int -> BufferM ()
setPrefCol c = do b <- ask; lift $ writeIORef (preferCol b) c
*************
v v v v v v v
readPrefCol = lift . readIORef =<< asks preferCol

setPrefCol c = do b <- ask; lift $ writeIORef (preferCol b) c
^ ^ ^ ^ ^ ^ ^
^ ^ ^ ^ ^ ^ ^

-- | Move point down by @n@ lines. @n@ can be negative.
v v v v v v v
lineMoveRel :: Int -> BufferM ()
lineMoveRel n = do
  prefCol <- readPrefCol
^ ^ ^ ^ ^ ^ ^
  targetCol <- case prefCol of
v v v v v v v
    Nothing -> offsetFromSol
^ ^ ^ ^ ^ ^ ^
    Just x -> return x
v v v v v v v
  gotoLnFrom n
  moveXorEol targetCol
^ ^ ^ ^ ^ ^ ^
  --logPutStrLn $ "lineMoveRel: targetCol = " ++ show targetCol
v v v v v v v
  b <- ask; lift $ writeIORef (preferCol b) (Just targetCol)
^ ^ ^ ^ ^ ^ ^

v v v v v v v
forgetPreferCol :: BufferM ()
forgetPreferCol = setPrefCol Nothing
^ ^ ^ ^ ^ ^ ^

v v v v v v v
savingPrefCol :: BufferM a -> BufferM a
savingPrefCol f = do
  pc <- lift . readIORef =<< asks preferCol
^ ^ ^ ^ ^ ^ ^
  result <- f
v v v v v v v
  setPrefCol pc
^ ^ ^ ^ ^ ^ ^
  return result

-- | Move point up one line
v v v v v v v
lineUp :: BufferM ()
lineUp = lineMoveRel (-1)
^ ^ ^ ^ ^ ^ ^

-- | Move point down one line
v v v v v v v
lineDown :: BufferM ()
lineDown = lineMoveRel 1
^ ^ ^ ^ ^ ^ ^


-- | Return the contents of the buffer as a list
v v v v v v v
elemsB :: BufferM [Char]
elemsB = do n <- sizeB
            nelemsB n 0
^ ^ ^ ^ ^ ^ ^

-- | Read the character at the current point
v v v v v v v
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
v v v v v v v
readAtB :: Int -> BufferM Char
readAtB i = do
    s <- nelemsB 1 i
^ ^ ^ ^ ^ ^ ^
    return $ case s of
               [c] -> c
               _ -> '\0'

-- | Delete the character at current point, shrinking size of buffer
v v v v v v v
deleteB :: BufferM ()
deleteB = deleteN 1
^ ^ ^ ^ ^ ^ ^

-- | Delete @n@ characters forward from the current point
v v v v v v v
deleteN :: Int -> BufferM ()
deleteN 0 = return ()
deleteN n = pointB >>= deleteNAt n
^ ^ ^ ^ ^ ^ ^

-- | Delete to the end of line, excluding it.
v v v v v v v
deleteToEol :: BufferM ()
deleteToEol = do
    p <- pointB
    moveToEol
    q <- pointB
    deleteNAt (q-p) p
^ ^ ^ ^ ^ ^ ^

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

-- | Return true if the current point is the start of a line
v v v v v v v
atSol :: BufferM Bool
atSol = do p <- pointB
           if p == 0 then return True
                     else do c <- readAtB (p-1)
                             return (c == '\n')
^ ^ ^ ^ ^ ^ ^

-- | Return true if the current point is the end of a line
v v v v v v v
atEol :: BufferM Bool
atEol = do p <- pointB
           e <- sizeB
           if p == e
                  then return True
                  else do c <- readAtB p
                          return (c == '\n')
^ ^ ^ ^ ^ ^ ^

-- | True if point at start of file
v v v v v v v
atSof :: BufferM Bool
atSof = do p <- pointB
           return (p == 0)
^ ^ ^ ^ ^ ^ ^

-- | True if point at end of file
v v v v v v v
atEof :: BufferM Bool
atEof = do p <- pointB
           e <- sizeB
           return (p == e)
^ ^ ^ ^ ^ ^ ^


-- | Offset from start of line
v v v v v v v
offsetFromSol :: BufferM Int
offsetFromSol = savingPrefCol $ do
    i <- pointB
    moveToSol
    j <- pointB
    moveTo i
^ ^ ^ ^ ^ ^ ^
    return (i - j)
{-# INLINE offsetFromSol #-}

-- | Index of start of line
v v v v v v v
indexOfSol :: BufferM Int
indexOfSol = savingPrefCol $ do
    i <- pointB
    j <- offsetFromSol
^ ^ ^ ^ ^ ^ ^
    return (i - j)
{-# INLINE indexOfSol #-}

-- | Index of end of line
v v v v v v v
indexOfEol :: BufferM Int
indexOfEol = savingPrefCol $ do
    i <- pointB
    moveToEol
    j <- pointB
    moveTo i
^ ^ ^ ^ ^ ^ ^
    return j
{-# INLINE indexOfEol #-}


v v v v v v v
-- | Move using the direction specified by the 1st argument, until
-- either we've moved @n@, the 2nd argument, or @p@ the 3rd argument
^ ^ ^ ^ ^ ^ ^
-- is True
v v v v v v v
moveAXuntil :: BufferM () -> Int -> (BufferM Bool) -> BufferM ()
moveAXuntil f x p
^ ^ ^ ^ ^ ^ ^
    | x <= 0    = return ()
    | otherwise = do -- will be slow on long lines...
        let loop 0 = return ()
v v v v v v v
            loop i = do r <- p
                        when (not r) $ f >> loop (i-1)
        savingPrefCol (loop x)
^ ^ ^ ^ ^ ^ ^
{-# INLINE moveAXuntil #-}

-- | Move @x@ chars back, or to the sol, whichever is less
v v v v v v v
moveXorSol :: Int -> BufferM ()
moveXorSol x = moveAXuntil leftB x atSol
^ ^ ^ ^ ^ ^ ^

-- | Move @x@ chars forward, or to the eol, whichever is less
v v v v v v v
moveXorEol :: Int -> BufferM ()
moveXorEol x = moveAXuntil rightB x atEol
^ ^ ^ ^ ^ ^ ^


-- | Go to line indexed from current point
v v v v v v v
gotoLnFrom :: Int -> BufferM Int
gotoLnFrom x = do 
  l <- curLn
  gotoLn (x+l)
^ ^ ^ ^ ^ ^ ^

-- | Move point to start of line
v v v v v v v
moveToSol :: BufferM ()
moveToSol = sizeB >>= moveXorSol  
^ ^ ^ ^ ^ ^ ^

-- | Move point to end of line
v v v v v v v
moveToEol :: BufferM ()
moveToEol = sizeB >>= moveXorEol 
^ ^ ^ ^ ^ ^ ^