{-# 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.Monad.Catch (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 :: m Region
newEmptyRegion =
  STM Region -> m Region
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 (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 :: m Region
newOpenRegion =
  STM Region -> m Region
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 (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 :: Region -> String -> m ()
openRegion (Region var :: TVar Body
var) content :: String
content =
  STM () -> m ()
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
      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 region :: ConsoleRegion
region ->
        ConsoleRegion -> String -> STM ()
forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Console.setConsoleRegion ConsoleRegion
region String
content

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

setRegion :: LiftRegion m => Region -> String -> m ()
setRegion :: Region -> String -> m ()
setRegion (Region var :: TVar Body
var) content :: String
content =
  STM () -> m ()
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
      Empty ->
        () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

displayRegions :: (MonadIO m, MonadMask m) => m a -> m a
displayRegions :: m a -> m a
displayRegions io :: 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 :: (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 c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
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 var :: TVar Body
var) =
  STM () -> STM ()
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
      Empty ->
        () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      Open region :: 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
          Nothing ->
            () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

          Just xs0 :: [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)

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

finishRegion :: LiftRegion m => Region -> m ()
finishRegion :: Region -> m ()
finishRegion (Region var :: TVar Body
var) =
  STM () -> m ()
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
      Empty -> do
        TVar Body -> Body -> STM ()
forall a. TVar a -> a -> STM ()
TVar.writeTVar TVar Body
var Body
Closed

      Open region :: 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

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