#if __GLASGOW_HASKELL__ < 802
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif
module System.Console.Haskeline.Backend.Terminfo(
                            Draw(),
                            runTerminfoDraw
                            )
                             where

import System.Console.Terminfo
import Control.Monad
import Control.Monad.Catch
import Data.List(foldl')
import System.IO
import qualified Control.Exception as Exception
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.IntMap as Map

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.Backend.WCWidth
import System.Console.Haskeline.Key

import qualified Control.Monad.Trans.Writer as Writer

----------------------------------------------------------------
-- Low-level terminal output

-- | 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 {Actions -> Int -> TermOutput
leftA, Actions -> Int -> TermOutput
rightA, Actions -> Int -> TermOutput
upA :: Int -> TermOutput,
                        TermAction
clearToLineEnd :: TermOutput,
                        TermAction
nl, TermAction
cr :: TermOutput,
                        TermAction
bellAudible,TermAction
bellVisual :: TermOutput,
                        Actions -> Int -> TermOutput
clearAllA :: LinesAffected -> TermOutput,
                        TermAction
wrapLine :: TermOutput}

getActions :: Capability Actions
getActions :: Capability Actions
getActions = do
    -- This capability is not strictly necessary, but is very widely supported
    -- and assuming it makes for a much simpler implementation of printText.
    Capability Bool
autoRightMargin forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *). Alternative f => Bool -> f ()
guard

    Int -> TermOutput
leftA' <- forall s. TermStr s => Capability (Int -> s)
moveLeft
    Int -> TermOutput
rightA' <- forall s. TermStr s => Capability (Int -> s)
moveRight
    Int -> TermOutput
upA' <- forall s. TermStr s => Capability (Int -> s)
moveUp
    TermOutput
clearToLineEnd' <- forall s. TermStr s => Capability s
clearEOL
    Int -> TermOutput
clearAll' <- Capability (Int -> TermOutput)
clearScreen
    TermOutput
nl' <- forall s. TermStr s => Capability s
newline
    TermOutput
cr' <- forall s. TermStr s => Capability s
carriageReturn
    -- Don't require the bell capabilities
    TermOutput
bellAudible' <- forall s. TermStr s => Capability s
bell forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
    TermOutput
bellVisual' <- Capability TermOutput
visualBell forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
    TermOutput
wrapLine' <- TermOutput -> Capability TermOutput
getWrapLine (Int -> TermOutput
leftA' Int
1)
    forall (m :: * -> *) a. Monad m => a -> m a
return Actions{leftA :: Int -> TermOutput
leftA = Int -> TermOutput
leftA', rightA :: Int -> TermOutput
rightA = Int -> TermOutput
rightA',upA :: Int -> TermOutput
upA = Int -> TermOutput
upA',
                clearToLineEnd :: TermOutput
clearToLineEnd = TermOutput
clearToLineEnd', nl :: TermOutput
nl = TermOutput
nl',cr :: TermOutput
cr = TermOutput
cr',
                bellAudible :: TermOutput
bellAudible = TermOutput
bellAudible', bellVisual :: TermOutput
bellVisual = TermOutput
bellVisual',
                clearAllA :: Int -> TermOutput
clearAllA = Int -> TermOutput
clearAll',
                 wrapLine :: TermOutput
wrapLine = TermOutput
wrapLine'}

-- If the wraparound glitch is in effect, force a wrap by printing a space.
-- Otherwise, it'll wrap automatically.
getWrapLine :: TermOutput -> Capability TermOutput
getWrapLine :: TermOutput -> Capability TermOutput
getWrapLine TermOutput
left1 = (do
    Capability Bool
wraparoundGlitch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *). Alternative f => Bool -> f ()
guard
    forall (m :: * -> *) a. Monad m => a -> m a
return (String -> TermOutput
termText String
" " forall m. Monoid m => m -> m -> m
<#> TermOutput
left1)
    ) forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty

----------------------------------------------------------------
-- The Draw monad

-- denote in modular arithmetic;
-- in particular, 0 <= termCol < width
data TermPos = TermPos {TermPos -> Int
termRow,TermPos -> Int
termCol :: !Int}
    deriving Int -> TermPos -> ShowS
[TermPos] -> ShowS
TermPos -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TermPos] -> ShowS
$cshowList :: [TermPos] -> ShowS
show :: TermPos -> String
$cshow :: TermPos -> String
showsPrec :: Int -> TermPos -> ShowS
$cshowsPrec :: Int -> TermPos -> ShowS
Show

initTermPos :: TermPos
initTermPos :: TermPos
initTermPos = TermPos {termRow :: Int
termRow = Int
0, termCol :: Int
termCol = Int
0}

data TermRows = TermRows {
                    TermRows -> IntMap Int
rowLengths :: !(Map.IntMap Int),
                    -- ^ The length of each nonempty row
                    TermRows -> Int
lastRow :: !Int
                    -- ^ The last nonempty row, or zero if the entire line
                    -- is empty.  Note that when the cursor wraps to the first
                    -- column of the next line, termRow > lastRow.
                         }
    deriving Int -> TermRows -> ShowS
[TermRows] -> ShowS
TermRows -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TermRows] -> ShowS
$cshowList :: [TermRows] -> ShowS
show :: TermRows -> String
$cshow :: TermRows -> String
showsPrec :: Int -> TermRows -> ShowS
$cshowsPrec :: Int -> TermRows -> ShowS
Show

initTermRows :: TermRows
initTermRows :: TermRows
initTermRows = TermRows {rowLengths :: IntMap Int
rowLengths = forall a. IntMap a
Map.empty, lastRow :: Int
lastRow=Int
0}

setRow :: Int -> Int -> TermRows -> TermRows
setRow :: Int -> Int -> TermRows -> TermRows
setRow Int
r Int
len TermRows
rs = TermRows {rowLengths :: IntMap Int
rowLengths = forall a. Int -> a -> IntMap a -> IntMap a
Map.insert Int
r Int
len (TermRows -> IntMap Int
rowLengths TermRows
rs),
                            lastRow :: Int
lastRow=Int
r}

lookupCells :: TermRows -> Int -> Int
lookupCells :: TermRows -> Int -> Int
lookupCells (TermRows IntMap Int
rc Int
_) Int
r = forall a. a -> Int -> IntMap a -> a
Map.findWithDefault Int
0 Int
r IntMap Int
rc

newtype Draw m a = Draw {forall (m :: * -> *) a.
Draw m a
-> ReaderT
     Actions
     (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
     a
unDraw :: (ReaderT Actions
                                    (ReaderT Terminal
                                    (StateT TermRows
                                    (StateT TermPos
                                    (PosixT m))))) a}
    deriving (forall a b. a -> Draw m b -> Draw m a
forall a b. (a -> b) -> Draw m a -> Draw m b
forall (m :: * -> *) a b. Functor m => a -> Draw m b -> Draw m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Draw m a -> Draw m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Draw m b -> Draw m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> Draw m b -> Draw m a
fmap :: forall a b. (a -> b) -> Draw m a -> Draw m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Draw m a -> Draw m b
Functor, forall a. a -> Draw m a
forall a b. Draw m a -> Draw m b -> Draw m a
forall a b. Draw m a -> Draw m b -> Draw m b
forall a b. Draw m (a -> b) -> Draw m a -> Draw m b
forall a b c. (a -> b -> c) -> Draw m a -> Draw m b -> Draw m c
forall {m :: * -> *}. Monad m => Functor (Draw m)
forall (m :: * -> *) a. Monad m => a -> Draw m a
forall (m :: * -> *) a b.
Monad m =>
Draw m a -> Draw m b -> Draw m a
forall (m :: * -> *) a b.
Monad m =>
Draw m a -> Draw m b -> Draw m b
forall (m :: * -> *) a b.
Monad m =>
Draw m (a -> b) -> Draw m a -> Draw m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Draw m a -> Draw m b -> Draw m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Draw m a -> Draw m b -> Draw m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
Draw m a -> Draw m b -> Draw m a
*> :: forall a b. Draw m a -> Draw m b -> Draw m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
Draw m a -> Draw m b -> Draw m b
liftA2 :: forall a b c. (a -> b -> c) -> Draw m a -> Draw m b -> Draw m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Draw m a -> Draw m b -> Draw m c
<*> :: forall a b. Draw m (a -> b) -> Draw m a -> Draw m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
Draw m (a -> b) -> Draw m a -> Draw m b
pure :: forall a. a -> Draw m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> Draw m a
Applicative, forall a. a -> Draw m a
forall a b. Draw m a -> Draw m b -> Draw m b
forall a b. Draw m a -> (a -> Draw m b) -> Draw m b
forall (m :: * -> *). Monad m => Applicative (Draw m)
forall (m :: * -> *) a. Monad m => a -> Draw m a
forall (m :: * -> *) a b.
Monad m =>
Draw m a -> Draw m b -> Draw m b
forall (m :: * -> *) a b.
Monad m =>
Draw m a -> (a -> Draw m b) -> Draw m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Draw m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> Draw m a
>> :: forall a b. Draw m a -> Draw m b -> Draw m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
Draw m a -> Draw m b -> Draw m b
>>= :: forall a b. Draw m a -> (a -> Draw m b) -> Draw m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
Draw m a -> (a -> Draw m b) -> Draw m b
Monad, forall a. IO a -> Draw m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (Draw m)
forall (m :: * -> *) a. MonadIO m => IO a -> Draw m a
liftIO :: forall a. IO a -> Draw m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> Draw m a
MonadIO,
              forall b.
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
forall a b c.
Draw m a
-> (a -> ExitCase b -> Draw m c)
-> (a -> Draw m b)
-> Draw m (b, c)
forall {m :: * -> *}. MonadMask m => MonadCatch (Draw m)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
forall (m :: * -> *) a b c.
MonadMask m =>
Draw m a
-> (a -> ExitCase b -> Draw m c)
-> (a -> Draw m b)
-> Draw m (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
Draw m a
-> (a -> ExitCase b -> Draw m c)
-> (a -> Draw m b)
-> Draw m (b, c)
$cgeneralBracket :: forall (m :: * -> *) a b c.
MonadMask m =>
Draw m a
-> (a -> ExitCase b -> Draw m c)
-> (a -> Draw m b)
-> Draw m (b, c)
uninterruptibleMask :: forall b.
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
mask :: forall b.
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
$cmask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
MonadMask, forall e a. Exception e => e -> Draw m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall {m :: * -> *}. MonadThrow m => Monad (Draw m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> Draw m a
throwM :: forall e a. Exception e => e -> Draw m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> Draw m a
MonadThrow, forall e a. Exception e => Draw m a -> (e -> Draw m a) -> Draw m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
forall {m :: * -> *}. MonadCatch m => MonadThrow (Draw m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
Draw m a -> (e -> Draw m a) -> Draw m a
catch :: forall e a. Exception e => Draw m a -> (e -> Draw m a) -> Draw m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
Draw m a -> (e -> Draw m a) -> Draw m a
MonadCatch,
              MonadReader Actions, MonadReader Terminal, MonadState TermPos,
              MonadState TermRows, MonadReader Handles)

instance MonadTrans Draw where
    lift :: forall (m :: * -> *) a. Monad m => m a -> Draw m a
lift = forall (m :: * -> *) a.
ReaderT
  Actions
  (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
  a
-> Draw m a
Draw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

evalDraw :: forall m . (MonadReader Layout m, CommandMonad m) => Terminal -> Actions -> EvalTerm (PosixT m)
evalDraw :: forall (m :: * -> *).
(MonadReader Layout m, CommandMonad m) =>
Terminal -> Actions -> EvalTerm (PosixT m)
evalDraw Terminal
term Actions
actions = forall (m :: * -> *) (n :: * -> *).
(Term n, CommandMonad n) =>
(forall a. n a -> m a) -> (forall a. m a -> n a) -> EvalTerm m
EvalTerm forall {a}. Draw m a -> PosixT m a
eval forall {a}. PosixT m a -> Draw m a
liftE
  where
    liftE :: PosixT m a -> Draw m a
liftE = forall (m :: * -> *) a.
ReaderT
  Actions
  (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
  a
-> Draw m a
Draw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
    eval :: Draw m a -> PosixT m a
eval = forall (m :: * -> *) s a. Monad m => s -> StateT s m a -> m a
evalStateT' TermPos
initTermPos
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) s a. Monad m => s -> StateT s m a -> m a
evalStateT' TermRows
initTermRows
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. r -> ReaderT r m a -> m a
runReaderT' Terminal
term
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. r -> ReaderT r m a -> m a
runReaderT' Actions
actions
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
Draw m a
-> ReaderT
     Actions
     (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
     a
unDraw 
 

runTerminfoDraw :: Handles -> MaybeT IO RunTerm
runTerminfoDraw :: Handles -> MaybeT IO RunTerm
runTerminfoDraw Handles
h = do
    Either SetupTermError Terminal
mterm <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
Exception.try IO Terminal
setupTermFromEnv
    case Either SetupTermError Terminal
mterm of
        Left (SetupTermError
_::SetupTermError) -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Right Terminal
term -> do
            Actions
actions <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
term Capability Actions
getActions
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handles
-> [IO (Maybe Layout)]
-> [(String, Key)]
-> (forall (m :: * -> *) b. (MonadIO m, MonadMask m) => m b -> m b)
-> (forall (m :: * -> *).
    (MonadMask m, CommandMonad m) =>
    EvalTerm (PosixT m))
-> IO RunTerm
posixRunTerm Handles
h (Handles -> [IO (Maybe Layout)]
posixLayouts Handles
h forall a. [a] -> [a] -> [a]
++ [Terminal -> IO (Maybe Layout)
tinfoLayout Terminal
term])
                (Terminal -> [(String, Key)]
terminfoKeys Terminal
term)
                (forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Handle -> Terminal -> m a -> m a
wrapKeypad (Handles -> Handle
ehOut Handles
h) Terminal
term)
                (forall (m :: * -> *).
(MonadReader Layout m, CommandMonad m) =>
Terminal -> Actions -> EvalTerm (PosixT m)
evalDraw Terminal
term Actions
actions)

-- If the keypad on/off capabilities are defined, wrap the computation with them.
wrapKeypad :: (MonadIO m, MonadMask m) => Handle -> Terminal -> m a -> m a
wrapKeypad :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Handle -> Terminal -> m a -> m a
wrapKeypad Handle
h Terminal
term m a
f = (Capability TermOutput -> m ()
maybeOutput forall s. TermStr s => Capability s
keypadOn forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
f)
                            forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` Capability TermOutput -> m ()
maybeOutput forall s. TermStr s => Capability s
keypadOff
  where
    maybeOutput :: Capability TermOutput -> m ()
maybeOutput = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Terminal -> TermOutput -> IO ()
hRunTermOutput Handle
h Terminal
term forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                            forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
term

tinfoLayout :: Terminal -> IO (Maybe Layout)
tinfoLayout :: Terminal -> IO (Maybe Layout)
tinfoLayout Terminal
term = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
term forall a b. (a -> b) -> a -> b
$ do
                        Int
c <- Capability Int
termColumns
                        Int
r <- Capability Int
termLines
                        forall (m :: * -> *) a. Monad m => a -> m a
return Layout {height :: Int
height=Int
r,width :: Int
width=Int
c}

terminfoKeys :: Terminal -> [(String,Key)]
terminfoKeys :: Terminal -> [(String, Key)]
terminfoKeys Terminal
term = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {b}. (Capability a, b) -> Maybe (a, b)
getSequence [(Capability String, Key)]
keyCapabilities
    where
        getSequence :: (Capability a, b) -> Maybe (a, b)
getSequence (Capability a
cap,b
x) = do
                            a
keys <- forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
term Capability a
cap
                            forall (m :: * -> *) a. Monad m => a -> m a
return (a
keys,b
x)
        keyCapabilities :: [(Capability String, Key)]
keyCapabilities =
                [(Capability String
keyLeft,      BaseKey -> Key
simpleKey BaseKey
LeftKey)
                ,(Capability String
keyRight,      BaseKey -> Key
simpleKey BaseKey
RightKey)
                ,(Capability String
keyUp,         BaseKey -> Key
simpleKey BaseKey
UpKey)
                ,(Capability String
keyDown,       BaseKey -> Key
simpleKey BaseKey
DownKey)
                ,(Capability String
keyBackspace,  BaseKey -> Key
simpleKey BaseKey
Backspace)
                ,(Capability String
keyDeleteChar, BaseKey -> Key
simpleKey BaseKey
Delete)
                ,(Capability String
keyHome,       BaseKey -> Key
simpleKey BaseKey
Home)
                ,(Capability String
keyEnd,        BaseKey -> Key
simpleKey BaseKey
End)
                ,(Capability String
keyPageDown,   BaseKey -> Key
simpleKey BaseKey
PageDown)
                ,(Capability String
keyPageUp,     BaseKey -> Key
simpleKey BaseKey
PageUp)
                ,(Capability String
keyEnter,      BaseKey -> Key
simpleKey forall a b. (a -> b) -> a -> b
$ Char -> BaseKey
KeyChar Char
'\n')
                ]

    

----------------------------------------------------------------
-- Terminal output actions
--
-- We combine all of the drawing commands into one big TermAction,
-- via a writer monad, and then output them all at once.
-- This prevents flicker, i.e., the cursor appearing briefly
-- in an intermediate position.

type TermAction = Actions -> TermOutput

type ActionT = Writer.WriterT TermAction

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

runActionT :: MonadIO m => ActionT (Draw m) a -> Draw m a
runActionT :: forall (m :: * -> *) a. MonadIO m => ActionT (Draw m) a -> Draw m a
runActionT ActionT (Draw m) a
m = do
    (a
x,TermAction
action) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Writer.runWriterT ActionT (Draw m) a
m
    TermOutput
toutput <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TermAction
action
    Terminal
term <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Handle
ttyh <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Handles -> Handle
ehOut forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Terminal -> TermOutput -> IO ()
hRunTermOutput Handle
ttyh Terminal
term TermOutput
toutput
    forall (m :: * -> *) a. Monad m => a -> m a
return a
x

output :: TermAction -> ActionM ()
output :: TermAction -> ActionM ()
output TermAction
t = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell TermAction
t  -- NB: explicit argument enables build with ghc-6.12.3
                          -- (Probably related to the monomorphism restriction;
                          -- see GHC ticket #1749).

outputText :: String -> ActionM ()
outputText :: String -> ActionM ()
outputText String
s = TermAction -> ActionM ()
output (forall a b. a -> b -> a
const (String -> TermOutput
termText String
s))

left,right,up :: Int -> TermAction
left :: Int -> TermAction
left = forall a b c. (a -> b -> c) -> b -> a -> c
flip Actions -> Int -> TermOutput
leftA
right :: Int -> TermAction
right = forall a b c. (a -> b -> c) -> b -> a -> c
flip Actions -> Int -> TermOutput
rightA
up :: Int -> TermAction
up = forall a b c. (a -> b -> c) -> b -> a -> c
flip Actions -> Int -> TermOutput
upA

clearAll :: LinesAffected -> TermAction
clearAll :: Int -> TermAction
clearAll = forall a b c. (a -> b -> c) -> b -> a -> c
flip Actions -> Int -> TermOutput
clearAllA

mreplicate :: Monoid m => Int -> m -> m
mreplicate :: forall m. Monoid m => Int -> m -> m
mreplicate Int
n m
m
    | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0    = forall a. Monoid a => a
mempty
    | Bool
otherwise = m
m forall m. Monoid m => m -> m -> m
`mappend` forall m. Monoid m => Int -> m -> m
mreplicate (Int
nforall a. Num a => a -> a -> a
-Int
1) m
m

-- We don't need to bother encoding the spaces.
spaces :: Int -> TermAction
spaces :: Int -> TermAction
spaces Int
0 = forall a. Monoid a => a
mempty
spaces Int
1 = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ String -> TermOutput
termText String
" " -- share when possible
spaces Int
n = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ String -> TermOutput
termText forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
n Char
' '


changePos :: TermPos -> TermPos -> TermAction
changePos :: TermPos -> TermPos -> TermAction
changePos TermPos {termRow :: TermPos -> Int
termRow=Int
r1, termCol :: TermPos -> Int
termCol=Int
c1} TermPos {termRow :: TermPos -> Int
termRow=Int
r2, termCol :: TermPos -> Int
termCol=Int
c2}
    | Int
r1 forall a. Eq a => a -> a -> Bool
== Int
r2 = if Int
c1 forall a. Ord a => a -> a -> Bool
< Int
c2 then Int -> TermAction
right (Int
c2forall a. Num a => a -> a -> a
-Int
c1) else Int -> TermAction
left (Int
c1forall a. Num a => a -> a -> a
-Int
c2)
    | Int
r1 forall a. Ord a => a -> a -> Bool
> Int
r2 = TermAction
cr forall m. Monoid m => m -> m -> m
<#> Int -> TermAction
up (Int
r1forall a. Num a => a -> a -> a
-Int
r2) forall m. Monoid m => m -> m -> m
<#> Int -> TermAction
right Int
c2
    | Bool
otherwise = TermAction
cr forall m. Monoid m => m -> m -> m
<#> forall m. Monoid m => Int -> m -> m
mreplicate (Int
r2forall a. Num a => a -> a -> a
-Int
r1) TermAction
nl forall m. Monoid m => m -> m -> m
<#> Int -> TermAction
right Int
c2

moveToPos :: TermPos -> ActionM ()
moveToPos :: TermPos -> ActionM ()
moveToPos TermPos
p = do
    TermPos
oldP <- forall s (m :: * -> *). MonadState s m => m s
get
    forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos
p
    TermAction -> ActionM ()
output forall a b. (a -> b) -> a -> b
$ TermPos -> TermPos -> TermAction
changePos TermPos
oldP TermPos
p

moveRelative :: Int -> ActionM ()
moveRelative :: Int -> ActionM ()
moveRelative Int
n = forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (Int -> Layout -> TermRows -> TermPos -> TermPos
advancePos Int
n) forall r (m :: * -> *). MonadReader r m => m r
ask forall s (m :: * -> *). MonadState s m => m s
get forall s (m :: * -> *). MonadState s m => m s
get
                    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TermPos
p -> TermPos -> ActionM ()
moveToPos TermPos
p

-- Note that these move by a certain number of cells, not graphemes.
changeRight, changeLeft :: Int -> ActionM ()
changeRight :: Int -> ActionM ()
changeRight Int
n   | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
                | Bool
otherwise = Int -> ActionM ()
moveRelative Int
n
changeLeft :: Int -> ActionM ()
changeLeft Int
n    | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
                | Bool
otherwise = Int -> ActionM ()
moveRelative (forall a. Num a => a -> a
negate Int
n)


-- TODO: this could be more efficient by only checking intermediate rows.
-- TODO: this is worth handling with QuickCheck.
advancePos :: Int -> Layout -> TermRows -> TermPos -> TermPos
advancePos :: Int -> Layout -> TermRows -> TermPos -> TermPos
advancePos Int
k Layout {width :: Layout -> Int
width=Int
w} TermRows
rs TermPos
p = Int -> TermPos
indexToPos forall a b. (a -> b) -> a -> b
$ Int
k forall a. Num a => a -> a -> a
+ Int
posIndex
  where
    posIndex :: Int
posIndex = TermPos -> Int
termCol TermPos
p forall a. Num a => a -> a -> a
+ [Int] -> Int
sum' (forall a b. (a -> b) -> [a] -> [b]
map (TermRows -> Int -> Int
lookupCells TermRows
rs)
                                            [Int
0..TermPos -> Int
termRow TermPos
pforall a. Num a => a -> a -> a
-Int
1])
    indexToPos :: Int -> TermPos
indexToPos Int
n = Int -> Int -> TermPos
loopFindRow Int
0 Int
n
    loopFindRow :: Int -> Int -> TermPos
loopFindRow Int
r Int
m = Int
r seq :: forall a b. a -> b -> b
`seq` Int
m seq :: forall a b. a -> b -> b
`seq` let
        thisRowSize :: Int
thisRowSize = TermRows -> Int -> Int
lookupCells TermRows
rs Int
r
        in if Int
m forall a. Ord a => a -> a -> Bool
< Int
thisRowSize
                Bool -> Bool -> Bool
|| (Int
m forall a. Eq a => a -> a -> Bool
== Int
thisRowSize Bool -> Bool -> Bool
&& Int
m forall a. Ord a => a -> a -> Bool
< Int
w)
                Bool -> Bool -> Bool
|| Int
thisRowSize forall a. Ord a => a -> a -> Bool
<= Int
0 -- This shouldn't happen in practice,
                                    -- but double-check to prevent an infinite loop
                then TermPos {termRow :: Int
termRow=Int
r, termCol :: Int
termCol=Int
m}
                else Int -> Int -> TermPos
loopFindRow (Int
rforall a. Num a => a -> a -> a
+Int
1) (Int
mforall a. Num a => a -> a -> a
-Int
thisRowSize)

sum' :: [Int] -> Int
sum' :: [Int] -> Int
sum' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) Int
0

----------------------------------------------------------------
-- Text printing actions

printText :: [Grapheme] -> ActionM ()
printText :: [Grapheme] -> ActionM ()
printText [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
printText [Grapheme]
gs = do
    -- First, get the monadic parameters:
    Int
w <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Layout -> Int
width
    TermPos {termRow :: TermPos -> Int
termRow=Int
r, termCol :: TermPos -> Int
termCol=Int
c} <- forall s (m :: * -> *). MonadState s m => m s
get
    -- Now, split off as much as will fit on the rest of this row:
    let ([Grapheme]
thisLine,[Grapheme]
rest,Int
thisWidth) = Int -> [Grapheme] -> ([Grapheme], [Grapheme], Int)
splitAtWidth (Int
wforall a. Num a => a -> a -> a
-Int
c) [Grapheme]
gs
    let lineWidth :: Int
lineWidth = Int
c forall a. Num a => a -> a -> a
+ Int
thisWidth
    -- Finally, actually print out the relevant text.
    String -> ActionM ()
outputText ([Grapheme] -> String
graphemesToString [Grapheme]
thisLine)
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ Int -> Int -> TermRows -> TermRows
setRow Int
r Int
lineWidth
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Grapheme]
rest Bool -> Bool -> Bool
&& Int
lineWidth forall a. Ord a => a -> a -> Bool
< Int
w
        then  -- everything fits on one line without wrapping
            forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos {termRow :: Int
termRow=Int
r, termCol :: Int
termCol=Int
lineWidth}
        else do -- Must wrap to the next line
            forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos {termRow :: Int
termRow=Int
rforall a. Num a => a -> a -> a
+Int
1,termCol :: Int
termCol=Int
0}
            TermAction -> ActionM ()
output forall a b. (a -> b) -> a -> b
$ if Int
lineWidth forall a. Eq a => a -> a -> Bool
== Int
w then TermAction
wrapLine else Int -> TermAction
spaces (Int
wforall a. Num a => a -> a -> a
-Int
lineWidth)
            [Grapheme] -> ActionM ()
printText [Grapheme]
rest

----------------------------------------------------------------
-- High-level Term implementation

drawLineDiffT :: LineChars -> LineChars -> ActionM ()
drawLineDiffT :: LineChars -> LineChars -> ActionM ()
drawLineDiffT ([Grapheme]
xs1,[Grapheme]
ys1) ([Grapheme]
xs2,[Grapheme]
ys2) = case forall a. Eq a => [a] -> [a] -> ([a], [a])
matchInit [Grapheme]
xs1 [Grapheme]
xs2 of
    ([],[])     | [Grapheme]
ys1 forall a. Eq a => a -> a -> Bool
== [Grapheme]
ys2            -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ([Grapheme]
xs1',[])   | [Grapheme]
xs1' forall a. [a] -> [a] -> [a]
++ [Grapheme]
ys1 forall a. Eq a => a -> a -> Bool
== [Grapheme]
ys2    -> Int -> ActionM ()
changeLeft ([Grapheme] -> Int
gsWidth [Grapheme]
xs1')
    ([],[Grapheme]
xs2')   | [Grapheme]
ys1 forall a. Eq a => a -> a -> Bool
== [Grapheme]
xs2' forall a. [a] -> [a] -> [a]
++ [Grapheme]
ys2    -> Int -> ActionM ()
changeRight ([Grapheme] -> Int
gsWidth [Grapheme]
xs2')
    ([Grapheme]
xs1',[Grapheme]
xs2')                         -> do
        TermRows
oldRS <- forall s (m :: * -> *). MonadState s m => m s
get
        Int -> ActionM ()
changeLeft ([Grapheme] -> Int
gsWidth [Grapheme]
xs1')
        [Grapheme] -> ActionM ()
printText [Grapheme]
xs2'
        TermPos
p <- forall s (m :: * -> *). MonadState s m => m s
get
        [Grapheme] -> ActionM ()
printText [Grapheme]
ys2
        TermRows -> ActionM ()
clearDeadText TermRows
oldRS
        TermPos -> ActionM ()
moveToPos TermPos
p

-- The number of nonempty lines after the current row position.
getLinesLeft :: ActionM Int
getLinesLeft :: ActionM Int
getLinesLeft = do
    TermPos
p <- forall s (m :: * -> *). MonadState s m => m s
get
    TermRows
rc <- forall s (m :: * -> *). MonadState s m => m s
get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Int
0 (TermRows -> Int
lastRow TermRows
rc forall a. Num a => a -> a -> a
- TermPos -> Int
termRow TermPos
p)

clearDeadText :: TermRows -> ActionM ()
clearDeadText :: TermRows -> ActionM ()
clearDeadText TermRows
oldRS = do
    TermPos {termRow :: TermPos -> Int
termRow = Int
r, termCol :: TermPos -> Int
termCol = Int
c} <- forall s (m :: * -> *). MonadState s m => m s
get
    let extraRows :: Int
extraRows = TermRows -> Int
lastRow TermRows
oldRS forall a. Num a => a -> a -> a
- Int
r
    if Int
extraRows forall a. Ord a => a -> a -> Bool
< Int
0
            Bool -> Bool -> Bool
|| (Int
extraRows forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& TermRows -> Int -> Int
lookupCells TermRows
oldRS Int
r forall a. Ord a => a -> a -> Bool
<= Int
c)
        then forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ Int -> Int -> TermRows -> TermRows
setRow Int
r Int
c
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
extraRows forall a. Eq a => a -> a -> Bool
/= Int
0)
                forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos {termRow :: Int
termRow = Int
r forall a. Num a => a -> a -> a
+ Int
extraRows, termCol :: Int
termCol=Int
0}
            TermAction -> ActionM ()
output forall a b. (a -> b) -> a -> b
$ TermAction
clearToLineEnd forall m. Monoid m => m -> m -> m
<#> forall m. Monoid m => Int -> m -> m
mreplicate Int
extraRows (TermAction
nl forall m. Monoid m => m -> m -> m
<#> TermAction
clearToLineEnd)

clearLayoutT :: ActionM ()
clearLayoutT :: ActionM ()
clearLayoutT = do
    Int
h <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Layout -> Int
height
    TermAction -> ActionM ()
output (Int -> TermAction
clearAll Int
h)
    forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos
initTermPos

moveToNextLineT :: ActionM ()
moveToNextLineT :: ActionM ()
moveToNextLineT = do
    Int
lleft <- ActionM Int
getLinesLeft
    TermAction -> ActionM ()
output forall a b. (a -> b) -> a -> b
$ forall m. Monoid m => Int -> m -> m
mreplicate (Int
lleftforall a. Num a => a -> a -> a
+Int
1) TermAction
nl
    forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos
initTermPos
    forall s (m :: * -> *). MonadState s m => s -> m ()
put TermRows
initTermRows

repositionT :: Layout -> LineChars -> ActionM ()
repositionT :: Layout -> LineChars -> ActionM ()
repositionT Layout
_ LineChars
s = do
    TermPos
oldPos <- forall s (m :: * -> *). MonadState s m => m s
get
    Int
l <- ActionM Int
getLinesLeft
    TermAction -> ActionM ()
output forall a b. (a -> b) -> a -> b
$ TermAction
cr forall m. Monoid m => m -> m -> m
<#> forall m. Monoid m => Int -> m -> m
mreplicate Int
l TermAction
nl
            forall m. Monoid m => m -> m -> m
<#> forall m. Monoid m => Int -> m -> m
mreplicate (Int
l forall a. Num a => a -> a -> a
+ TermPos -> Int
termRow TermPos
oldPos) (TermAction
clearToLineEnd forall m. Monoid m => m -> m -> m
<#> Int -> TermAction
up Int
1)
    forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos
initTermPos
    forall s (m :: * -> *). MonadState s m => s -> m ()
put TermRows
initTermRows
    LineChars -> LineChars -> ActionM ()
drawLineDiffT ([],[]) LineChars
s

instance (MonadIO m, MonadMask m, MonadReader Layout m) => Term (Draw m) where
    drawLineDiff :: LineChars -> LineChars -> Draw m ()
drawLineDiff LineChars
xs LineChars
ys = forall (m :: * -> *) a. MonadIO m => ActionT (Draw m) a -> Draw m a
runActionT forall a b. (a -> b) -> a -> b
$ LineChars -> LineChars -> ActionM ()
drawLineDiffT LineChars
xs LineChars
ys
    reposition :: Layout -> LineChars -> Draw m ()
reposition Layout
layout LineChars
lc = forall (m :: * -> *) a. MonadIO m => ActionT (Draw m) a -> Draw m a
runActionT forall a b. (a -> b) -> a -> b
$ Layout -> LineChars -> ActionM ()
repositionT Layout
layout LineChars
lc
    
    printLines :: [String] -> Draw m ()
printLines = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a b. (a -> b) -> a -> b
$ \String
line -> forall (m :: * -> *) a. MonadIO m => ActionT (Draw m) a -> Draw m a
runActionT forall a b. (a -> b) -> a -> b
$ do
                                    String -> ActionM ()
outputText String
line
                                    TermAction -> ActionM ()
output TermAction
nl
    clearLayout :: Draw m ()
clearLayout = forall (m :: * -> *) a. MonadIO m => ActionT (Draw m) a -> Draw m a
runActionT ActionM ()
clearLayoutT
    moveToNextLine :: LineChars -> Draw m ()
moveToNextLine LineChars
_ = forall (m :: * -> *) a. MonadIO m => ActionT (Draw m) a -> Draw m a
runActionT ActionM ()
moveToNextLineT
    ringBell :: Bool -> Draw m ()
ringBell Bool
True = forall (m :: * -> *) a. MonadIO m => ActionT (Draw m) a -> Draw m a
runActionT forall a b. (a -> b) -> a -> b
$ TermAction -> ActionM ()
output TermAction
bellAudible
    ringBell Bool
False = forall (m :: * -> *) a. MonadIO m => ActionT (Draw m) a -> Draw m a
runActionT forall a b. (a -> b) -> a -> b
$ TermAction -> ActionM ()
output TermAction
bellVisual