module Control.Concurrent.CHP.Traces.Structural (StructuralTrace(..), EventHierarchy(..), getStructuralPlain, runCHP_StructuralTrace, runCHP_StructuralTraceAndPrint,
getAllEventsInHierarchy) where
import Control.Applicative hiding (empty)
import qualified Data.Foldable as F
import Data.IORef
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Traversable as T
import Data.Unique
import Text.PrettyPrint.HughesPJ
import Control.Concurrent.CHP.Base
import Control.Concurrent.CHP.Traces.Base
data EventHierarchy a =
SingleEvent a
| StructuralSequence Int [EventHierarchy a]
| StructuralParallel [EventHierarchy a]
deriving (Show, Read)
instance Eq a => Eq (EventHierarchy a) where
(SingleEvent x) == (SingleEvent y) = x == y
(StructuralSequence m es) == (StructuralSequence m' es')
= concat (replicate m es) == concat (replicate m' es')
(StructuralParallel es) == (StructuralParallel es')
= es `bagsEq` es'
(StructuralSequence 1 [x]) == y = x == y
x == (StructuralSequence 1 [y]) = x == y
(StructuralParallel [x]) == y = x == y
x == (StructuralParallel [y]) = x == y
_ == _ = False
instance Functor EventHierarchy where
fmap f (SingleEvent x) = SingleEvent $ f x
fmap f (StructuralSequence n es) = StructuralSequence n $ map (fmap f) es
fmap f (StructuralParallel es) = StructuralParallel $ map (fmap f) es
instance F.Foldable EventHierarchy where
foldr f y (SingleEvent x) = f x y
foldr f y (StructuralSequence _ es) = F.foldr (flip $ F.foldr f) y es
foldr f y (StructuralParallel es) = F.foldr (flip $ F.foldr f) y es
instance T.Traversable EventHierarchy where
traverse f (SingleEvent x) = SingleEvent <$> f x
traverse f (StructuralSequence n es) = StructuralSequence n <$> T.traverse (T.traverse f) es
traverse f (StructuralParallel es) = StructuralParallel <$> T.traverse (T.traverse f) es
getAllEventsInHierarchy :: EventHierarchy a -> [a]
getAllEventsInHierarchy (SingleEvent e) = [e]
getAllEventsInHierarchy (StructuralSequence _ es) = concatMap getAllEventsInHierarchy es
getAllEventsInHierarchy (StructuralParallel es) = concatMap getAllEventsInHierarchy es
newtype StructuralTrace u = StructuralTrace (ChannelLabels u, Maybe (EventHierarchy (RecordedIndivEvent u)))
instance Ord u => Show (StructuralTrace u) where
show = renderStyle (Style OneLineMode 1 1) . prettyPrint
instance Trace StructuralTrace where
emptyTrace = StructuralTrace (Map.empty, Nothing)
runCHPAndTrace p = do trV <- newIORef $ RevSeq []
let st = (Hierarchy trV)
runCHPProgramWith' st (flip toPublic st) p
prettyPrint (StructuralTrace (_,Nothing)) = empty
prettyPrint (StructuralTrace (labels, Just h))
= pp $ T.mapM nameIndivEvent h `labelWith` labels
where
pp :: EventHierarchy String -> Doc
pp (SingleEvent x) = text x
pp (StructuralSequence 1 es)
= sep $ intersperse (text "->") $ map pp es
pp (StructuralSequence n es)
= int n <> char '*' <> parens (sep $
intersperse (text "->") $ map pp es)
pp (StructuralParallel es)
= parens $ sep $ intersperse (text "||") $ map pp es
labelAll (StructuralTrace (_, Nothing)) = StructuralTrace (Map.empty, Nothing)
labelAll (StructuralTrace (labels, Just h))
= StructuralTrace (Map.empty, Just $ T.mapM nameIndivEvent' h `labelWith` labels)
toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (StructuralTrace Unique)
toPublic l (Hierarchy hv)
= do h <- readIORef hv
return $ StructuralTrace (l, conv h)
where
nonEmptyListToMaybe :: ([a] -> b) -> [a] -> Maybe b
nonEmptyListToMaybe _ [] = Nothing
nonEmptyListToMaybe f xs = Just $ f xs
mapToMaybe :: ([b] -> c) -> (a -> Maybe b) -> [a] -> Maybe c
mapToMaybe f g = nonEmptyListToMaybe f . mapMaybe g
conv :: Ord a => Structured a -> Maybe (EventHierarchy a)
conv (StrEvent x) = Just $ SingleEvent x
conv (Par es) = mapToMaybe StructuralParallel conv es
conv (RevSeq []) = Nothing
conv (RevSeq [(0, _)]) = Nothing
conv (RevSeq [(n, ss)]) = mapToMaybe (StructuralSequence n) conv (reverse ss)
conv (RevSeq es) = trans
where
rev = reverse es
trans = mapToMaybe (StructuralSequence 1) (\(n,s) -> mapToMaybe (StructuralSequence n) conv $
reverse s) rev
toPublic _ _ = error "Error in Structural trace -- tracing type got switched"
getStructuralPlain :: StructuralTrace String -> Maybe (EventHierarchy (RecordedIndivEvent String))
getStructuralPlain (StructuralTrace (ls, t))
| Map.null ls = t
| otherwise = error "getStructuralPlain: remaining unused labels"
runCHP_StructuralTrace :: CHP a -> IO (Maybe a, StructuralTrace Unique)
runCHP_StructuralTrace = runCHPAndTrace
runCHP_StructuralTraceAndPrint :: CHP a -> IO ()
runCHP_StructuralTraceAndPrint p
= do (_, tr) <- runCHP_StructuralTrace p
putStrLn $ show tr