#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
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
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
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
TermOutput
bellAudible' <- Capability TermOutput
forall s. TermStr s => Capability s
bell 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
TermOutput
bellVisual' <- Capability TermOutput
visualBell 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
TermOutput
wrapLine' <- TermOutput -> Capability TermOutput
getWrapLine (Int -> TermOutput
leftA' Int
1)
Actions -> Capability Actions
forall a. a -> Capability a
forall (m :: * -> *) a. Monad m => a -> m a
return Actions{leftA :: Int -> TermOutput
leftA = Int -> TermOutput
leftA', rightA :: Int -> TermOutput
rightA = Int -> TermOutput
rightA',upA :: Int -> TermOutput
upA = Int -> TermOutput
upA',
clearToLineEnd :: TermOutput
clearToLineEnd = TermOutput
clearToLineEnd', nl :: TermOutput
nl = TermOutput
nl',cr :: TermOutput
cr = TermOutput
cr',
bellAudible :: TermOutput
bellAudible = TermOutput
bellAudible', bellVisual :: TermOutput
bellVisual = TermOutput
bellVisual',
clearAllA :: Int -> TermOutput
clearAllA = Int -> TermOutput
clearAll',
wrapLine :: TermOutput
wrapLine = TermOutput
wrapLine'}
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
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),
TermRows -> Int
lastRow :: !Int
}
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.
((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)
forall b.
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
forall a b c.
Draw m a
-> (a -> ExitCase b -> Draw m c)
-> (a -> Draw m b)
-> Draw m (b, c)
forall {m :: * -> *}. MonadMask m => MonadCatch (Draw m)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
forall (m :: * -> *) a b c.
MonadMask m =>
Draw m a
-> (a -> ExitCase b -> Draw m c)
-> (a -> Draw m b)
-> Draw m (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
mask :: forall b.
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
uninterruptibleMask :: forall b.
((forall a. Draw m a -> Draw m a) -> Draw m b) -> Draw m b
$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)
generalBracket :: forall a b c.
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. 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
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> Draw m a
throwM :: forall e a. Exception e => e -> Draw m a
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)
forall e a. 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, 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
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
Draw m a -> (e -> Draw m a) -> Draw m a
catch :: forall e a. Exception e => Draw m a -> (e -> Draw m a) -> Draw m a
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
Either SetupTermError Terminal
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 Either SetupTermError Terminal
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
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
IO RunTerm -> MaybeT IO RunTerm
forall a. IO a -> MaybeT IO a
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)
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. 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
Int
c <- Capability Int
termColumns
Int
r <- Capability Int
termLines
Layout -> Capability Layout
forall a. a -> Capability a
forall (m :: * -> *) a. Monad m => a -> m a
return Layout {height :: Int
height=Int
r,width :: Int
width=Int
c}
terminfoKeys :: Terminal -> [(String,Key)]
terminfoKeys :: Terminal -> [(String, Key)]
terminfoKeys Terminal
term = ((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 a. a -> Maybe a
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')
]
type TermAction = Actions -> TermOutput
type ActionT = Writer.WriterT TermAction
type ActionM a = forall m . (MonadReader Layout m, MonadIO m) => ActionT (Draw m) a
runActionT :: MonadIO m => ActionT (Draw m) a -> Draw m a
runActionT :: forall (m :: * -> *) a. MonadIO m => ActionT (Draw m) a -> Draw m a
runActionT ActionT (Draw m) a
m = do
(a
x,TermAction
action) <- 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
TermOutput
toutput <- TermAction -> Draw m TermOutput
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TermAction
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 a. IO a -> Draw m a
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 a. a -> Draw m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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
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
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
" "
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
TermPos
oldP <- WriterT TermAction (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
TermAction -> ActionM ()
output (TermAction -> ActionM ()) -> TermAction -> ActionM ()
forall a b. (a -> b) -> a -> b
$ TermPos -> TermPos -> TermAction
changePos TermPos
oldP TermPos
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
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)
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
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
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
Int
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 :: TermPos -> Int
termRow=Int
r, termCol :: TermPos -> Int
termCol=Int
c} <- WriterT TermAction (Draw m) TermPos
forall s (m :: * -> *). MonadState s m => m s
get
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
String -> ActionM ()
outputText ([Grapheme] -> String
graphemesToString [Grapheme]
thisLine)
(TermRows -> TermRows) -> WriterT TermAction (Draw m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TermRows -> TermRows) -> WriterT TermAction (Draw m) ())
-> (TermRows -> TermRows) -> WriterT TermAction (Draw m) ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> TermRows -> TermRows
setRow Int
r Int
lineWidth
if [Grapheme] -> Bool
forall a. [a] -> 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
TermPos -> WriterT TermAction (Draw m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos {termRow :: Int
termRow=Int
r, termCol :: Int
termCol=Int
lineWidth}
else do
TermPos -> WriterT TermAction (Draw m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos {termRow :: Int
termRow=Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,termCol :: Int
termCol=Int
0}
TermAction -> ActionM ()
output (TermAction -> ActionM ()) -> TermAction -> ActionM ()
forall a b. (a -> b) -> a -> b
$ if Int
lineWidth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
w then TermAction
wrapLine else Int -> TermAction
spaces (Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
lineWidth)
[Grapheme] -> ActionM ()
printText [Grapheme]
rest
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
TermRows
oldRS <- WriterT TermAction (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 TermAction (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
getLinesLeft :: ActionM Int
getLinesLeft :: ActionM Int
getLinesLeft = do
TermPos
p <- WriterT TermAction (Draw m) TermPos
forall s (m :: * -> *). MonadState s m => m s
get
TermRows
rc <- WriterT TermAction (Draw m) TermRows
forall s (m :: * -> *). MonadState s m => m s
get
Int -> ActionT (Draw m) Int
forall a. a -> WriterT TermAction (Draw m) a
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 TermAction (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 a. a -> WriterT TermAction (Draw m) a
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 {termRow :: Int
termRow = Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
extraRows, termCol :: Int
termCol=Int
0}
TermAction -> ActionM ()
output (TermAction -> ActionM ()) -> TermAction -> ActionM ()
forall a b. (a -> b) -> a -> b
$ TermAction
clearToLineEnd TermAction -> TermAction -> TermAction
forall m. Monoid m => m -> m -> m
<#> Int -> TermAction -> TermAction
forall m. Monoid m => Int -> m -> m
mreplicate Int
extraRows (TermAction
nl TermAction -> TermAction -> TermAction
forall m. Monoid m => m -> m -> m
<#> TermAction
clearToLineEnd)
clearLayoutT :: ActionM ()
clearLayoutT :: ActionM ()
clearLayoutT = do
Int
h <- (Layout -> Int) -> WriterT TermAction (Draw m) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Layout -> Int
height
TermAction -> ActionM ()
output (Int -> TermAction
clearAll Int
h)
TermPos -> ActionT (Draw m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TermPos
initTermPos
moveToNextLineT :: ActionM ()
moveToNextLineT :: ActionM ()
moveToNextLineT = do
Int
lleft <- ActionT (Draw m) Int
ActionM Int
getLinesLeft
TermAction -> ActionM ()
output (TermAction -> ActionM ()) -> TermAction -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Int -> TermAction -> TermAction
forall m. Monoid m => Int -> m -> m
mreplicate (Int
lleftInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) TermAction
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 TermAction (Draw m) TermPos
forall s (m :: * -> *). MonadState s m => m s
get
Int
l <- ActionT (Draw m) Int
ActionM Int
getLinesLeft
TermAction -> ActionM ()
output (TermAction -> ActionM ()) -> TermAction -> ActionM ()
forall a b. (a -> b) -> a -> b
$ TermAction
cr TermAction -> TermAction -> TermAction
forall m. Monoid m => m -> m -> m
<#> Int -> TermAction -> TermAction
forall m. Monoid m => Int -> m -> m
mreplicate Int
l TermAction
nl
TermAction -> TermAction -> TermAction
forall m. Monoid m => m -> m -> m
<#> Int -> TermAction -> TermAction
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) (TermAction
clearToLineEnd TermAction -> TermAction -> TermAction
forall m. Monoid m => m -> m -> m
<#> Int -> TermAction
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
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