\begin{code}
\end{code}
The file is part of the Haskell Object Observation Debugger,
(HOOD) March 2010 release.
HOOD is a small post-mortem debugger for the lazy functional
language Haskell. It is based on the concept of observation of
intermediate data structures, rather than the more traditional
stepping and variable examination paradigm used by imperative
language debuggers.
Copyright (c) Andy Gill, 1992-2000
Copyright (c) The University of Kansas 2010
Copyright (c) Maarten Faddegon, 2013-2014
All rights reserved. HOOD is distributed as free software under
the license in the file "License", which available from the HOOD
web page, http://www.haskell.org/hood
This module produces CDS's, based on the observation made on Haskell
objects, including base types, constructors and functions.
WARNING: unrestricted use of unsafePerformIO below.
This was ported for the version found on www.haskell.org/hood.
%************************************************************************
%* *
\subsection{Exports}
%* *
%************************************************************************
\begin{code}
module Debug.Hoed.Stk.Observe
(
observeTempl
, observe
, observe'
, observeCC
, Observer(..)
, Observable(..)
, (<<)
, thunk
, nothunk
, send
, observeBase
, observeOpaque
, observedTypes
, Generic
, CallStack
, emptyStack
, Event(..)
, Change(..)
, Parent(..)
, ThreadId(..)
, Identifier(..)
, initUniq
, startEventStream
, endEventStream
, ourCatchAllIO
, peepUniq
, ccsToStrings
) where
\end{code}
%************************************************************************
%* *
\subsection{Imports and infixing}
%* *
%************************************************************************
\begin{code}
import Prelude hiding (Right)
import qualified Prelude
import System.IO
import Data.Maybe
import Control.Monad
import Data.Array as Array
import Data.List
import Data.Char
import System.Environment
import Language.Haskell.TH
import GHC.Generics
import Data.IORef
import System.IO.Unsafe
import Control.Concurrent(takeMVar,putMVar,MVar,newMVar)
import qualified Control.Concurrent as Concurrent
\end{code}
Needed to access the cost centre stack:
\begin{code}
import GHC.Stack (ccLabel, getCurrentCCS, CostCentreStack,ccsCC,ccsParent,currentCallStack)
import GHC.Foreign as GHC
import GHC.Ptr
\end{code}
For the TracedMonad instance of IO:
\begin{code}
import GHC.Base hiding (mapM)
\end{code}
\begin{code}
import qualified Control.Exception as Exception
import Control.Exception (Exception, throw, ErrorCall(..), SomeException(..))
import Data.Dynamic ( Dynamic )
\end{code}
\begin{code}
infixl 9 <<
\end{code}
%************************************************************************
%* *
\subsection{GDM Generics}
%* *
%************************************************************************
he generic implementation of the observer function.
\begin{code}
class Observable a where
observer :: a -> Parent -> a
default observer :: (Generic a, GObservable (Rep a)) => a -> Parent -> a
observer x c = to (gdmobserver (from x) c)
class GObservable f where
gdmobserver :: f a -> Parent -> f a
gdmObserveChildren :: f a -> ObserverM (f a)
gdmShallowShow :: f a -> String
\end{code}
Creating a shallow representation for types of the Data class.
\begin{code}
\end{code}
Observing the children of Data types of kind *.
\begin{code}
instance (GObservable a) => GObservable (M1 D d a) where
gdmobserver m@(M1 x) cxt = M1 (gdmobserver x cxt)
gdmObserveChildren = gthunk
gdmShallowShow = undefined
instance (GObservable a, Constructor c) => GObservable (M1 C c a) where
gdmobserver m@(M1 x) cxt = M1 (send (gdmShallowShow m) (gdmObserveChildren x) cxt)
gdmObserveChildren = gthunk
gdmShallowShow = conName
instance (GObservable a, Selector s) => GObservable (M1 S s a) where
gdmobserver m@(M1 x) cxt
| selName m == "" = M1 (gdmobserver x cxt)
| otherwise = M1 (send (selName m ++ " =") (gdmObserveChildren x) cxt)
gdmObserveChildren = gthunk
gdmShallowShow = undefined
instance GObservable U1 where
gdmobserver x _ = x
gdmObserveChildren = return
gdmShallowShow = undefined
instance (GObservable a, GObservable b) => GObservable (a :*: b) where
gdmobserver (a :*: b) cxt = error "gdmobserver product"
gdmObserveChildren (a :*: b) = do a' <- gdmObserveChildren a
b' <- gdmObserveChildren b
return (a' :*: b')
gdmShallowShow = undefined
instance (GObservable a, GObservable b) => GObservable (a :+: b) where
gdmobserver (L1 x) cxt = L1 (gdmobserver x cxt)
gdmobserver (R1 x) cxt = R1 (gdmobserver x cxt)
gdmObserveChildren (R1 x) = do {x' <- gdmObserveChildren x; return (R1 x')}
gdmObserveChildren (L1 x) = do {x' <- gdmObserveChildren x; return (L1 x')}
gdmShallowShow = undefined
instance (Observable a) => GObservable (K1 i a) where
gdmobserver (K1 x) cxt = K1 (observer x cxt)
gdmObserveChildren = gthunk
gdmShallowShow = undefined
\end{code}
Observing functions is done via the ad-hoc mechanism, because
we provide an instance definition the default is ignored for
this type.
\begin{code}
instance (Observable a,Observable b) => Observable (a -> b) where
observer fn cxt arg = gdmFunObserver cxt fn arg
\end{code}
Observing the children of Data types of kind *->*.
\begin{code}
gdmFunObserver :: (Observable a,Observable b) => Parent -> (a->b) -> (a->b)
gdmFunObserver cxt fn arg
= let (app,stack) = getStack
$ sendObserveFnPacket stack
(do arg' <- thunk observer arg
thunk observer (fn arg')
) cxt
in app
\end{code}
%************************************************************************
%* *
\subsection{Cost Centre Stack}
%* *
%************************************************************************
\begin{code}
type CallStack = [String]
emptyStack = [""]
getStack :: a -> (a, CallStack)
getStack x = let stack = unsafePerformIO
$ do {ccs <- getCurrentCCS (); ccsToStrings ccs}
in (x, rev stack)
where rev [] = []
rev (h:s) = let s' = case h of "CAF" -> s
_ -> h:s
in reverse s'
ccsToStrings :: Ptr CostCentreStack -> IO [String]
ccsToStrings ccs0 = go ccs0 []
where
go ccs acc
| ccs == nullPtr = return acc
| otherwise = do
cc <- ccsCC ccs
lbl <- GHC.peekCString utf8 =<< ccLabel cc
parent <- ccsParent ccs
if (lbl == "MAIN")
then return acc
else go parent (lbl : acc)
\end{code}
%************************************************************************
%* *
\subsection{Generics}
%* *
%************************************************************************
Generate a new observe from generated observers and the gobserve mechanism.
Where gobserve is the 'classic' observe but parametrized.
\begin{code}
observeTempl :: String -> Q Exp
observeTempl s = do n <- methodName s
let f = return $ VarE n
s' = stringE s
[| (\x-> fst (gobserve $f DoNotTraceThreadId UnknownId $s' x)) |]
\end{code}
Generate class definition and class instances for list of types.
\begin{code}
observedTypes :: String -> [Q Type] -> Q [Dec]
observedTypes s qt = do cd <- (genClassDef s)
ci <- foldM f [] qt
bi <- foldM g [] baseTypes
fi <- (gfunObserver s)
return (cd ++ ci ++ bi ++ fi)
where f d t = do ds <- (gobservableInstance s t)
return (ds ++ d)
g d t = do ds <- (gobservableBaseInstance s t)
return (ds ++ d)
baseTypes = [[t|Int|], [t|Char|], [t|Float|], [t|Bool|]]
\end{code}
Generate a class definition from a string
\begin{code}
genClassDef :: String -> Q [Dec]
genClassDef s = do cn <- className s
mn <- methodName s
nn <- newName "a"
let a = PlainTV nn
tvb = [a]
vt = varT nn
mt <- [t| $vt -> Parent -> $vt |]
let m = SigD mn mt
cd = ClassD [] cn tvb [] [m]
return [cd]
className :: String -> Q Name
className s = return $ mkName ("Observable" ++ headToUpper s)
methodName :: String -> Q Name
methodName s = return $ mkName ("observer" ++ headToUpper s)
headToUpper (c:cs) = toUpper c : cs
\end{code}
\begin{code}
gobserverBase :: Q Name -> Q Type -> Q [Dec]
gobserverBase qn t = do n <- qn
c <- gobserverBaseClause qn
return [FunD n [c]]
gobserverBaseClause :: Q Name -> Q Clause
gobserverBaseClause qn = clause [] (normalB (varE $ mkName "observeBase")) []
\end{code}
The generic implementation of the observer function, special cases
for base types and functions.
\begin{code}
gobserver :: Q Name -> Q Type -> Q [Dec]
gobserver qn t = do n <- qn
cs <- gobserverClauses qn t
return [FunD n cs]
gobserverClauses :: Q Name -> Q Type -> Q [Clause]
gobserverClauses n qt = do t <- qt
bs <- getBindings qt
case t of
_ -> do cs <- (getConstructors . getName) qt
mapM (gobserverClause t n bs) cs
gobserverClause :: Type -> Q Name -> TyVarMap -> Con -> Q Clause
gobserverClause t n bs (y@(NormalC name fields))
= do { vars <- guniqueVariables (length fields)
; let evars = map varE vars
pvars = map varP vars
c' = varP (mkName "c")
c = varE (mkName "c")
; clause [conP name pvars, c']
( normalB [| send $(shallowShow y) $(observeChildren n t bs y evars) $c |]
) []
}
gobserverClause t n bs (InfixC left name right)
= gobserverClause t n bs (NormalC name (left:[right]))
gobserverClause t n bs y = error ("gobserverClause can't handle " ++ show y)
\end{code}
We also need to do some work to also generate the instance declaration
around the observer method.
\begin{code}
gobservableInstance :: String -> Q Type -> Q [Dec]
gobservableInstance s qt
= do t <- qt
cn <- className s
let ct = conT cn
n <- case t of
(ForallT tvs _ t') -> [t| $ct $(return t') |]
_ -> [t| $ct $qt |]
m <- gobserver (methodName s) qt
c <- case t of
(ForallT _ c' _) -> return c'
_ -> return []
return [InstanceD (updateContext cn c) n m]
#if __GLASGOW_HASKELL__ >= 710
updateContext :: Name -> [Pred] -> [Pred]
updateContext cn ps = map f ps
where f (AppT (ConT n) ts)
| nameBase n == "Observable" = (AppT (ConT cn) ts)
| otherwise = (AppT (ConT n) ts)
f p = p
#else
updateContext :: Name -> [Pred] -> [Pred]
updateContext cn ps = map f ps
where f (ClassP n ts)
| nameBase n == "Observable" = ClassP cn ts
| otherwise = ClassP n ts
f p = p
#endif
gobservableBaseInstance :: String -> Q Type -> Q [Dec]
gobservableBaseInstance s qt
= do t <- qt
cn <- className s
let ct = conT cn
n <- case t of
(ForallT tvs _ t') -> [t| $ct $(return t') |]
_ -> [t| $ct $qt |]
m <- gobserverBase (methodName s) qt
c <- case t of
(ForallT _ c' _) -> return c'
_ -> return []
return [InstanceD c n m]
gobserverFunClause :: Name -> Q Clause
gobserverFunClause n
= do { [f',a'] <- guniqueVariables 2
; let vs = [f', mkName "c", a']
[f, c, a] = map varE vs
pvars = map varP vs
; clause pvars
(normalB [| let (app,stack) = getStack
$ sendObserveFnPacket stack
( do a' <- thunk $(varE n) $a
thunk $(varE n) ($f a')
) $c
in app
|]
) []
}
gobserverFun :: Q Name -> Q [Dec]
gobserverFun qn
= do n <- qn
c <- gobserverFunClause n
cs <- return [c]
return [FunD n cs]
gfunObserver :: String -> Q [Dec]
gfunObserver s
= do cn <- className s
let ct = conT cn
a = VarT (mkName "a")
b = VarT (mkName "b")
f = return $ AppT (AppT ArrowT a) b
#if __GLASGOW_HASKELL__ >= 710
p <- return $ AppT (ConT cn) a
q <- return $ AppT (ConT cn) b
#else
let a' = return a
b' = return b
p <- return $ ClassP cn a'
q <- return $ ClassP cn b'
#endif
c <- return [p,q]
n <- [t| $ct $f |]
m <- gobserverFun (methodName s)
return [InstanceD c n m]
\end{code}
Creating a shallow representation for types of the Data class.
\begin{code}
shallowShow :: Con -> ExpQ
shallowShow (NormalC name _)
= stringE (case (nameBase name) of "(,)" -> ","; s -> s)
\end{code}
Observing the children of Data types of kind *.
Note how we are forced to add the extra 'vars' argument that should
have the same unique name as the corresponding pattern.
To implement observeChildren we also define a mapM and compositionM function.
To our knowledge there is no existing work that do this in a generic fashion
with Template Haskell.
\begin{code}
isObservable :: TyVarMap -> Type -> Type -> Q Bool
isObservable bs s t = isObservable' bs t
isObservable' bs (AppT ListT _) = return True
isObservable' bs (VarT n) = case lookupBinding bs n of
(Just (T t)) -> isObservableT t
(Just (P p)) -> isObservableP p
Nothing -> return False
isObservable' (n,_) t@(ConT m) = if n == m then return True else isObservableT t
isObservable' bs t = isObservableT t
isObservableT :: Type -> Q Bool
isObservableT t@(ConT _) = isInstance (mkName "Observable") [t]
isObservableT _ = return False
isObservableP :: Pred -> Q Bool
#if __GLASGOW_HASKELL__ >= 710
isObservableP (AppT (ConT n) _) = return $ (nameBase n) == "Observable"
#else
isObservableP (ClassP n _) = return $ (nameBase n) == "Observable"
#endif
isObservableP _ = return False
thunkObservable :: Q Name -> TyVarMap -> Type -> Type -> Q Exp
thunkObservable qn bs s t
= do i <- isObservable bs s t
n <- qn
if i then [| thunk $(varE n) |] else [| nothunk |]
observeChildren :: Q Name -> Type -> TyVarMap -> Con -> [Q Exp] -> Q Exp
observeChildren n t bs = gmapM (thunkObservable n bs t)
gmapM :: (Type -> Q Exp) -> Con -> [ExpQ] -> ExpQ
gmapM f (NormalC name fields) vars
= m name (reverse fields) (reverse vars)
where m :: Name -> [(Strict,Type)] -> [ExpQ] -> ExpQ
m n _ [] = [| return $(conE n) |]
m n ((_,t):ts) (v:vars) = [| compositionM $(f t) $(m n ts vars) $v |]
compositionM :: Monad m => (a -> m b) -> m (b -> c) -> a -> m c
compositionM f g x = do { g' <- g
; x' <- f x
; return (g' x')
}
\end{code}
And we need some helper functions:
\begin{code}
type TyVarMap = (Name, [(TyVarBndr,TypeOrPred)])
data TypeOrPred = T Type | P Pred
lookupBinding :: TyVarMap -> Name -> Maybe TypeOrPred
lookupBinding (_,[]) _ = Nothing
lookupBinding (r,((b,t):ts)) n
= let m = case b of (PlainTV m ) -> m
(KindedTV m _) ->m
in if (m == n) then Just t else lookupBinding (r,ts) n
getBindings :: Q Type -> Q TyVarMap
getBindings t = do bs <- getBs t
tvs <- (getTvbs . getName) t
pbs <- getPBindings t
n <- getName t
let fromApps = (zip tvs (map T bs))
fromCxt = (zip tvs (map P pbs))
return (n, (fromCxt ++ fromApps))
getPBindings :: Q Type -> Q [Pred]
getPBindings qt = do t <- qt
case t of (ForallT _ cs _) -> getPBindings' cs
_ -> return []
getPBindings' :: [Pred] -> Q [Pred]
getPBindings' [] = return []
getPBindings' (p:ps) = do pbs <- getPBindings' ps
#if __GLASGOW_HASKELL__ >= 710
return $ case p of (AppT (ConT n) t) -> p : pbs
_ -> pbs
#else
return $ case p of (ClassP n t) -> p : pbs
_ -> pbs
#endif
getTvbs :: Q Name -> Q [TyVarBndr]
getTvbs name = do n <- name
i <- reify n
case i of
TyConI (DataD _ _ tvbs _ _)
-> return tvbs
i
-> error ("getTvbs: can't reify " ++ show i)
getBs :: Q Type -> Q [Type]
getBs t = do t' <- t
let t'' = case t' of (ForallT _ _ s) -> s
_ -> t'
return (getBs' t'')
getBs' :: Type -> [Type]
getBs' (AppT c t) = t : getBs' c
getBs' _ = []
getName :: Q Type -> Q Name
getName t = do t' <- t
getName' t'
getName' :: Type -> Q Name
getName' t = case t of
(ForallT _ _ t'') -> getName' t''
(AppT t'' _) -> getName' t''
(ConT name) -> return name
ListT -> return $ mkName "[]"
TupleT _ -> return $ mkName "(,)"
t'' -> error ("getName can't handle " ++ show t'')
getConstructors :: Q Name -> Q [Con]
getConstructors name = do {n <- name; TyConI (DataD _ _ _ cs _) <- reify n; return cs}
guniqueVariables :: Int -> Q [Name]
guniqueVariables n = replicateM n (newName "x")
\end{code}
%************************************************************************
%* *
\subsection{Instances}
%* *
%************************************************************************
The Haskell Base types
\begin{code}
instance Observable Int where { observer = observeBase }
instance Observable Bool where { observer = observeBase }
instance Observable Integer where { observer = observeBase }
instance Observable Float where { observer = observeBase }
instance Observable Double where { observer = observeBase }
instance Observable Char where { observer = observeBase }
instance Observable () where { observer = observeOpaque "()" }
observeBase :: (Show a) => a -> Parent -> a
observeBase lit cxt = seq lit $ send (show lit) (return lit) cxt
observeOpaque :: String -> a -> Parent -> a
observeOpaque str val cxt = seq val $ send str (return val) cxt
\end{code}
The Constructors.
\begin{code}
instance (Observable a,Observable b) => Observable (a,b) where
observer (a,b) = send "," (return (,) << a << b)
instance (Observable a,Observable b,Observable c) => Observable (a,b,c) where
observer (a,b,c) = send "," (return (,,) << a << b << c)
instance (Observable a,Observable b,Observable c,Observable d)
=> Observable (a,b,c,d) where
observer (a,b,c,d) = send "," (return (,,,) << a << b << c << d)
instance (Observable a,Observable b,Observable c,Observable d,Observable e)
=> Observable (a,b,c,d,e) where
observer (a,b,c,d,e) = send "," (return (,,,,) << a << b << c << d << e)
instance (Observable a) => Observable [a] where
observer (a:as) = send ":" (return (:) << a << as)
observer [] = send "[]" (return [])
instance (Observable a) => Observable (Maybe a) where
observer (Just a) = send "Just" (return Just << a)
observer Nothing = send "Nothing" (return Nothing)
instance (Observable a,Observable b) => Observable (Either a b) where
observer (Left a) = send "Left" (return Left << a)
observer (Prelude.Right a) = send "Right" (return Prelude.Right << a)
\end{code}
Arrays.
\begin{code}
instance (Ix a,Observable a,Observable b) => Observable (Array.Array a b) where
observer arr = send "array" (return Array.array << Array.bounds arr
<< Array.assocs arr
)
\end{code}
IO monad.
\begin{code}
instance (Observable a) => Observable (IO a) where
observer fn cxt =
do res <- fn
send "<IO>" (return return << res) cxt
\end{code}
The Exception *datatype* (not exceptions themselves!).
\begin{code}
instance Observable SomeException where
observer e = send ("<Exception> " ++ show e) (return e)
instance Observable Dynamic where { observer = observeOpaque "<Dynamic>" }
\end{code}
%************************************************************************
%* *
\subsection{Classes and Data Definitions}
%* *
%************************************************************************
\begin{code}
newtype Observer = O (forall a . (Observable a) => String -> a -> a)
\end{code}
%************************************************************************
%* *
\subsection{The ObserveM Monad}
%* *
%************************************************************************
The Observer monad, a simple state monad,
for placing numbers on sub-observations.
\begin{code}
newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) }
instance Functor ObserverM where
fmap = liftM
#if __GLASGOW_HASKELL__ >= 710
instance Applicative ObserverM where
pure = return
(<*>) = ap
#endif
instance Monad ObserverM where
return a = ObserverM (\ c i -> (a,i))
fn >>= k = ObserverM (\ c i ->
case runMO fn c i of
(r,i2) -> runMO (k r) c i2
)
thunk :: (a -> Parent -> a) -> a -> ObserverM a
thunk f a = ObserverM $ \ parent port ->
( observer_ f a (Parent
{ observeParent = parent
, observePort = port
})
, port+1 )
gthunk :: (GObservable f) => f a -> ObserverM (f a)
gthunk a = ObserverM $ \ parent port ->
( gdmobserver_ a (Parent
{ observeParent = parent
, observePort = port
})
, port+1 )
nothunk :: a -> ObserverM a
nothunk a = ObserverM $ \ parent port ->
( observer__ a (Parent
{ observeParent = parent
, observePort = port
})
, port+1 )
(<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b
fn << a = gdMapM (thunk observer) fn a
gdMapM :: (Monad m)
=> (a -> m a)
-> m (a -> b)
-> a
-> m b
gdMapM f c a = do { c' <- c ; a' <- f a ; return (c' a') }
\end{code}
%************************************************************************
%* *
\subsection{observe and friends}
%* *
%************************************************************************
Our principle function and class
\begin{code}
gobserve :: (a->Parent->a) -> TraceThreadId -> Identifier -> String -> a -> (a,Int)
gobserve f tti d name a = generateContext f tti d name a
observe :: (Observable a) => String -> a -> a
observe lbl = fst . (gobserve observer DoNotTraceThreadId UnknownId lbl)
observeCC :: (Observable a) => String -> a -> a
observeCC lbl = fst . (gobserve observer TraceThreadId UnknownId lbl)
data Identifier = UnknownId | DependsJustOn Int | InSequenceAfter Int
deriving (Show, Eq, Ord)
observe' :: (Observable a) => String -> Identifier -> a -> (a,Int)
observe' lbl d x = let (y,i) = (gobserve observer DoNotTraceThreadId d lbl) x
in (y, i)
observer_ :: (a -> Parent -> a) -> a -> Parent -> a
observer_ f a context = sendEnterPacket f a context
gdmobserver_ :: (GObservable f) => f a -> Parent -> f a
gdmobserver_ a context = gsendEnterPacket a context
observer__ :: a -> Parent -> a
observer__ a context = sendNoEnterPacket a context
\end{code}
\begin{code}
data Parent = Parent
{ observeParent :: !Int
, observePort :: !Int
} deriving (Show, Read)
\end{code}
The functions that output the data. All are dirty.
\begin{code}
unsafeWithUniq :: (Int -> IO a) -> a
unsafeWithUniq fn
= unsafePerformIO $ do { node <- getUniq
; fn node
}
\end{code}
\begin{code}
data TraceThreadId = TraceThreadId | DoNotTraceThreadId
generateContext :: (a->Parent->a) -> TraceThreadId -> Identifier -> String -> a -> (a,Int)
generateContext f tti d label orig = unsafeWithUniq $ \ node ->
do { t <- myThreadId
; sendEvent node (Parent 0 0) (Observe label t node d)
; return (observer_ f orig (Parent
{ observeParent = node
, observePort = 0
})
, node)
}
where myThreadId = case tti of
DoNotTraceThreadId -> return ThreadIdUnknown
TraceThreadId -> do t <- Concurrent.myThreadId
return (ThreadId t)
send :: String -> ObserverM a -> Parent -> a
send consLabel fn context = unsafeWithUniq $ \ node ->
do { let (r,portCount) = runMO fn node 0
; sendEvent node context (Cons portCount consLabel)
; return r
}
sendEnterPacket :: (a -> Parent -> a) -> a -> Parent -> a
sendEnterPacket f r context = unsafeWithUniq $ \ node ->
do { sendEvent node context Enter
; ourCatchAllIO (evaluate (f r context))
(handleExc context)
}
gsendEnterPacket :: (GObservable f) => f a -> Parent -> f a
gsendEnterPacket r context = unsafeWithUniq $ \ node ->
do { sendEvent node context Enter
; ourCatchAllIO (evaluate (gdmobserver r context))
(handleExc context)
}
sendNoEnterPacket :: a -> Parent -> a
sendNoEnterPacket r context = unsafeWithUniq $ \ node ->
do { sendEvent node context NoEnter
; ourCatchAllIO (evaluate r)
(handleExc context)
}
evaluate :: a -> IO a
evaluate a = a `seq` return a
sendObserveFnPacket :: CallStack -> ObserverM a -> Parent -> a
sendObserveFnPacket callStack fn context
= unsafeWithUniq $ \ node ->
do { let (r,_) = runMO fn node 0
; sendEvent node context (Fun callStack)
; return r
}
\end{code}
%************************************************************************
%* *
\subsection{Event stream}
%* *
%************************************************************************
Trival output functions
\begin{code}
type Trace = [Event]
data Event = Event
{ portId :: !Int
, parent :: !Parent
, change :: !Change
}
deriving (Show)
data ThreadId = ThreadIdUnknown | ThreadId Concurrent.ThreadId
deriving (Show,Eq,Ord)
data Change
= Observe !String !ThreadId !Int !Identifier
| Cons !Int !String
| Enter
| NoEnter
| Fun !CallStack
deriving (Show)
startEventStream :: IO ()
startEventStream = writeIORef events []
endEventStream :: IO Trace
endEventStream =
do { es <- readIORef events
; writeIORef events badEvents
; return es
}
sendEvent :: Int -> Parent -> Change -> IO ()
sendEvent nodeId parent change =
do { nodeId `seq` parent `seq` return ()
; change `seq` return ()
; takeMVar sendSem
; es <- readIORef events
; let event = Event nodeId parent change
; writeIORef events (event `seq` (event : es))
; putMVar sendSem ()
}
events :: IORef Trace
events = unsafePerformIO $ newIORef badEvents
badEvents :: Trace
badEvents = error "Bad Event Stream"
sendSem :: MVar ()
sendSem = unsafePerformIO $ newMVar ()
\end{code}
%************************************************************************
%* *
\subsection{unique name supply code}
%* *
%************************************************************************
Use the single threaded version
\begin{code}
type UID = Int
initUniq :: IO ()
initUniq = writeIORef uniq 1
getUniq :: IO UID
getUniq
= do { takeMVar uniqSem
; n <- readIORef uniq
; writeIORef uniq $! (n + 1)
; putMVar uniqSem ()
; return n
}
peepUniq :: IO UID
peepUniq = readIORef uniq
uniq :: IORef UID
uniq = unsafePerformIO $ newIORef 1
uniqSem :: MVar ()
uniqSem = unsafePerformIO $ newMVar ()
\end{code}
%************************************************************************
%* *
\subsection{Global, initualizers, etc}
%* *
%************************************************************************
-- \begin{code}
-- openObserveGlobal :: IO ()
-- openObserveGlobal =
-- do { initUniq
-- ; startEventStream
-- }
--
-- closeObserveGlobal :: IO Trace
-- closeObserveGlobal =
-- do { evs <- endEventStream
-- ; putStrLn ""
-- ; return evs
-- }
-- \end{code}
%************************************************************************
%* *
\subsection{Simulations}
%* *
%************************************************************************
Here we provide stubs for the functionally that is not supported
by some compilers, and provide some combinators of various flavors.
\begin{code}
ourCatchAllIO :: IO a -> (SomeException -> IO a) -> IO a
ourCatchAllIO = Exception.catch
handleExc :: Parent -> SomeException -> IO a
handleExc context exc = return (send "throw" (return throw << exc) context)
\end{code}
%************************************************************************
% (*>>=) :: Monad m => m a -> (Identifier -> (a -> m b, Int)) -> (m b, Identifier)
% x *>>= f = let (g,i) = f UnknownId in (x >>= g,InSequenceAfter i)
%
% (>>==) :: Monad m => (m a, Identifier) -> (Identifier -> (a -> m b, Int)) -> (m b, Identifier)
% (x,d) >>== f = let (g,i) = f d in (x >>= g,InSequenceAfter i)
%
% (>>=*) :: Monad m => (m a, Identifier) -> (Identifier -> (a -> m b, Int)) -> m b
% (x,d) >>=* f = let (g,i) = f d in x >>= g