module Control.Monad.IOSimPOR.Types where

import qualified Data.List as List
import           Data.Set (Set)
import qualified Data.Set as Set

import           Control.Monad.IOSim.CommonTypes

--
-- Effects
--

-- | An `Effect` aggregates effects performed by a thread.  Only used by
-- *IOSimPOR*.
--
data Effect = Effect {
    Effect -> Set TVarId
effectReads  :: !(Set TVarId),
    Effect -> Set TVarId
effectWrites :: !(Set TVarId),
    Effect -> Set ThreadId
effectForks  :: !(Set ThreadId),
    Effect -> [ThreadId]
effectThrows :: ![ThreadId],
    Effect -> [ThreadId]
effectWakeup :: ![ThreadId]
  }
  deriving (Effect -> Effect -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Effect -> Effect -> Bool
$c/= :: Effect -> Effect -> Bool
== :: Effect -> Effect -> Bool
$c== :: Effect -> Effect -> Bool
Eq, Int -> Effect -> ShowS
[Effect] -> ShowS
Effect -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Effect] -> ShowS
$cshowList :: [Effect] -> ShowS
show :: Effect -> String
$cshow :: Effect -> String
showsPrec :: Int -> Effect -> ShowS
$cshowsPrec :: Int -> Effect -> ShowS
Show)

instance Semigroup Effect where
  Effect Set TVarId
r Set TVarId
w Set ThreadId
s [ThreadId]
ts [ThreadId]
wu <> :: Effect -> Effect -> Effect
<> Effect Set TVarId
r' Set TVarId
w' Set ThreadId
s' [ThreadId]
ts' [ThreadId]
wu' =
    Set TVarId
-> Set TVarId -> Set ThreadId -> [ThreadId] -> [ThreadId] -> Effect
Effect (Set TVarId
r forall a. Semigroup a => a -> a -> a
<> Set TVarId
r') (Set TVarId
w forall a. Semigroup a => a -> a -> a
<> Set TVarId
w') (Set ThreadId
s forall a. Semigroup a => a -> a -> a
<> Set ThreadId
s') ([ThreadId]
ts forall a. [a] -> [a] -> [a]
++ [ThreadId]
ts') ([ThreadId]
wuforall a. [a] -> [a] -> [a]
++[ThreadId]
wu')

instance Monoid Effect where
  mempty :: Effect
mempty = Set TVarId
-> Set TVarId -> Set ThreadId -> [ThreadId] -> [ThreadId] -> Effect
Effect forall a. Set a
Set.empty forall a. Set a
Set.empty forall a. Set a
Set.empty [] []

-- readEffect :: SomeTVar s -> Effect
-- readEffect r = mempty{effectReads = Set.singleton $ someTvarId r }

readEffects :: [SomeTVar s] -> Effect
readEffects :: forall s. [SomeTVar s] -> Effect
readEffects [SomeTVar s]
rs = forall a. Monoid a => a
mempty{effectReads :: Set TVarId
effectReads = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall s. SomeTVar s -> TVarId
someTvarId [SomeTVar s]
rs)}

-- writeEffect :: SomeTVar s -> Effect
-- writeEffect r = mempty{effectWrites = Set.singleton $ someTvarId r }

writeEffects :: [SomeTVar s] -> Effect
writeEffects :: forall s. [SomeTVar s] -> Effect
writeEffects [SomeTVar s]
rs = forall a. Monoid a => a
mempty{effectWrites :: Set TVarId
effectWrites = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall s. SomeTVar s -> TVarId
someTvarId [SomeTVar s]
rs)}

forkEffect :: ThreadId -> Effect
forkEffect :: ThreadId -> Effect
forkEffect ThreadId
tid = forall a. Monoid a => a
mempty{effectForks :: Set ThreadId
effectForks = forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ ThreadId
tid}

throwToEffect :: ThreadId -> Effect
throwToEffect :: ThreadId -> Effect
throwToEffect ThreadId
tid = forall a. Monoid a => a
mempty{ effectThrows :: [ThreadId]
effectThrows = [ThreadId
tid] }

wakeupEffects :: [ThreadId] -> Effect
wakeupEffects :: [ThreadId] -> Effect
wakeupEffects [ThreadId]
tids = forall a. Monoid a => a
mempty{effectWakeup :: [ThreadId]
effectWakeup = [ThreadId]
tids}

someTvarId :: SomeTVar s -> TVarId
someTvarId :: forall s. SomeTVar s -> TVarId
someTvarId (SomeTVar TVar s a
r) = forall s a. TVar s a -> TVarId
tvarId TVar s a
r

onlyReadEffect :: Effect -> Bool
onlyReadEffect :: Effect -> Bool
onlyReadEffect Effect
e = Effect
e { effectReads :: Set TVarId
effectReads = Effect -> Set TVarId
effectReads forall a. Monoid a => a
mempty } forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty

racingEffects :: Effect -> Effect -> Bool
racingEffects :: Effect -> Effect -> Bool
racingEffects Effect
e Effect
e' =
      Effect -> [ThreadId]
effectThrows Effect
e       forall a. Eq a => [a] -> [a] -> Bool
`intersectsL` Effect -> [ThreadId]
effectThrows Effect
e'
   Bool -> Bool -> Bool
|| Effect -> Set TVarId
effectReads  Effect
e       forall a. Ord a => Set a -> Set a -> Bool
`intersects`  Effect -> Set TVarId
effectWrites Effect
e'
   Bool -> Bool -> Bool
|| Effect -> Set TVarId
effectWrites Effect
e       forall a. Ord a => Set a -> Set a -> Bool
`intersects`  Effect -> Set TVarId
effectReads  Effect
e'
   Bool -> Bool -> Bool
|| Effect -> Set TVarId
effectWrites Effect
e       forall a. Ord a => Set a -> Set a -> Bool
`intersects`  Effect -> Set TVarId
effectWrites Effect
e'
  where
    intersects :: Ord a => Set a -> Set a -> Bool
    intersects :: forall a. Ord a => Set a -> Set a -> Bool
intersects Set a
a Set a
b = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Set a
a forall a. Ord a => Set a -> Set a -> Bool
`Set.disjoint` Set a
b

    intersectsL :: Eq a => [a] -> [a] -> Bool
    intersectsL :: forall a. Eq a => [a] -> [a] -> Bool
intersectsL [a]
a [a]
b = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [a]
a forall a. Eq a => [a] -> [a] -> [a]
`List.intersect` [a]
b