#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 Capability Bool -> (Bool -> Capability ()) -> Capability ()
forall a b. Capability a -> (a -> Capability b) -> Capability b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Capability ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard

    leftA' <- Capability (Int -> TermOutput)
forall s. TermStr s => Capability (Int -> s)
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 (leftA' 1)
    return Actions{leftA = leftA', rightA = rightA',upA = upA',
                clearToLineEnd = clearToLineEnd', nl = nl',cr = cr',
                bellAudible = bellAudible', bellVisual = bellVisual',
                clearAllA = clearAll',
                 wrapLine = 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 Capability Bool -> (Bool -> Capability ()) -> Capability ()
forall a b. Capability a -> (a -> Capability b) -> Capability b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Capability ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
    TermOutput -> Capability TermOutput
forall a. a -> Capability a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> TermOutput
termText String
" " TermOutput -> TermOutput -> TermOutput
forall m. Monoid m => m -> m -> m
<#> TermOutput
left1)
    ) Capability TermOutput
-> Capability TermOutput -> Capability TermOutput
forall a. Capability a -> Capability a -> Capability a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` TermOutput -> Capability TermOutput
forall a. a -> Capability a
forall (m :: * -> *) a. Monad m => a -> m a
return TermOutput
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
(Int -> TermPos -> ShowS)
-> (TermPos -> String) -> ([TermPos] -> ShowS) -> Show TermPos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TermPos -> ShowS
showsPrec :: Int -> TermPos -> ShowS
$cshow :: TermPos -> String
show :: TermPos -> String
$cshowList :: [TermPos] -> ShowS
showList :: [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
(Int -> TermRows -> ShowS)
-> (TermRows -> String) -> ([TermRows] -> ShowS) -> Show TermRows
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TermRows -> ShowS
showsPrec :: Int -> TermRows -> ShowS
$cshow :: TermRows -> String
show :: TermRows -> String
$cshowList :: [TermRows] -> ShowS
showList :: [TermRows] -> ShowS
Show

initTermRows :: TermRows
initTermRows :: TermRows
initTermRows = TermRows {rowLengths :: IntMap Int
rowLengths = IntMap Int
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 = Int -> Int -> IntMap Int -> IntMap Int
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 = Int -> Int -> IntMap Int -> Int
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 -> b) -> Draw m a -> Draw m b)
-> (forall a b. a -> Draw m b -> Draw m a) -> Functor (Draw m)
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
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Draw m a -> Draw m b
fmap :: forall a b. (a -> b) -> Draw m a -> Draw m b
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> Draw m b -> Draw m a
<$ :: forall a b. a -> Draw m b -> Draw m a
Functor, Functor (Draw m)
Functor (Draw m) =>
(forall a. a -> Draw m a)
-> (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 a b. Draw m a -> Draw m b -> Draw m b)
-> (forall a b. Draw m a -> Draw m b -> Draw m a)
-> Applicative (Draw m)
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
$cpure :: forall (m :: * -> *) a. Monad m => a -> Draw m a
pure :: forall a. a -> Draw m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
Draw m (a -> b) -> Draw m a -> Draw m b
<*> :: forall a b. Draw m (a -> b) -> Draw m a -> Draw m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Draw m a -> Draw m b -> Draw m c
liftA2 :: forall a b c. (a -> b -> c) -> Draw m a -> Draw m b -> Draw m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
Draw m a -> Draw m b -> Draw m b
*> :: 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 a
<* :: forall a b. Draw m a -> Draw m b -> Draw m a
Applicative, Applicative (Draw m)
Applicative (Draw m) =>
(forall a b. Draw m a -> (a -> Draw m b) -> Draw m b)
-> (forall a b. Draw m a -> Draw m b -> Draw m b)
-> (forall a. a -> Draw m a)
-> Monad (Draw m)
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
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
Draw m a -> (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 -> Draw m b -> Draw m b
>> :: forall a b. Draw m a -> Draw m b -> Draw m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> Draw m a
return :: forall a. a -> Draw m a
Monad, Monad (Draw m)
Monad (Draw m) => (forall a. IO a -> Draw m a) -> MonadIO (Draw m)
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
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> Draw m a
liftIO :: forall a. IO a -> Draw m a
MonadIO,
              MonadCatch (Draw m)
MonadCatch (Draw m) =>
(forall b.
 HasCallStack =>
 ((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b)
-> (forall b.
    HasCallStack =>
    ((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b)
-> (forall a b c.
    HasCallStack =>
    Draw m a
    -> (a -> ExitCase b -> Draw m c)
    -> (a -> Draw m b)
    -> Draw m (b, c))
-> MonadMask (Draw m)
forall b.
HasCallStack =>
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
forall a b c.
HasCallStack =>
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, HasCallStack) =>
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
Draw m a
-> (a -> ExitCase b -> Draw m c)
-> (a -> Draw m b)
-> Draw m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
mask :: forall b.
HasCallStack =>
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
$cgeneralBracket :: forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
Draw m a
-> (a -> ExitCase b -> Draw m c)
-> (a -> Draw m b)
-> Draw m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
Draw m a
-> (a -> ExitCase b -> Draw m c)
-> (a -> Draw m b)
-> Draw m (b, c)
MonadMask, Monad (Draw m)
Monad (Draw m) =>
(forall e a. (HasCallStack, Exception e) => e -> Draw m a)
-> MonadThrow (Draw m)
forall e a. (HasCallStack, Exception e) => e -> Draw m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (Draw m)
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> Draw m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> Draw m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> Draw m a
MonadThrow, MonadThrow (Draw m)
MonadThrow (Draw m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 Draw m a -> (e -> Draw m a) -> Draw m a)
-> MonadCatch (Draw m)
forall e a.
(HasCallStack, Exception e) =>
Draw m a -> (e -> Draw m a) -> Draw m a
forall (m :: * -> *). MonadCatch m => MonadThrow (Draw m)
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
Draw m a -> (e -> Draw m a) -> Draw m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
Draw m a -> (e -> Draw m a) -> Draw m a
catch :: forall e a.
(HasCallStack, 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 = ReaderT
  Actions
  (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
  a
-> Draw m a
forall (m :: * -> *) a.
ReaderT
  Actions
  (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
  a
-> Draw m a
Draw (ReaderT
   Actions
   (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
   a
 -> Draw m a)
-> (m a
    -> ReaderT
         Actions
         (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
         a)
-> m a
-> Draw m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))) a
-> ReaderT
     Actions
     (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
     a
forall (m :: * -> *) a. Monad m => m a -> ReaderT Actions m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))) a
 -> ReaderT
      Actions
      (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
      a)
-> (m a
    -> ReaderT
         Terminal (StateT TermRows (StateT TermPos (PosixT m))) a)
-> m a
-> ReaderT
     Actions
     (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT TermRows (StateT TermPos (PosixT m)) a
-> ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT Terminal m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TermRows (StateT TermPos (PosixT m)) a
 -> ReaderT
      Terminal (StateT TermRows (StateT TermPos (PosixT m))) a)
-> (m a -> StateT TermRows (StateT TermPos (PosixT m)) a)
-> m a
-> ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT TermPos (PosixT m) a
-> StateT TermRows (StateT TermPos (PosixT m)) a
forall (m :: * -> *) a. Monad m => m a -> StateT TermRows m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TermPos (PosixT m) a
 -> StateT TermRows (StateT TermPos (PosixT m)) a)
-> (m a -> StateT TermPos (PosixT m) a)
-> m a
-> StateT TermRows (StateT TermPos (PosixT m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PosixT m a -> StateT TermPos (PosixT m) a
forall (m :: * -> *) a. Monad m => m a -> StateT TermPos m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (PosixT m a -> StateT TermPos (PosixT m) a)
-> (m a -> PosixT m a) -> m a -> StateT TermPos (PosixT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> PosixT m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT Handles m a
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 a. Draw m a -> PosixT m a)
-> (forall a. PosixT m a -> Draw m a) -> EvalTerm (PosixT m)
forall (m :: * -> *) (n :: * -> *).
(Term n, CommandMonad n) =>
(forall a. n a -> m a) -> (forall a. m a -> n a) -> EvalTerm m
EvalTerm Draw m a -> PosixT m a
forall a. Draw m a -> PosixT m a
eval PosixT m a -> Draw m a
forall a. PosixT m a -> Draw m a
liftE
  where
    liftE :: PosixT m a -> Draw m a
liftE = ReaderT
  Actions
  (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
  a
-> Draw m a
forall (m :: * -> *) a.
ReaderT
  Actions
  (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
  a
-> Draw m a
Draw (ReaderT
   Actions
   (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
   a
 -> Draw m a)
-> (PosixT m a
    -> ReaderT
         Actions
         (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
         a)
-> PosixT m a
-> Draw m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))) a
-> ReaderT
     Actions
     (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
     a
forall (m :: * -> *) a. Monad m => m a -> ReaderT Actions m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))) a
 -> ReaderT
      Actions
      (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
      a)
-> (PosixT m a
    -> ReaderT
         Terminal (StateT TermRows (StateT TermPos (PosixT m))) a)
-> PosixT m a
-> ReaderT
     Actions
     (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT TermRows (StateT TermPos (PosixT m)) a
-> ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT Terminal m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TermRows (StateT TermPos (PosixT m)) a
 -> ReaderT
      Terminal (StateT TermRows (StateT TermPos (PosixT m))) a)
-> (PosixT m a -> StateT TermRows (StateT TermPos (PosixT m)) a)
-> PosixT m a
-> ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT TermPos (PosixT m) a
-> StateT TermRows (StateT TermPos (PosixT m)) a
forall (m :: * -> *) a. Monad m => m a -> StateT TermRows m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TermPos (PosixT m) a
 -> StateT TermRows (StateT TermPos (PosixT m)) a)
-> (PosixT m a -> StateT TermPos (PosixT m) a)
-> PosixT m a
-> StateT TermRows (StateT TermPos (PosixT m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PosixT m a -> StateT TermPos (PosixT m) a
forall (m :: * -> *) a. Monad m => m a -> StateT TermPos m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
    eval :: Draw m a -> PosixT m a
eval = TermPos -> StateT TermPos (PosixT m) a -> PosixT m a
forall (m :: * -> *) s a. Monad m => s -> StateT s m a -> m a
evalStateT' TermPos
initTermPos
                            (StateT TermPos (PosixT m) a -> PosixT m a)
-> (Draw m a -> StateT TermPos (PosixT m) a)
-> Draw m a
-> PosixT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermRows
-> StateT TermRows (StateT TermPos (PosixT m)) a
-> StateT TermPos (PosixT m) a
forall (m :: * -> *) s a. Monad m => s -> StateT s m a -> m a
evalStateT' TermRows
initTermRows
                            (StateT TermRows (StateT TermPos (PosixT m)) a
 -> StateT TermPos (PosixT m) a)
-> (Draw m a -> StateT TermRows (StateT TermPos (PosixT m)) a)
-> Draw m a
-> StateT TermPos (PosixT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Terminal
-> ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))) a
-> StateT TermRows (StateT TermPos (PosixT m)) a
forall r (m :: * -> *) a. r -> ReaderT r m a -> m a
runReaderT' Terminal
term
                            (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))) a
 -> StateT TermRows (StateT TermPos (PosixT m)) a)
-> (Draw m a
    -> ReaderT
         Terminal (StateT TermRows (StateT TermPos (PosixT m))) a)
-> Draw m a
-> StateT TermRows (StateT TermPos (PosixT m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Actions
-> ReaderT
     Actions
     (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
     a
-> ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))) a
forall r (m :: * -> *) a. r -> ReaderT r m a -> m a
runReaderT' Actions
actions
                            (ReaderT
   Actions
   (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
   a
 -> ReaderT
      Terminal (StateT TermRows (StateT TermPos (PosixT m))) a)
-> (Draw m a
    -> ReaderT
         Actions
         (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
         a)
-> Draw m a
-> ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Draw m a
-> ReaderT
     Actions
     (ReaderT Terminal (StateT TermRows (StateT TermPos (PosixT m))))
     a
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
    mterm <- IO (Either SetupTermError Terminal)
-> MaybeT IO (Either SetupTermError Terminal)
forall a. IO a -> MaybeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SetupTermError Terminal)
 -> MaybeT IO (Either SetupTermError Terminal))
-> IO (Either SetupTermError Terminal)
-> MaybeT IO (Either SetupTermError Terminal)
forall a b. (a -> b) -> a -> b
$ IO Terminal -> IO (Either SetupTermError Terminal)
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try IO Terminal
setupTermFromEnv
    case mterm of
        Left (SetupTermError
_::SetupTermError) -> MaybeT IO RunTerm
forall a. MaybeT IO a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Right Terminal
term -> do
            actions <- IO (Maybe Actions) -> MaybeT IO Actions
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Actions) -> MaybeT IO Actions)
-> IO (Maybe Actions) -> MaybeT IO Actions
forall a b. (a -> b) -> a -> b
$ Maybe Actions -> IO (Maybe Actions)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Actions -> IO (Maybe Actions))
-> Maybe Actions -> IO (Maybe Actions)
forall a b. (a -> b) -> a -> b
$ Terminal -> Capability Actions -> Maybe Actions
forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
term Capability Actions
getActions
            liftIO $ posixRunTerm h (posixLayouts h ++ [tinfoLayout term])
                (terminfoKeys term)
                (wrapKeypad (ehOut h) term)
                (evalDraw term 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 Capability TermOutput
forall s. TermStr s => Capability s
keypadOn m () -> m a -> m a
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
f)
                            m a -> m () -> m a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` Capability TermOutput -> m ()
maybeOutput Capability TermOutput
forall s. TermStr s => Capability s
keypadOff
  where
    maybeOutput :: Capability TermOutput -> m ()
maybeOutput = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (Capability TermOutput -> IO ())
-> Capability TermOutput
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Terminal -> TermOutput -> IO ()
hRunTermOutput Handle
h Terminal
term (TermOutput -> IO ())
-> (Capability TermOutput -> TermOutput)
-> Capability TermOutput
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                            TermOutput -> Maybe TermOutput -> TermOutput
forall a. a -> Maybe a -> a
fromMaybe TermOutput
forall a. Monoid a => a
mempty (Maybe TermOutput -> TermOutput)
-> (Capability TermOutput -> Maybe TermOutput)
-> Capability TermOutput
-> TermOutput
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Terminal -> Capability TermOutput -> Maybe TermOutput
forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
term

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

terminfoKeys :: Terminal -> [(String,Key)]
terminfoKeys :: Terminal -> [(String, Key)]
terminfoKeys Terminal
term = ((Capability String, Key) -> Maybe (String, Key))
-> [(Capability String, Key)] -> [(String, Key)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Capability String, Key) -> Maybe (String, Key)
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
                            keys <- Terminal -> Capability a -> Maybe a
forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
term Capability a
cap
                            return (keys,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 (BaseKey -> Key) -> BaseKey -> Key
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
    (x,action) <- ActionT (Draw m) a -> Draw m (a, TermAction)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Writer.runWriterT ActionT (Draw m) a
m
    toutput <- asks action
    term <- ask
    ttyh <- liftM ehOut ask
    liftIO $ hRunTermOutput ttyh term toutput
    return x

output :: TermAction -> ActionM ()
output :: TermAction -> ActionM ()
output TermAction
t = TermAction -> WriterT TermAction (Draw m) ()
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 (TermOutput -> TermAction
forall a b. a -> b -> a
const (String -> TermOutput
termText String
s))

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

clearAll :: LinesAffected -> TermAction
clearAll :: Int -> TermAction
clearAll = (Actions -> Int -> TermOutput) -> Int -> TermAction
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = m
forall a. Monoid a => a
mempty
    | Bool
otherwise = m
m m -> m -> m
forall m. Monoid m => m -> m -> m
`mappend` Int -> m -> m
forall m. Monoid m => Int -> m -> m
mreplicate (Int
nInt -> Int -> Int
forall 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 = TermAction
forall a. Monoid a => a
mempty
spaces Int
1 = TermOutput -> TermAction
forall a b. a -> b -> a
const (TermOutput -> TermAction) -> TermOutput -> TermAction
forall a b. (a -> b) -> a -> b
$ String -> TermOutput
termText String
" " -- share when possible
spaces Int
n = TermOutput -> TermAction
forall a b. a -> b -> a
const (TermOutput -> TermAction) -> TermOutput -> TermAction
forall a b. (a -> b) -> a -> b
$ String -> TermOutput
termText (String -> TermOutput) -> String -> TermOutput
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
r2 = if Int
c1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
c2 then Int -> TermAction
right (Int
c2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
c1) else Int -> TermAction
left (Int
c1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
c2)
    | Int
r1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
r2 = TermAction
cr TermAction -> TermAction -> TermAction
forall m. Monoid m => m -> m -> m
<#> Int -> TermAction
up (Int
r1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
r2) TermAction -> TermAction -> TermAction
forall m. Monoid m => m -> m -> m
<#> Int -> TermAction
right Int
c2
    | Bool
otherwise = TermAction
cr TermAction -> TermAction -> TermAction
forall m. Monoid m => m -> m -> m
<#> Int -> TermAction -> TermAction
forall m. Monoid m => Int -> m -> m
mreplicate (Int
r2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
r1) TermAction
nl TermAction -> TermAction -> TermAction
forall m. Monoid m => m -> m -> m
<#> Int -> TermAction
right Int
c2

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

moveRelative :: Int -> ActionM ()
moveRelative :: Int -> ActionM ()
moveRelative Int
n = (Layout -> TermRows -> TermPos -> TermPos)
-> WriterT TermAction (Draw m) Layout
-> WriterT TermAction (Draw m) TermRows
-> WriterT TermAction (Draw m) TermPos
-> WriterT TermAction (Draw m) TermPos
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) WriterT TermAction (Draw m) Layout
forall r (m :: * -> *). MonadReader r m => m r
ask WriterT TermAction (Draw m) TermRows
forall s (m :: * -> *). MonadState s m => m s
get WriterT TermAction (Draw m) TermPos
forall s (m :: * -> *). MonadState s m => m s
get
                    WriterT TermAction (Draw m) TermPos
-> (TermPos -> WriterT TermAction (Draw m) ())
-> WriterT TermAction (Draw m) ()
forall a b.
WriterT TermAction (Draw m) a
-> (a -> WriterT TermAction (Draw m) b)
-> WriterT TermAction (Draw m) b
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = () -> WriterT TermAction (Draw m) ()
forall a. a -> WriterT TermAction (Draw m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                | Bool
otherwise = Int -> ActionM ()
moveRelative Int
n
changeLeft :: Int -> ActionM ()
changeLeft Int
n    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = () -> WriterT TermAction (Draw m) ()
forall a. a -> WriterT TermAction (Draw m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                | Bool
otherwise = Int -> ActionM ()
moveRelative (Int -> Int
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 (Int -> TermPos) -> Int -> TermPos
forall a b. (a -> b) -> a -> b
$ Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
posIndex
  where
    posIndex :: Int
posIndex = TermPos -> Int
termCol TermPos
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
sum' ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (TermRows -> Int -> Int
lookupCells TermRows
rs)
                                            [Int
0..TermPos -> Int
termRow TermPos
pInt -> Int -> Int
forall 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 Int -> TermPos -> TermPos
forall a b. a -> b -> b
`seq` Int
m Int -> TermPos -> TermPos
forall a b. a -> b -> b
`seq` let
        thisRowSize :: Int
thisRowSize = TermRows -> Int -> Int
lookupCells TermRows
rs Int
r
        in if Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
thisRowSize
                Bool -> Bool -> Bool
|| (Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
thisRowSize Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w)
                Bool -> Bool -> Bool
|| Int
thisRowSize Int -> Int -> Bool
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
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
thisRowSize)

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

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

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

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

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

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

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

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

moveToNextLineT :: ActionM ()
moveToNextLineT :: ActionM ()
moveToNextLineT = do
    lleft <- ActionT (Draw m) Int
ActionM Int
getLinesLeft
    output $ mreplicate (lleft+1) nl
    put initTermPos
    put initTermRows

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

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