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

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

      Body
Closed ->
        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 =
  forall (m :: * -> *) a. LiftRegion m => STM a -> m a
liftRegion forall a b. (a -> b) -> a -> b
$ do
    Body
body <- forall a. TVar a -> STM a
TVar.readTVar TVar Body
var
    case Body
body of
      Body
Empty ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

      Body
Closed ->
        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 =
  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 =
  forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
displayRegions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket forall (m :: * -> *). LiftRegion m => m Region
newOpenRegion forall (m :: * -> *). LiftRegion m => Region -> m ()
finishRegion

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

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

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

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

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

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