    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, catMaybes)
    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

    -- | 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 n = flip leftA n
    right n = flip rightA n
    up n = flip upA n

    clearAll :: LinesAffected -> TermAction
    clearAll la = flip clearAllA la

    --------

    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
    data TermPos = TermPos {termRow,termCol :: Int}
        deriving Show

    initTermPos :: TermPos
    initTermPos = TermPos {termRow = 0, termCol = 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)

    instance MonadReader Layout m => MonadReader Layout (Draw m) where
        ask = lift ask
        local r = Draw . local r . unDraw

    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]),
                        runTerm = \f ->
                                 runPosixT enc h
                                  $ evalStateT' initTermPos
                                  $ runReaderT' term
                                  $ runReaderT' actions
                                  $ unDraw
                                  $ wrapKeypad h term
                                  $ withPosixGetEvent ch enc (terminfoKeys term) 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 cap = liftIO $ hRunTermOutput h term $
                                fromMaybe mempty (getCapability term cap)

    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 = catMaybes $ map 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)
                    ]

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

    changeRight, changeLeft :: MonadLayout m => Int -> Draw m ()
    changeRight n = do
        w <- asks width
        TermPos {termRow=r,termCol=c} <- get
        if c+n < w
            then do
                    put TermPos {termRow=r,termCol=c+n}
                    output (right n)
            else do
                  let m = c+n
                  let linesDown = m `div` w
                  let newCol = m `rem` w
                  put TermPos {termRow=r+linesDown, termCol=newCol}
                  output $ cr <#> mreplicate linesDown nl <#> right newCol

    changeLeft n = do
        w <- asks width
        TermPos {termRow=r,termCol=c} <- get
        if c - n >= 0
            then do
                    put TermPos {termRow = r,termCol = c-n}
                    output (left n)
            else do
                    let m = n - c
                    let linesUp = 1 + ((m-1) `div` w)
                    let newCol = (-m) `mod` w -- mod returns positive #
                    put TermPos {termRow = r - linesUp, termCol=newCol}
                    output $ cr <#> up linesUp <#> right newCol

    -- TODO: I think if we wrap this all up in one call to output, it'll be faster...
    printText :: MonadLayout m => String -> Draw m ()
    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 :: MonadLayout m => String -> Draw m String
    fillLine str = do
        w <- asks width
        TermPos {termRow=r,termCol=c} <- get
        let roomLeft = w - c
        if length str < roomLeft
            then do
                    posixEncode str >>= output . text
                    put TermPos{termRow=r, termCol=c+length str}
                    return ""
            else do
                    let (thisLine,rest) = splitAt roomLeft str
                    bstr <- posixEncode thisLine
                    output (text bstr <#> wrapLine)
                    put TermPos {termRow=r+1,termCol=0}
                    return rest

    drawLineDiffT :: MonadLayout m => LineChars -> LineChars -> Draw m ()
    drawLineDiffT (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of
        ([],[])     | ys1 == ys2            -> return ()
        (xs1',[])   | xs1' ++ ys1 == ys2    -> changeLeft (length xs1')
        ([],xs2')   | ys1 == xs2' ++ ys2    -> changeRight (length xs2')
        (xs1',xs2')                         -> do
            changeLeft (length xs1')
            printText (xs2' ++ ys2)
            let m = length xs1' + length ys1 - (length xs2' + length ys2)
            clearDeadText m
            changeLeft (length ys2)

    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 s = linesLeft layout pos (lengthToEnd s)

    clearDeadText :: MonadLayout m => Int -> Draw m ()
    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 :: MonadLayout m => Draw m ()
    clearLayoutT = do
        h <- asks height
        output (clearAll h)
        put initTermPos

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

    repositionT :: (MonadLayout m, MonadException m) =>
                    Layout -> LineChars -> Draw m ()
    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, MonadLayout 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