#if __GLASGOW_HASKELL__ < 802
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif
module System.Console.Haskeline.Backend.ANSILike
  ( Actions (..),
    ANSILike,
    runANSILike,
    liftPosixT,
    TermPos (..),
    TermRows (..),
    TermAction,
    output,
    outputText,
    drawLineDiffT,
    clearLayoutT,
    moveToNextLineT,
    repositionT,
    printLinesT,
    ringBellT,
  )
where

import Control.Monad
import Control.Monad.Catch
import Control.Monad.Trans.Writer (WriterT)
import qualified Control.Monad.Trans.Writer as Writer
import qualified Data.IntMap as Map
import Data.List (foldl')
import System.Console.Haskeline.Backend.Posix
import System.Console.Haskeline.Backend.WCWidth
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Monads as Monads
import System.Console.Haskeline.Term

data Actions a = Actions
  { forall a. Actions a -> Int -> a
leftA, forall a. Actions a -> Int -> a
rightA, forall a. Actions a -> Int -> a
upA :: Int -> a,
    forall a. Actions a -> a
clearToLineEnd :: a,
    forall a. Actions a -> a
nl, forall a. Actions a -> a
cr :: a,
    forall a. Actions a -> a
bellAudible, forall a. Actions a -> a
bellVisual :: a,
    forall a. Actions a -> Int -> a
clearAllA :: Int -> a,
    forall a. Actions a -> a
wrapLine :: a,
    forall a. Actions a -> String -> a
textA :: String -> a
  }

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

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

data TermRows = TermRows
  { -- | The length of each nonempty row
    TermRows -> IntMap Int
rowLengths :: !(Map.IntMap 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.
    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 ANSILike c m a = ANSILike
  {forall c (m :: * -> *) a.
ANSILike c m a
-> ReaderT
     (Actions c) (StateT TermRows (StateT TermPos (PosixT m))) a
unANSILike :: ReaderT (Actions c) (StateT TermRows (StateT TermPos (PosixT m))) a}
  deriving
    ( (forall a b. (a -> b) -> ANSILike c m a -> ANSILike c m b)
-> (forall a b. a -> ANSILike c m b -> ANSILike c m a)
-> Functor (ANSILike c m)
forall a b. a -> ANSILike c m b -> ANSILike c m a
forall a b. (a -> b) -> ANSILike c m a -> ANSILike c m b
forall c (m :: * -> *) a b.
Functor m =>
a -> ANSILike c m b -> ANSILike c m a
forall c (m :: * -> *) a b.
Functor m =>
(a -> b) -> ANSILike c m a -> ANSILike c 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 c (m :: * -> *) a b.
Functor m =>
(a -> b) -> ANSILike c m a -> ANSILike c m b
fmap :: forall a b. (a -> b) -> ANSILike c m a -> ANSILike c m b
$c<$ :: forall c (m :: * -> *) a b.
Functor m =>
a -> ANSILike c m b -> ANSILike c m a
<$ :: forall a b. a -> ANSILike c m b -> ANSILike c m a
Functor,
      Functor (ANSILike c m)
Functor (ANSILike c m) =>
(forall a. a -> ANSILike c m a)
-> (forall a b.
    ANSILike c m (a -> b) -> ANSILike c m a -> ANSILike c m b)
-> (forall a b c.
    (a -> b -> c)
    -> ANSILike c m a -> ANSILike c m b -> ANSILike c m c)
-> (forall a b. ANSILike c m a -> ANSILike c m b -> ANSILike c m b)
-> (forall a b. ANSILike c m a -> ANSILike c m b -> ANSILike c m a)
-> Applicative (ANSILike c m)
forall a. a -> ANSILike c m a
forall a b. ANSILike c m a -> ANSILike c m b -> ANSILike c m a
forall a b. ANSILike c m a -> ANSILike c m b -> ANSILike c m b
forall a b.
ANSILike c m (a -> b) -> ANSILike c m a -> ANSILike c m b
forall a b c.
(a -> b -> c) -> ANSILike c m a -> ANSILike c m b -> ANSILike c m c
forall c (m :: * -> *). Monad m => Functor (ANSILike c m)
forall c (m :: * -> *) a. Monad m => a -> ANSILike c m a
forall c (m :: * -> *) a b.
Monad m =>
ANSILike c m a -> ANSILike c m b -> ANSILike c m a
forall c (m :: * -> *) a b.
Monad m =>
ANSILike c m a -> ANSILike c m b -> ANSILike c m b
forall c (m :: * -> *) a b.
Monad m =>
ANSILike c m (a -> b) -> ANSILike c m a -> ANSILike c m b
forall c (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> ANSILike c m a -> ANSILike c m b -> ANSILike c 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 c (m :: * -> *) a. Monad m => a -> ANSILike c m a
pure :: forall a. a -> ANSILike c m a
$c<*> :: forall c (m :: * -> *) a b.
Monad m =>
ANSILike c m (a -> b) -> ANSILike c m a -> ANSILike c m b
<*> :: forall a b.
ANSILike c m (a -> b) -> ANSILike c m a -> ANSILike c m b
$cliftA2 :: forall c (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> ANSILike c m a -> ANSILike c m b -> ANSILike c m c
liftA2 :: forall a b c.
(a -> b -> c) -> ANSILike c m a -> ANSILike c m b -> ANSILike c m c
$c*> :: forall c (m :: * -> *) a b.
Monad m =>
ANSILike c m a -> ANSILike c m b -> ANSILike c m b
*> :: forall a b. ANSILike c m a -> ANSILike c m b -> ANSILike c m b
$c<* :: forall c (m :: * -> *) a b.
Monad m =>
ANSILike c m a -> ANSILike c m b -> ANSILike c m a
<* :: forall a b. ANSILike c m a -> ANSILike c m b -> ANSILike c m a
Applicative,
      Applicative (ANSILike c m)
Applicative (ANSILike c m) =>
(forall a b.
 ANSILike c m a -> (a -> ANSILike c m b) -> ANSILike c m b)
-> (forall a b. ANSILike c m a -> ANSILike c m b -> ANSILike c m b)
-> (forall a. a -> ANSILike c m a)
-> Monad (ANSILike c m)
forall a. a -> ANSILike c m a
forall a b. ANSILike c m a -> ANSILike c m b -> ANSILike c m b
forall a b.
ANSILike c m a -> (a -> ANSILike c m b) -> ANSILike c m b
forall c (m :: * -> *). Monad m => Applicative (ANSILike c m)
forall c (m :: * -> *) a. Monad m => a -> ANSILike c m a
forall c (m :: * -> *) a b.
Monad m =>
ANSILike c m a -> ANSILike c m b -> ANSILike c m b
forall c (m :: * -> *) a b.
Monad m =>
ANSILike c m a -> (a -> ANSILike c m b) -> ANSILike c 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 c (m :: * -> *) a b.
Monad m =>
ANSILike c m a -> (a -> ANSILike c m b) -> ANSILike c m b
>>= :: forall a b.
ANSILike c m a -> (a -> ANSILike c m b) -> ANSILike c m b
$c>> :: forall c (m :: * -> *) a b.
Monad m =>
ANSILike c m a -> ANSILike c m b -> ANSILike c m b
>> :: forall a b. ANSILike c m a -> ANSILike c m b -> ANSILike c m b
$creturn :: forall c (m :: * -> *) a. Monad m => a -> ANSILike c m a
return :: forall a. a -> ANSILike c m a
Monad,
      Monad (ANSILike c m)
Monad (ANSILike c m) =>
(forall a. IO a -> ANSILike c m a) -> MonadIO (ANSILike c m)
forall a. IO a -> ANSILike c m a
forall c (m :: * -> *). MonadIO m => Monad (ANSILike c m)
forall c (m :: * -> *) a. MonadIO m => IO a -> ANSILike c m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall c (m :: * -> *) a. MonadIO m => IO a -> ANSILike c m a
liftIO :: forall a. IO a -> ANSILike c m a
MonadIO,
      MonadCatch (ANSILike c m)
MonadCatch (ANSILike c m) =>
(forall b.
 HasCallStack =>
 ((forall a. ANSILike c m a -> ANSILike c m a) -> ANSILike c m b)
 -> ANSILike c m b)
-> (forall b.
    HasCallStack =>
    ((forall a. ANSILike c m a -> ANSILike c m a) -> ANSILike c m b)
    -> ANSILike c m b)
-> (forall a b c.
    HasCallStack =>
    ANSILike c m a
    -> (a -> ExitCase b -> ANSILike c m c)
    -> (a -> ANSILike c m b)
    -> ANSILike c m (b, c))
-> MonadMask (ANSILike c m)
forall b.
HasCallStack =>
((forall a. ANSILike c m a -> ANSILike c m a) -> ANSILike c m b)
-> ANSILike c m b
forall a b c.
HasCallStack =>
ANSILike c m a
-> (a -> ExitCase b -> ANSILike c m c)
-> (a -> ANSILike c m b)
-> ANSILike c m (b, c)
forall c (m :: * -> *). MonadMask m => MonadCatch (ANSILike c m)
forall c (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. ANSILike c m a -> ANSILike c m a) -> ANSILike c m b)
-> ANSILike c m b
forall c (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
ANSILike c m a
-> (a -> ExitCase b -> ANSILike c m c)
-> (a -> ANSILike c m b)
-> ANSILike c m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall c (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. ANSILike c m a -> ANSILike c m a) -> ANSILike c m b)
-> ANSILike c m b
mask :: forall b.
HasCallStack =>
((forall a. ANSILike c m a -> ANSILike c m a) -> ANSILike c m b)
-> ANSILike c m b
$cuninterruptibleMask :: forall c (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. ANSILike c m a -> ANSILike c m a) -> ANSILike c m b)
-> ANSILike c m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. ANSILike c m a -> ANSILike c m a) -> ANSILike c m b)
-> ANSILike c m b
$cgeneralBracket :: forall c (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
ANSILike c m a
-> (a -> ExitCase b -> ANSILike c m c)
-> (a -> ANSILike c m b)
-> ANSILike c m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
ANSILike c m a
-> (a -> ExitCase b -> ANSILike c m c)
-> (a -> ANSILike c m b)
-> ANSILike c m (b, c)
MonadMask,
      Monad (ANSILike c m)
Monad (ANSILike c m) =>
(forall e a. (HasCallStack, Exception e) => e -> ANSILike c m a)
-> MonadThrow (ANSILike c m)
forall e a. (HasCallStack, Exception e) => e -> ANSILike c m a
forall c (m :: * -> *). MonadThrow m => Monad (ANSILike c m)
forall c (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> ANSILike c m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall c (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> ANSILike c m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> ANSILike c m a
MonadThrow,
      MonadThrow (ANSILike c m)
MonadThrow (ANSILike c m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 ANSILike c m a -> (e -> ANSILike c m a) -> ANSILike c m a)
-> MonadCatch (ANSILike c m)
forall e a.
(HasCallStack, Exception e) =>
ANSILike c m a -> (e -> ANSILike c m a) -> ANSILike c m a
forall c (m :: * -> *). MonadCatch m => MonadThrow (ANSILike c m)
forall c (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
ANSILike c m a -> (e -> ANSILike c m a) -> ANSILike c m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall c (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
ANSILike c m a -> (e -> ANSILike c m a) -> ANSILike c m a
catch :: forall e a.
(HasCallStack, Exception e) =>
ANSILike c m a -> (e -> ANSILike c m a) -> ANSILike c m a
MonadCatch,
      MonadReader (Actions c),
      MonadState TermPos,
      MonadState TermRows,
      MonadReader Handles
    )

instance MonadTrans (ANSILike c) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ANSILike c m a
lift = PosixT m a -> ANSILike c m a
forall (m :: * -> *) a c. Monad m => PosixT m a -> ANSILike c m a
liftPosixT (PosixT m a -> ANSILike c m a)
-> (m a -> PosixT m a) -> m a -> ANSILike c 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

runANSILike :: (Monad m) => Actions c -> ANSILike c m a -> PosixT m a
runANSILike :: forall (m :: * -> *) c a.
Monad m =>
Actions c -> ANSILike c m a -> PosixT m a
runANSILike Actions c
actions =
  TermPos
-> StateT TermPos (ReaderT Handles m) a -> ReaderT Handles m a
forall (m :: * -> *) s a. Monad m => s -> StateT s m a -> m a
evalStateT' TermPos
initTermPos
    (StateT TermPos (ReaderT Handles m) a -> ReaderT Handles m a)
-> (ANSILike c m a -> StateT TermPos (ReaderT Handles m) a)
-> ANSILike c m a
-> ReaderT Handles m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermRows
-> StateT TermRows (StateT TermPos (ReaderT Handles m)) a
-> StateT TermPos (ReaderT Handles m) a
forall (m :: * -> *) s a. Monad m => s -> StateT s m a -> m a
evalStateT' TermRows
initTermRows
    (StateT TermRows (StateT TermPos (ReaderT Handles m)) a
 -> StateT TermPos (ReaderT Handles m) a)
-> (ANSILike c m a
    -> StateT TermRows (StateT TermPos (ReaderT Handles m)) a)
-> ANSILike c m a
-> StateT TermPos (ReaderT Handles m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Actions c
-> ReaderT
     (Actions c)
     (StateT TermRows (StateT TermPos (ReaderT Handles m)))
     a
-> StateT TermRows (StateT TermPos (ReaderT Handles m)) a
forall r (m :: * -> *) a. r -> ReaderT r m a -> m a
runReaderT' Actions c
actions
    (ReaderT
   (Actions c)
   (StateT TermRows (StateT TermPos (ReaderT Handles m)))
   a
 -> StateT TermRows (StateT TermPos (ReaderT Handles m)) a)
-> (ANSILike c m a
    -> ReaderT
         (Actions c)
         (StateT TermRows (StateT TermPos (ReaderT Handles m)))
         a)
-> ANSILike c m a
-> StateT TermRows (StateT TermPos (ReaderT Handles m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ANSILike c m a
-> ReaderT
     (Actions c)
     (StateT TermRows (StateT TermPos (ReaderT Handles m)))
     a
forall c (m :: * -> *) a.
ANSILike c m a
-> ReaderT
     (Actions c) (StateT TermRows (StateT TermPos (PosixT m))) a
unANSILike

liftPosixT :: (Monad m) => PosixT m a -> ANSILike c m a
liftPosixT :: forall (m :: * -> *) a c. Monad m => PosixT m a -> ANSILike c m a
liftPosixT =
  ReaderT (Actions c) (StateT TermRows (StateT TermPos (PosixT m))) a
-> ANSILike c m a
forall c (m :: * -> *) a.
ReaderT (Actions c) (StateT TermRows (StateT TermPos (PosixT m))) a
-> ANSILike c m a
ANSILike (ReaderT
   (Actions c) (StateT TermRows (StateT TermPos (PosixT m))) a
 -> ANSILike c m a)
-> (PosixT m a
    -> ReaderT
         (Actions c) (StateT TermRows (StateT TermPos (PosixT m))) a)
-> PosixT m a
-> ANSILike c m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT TermRows (StateT TermPos (PosixT m)) a
-> ReaderT
     (Actions c) (StateT TermRows (StateT TermPos (PosixT m))) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT (Actions c) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT TermRows (StateT TermPos (PosixT m)) a
 -> ReaderT
      (Actions c) (StateT TermRows (StateT TermPos (PosixT m))) a)
-> (PosixT m a -> StateT TermRows (StateT TermPos (PosixT m)) a)
-> PosixT m a
-> ReaderT
     (Actions c) (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

----------------------------------------------------------------
-- 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 a = Actions a -> a

output :: (Monad m) => TermAction c -> WriterT (TermAction c) (ANSILike c m) ()
output :: forall (m :: * -> *) c.
Monad m =>
TermAction c -> WriterT (TermAction c) (ANSILike c m) ()
output TermAction c
t = TermAction c -> WriterT (TermAction c) (ANSILike c m) ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell TermAction c
t

-- NB: explicit argument enables build with ghc-6.12.3
-- (Probably related to the monomorphism restriction;
-- see GHC ticket #1749).

outputText :: (Monad m) => String -> WriterT (TermAction c) (ANSILike c m) ()
outputText :: forall (m :: * -> *) c.
Monad m =>
String -> WriterT (TermAction c) (ANSILike c m) ()
outputText String
s = TermAction c -> WriterT (TermAction c) (ANSILike c m) ()
forall (m :: * -> *) c.
Monad m =>
TermAction c -> WriterT (TermAction c) (ANSILike c m) ()
output (String -> TermAction c
forall a. String -> TermAction a
text String
s)

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

text :: String -> TermAction a
text :: forall a. String -> TermAction a
text = (Actions a -> String -> a) -> String -> Actions a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Actions a -> String -> a
forall a. Actions a -> String -> a
textA

clearAll :: Int -> TermAction a
clearAll :: forall a. Int -> TermAction a
clearAll = (Actions a -> Int -> a) -> Int -> Actions a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Actions a -> Int -> a
forall a. Actions a -> Int -> a
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 a. Monoid a => a -> a -> a
`mappend` Int -> m -> m
forall m. Monoid m => Int -> m -> m
mreplicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) m
m

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

changePos :: (Monoid a) => TermPos -> TermPos -> TermAction a
changePos :: forall a. Monoid a => TermPos -> TermPos -> TermAction a
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 a
forall a. Int -> TermAction a
right (Int
c2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
c1) else Int -> TermAction a
forall a. Int -> TermAction a
left (Int
c1 Int -> 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 a
forall a. Actions a -> a
cr TermAction a -> TermAction a -> TermAction a
forall a. Semigroup a => a -> a -> a
<> Int -> TermAction a
forall a. Int -> TermAction a
up (Int
r1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r2) TermAction a -> TermAction a -> TermAction a
forall a. Semigroup a => a -> a -> a
<> Int -> TermAction a
forall a. Int -> TermAction a
right Int
c2
  | Bool
otherwise = TermAction a
forall a. Actions a -> a
cr TermAction a -> TermAction a -> TermAction a
forall a. Semigroup a => a -> a -> a
<> Int -> TermAction a -> TermAction a
forall m. Monoid m => Int -> m -> m
mreplicate (Int
r2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r1) TermAction a
forall a. Actions a -> a
nl TermAction a -> TermAction a -> TermAction a
forall a. Semigroup a => a -> a -> a
<> Int -> TermAction a
forall a. Int -> TermAction a
right Int
c2

moveToPos :: (Monoid c, Monad m) => TermPos -> WriterT (TermAction c) (ANSILike c m) ()
moveToPos :: forall c (m :: * -> *).
(Monoid c, Monad m) =>
TermPos -> WriterT (TermAction c) (ANSILike c m) ()
moveToPos TermPos
p = do
  oldP <- WriterT (TermAction c) (ANSILike c m) TermPos
forall s (m :: * -> *). MonadState s m => m s
get
  put p
  output $ changePos oldP p

moveRelative :: (Monoid c, MonadReader Layout m) => Int -> WriterT (TermAction c) (ANSILike c m) ()
moveRelative :: forall c (m :: * -> *).
(Monoid c, MonadReader Layout m) =>
Int -> WriterT (TermAction c) (ANSILike c m) ()
moveRelative Int
n =
  (Layout -> TermRows -> TermPos -> TermPos)
-> WriterT (TermAction c) (ANSILike c m) Layout
-> WriterT (TermAction c) (ANSILike c m) TermRows
-> WriterT (TermAction c) (ANSILike c m) TermPos
-> WriterT (TermAction c) (ANSILike c 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 c) (ANSILike c m) Layout
forall r (m :: * -> *). MonadReader r m => m r
ask WriterT (TermAction c) (ANSILike c m) TermRows
forall s (m :: * -> *). MonadState s m => m s
get WriterT (TermAction c) (ANSILike c m) TermPos
forall s (m :: * -> *). MonadState s m => m s
get
    WriterT (TermAction c) (ANSILike c m) TermPos
-> (TermPos -> WriterT (TermAction c) (ANSILike c m) ())
-> WriterT (TermAction c) (ANSILike c m) ()
forall a b.
WriterT (TermAction c) (ANSILike c m) a
-> (a -> WriterT (TermAction c) (ANSILike c m) b)
-> WriterT (TermAction c) (ANSILike c m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TermPos
p -> TermPos -> WriterT (TermAction c) (ANSILike c m) ()
forall c (m :: * -> *).
(Monoid c, Monad m) =>
TermPos -> WriterT (TermAction c) (ANSILike c m) ()
moveToPos TermPos
p

-- Note that these move by a certain number of cells, not graphemes.
changeRight, changeLeft :: (Monoid c, MonadReader Layout m) => Int -> WriterT (TermAction c) (ANSILike c m) ()
changeRight :: forall c (m :: * -> *).
(Monoid c, MonadReader Layout m) =>
Int -> WriterT (TermAction c) (ANSILike c m) ()
changeRight Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = () -> WriterT (TermAction c) (ANSILike c m) ()
forall a. a -> WriterT (TermAction c) (ANSILike c m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = Int -> WriterT (TermAction c) (ANSILike c m) ()
forall c (m :: * -> *).
(Monoid c, MonadReader Layout m) =>
Int -> WriterT (TermAction c) (ANSILike c m) ()
moveRelative Int
n
changeLeft :: forall c (m :: * -> *).
(Monoid c, MonadReader Layout m) =>
Int -> WriterT (TermAction c) (ANSILike c m) ()
changeLeft Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = () -> WriterT (TermAction c) (ANSILike c m) ()
forall a. a -> WriterT (TermAction c) (ANSILike c m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = Int -> WriterT (TermAction c) (ANSILike c m) ()
forall c (m :: * -> *).
(Monoid c, MonadReader Layout m) =>
Int -> WriterT (TermAction c) (ANSILike c m) ()
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
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
          )
    indexToPos :: Int -> TermPos
indexToPos Int
n = Int -> Int -> TermPos
loopFindRow Int
0 Int
n
    loopFindRow :: Int -> Int -> TermPos
loopFindRow Int
r Int
m =
      Int
r Int -> TermPos -> TermPos
forall a b. a -> b -> b
`seq`
        Int
m Int -> TermPos -> TermPos
forall a b. a -> b -> b
`seq`
          let thisRowSize :: Int
thisRowSize = TermRows -> Int -> Int
lookupCells TermRows
rs Int
r
           in if Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
thisRowSize
                Bool -> Bool -> Bool
|| (Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
thisRowSize Bool -> Bool -> Bool
&& Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w)
                Bool -> Bool -> Bool
|| Int
thisRowSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 -- This shouldn't happen in practice,
                -- but double-check to prevent an infinite loop
                then TermPos {termRow :: Int
termRow = Int
r, termCol :: Int
termCol = Int
m}
                else Int -> Int -> TermPos
loopFindRow (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
thisRowSize)

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

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

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

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

drawLineDiffT :: (Monoid c, MonadReader Layout m) => LineChars -> LineChars -> WriterT (TermAction c) (ANSILike c m) ()
drawLineDiffT :: forall c (m :: * -> *).
(Monoid c, MonadReader Layout m) =>
LineChars -> LineChars -> WriterT (TermAction c) (ANSILike c m) ()
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 -> () -> WriterT (TermAction c) (ANSILike c m) ()
forall a. a -> WriterT (TermAction c) (ANSILike c 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 -> WriterT (TermAction c) (ANSILike c m) ()
forall c (m :: * -> *).
(Monoid c, MonadReader Layout m) =>
Int -> WriterT (TermAction c) (ANSILike c m) ()
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 -> WriterT (TermAction c) (ANSILike c m) ()
forall c (m :: * -> *).
(Monoid c, MonadReader Layout m) =>
Int -> WriterT (TermAction c) (ANSILike c m) ()
changeRight ([Grapheme] -> Int
gsWidth [Grapheme]
xs2')
  ([Grapheme]
xs1', [Grapheme]
xs2') -> do
    oldRS <- WriterT (TermAction c) (ANSILike c m) TermRows
forall s (m :: * -> *). MonadState s m => m s
get
    changeLeft (gsWidth xs1')
    printText xs2'
    p <- get
    printText ys2
    clearDeadText oldRS
    moveToPos p

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

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

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

moveToNextLineT :: (Monoid c, Monad m) => WriterT (TermAction c) (ANSILike c m) ()
moveToNextLineT :: forall c (m :: * -> *).
(Monoid c, Monad m) =>
WriterT (TermAction c) (ANSILike c m) ()
moveToNextLineT = do
  lleft <- WriterT (TermAction c) (ANSILike c m) Int
forall c (m :: * -> *).
(Monoid c, Monad m) =>
WriterT (TermAction c) (ANSILike c m) Int
getLinesLeft
  output $ mreplicate (lleft + 1) nl
  put initTermPos
  put initTermRows

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

printLinesT :: (Monoid c, Monad m) => [String] -> WriterT (TermAction c) (ANSILike c m) ()
printLinesT :: forall c (m :: * -> *).
(Monoid c, Monad m) =>
[String] -> WriterT (TermAction c) (ANSILike c m) ()
printLinesT =
  (String -> WriterT (TermAction c) (ANSILike c m) ())
-> [String] -> WriterT (TermAction c) (ANSILike c m) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((String -> WriterT (TermAction c) (ANSILike c m) ())
 -> [String] -> WriterT (TermAction c) (ANSILike c m) ())
-> (String -> WriterT (TermAction c) (ANSILike c m) ())
-> [String]
-> WriterT (TermAction c) (ANSILike c m) ()
forall a b. (a -> b) -> a -> b
$ \String
line -> do
    String -> WriterT (TermAction c) (ANSILike c m) ()
forall (m :: * -> *) c.
Monad m =>
String -> WriterT (TermAction c) (ANSILike c m) ()
outputText String
line
    TermAction c -> WriterT (TermAction c) (ANSILike c m) ()
forall (m :: * -> *) c.
Monad m =>
TermAction c -> WriterT (TermAction c) (ANSILike c m) ()
output TermAction c
forall a. Actions a -> a
nl

ringBellT :: (Monad m) => Bool -> WriterT (TermAction c) (ANSILike c m) ()
ringBellT :: forall (m :: * -> *) c.
Monad m =>
Bool -> WriterT (TermAction c) (ANSILike c m) ()
ringBellT Bool
True = TermAction c -> WriterT (TermAction c) (ANSILike c m) ()
forall (m :: * -> *) c.
Monad m =>
TermAction c -> WriterT (TermAction c) (ANSILike c m) ()
output TermAction c
forall a. Actions a -> a
bellAudible
ringBellT Bool
False = TermAction c -> WriterT (TermAction c) (ANSILike c m) ()
forall (m :: * -> *) c.
Monad m =>
TermAction c -> WriterT (TermAction c) (ANSILike c m) ()
output TermAction c
forall a. Actions a -> a
bellVisual