content: {-# OPTIONS_GHC -O2 #-}
  {-# LANGUAGE RankNTypes   #-}
  {-# LANGUAGE TypeFamilies #-}
  
  -- | Base monad used in tests, some real-world functionality is emulated.
  -- It's called 'Emulation' to follow the style used in node-sketch, where
  -- real-world analogue is called 'Production'.
  
  module Test.Pos.Block.Logic.Emulation
         ( ClockVar (..)
         , Emulation (..)
         , runEmulation
         , sudoLiftIO
         ) where
  
  import           Universum
  
  import           Control.Monad.Base (MonadBase (..))
  import qualified Control.Monad.Trans.Control as MC
  import qualified Crypto.Random as Rand
  import           Data.Coerce (coerce)
  import           Data.Time.Units (Microsecond)
  import           UnliftIO (MonadUnliftIO)
  
  import           Pos.Util.Wlog (CanLog (..))
  
  newtype ClockVar = ClockVar (IORef Microsecond)
  
  newtype Emulation a = Emulation { unEmulation :: ReaderT ClockVar IO a }
    deriving
      (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)
  
  instance Rand.MonadRandom Emulation where
      getRandomBytes = Emulation . lift . Rand.getRandomBytes
  
  runEmulation :: Microsecond -> Emulation a -> IO a
  runEmulation startTime m = do
      clockVar <- newIORef startTime
      runReaderT (unEmulation m) (ClockVar clockVar)
  
  -- Lift IO without a warning.
  sudoLiftIO :: IO a -> Emulation a
  sudoLiftIO m = Emulation (liftIO m)
  
  instance MonadIO Emulation where
      liftIO m = Emulation . liftIO $ do
          -- if you see a lot of stars in the test log, a hunting season for
          -- not-mocked operations is open.
          --
          -- It's currently commented because stars take too much buffer space
          -- (all of my tmux @volhovm)
          --
          -- putStr ("*" :: String)
          m
  
  instance MonadBase IO Emulation where
      liftBase = liftIO
  
  type LiftBaseWith b m a = (MC.RunInBase m b -> b a) -> m a
  
  newtype LiftBaseWith' b m a = LBW { unLBW :: LiftBaseWith b m a }
  
  coerceLiftBaseWith ::
      LiftBaseWith b (ReaderT ClockVar IO) a ->
      LiftBaseWith b Emulation             a
  coerceLiftBaseWith lbw =
      unLBW (coerce (LBW lbw))
  
  -- Bad instance! Bad! Kill it!
  -- NB. the instance is correct, but
  --    we don't need no IO actions
  --    we don't need no flow control
  --    no damn exceptions in the test logs
  --    hey, -------, leave the code alone.
  instance MC.MonadBaseControl IO Emulation where
      type StM Emulation a = a
      liftBaseWith = coerceLiftBaseWith MC.liftBaseWith
      restoreM =
        (coerce :: forall a .
          (a -> ReaderT ClockVar IO a) ->
          (a -> Emulation a))
        MC.restoreM
  
  instance CanLog Emulation where
      dispatchMessage ln s t = Emulation $ dispatchMessage ln s t
  