module Control.Concurrent.CHP.Traces.Structural (StructuralTrace(..), EventHierarchy(..), runCHP_StructuralTrace, runCHP_StructuralTraceAndPrint,
getAllEventsInHierarchy) where
import Control.Applicative hiding (empty)
import Control.Monad.State
import qualified Data.Foldable as F
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 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 = runCHPProgramWith' (Hierarchy $ RevSeq []) toPublic p
prettyPrint (StructuralTrace (_,Nothing)) = empty
prettyPrint (StructuralTrace (labels, Just h))
= pp $ evalState (T.mapM nameIndivEvent h) 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 $ evalState (T.mapM nameIndivEvent' h) labels)
toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (StructuralTrace Unique)
toPublic l (Hierarchy h)
= 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"
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