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
toTIdTrace :: Trace -> [(ThreadId, ThreadAction)]
toTIdTrace =
tail . scanl (\(t, _) (d, _, a) -> (tidOf t d, a)) (initialThread, undefined)
showTrace :: Trace -> String
showTrace [] = "<trace discarded>"
showTrace trc = intercalate "\n" $ go False trc : strkey where
go _ ((_,_,CommitIORef _ _):rest) = "C-" ++ go False rest
go _ ((Start (ThreadId (Id _ i)),_,a):rest) = "S" ++ show i ++ "-" ++ go (didYield a) rest
go y ((SwitchTo (ThreadId (Id _ i)),_,a):rest) = (if y then "p" else "P") ++ show i ++ "-" ++ go (didYield a) rest
go _ ((Continue,_,a):rest) = '-' : go (didYield a) rest
go _ _ = ""
strkey =
[" " ++ show i ++ ": " ++ name | (i, name) <- threadNames trc]
didYield Yield = True
didYield (ThreadDelay _) = True
didYield _ = False
threadNames :: Trace -> [(Int, String)]
threadNames = mapMaybe go where
go (_, _, Fork (ThreadId (Id (Just name) i))) = Just (i, name)
go (_, _, ForkOS (ThreadId (Id (Just name) i))) = Just (i, name)
go _ = Nothing
simplestsBy :: (x -> x -> Bool) -> [(x, Trace)] -> [(x, Trace)]
simplestsBy f = map choose . collect where
collect = groupBy' [] (\(a,_) (b,_) -> f a b)
choose = minimumBy . comparing $ \(_, trc) ->
let switchTos = length . filter (\(d,_,_) -> case d of SwitchTo _ -> True; _ -> False)
starts = length . filter (\(d,_,_) -> case d of Start _ -> True; _ -> False)
commits = length . filter (\(_,_,a) -> case a of CommitIORef _ _ -> True; _ -> False)
in (switchTos trc, commits trc, length trc, starts trc)
groupBy' res _ [] = res
groupBy' res eq (y:ys) = groupBy' (insert' eq y res) eq ys
insert' _ x [] = [[x]]
insert' eq x (ys@(y:_):yss)
| x `eq` y = (x:ys) : yss
| otherwise = ys : insert' eq x yss
insert' _ _ ([]:_) = undefined
showCondition :: Condition -> String
showCondition Abort = "[abort]"
showCondition Deadlock = "[deadlock]"
showCondition (UncaughtException exc) = "[" ++ displayException exc ++ "]"
showCondition (InvariantFailure _) = "[invariant failure]"
tidOf :: ThreadId -> Decision -> ThreadId
tidOf _ (Start t) = t
tidOf _ (SwitchTo t) = t
tidOf tid _ = tid
decisionOf :: Foldable f
=> Maybe ThreadId
-> f ThreadId
-> ThreadId
-> Decision
decisionOf Nothing _ chosen = Start chosen
decisionOf (Just prior) runnable chosen
| prior == chosen = Continue
| prior `elem` runnable = SwitchTo chosen
| otherwise = Start chosen