{-# 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 ()