-- |
-- Module      : Test.DejaFu.Utils
-- Copyright   : (c) 2017--2018 Michael Walker
-- License     : MIT
-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
-- Stability   : experimental
-- Portability : portable
--
-- Utility functions for users of dejafu.
module Test.DejaFu.Utils where

import           Control.Exception (Exception(..), displayException)
import           Data.List         (intercalate, minimumBy)
import           Data.Maybe        (mapMaybe)
import           Data.Ord          (comparing)

import           Test.DejaFu.Types

-------------------------------------------------------------------------------
-- * Traces

-- | Turn a 'Trace' into an abbreviated form.
--
-- @since 1.3.2.0
toTIdTrace :: Trace -> [(ThreadId, ThreadAction)]
toTIdTrace :: Trace -> [(ThreadId, ThreadAction)]
toTIdTrace =
  Int -> [(ThreadId, ThreadAction)] -> [(ThreadId, ThreadAction)]
forall a. Int -> [a] -> [a]
drop Int
1 ([(ThreadId, ThreadAction)] -> [(ThreadId, ThreadAction)])
-> (Trace -> [(ThreadId, ThreadAction)])
-> Trace
-> [(ThreadId, ThreadAction)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ThreadId, ThreadAction)
 -> (Decision, [(ThreadId, Lookahead)], ThreadAction)
 -> (ThreadId, ThreadAction))
-> (ThreadId, ThreadAction) -> Trace -> [(ThreadId, ThreadAction)]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\(ThreadId
t, ThreadAction
_) (Decision
d, [(ThreadId, Lookahead)]
_, ThreadAction
a) -> (ThreadId -> Decision -> ThreadId
tidOf ThreadId
t Decision
d, ThreadAction
a)) (ThreadId
initialThread, ThreadAction
forall a. HasCallStack => a
undefined)

-- | Pretty-print a trace, including a key of the thread IDs (not
-- including thread 0). Each line of the key is indented by two
-- spaces.
--
-- @since 0.5.0.0
showTrace :: Trace -> String
showTrace :: Trace -> String
showTrace []  = String
"<trace discarded>"
showTrace Trace
trc = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Bool -> Trace -> String
forall {b}. Bool -> [(Decision, b, ThreadAction)] -> String
go Bool
False Trace
trc String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
strkey where
  go :: Bool -> [(Decision, b, ThreadAction)] -> String
go Bool
_ ((Decision
_,b
_,CommitIORef ThreadId
_ IORefId
_):[(Decision, b, ThreadAction)]
rest) = String
"C-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> [(Decision, b, ThreadAction)] -> String
go Bool
False [(Decision, b, ThreadAction)]
rest
  go Bool
_ ((Start    (ThreadId (Id Maybe String
_ Int
i)),b
_,ThreadAction
a):[(Decision, b, ThreadAction)]
rest) = String
"S" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> [(Decision, b, ThreadAction)] -> String
go (ThreadAction -> Bool
didYield ThreadAction
a) [(Decision, b, ThreadAction)]
rest
  go Bool
y ((SwitchTo (ThreadId (Id Maybe String
_ Int
i)),b
_,ThreadAction
a):[(Decision, b, ThreadAction)]
rest) = (if Bool
y then String
"p" else String
"P") String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> [(Decision, b, ThreadAction)] -> String
go (ThreadAction -> Bool
didYield ThreadAction
a) [(Decision, b, ThreadAction)]
rest
  go Bool
_ ((Decision
Continue,b
_,ThreadAction
a):[(Decision, b, ThreadAction)]
rest) = Char
'-' Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> [(Decision, b, ThreadAction)] -> String
go (ThreadAction -> Bool
didYield ThreadAction
a) [(Decision, b, ThreadAction)]
rest
  go Bool
_ [(Decision, b, ThreadAction)]
_ = String
""

  strkey :: [String]
strkey =
    [String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name | (Int
i, String
name) <- Trace -> [(Int, String)]
threadNames Trace
trc]

  didYield :: ThreadAction -> Bool
didYield ThreadAction
Yield = Bool
True
  didYield (ThreadDelay Int
_) = Bool
True
  didYield ThreadAction
_ = Bool
False

-- | Get all named threads in the trace.
--
-- @since 0.7.3.0
threadNames :: Trace -> [(Int, String)]
threadNames :: Trace -> [(Int, String)]
threadNames = ((Decision, [(ThreadId, Lookahead)], ThreadAction)
 -> Maybe (Int, String))
-> Trace -> [(Int, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Decision, [(ThreadId, Lookahead)], ThreadAction)
-> Maybe (Int, String)
forall {a} {b}. (a, b, ThreadAction) -> Maybe (Int, String)
go where
  go :: (a, b, ThreadAction) -> Maybe (Int, String)
go (a
_, b
_, Fork   (ThreadId (Id (Just String
name) Int
i))) = (Int, String) -> Maybe (Int, String)
forall a. a -> Maybe a
Just (Int
i, String
name)
  go (a
_, b
_, ForkOS (ThreadId (Id (Just String
name) Int
i))) = (Int, String) -> Maybe (Int, String)
forall a. a -> Maybe a
Just (Int
i, String
name)
  go (a, b, ThreadAction)
_ = Maybe (Int, String)
forall a. Maybe a
Nothing

-- | Find the \"simplest\" trace leading to each result.
simplestsBy :: (x -> x -> Bool) -> [(x, Trace)] -> [(x, Trace)]
simplestsBy :: forall x. (x -> x -> Bool) -> [(x, Trace)] -> [(x, Trace)]
simplestsBy x -> x -> Bool
f = ([(x, Trace)] -> (x, Trace)) -> [[(x, Trace)]] -> [(x, Trace)]
forall a b. (a -> b) -> [a] -> [b]
map [(x, Trace)] -> (x, Trace)
forall {a} {b}.
[(a, [(Decision, b, ThreadAction)])]
-> (a, [(Decision, b, ThreadAction)])
choose ([[(x, Trace)]] -> [(x, Trace)])
-> ([(x, Trace)] -> [[(x, Trace)]]) -> [(x, Trace)] -> [(x, Trace)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(x, Trace)] -> [[(x, Trace)]]
forall {b}. [(x, b)] -> [[(x, b)]]
collect where
  collect :: [(x, b)] -> [[(x, b)]]
collect = [[(x, b)]] -> ((x, b) -> (x, b) -> Bool) -> [(x, b)] -> [[(x, b)]]
forall {t}. [[t]] -> (t -> t -> Bool) -> [t] -> [[t]]
groupBy' [] (\(x
a,b
_) (x
b,b
_) -> x -> x -> Bool
f x
a x
b)
  choose :: [(a, [(Decision, b, ThreadAction)])]
-> (a, [(Decision, b, ThreadAction)])
choose  = ((a, [(Decision, b, ThreadAction)])
 -> (a, [(Decision, b, ThreadAction)]) -> Ordering)
-> [(a, [(Decision, b, ThreadAction)])]
-> (a, [(Decision, b, ThreadAction)])
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (((a, [(Decision, b, ThreadAction)])
  -> (a, [(Decision, b, ThreadAction)]) -> Ordering)
 -> [(a, [(Decision, b, ThreadAction)])]
 -> (a, [(Decision, b, ThreadAction)]))
-> (((a, [(Decision, b, ThreadAction)]) -> (Int, Int, Int, Int))
    -> (a, [(Decision, b, ThreadAction)])
    -> (a, [(Decision, b, ThreadAction)])
    -> Ordering)
-> ((a, [(Decision, b, ThreadAction)]) -> (Int, Int, Int, Int))
-> [(a, [(Decision, b, ThreadAction)])]
-> (a, [(Decision, b, ThreadAction)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, [(Decision, b, ThreadAction)]) -> (Int, Int, Int, Int))
-> (a, [(Decision, b, ThreadAction)])
-> (a, [(Decision, b, ThreadAction)])
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (((a, [(Decision, b, ThreadAction)]) -> (Int, Int, Int, Int))
 -> [(a, [(Decision, b, ThreadAction)])]
 -> (a, [(Decision, b, ThreadAction)]))
-> ((a, [(Decision, b, ThreadAction)]) -> (Int, Int, Int, Int))
-> [(a, [(Decision, b, ThreadAction)])]
-> (a, [(Decision, b, ThreadAction)])
forall a b. (a -> b) -> a -> b
$ \(a
_, [(Decision, b, ThreadAction)]
trc) ->
    let switchTos :: [(Decision, b, c)] -> Int
switchTos = [(Decision, b, c)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Decision, b, c)] -> Int)
-> ([(Decision, b, c)] -> [(Decision, b, c)])
-> [(Decision, b, c)]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Decision, b, c) -> Bool)
-> [(Decision, b, c)] -> [(Decision, b, c)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Decision
d,b
_,c
_) -> case Decision
d of SwitchTo ThreadId
_ -> Bool
True; Decision
_ -> Bool
False)
        starts :: [(Decision, b, c)] -> Int
starts    = [(Decision, b, c)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Decision, b, c)] -> Int)
-> ([(Decision, b, c)] -> [(Decision, b, c)])
-> [(Decision, b, c)]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Decision, b, c) -> Bool)
-> [(Decision, b, c)] -> [(Decision, b, c)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Decision
d,b
_,c
_) -> case Decision
d of Start    ThreadId
_ -> Bool
True; Decision
_ -> Bool
False)
        commits :: [(a, b, ThreadAction)] -> Int
commits   = [(a, b, ThreadAction)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(a, b, ThreadAction)] -> Int)
-> ([(a, b, ThreadAction)] -> [(a, b, ThreadAction)])
-> [(a, b, ThreadAction)]
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b, ThreadAction) -> Bool)
-> [(a, b, ThreadAction)] -> [(a, b, ThreadAction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
_,b
_,ThreadAction
a) -> case ThreadAction
a of CommitIORef ThreadId
_ IORefId
_ -> Bool
True; ThreadAction
_ -> Bool
False)
    in ([(Decision, b, ThreadAction)] -> Int
forall {b} {c}. [(Decision, b, c)] -> Int
switchTos [(Decision, b, ThreadAction)]
trc, [(Decision, b, ThreadAction)] -> Int
forall {a} {b}. [(a, b, ThreadAction)] -> Int
commits [(Decision, b, ThreadAction)]
trc, [(Decision, b, ThreadAction)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Decision, b, ThreadAction)]
trc, [(Decision, b, ThreadAction)] -> Int
forall {b} {c}. [(Decision, b, c)] -> Int
starts [(Decision, b, ThreadAction)]
trc)

  groupBy' :: [[t]] -> (t -> t -> Bool) -> [t] -> [[t]]
groupBy' [[t]]
res t -> t -> Bool
_ [] = [[t]]
res
  groupBy' [[t]]
res t -> t -> Bool
eq (t
y:[t]
ys) = [[t]] -> (t -> t -> Bool) -> [t] -> [[t]]
groupBy' ((t -> t -> Bool) -> t -> [[t]] -> [[t]]
forall {t}. (t -> t -> Bool) -> t -> [[t]] -> [[t]]
insert' t -> t -> Bool
eq t
y [[t]]
res) t -> t -> Bool
eq [t]
ys

  insert' :: (t -> t -> Bool) -> t -> [[t]] -> [[t]]
insert' t -> t -> Bool
_ t
x [] = [[t
x]]
  insert' t -> t -> Bool
eq t
x (ys :: [t]
ys@(t
y:[t]
_):[[t]]
yss)
    | t
x t -> t -> Bool
`eq` t
y  = (t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
ys) [t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
: [[t]]
yss
    | Bool
otherwise = [t]
ys [t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
: (t -> t -> Bool) -> t -> [[t]] -> [[t]]
insert' t -> t -> Bool
eq t
x [[t]]
yss
  insert' t -> t -> Bool
_ t
_ ([]:[[t]]
_) = [[t]]
forall a. HasCallStack => a
undefined

-------------------------------------------------------------------------------
-- * Conditions

-- | Pretty-print a condition
--
-- @since 1.12.0.0
showCondition :: Condition -> String
showCondition :: Condition -> String
showCondition Condition
Abort = String
"[abort]"
showCondition Condition
Deadlock = String
"[deadlock]"
showCondition (UncaughtException SomeException
exc) = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
exc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
showCondition (InvariantFailure SomeException
_) = String
"[invariant failure]"

-------------------------------------------------------------------------------
-- * Scheduling

-- | Get the resultant thread identifier of a 'Decision', with a default case
-- for 'Continue'.
--
-- @since 0.5.0.0
tidOf :: ThreadId -> Decision -> ThreadId
tidOf :: ThreadId -> Decision -> ThreadId
tidOf ThreadId
_ (Start ThreadId
t)    = ThreadId
t
tidOf ThreadId
_ (SwitchTo ThreadId
t) = ThreadId
t
tidOf ThreadId
tid Decision
_          = ThreadId
tid

-- | Get the 'Decision' that would have resulted in this thread
-- identifier, given a prior thread (if any) and collection of threads
-- which are unblocked at this point.
--
-- @since 0.5.0.0
decisionOf :: Foldable f
  => Maybe ThreadId
  -- ^ The prior thread.
  -> f ThreadId
  -- ^ The threads.
  -> ThreadId
  -- ^ The current thread.
  -> Decision
decisionOf :: forall (f :: * -> *).
Foldable f =>
Maybe ThreadId -> f ThreadId -> ThreadId -> Decision
decisionOf Maybe ThreadId
Nothing f ThreadId
_ ThreadId
chosen = ThreadId -> Decision
Start ThreadId
chosen
decisionOf (Just ThreadId
prior) f ThreadId
runnable ThreadId
chosen
  | ThreadId
prior ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
chosen = Decision
Continue
  | ThreadId
prior ThreadId -> f ThreadId -> Bool
forall a. Eq a => a -> f a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` f ThreadId
runnable = ThreadId -> Decision
SwitchTo ThreadId
chosen
  | Bool
otherwise = ThreadId -> Decision
Start ThreadId
chosen