-- | Provides functionality for logging to a specific region
-- (i.e. for concurrent console logging).
module Shrun.Logging.MonadRegionLogger
  ( MonadRegionLogger (..),
    restoreTimerRegion,
  )
where

import Control.Concurrent.STM.TMVar qualified as TMVar
import Shrun.Logging.Types.Internal
  ( LogMode
      ( LogModeAppend,
        LogModeFinish,
        LogModeSet
      ),
  )
import Shrun.Prelude
import System.Console.Regions qualified as Regions

-- | `MonadRegionLogger` is a simple typeclass for abstracting logging functions.
type MonadRegionLogger :: (Type -> Type) -> Constraint
class (Eq (Region m), Monad m) => MonadRegionLogger m where
  -- | The type of the region. This will be ConsoleRegion for production
  -- code and () for tests.
  type Region m

  -- | Pushes a log to the "global" region.
  logGlobal :: (HasCallStack) => Text -> m ()

  -- | Pushes a log to the region.
  logRegion :: (HasCallStack) => LogMode -> Region m -> Text -> m ()

  -- | Runs an @m a@ with a region.
  withRegion :: (HasCallStack) => RegionLayout -> (Region m -> m a) -> m a

  -- | Displays the regions. This should wrap whatever top-level logic
  -- needs regions.
  displayRegions :: (HasCallStack) => m a -> m a

  -- | Retrieve all regions.
  regionList :: m (TMVar [Region m])

instance MonadRegionLogger IO where
  type Region IO = ConsoleRegion

  logGlobal :: HasCallStack => Text -> IO ()
logGlobal = Text -> IO ()
forall (m :: Type -> Type).
(HasCallStack, MonadTerminal m) =>
Text -> m ()
putTextLn

  logRegion :: HasCallStack => LogMode -> Region IO -> Text -> IO ()
logRegion LogMode
LogModeSet Region IO
cr = ConsoleRegion -> Text -> IO ()
forall v (m :: Type -> Type).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Regions.setConsoleRegion ConsoleRegion
Region IO
cr
  logRegion LogMode
LogModeAppend Region IO
cr = ConsoleRegion -> Text -> IO ()
forall v (m :: Type -> Type).
(Outputable v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Regions.appendConsoleRegion ConsoleRegion
Region IO
cr
  logRegion LogMode
LogModeFinish Region IO
cr = ConsoleRegion -> Text -> IO ()
forall v (m :: Type -> Type).
(Outputable v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Regions.finishConsoleRegion ConsoleRegion
Region IO
cr

  withRegion :: forall a.
HasCallStack =>
RegionLayout -> (Region IO -> IO a) -> IO a
withRegion = RegionLayout -> (ConsoleRegion -> IO a) -> IO a
RegionLayout -> (Region IO -> IO a) -> IO a
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
RegionLayout -> (ConsoleRegion -> m a) -> m a
Regions.withConsoleRegion

  displayRegions :: forall a. HasCallStack => IO a -> IO a
displayRegions = IO a -> IO a
forall (m :: Type -> Type) a.
(MonadIO m, MonadMask m) =>
m a -> m a
Regions.displayConsoleRegions

  regionList :: IO (TMVar [Region IO])
regionList = TMVar [ConsoleRegion] -> IO (TMVar [ConsoleRegion])
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TMVar [ConsoleRegion]
Regions.regionList

instance (MonadRegionLogger m) => MonadRegionLogger (ReaderT env m) where
  type Region (ReaderT env m) = Region m

  logGlobal :: HasCallStack => Text -> ReaderT env m ()
logGlobal = m () -> ReaderT env m ()
forall (m :: Type -> Type) a. Monad m => m a -> ReaderT env m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT env m ())
-> (Text -> m ()) -> Text -> ReaderT env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> m ()
forall (m :: Type -> Type).
(MonadRegionLogger m, HasCallStack) =>
Text -> m ()
logGlobal

  logRegion :: HasCallStack =>
LogMode -> Region (ReaderT env m) -> Text -> ReaderT env m ()
logRegion LogMode
m Region (ReaderT env m)
r = m () -> ReaderT env m ()
forall (m :: Type -> Type) a. Monad m => m a -> ReaderT env m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT env m ())
-> (Text -> m ()) -> Text -> ReaderT env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LogMode -> Region m -> Text -> m ()
forall (m :: Type -> Type).
(MonadRegionLogger m, HasCallStack) =>
LogMode -> Region m -> Text -> m ()
logRegion LogMode
m Region m
Region (ReaderT env m)
r

  withRegion :: forall a.
HasCallStack =>
RegionLayout
-> (Region (ReaderT env m) -> ReaderT env m a) -> ReaderT env m a
withRegion RegionLayout
l Region (ReaderT env m) -> ReaderT env m a
f =
    ReaderT env m env
forall r (m :: Type -> Type). MonadReader r m => m r
ask ReaderT env m env -> (env -> ReaderT env m a) -> ReaderT env m a
forall a b.
ReaderT env m a -> (a -> ReaderT env m b) -> ReaderT env m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \env
e -> m a -> ReaderT env m a
forall (m :: Type -> Type) a. Monad m => m a -> ReaderT env m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RegionLayout -> (Region m -> m a) -> m a
forall a. HasCallStack => RegionLayout -> (Region m -> m a) -> m a
forall (m :: Type -> Type) a.
(MonadRegionLogger m, HasCallStack) =>
RegionLayout -> (Region m -> m a) -> m a
withRegion RegionLayout
l (\Region m
r -> ReaderT env m a -> env -> m a
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (Region (ReaderT env m) -> ReaderT env m a
f Region m
Region (ReaderT env m)
r) env
e))

  displayRegions :: forall a. HasCallStack => ReaderT env m a -> ReaderT env m a
displayRegions ReaderT env m a
m = ReaderT env m env
forall r (m :: Type -> Type). MonadReader r m => m r
ask ReaderT env m env -> (env -> ReaderT env m a) -> ReaderT env m a
forall a b.
ReaderT env m a -> (a -> ReaderT env m b) -> ReaderT env m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \env
e -> m a -> ReaderT env m a
forall (m :: Type -> Type) a. Monad m => m a -> ReaderT env m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> m a
forall a. HasCallStack => m a -> m a
forall (m :: Type -> Type) a.
(MonadRegionLogger m, HasCallStack) =>
m a -> m a
displayRegions (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ ReaderT env m a -> env -> m a
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT ReaderT env m a
m env
e)

  regionList :: ReaderT env m (TMVar [Region (ReaderT env m)])
regionList = m (TMVar [Region m]) -> ReaderT env m (TMVar [Region m])
forall (m :: Type -> Type) a. Monad m => m a -> ReaderT env m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (TMVar [Region m])
forall (m :: Type -> Type).
MonadRegionLogger m =>
m (TMVar [Region m])
regionList

-- | Moves the timer region to the bottom of all active regions.
--
-- See NOTE: [Restore Timer Region].
restoreTimerRegion ::
  forall m.
  ( MonadAtomic m,
    MonadIORef m,
    MonadRegionLogger m
  ) =>
  IORef (Maybe (Region m)) ->
  m ()
restoreTimerRegion :: forall (m :: Type -> Type).
(MonadAtomic m, MonadIORef m, MonadRegionLogger m) =>
IORef (Maybe (Region m)) -> m ()
restoreTimerRegion IORef (Maybe (Region m))
timerRegionRef = do
  Maybe (Region m)
mRegion <- IORef (Maybe (Region m)) -> m (Maybe (Region m))
forall a. HasCallStack => IORef a -> m a
forall (m :: Type -> Type) a.
(MonadIORef m, HasCallStack) =>
IORef a -> m a
readIORef' IORef (Maybe (Region m))
timerRegionRef
  case Maybe (Region m)
mRegion of
    Maybe (Region m)
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    Just Region m
region -> do
      TMVar [Region m]
regionsVar <- m (TMVar [Region m])
forall (m :: Type -> Type).
MonadRegionLogger m =>
m (TMVar [Region m])
regionList
      STM () -> m ()
forall a. HasCallStack => STM a -> m a
forall (m :: Type -> Type) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TMVar [Region m] -> STM (Maybe [Region m])
forall a. TMVar a -> STM (Maybe a)
TMVar.tryReadTMVar TMVar [Region m]
regionsVar STM (Maybe [Region m]) -> (Maybe [Region m] -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe [Region m]
Nothing -> () -> STM ()
forall a. a -> STM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
        Just [Region m]
allRegions -> do
          let ([Region m]
allRegions', Bool
changed) = Region m -> [Region m] -> ([Region m], Bool)
forall a. Eq a => a -> [a] -> ([a], Bool)
moveRegionLast Region m
region [Region m]
allRegions
          -- Doesn't seem necessary, but maybe worth only messing with the UI
          -- when there has strictly been a change. At the very least we may
          -- want this if we move these function calls to the timer
          -- (i.e. every second).
          Bool -> STM () -> STM ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
changed (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TMVar [Region m] -> [Region m] -> STM ()
forall a. TMVar a -> a -> STM ()
TMVar.writeTMVar TMVar [Region m]
regionsVar [Region m]
allRegions'
  where
    -- Searches for the given element in the list. Removes all occurences,
    -- and if any were found, prepends it to the new list.
    -- I _thought_ I had to end this with a 'reverse' as foldl' reverses the
    -- list. But for whatever reason, the appears not to be the case.
    --
    -- More precisely, without the reverse, the TimerRegion (what we are
    -- searching for) ends up on the bottom, as we want. With the reverse,
    -- it is succeeded by the command logs. I am not sure why.
    moveRegionLast :: forall a. (Eq a) => a -> List a -> Tuple2 (List a) Bool
    moveRegionLast :: forall a. Eq a => a -> [a] -> ([a], Bool)
moveRegionLast a
r = ([a], Bool) -> ([a], Bool)
k (([a], Bool) -> ([a], Bool))
-> ([a] -> ([a], Bool)) -> [a] -> ([a], Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (([a], Bool) -> a -> ([a], Bool))
-> ([a], Bool) -> [a] -> ([a], Bool)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([a], Bool) -> a -> ([a], Bool)
go ([], Bool
False)
      where
        go :: Tuple2 (List a) Bool -> a -> Tuple2 (List a) Bool
        go :: ([a], Bool) -> a -> ([a], Bool)
go ([a]
acc, Bool
found) a
s
          | a
r a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
s = ([a]
acc, Bool
True)
          | Bool
otherwise = (a
s a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc, Bool
found)

        k :: Tuple2 (List a) Bool -> Tuple2 (List a) Bool
        k :: ([a], Bool) -> ([a], Bool)
k ([a]
acc, Bool
False) = ([a]
acc, Bool
False)
        k ([a]
acc, Bool
True) = (a
r a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc, Bool
True)