module System.Console.Haskeline.Backend.DumbTerm where

import System.Console.Haskeline.Backend.Posix
import System.Console.Haskeline.Backend.WCWidth
import System.Console.Haskeline.Term
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Monads as Monads

import System.IO
import qualified Data.ByteString as B
import Control.Concurrent.Chan
import Control.Monad(liftM)

-- TODO: 
---- Put "<" and ">" at end of term if scrolls off.
---- Have a margin at the ends

data Window = Window {pos :: Int -- ^ # of visible chars to left of cursor
                }

initWindow :: Window
initWindow = Window {pos=0}

newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a}
                deriving (Monad, MonadIO, MonadException,
                          MonadState Window,
                          MonadReader Handles, MonadReader Encoders)

type DumbTermM a = forall m . (MonadIO m, MonadReader Layout m) => DumbTerm m a

instance MonadTrans DumbTerm where
    lift = DumbTerm . lift . lift . lift

runDumbTerm :: Handles -> MaybeT IO RunTerm
runDumbTerm h = do
    ch <- liftIO newChan
    posixRunTerm h $ \enc ->
                TermOps {
                        getLayout = tryGetLayouts (posixLayouts h)
                        , withGetEvent = withPosixGetEvent ch h enc []
                        , runTerm = \(RunTermType f) -> 
                                    runPosixT enc h
                                    $ evalStateT' initWindow
                                    $ unDumbTerm f
                        }
                                
instance (MonadException m, MonadReader Layout m) => Term (DumbTerm m) where
    reposition _ s = refitLine s
    drawLineDiff = drawLineDiff'
    
    printLines = mapM_ (printText . (++ crlf))
    moveToNextLine _ = printText crlf
    clearLayout = clearLayoutD
    ringBell True = printText "\a"
    ringBell False = return ()
      
printText :: MonadIO m => String -> DumbTerm m ()
printText str = do
    h <- liftM hOut ask
    posixEncode str >>= liftIO . B.hPutStr h
    liftIO $ hFlush h

-- Things we can assume a dumb terminal knows how to do
cr,crlf :: String
crlf = "\r\n"
cr = "\r"

backs,spaces :: Int -> String
backs n = replicate n '\b'
spaces n = replicate n ' '


clearLayoutD :: DumbTermM ()
clearLayoutD = do
    w <- maxWidth
    printText (cr ++ spaces w ++ cr)

-- Don't want to print in the last column, as that may wrap to the next line.
maxWidth :: DumbTermM Int
maxWidth = asks (\lay -> width lay - 1)

drawLineDiff' :: LineChars -> LineChars -> DumbTermM ()
drawLineDiff' (xs1,ys1) (xs2,ys2) = do
    Window {pos=p} <- get
    w <- maxWidth
    let (xs1',xs2') = matchInit xs1 xs2
    let (xw1, xw2) = (gsWidth xs1', gsWidth xs2')
    let newP = p + xw2 - xw1
    let (ys2', yw2) = takeWidth (w-newP) ys2
    if xw1 > p  || newP >= w
        then refitLine (xs2,ys2)
        else do -- we haven't moved outside the margins
            put Window {pos=newP}
            case (xs1',xs2') of
                ([],[]) | ys1 == ys2    -> return () -- no change
                (_,[]) | xs1' ++ ys1 == ys2 -> -- moved left
                    printText $ backs xw1
                ([],_) | ys1 == xs2' ++ ys2 -> -- moved right
                    printText (graphemesToString xs2')
                _ -> let extraLength = xw1 + snd (takeWidth (w-p) ys1)
                                        - xw2 - yw2
                     in printText $ backs xw1
                        ++ graphemesToString (xs2' ++ ys2') ++ clearDeadText extraLength
                        ++ backs yw2

refitLine :: ([Grapheme],[Grapheme]) -> DumbTermM ()
refitLine (xs,ys) = do
    w <- maxWidth
    let (xs',p) = dropFrames w xs
    put Window {pos=p}
    let (ys',k) = takeWidth (w - p) ys
    printText $ cr ++ graphemesToString (xs' ++ ys')
        ++ spaces (w-k-p)
        ++ backs (w-p)
  where
    -- returns the width of the returned characters.
    dropFrames w zs = case splitAtWidth w zs of
                        (_,[],l) -> (zs,l)
                        (_,zs',_) -> dropFrames w zs'

    
clearDeadText :: Int -> String
clearDeadText n | n > 0 = spaces n ++ backs n
                | otherwise = ""