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
(Effect -> Effect -> Bool)
-> (Effect -> Effect -> Bool) -> Eq Effect
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
(Int -> Effect -> ShowS)
-> (Effect -> String) -> ([Effect] -> ShowS) -> Show Effect
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
rSet TVarId -> Set TVarId -> Set TVarId
forall a. Semigroup a => a -> a -> a
<>Set TVarId
r') (Set TVarId
wSet TVarId -> Set TVarId -> Set TVarId
forall a. Semigroup a => a -> a -> a
<>Set TVarId
w') (Set ThreadId
sSet ThreadId -> Set ThreadId -> Set ThreadId
forall a. Semigroup a => a -> a -> a
<>Set ThreadId
s') ([ThreadId]
ts[ThreadId] -> [ThreadId] -> [ThreadId]
forall a. [a] -> [a] -> [a]
++[ThreadId]
ts') ([ThreadId]
wu[ThreadId] -> [ThreadId] -> [ThreadId]
forall a. [a] -> [a] -> [a]
++[ThreadId]
wu')

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

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

readEffects :: [SomeTVar s] -> Effect
readEffects :: [SomeTVar s] -> Effect
readEffects [SomeTVar s]
rs = Effect
forall a. Monoid a => a
mempty{effectReads :: Set TVarId
effectReads = [TVarId] -> Set TVarId
forall a. Ord a => [a] -> Set a
Set.fromList ((SomeTVar s -> TVarId) -> [SomeTVar s] -> [TVarId]
forall a b. (a -> b) -> [a] -> [b]
map SomeTVar s -> TVarId
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 :: [SomeTVar s] -> Effect
writeEffects [SomeTVar s]
rs = Effect
forall a. Monoid a => a
mempty{effectWrites :: Set TVarId
effectWrites = [TVarId] -> Set TVarId
forall a. Ord a => [a] -> Set a
Set.fromList ((SomeTVar s -> TVarId) -> [SomeTVar s] -> [TVarId]
forall a b. (a -> b) -> [a] -> [b]
map SomeTVar s -> TVarId
forall s. SomeTVar s -> TVarId
someTvarId [SomeTVar s]
rs)}

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

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

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

someTvarId :: SomeTVar s -> TVarId
someTvarId :: SomeTVar s -> TVarId
someTvarId (SomeTVar TVar s a
r) = TVar s a -> TVarId
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 Effect
forall a. Monoid a => a
mempty } Effect -> Effect -> Bool
forall a. Eq a => a -> a -> Bool
== Effect
forall a. Monoid a => a
mempty

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

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