{-# LANGUAGE GADTs               #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Internal types shared between `IOSim` and `IOSimPOR`.
--
module Control.Monad.IOSim.InternalTypes
  ( ThreadControl (..)
  , ControlStack (..)
  , IsLocked (..)
  , unsafeUnregisterTimeout
  ) where

import           Control.Exception (Exception)
import           Control.Concurrent.Class.MonadSTM
import           Control.Monad.Class.MonadThrow (MaskingState (..))

import           Control.Monad.IOSim.Types (IOSim (..), SimA (..), IOSimThreadId, TimeoutId)

import           GHC.Exts (oneShot)

-- We hide the type @b@ here, so it's useful to bundle these two parts together,
-- rather than having Thread have an existential type, which makes record
-- updates awkward.
data ThreadControl s a where
  ThreadControl :: SimA s b
                -> !(ControlStack s b a)
                -> ThreadControl s a

instance Show (ThreadControl s a) where
  show :: ThreadControl s a -> String
show ThreadControl s a
_ = String
"..."

data ControlStack s b a where
  MainFrame  :: ControlStack s a  a
  ForkFrame  :: ControlStack s () a
  MaskFrame  :: (b -> SimA s c)         -- subsequent continuation
             -> MaskingState            -- thread local state to restore
             -> !(ControlStack s c a)
             -> ControlStack s b a
  CatchFrame :: Exception e
             => (e -> SimA s b)         -- exception continuation
             -> (b -> SimA s c)         -- subsequent continuation
             -> !(ControlStack s c a)
             -> ControlStack s b a
  TimeoutFrame :: TimeoutId
               -> TMVar (IOSim s) IOSimThreadId
               -> (Maybe b -> SimA s c)
               -> !(ControlStack s c a)
               -> ControlStack s b a
  DelayFrame   :: TimeoutId
               -> SimA s c
               -> ControlStack s c a
               -> ControlStack s b a

instance Show (ControlStack s b a) where
  show :: ControlStack s b a -> String
show = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b'. ControlStack s b' a -> ControlStackDash
dash
    where
      dash :: ControlStack s b' a -> ControlStackDash
      dash :: forall b'. ControlStack s b' a -> ControlStackDash
dash ControlStack s b' a
MainFrame                  = ControlStackDash
MainFrame'
      dash ControlStack s b' a
ForkFrame                  = ControlStackDash
ForkFrame'
      dash (MaskFrame b' -> SimA s c
_ MaskingState
m ControlStack s c a
cs)         = MaskingState -> ControlStackDash -> ControlStackDash
MaskFrame' MaskingState
m (forall b'. ControlStack s b' a -> ControlStackDash
dash ControlStack s c a
cs)
      dash (CatchFrame e -> SimA s b'
_ b' -> SimA s c
_ ControlStack s c a
cs)        = ControlStackDash -> ControlStackDash
CatchFrame' (forall b'. ControlStack s b' a -> ControlStackDash
dash ControlStack s c a
cs)
      dash (TimeoutFrame TimeoutId
tmid TMVar (IOSim s) IOSimThreadId
_ Maybe b' -> SimA s c
_ ControlStack s c a
cs) = TimeoutId -> ControlStackDash -> ControlStackDash
TimeoutFrame' TimeoutId
tmid (forall b'. ControlStack s b' a -> ControlStackDash
dash ControlStack s c a
cs)
      dash (DelayFrame TimeoutId
tmid SimA s c
_ ControlStack s c a
cs)     = TimeoutId -> ControlStackDash -> ControlStackDash
DelayFrame' TimeoutId
tmid (forall b'. ControlStack s b' a -> ControlStackDash
dash ControlStack s c a
cs)

data ControlStackDash =
    MainFrame'
  | ForkFrame'
  | MaskFrame' MaskingState ControlStackDash
  | CatchFrame' ControlStackDash
  -- TODO: Figure out a better way to include IsLocked here
  | TimeoutFrame' TimeoutId ControlStackDash
  | ThreadDelayFrame' TimeoutId ControlStackDash
  | DelayFrame' TimeoutId ControlStackDash
  deriving Int -> ControlStackDash -> ShowS
[ControlStackDash] -> ShowS
ControlStackDash -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControlStackDash] -> ShowS
$cshowList :: [ControlStackDash] -> ShowS
show :: ControlStackDash -> String
$cshow :: ControlStackDash -> String
showsPrec :: Int -> ControlStackDash -> ShowS
$cshowsPrec :: Int -> ControlStackDash -> ShowS
Show

data IsLocked = NotLocked | Locked !IOSimThreadId
  deriving (IsLocked -> IsLocked -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IsLocked -> IsLocked -> Bool
$c/= :: IsLocked -> IsLocked -> Bool
== :: IsLocked -> IsLocked -> Bool
$c== :: IsLocked -> IsLocked -> Bool
Eq, Int -> IsLocked -> ShowS
[IsLocked] -> ShowS
IsLocked -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IsLocked] -> ShowS
$cshowList :: [IsLocked] -> ShowS
show :: IsLocked -> String
$cshow :: IsLocked -> String
showsPrec :: Int -> IsLocked -> ShowS
$cshowsPrec :: Int -> IsLocked -> ShowS
Show)

-- | Unsafe method which removes a timeout.
--
-- It's not part of public API, and it might cause deadlocks when used in
-- a wrong context.
--
-- It is defined here rather so that it's not exposed to the user, even tough
-- one could define it oneself.
--
-- TODO: `SimA` constructors should be defined here.
--
unsafeUnregisterTimeout :: TimeoutId -> IOSim s ()
unsafeUnregisterTimeout :: forall s. TimeoutId -> IOSim s ()
unsafeUnregisterTimeout TimeoutId
tmid = forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> forall s a. TimeoutId -> SimA s a -> SimA s a
UnregisterTimeout TimeoutId
tmid (() -> SimA s r
k ())