Ticket #81: Terminfo.hs

module System.Console.Haskeline.Backend.Terminfo(
                            Draw(),
                            runTerminfoDraw
                            )
                             where

import System.Console.Terminfo
import Control.Monad
import Data.List(intersperse)
import System.IO
import qualified Control.Exception.Extensible as Exception
import qualified Data.ByteString.Char8 as B
import Data.Maybe (fromMaybe, mapMaybe)
import Control.Concurrent.Chan

import System.Console.Haskeline.Monads as Monads
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Term
import System.Console.Haskeline.Backend.Posix
import System.Console.Haskeline.Key
import qualified Data.IntMap as M
-- | Keep track of all of the output capabilities we can use.
-- 
-- We'll be frequently using the (automatic) 'Monoid' instance for 
-- @Actions -> TermOutput@.
data Actions = Actions {leftA, rightA, upA :: Int -> TermOutput,
                        clearToLineEnd :: TermOutput,
                        nl, cr :: TermOutput,
                        bellAudible,bellVisual :: TermOutput,
                        clearAllA :: LinesAffected -> TermOutput,
                        wrapLine :: TermOutput}

getActions :: Capability Actions
getActions = do
    leftA' <- moveLeft
    rightA' <- moveRight
    upA' <- moveUp
    clearToLineEnd' <- clearEOL
    clearAll' <- clearScreen
    nl' <- newline
    cr' <- carriageReturn
    -- Don't require the bell capabilities
    bellAudible' <- bell `mplus` return mempty
    bellVisual' <- visualBell `mplus` return mempty
    wrapLine' <- getWrapLine nl' (leftA' 1)
    return Actions{leftA = leftA', rightA = rightA',upA = upA',
                clearToLineEnd = clearToLineEnd', nl = nl',cr = cr',
                bellAudible = bellAudible', bellVisual = bellVisual',
                clearAllA = clearAll',
                 wrapLine = wrapLine'}

text :: B.ByteString -> Actions -> TermOutput
text str _ = termText $ B.unpack str

getWrapLine :: TermOutput -> TermOutput -> Capability TermOutput
getWrapLine nl' left1 = (autoRightMargin >>= guard >> withAutoMargin)
                    `mplus` return nl'
  where 
    -- If the wraparound glitch is in effect, force a wrap by printing a space.
    -- Otherwise, it'll wrap automatically.
    withAutoMargin = (do
                        wraparoundGlitch >>= guard
                        return (termText " " <#> left1)
                     )`mplus` return mempty

type TermAction = Actions -> TermOutput
    
left,right,up :: Int -> TermAction
left = flip leftA
right = flip rightA
up = flip upA

clearAll :: LinesAffected -> TermAction
clearAll = flip clearAllA

--------


mreplicate :: Monoid m => Int -> m -> m
mreplicate n m
    | n <= 0    = mempty
    | otherwise = m `mappend` mreplicate (n-1) m

-- denote in modular arithmetic;
-- in particular, 0 <= termCol < width
--eolPos, End of Line Position, every on screen displaying line's end Char position.
data TermPos = TermPos {termRow,termCol,termLastLine :: Int, eolPos :: M.IntMap Int}
                deriving Show

initTermPos :: TermPos
initTermPos = TermPos {termRow = 0, termCol = 0, termLastLine=0 ,eolPos =(M.singleton 0 0)}


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

newtype Draw m a = Draw {unDraw :: (ReaderT Actions
                                    (ReaderT Terminal (StateT TermPos
                                    (PosixT m)))) a}
    deriving (Monad, MonadIO, MonadException,
              MonadReader Actions, MonadReader Terminal, MonadState TermPos,
              MonadReader Handle, MonadReader Encoders)

type DrawM a = forall m . (MonadReader Layout m, MonadIO m) => Draw m a

instance MonadTrans Draw where
    lift = Draw . lift . lift . lift . lift . lift
    
runTerminfoDraw :: IO (Maybe RunTerm)
runTerminfoDraw = do
    mterm <- Exception.try setupTermFromEnv
    ch <- newChan
    case mterm of
        -- XXX narrow this: either an ioexception (from getenv) or a 
        -- usererror.
        Left (_::SetupTermError) -> return Nothing
        Right term -> case getCapability term getActions of
            Nothing -> return Nothing
            Just actions -> fmap Just $ posixRunTerm $ \enc h ->
                TermOps {
                    getLayout = tryGetLayouts (posixLayouts h
                                                ++ [tinfoLayout term])
                    , withGetEvent = wrapKeypad h term
                                        . withPosixGetEvent ch h enc
                                            (terminfoKeys term)
                    , runTerm = \(RunTermType f) -> 
                             runPosixT enc h
                              $ evalStateT' initTermPos
                              $ runReaderT' term
                              $ runReaderT' actions
                              $ unDraw f
                    }

-- If the keypad on/off capabilities are defined, wrap the computation with them.
wrapKeypad :: MonadException m => Handle -> Terminal -> m a -> m a
wrapKeypad h term f = (maybeOutput keypadOn >> f)
                            `finally` maybeOutput keypadOff
  where
    maybeOutput = liftIO . hRunTermOutput h term .
                            fromMaybe mempty . getCapability term

tinfoLayout :: Terminal -> IO (Maybe Layout)
tinfoLayout term = return $ getCapability term $ do
                        r <- termColumns
                        c <- termLines
                        return Layout {height=r,width=c}

terminfoKeys :: Terminal -> [(String,Key)]
terminfoKeys term = mapMaybe getSequence keyCapabilities
    where
        getSequence (cap,x) = do
                            keys <- getCapability term cap
                            return (keys,x)
        keyCapabilities =
                [(keyLeft,      simpleKey LeftKey)
                ,(keyRight,      simpleKey RightKey)
                ,(keyUp,         simpleKey UpKey)
                ,(keyDown,       simpleKey DownKey)
                ,(keyBackspace,  simpleKey Backspace)
                ,(keyDeleteChar, simpleKey Delete)
                ,(keyHome,       simpleKey Home)
                ,(keyEnd,        simpleKey End)
                ,(keyPageDown,   simpleKey PageDown)
                ,(keyPageUp,     simpleKey PageUp)
                ]

    
output :: MonadIO m => TermAction -> Draw m ()
output f = do
    toutput <- asks f
    term <- ask
    ttyh <- ask
    liftIO $ hRunTermOutput ttyh term toutput



changeRight, changeLeft :: Int -> DrawM ()
changeRight n = do
    w <- asks width
    TermPos {termRow=r,termCol=c,termLastLine=l,eolPos=ep} <- get
    if c+n < M.findWithDefault w r ep || r == l
        -- Still not reach the EOL || This is the Last line on the screen
        then do
                put TermPos {termRow=r,termCol=c+n,termLastLine=l,eolPos=ep}
                output (right n)
        else do
        -- Reach or Over EOL need mapRight to calculate.
                let (r',c') = mapRight (r,c) w l ep n
                let linesDown = r'-r
                let newCol = c'
                put TermPos {termRow=r+linesDown, termCol=newCol,termLastLine=l, eolPos=ep}
                output $ cr <#> mreplicate linesDown nl <#> right newCol

mapRight::(M.Key,Int) -> Int -> Int -> M.IntMap Int -> Int -> (M.Key,Int)
mapRight (r,c) w l m n
        |r >= 0 && c >= 0  = do
                if c + n <= findD r m || r == l
                        then (r,c+n)
                        else mapRight (r+1,0) w l m (c + n-(findD r m)-1)
        |True =  (0,0)
        where
                findD r' m' = M.findWithDefault (-1) r' m'
                      
changeLeft n = do
    TermPos {termRow=r,termCol=c,termLastLine=l,eolPos=ep} <- get
    if c - n >= 0
        then do 
                put TermPos {termRow = r,termCol = c-n,termLastLine=l,eolPos=ep}
                output (left n)
        else do      
                let (r',c') = mapLeft (r,c) n ep
                let linesUp = r - r'
                let newCol = c'
                put TermPos {termRow = r - linesUp, termCol=newCol,termLastLine=l,eolPos=ep}
                output $ cr <#> up linesUp <#> right newCol

mapLeft::(M.Key,Int) -> Int -> M.IntMap Int -> (M.Key,Int)
mapLeft (r,c) n m = do 
        if c-n >= 0
                then do 
                        if r < 0
                                then (0,0)
                                else (r,c-n)
                else do if r < 0
                                then (0,0)
                                else mapLeft (r-1,findD (r-1) m) (n-c-1) m
        where
                findD r' m' = M.findWithDefault (-1) r' m' 
              
-- TODO: I think if we wrap this all up in one call to output, it'll be faster...
printText :: [Grapheme] -> DrawM ()
printText [] = return ()
printText xs = fillLine xs >>= printText

-- Draws as much of the string as possible in the line, and returns the rest.
-- If we fill up the line completely, wrap to the next row.
fillLine :: [Grapheme] -> DrawM [Grapheme]
fillLine str = do
    w <- asks width
    TermPos {termRow=r,termCol=c,termLastLine=l,eolPos=ep} <- get
    let roomLeft = w - c -- Cell Room still Left for Print
    if graphemeWidth str < roomLeft
        then do
                posixEncode (graphemesToString str) >>= output . text
                put TermPos{termRow=r, termCol=c+graphemeWidth str,termLastLine=r,eolPos=M.insert r (c + graphemeWidth str-1) ep}
                return []
        else do -- Line Changer, set or fix thisLine's eolPos, set termLastLine 
                let (thisLine,rest) = graphemeSplitAt roomLeft str --splitAt dosen't fit for variable width sting, use graphemeSplitAt here.
                bstr <- posixEncode (graphemesToString thisLine)
                output (text bstr <#> wrapLine)
                case (thisLine,rest) of
                        ([],_) ->  put TermPos {termRow=r+1,termCol=0,termLastLine=r+1,eolPos=M.insert r (w-roomLeft-1) ep}
                        (ts,_) ->  put TermPos {termRow=r+1,termCol=0,termLastLine=r+1,eolPos=M.insert r (c + graphemeWidth ts - 1) ep}
                return rest

drawLineDiffT :: LineChars -> LineChars -> DrawM ()
drawLineDiffT (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of
    ([],[])     | ys1 == ys2            -> return ()
    (xs1',[])   | xs1' ++ ys1 == ys2    -> changeLeft (graphemeWidth xs1')
    ([],xs2')   | ys1 == xs2' ++ ys2    -> changeRight (graphemeWidth xs2')
    (xs1',xs2')                         -> do
        changeLeft (graphemeWidth xs1')
        printText (xs2' ++ ys2)
        let m = graphemeWidth xs1' + graphemeWidth ys1 - (graphemeWidth xs2' + graphemeWidth ys2)
        clearDeadText m
        changeLeft (graphemeWidth ys2)
        
graphemeWidth::[Grapheme]->Int
graphemeWidth wc = sum $ map (wcwidth . baseChar) wc

--Split String which contain Wide Char at a properly point,
--Use room left as much as possible.
graphemeSplitAt::Int -> [Grapheme] -> ([Grapheme],[Grapheme])
graphemeSplitAt roomleft wcstr = (take splitPoint wcstr,drop splitPoint wcstr)
        where
                splitPoint = countWhileSumLQ roomleft widthMap 0
                widthMap = map (wcwidth . baseChar) wcstr
                countWhileSumLQ _ [] counter = counter -- Count while sum up width just less than or equal as 'n'
                countWhileSumLQ n (x:xs) counter = if n-x >= 0 
                                                        then countWhileSumLQ (n-x) xs (counter + 1)
                                                        else counter

linesLeft :: Layout -> TermPos -> Int -> Int
linesLeft Layout {width=w} TermPos {termCol = c} n
    | c + n < w = 1
    | otherwise = 1 + div (c+n) w

lsLinesLeft :: Layout -> TermPos -> LineChars -> Int
lsLinesLeft layout pos = linesLeft layout pos . lengthToEnd

clearDeadText :: Int -> DrawM ()
clearDeadText n
    | n <= 0    = return ()
    | otherwise = do
        layout <- ask
        pos <- get
        let numLinesToClear = linesLeft layout pos n
        output clearToLineEnd
        when (numLinesToClear > 1) $ output $ mconcat [
                    mreplicate (numLinesToClear - 1) 
                            $ nl <#> clearToLineEnd
                    , up (numLinesToClear - 1)
                    , right (termCol pos)]

clearLayoutT :: DrawM ()
clearLayoutT = do
    h <- asks height
    output (clearAll h)
    put initTermPos

moveToNextLineT :: LineChars -> DrawM ()
moveToNextLineT s = do
    pos <- get
    layout <- ask
    output $ mreplicate (lsLinesLeft layout pos s) nl
    put initTermPos

repositionT :: Layout -> LineChars -> DrawM ()
repositionT oldLayout s = do
    oldPos <- get
    let l = lsLinesLeft oldLayout oldPos s - 1
    output $ cr <#> mreplicate l nl
            <#> mreplicate (l + termRow oldPos) (clearToLineEnd <#> up 1)
    put initTermPos
    drawLineDiffT ([],[]) s

instance (MonadException m, MonadReader Layout m) => Term (Draw m) where
    drawLineDiff = drawLineDiffT
    reposition = repositionT
    
    printLines [] = return ()
    printLines ls = do
        bls <- mapM posixEncode ls
        output $ mconcat $ intersperse nl (map text bls) ++ [nl]
    clearLayout = clearLayoutT
    moveToNextLine = moveToNextLineT
    ringBell True = output bellAudible
    ringBell False = output bellVisual