Hoed 0.2.0 → 0.2.1
raw patch · 8 files changed
+536/−491 lines, 8 filesdep ~basedep ~threepenny-guinew-component:exe:hoed-examples-Ho
Dependency ranges changed: base, threepenny-gui
Files
- Debug/Hoed.hs +7/−7
- Debug/Hoed/DemoGUI.hs +1/−1
- Debug/Hoed/Observe.lhs +176/−170
- Debug/Hoed/Render.hs +149/−149
- Hoed.cabal +17/−4
- changelog +13/−0
- examples/Ho.hs +13/−0
- examples/Pretty.hs +160/−160
Debug/Hoed.hs view
@@ -92,9 +92,9 @@ -- %************************************************************************--- %* *+-- %* * -- \subsection{External start functions}--- %* *+-- %* * -- %************************************************************************ -- Run the observe ridden code.@@ -103,13 +103,13 @@ debugO :: IO a -> IO [CDS] debugO program = do { initUniq- ; startEventStream+ ; startEventStream ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]"- ; ourCatchAllIO (do { program ; return () }) - (hPutStrLn stderr . errorMsg)+ ; ourCatchAllIO (do { program ; return () }) + (hPutStrLn stderr . errorMsg) ; events <- endEventStream- ; return (eventsToCDS events)- }+ ; return (eventsToCDS events)+ } -- | Short for @runO . print@. printO :: (Show a) => a -> IO ()
Debug/Hoed/DemoGUI.hs view
@@ -9,7 +9,7 @@ import Debug.Hoed.Render import Data.Graph.Libgraph import qualified Graphics.UI.Threepenny as UI-import Graphics.UI.Threepenny (startGUI,defaultConfig,tpPort,tpStatic+import Graphics.UI.Threepenny (startGUI,defaultConfig, loadFile , Window, UI, (#), (#+), (#.), string, on ) import System.Process(system)
Debug/Hoed/Observe.lhs view
@@ -36,9 +36,9 @@ %************************************************************************-%* *+%* * \subsection{Exports}-%* *+%* * %************************************************************************ \begin{code}@@ -57,7 +57,7 @@ -- * For advanced users, that want to render their own datatypes. , (<<) -- (Observable a) => ObserverM (a -> b) -> a -> ObserverM b ,(*>>=),(>>==),(>>=*)- , thunk -- (Observable a) => a -> ObserverM a + , thunk -- (Observable a) => a -> ObserverM a , nothunk , send , observeBase@@ -82,9 +82,9 @@ %************************************************************************-%* *+%* * \subsection{Imports and infixing}-%* *+%* * %************************************************************************ \begin{code}@@ -117,7 +117,7 @@ For the TracedMonad instance of IO: \begin{code}-import GHC.Base+import GHC.Base hiding (mapM) -- import Control.Monad.ST(RealWorld) -- import Control.Monad.State(State) \end{code}@@ -127,9 +127,9 @@ import Control.Exception (Exception, throw, ErrorCall(..), SomeException(..)) {- ( catch- , Exception(..)- , throw- ) as Exception+ , Exception(..)+ , throw+ ) as Exception -} import Data.Dynamic ( Dynamic ) \end{code}@@ -140,16 +140,16 @@ %************************************************************************-%* *+%* * \subsection{GDM Generics}-%* *+%* * %************************************************************************ he generic implementation of the observer function. \begin{code} class Observable a where- observer :: a -> Parent -> a + observer :: a -> Parent -> a default observer :: (Generic a, GObservable (Rep a)) => a -> Parent -> a observer x c = to (gdmobserver (from x) c) @@ -255,9 +255,9 @@ %************************************************************************-%* *+%* * \subsection{Cost Centre Stack}-%* *+%* * %************************************************************************ \begin{code}@@ -295,9 +295,9 @@ %************************************************************************-%* *+%* * \subsection{Generics}-%* *+%* * %************************************************************************ Generate a new observe from generated observers and the gobserve mechanism.@@ -466,9 +466,9 @@ 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+ where f (AppT (ConT n) ts) -- TH<2.10: f (ClassP n ts)+ | nameBase n == "Observable" = (AppT (ConT cn) ts) -- ClassP cn ts+ | otherwise = (AppT (ConT n) ts) -- ClassP n ts f p = p gobservableBaseInstance :: String -> Q Type -> Q [Dec]@@ -544,10 +544,8 @@ a = VarT (mkName "a") b = VarT (mkName "b") f = return $ AppT (AppT ArrowT a) b- a' = return a- b' = return b- p <- return $ ClassP cn a'- q <- return $ ClassP cn b'+ p <- return $ AppT (ConT cn) a+ q <- return $ AppT (ConT cn) b c <- return [p,q] n <- [t| $ct $f |] m <- gobserverFun (methodName s)@@ -594,7 +592,8 @@ isObservableT _ = return False isObservableP :: Pred -> Q Bool-isObservableP (ClassP n _) = return $ (nameBase n) == "Observable"+-- TH<2.10: isObservableP (ClassP n _) = return $ (nameBase n) == "Observable"+isObservableP (AppT (ConT n) _) = return $ (nameBase n) == "Observable" isObservableP _ = return False @@ -662,8 +661,8 @@ getPBindings' :: [Pred] -> Q [Pred] getPBindings' [] = return [] getPBindings' (p:ps) = do pbs <- getPBindings' ps- return $ case p of (ClassP n t) -> p : pbs- _ -> pbs+ return $ case p of (AppT (ConT n) t) -> p : pbs+ _ -> pbs -- Given a parametrized type, get a list with its type variables -- e.g. [a,b] in (MyData a b) Int Float@@ -698,9 +697,9 @@ getName' :: Type -> Q Name getName' t = case t of - (ForallT _ _ t'') -> getName' t''+ (ForallT _ _ t'') -> getName' t'' (AppT t'' _) -> getName' t''- (ConT name) -> return name+ (ConT name) -> return name ListT -> return $ mkName "[]" TupleT _ -> return $ mkName "(,)" t'' -> error ("getName can't handle " ++ show t'')@@ -721,8 +720,8 @@ observableCxt :: [TyVarBndr] -> Q Cxt observableCxt tvs = return [classpObservable $ map (\v -> (tvname v)) tvs] -classpObservable :: [Type] -> Pred-classpObservable = ClassP (mkName "Observable")+classpObservable :: [Type] -> Type+classpObservable = foldl AppT (ConT (mkName "Observable")) qcontObservable :: Q Type qcontObservable = return contObservable@@ -740,22 +739,22 @@ \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 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 "()" }+instance Observable () where { observer = observeOpaque "()" } -- utilities for base types. -- The strictness (by using seq) is the same @@ -779,11 +778,11 @@ observer (a,b,c) = send "," (return (,,) << a << b << c) instance (Observable a,Observable b,Observable c,Observable d) - => Observable (a,b,c,d) where+ => 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+ => 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@@ -804,8 +803,8 @@ \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- )+ << Array.assocs arr+ ) \end{code} IO monad.@@ -813,8 +812,8 @@ \begin{code} instance (Observable a) => Observable (IO a) where observer fn cxt = - do res <- fn- send "<IO>" (return return << res) cxt+ do res <- fn+ send "<IO>" (return return << res) cxt \end{code} @@ -834,9 +833,9 @@ %************************************************************************-%* *+%* * \subsection{Classes and Data Definitions}-%* *+%* * %************************************************************************ \begin{code}@@ -851,47 +850,47 @@ -- defaultObservers :: (Observable a) => String -> (Observer -> a) -> a -- defaultObservers label fn = unsafeWithUniq $ \ node -> -- do { sendEvent node (Parent 0 0) (Observe label ThreadIdUnknown)--- ; let observe' sublabel a--- = unsafeWithUniq $ \ subnode ->--- do { sendEvent subnode (Parent node 0) --- (Observe sublabel ThreadIdUnknown)--- ; return (observer_ observer a (Parent--- { observeParent = subnode--- , observePort = 0--- }))--- }+-- ; let observe' sublabel a+-- = unsafeWithUniq $ \ subnode ->+-- do { sendEvent subnode (Parent node 0) +-- (Observe sublabel ThreadIdUnknown)+-- ; return (observer_ observer a (Parent+-- { observeParent = subnode+-- , observePort = 0+-- }))+-- } -- ; return (observer_ observer (fn (O observe'))--- (Parent--- { observeParent = node--- , observePort = 0--- }))--- }+-- (Parent+-- { observeParent = node+-- , observePort = 0+-- }))+-- } -- defaultFnObservers :: (Observable a, Observable b) --- => String -> (Observer -> a -> b) -> a -> b+-- => String -> (Observer -> a -> b) -> a -> b -- defaultFnObservers label fn arg = unsafeWithUniq $ \ node -> -- do { sendEvent node (Parent 0 0) (Observe label ThreadIdUnknown)--- ; let observe' sublabel a--- = unsafeWithUniq $ \ subnode ->--- do { sendEvent subnode (Parent node 0) --- (Observe sublabel ThreadIdUnknown)--- ; return (observer_ observer a (Parent--- { observeParent = subnode--- , observePort = 0--- }))--- }+-- ; let observe' sublabel a+-- = unsafeWithUniq $ \ subnode ->+-- do { sendEvent subnode (Parent node 0) +-- (Observe sublabel ThreadIdUnknown)+-- ; return (observer_ observer a (Parent+-- { observeParent = subnode+-- , observePort = 0+-- }))+-- } -- ; return (observer_ observer (fn (O observe'))--- (Parent--- { observeParent = node--- , observePort = 0--- }) arg)--- }+-- (Parent+-- { observeParent = node+-- , observePort = 0+-- }) arg)+-- } \end{code} %************************************************************************-%* *+%* * \subsection{The ObserveM Monad}-%* *+%* * %************************************************************************ The Observer monad, a simple state monad, @@ -900,36 +899,43 @@ \begin{code} newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) } +instance Functor ObserverM where+ fmap = liftM++instance Applicative ObserverM where+ pure = return+ (<*>) = ap+ 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- )+ 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 )+ ( 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 )+ ( 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 )+ ( observer__ a (Parent+ { observeParent = parent+ , observePort = port+ }) + , port+1 ) (<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b@@ -947,9 +953,9 @@ %************************************************************************-%* *+%* * \subsection{observe and friends}-%* *+%* * %************************************************************************ Our principle function and class@@ -1036,9 +1042,9 @@ \begin{code} data Parent = Parent- { observeParent :: !Int -- my parent- , observePort :: !Int -- my branch number- } deriving (Show, Read)+ { observeParent :: !Int -- my parent+ , observePort :: !Int -- my branch number+ } deriving (Show, Read) root = Parent 0 0 \end{code} @@ -1049,8 +1055,8 @@ unsafeWithUniq :: (Int -> IO a) -> a unsafeWithUniq fn = unsafePerformIO $ do { node <- getUniq- ; fn node- }+ ; fn node+ } \end{code} \begin{code}@@ -1060,12 +1066,12 @@ 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)- }+ ; return (observer_ f orig (Parent+ { observeParent = node+ , observePort = 0+ })+ , node)+ } where myThreadId = case tti of DoNotTraceThreadId -> return ThreadIdUnknown TraceThreadId -> do t <- Concurrent.myThreadId@@ -1074,31 +1080,31 @@ 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- }+ ; 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)- }+ 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)- }+ 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)- }+ do { sendEvent node context NoEnter+ ; ourCatchAllIO (evaluate r)+ (handleExc context)+ } evaluate :: a -> IO a evaluate a = a `seq` return a@@ -1107,61 +1113,61 @@ 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- }+ do { let (r,_) = runMO fn node 0+ ; sendEvent node context (Fun callStack)+ ; return r+ } \end{code} %************************************************************************-%* *+%* * \subsection{Event stream}-%* *+%* * %************************************************************************ Trival output functions \begin{code} data Event = Event- { portId :: !Int- , parent :: !Parent- , change :: !Change- }- deriving (Show)+ { portId :: !Int+ , parent :: !Parent+ , change :: !Change+ }+ deriving (Show) data ThreadId = ThreadIdUnknown | ThreadId Concurrent.ThreadId- deriving (Show,Eq,Ord)+ deriving (Show,Eq,Ord) -- MF TODO: Shouldn't we just have the CallStack as part of Observe? data Change- = Observe !String !ThreadId !Int !Identifier- | Cons !Int !String- | Enter+ = Observe !String !ThreadId !Int !Identifier+ | Cons !Int !String+ | Enter | NoEnter- | Fun !CallStack- deriving (Show)+ | Fun !CallStack+ deriving (Show) startEventStream :: IO () startEventStream = writeIORef events [] endEventStream :: IO [Event] endEventStream =- do { es <- readIORef events- ; writeIORef events badEvents - ; return es- }+ 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 ()- }+ 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 ()+ } -- writeEvent :: FilePath -> Event -> IO ()@@ -1188,9 +1194,9 @@ %************************************************************************-%* *+%* * \subsection{unique name supply code}-%* *+%* * %************************************************************************ Use the single threaded version@@ -1202,11 +1208,11 @@ getUniq :: IO Int getUniq = do { takeMVar uniqSem- ; n <- readIORef uniq- ; writeIORef uniq $! (n + 1)- ; putMVar uniqSem ()- ; return n- }+ ; n <- readIORef uniq+ ; writeIORef uniq $! (n + 1)+ ; putMVar uniqSem ()+ ; return n+ } peepUniq :: IO Int peepUniq = readIORef uniq@@ -1224,30 +1230,30 @@ %************************************************************************-%* *+%* * \subsection{Global, initualizers, etc}-%* *+%* * %************************************************************************ -- \begin{code} -- openObserveGlobal :: IO () -- openObserveGlobal = -- do { initUniq--- ; startEventStream--- }+-- ; startEventStream+-- } -- -- closeObserveGlobal :: IO [Event] -- closeObserveGlobal = -- do { evs <- endEventStream -- ; putStrLn ""--- ; return evs--- }+-- ; return evs+-- } -- \end{code} %************************************************************************-%* *+%* * \subsection{Simulations}-%* *+%* * %************************************************************************ Here we provide stubs for the functionally that is not supported
Debug/Hoed/Render.hs view
@@ -60,9 +60,9 @@ ) where (pairs',callStack) = findFn [cds] pairs = (nub . (sort)) pairs'- -- local nub for sorted lists- nub [] = []- nub (a:a':as) | a == a' = nub (a' : as)+ -- local nub for sorted lists+ nub [] = []+ nub (a:a':as) | a == a' = nub (a' : as) nub (a:as) = a : nub as renderCallStack :: CallStack -> DOC@@ -320,18 +320,18 @@ src ==> tgt = Arc src tgt () -- %************************************************************************--- %* *+-- %* * -- \subsection{The CDS and converting functions}--- %* *+-- %* * -- %************************************************************************ data CDS = CDSNamed String ThreadId Int Identifier CDSSet- | CDSCons Int String [CDSSet]- | CDSFun Int CDSSet CDSSet CallStack- | CDSEntered Int- | CDSTerminated Int- deriving (Show,Eq,Ord)+ | CDSCons Int String [CDSSet]+ | CDSFun Int CDSSet CDSSet CallStack+ | CDSEntered Int+ | CDSTerminated Int+ deriving (Show,Eq,Ord) type CDSSet = [CDS] @@ -344,55 +344,55 @@ mid_arr :: Array Int [(Int,CDS)] mid_arr = accumArray (flip (:)) [] bnds- [ (pnode,(pport,res node))- | (Event node (Parent pnode pport) _) <- pairs- ]+ [ (pnode,(pport,res node))+ | (Event node (Parent pnode pport) _) <- pairs+ ] - out_arr = array bnds -- never uses 0 index- [ (node,getNode'' node change)- | (Event node _ change) <- pairs- ]+ out_arr = array bnds -- never uses 0 index+ [ (node,getNode'' node change)+ | (Event node _ change) <- pairs+ ] getNode'' :: Int -> Change -> CDS getNode'' node change = case change of- (Observe str t i d) -> CDSNamed str t i d (getChild node 0)- (Enter) -> CDSEntered node- (NoEnter) -> CDSTerminated node- (Fun str) -> CDSFun node (getChild node 0) (getChild node 1) str- (Cons portc cons)- -> CDSCons node cons - [ getChild node n | n <- [0..(portc-1)]]+ (Observe str t i d) -> CDSNamed str t i d (getChild node 0)+ (Enter) -> CDSEntered node+ (NoEnter) -> CDSTerminated node+ (Fun str) -> CDSFun node (getChild node 0) (getChild node 1) str+ (Cons portc cons)+ -> CDSCons node cons + [ getChild node n | n <- [0..(portc-1)]] getChild :: Int -> Int -> CDSSet getChild pnode pport =- [ content+ [ content | (pport',content) <- (!) mid_arr pnode- , pport == pport'- ]+ , pport == pport'+ ] render :: Int -> Bool -> CDS -> DOC render prec par (CDSCons _ ":" [cds1,cds2]) =- if (par && not needParen) - then doc -- dont use paren (..) because we dont want a grp here!- else paren needParen doc+ if (par && not needParen) + then doc -- dont use paren (..) because we dont want a grp here!+ else paren needParen doc where- doc = grp (brk <> renderSet' 5 False cds1 <> text " : ") <>- renderSet' 4 True cds2- needParen = prec > 4+ doc = grp (brk <> renderSet' 5 False cds1 <> text " : ") <>+ renderSet' 4 True cds2+ needParen = prec > 4 render prec par (CDSCons _ "," cdss) | length cdss > 0 =- nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b)- (map renderSet cdss) <>- text ")")+ nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b)+ (map renderSet cdss) <>+ text ")") render prec par (CDSCons _ name cdss) =- paren (length cdss > 0 && prec /= 0)- (nest 2- (text name <> foldr (<>) nil- [ sep <> renderSet' 10 False cds- | cds <- cdss - ]- )- )+ paren (length cdss > 0 && prec /= 0)+ (nest 2+ (text name <> foldr (<>) nil+ [ sep <> renderSet' 10 False cds+ | cds <- cdss + ]+ )+ ) {- renderSet handles the various styles of CDSSet. -}@@ -403,29 +403,29 @@ renderSet' :: Int -> Bool -> CDSSet -> DOC renderSet' _ _ [] = text "_" renderSet' prec par [cons@(CDSCons {})] = render prec par cons-renderSet' prec par cdss = - nest 0 (text "{ " <> foldl1 (\ a b -> a <> line <>- text ", " <> b)- (map (renderFn caller) pairs) <>- line <> text "}")+renderSet' prec par cdss = + nest 0 (text "{ " <> foldl1 (\ a b -> a <> line <>+ text ", " <> b)+ (map (renderFn caller) pairs) <>+ line <> text "}") where- (pairs',caller) = findFn cdss+ (pairs',caller) = findFn cdss pairs = (nub . sort) pairs'- -- local nub for sorted lists- nub [] = []- nub (a:a':as) | a == a' = nub (a' : as)+ -- local nub for sorted lists+ nub [] = []+ nub (a:a':as) | a == a' = nub (a' : as) nub (a:as) = a : nub as renderFn :: CallStack -> ([CDSSet],CDSSet) -> DOC renderFn callStack (args, res)- = grp (nest 3 - (text "\\ " <>- foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b)- nil- args <> sep <>- text "-> " <> renderSet' 0 False res- )+ = grp (nest 3 + (text "\\ " <>+ foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b)+ nil+ args <> sep <>+ text "-> " <> renderSet' 0 False res+ ) ) renderNamedFn :: String -> ([CDSSet],CDSSet) -> DOC@@ -459,9 +459,9 @@ renderTop :: Output -> DOC renderTop (OutLabel str set extras) =- nest 2 (text ("-- " ++ str) <> line <>- renderSet set- <> renderTops extras) <> line+ nest 2 (text ("-- " ++ str) <> line <>+ renderSet set+ <> renderTops extras) <> line rmEntry :: CDS -> CDS rmEntry (CDSNamed str t i d set) = CDSNamed str t i d (rmEntrySet set)@@ -472,18 +472,18 @@ rmEntrySet = map rmEntry . filter noEntered where- noEntered (CDSEntered _) = False- noEntered _ = True+ noEntered (CDSEntered _) = False+ noEntered _ = True simplifyCDS :: CDS -> CDS simplifyCDS (CDSNamed str t i d set) = CDSNamed str t i d (simplifyCDSSet set) simplifyCDS (CDSCons _ "throw" - [[CDSCons _ "ErrorCall" set]]- ) = simplifyCDS (CDSCons 0 "error" set)+ [[CDSCons _ "ErrorCall" set]]+ ) = simplifyCDS (CDSCons 0 "error" set) simplifyCDS cons@(CDSCons i str sets) = - case spotString [cons] of- Just str | not (null str) -> CDSCons 0 (show str) []- _ -> CDSCons 0 str (map simplifyCDSSet sets)+ case spotString [cons] of+ Just str | not (null str) -> CDSCons 0 (show str) []+ _ -> CDSCons 0 str (map simplifyCDSSet sets) simplifyCDS (CDSFun i a b str) = CDSFun 0 (simplifyCDSSet a) (simplifyCDSSet b) str @@ -493,16 +493,16 @@ spotString :: CDSSet -> Maybe String spotString [CDSCons _ ":"- [[CDSCons _ str []]- ,rest- ]- ] - = do { ch <- case reads str of- [(ch,"")] -> return ch+ [[CDSCons _ str []]+ ,rest+ ]+ ] + = do { ch <- case reads str of+ [(ch,"")] -> return ch _ -> Nothing- ; more <- spotString rest- ; return (ch : more)- }+ ; more <- spotString rest+ ; return (ch : more)+ } spotString [CDSCons _ "[]" []] = return [] spotString other = Nothing @@ -515,7 +515,7 @@ data Output = OutLabel String CDSSet [Output] | OutData CDS- deriving (Eq,Ord,Show)+ deriving (Eq,Ord,Show) commonOutput :: [Output] -> [Output]@@ -527,7 +527,7 @@ cdssToOutput = map cdsToOutput cdsToOutput (CDSNamed name _ _ _ cdsset)- = OutLabel name res1 res2+ = OutLabel name res1 res2 where res1 = [ cdss | (OutData cdss) <- res ] res2 = [ out | out@(OutLabel {}) <- res ]@@ -536,92 +536,92 @@ cdsToOutput fn@(CDSFun {}) = OutData fn -- %************************************************************************--- %* *+-- %* * -- \subsection{A Pretty Printer}--- %* *+-- %* * -- %************************************************************************ -- This pretty printer is based on Wadler's pretty printer. -data DOC = NIL -- nil - | DOC :<> DOC -- beside - | NEST Int DOC- | TEXT String- | LINE -- always "\n"- | SEP -- " " or "\n"- | BREAK -- "" or "\n"- | DOC :<|> DOC -- choose one- deriving (Eq,Show)-data Doc = Nil- | Text Int String Doc- | Line Int Int Doc- deriving (Show,Eq)+data DOC = NIL -- nil + | DOC :<> DOC -- beside + | NEST Int DOC+ | TEXT String+ | LINE -- always "\n"+ | SEP -- " " or "\n"+ | BREAK -- "" or "\n"+ | DOC :<|> DOC -- choose one+ deriving (Eq,Show)+data Doc = Nil+ | Text Int String Doc+ | Line Int Int Doc+ deriving (Show,Eq) -mkText :: String -> Doc -> Doc-mkText s d = Text (toplen d + length s) s d+mkText :: String -> Doc -> Doc+mkText s d = Text (toplen d + length s) s d -mkLine :: Int -> Doc -> Doc-mkLine i d = Line (toplen d + i) i d+mkLine :: Int -> Doc -> Doc+mkLine i d = Line (toplen d + i) i d -toplen :: Doc -> Int-toplen Nil = 0-toplen (Text w s x) = w-toplen (Line w s x) = 0+toplen :: Doc -> Int+toplen Nil = 0+toplen (Text w s x) = w+toplen (Line w s x) = 0 -nil = NIL-x <> y = x :<> y-nest i x = NEST i x-text s = TEXT s-line = LINE-sep = SEP-brk = BREAK+nil = NIL+x <> y = x :<> y+nest i x = NEST i x+text s = TEXT s+line = LINE+sep = SEP+brk = BREAK -fold x = grp (brk <> x)+fold x = grp (brk <> x) -grp :: DOC -> DOC-grp x = - case flatten x of- Just x' -> x' :<|> x- Nothing -> x+grp :: DOC -> DOC+grp x = + case flatten x of+ Just x' -> x' :<|> x+ Nothing -> x -flatten :: DOC -> Maybe DOC-flatten NIL = return NIL-flatten (x :<> y) = - do x' <- flatten x- y' <- flatten y- return (x' :<> y')-flatten (NEST i x) = - do x' <- flatten x- return (NEST i x')-flatten (TEXT s) = return (TEXT s)-flatten LINE = Nothing -- abort-flatten SEP = return (TEXT " ") -- SEP is space-flatten BREAK = return NIL -- BREAK is nil-flatten (x :<|> y) = flatten x+flatten :: DOC -> Maybe DOC+flatten NIL = return NIL+flatten (x :<> y) = + do x' <- flatten x+ y' <- flatten y+ return (x' :<> y')+flatten (NEST i x) = + do x' <- flatten x+ return (NEST i x')+flatten (TEXT s) = return (TEXT s)+flatten LINE = Nothing -- abort+flatten SEP = return (TEXT " ") -- SEP is space+flatten BREAK = return NIL -- BREAK is nil+flatten (x :<|> y) = flatten x -layout :: Doc -> String-layout Nil = ""-layout (Text _ s x) = s ++ layout x-layout (Line _ i x) = '\n' : replicate i ' ' ++ layout x+layout :: Doc -> String+layout Nil = ""+layout (Text _ s x) = s ++ layout x+layout (Line _ i x) = '\n' : replicate i ' ' ++ layout x best w k doc = be w k [(0,doc)] -be :: Int -> Int -> [(Int,DOC)] -> Doc-be w k [] = Nil-be w k ((i,NIL):z) = be w k z-be w k ((i,x :<> y):z) = be w k ((i,x):(i,y):z)+be :: Int -> Int -> [(Int,DOC)] -> Doc+be w k [] = Nil+be w k ((i,NIL):z) = be w k z+be w k ((i,x :<> y):z) = be w k ((i,x):(i,y):z) be w k ((i,NEST j x):z) = be w k ((k+j,x):z)-be w k ((i,TEXT s):z) = s `mkText` be w (k+length s) z-be w k ((i,LINE):z) = i `mkLine` be w i z-be w k ((i,SEP):z) = i `mkLine` be w i z-be w k ((i,BREAK):z) = i `mkLine` be w i z+be w k ((i,TEXT s):z) = s `mkText` be w (k+length s) z+be w k ((i,LINE):z) = i `mkLine` be w i z+be w k ((i,SEP):z) = i `mkLine` be w i z+be w k ((i,BREAK):z) = i `mkLine` be w i z be w k ((i,x :<|> y):z) = better w k - (be w k ((i,x):z))- (be w k ((i,y):z))+ (be w k ((i,x):z))+ (be w k ((i,y):z)) -better :: Int -> Int -> Doc -> Doc -> Doc-better w k x y = if (w-k) >= toplen x then x else y+better :: Int -> Int -> Doc -> Doc -> Doc+better w k x y = if (w-k) >= toplen x then x else y -pretty :: Int -> DOC -> String-pretty w x = layout (best w 0 x)+pretty :: Int -> DOC -> String+pretty w x = layout (best w 0 x)
Hoed.cabal view
@@ -1,5 +1,5 @@ name: Hoed-version: 0.2.0+version: 0.2.1 synopsis: Lighweight algorithmic debugging based on observing intermediate values and the cost centre stack. -- description: TODO homepage: http://maartenfaddegon.nl@@ -7,10 +7,11 @@ license-file: LICENSE author: Maarten Faddegon maintainer: hoed@maartenfaddegon.nl-copyright: (c) 2000 Andy Gill, (c) 2010 University of Kansas, (c) 2013-2014 Maarten Faddegon+copyright: (c) 2000 Andy Gill, (c) 2010 University of Kansas, (c) 2013-2015 Maarten Faddegon category: Debug, Trace build-type: Simple cabal-version: >=1.10+Extra-Source-Files: changelog flag buildExamples description: Build example executables.@@ -20,7 +21,6 @@ description: Build validation executables. default: False - library exposed-modules: Debug.Hoed other-modules: Debug.Hoed.Observe@@ -30,7 +30,7 @@ , template-haskell , array, containers , process- , threepenny-gui+ , threepenny-gui == 0.5.* , filepath , libgraph == 1.4 , RBTree == 0.0.5@@ -73,6 +73,19 @@ else buildable: False main-is: HeadOnEmpty.hs+ hs-source-dirs: examples+ default-language: Haskell2010+ ghc-options: -O0++Executable hoed-examples-Ho+ if flag(buildExamples)+ build-depends: base >= 4 && < 5+ , Hoed+ , threepenny-gui+ , filepath+ else+ buildable: False+ main-is: Ho.hs hs-source-dirs: examples default-language: Haskell2010 ghc-options: -O0
+ changelog view
@@ -0,0 +1,13 @@+0.2.1 Maarten Faddegon 1 May 2015++ * Small changes to make Hoed work with GHC 7.10++0.2.0 Maarten Faddegon 12 Feb 2015++ * A threepenny-gui algorithmic debugger.+ * Construction of computation trees with just local annotations. Existing algorithmic debuggers for Haskell require a transformation of all modules in a program, even libraries that the user does not want to debug and which may use language features not supported by the debugger. This is a pity, because a promising approach to debugging is therefore not applicable to many real-world programs. We use the cost centre stack from the Glasgow Haskell Compiler profiling environment together with runtime value observations to collect enough information for algorithmic debugging.+++0.1.0.1 Maarten Faddegon 24 May 2014++ * A tracer library based on Andy Gills HOOD v0.2. Allows to observe intermediate values. How values are observed can be derived with the Generic Deriving Mechanism, or generated with Template Haskell.
+ examples/Ho.hs view
@@ -0,0 +1,13 @@+import Debug.Hoed++app :: Observable a => (a->a) -> a -> a+app = observe "app" (\g y -> {-# SCC "app" #-} g y)+++f :: Observable a => a -> a+f = observe "f" (\x -> {-# SCC "app" #-} x)++k :: Int+k = 3++main = runO $ print (app f k)
examples/Pretty.hs view
@@ -49,9 +49,9 @@ ) where (pairs',callStack) = findFn [cds] pairs = (nub . (sort)) pairs'- -- local nub for sorted lists- nub [] = []- nub (a:a':as) | a == a' = nub (a' : as)+ -- local nub for sorted lists+ nub [] = []+ nub (a:a':as) | a == a' = nub (a' : as) nub (a:as) = a : nub as renderCallStack :: CallStack -> DOC@@ -91,11 +91,11 @@ -- The CDS and converting functions data CDS = CDSNamed String CDSSet- | CDSCons Int String [CDSSet]- | CDSFun Int CDSSet CDSSet CallStack- | CDSEntered Int- | CDSTerminated Int- deriving (Show,Eq,Ord,Generic)+ | CDSCons Int String [CDSSet]+ | CDSFun Int CDSSet CDSSet CallStack+ | CDSEntered Int+ | CDSTerminated Int+ deriving (Show,Eq,Ord,Generic) type CDSSet = [CDS] @@ -108,55 +108,55 @@ mid_arr :: Array Int [(Int,CDS)] mid_arr = accumArray (flip (:)) [] bnds- [ (pnode,(pport,res node))- | (Event node (Parent pnode pport) _) <- pairs- ]+ [ (pnode,(pport,res node))+ | (Event node (Parent pnode pport) _) <- pairs+ ] - out_arr = array bnds -- never uses 0 index- [ (node,getNode'' node change)- | (Event node _ change) <- pairs- ]+ out_arr = array bnds -- never uses 0 index+ [ (node,getNode'' node change)+ | (Event node _ change) <- pairs+ ] getNode'' :: Int -> Change -> CDS getNode'' node change = case change of- (Observe str) -> CDSNamed str (getChild node 0)- (Enter) -> CDSEntered node- (NoEnter) -> CDSTerminated node- (Fun str) -> CDSFun node (getChild node 0) (getChild node 1) str- (Cons portc cons)- -> CDSCons node cons - [ getChild node n | n <- [0..(portc-1)]]+ (Observe str) -> CDSNamed str (getChild node 0)+ (Enter) -> CDSEntered node+ (NoEnter) -> CDSTerminated node+ (Fun str) -> CDSFun node (getChild node 0) (getChild node 1) str+ (Cons portc cons)+ -> CDSCons node cons + [ getChild node n | n <- [0..(portc-1)]] getChild :: Int -> Int -> CDSSet getChild pnode pport =- [ content+ [ content | (pport',content) <- (!) mid_arr pnode- , pport == pport'- ]+ , pport == pport'+ ] render :: Int -> Bool -> CDS -> DOC render prec par (CDSCons _ ":" [cds1,cds2]) =- if (par && not needParen) - then doc -- dont use paren (..) because we dont want a grp here!- else paren needParen doc+ if (par && not needParen) + then doc -- dont use paren (..) because we dont want a grp here!+ else paren needParen doc where- doc = grp (brk <> renderSet' 5 False cds1 <> text " : ") <>- renderSet' 4 True cds2- needParen = prec > 4+ doc = grp (brk <> renderSet' 5 False cds1 <> text " : ") <>+ renderSet' 4 True cds2+ needParen = prec > 4 render prec par (CDSCons _ "," cdss) | length cdss > 0 =- nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b)- (map renderSet cdss) <>- text ")")+ nest 2 (text "(" <> foldl1 (\ a b -> a <> text ", " <> b)+ (map renderSet cdss) <>+ text ")") render prec par (CDSCons _ name cdss) =- paren (length cdss > 0 && prec /= 0)- (nest 2- (text name <> foldr (<>) nil- [ sep <> renderSet' 10 False cds- | cds <- cdss - ]- )- )+ paren (length cdss > 0 && prec /= 0)+ (nest 2+ (text name <> foldr (<>) nil+ [ sep <> renderSet' 10 False cds+ | cds <- cdss + ]+ )+ ) {- renderSet handles the various styles of CDSSet. -}@@ -167,29 +167,29 @@ renderSet' :: Int -> Bool -> CDSSet -> DOC renderSet' _ _ [] = text "_" renderSet' prec par [cons@(CDSCons {})] = render prec par cons-renderSet' prec par cdss = - nest 0 (text "{ " <> foldl1 (\ a b -> a <> line <>- text ", " <> b)- (map (renderFn caller) pairs) <>- line <> text "}")+renderSet' prec par cdss = + nest 0 (text "{ " <> foldl1 (\ a b -> a <> line <>+ text ", " <> b)+ (map (renderFn caller) pairs) <>+ line <> text "}") where- (pairs',caller) = findFn cdss+ (pairs',caller) = findFn cdss pairs = (nub . sort) pairs'- -- local nub for sorted lists- nub [] = []- nub (a:a':as) | a == a' = nub (a' : as)+ -- local nub for sorted lists+ nub [] = []+ nub (a:a':as) | a == a' = nub (a' : as) nub (a:as) = a : nub as renderFn :: CallStack -> ([CDSSet],CDSSet) -> DOC renderFn callStack (args, res)- = grp (nest 3 - (text "\\ " <>- foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b)- nil- args <> sep <>- text "-> " <> renderSet' 0 False res- )+ = grp (nest 3 + (text "\\ " <>+ foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b)+ nil+ args <> sep <>+ text "-> " <> renderSet' 0 False res+ ) ) renderNamedFn :: String -> ([CDSSet],CDSSet) -> DOC@@ -226,9 +226,9 @@ renderTop :: Output -> DOC renderTop (OutLabel str set extras) =- nest 2 (text ("-- " ++ str) <> line <>- renderSet set- <> renderTops extras) <> line+ nest 2 (text ("-- " ++ str) <> line <>+ renderSet set+ <> renderTops extras) <> line rmEntry :: CDS -> CDS rmEntry (CDSNamed str set) = CDSNamed str (rmEntrySet set)@@ -239,18 +239,18 @@ rmEntrySet = map rmEntry . filter noEntered where- noEntered (CDSEntered _) = False- noEntered _ = True+ noEntered (CDSEntered _) = False+ noEntered _ = True simplifyCDS :: CDS -> CDS simplifyCDS (CDSNamed str set) = CDSNamed str (simplifyCDSSet set) simplifyCDS (CDSCons _ "throw" - [[CDSCons _ "ErrorCall" set]]- ) = simplifyCDS (CDSCons 0 "error" set)+ [[CDSCons _ "ErrorCall" set]]+ ) = simplifyCDS (CDSCons 0 "error" set) simplifyCDS cons@(CDSCons i str sets) = - case spotString [cons] of- Just str | not (null str) -> CDSCons 0 (show str) []- _ -> CDSCons 0 str (map simplifyCDSSet sets)+ case spotString [cons] of+ Just str | not (null str) -> CDSCons 0 (show str) []+ _ -> CDSCons 0 str (map simplifyCDSSet sets) simplifyCDS (CDSFun i a b str) = CDSFun 0 (simplifyCDSSet a) (simplifyCDSSet b) str @@ -260,16 +260,16 @@ spotString :: CDSSet -> Maybe String spotString [CDSCons _ ":"- [[CDSCons _ str []]- ,rest- ]- ] - = do { ch <- case reads str of- [(ch,"")] -> return ch+ [[CDSCons _ str []]+ ,rest+ ]+ ] + = do { ch <- case reads str of+ [(ch,"")] -> return ch _ -> Nothing- ; more <- spotString rest- ; return (ch : more)- }+ ; more <- spotString rest+ ; return (ch : more)+ } spotString [CDSCons _ "[]" []] = return [] spotString other = Nothing @@ -282,7 +282,7 @@ data Output = OutLabel String CDSSet [Output] | OutData CDS- deriving (Eq,Ord,Show,Generic)+ deriving (Eq,Ord,Show,Generic) commonOutput :: [Output] -> [Output]@@ -294,7 +294,7 @@ cdssToOutput = map cdsToOutput cdsToOutput (CDSNamed name cdsset)- = OutLabel name res1 res2+ = OutLabel name res1 res2 where res1 = [ cdss | (OutData cdss) <- res ] res2 = [ out | out@(OutLabel {}) <- res ]@@ -303,96 +303,96 @@ cdsToOutput fn@(CDSFun {}) = OutData fn -- %************************************************************************--- %* *+-- %* * -- \subsection{A Pretty Printer}--- %* *+-- %* * -- %************************************************************************ -- This pretty printer is based on Wadler's pretty printer. -data DOC = NIL -- nil - | DOC :<> DOC -- beside - | NEST Int DOC- | TEXT String- | LINE -- always "\n"- | SEP -- " " or "\n"- | BREAK -- "" or "\n"- | DOC :<|> DOC -- choose one- deriving (Eq,Show,Generic)-data Doc = Nil- | Text Int String Doc- | Line Int Int Doc- deriving (Show,Eq)+data DOC = NIL -- nil + | DOC :<> DOC -- beside + | NEST Int DOC+ | TEXT String+ | LINE -- always "\n"+ | SEP -- " " or "\n"+ | BREAK -- "" or "\n"+ | DOC :<|> DOC -- choose one+ deriving (Eq,Show,Generic)+data Doc = Nil+ | Text Int String Doc+ | Line Int Int Doc+ deriving (Show,Eq) -mkText :: String -> Doc -> Doc-mkText s d = Text (toplen d + length s) s d+mkText :: String -> Doc -> Doc+mkText s d = Text (toplen d + length s) s d -mkLine :: Int -> Doc -> Doc-mkLine i d = Line (toplen d + i) i d+mkLine :: Int -> Doc -> Doc+mkLine i d = Line (toplen d + i) i d -toplen :: Doc -> Int-toplen Nil = 0-toplen (Text w s x) = w-toplen (Line w s x) = 0+toplen :: Doc -> Int+toplen Nil = 0+toplen (Text w s x) = w+toplen (Line w s x) = 0 -nil = NIL-x <> y = x :<> y-nest i x = NEST i x-text s = TEXT s-line = LINE-sep = SEP-brk = BREAK+nil = NIL+x <> y = x :<> y+nest i x = NEST i x+text s = TEXT s+line = LINE+sep = SEP+brk = BREAK -fold x = grp (brk <> x)+fold x = grp (brk <> x) -grp :: DOC -> DOC-grp x = - case flatten x of- Just x' -> x' :<|> x- Nothing -> x+grp :: DOC -> DOC+grp x = + case flatten x of+ Just x' -> x' :<|> x+ Nothing -> x -flatten :: DOC -> Maybe DOC-flatten NIL = return NIL-flatten (x :<> y) = - do x' <- flatten x- y' <- flatten y- return (x' :<> y')-flatten (NEST i x) = - do x' <- flatten x- return (NEST i x')-flatten (TEXT s) = return (TEXT s)-flatten LINE = Nothing -- abort-flatten SEP = return (TEXT " ") -- SEP is space-flatten BREAK = return NIL -- BREAK is nil-flatten (x :<|> y) = flatten x+flatten :: DOC -> Maybe DOC+flatten NIL = return NIL+flatten (x :<> y) = + do x' <- flatten x+ y' <- flatten y+ return (x' :<> y')+flatten (NEST i x) = + do x' <- flatten x+ return (NEST i x')+flatten (TEXT s) = return (TEXT s)+flatten LINE = Nothing -- abort+flatten SEP = return (TEXT " ") -- SEP is space+flatten BREAK = return NIL -- BREAK is nil+flatten (x :<|> y) = flatten x -layout :: Doc -> String-layout Nil = ""-layout (Text _ s x) = s ++ layout x-layout (Line _ i x) = '\n' : replicate i ' ' ++ layout x+layout :: Doc -> String+layout Nil = ""+layout (Text _ s x) = s ++ layout x+layout (Line _ i x) = '\n' : replicate i ' ' ++ layout x best w k doc = be w k [(0,doc)] -be :: Int -> Int -> [(Int,DOC)] -> Doc-be w k [] = Nil-be w k ((i,NIL):z) = be w k z-be w k ((i,x :<> y):z) = be w k ((i,x):(i,y):z)+be :: Int -> Int -> [(Int,DOC)] -> Doc+be w k [] = Nil+be w k ((i,NIL):z) = be w k z+be w k ((i,x :<> y):z) = be w k ((i,x):(i,y):z) be w k ((i,NEST j x):z) = be w k ((k+j,x):z)-be w k ((i,TEXT s):z) = s `mkText` be w (k+length s) z-be w k ((i,LINE):z) = i `mkLine` be w i z-be w k ((i,SEP):z) = i `mkLine` be w i z-be w k ((i,BREAK):z) = i `mkLine` be w i z+be w k ((i,TEXT s):z) = s `mkText` be w (k+length s) z+be w k ((i,LINE):z) = i `mkLine` be w i z+be w k ((i,SEP):z) = i `mkLine` be w i z+be w k ((i,BREAK):z) = i `mkLine` be w i z be w k ((i,x :<|> y):z) = better w k - (be w k ((i,x):z))- (be w k ((i,y):z))+ (be w k ((i,x):z))+ (be w k ((i,y):z)) -better :: Int -> Int -> Doc -> Doc -> Doc-better w k x y = if (w-k) >= toplen x then x else y+better :: Int -> Int -> Doc -> Doc -> Doc+better w k x y = if (w-k) >= toplen x then x else y -pretty :: Int -> DOC -> String+pretty :: Int -> DOC -> String pretty w x = observe "pretty" (\w' x'-> {-# SCC "pretty" #-} pretty' w' x') w x-pretty' w x = layout (best w 0 x)+pretty' w x = layout (best w 0 x) ------------------------------------------------------------------------ -- Stacks@@ -403,22 +403,22 @@ ------------------------------------------------------------------------ -- Events data Event = Event- { portId :: !Int- , parent :: !Parent- , change :: !Change- }- deriving (Show, Read)+ { portId :: !Int+ , parent :: !Parent+ , change :: !Change+ }+ deriving (Show, Read) data Change- = Observe !String- | Cons !Int !String- | Enter+ = Observe !String+ | Cons !Int !String+ | Enter | NoEnter- | Fun !CallStack- deriving (Show, Read)+ | Fun !CallStack+ deriving (Show, Read) data Parent = Parent- { observeParent :: !Int -- my parent- , observePort :: !Int -- my branch number- } deriving (Show, Read)+ { observeParent :: !Int -- my parent+ , observePort :: !Int -- my branch number+ } deriving (Show, Read) root = Parent 0 0