{-# 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
    ref <- Body -> STM (TVar Body)
forall a. a -> STM (TVar a)
TVar.newTVar Body
Empty
    pure $ Region 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
    region <- RegionLayout -> STM ConsoleRegion
forall (m :: * -> *).
LiftRegion m =>
RegionLayout -> m ConsoleRegion
Console.openConsoleRegion RegionLayout
Linear
    ref <- TVar.newTVar $ Open region
    pure $ Region 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 <- TVar Body -> STM Body
forall a. TVar a -> STM a
TVar.readTVar TVar Body
var
    case body of
      Body
Empty -> do
        region <- RegionLayout -> STM ConsoleRegion
forall (m :: * -> *).
LiftRegion m =>
RegionLayout -> m ConsoleRegion
Console.openConsoleRegion RegionLayout
Linear
        TVar.writeTVar var $ Open region
        Console.setConsoleRegion region 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 <- TVar Body -> STM Body
forall a. TVar a -> STM a
TVar.readTVar TVar Body
var
    case 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 <- TVar Body -> STM Body
forall a. TVar a -> STM a
TVar.readTVar TVar Body
var
    case body of
      Body
Empty ->
        () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      Open ConsoleRegion
region -> do
        mxs <- TMVar [ConsoleRegion] -> STM (Maybe [ConsoleRegion])
forall a. TMVar a -> STM (Maybe a)
TMVar.tryTakeTMVar TMVar [ConsoleRegion]
Console.regionList
        case 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 <- TVar Body -> STM Body
forall a. TVar a -> STM a
TVar.readTVar TVar Body
var
    case 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
        content <- ConsoleRegion -> STM Text
forall (m :: * -> *). LiftRegion m => ConsoleRegion -> m Text
Console.getConsoleRegion ConsoleRegion
region
        Console.finishConsoleRegion region content
        TVar.writeTVar var Closed

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