{-# OPTIONS_HADDOCK not-home #-}
module Hedgehog.Internal.Region (
    Region(..)
  , newEmptyRegion
  , newOpenRegion
  , openRegion
  , setRegion
  , displayRegions
  , displayRegion
  , moveToBottom
  , finishRegion
  ) where

import           Control.Concurrent.STM (STM, TVar)
import qualified Control.Concurrent.STM.TMVar as TMVar
import qualified Control.Concurrent.STM.TVar as TVar
import           Control.Exception.Safe (MonadMask, bracket)
import           Control.Monad.IO.Class (MonadIO(..))

import           System.Console.Regions (ConsoleRegion, RegionLayout(..), LiftRegion(..))
import qualified System.Console.Regions as Console


data Body =
    Empty
  | Open ConsoleRegion
  | Closed

newtype Region =
  Region {
      Region -> TVar Body
unRegion :: TVar Body
    }

newEmptyRegion :: LiftRegion m => m Region
newEmptyRegion :: forall (m :: * -> *). LiftRegion m => m Region
newEmptyRegion =
  STM Region -> m Region
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM Region -> m Region) -> STM Region -> m Region
forall a b. (a -> b) -> a -> b
$ do
    TVar Body
ref <- Body -> STM (TVar Body)
forall a. a -> STM (TVar a)
TVar.newTVar Body
Empty
    Region -> STM Region
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Region -> STM Region) -> Region -> STM Region
forall a b. (a -> b) -> a -> b
$ TVar Body -> Region
Region TVar Body
ref

newOpenRegion :: LiftRegion m => m Region
newOpenRegion :: forall (m :: * -> *). LiftRegion m => m Region
newOpenRegion =
  STM Region -> m Region
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM Region -> m Region) -> STM Region -> m Region
forall a b. (a -> b) -> a -> b
$ do
    ConsoleRegion
region <- RegionLayout -> STM ConsoleRegion
forall (m :: * -> *).
LiftRegion m =>
RegionLayout -> m ConsoleRegion
Console.openConsoleRegion RegionLayout
Linear
    TVar Body
ref <- Body -> STM (TVar Body)
forall a. a -> STM (TVar a)
TVar.newTVar (Body -> STM (TVar Body)) -> Body -> STM (TVar Body)
forall a b. (a -> b) -> a -> b
$ ConsoleRegion -> Body
Open ConsoleRegion
region
    Region -> STM Region
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Region -> STM Region) -> Region -> STM Region
forall a b. (a -> b) -> a -> b
$ TVar Body -> Region
Region TVar Body
ref

openRegion :: LiftRegion m => Region -> String -> m ()
openRegion :: forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
openRegion (Region TVar Body
var) String
content =
  STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Body
body <- TVar Body -> STM Body
forall a. TVar a -> STM a
TVar.readTVar TVar Body
var
    case Body
body of
      Body
Empty -> do
        ConsoleRegion
region <- RegionLayout -> STM ConsoleRegion
forall (m :: * -> *).
LiftRegion m =>
RegionLayout -> m ConsoleRegion
Console.openConsoleRegion RegionLayout
Linear
        TVar Body -> Body -> STM ()
forall a. TVar a -> a -> STM ()
TVar.writeTVar TVar Body
var (Body -> STM ()) -> Body -> STM ()
forall a b. (a -> b) -> a -> b
$ ConsoleRegion -> Body
Open ConsoleRegion
region
        ConsoleRegion -> String -> STM ()
forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Console.setConsoleRegion ConsoleRegion
region String
content

      Open ConsoleRegion
region ->
        ConsoleRegion -> String -> STM ()
forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Console.setConsoleRegion ConsoleRegion
region String
content

      Body
Closed ->
        () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

setRegion :: LiftRegion m => Region -> String -> m ()
setRegion :: forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
setRegion (Region TVar Body
var) String
content =
  STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Body
body <- TVar Body -> STM Body
forall a. TVar a -> STM a
TVar.readTVar TVar Body
var
    case Body
body of
      Body
Empty ->
        () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      Open ConsoleRegion
region ->
        ConsoleRegion -> String -> STM ()
forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Console.setConsoleRegion ConsoleRegion
region String
content

      Body
Closed ->
        () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

displayRegions :: (MonadIO m, MonadMask m) => m a -> m a
displayRegions :: forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
displayRegions m a
io =
  m a -> m a
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
Console.displayConsoleRegions m a
io

displayRegion ::
     MonadIO m
  => MonadMask m
  => LiftRegion m
  => (Region -> m a)
  -> m a
displayRegion :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m, LiftRegion m) =>
(Region -> m a) -> m a
displayRegion =
  m a -> m a
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
displayRegions (m a -> m a) -> ((Region -> m a) -> m a) -> (Region -> m a) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Region -> (Region -> m ()) -> (Region -> m a) -> m a
forall (m :: * -> *) a b c.
(HasCallStack, MonadMask m) =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m Region
forall (m :: * -> *). LiftRegion m => m Region
newOpenRegion Region -> m ()
forall (m :: * -> *). LiftRegion m => Region -> m ()
finishRegion

moveToBottom :: Region -> STM ()
moveToBottom :: Region -> STM ()
moveToBottom (Region TVar Body
var) =
  STM () -> STM ()
forall a. STM a -> STM a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
    Body
body <- TVar Body -> STM Body
forall a. TVar a -> STM a
TVar.readTVar TVar Body
var
    case Body
body of
      Body
Empty ->
        () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      Open ConsoleRegion
region -> do
        Maybe [ConsoleRegion]
mxs <- TMVar [ConsoleRegion] -> STM (Maybe [ConsoleRegion])
forall a. TMVar a -> STM (Maybe a)
TMVar.tryTakeTMVar TMVar [ConsoleRegion]
Console.regionList
        case Maybe [ConsoleRegion]
mxs of
          Maybe [ConsoleRegion]
Nothing ->
            () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

          Just [ConsoleRegion]
xs0 ->
            let
              xs1 :: [ConsoleRegion]
xs1 =
                (ConsoleRegion -> Bool) -> [ConsoleRegion] -> [ConsoleRegion]
forall a. (a -> Bool) -> [a] -> [a]
filter (ConsoleRegion -> ConsoleRegion -> Bool
forall a. Eq a => a -> a -> Bool
/= ConsoleRegion
region) [ConsoleRegion]
xs0
            in
              TMVar [ConsoleRegion] -> [ConsoleRegion] -> STM ()
forall a. TMVar a -> a -> STM ()
TMVar.putTMVar TMVar [ConsoleRegion]
Console.regionList (ConsoleRegion
region ConsoleRegion -> [ConsoleRegion] -> [ConsoleRegion]
forall a. a -> [a] -> [a]
: [ConsoleRegion]
xs1)

      Body
Closed ->
        () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

finishRegion :: LiftRegion m => Region -> m ()
finishRegion :: forall (m :: * -> *). LiftRegion m => Region -> m ()
finishRegion (Region TVar Body
var) =
  STM () -> m ()
forall a. STM a -> m a
forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Body
body <- TVar Body -> STM Body
forall a. TVar a -> STM a
TVar.readTVar TVar Body
var
    case Body
body of
      Body
Empty -> do
        TVar Body -> Body -> STM ()
forall a. TVar a -> a -> STM ()
TVar.writeTVar TVar Body
var Body
Closed

      Open ConsoleRegion
region -> do
        Text
content <- ConsoleRegion -> STM Text
forall (m :: * -> *). LiftRegion m => ConsoleRegion -> m Text
Console.getConsoleRegion ConsoleRegion
region
        ConsoleRegion -> Text -> STM ()
forall v (m :: * -> *).
(Outputable v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Console.finishConsoleRegion ConsoleRegion
region Text
content
        TVar Body -> Body -> STM ()
forall a. TVar a -> a -> STM ()
TVar.writeTVar TVar Body
var Body
Closed

      Body
Closed ->
        () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()