diff --git a/Debug/Hoed.hs b/Debug/Hoed.hs --- a/Debug/Hoed.hs +++ b/Debug/Hoed.hs @@ -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 () diff --git a/Debug/Hoed/DemoGUI.hs b/Debug/Hoed/DemoGUI.hs --- a/Debug/Hoed/DemoGUI.hs +++ b/Debug/Hoed/DemoGUI.hs @@ -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) diff --git a/Debug/Hoed/Observe.lhs b/Debug/Hoed/Observe.lhs --- a/Debug/Hoed/Observe.lhs +++ b/Debug/Hoed/Observe.lhs @@ -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 "" (return return << res) cxt + do res <- fn + send "" (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 diff --git a/Debug/Hoed/Render.hs b/Debug/Hoed/Render.hs --- a/Debug/Hoed/Render.hs +++ b/Debug/Hoed/Render.hs @@ -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) diff --git a/Hoed.cabal b/Hoed.cabal --- a/Hoed.cabal +++ b/Hoed.cabal @@ -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 diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -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. diff --git a/examples/Ho.hs b/examples/Ho.hs new file mode 100644 --- /dev/null +++ b/examples/Ho.hs @@ -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) diff --git a/examples/Pretty.hs b/examples/Pretty.hs --- a/examples/Pretty.hs +++ b/examples/Pretty.hs @@ -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