#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,
                        Actions -> TermOutput
clearToLineEnd :: TermOutput,
                        Actions -> TermOutput
nl, Actions -> TermOutput
cr :: TermOutput,
                        Actions -> TermOutput
bellAudible,Actions -> TermOutput
bellVisual :: TermOutput,
                        Actions -> Int -> TermOutput
clearAllA :: LinesAffected -> TermOutput,
                        Actions -> TermOutput
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Capability ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard

    Int -> TermOutput
leftA' <- Capability (Int -> TermOutput)
forall s. TermStr s => Capability (Int -> s)
moveLeft
    Int -> TermOutput
rightA' <- Capability (Int -> TermOutput)
forall s. TermStr s => Capability (Int -> s)
moveRight
    Int -> TermOutput
upA' <- Capability (Int -> TermOutput)
forall s. TermStr s => Capability (Int -> s)
moveUp
    TermOutput
clearToLineEnd' <- Capability TermOutput
forall s. TermStr s => Capability s
clearEOL
    Int -> TermOutput
clearAll' <- Capability (Int -> TermOutput)
clearScreen
    TermOutput
nl' <- Capability TermOutput
forall s. TermStr s => Capability s
newline
    TermOutput
cr' <- Capability TermOutput
forall s. TermStr s => Capability s
carriageReturn
    -- Don't require the bell capabilities
    TermOutput
bellAudible' <- Capability TermOutput
forall s. TermStr s => Capability s
bell Capability TermOutput
-> Capability TermOutput -> Capability TermOutput
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` TermOutput -> Capability TermOutput
forall (m :: * -> *) a. Monad m => a -> m a
return TermOutput
forall a. Monoid a => a
mempty
    TermOutput
bellVisual' <- Capability TermOutput
visualBell Capability TermOutput
-> Capability TermOutput -> Capability TermOutput
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` TermOutput -> Capability TermOutput
forall (m :: * -> *) a. Monad m => a -> m a
return TermOutput
forall a. Monoid a => a
mempty
    TermOutput
wrapLine' <- TermOutput -> Capability TermOutput
getWrapLine (Int -> TermOutput
leftA' Int
1)
    Actions -> Capability Actions
forall (m :: * -> *) a. Monad m => a -> m a
return Actions :: (Int -> TermOutput)
-> (Int -> TermOutput)
-> (Int -> TermOutput)
-> TermOutput
-> TermOutput
-> TermOutput
-> TermOutput
-> TermOutput
-> (Int -> TermOutput)
-> TermOutput
-> Actions
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 Capability Bool -> (Bool -> Capability ()) -> Capability ()
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 (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 (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` TermOutput -> Capability TermOutput
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
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 :: Int -> Int -> TermPos
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
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 :: IntMap Int -> Int -> TermRows
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 :: IntMap Int -> Int -> TermRows
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 {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 (a -> Draw m b -> Draw m a
(a -> b) -> Draw m a -> Draw m b
(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
<$ :: a -> Draw m b -> Draw m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> Draw m b -> Draw m a
fmap :: (a -> b) -> Draw m a -> Draw m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Draw m a -> Draw m b
Functor, Functor (Draw m)
a -> Draw m a
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)
Draw m a -> Draw m b -> Draw m b
Draw m a -> Draw m b -> Draw m a
Draw m (a -> b) -> Draw m a -> Draw m b
(a -> b -> c) -> Draw m a -> Draw m b -> Draw m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> Draw m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> Draw m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (Draw m)
Applicative, Applicative (Draw m)
a -> Draw m a
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)
Draw m a -> (a -> Draw m b) -> Draw m b
Draw m a -> Draw m b -> Draw m b
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 :: a -> Draw m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> Draw m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (Draw m)
Monad, Monad (Draw m)
Monad (Draw m) -> (forall a. IO a -> Draw m a) -> MonadIO (Draw m)
IO a -> Draw m a
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 :: IO a -> Draw m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> Draw m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (Draw m)
MonadIO,
              MonadCatch (Draw m)
MonadCatch (Draw m)
-> (forall b.
    ((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b)
-> (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))
-> MonadMask (Draw m)
Draw m a
-> (a -> ExitCase b -> Draw m c)
-> (a -> Draw m b)
-> Draw m (b, c)
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
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 :: * -> *).
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
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)
generalBracket :: 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 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 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
$cp1MonadMask :: forall (m :: * -> *). MonadMask m => MonadCatch (Draw m)
MonadMask, Monad (Draw m)
e -> Draw m a
Monad (Draw m)
-> (forall e a. Exception e => e -> Draw m a)
-> MonadThrow (Draw m)
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 :: e -> Draw m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> Draw m a
$cp1MonadThrow :: forall (m :: * -> *). MonadThrow m => Monad (Draw m)
MonadThrow, MonadThrow (Draw m)
MonadThrow (Draw m)
-> (forall e a.
    Exception e =>
    Draw m a -> (e -> Draw m a) -> Draw m a)
-> MonadCatch (Draw m)
Draw m a -> (e -> Draw m a) -> Draw m a
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 :: 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
$cp1MonadCatch :: forall (m :: * -> *). MonadCatch m => MonadThrow (Draw m)
MonadCatch,
              MonadReader Actions, MonadReader Terminal, MonadState TermPos,
              MonadState TermRows, MonadReader Handles)

instance MonadTrans Draw where
    lift :: 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 (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 (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 (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
. ReaderT Handles m a -> StateT TermPos (PosixT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT Handles m a -> StateT TermPos (PosixT m) a)
-> (m a -> ReaderT Handles m a)
-> m a
-> StateT TermPos (PosixT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: 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 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 = 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 (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 (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 (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 (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
    Either SetupTermError Terminal
mterm <- IO (Either SetupTermError Terminal)
-> MaybeT IO (Either SetupTermError Terminal)
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 Either SetupTermError Terminal
mterm of
        Left (SetupTermError
_::SetupTermError) -> MaybeT IO RunTerm
forall (m :: * -> *) a. MonadPlus m => m a
mzero
        Right Terminal
term -> do
            Actions
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 (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
            IO RunTerm -> MaybeT IO RunTerm
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RunTerm -> MaybeT IO RunTerm)
-> IO RunTerm -> MaybeT IO RunTerm
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 [IO (Maybe Layout)] -> [IO (Maybe Layout)] -> [IO (Maybe Layout)]
forall a. [a] -> [a] -> [a]
++ [Terminal -> IO (Maybe Layout)
tinfoLayout Terminal
term])
                (Terminal -> [(String, Key)]
terminfoKeys Terminal
term)
                (Handle -> Terminal -> m b -> m b
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Handle -> Terminal -> m a -> m a
wrapKeypad (Handles -> Handle
ehOut Handles
h) Terminal
term)
                (Terminal -> Actions -> EvalTerm (PosixT m)
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 :: 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
f)
                            m a -> m () -> m a
forall (m :: * -> *) a b. 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 (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 (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
                        Int
c <- Capability Int
termColumns
                        Int
r <- Capability Int
termLines
                        Layout -> Capability Layout
forall (m :: * -> *) a. Monad m => a -> m a
return Layout :: Int -> Int -> Layout
Layout {height :: Int
height=Int
r,width :: Int
width=Int
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
                            a
keys <- Terminal -> Capability a -> Maybe a
forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
term Capability a
cap
                            (a, b) -> Maybe (a, b)
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 (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 :: ActionT (Draw m) a -> Draw m a
runActionT ActionT (Draw m) a
m = do
    (a
x,Actions -> TermOutput
action) <- ActionT (Draw m) a -> Draw m (a, Actions -> TermOutput)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
Writer.runWriterT ActionT (Draw m) a
m
    TermOutput
toutput <- (Actions -> TermOutput) -> Draw m TermOutput
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Actions -> TermOutput
action
    Terminal
term <- Draw m Terminal
forall r (m :: * -> *). MonadReader r m => m r
ask
    Handle
ttyh <- (Handles -> Handle) -> Draw m Handles -> Draw m Handle
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Handles -> Handle
ehOut Draw m Handles
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO () -> Draw m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Draw m ()) -> IO () -> Draw m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Terminal -> TermOutput -> IO ()
hRunTermOutput Handle
ttyh Terminal
term TermOutput
toutput
    a -> Draw m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

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

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

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

mreplicate :: Monoid m => Int -> m -> m
mreplicate :: 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 -> Actions -> TermOutput
spaces Int
0 = Actions -> TermOutput
forall a. Monoid a => a
mempty
spaces Int
1 = TermOutput -> Actions -> TermOutput
forall a b. a -> b -> a
const (TermOutput -> Actions -> TermOutput)
-> TermOutput -> Actions -> TermOutput
forall a b. (a -> b) -> a -> b
$ String -> TermOutput
termText String
" " -- share when possible
spaces Int
n = TermOutput -> Actions -> TermOutput
forall a b. a -> b -> a
const (TermOutput -> Actions -> TermOutput)
-> TermOutput -> Actions -> TermOutput
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 -> Actions -> TermOutput
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 -> Actions -> TermOutput
right (Int
c2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
c1) else Int -> Actions -> TermOutput
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 = Actions -> TermOutput
cr (Actions -> TermOutput)
-> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => m -> m -> m
<#> Int -> Actions -> TermOutput
up (Int
r1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
r2) (Actions -> TermOutput)
-> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => m -> m -> m
<#> Int -> Actions -> TermOutput
right Int
c2
    | Bool
otherwise = Actions -> TermOutput
cr (Actions -> TermOutput)
-> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => m -> m -> m
<#> Int -> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => Int -> m -> m
mreplicate (Int
r2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
r1) Actions -> TermOutput
nl (Actions -> TermOutput)
-> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => m -> m -> m
<#> Int -> Actions -> TermOutput
right Int
c2

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

moveRelative :: Int -> ActionM ()
moveRelative :: Int -> ActionM ()
moveRelative Int
n = (Layout -> TermRows -> TermPos -> TermPos)
-> WriterT (Actions -> TermOutput) (Draw m) Layout
-> WriterT (Actions -> TermOutput) (Draw m) TermRows
-> WriterT (Actions -> TermOutput) (Draw m) TermPos
-> WriterT (Actions -> TermOutput) (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 (Actions -> TermOutput) (Draw m) Layout
forall r (m :: * -> *). MonadReader r m => m r
ask WriterT (Actions -> TermOutput) (Draw m) TermRows
forall s (m :: * -> *). MonadState s m => m s
get WriterT (Actions -> TermOutput) (Draw m) TermPos
forall s (m :: * -> *). MonadState s m => m s
get
                    WriterT (Actions -> TermOutput) (Draw m) TermPos
-> (TermPos -> WriterT (Actions -> TermOutput) (Draw m) ())
-> WriterT (Actions -> TermOutput) (Draw m) ()
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 (Actions -> TermOutput) (Draw m) ()
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 (Actions -> TermOutput) (Draw m) ()
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
`seq` Int
m Int -> TermPos -> TermPos
`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 :: Int -> Int -> TermPos
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 (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 (Actions -> TermOutput) (Draw m) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
printText [Grapheme]
gs = do
    -- First, get the monadic parameters:
    Int
w <- (Layout -> Int) -> WriterT (Actions -> TermOutput) (Draw m) Int
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} <- WriterT (Actions -> TermOutput) (Draw m) TermPos
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
wInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
c) [Grapheme]
gs
    let lineWidth :: Int
lineWidth = Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
thisWidth
    -- Finally, actually print out the relevant text.
    String -> ActionM ()
outputText ([Grapheme] -> String
graphemesToString [Grapheme]
thisLine)
    (TermRows -> TermRows)
-> WriterT (Actions -> TermOutput) (Draw m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TermRows -> TermRows)
 -> WriterT (Actions -> TermOutput) (Draw m) ())
-> (TermRows -> TermRows)
-> WriterT (Actions -> TermOutput) (Draw m) ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> TermRows -> TermRows
setRow Int
r Int
lineWidth
    if [Grapheme] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Grapheme]
rest Bool -> Bool -> Bool
&& Int
lineWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w
        then  -- everything fits on one line without wrapping
            TermPos -> WriterT (Actions -> TermOutput) (Draw m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos :: Int -> Int -> TermPos
TermPos {termRow :: Int
termRow=Int
r, termCol :: Int
termCol=Int
lineWidth}
        else do -- Must wrap to the next line
            TermPos -> WriterT (Actions -> TermOutput) (Draw m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos :: Int -> Int -> TermPos
TermPos {termRow :: Int
termRow=Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,termCol :: Int
termCol=Int
0}
            (Actions -> TermOutput) -> ActionM ()
output ((Actions -> TermOutput) -> ActionM ())
-> (Actions -> TermOutput) -> ActionM ()
forall a b. (a -> b) -> a -> b
$ if Int
lineWidth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
w then Actions -> TermOutput
wrapLine else Int -> Actions -> TermOutput
spaces (Int
wInt -> Int -> Int
forall 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 [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 (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
        TermRows
oldRS <- WriterT (Actions -> TermOutput) (Draw m) TermRows
forall s (m :: * -> *). MonadState s m => m s
get
        Int -> ActionM ()
changeLeft ([Grapheme] -> Int
gsWidth [Grapheme]
xs1')
        [Grapheme] -> ActionM ()
printText [Grapheme]
xs2'
        TermPos
p <- WriterT (Actions -> TermOutput) (Draw m) TermPos
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 :: ActionT (Draw m) Int
getLinesLeft = do
    TermPos
p <- WriterT (Actions -> TermOutput) (Draw m) TermPos
forall s (m :: * -> *). MonadState s m => m s
get
    TermRows
rc <- WriterT (Actions -> TermOutput) (Draw m) TermRows
forall s (m :: * -> *). MonadState s m => m s
get
    Int -> ActionT (Draw m) Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ActionT (Draw m) Int) -> Int -> ActionT (Draw m) Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (TermRows -> Int
lastRow TermRows
rc Int -> Int -> Int
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} <- WriterT (Actions -> TermOutput) (Draw m) TermPos
forall s (m :: * -> *). MonadState s m => m s
get
    let extraRows :: Int
extraRows = TermRows -> Int
lastRow TermRows
oldRS Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r
    if Int
extraRows Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
            Bool -> Bool -> Bool
|| (Int
extraRows Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& TermRows -> Int -> Int
lookupCells TermRows
oldRS Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
c)
        then () -> ActionT (Draw m) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
            (TermRows -> TermRows) -> ActionT (Draw m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TermRows -> TermRows) -> ActionT (Draw m) ())
-> (TermRows -> TermRows) -> ActionT (Draw m) ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> TermRows -> TermRows
setRow Int
r Int
c
            Bool -> ActionT (Draw m) () -> ActionT (Draw m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
extraRows Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0)
                (ActionT (Draw m) () -> ActionT (Draw m) ())
-> ActionT (Draw m) () -> ActionT (Draw m) ()
forall a b. (a -> b) -> a -> b
$ TermPos -> ActionT (Draw m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos :: Int -> Int -> TermPos
TermPos {termRow :: Int
termRow = Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
extraRows, termCol :: Int
termCol=Int
0}
            (Actions -> TermOutput) -> ActionM ()
output ((Actions -> TermOutput) -> ActionM ())
-> (Actions -> TermOutput) -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Actions -> TermOutput
clearToLineEnd (Actions -> TermOutput)
-> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => m -> m -> m
<#> Int -> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => Int -> m -> m
mreplicate Int
extraRows (Actions -> TermOutput
nl (Actions -> TermOutput)
-> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => m -> m -> m
<#> Actions -> TermOutput
clearToLineEnd)

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

moveToNextLineT :: ActionM ()
moveToNextLineT :: ActionT (Draw m) ()
moveToNextLineT = do
    Int
lleft <- ActionT (Draw m) Int
ActionM Int
getLinesLeft
    (Actions -> TermOutput) -> ActionM ()
output ((Actions -> TermOutput) -> ActionM ())
-> (Actions -> TermOutput) -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Int -> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => Int -> m -> m
mreplicate (Int
lleftInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Actions -> TermOutput
nl
    TermPos -> ActionT (Draw m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos
initTermPos
    TermRows -> ActionT (Draw m) ()
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 <- WriterT (Actions -> TermOutput) (Draw m) TermPos
forall s (m :: * -> *). MonadState s m => m s
get
    Int
l <- ActionT (Draw m) Int
ActionM Int
getLinesLeft
    (Actions -> TermOutput) -> ActionM ()
output ((Actions -> TermOutput) -> ActionM ())
-> (Actions -> TermOutput) -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Actions -> TermOutput
cr (Actions -> TermOutput)
-> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => m -> m -> m
<#> Int -> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => Int -> m -> m
mreplicate Int
l Actions -> TermOutput
nl
            (Actions -> TermOutput)
-> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => m -> m -> m
<#> Int -> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => Int -> m -> m
mreplicate (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TermPos -> Int
termRow TermPos
oldPos) (Actions -> TermOutput
clearToLineEnd (Actions -> TermOutput)
-> (Actions -> TermOutput) -> Actions -> TermOutput
forall m. Monoid m => m -> m -> m
<#> Int -> Actions -> TermOutput
up Int
1)
    TermPos -> ActionT (Draw m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos
initTermPos
    TermRows -> ActionT (Draw m) ()
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 = 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
                                    (Actions -> TermOutput) -> ActionM ()
output Actions -> TermOutput
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
$ (Actions -> TermOutput) -> ActionM ()
output Actions -> TermOutput
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
$ (Actions -> TermOutput) -> ActionM ()
output Actions -> TermOutput
bellVisual