{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -O2 #-}
module System.Console.Regions (
ConsoleRegion,
RegionLayout(..),
ToRegionContent(..),
RegionContent(..),
LiftRegion(..),
displayConsoleRegions,
withConsoleRegion,
openConsoleRegion,
newConsoleRegion,
closeConsoleRegion,
setConsoleRegion,
appendConsoleRegion,
finishConsoleRegion,
getConsoleRegion,
tuneDisplay,
consoleWidth,
consoleHeight,
regionList,
waitDisplayChange,
) where
import Data.Monoid
import Data.String
import Data.Char
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import qualified Data.Text.IO as T
import Data.Text (Text)
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Control.Concurrent.Async
import System.Console.ANSI
import qualified System.Console.Terminal.Size as Console
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import Text.Read
import Data.List
#ifndef mingw32_HOST_OS
import System.Posix.Signals
import System.Posix.Signals.Exts
#endif
import Control.Applicative
import Prelude
import System.Console.Concurrent
import Utility.Monad
import Utility.Exception
data RegionLayout = Linear | InLine ConsoleRegion
deriving (RegionLayout -> RegionLayout -> Bool
(RegionLayout -> RegionLayout -> Bool)
-> (RegionLayout -> RegionLayout -> Bool) -> Eq RegionLayout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RegionLayout -> RegionLayout -> Bool
$c/= :: RegionLayout -> RegionLayout -> Bool
== :: RegionLayout -> RegionLayout -> Bool
$c== :: RegionLayout -> RegionLayout -> Bool
Eq)
newtype ConsoleRegion = ConsoleRegion (TVar R)
deriving (ConsoleRegion -> ConsoleRegion -> Bool
(ConsoleRegion -> ConsoleRegion -> Bool)
-> (ConsoleRegion -> ConsoleRegion -> Bool) -> Eq ConsoleRegion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConsoleRegion -> ConsoleRegion -> Bool
$c/= :: ConsoleRegion -> ConsoleRegion -> Bool
== :: ConsoleRegion -> ConsoleRegion -> Bool
$c== :: ConsoleRegion -> ConsoleRegion -> Bool
Eq)
data R = R
{ R -> RegionContent
regionContent :: RegionContent
, R -> Text -> STM Text
regionRender :: (Text -> STM Text)
, R -> RegionLayout
regionLayout :: RegionLayout
, R -> TVar [ConsoleRegion]
regionChildren :: TVar [ConsoleRegion]
}
newtype RegionContent = RegionContent (STM Text)
{-# NOINLINE regionList #-}
regionList :: TMVar [ConsoleRegion]
regionList :: TMVar [ConsoleRegion]
regionList = IO (TMVar [ConsoleRegion]) -> TMVar [ConsoleRegion]
forall a. IO a -> a
unsafePerformIO IO (TMVar [ConsoleRegion])
forall a. IO (TMVar a)
newEmptyTMVarIO
{-# NOINLINE consoleSize #-}
consoleSize :: TVar (Console.Window Int)
consoleSize :: TVar (Window Int)
consoleSize = IO (TVar (Window Int)) -> TVar (Window Int)
forall a. IO a -> a
unsafePerformIO (IO (TVar (Window Int)) -> TVar (Window Int))
-> IO (TVar (Window Int)) -> TVar (Window Int)
forall a b. (a -> b) -> a -> b
$ Window Int -> IO (TVar (Window Int))
forall a. a -> IO (TVar a)
newTVarIO (Window Int -> IO (TVar (Window Int)))
-> Window Int -> IO (TVar (Window Int))
forall a b. (a -> b) -> a -> b
$
$WWindow :: forall a. a -> a -> Window a
Console.Window { width :: Int
Console.width = 80, height :: Int
Console.height = 25}
type Width = Int
consoleWidth :: STM Int
consoleWidth :: STM Int
consoleWidth = Int -> Int
forall a. a -> a
munge (Int -> Int) -> (Window Int -> Int) -> Window Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window Int -> Int
forall a. Window a -> a
Console.width (Window Int -> Int) -> STM (Window Int) -> STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Window Int) -> STM (Window Int)
forall a. TVar a -> STM a
readTVar TVar (Window Int)
consoleSize
where
#ifndef mingw32_HOST_OS
munge :: a -> a
munge = a -> a
forall a. a -> a
id
#else
munge = pred
#endif
consoleHeight :: STM Int
consoleHeight :: STM Int
consoleHeight = Window Int -> Int
forall a. Window a -> a
Console.height (Window Int -> Int) -> STM (Window Int) -> STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Window Int) -> STM (Window Int)
forall a. TVar a -> STM a
readTVar TVar (Window Int)
consoleSize
regionDisplayEnabled :: IO Bool
regionDisplayEnabled :: IO Bool
regionDisplayEnabled = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar [ConsoleRegion] -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar [ConsoleRegion]
regionList
class LiftRegion m where
liftRegion :: STM a -> m a
instance LiftRegion STM where
liftRegion :: STM a -> STM a
liftRegion = STM a -> STM a
forall a. a -> a
id
instance LiftRegion IO where
liftRegion :: STM a -> IO a
liftRegion = STM a -> IO a
forall a. STM a -> IO a
atomically
class ToRegionContent v where
toRegionContent :: v -> RegionContent
instance ToRegionContent String where
toRegionContent :: String -> RegionContent
toRegionContent = String -> RegionContent
forall v. Outputable v => v -> RegionContent
fromOutput
instance ToRegionContent Text where
toRegionContent :: Text -> RegionContent
toRegionContent = Text -> RegionContent
forall v. Outputable v => v -> RegionContent
fromOutput
instance ToRegionContent L.Text where
toRegionContent :: Text -> RegionContent
toRegionContent = Text -> RegionContent
forall v. Outputable v => v -> RegionContent
fromOutput
fromOutput :: Outputable v => v -> RegionContent
fromOutput :: v -> RegionContent
fromOutput = STM Text -> RegionContent
RegionContent (STM Text -> RegionContent)
-> (v -> STM Text) -> v -> RegionContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> STM Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> STM Text) -> (v -> Text) -> v -> STM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Text
forall v. Outputable v => v -> Text
toOutput
instance ToRegionContent (STM Text) where
toRegionContent :: STM Text -> RegionContent
toRegionContent = STM Text -> RegionContent
RegionContent
setConsoleRegion :: (ToRegionContent v, LiftRegion m) => ConsoleRegion -> v -> m ()
setConsoleRegion :: ConsoleRegion -> v -> m ()
setConsoleRegion r :: ConsoleRegion
r v :: v
v = STM () -> m ()
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
ConsoleRegion -> (RegionContent -> STM RegionContent) -> STM ()
modifyRegion ConsoleRegion
r ((RegionContent -> STM RegionContent) -> STM ())
-> (RegionContent -> STM RegionContent) -> STM ()
forall a b. (a -> b) -> a -> b
$ STM RegionContent -> RegionContent -> STM RegionContent
forall a b. a -> b -> a
const (STM RegionContent -> RegionContent -> STM RegionContent)
-> STM RegionContent -> RegionContent -> STM RegionContent
forall a b. (a -> b) -> a -> b
$ RegionContent -> STM RegionContent
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RegionContent -> STM RegionContent)
-> RegionContent -> STM RegionContent
forall a b. (a -> b) -> a -> b
$ v -> RegionContent
forall v. ToRegionContent v => v -> RegionContent
toRegionContent v
v
appendConsoleRegion :: (Outputable v, LiftRegion m) => ConsoleRegion -> v -> m ()
appendConsoleRegion :: ConsoleRegion -> v -> m ()
appendConsoleRegion r :: ConsoleRegion
r v :: v
v = STM () -> m ()
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$
ConsoleRegion -> (RegionContent -> STM RegionContent) -> STM ()
modifyRegion ConsoleRegion
r ((RegionContent -> STM RegionContent) -> STM ())
-> (RegionContent -> STM RegionContent) -> STM ()
forall a b. (a -> b) -> a -> b
$ \(RegionContent a :: STM Text
a) ->
RegionContent -> STM RegionContent
forall (m :: * -> *) a. Monad m => a -> m a
return (RegionContent -> STM RegionContent)
-> RegionContent -> STM RegionContent
forall a b. (a -> b) -> a -> b
$ STM Text -> RegionContent
RegionContent (STM Text -> RegionContent) -> STM Text -> RegionContent
forall a b. (a -> b) -> a -> b
$ do
Text
t <- STM Text
a
Text -> STM Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> v -> Text
forall v. Outputable v => v -> Text
toOutput v
v)
modifyRegion :: ConsoleRegion -> (RegionContent -> STM RegionContent) -> STM ()
modifyRegion :: ConsoleRegion -> (RegionContent -> STM RegionContent) -> STM ()
modifyRegion (ConsoleRegion tv :: TVar R
tv) f :: RegionContent -> STM RegionContent
f = do
R
r <- TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
tv
RegionContent
rc <- RegionContent -> STM RegionContent
f (R -> RegionContent
regionContent R
r)
let r' :: R
r' = R
r { regionContent :: RegionContent
regionContent = RegionContent
rc }
TVar R -> R -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar R
tv R
r'
readRegionContent :: RegionContent -> STM Text
readRegionContent :: RegionContent -> STM Text
readRegionContent (RegionContent a :: STM Text
a) = STM Text
a
resizeRegion :: Width -> ConsoleRegion -> STM [Text]
resizeRegion :: Int -> ConsoleRegion -> STM [Text]
resizeRegion width :: Int
width (ConsoleRegion tv :: TVar R
tv) = do
R
r <- TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
tv
[Text]
ls <- R -> Int -> STM [Text]
calcRegionLines R
r Int
width
[Text] -> STM [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
ls
withConsoleRegion :: (MonadIO m, MonadMask m) => RegionLayout -> (ConsoleRegion -> m a) -> m a
withConsoleRegion :: RegionLayout -> (ConsoleRegion -> m a) -> m a
withConsoleRegion ly :: RegionLayout
ly = IO ConsoleRegion
-> (ConsoleRegion -> IO ()) -> (ConsoleRegion -> m a) -> m a
forall (m :: * -> *) v b a.
(MonadMask m, MonadIO m) =>
IO v -> (v -> IO b) -> (v -> m a) -> m a
bracketIO (RegionLayout -> IO ConsoleRegion
forall (m :: * -> *).
LiftRegion m =>
RegionLayout -> m ConsoleRegion
openConsoleRegion RegionLayout
ly) (ConsoleRegion -> IO ()
forall (m :: * -> *). LiftRegion m => ConsoleRegion -> m ()
closeConsoleRegion)
openConsoleRegion :: LiftRegion m => RegionLayout -> m ConsoleRegion
openConsoleRegion :: RegionLayout -> m ConsoleRegion
openConsoleRegion ly :: RegionLayout
ly = STM ConsoleRegion -> m ConsoleRegion
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM ConsoleRegion -> m ConsoleRegion)
-> STM ConsoleRegion -> m ConsoleRegion
forall a b. (a -> b) -> a -> b
$ do
ConsoleRegion
h <- RegionLayout -> Text -> STM ConsoleRegion
forall (m :: * -> *) v.
(LiftRegion m, ToRegionContent v) =>
RegionLayout -> v -> m ConsoleRegion
newConsoleRegion RegionLayout
ly Text
T.empty
case RegionLayout
ly of
Linear -> do
Maybe [ConsoleRegion]
ml <- TMVar [ConsoleRegion] -> STM (Maybe [ConsoleRegion])
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar [ConsoleRegion]
regionList
case Maybe [ConsoleRegion]
ml of
Just l :: [ConsoleRegion]
l -> TMVar [ConsoleRegion] -> [ConsoleRegion] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [ConsoleRegion]
regionList (ConsoleRegion
hConsoleRegion -> [ConsoleRegion] -> [ConsoleRegion]
forall a. a -> [a] -> [a]
:[ConsoleRegion]
l)
Nothing -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
InLine parent :: ConsoleRegion
parent -> ConsoleRegion -> ConsoleRegion -> STM ()
addChild ConsoleRegion
h ConsoleRegion
parent
ConsoleRegion -> STM ConsoleRegion
forall (m :: * -> *) a. Monad m => a -> m a
return ConsoleRegion
h
newConsoleRegion :: (LiftRegion m) => ToRegionContent v => RegionLayout -> v -> m ConsoleRegion
newConsoleRegion :: RegionLayout -> v -> m ConsoleRegion
newConsoleRegion ly :: RegionLayout
ly v :: v
v = STM ConsoleRegion -> m ConsoleRegion
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM ConsoleRegion -> m ConsoleRegion)
-> STM ConsoleRegion -> m ConsoleRegion
forall a b. (a -> b) -> a -> b
$ do
TVar [ConsoleRegion]
cs <- [ConsoleRegion] -> STM (TVar [ConsoleRegion])
forall a. a -> STM (TVar a)
newTVar [ConsoleRegion]
forall a. Monoid a => a
mempty
let r :: R
r = R :: RegionContent
-> (Text -> STM Text) -> RegionLayout -> TVar [ConsoleRegion] -> R
R
{ regionContent :: RegionContent
regionContent = STM Text -> RegionContent
RegionContent (STM Text -> RegionContent) -> STM Text -> RegionContent
forall a b. (a -> b) -> a -> b
$ Text -> STM Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
forall a. Monoid a => a
mempty
, regionRender :: Text -> STM Text
regionRender = Text -> STM Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure
, regionLayout :: RegionLayout
regionLayout = RegionLayout
ly
, regionChildren :: TVar [ConsoleRegion]
regionChildren = TVar [ConsoleRegion]
cs
}
ConsoleRegion
h <- TVar R -> ConsoleRegion
ConsoleRegion (TVar R -> ConsoleRegion) -> STM (TVar R) -> STM ConsoleRegion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> R -> STM (TVar R)
forall a. a -> STM (TVar a)
newTVar R
r
ConsoleRegion -> STM ()
displayChildren ConsoleRegion
h
ConsoleRegion -> v -> STM ()
forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
setConsoleRegion ConsoleRegion
h v
v
ConsoleRegion -> STM ConsoleRegion
forall (m :: * -> *) a. Monad m => a -> m a
return ConsoleRegion
h
displayChildren :: ConsoleRegion -> STM ()
displayChildren :: ConsoleRegion -> STM ()
displayChildren p :: ConsoleRegion
p@(ConsoleRegion tv :: TVar R
tv) = ConsoleRegion -> (Text -> STM Text) -> STM ()
forall (m :: * -> *).
LiftRegion m =>
ConsoleRegion -> (Text -> STM Text) -> m ()
tuneDisplay ConsoleRegion
p ((Text -> STM Text) -> STM ()) -> (Text -> STM Text) -> STM ()
forall a b. (a -> b) -> a -> b
$ \t :: Text
t -> do
[ConsoleRegion]
children <- TVar [ConsoleRegion] -> STM [ConsoleRegion]
forall a. TVar a -> STM a
readTVar (TVar [ConsoleRegion] -> STM [ConsoleRegion])
-> (R -> TVar [ConsoleRegion]) -> R -> STM [ConsoleRegion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R -> TVar [ConsoleRegion]
regionChildren (R -> STM [ConsoleRegion]) -> STM R -> STM [ConsoleRegion]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
tv
Text
ct <- [Text] -> Text
T.concat ([Text] -> Text) -> STM [Text] -> STM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConsoleRegion -> STM Text) -> [ConsoleRegion] -> STM [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ConsoleRegion -> STM Text
getc [ConsoleRegion]
children
Text -> STM Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> STM Text) -> Text -> STM Text
forall a b. (a -> b) -> a -> b
$ Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ct
where
getc :: ConsoleRegion -> STM Text
getc (ConsoleRegion cv :: TVar R
cv) = do
R
c <- TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
cv
R -> Text -> STM Text
regionRender R
c (Text -> STM Text) -> STM Text -> STM Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RegionContent -> STM Text
readRegionContent (R -> RegionContent
regionContent R
c)
closeConsoleRegion :: LiftRegion m => ConsoleRegion -> m ()
closeConsoleRegion :: ConsoleRegion -> m ()
closeConsoleRegion h :: ConsoleRegion
h@(ConsoleRegion tv :: TVar R
tv) = STM () -> m ()
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
Maybe [ConsoleRegion]
v <- TMVar [ConsoleRegion] -> STM (Maybe [ConsoleRegion])
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar [ConsoleRegion]
regionList
case Maybe [ConsoleRegion]
v of
Just l :: [ConsoleRegion]
l ->
let !l' :: [ConsoleRegion]
l' = (ConsoleRegion -> Bool) -> [ConsoleRegion] -> [ConsoleRegion]
forall a. (a -> Bool) -> [a] -> [a]
filter (ConsoleRegion -> ConsoleRegion -> Bool
forall a. Eq a => a -> a -> Bool
/= ConsoleRegion
h) [ConsoleRegion]
l
in TMVar [ConsoleRegion] -> [ConsoleRegion] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [ConsoleRegion]
regionList [ConsoleRegion]
l'
_ -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
RegionLayout
ly <- R -> RegionLayout
regionLayout (R -> RegionLayout) -> STM R -> STM RegionLayout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
tv
case RegionLayout
ly of
Linear -> () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
InLine parent :: ConsoleRegion
parent -> ConsoleRegion -> ConsoleRegion -> STM ()
removeChild ConsoleRegion
h ConsoleRegion
parent
finishConsoleRegion :: (Outputable v, LiftRegion m) => ConsoleRegion -> v -> m ()
finishConsoleRegion :: ConsoleRegion -> v -> m ()
finishConsoleRegion h :: ConsoleRegion
h v :: v
v = STM () -> m ()
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ConsoleRegion -> STM ()
forall (m :: * -> *). LiftRegion m => ConsoleRegion -> m ()
closeConsoleRegion ConsoleRegion
h
StdHandle -> Text -> STM ()
forall v. Outputable v => StdHandle -> v -> STM ()
bufferOutputSTM StdHandle
StdOut (v -> Text
forall v. Outputable v => v -> Text
toOutput v
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString "\n")
getConsoleRegion :: LiftRegion m => ConsoleRegion -> m Text
getConsoleRegion :: ConsoleRegion -> m Text
getConsoleRegion (ConsoleRegion tv :: TVar R
tv) = STM Text -> m Text
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM Text -> m Text) -> STM Text -> m Text
forall a b. (a -> b) -> a -> b
$
RegionContent -> STM Text
readRegionContent (RegionContent -> STM Text)
-> (R -> RegionContent) -> R -> STM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R -> RegionContent
regionContent (R -> STM Text) -> STM R -> STM Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
tv
tuneDisplay :: LiftRegion m => ConsoleRegion -> (Text -> STM Text) -> m ()
tuneDisplay :: ConsoleRegion -> (Text -> STM Text) -> m ()
tuneDisplay (ConsoleRegion tv :: TVar R
tv) renderer :: Text -> STM Text
renderer = STM () -> m ()
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
R
r <- TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
tv
let rr :: Text -> STM Text
rr = \t :: Text
t -> Text -> STM Text
renderer (Text -> STM Text) -> STM Text -> STM Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< R -> Text -> STM Text
regionRender R
r Text
t
let r' :: R
r' = R
r { regionRender :: Text -> STM Text
regionRender = Text -> STM Text
rr }
TVar R -> R -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar R
tv R
r'
addChild :: ConsoleRegion -> ConsoleRegion -> STM ()
addChild :: ConsoleRegion -> ConsoleRegion -> STM ()
addChild child :: ConsoleRegion
child _parent :: ConsoleRegion
_parent@(ConsoleRegion pv :: TVar R
pv) = do
TVar [ConsoleRegion]
cv <- R -> TVar [ConsoleRegion]
regionChildren (R -> TVar [ConsoleRegion]) -> STM R -> STM (TVar [ConsoleRegion])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
pv
[ConsoleRegion]
children <- TVar [ConsoleRegion] -> STM [ConsoleRegion]
forall a. TVar a -> STM a
readTVar TVar [ConsoleRegion]
cv
let !children' :: [ConsoleRegion]
children' = (ConsoleRegion -> Bool) -> [ConsoleRegion] -> [ConsoleRegion]
forall a. (a -> Bool) -> [a] -> [a]
filter (ConsoleRegion -> ConsoleRegion -> Bool
forall a. Eq a => a -> a -> Bool
/= ConsoleRegion
child) [ConsoleRegion]
children [ConsoleRegion] -> [ConsoleRegion] -> [ConsoleRegion]
forall a. [a] -> [a] -> [a]
++ [ConsoleRegion
child]
TVar [ConsoleRegion] -> [ConsoleRegion] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [ConsoleRegion]
cv [ConsoleRegion]
children'
removeChild :: ConsoleRegion -> ConsoleRegion -> STM ()
removeChild :: ConsoleRegion -> ConsoleRegion -> STM ()
removeChild child :: ConsoleRegion
child _parent :: ConsoleRegion
_parent@(ConsoleRegion pv :: TVar R
pv) = do
TVar [ConsoleRegion]
cv <- R -> TVar [ConsoleRegion]
regionChildren (R -> TVar [ConsoleRegion]) -> STM R -> STM (TVar [ConsoleRegion])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
pv
TVar [ConsoleRegion]
-> ([ConsoleRegion] -> [ConsoleRegion]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [ConsoleRegion]
cv ((ConsoleRegion -> Bool) -> [ConsoleRegion] -> [ConsoleRegion]
forall a. (a -> Bool) -> [a] -> [a]
filter (ConsoleRegion -> ConsoleRegion -> Bool
forall a. Eq a => a -> a -> Bool
/= ConsoleRegion
child))
displayConsoleRegions :: (MonadIO m, MonadMask m) => m a -> m a
displayConsoleRegions :: m a -> m a
displayConsoleRegions a :: m a
a = m Bool -> (m a, m a) -> m a
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
regionDisplayEnabled)
( m a
a
, m a -> m a
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
lockOutput (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m (Bool, Async (), TSem)
-> ((Bool, Async (), TSem) -> m ())
-> ((Bool, Async (), TSem) -> m a)
-> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m (Bool, Async (), TSem)
setup (Bool, Async (), TSem) -> m ()
forall (m :: * -> *) a. MonadIO m => (Bool, Async a, TSem) -> m ()
cleanup (m a -> (Bool, Async (), TSem) -> m a
forall a b. a -> b -> a
const m a
a)
)
where
setup :: m (Bool, Async (), TSem)
setup = IO (Bool, Async (), TSem) -> m (Bool, Async (), TSem)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Bool, Async (), TSem) -> m (Bool, Async (), TSem))
-> IO (Bool, Async (), TSem) -> m (Bool, Async (), TSem)
forall a b. (a -> b) -> a -> b
$ do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar [ConsoleRegion] -> [ConsoleRegion] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [ConsoleRegion]
regionList []
TSem
endsignal <- STM TSem -> IO TSem
forall a. STM a -> IO a
atomically (STM TSem -> IO TSem) -> STM TSem -> IO TSem
forall a b. (a -> b) -> a -> b
$ do
TSem
s <- Integer -> STM TSem
newTSem 1
TSem -> STM ()
waitTSem TSem
s
TSem -> STM TSem
forall (m :: * -> *) a. Monad m => a -> m a
return TSem
s
Bool
isterm <- IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hSupportsANSI Handle
stdout
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm IO ()
trackConsoleWidth
Async ()
da <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Bool -> TSem -> IO ()
displayThread Bool
isterm TSem
endsignal
(Bool, Async (), TSem) -> IO (Bool, Async (), TSem)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isterm, Async ()
da, TSem
endsignal)
cleanup :: (Bool, Async a, TSem) -> m ()
cleanup (isterm :: Bool
isterm, da :: Async a
da, endsignal :: TSem
endsignal) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TSem -> STM ()
signalTSem TSem
endsignal
IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO a -> IO ()) -> IO a -> IO ()
forall a b. (a -> b) -> a -> b
$ Async a -> IO a
forall a. Async a -> IO a
wait Async a
da
IO [ConsoleRegion] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [ConsoleRegion] -> IO ()) -> IO [ConsoleRegion] -> IO ()
forall a b. (a -> b) -> a -> b
$ STM [ConsoleRegion] -> IO [ConsoleRegion]
forall a. STM a -> IO a
atomically (STM [ConsoleRegion] -> IO [ConsoleRegion])
-> STM [ConsoleRegion] -> IO [ConsoleRegion]
forall a b. (a -> b) -> a -> b
$ TMVar [ConsoleRegion] -> STM [ConsoleRegion]
forall a. TMVar a -> STM a
takeTMVar TMVar [ConsoleRegion]
regionList
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Maybe (IO ()) -> IO ()
installResizeHandler Maybe (IO ())
forall a. Maybe a
Nothing
trackConsoleWidth :: IO ()
trackConsoleWidth :: IO ()
trackConsoleWidth = do
let getsz :: IO ()
getsz = IO () -> (Window Int -> IO ()) -> Maybe (Window Int) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
forall (m :: * -> *). Monad m => m ()
noop (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Window Int -> STM ()) -> Window Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Window Int) -> Window Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Window Int)
consoleSize)
(Maybe (Window Int) -> IO ()) -> IO (Maybe (Window Int)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe (Window Int))
forall n. Integral n => IO (Maybe (Window n))
Console.size
IO ()
getsz
Maybe (IO ()) -> IO ()
installResizeHandler (IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just IO ()
getsz)
data DisplayChange
= BufferChange BufferSnapshot
| RegionChange RegionSnapshot
| RegionListChange RegionSnapshot
| TerminalResize Width
| Shutdown
| DisplayChangeBarrier Barrier
type BufferSnapshot = (StdHandle, OutputBuffer)
type RegionSnapshot = ([ConsoleRegion], [R], [[Text]])
type Barrier = Integer
{-# NOINLINE displayUpdateNotifier #-}
displayUpdateNotifier :: TChan DisplayChange
displayUpdateNotifier :: TChan DisplayChange
displayUpdateNotifier = IO (TChan DisplayChange) -> TChan DisplayChange
forall a. IO a -> a
unsafePerformIO (IO (TChan DisplayChange) -> TChan DisplayChange)
-> IO (TChan DisplayChange) -> TChan DisplayChange
forall a b. (a -> b) -> a -> b
$ IO (TChan DisplayChange)
forall a. IO (TChan a)
newBroadcastTChanIO
{-# NOINLINE displayChangeBarrier #-}
displayChangeBarrier :: TVar Barrier
displayChangeBarrier :: TVar Integer
displayChangeBarrier = IO (TVar Integer) -> TVar Integer
forall a. IO a -> a
unsafePerformIO (IO (TVar Integer) -> TVar Integer)
-> IO (TVar Integer) -> TVar Integer
forall a b. (a -> b) -> a -> b
$ Integer -> IO (TVar Integer)
forall a. a -> IO (TVar a)
newTVarIO 0
waitDisplayChange :: STM a -> IO a
waitDisplayChange :: STM a -> IO a
waitDisplayChange a :: STM a
a = do
TChan DisplayChange
c <- STM (TChan DisplayChange) -> IO (TChan DisplayChange)
forall a. STM a -> IO a
atomically (STM (TChan DisplayChange) -> IO (TChan DisplayChange))
-> STM (TChan DisplayChange) -> IO (TChan DisplayChange)
forall a b. (a -> b) -> a -> b
$ TChan DisplayChange -> STM (TChan DisplayChange)
forall a. TChan a -> STM (TChan a)
dupTChan TChan DisplayChange
displayUpdateNotifier
TMVar (Integer, a)
bv <- IO (TMVar (Integer, a))
forall a. IO (TMVar a)
newEmptyTMVarIO
((), ())
_ <- TMVar (Integer, a) -> IO ()
setbarrier TMVar (Integer, a)
bv IO () -> IO () -> IO ((), ())
forall a b. IO a -> IO b -> IO (a, b)
`concurrently` TChan DisplayChange -> TMVar (Integer, a) -> IO ()
forall b. TChan DisplayChange -> TMVar (Integer, b) -> IO ()
waitchange TChan DisplayChange
c TMVar (Integer, a)
bv
(Integer, a) -> a
forall a b. (a, b) -> b
snd ((Integer, a) -> a) -> IO (Integer, a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Integer, a) -> IO (Integer, a)
forall a. STM a -> IO a
atomically (TMVar (Integer, a) -> STM (Integer, a)
forall a. TMVar a -> STM a
readTMVar TMVar (Integer, a)
bv)
where
setbarrier :: TMVar (Integer, a) -> IO ()
setbarrier bv :: TMVar (Integer, a)
bv = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
!Integer
b <- Integer -> Integer
forall a. Enum a => a -> a
succ (Integer -> Integer) -> STM Integer -> STM Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Integer -> STM Integer
forall a. TVar a -> STM a
readTVar TVar Integer
displayChangeBarrier
a
r <- STM a
a
TVar Integer -> Integer -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Integer
displayChangeBarrier Integer
b
TMVar (Integer, a) -> (Integer, a) -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Integer, a)
bv (Integer
b, a
r)
waitchange :: TChan DisplayChange -> TMVar (Integer, b) -> IO ()
waitchange c :: TChan DisplayChange
c bv :: TMVar (Integer, b)
bv = do
DisplayChange
change <- STM DisplayChange -> IO DisplayChange
forall a. STM a -> IO a
atomically (STM DisplayChange -> IO DisplayChange)
-> STM DisplayChange -> IO DisplayChange
forall a b. (a -> b) -> a -> b
$ TChan DisplayChange -> STM DisplayChange
forall a. TChan a -> STM a
readTChan TChan DisplayChange
c
Integer
b <- (Integer, b) -> Integer
forall a b. (a, b) -> a
fst ((Integer, b) -> Integer) -> IO (Integer, b) -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (Integer, b) -> IO (Integer, b)
forall a. STM a -> IO a
atomically (TMVar (Integer, b) -> STM (Integer, b)
forall a. TMVar a -> STM a
readTMVar TMVar (Integer, b)
bv)
case DisplayChange
change of
DisplayChangeBarrier b' :: Integer
b' | Integer
b' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
b -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> TChan DisplayChange -> TMVar (Integer, b) -> IO ()
waitchange TChan DisplayChange
c TMVar (Integer, b)
bv
displayThread :: Bool -> TSem -> IO ()
displayThread :: Bool -> TSem -> IO ()
displayThread isterm :: Bool
isterm endsignal :: TSem
endsignal = do
Int
origwidth <- STM Int -> IO Int
forall a. STM a -> IO a
atomically STM Int
consoleWidth
Integer
origbarrier <- STM Integer -> IO Integer
forall a. STM a -> IO a
atomically (TVar Integer -> STM Integer
forall a. TVar a -> STM a
readTVar TVar Integer
displayChangeBarrier)
([ConsoleRegion], [R], [[Text]]) -> Int -> Integer -> IO ()
go ([], [], []) Int
origwidth Integer
origbarrier
where
go :: ([ConsoleRegion], [R], [[Text]]) -> Int -> Integer -> IO ()
go origsnapshot :: ([ConsoleRegion], [R], [[Text]])
origsnapshot@(orighandles :: [ConsoleRegion]
orighandles, origregions :: [R]
origregions, origlines :: [[Text]]
origlines) origwidth :: Int
origwidth origbarrier :: Integer
origbarrier = do
let waitwidthchange :: STM Int
waitwidthchange = do
Int
w <- STM Int
consoleWidth
if Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
origwidth then STM Int
forall a. STM a
retry else Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
w
let waitbarrierchange :: STM Integer
waitbarrierchange = do
Integer
b <- TVar Integer -> STM Integer
forall a. TVar a -> STM a
readTVar TVar Integer
displayChangeBarrier
if Integer
b Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
origbarrier
then Integer -> STM Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
b
else STM Integer
forall a. STM a
retry
let waitanychange :: STM DisplayChange
waitanychange =
(([ConsoleRegion], [R], [[Text]]) -> DisplayChange
RegionChange (([ConsoleRegion], [R], [[Text]]) -> DisplayChange)
-> STM ([ConsoleRegion], [R], [[Text]]) -> STM DisplayChange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ConsoleRegion], [R], [[Text]])
-> Int -> STM ([ConsoleRegion], [R], [[Text]])
regionWaiter ([ConsoleRegion], [R], [[Text]])
origsnapshot Int
origwidth)
STM DisplayChange -> STM DisplayChange -> STM DisplayChange
forall a. STM a -> STM a -> STM a
`orElse`
(([ConsoleRegion], [R], [[Text]]) -> DisplayChange
RegionListChange (([ConsoleRegion], [R], [[Text]]) -> DisplayChange)
-> STM ([ConsoleRegion], [R], [[Text]]) -> STM DisplayChange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([ConsoleRegion], [R], [[Text]])
-> STM ([ConsoleRegion], [R], [[Text]])
regionListWaiter ([ConsoleRegion], [R], [[Text]])
origsnapshot)
STM DisplayChange -> STM DisplayChange -> STM DisplayChange
forall a. STM a -> STM a -> STM a
`orElse`
(BufferSnapshot -> DisplayChange
BufferChange (BufferSnapshot -> DisplayChange)
-> STM BufferSnapshot -> STM DisplayChange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OutputBuffer -> (OutputBuffer, OutputBuffer))
-> STM BufferSnapshot
outputBufferWaiterSTM OutputBuffer -> (OutputBuffer, OutputBuffer)
waitCompleteLines)
STM DisplayChange -> STM DisplayChange -> STM DisplayChange
forall a. STM a -> STM a -> STM a
`orElse`
(Int -> DisplayChange
TerminalResize (Int -> DisplayChange) -> STM Int -> STM DisplayChange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM Int
waitwidthchange)
STM DisplayChange -> STM DisplayChange -> STM DisplayChange
forall a. STM a -> STM a -> STM a
`orElse`
(TSem -> STM ()
waitTSem TSem
endsignal STM () -> STM DisplayChange -> STM DisplayChange
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DisplayChange -> STM DisplayChange
forall (f :: * -> *) a. Applicative f => a -> f a
pure DisplayChange
Shutdown)
STM DisplayChange -> STM DisplayChange -> STM DisplayChange
forall a. STM a -> STM a -> STM a
`orElse`
(Integer -> DisplayChange
DisplayChangeBarrier (Integer -> DisplayChange) -> STM Integer -> STM DisplayChange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM Integer
waitbarrierchange)
(change :: DisplayChange
change, height :: Int
height) <- STM (DisplayChange, Int) -> IO (DisplayChange, Int)
forall a. STM a -> IO a
atomically (STM (DisplayChange, Int) -> IO (DisplayChange, Int))
-> STM (DisplayChange, Int) -> IO (DisplayChange, Int)
forall a b. (a -> b) -> a -> b
$ (,)
(DisplayChange -> Int -> (DisplayChange, Int))
-> STM DisplayChange -> STM (Int -> (DisplayChange, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM DisplayChange
waitanychange
STM (Int -> (DisplayChange, Int))
-> STM Int -> STM (DisplayChange, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM Int
consoleHeight
let onscreen :: [[a]] -> [a]
onscreen = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) ([a] -> [a]) -> ([[a]] -> [a]) -> [[a]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
let update :: ([ConsoleRegion], [R], [[Text]]) -> IO (IO ())
update snapshot :: ([ConsoleRegion], [R], [[Text]])
snapshot@(_, _, newlines :: [[Text]]
newlines) = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Text] -> [Text] -> IO ()
changedLines ([[Text]] -> [Text]
forall a. [[a]] -> [a]
onscreen [[Text]]
origlines) ([[Text]] -> [Text]
forall a. [[a]] -> [a]
onscreen [[Text]]
newlines)
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ([ConsoleRegion], [R], [[Text]]) -> Int -> Integer -> IO ()
go ([ConsoleRegion], [R], [[Text]])
snapshot Int
origwidth Integer
origbarrier
IO ()
next <- case DisplayChange
change of
RegionChange snapshot :: ([ConsoleRegion], [R], [[Text]])
snapshot -> ([ConsoleRegion], [R], [[Text]]) -> IO (IO ())
update ([ConsoleRegion], [R], [[Text]])
snapshot
RegionListChange snapshot :: ([ConsoleRegion], [R], [[Text]])
snapshot -> ([ConsoleRegion], [R], [[Text]]) -> IO (IO ())
update ([ConsoleRegion], [R], [[Text]])
snapshot
BufferChange (h :: StdHandle
h, buf :: OutputBuffer
buf) -> do
let origlines' :: [Text]
origlines' = [[Text]] -> [Text]
forall a. [[a]] -> [a]
onscreen [[Text]]
origlines
Bool -> Int -> [Text] -> IO () -> IO ()
inAreaAbove Bool
isterm ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
origlines') [Text]
origlines' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
StdHandle -> OutputBuffer -> IO ()
emitOutputBuffer StdHandle
h OutputBuffer
buf
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ([ConsoleRegion], [R], [[Text]]) -> Int -> Integer -> IO ()
go ([ConsoleRegion], [R], [[Text]])
origsnapshot Int
origwidth Integer
origbarrier
TerminalResize newwidth :: Int
newwidth -> do
[[Text]]
newlines <- STM [[Text]] -> IO [[Text]]
forall a. STM a -> IO a
atomically ((ConsoleRegion -> STM [Text]) -> [ConsoleRegion] -> STM [[Text]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int -> ConsoleRegion -> STM [Text]
resizeRegion Int
newwidth) [ConsoleRegion]
orighandles)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Text] -> IO ()
resizeRecovery ([[Text]] -> [Text]
forall a. [[a]] -> [a]
onscreen [[Text]]
newlines)
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ([ConsoleRegion], [R], [[Text]]) -> Int -> Integer -> IO ()
go ([ConsoleRegion]
orighandles, [R]
origregions, [[Text]]
newlines) Int
newwidth Integer
origbarrier
Shutdown ->
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
DisplayChangeBarrier b :: Integer
b ->
IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ ([ConsoleRegion], [R], [[Text]]) -> Int -> Integer -> IO ()
go ([ConsoleRegion], [R], [[Text]])
origsnapshot Int
origwidth Integer
b
Handle -> IO ()
hFlush Handle
stdout
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan DisplayChange -> DisplayChange -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan DisplayChange
displayUpdateNotifier DisplayChange
change
IO ()
next
readRegions :: [ConsoleRegion] -> STM [R]
readRegions :: [ConsoleRegion] -> STM [R]
readRegions = (ConsoleRegion -> STM R) -> [ConsoleRegion] -> STM [R]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(ConsoleRegion h :: TVar R
h) -> TVar R -> STM R
forall a. TVar a -> STM a
readTVar TVar R
h)
regionListWaiter :: RegionSnapshot -> STM RegionSnapshot
regionListWaiter :: ([ConsoleRegion], [R], [[Text]])
-> STM ([ConsoleRegion], [R], [[Text]])
regionListWaiter (orighandles :: [ConsoleRegion]
orighandles, _origregions :: [R]
_origregions, origlines :: [[Text]]
origlines) = do
[ConsoleRegion]
handles <- TMVar [ConsoleRegion] -> STM [ConsoleRegion]
forall a. TMVar a -> STM a
readTMVar TMVar [ConsoleRegion]
regionList
if [ConsoleRegion]
handles [ConsoleRegion] -> [ConsoleRegion] -> Bool
forall a. Eq a => a -> a -> Bool
== [ConsoleRegion]
orighandles
then STM ([ConsoleRegion], [R], [[Text]])
forall a. STM a
retry
else do
[R]
rs <- [ConsoleRegion] -> STM [R]
readRegions [ConsoleRegion]
handles
([ConsoleRegion], [R], [[Text]])
-> STM ([ConsoleRegion], [R], [[Text]])
forall (m :: * -> *) a. Monad m => a -> m a
return ([ConsoleRegion]
handles, [R]
rs, [[Text]]
origlines)
regionWaiter :: RegionSnapshot -> Width -> STM RegionSnapshot
regionWaiter :: ([ConsoleRegion], [R], [[Text]])
-> Int -> STM ([ConsoleRegion], [R], [[Text]])
regionWaiter (orighandles :: [ConsoleRegion]
orighandles, _origregions :: [R]
_origregions, origlines :: [[Text]]
origlines) width :: Int
width = do
[R]
rs <- [ConsoleRegion] -> STM [R]
readRegions [ConsoleRegion]
orighandles
[[Text]]
newlines <- (R -> STM [Text]) -> [R] -> STM [[Text]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM R -> STM [Text]
getr [R]
rs
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Text]]
newlines [[Text]] -> [[Text]] -> Bool
forall a. Eq a => a -> a -> Bool
/= [[Text]]
origlines)
STM ()
forall a. STM a
retry
([ConsoleRegion], [R], [[Text]])
-> STM ([ConsoleRegion], [R], [[Text]])
forall (m :: * -> *) a. Monad m => a -> m a
return ([ConsoleRegion]
orighandles, [R]
rs, [[Text]]
newlines)
where
getr :: R -> STM [Text]
getr r :: R
r = R -> Int -> STM [Text]
calcRegionLines R
r Int
width
changedLines :: [Text] -> [Text] -> IO ()
changedLines :: [Text] -> [Text] -> IO ()
changedLines origlines :: [Text]
origlines newlines :: [Text]
newlines
| Int
delta Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = do
[Text] -> [Text] -> IO ()
diffUpdate [Text]
origlines [Text]
newlines
| Int
delta Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = do
let addedlines :: [Text]
addedlines = [Text] -> [Text]
forall a. [a] -> [a]
reverse (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
delta [Text]
newlines)
[Text] -> IO ()
displayLines [Text]
addedlines
let scrolledlines :: [Text]
scrolledlines = [Text]
addedlines [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
origlines
[Text] -> [Text] -> IO ()
diffUpdate [Text]
scrolledlines [Text]
newlines
| Bool
otherwise = do
Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (Int -> Int
forall a. Num a => a -> a
abs Int
delta) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
setCursorColumn 0
Int -> IO ()
cursorUp 1
IO ()
clearLine
[Text] -> [Text] -> IO ()
diffUpdate (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop (Int -> Int
forall a. Num a => a -> a
abs Int
delta) [Text]
origlines) [Text]
newlines
where
delta :: Int
delta = [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
newlines Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
origlines
diffUpdate :: [Text] -> [Text] -> IO ()
diffUpdate :: [Text] -> [Text] -> IO ()
diffUpdate old :: [Text]
old new :: [Text]
new = [((Text, Bool), Text)] -> IO ()
updateLines ([(Text, Bool)] -> [Text] -> [((Text, Bool), Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Text] -> [Bool] -> [(Text, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
new [Bool]
changed) [Text]
old)
where
changed :: [Bool]
changed = ((Text, Text) -> Bool) -> [(Text, Text)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text -> Bool) -> (Text, Text) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(/=)) ([Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
new [Text]
old) [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True
changeOffsets :: [((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
changeOffsets :: [((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
changeOffsets [] _ c :: [((r, Int), r)]
c = [((r, Int), r)] -> [((r, Int), r)]
forall a. [a] -> [a]
reverse [((r, Int), r)]
c
changeOffsets (((new :: r
new, changed :: Bool
changed), old :: r
old):rs :: [((r, Bool), r)]
rs) n :: Int
n c :: [((r, Int), r)]
c
| Bool
changed = [((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
forall r.
[((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
changeOffsets [((r, Bool), r)]
rs 1 (((r
new, Int
n), r
old)((r, Int), r) -> [((r, Int), r)] -> [((r, Int), r)]
forall a. a -> [a] -> [a]
:[((r, Int), r)]
c)
| Bool
otherwise = [((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
forall r.
[((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
changeOffsets [((r, Bool), r)]
rs (Int -> Int
forall a. Enum a => a -> a
succ Int
n) [((r, Int), r)]
c
updateLines :: [((Text, Bool), Text)] -> IO ()
updateLines :: [((Text, Bool), Text)] -> IO ()
updateLines l :: [((Text, Bool), Text)]
l
| [((Text, Int), Text)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [((Text, Int), Text)]
l' = IO ()
forall (m :: * -> *). Monad m => m ()
noop
| Bool
otherwise = do
[((Text, Int), Text)] -> (((Text, Int), Text) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((Text, Int), Text)]
l' ((((Text, Int), Text) -> IO ()) -> IO ())
-> (((Text, Int), Text) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \((newt :: Text
newt, offset :: Int
offset), oldt :: Text
oldt) -> do
Int -> IO ()
setCursorColumn 0
Int -> IO ()
cursorUp Int
offset
#ifndef mingw32_HOST_OS
Handle -> Text -> IO ()
T.hPutStr Handle
stdout (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
[LineUpdate] -> Text
genLineUpdate ([LineUpdate] -> Text) -> [LineUpdate] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [LineUpdate]
calcLineUpdate Text
oldt Text
newt
#else
T.hPutStr stdout newt
clearFromCursorToLineEnd
#endif
Int -> IO ()
cursorDown ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((((Text, Int), Text) -> Int) -> [((Text, Int), Text)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Text, Int) -> Int
forall a b. (a, b) -> b
snd ((Text, Int) -> Int)
-> (((Text, Int), Text) -> (Text, Int))
-> ((Text, Int), Text)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Int), Text) -> (Text, Int)
forall a b. (a, b) -> a
fst) [((Text, Int), Text)]
l'))
Int -> IO ()
setCursorColumn 0
where
l' :: [((Text, Int), Text)]
l' = [((Text, Bool), Text)]
-> Int -> [((Text, Int), Text)] -> [((Text, Int), Text)]
forall r.
[((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]
changeOffsets [((Text, Bool), Text)]
l 1 []
resizeRecovery :: [Text] -> IO ()
resizeRecovery :: [Text] -> IO ()
resizeRecovery newlines :: [Text]
newlines = do
Int -> Int -> IO ()
setCursorPosition 0 0
Bool -> Int -> [Text] -> IO () -> IO ()
inAreaAbove Bool
True 0 [Text]
newlines (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
inAreaAbove :: Bool -> Int -> [Text] -> IO () -> IO ()
inAreaAbove :: Bool -> Int -> [Text] -> IO () -> IO ()
inAreaAbove isterm :: Bool
isterm numlines :: Int
numlines ls :: [Text]
ls outputter :: IO ()
outputter = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
numlines Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
setCursorColumn 0
Int -> IO ()
cursorUp (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
numlines
IO ()
clearFromCursorToScreenEnd
Handle -> IO ()
hFlush Handle
stdout
IO ()
outputter
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isterm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
setCursorColumn 0
[Text] -> IO ()
displayLines ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
ls)
displayLines :: [Text] -> IO ()
displayLines :: [Text] -> IO ()
displayLines = (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Text -> IO ()) -> [Text] -> IO ())
-> (Text -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$ \l :: Text
l -> do
Handle -> Text -> IO ()
T.hPutStr Handle
stdout Text
l
Char -> IO ()
putChar '\n'
installResizeHandler :: Maybe (IO ()) -> IO ()
#ifndef mingw32_HOST_OS
installResizeHandler :: Maybe (IO ()) -> IO ()
installResizeHandler h :: Maybe (IO ())
h = IO Handler -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Handler -> IO ()) -> IO Handler -> IO ()
forall a b. (a -> b) -> a -> b
$
Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
windowChange (Handler -> (IO () -> Handler) -> Maybe (IO ()) -> Handler
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Handler
Default IO () -> Handler
Catch Maybe (IO ())
h) Maybe SignalSet
forall a. Maybe a
Nothing
#else
installResizeHandler _ = return ()
#endif
calcRegionLines :: R -> Width -> STM [Text]
calcRegionLines :: R -> Int -> STM [Text]
calcRegionLines r :: R
r width :: Int
width = do
Text
t <- R -> Text -> STM Text
regionRender R
r (Text -> STM Text) -> STM Text -> STM Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RegionContent -> STM Text
readRegionContent (R -> RegionContent
regionContent R
r)
[Text] -> STM [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> STM [Text]) -> [Text] -> STM [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Int -> [Text]
calcLines Text
t Int
width
calcLines :: Text -> Width -> [Text]
calcLines :: Text -> Int -> [Text]
calcLines t :: Text
t width :: Int
width
| Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 1 Bool -> Bool -> Bool
|| Text -> Bool
T.null Text
t = [Text
t]
| Bool
otherwise = Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width [] [] 0 1 (Text -> Int
T.length Text
t) Text
t
calcLines' :: Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' :: Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' width :: Int
width collectedlines :: [Text]
collectedlines collectedSGR :: [Text]
collectedSGR i :: Int
i displaysize :: Int
displaysize len :: Int
len t :: Text
t
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
then [Text] -> [Text]
forall a. [a] -> [a]
reverse (Text -> [Text]
finishline Text
t)
else [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
collectedlines
| Char
t1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' = Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width (Text -> [Text]
finishline (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.init Text
currline)
[] 0 1 (Text -> Int
T.length Text
rest) (Text -> Text
contSGR Text
rest)
| Char
t1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\ESC' Bool -> Bool -> Bool
&& Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len = case Text -> Int -> Char
T.index Text
t (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) of
'[' -> (Char -> Bool) -> Bool -> [Text]
skipansi Char -> Bool
endCSI Bool
True
']' -> (Char -> Bool) -> Bool -> [Text]
skipansi Char -> Bool
endOSC Bool
False
_ -> Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width [Text]
collectedlines [Text]
collectedSGR (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Int
displaysize Int
len Text
t
| Char -> Bool
isControl Char
t1 = Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width [Text]
collectedlines [Text]
collectedSGR (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Int
displaysize Int
len Text
t
| Int
displaysize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
width = Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width (Text -> [Text]
finishline Text
currline)
[] 0 1 (Text -> Int
T.length Text
rest) (Text -> Text
contSGR Text
rest)
| Bool
otherwise = Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width [Text]
collectedlines [Text]
collectedSGR (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) (Int
displaysizeInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Int
len Text
t
where
t1 :: Char
t1 = Text -> Int -> Char
T.index Text
t Int
i
(currline :: Text
currline, rest :: Text
rest) = Int -> Text -> (Text, Text)
T.splitAt (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Text
t
skipansi :: (Char -> Bool) -> Bool -> [Text]
skipansi toend :: Char -> Bool
toend isCSI :: Bool
isCSI = case (Char -> Bool) -> Text -> Maybe Int
T.findIndex Char -> Bool
toend (Int -> Text -> Text
T.drop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+2) Text
t) of
Just csiend :: Int
csiend -> Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text]
calcLines' Int
width [Text]
collectedlines
(Int -> [Text]
addSGR (Int
csiendInt -> Int -> Int
forall a. Num a => a -> a -> a
+2)) (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+2Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
csiend) (Int
displaysizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) Int
len Text
t
Nothing -> [Text] -> [Text]
forall a. [a] -> [a]
reverse (Text -> [Text]
finishline Text
t)
where
addSGR :: Int -> [Text]
addSGR csiend :: Int
csiend
| Bool -> Bool
not Bool
isCSI = [Text]
collectedSGR
| Text
ansicode Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
resetSGR = []
| Bool -> Bool
not (Text -> Bool
T.null Text
ansicode) Bool -> Bool -> Bool
&& Text -> Char
T.last Text
ansicode Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
endSGR =
Text
ansicode Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
collectedSGR
| Bool
otherwise = [Text]
collectedSGR
where
ansicode :: Text
ansicode = Int -> Text -> Text
T.take (Int
csiend Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> Text -> Text
T.drop Int
i Text
t)
finishline :: Text -> [Text]
finishline l :: Text
l = Text -> Text
closeSGR Text
l Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
collectedlines
closeSGR :: Text -> Text
closeSGR l :: Text
l
| [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
collectedSGR = Text
l
| Bool
otherwise = Text
l Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
resetSGR
contSGR :: Text -> Text
contSGR l :: Text
l = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
collectedSGR) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l
resetSGR :: Text
resetSGR :: Text
resetSGR = String -> Text
T.pack ([SGR] -> String
setSGRCode [SGR
Reset])
endCSI :: Char -> Bool
endCSI :: Char -> Bool
endCSI c :: Char
c = let o :: Int
o = Char -> Int
ord Char
c in Int
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 64 Bool -> Bool -> Bool
&& Int
o Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 127
endOSC :: Char -> Bool
endOSC :: Char -> Bool
endOSC c :: Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\BEL'
endSGR :: Char
endSGR :: Char
endSGR = 'm'
calcLineUpdate :: Text -> Text -> [LineUpdate]
calcLineUpdate :: Text -> Text -> [LineUpdate]
calcLineUpdate old :: Text
old new :: Text
new =
[LineUpdate] -> [LineUpdate]
forall a. [a] -> [a]
reverse ([LineUpdate] -> [LineUpdate]) -> [LineUpdate] -> [LineUpdate]
forall a b. (a -> b) -> a -> b
$ (Maybe Char, Text, [LineUpdate], [LineUpdate])
-> (Maybe Char, Text, [LineUpdate], [LineUpdate]) -> [LineUpdate]
go
(Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
old [] [])
(Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
new [] [])
where
go :: (Maybe Char, Text, [LineUpdate], [LineUpdate])
-> (Maybe Char, Text, [LineUpdate], [LineUpdate]) -> [LineUpdate]
go (Just _, _, _, _) (Nothing, _, past :: [LineUpdate]
past, _) = LineUpdate
ClearToEnd LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
: [LineUpdate]
past
go (Nothing, _, _, _) (Nothing, _, past :: [LineUpdate]
past, _) = [LineUpdate]
past
go (Nothing, _, _, _) (Just n :: Char
n, ns :: Text
ns, past :: [LineUpdate]
past, _) =
Text -> LineUpdate
Display Text
ns LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
: Text -> LineUpdate
Display (Char -> Text
T.singleton Char
n) LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
: [LineUpdate]
past
go (Just o :: Char
o, os :: Text
os, _, oinvis :: [LineUpdate]
oinvis) (Just n :: Char
n, ns :: Text
ns, past :: [LineUpdate]
past, ninvis :: [LineUpdate]
ninvis)
| Char
o Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
n Bool -> Bool -> Bool
&& [LineUpdate]
oinvis [LineUpdate] -> [LineUpdate] -> Bool
forall a. Eq a => a -> a -> Bool
== [LineUpdate]
ninvis = (Maybe Char, Text, [LineUpdate], [LineUpdate])
-> (Maybe Char, Text, [LineUpdate], [LineUpdate]) -> [LineUpdate]
go
(Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
os [] [LineUpdate]
oinvis)
(Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
ns (String -> LineUpdate
Skip [Char
o] LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
: [LineUpdate]
past) [LineUpdate]
ninvis)
| Bool
otherwise = (Maybe Char, Text, [LineUpdate], [LineUpdate])
-> (Maybe Char, Text, [LineUpdate], [LineUpdate]) -> [LineUpdate]
go
(Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
os [] [LineUpdate]
oinvis)
(Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine Text
ns (Text -> LineUpdate
Display (Char -> Text
T.singleton Char
n) LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
: [LineUpdate]
past) [LineUpdate]
ninvis)
type Past = [LineUpdate]
type Invis = [LineUpdate]
advanceLine :: Text -> Past -> Invis -> (Maybe Char, Text, Past, Invis)
advanceLine :: Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine t :: Text
t past :: [LineUpdate]
past invis :: [LineUpdate]
invis
| Text -> Bool
T.null Text
t = (Maybe Char
forall a. Maybe a
Nothing, Text
T.empty, [LineUpdate]
past, [LineUpdate]
invis)
| Bool
otherwise = case Text -> Char
T.head Text
t of
'\ESC' -> case Int -> Text -> Text
T.drop 1 Text
t of
t' :: Text
t' | Text -> Bool
T.null Text
t' -> Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine (Int -> Text -> Text
T.drop 1 Text
t)
(String -> LineUpdate
Skip "\ESC"LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
past) (String -> LineUpdate
Skip "\ESC"LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
invis)
| Bool
otherwise -> case Text -> Char
T.head Text
t' of
'[' -> (Char -> Bool) -> (Maybe Char, Text, [LineUpdate], [LineUpdate])
skipansi Char -> Bool
endCSI
']' -> (Char -> Bool) -> (Maybe Char, Text, [LineUpdate], [LineUpdate])
skipansi Char -> Bool
endOSC
c :: Char
c -> (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c, Int -> Text -> Text
T.drop 2 Text
t, String -> LineUpdate
Skip "\ESC"LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
past, String -> LineUpdate
Skip "\ESC"LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
invis)
c :: Char
c | Char -> Bool
isControl Char
c -> Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine (Int -> Text -> Text
T.drop 1 Text
t) (String -> LineUpdate
Skip [Char
c]LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
past) (String -> LineUpdate
Skip [Char
c]LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
invis)
| Bool
otherwise -> (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c, Int -> Text -> Text
T.drop 1 Text
t, [LineUpdate]
past, [LineUpdate]
invis)
where
skipansi :: (Char -> Bool) -> (Maybe Char, Text, [LineUpdate], [LineUpdate])
skipansi toend :: Char -> Bool
toend = case (Char -> Bool) -> Text -> Maybe Int
T.findIndex Char -> Bool
toend (Int -> Text -> Text
T.drop 2 Text
t) of
Just csiend :: Int
csiend ->
let sgr :: LineUpdate
sgr = Text -> LineUpdate
SGR (Int -> Text -> Text
T.take (Int
csiendInt -> Int -> Int
forall a. Num a => a -> a -> a
+3) Text
t)
in Text
-> [LineUpdate]
-> [LineUpdate]
-> (Maybe Char, Text, [LineUpdate], [LineUpdate])
advanceLine (Int -> Text -> Text
T.drop (Int
csiendInt -> Int -> Int
forall a. Num a => a -> a -> a
+3) Text
t)
(LineUpdate
sgrLineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
past) (LineUpdate -> [LineUpdate] -> [LineUpdate]
addsgr LineUpdate
sgr [LineUpdate]
invis)
Nothing -> (Maybe Char
forall a. Maybe a
Nothing, Text
T.empty, [LineUpdate]
past, [LineUpdate]
invis)
addsgr :: LineUpdate -> [LineUpdate] -> [LineUpdate]
addsgr (SGR sgrt :: Text
sgrt) l :: [LineUpdate]
l
| Text
sgrt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
resetSGR = (LineUpdate -> Bool) -> [LineUpdate] -> [LineUpdate]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (LineUpdate -> Bool) -> LineUpdate -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineUpdate -> Bool
isSGR) [LineUpdate]
l
addsgr s :: LineUpdate
s l :: [LineUpdate]
l = LineUpdate
sLineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
l
data LineUpdate = Display Text | Skip [Char] | SGR Text | ClearToEnd
deriving (LineUpdate -> LineUpdate -> Bool
(LineUpdate -> LineUpdate -> Bool)
-> (LineUpdate -> LineUpdate -> Bool) -> Eq LineUpdate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LineUpdate -> LineUpdate -> Bool
$c/= :: LineUpdate -> LineUpdate -> Bool
== :: LineUpdate -> LineUpdate -> Bool
$c== :: LineUpdate -> LineUpdate -> Bool
Eq, Int -> LineUpdate -> ShowS
[LineUpdate] -> ShowS
LineUpdate -> String
(Int -> LineUpdate -> ShowS)
-> (LineUpdate -> String)
-> ([LineUpdate] -> ShowS)
-> Show LineUpdate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LineUpdate] -> ShowS
$cshowList :: [LineUpdate] -> ShowS
show :: LineUpdate -> String
$cshow :: LineUpdate -> String
showsPrec :: Int -> LineUpdate -> ShowS
$cshowsPrec :: Int -> LineUpdate -> ShowS
Show)
isSGR :: LineUpdate -> Bool
isSGR :: LineUpdate -> Bool
isSGR (SGR _) = Bool
True
isSGR _ = Bool
False
genLineUpdate :: [LineUpdate] -> Text
genLineUpdate :: [LineUpdate] -> Text
genLineUpdate l :: [LineUpdate]
l = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (LineUpdate -> Text) -> [LineUpdate] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map LineUpdate -> Text
tot ([LineUpdate] -> [LineUpdate]
optimiseLineUpdate [LineUpdate]
l)
where
tot :: LineUpdate -> Text
tot (Display t :: Text
t) = Text
t
tot (Skip s :: String
s)
| Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 5 = String -> Text
T.pack String
s
| Bool
otherwise = String -> Text
T.pack (Int -> String
cursorForwardCode Int
len)
where
len :: Int
len = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
tot (SGR t :: Text
t) = Text
t
tot ClearToEnd = String -> Text
T.pack String
clearFromCursorToLineEndCode
optimiseLineUpdate :: [LineUpdate] -> [LineUpdate]
optimiseLineUpdate :: [LineUpdate] -> [LineUpdate]
optimiseLineUpdate = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go []
where
go :: [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go (Skip _:rest :: [LineUpdate]
rest) [] = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go [LineUpdate]
rest []
go (SGR t :: Text
t:rest :: [LineUpdate]
rest) [] | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
resetSGR = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go [LineUpdate]
rest []
go c :: [LineUpdate]
c [] = [LineUpdate] -> [LineUpdate]
forall a. [a] -> [a]
reverse [LineUpdate]
c
go c :: [LineUpdate]
c (SGR t1 :: Text
t1:Skip s :: String
s:SGR t2 :: Text
t2:rest :: [LineUpdate]
rest) = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
tryharder [LineUpdate]
c (Text -> LineUpdate
SGR (Text -> Text -> Text
combineSGR Text
t1 Text
t2)LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:String -> LineUpdate
Skip String
sLineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
rest)
go c :: [LineUpdate]
c (Skip s :: String
s:Skip s' :: String
s':rest :: [LineUpdate]
rest) = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
tryharder [LineUpdate]
c (String -> LineUpdate
Skip (String
sString -> ShowS
forall a. [a] -> [a] -> [a]
++String
s')LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
rest)
go c :: [LineUpdate]
c (SGR t1 :: Text
t1:SGR t2 :: Text
t2:rest :: [LineUpdate]
rest) = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
tryharder [LineUpdate]
c (Text -> LineUpdate
SGR (Text -> Text -> Text
combineSGR Text
t1 Text
t2)LineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
rest)
go c :: [LineUpdate]
c (v :: LineUpdate
v:rest :: [LineUpdate]
rest) = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go (LineUpdate
vLineUpdate -> [LineUpdate] -> [LineUpdate]
forall a. a -> [a] -> [a]
:[LineUpdate]
c) [LineUpdate]
rest
tryharder :: [LineUpdate] -> [LineUpdate] -> [LineUpdate]
tryharder c :: [LineUpdate]
c l :: [LineUpdate]
l = [LineUpdate] -> [LineUpdate] -> [LineUpdate]
go [] ([LineUpdate] -> [LineUpdate]
forall a. [a] -> [a]
reverse [LineUpdate]
c [LineUpdate] -> [LineUpdate] -> [LineUpdate]
forall a. [a] -> [a] -> [a]
++ [LineUpdate]
l)
combineSGR :: Text -> Text -> Text
combineSGR :: Text -> Text -> Text
combineSGR a :: Text
a b :: Text
b = case [Maybe Int] -> [Maybe Int] -> Maybe [Int]
combineSGRCodes (Text -> [Maybe Int]
codes Text
a) (Text -> [Maybe Int]
codes Text
b) of
Nothing -> Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b
Just cs :: [Int]
cs -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ "\ESC[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ";" ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show [Int]
cs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "m"
where
codes :: Text -> [Maybe Int]
codes = (Text -> Maybe Int) -> [Text] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ([Text] -> [Maybe Int]) -> (Text -> [Text]) -> Text -> [Maybe Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ';') (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop 2 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.init
combineSGRCodes :: [Maybe Int] -> [Maybe Int] -> Maybe [Int]
combineSGRCodes :: [Maybe Int] -> [Maybe Int] -> Maybe [Int]
combineSGRCodes as :: [Maybe Int]
as bs :: [Maybe Int]
bs =
((ConsoleLayer, Int) -> Int) -> [(ConsoleLayer, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (ConsoleLayer, Int) -> Int
forall a b. (a, b) -> b
snd ([(ConsoleLayer, Int)] -> [Int])
-> ([(ConsoleLayer, Int)] -> [(ConsoleLayer, Int)])
-> [(ConsoleLayer, Int)]
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ConsoleLayer, Int) -> (ConsoleLayer, Int) -> Bool)
-> [(ConsoleLayer, Int)] -> [(ConsoleLayer, Int)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\a :: (ConsoleLayer, Int)
a b :: (ConsoleLayer, Int)
b -> (ConsoleLayer, Int) -> ConsoleLayer
forall a b. (a, b) -> a
fst (ConsoleLayer, Int)
a ConsoleLayer -> ConsoleLayer -> Bool
forall a. Eq a => a -> a -> Bool
== (ConsoleLayer, Int) -> ConsoleLayer
forall a b. (a, b) -> a
fst (ConsoleLayer, Int)
b) ([(ConsoleLayer, Int)] -> [Int])
-> Maybe [(ConsoleLayer, Int)] -> Maybe [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Int -> Maybe (ConsoleLayer, Int))
-> [Maybe Int] -> Maybe [(ConsoleLayer, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Maybe Int -> Maybe (ConsoleLayer, Int)
forall b. (Ord b, Num b) => Maybe b -> Maybe (ConsoleLayer, b)
range ([Maybe Int] -> [Maybe Int]
forall a. [a] -> [a]
reverse [Maybe Int]
bs [Maybe Int] -> [Maybe Int] -> [Maybe Int]
forall a. [a] -> [a] -> [a]
++ [Maybe Int] -> [Maybe Int]
forall a. [a] -> [a]
reverse [Maybe Int]
as)
where
range :: Maybe b -> Maybe (ConsoleLayer, b)
range Nothing = Maybe (ConsoleLayer, b)
forall a. Maybe a
Nothing
range (Just x :: b
x)
| b
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
>= 30 Bool -> Bool -> Bool
&& b
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= 37 = (ConsoleLayer, b) -> Maybe (ConsoleLayer, b)
forall a. a -> Maybe a
Just (ConsoleLayer
Foreground, b
x)
| b
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
>= 40 Bool -> Bool -> Bool
&& b
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= 47 = (ConsoleLayer, b) -> Maybe (ConsoleLayer, b)
forall a. a -> Maybe a
Just (ConsoleLayer
Background, b
x)
| b
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
>= 90 Bool -> Bool -> Bool
&& b
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= 97 = (ConsoleLayer, b) -> Maybe (ConsoleLayer, b)
forall a. a -> Maybe a
Just (ConsoleLayer
Foreground, b
x)
| b
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
>= 100 Bool -> Bool -> Bool
&& b
x b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= 107 = (ConsoleLayer, b) -> Maybe (ConsoleLayer, b)
forall a. a -> Maybe a
Just (ConsoleLayer
Background, b
x)
| Bool
otherwise = Maybe (ConsoleLayer, b)
forall a. Maybe a
Nothing