Hoed 0.2.2 → 0.3.0

raw patch · 36 files changed

+3690/−264 lines, 36 filesdep ~basenew-component:exe:hoed-tests-Generic-r0new-component:exe:hoed-tests-Generic-r1new-component:exe:hoed-tests-Generic-r2new-component:exe:hoed-tests-Generic-r3new-component:exe:hoed-tests-Generic-t0new-component:exe:hoed-tests-Generic-t1new-component:exe:hoed-tests-Generic-t2new-component:exe:hoed-tests-Generic-t3new-component:exe:hoed-tests-Pure-t1new-component:exe:hoed-tests-Pure-t2new-component:exe:hoed-tests-Pure-t3new-component:exe:hoed-tests-Pure-t4new-component:exe:hoed-tests-Stk-DoublingServernew-component:exe:hoed-tests-Stk-Example1new-component:exe:hoed-tests-Stk-Example3new-component:exe:hoed-tests-Stk-Example4new-component:exe:hoed-tests-Stk-IndirectRecursionnew-component:exe:hoed-tests-Stk-Insort2PVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Debug/Hoed/Pure.hs +318/−0
• Debug/Hoed/Pure/CompTree.hs +311/−0
• Debug/Hoed/Pure/DemoGUI.hs +521/−0
• Debug/Hoed/Pure/EventForest.hs +163/−0
• Debug/Hoed/Pure/Observe.lhs +1190/−0
• Debug/Hoed/Pure/Prop.hs +105/−0
• Debug/Hoed/Pure/Render.hs +398/−0
• Debug/Hoed/Stk.hs +17/−14
• Debug/Hoed/Stk/Observe.lhs +13/−19
• Debug/Hoed/Stk/Render.hs +22/−11
• Hoed.cabal +170/−29
• README.md +85/−0
• tests/DoublingServer.hs +0/−76
• tests/Example1.hs +0/−9
• tests/Example3.lhs +0/−27
• tests/Example4.hs +0/−3
• tests/Generic/r0.hs +12/−0
• tests/Generic/r1.hs +15/−0
• tests/Generic/r2.hs +15/−0
• tests/Generic/r3.hs +15/−0
• tests/Generic/t0.hs +12/−0
• tests/Generic/t1.hs +14/−0
• tests/Generic/t2.hs +14/−0
• tests/Generic/t3.hs +13/−0
• tests/IndirectRecursion.lhs +0/−37
• tests/Insort2.hs +0/−39
• tests/Pure/t1.hs +12/−0
• tests/Pure/t2.hs +19/−0
• tests/Pure/t3.hs +22/−0
• tests/Pure/t4.hs +25/−0
• tests/Stk/DoublingServer.hs +74/−0
• tests/Stk/Example1.hs +9/−0
• tests/Stk/Example3.lhs +27/−0
• tests/Stk/Example4.hs +3/−0
• tests/Stk/IndirectRecursion.lhs +37/−0
• tests/Stk/Insort2.hs +39/−0

@@ -0,0 +1,318 @@+{-|+Module      : Debug.Hoed.Pure+Description : Lighweight algorithmic debugging based on observing intermediate values and the cost centre stack.+Copyright   : (c) 2000 Andy Gill, (c) 2010 University of Kansas, (c) 2013-2015 Maarten Faddegon+License     : BSD3+Maintainer  : hoed@maartenfaddegon.nl+Stability   : experimental+Portability : POSIX++Hoed is a tracer and debugger for the programming language Haskell. You can+trace a program by annotating functions in suspected modules and linking your+program against standard profiling libraries.++To locate a defect with Hoed you annotate suspected functions and compile as usual. Then you run your program, information about the annotated functions is collected. Finally you connect to a debugging session using a webbrowser.++Let us consider the following program, a defective implementation of a parity function with a test property.++> import Test.QuickCheck+>+> isOdd :: Int -> Bool+> isOdd n = isEven (plusOne n)+>+> isEven :: Int -> Bool+> isEven n = mod2 n == 0+>+> plusOne :: Int -> Int+> plusOne n = n + 1+>+> mod2 :: Int -> Int+> mod2 n = div n 2+>+> prop_isOdd :: Int -> Bool+> prop_isOdd x = isOdd (2*x+1)+>+> main :: IO ()+> main = printO (prop_isOdd 1)+>+> main :: IO ()+> main = quickcheck prop_isOdd++Using the property-based test tool QuickCheck we find the counter example `1` for our property.++> ./MyProgram+> *** Failed! Falsifiable (after 1 test): 1++Hoed can help us determine which function is defective. We annotate the functions `isOdd`, `isEven`, `plusOne` and `mod2` as follows:++> import Debug.Hoed.Pure+>+> isOdd :: Int -> Bool+> isOdd = observe "isOdd" isOdd'+> isOdd' n = isEven (plusOne n)+>+> isEven :: Int -> Bool+> isEven = observe "isEven" isEven'+> isEven' n = mod2 n == 0+>+> plusOne :: Int -> Int+> plusOne = observe "plusOne" plusOne'+> plusOne' n = n + 1+>+> mod2 :: Int -> Int+> mod2 = observe "mod2" mod2'+> mod2' n = div n 2+>+> prop_isOdd :: Int -> Bool+> prop_isOdd x = isOdd (2*x+1)+>+> main :: IO ()+> main = printO (prop_isOdd 1)++After running the program a computation tree is constructed and displayed in a web browser.++> ./MyProgram+> False+> Listening on http://127.0.0.1:10000/++After running the program a computation tree is constructed and displayed in a+web browser. You can freely browse this tree to get a better understanding of+your program. If your program misbehaves, you can judge the computation+statements in the tree as 'right' or 'wrong' according to your intention. When+enough statements are judged the debugger tells you the location of the fault+in your code.++<<http://www.cs.kent.ac.uk/people/rpg/mf357/hoedv2.0.0.png>>++I work on this debugger in the context of my Ph.D. research.+Read more about the theory behind Hoed at <http://maartenfaddegon.nl/#pub>.++Hoed.Pure is recommended over Hoed.Stk because to debug your program with Hoed.Pure you can optimize your program and do not need to enable profiling.++I am keen to hear about your experience with Hoed: where did you find it useful and where would you like to see improvement? You can send me an e-mail at hoed@maartenfaddegon.nl, or use the github issue tracker <https://github.com/MaartenFaddegon/hoed/issues>.+-}++module Debug.Hoed.Pure+  ( -- * Basic annotations+    observe+  , runO+  , printO++    -- * Experimental annotations+  , traceOnly+  , doit+  , observeTempl+  , observedTypes+  , observeCC+  , logO++   -- * The Observable class+  , Observer(..)+  , Observable(..)+  , (<<)+  , thunk+  , nothunk+  , send+  , observeBase+  , observeOpaque+  , debugO+  , CDS(..)+  , Generic+  ) where+++import Debug.Hoed.Pure.Observe+import Debug.Hoed.Pure.Render+import Debug.Hoed.Pure.EventForest+import Debug.Hoed.Pure.CompTree+import Debug.Hoed.Pure.DemoGUI+import Debug.Hoed.Pure.Prop++import Prelude hiding (Right)+import qualified Prelude+import System.IO+import Data.Maybe+import Control.Monad+import Data.List+import Data.Ord+import Data.Char+import System.Environment+import System.Directory(createDirectoryIfMissing)++import Language.Haskell.TH+import GHC.Generics++import Data.IORef+import System.IO.Unsafe+import Data.Graph.Libgraph+import Graphics.UI.Threepenny(startGUI,defaultConfig,Config(..))++import System.Directory(createDirectoryIfMissing)+++-- %************************************************************************+-- %*                                                                   *+-- \subsection{External start functions}+-- %*                                                                   *+-- %************************************************************************++-- Run the observe ridden code.++-- | run some code and return the Trace+debugO :: IO a -> IO Trace+debugO program =+     do { initUniq+        ; startEventStream+        ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]"+        ; ourCatchAllIO (do { program ; return () })+                        (hPutStrLn stderr . errorMsg)+        ; endEventStream+        }++-- | run some code and return the CDS structure (for when you want to write your own debugger).+debugO' :: IO a -> IO [CDS]+debugO' program = do+  events <- debugO program+  return (eventsToCDS events)+++-- | print a string, with debugging+putStrO :: String -> IO ()+putStrO expr = runO (putStr expr)++-- | The main entry point; run some IO code, and debug inside it.+--   After the IO action is completed, an algorithmic debugging session is started at+--   @http://localhost:10000/@ to which you can connect with your webbrowser.+--+-- For example:+--+-- @+--   main = runO $ do print (triple 3)+--                    print (triple 2)+-- @++runO :: IO a -> IO ()+runO program = do+  (trace,traceInfo,compGraph,frt) <- runO' program+  debugSession trace traceInfo compGraph frt+  return ()++-- | Short for @runO . print@.+printO :: (Show a) => a -> IO ()+printO expr = runO (print expr)++-- | Only produces a trace. Useful for performance measurements.+traceOnly :: IO a -> IO ()+traceOnly program = do+  debugO program+  return ()++doit :: IO a -> IO ()+doit program = do+  (trace,traceInfo,compGraph,frt) <- runO' program+  case filter (/= RootVertex) (vertices compGraph) of+    []    -> return ()+    (v:_) -> do putStrLn "\n=== DoIt ===\n"+                v' <- judge trace p1 v+                print v'++runO' :: IO a -> IO (Trace,TraceInfo,CompTree,EventForest)+runO' program = do+  createDirectoryIfMissing True ".Hoed/"+  hPutStrLn stderr "=== program output ===\n"+  events <- debugO program+  let cdss = eventsToCDS events+  let cdss1 = rmEntrySet cdss+  let cdss2 = simplifyCDSSet cdss1+  let eqs   = renderCompStmts cdss2++  let frt  = mkEventForest events+      rs   = filter isRootEvent events+      ti   = traceInfo (reverse events)+      ds   = dependencies ti+      ct   = mkCompTree eqs ds++  -- hPutStrLn stderr "\n=== Events ===\n"+  -- hPutStrLn stderr $ unlines (map show . reverse $ events)+  writeFile ".Hoed/Events" (unlines . map show . reverse $ events)++  -- hPutStrLn stderr "\n=== Dependencies ===\n"+  -- hPutStrLn stderr $ unlines (map (\(m,n,msg) -> show m ++ " -> " ++ show n ++ " %" ++ msg) ds)++  -- hPutStrLn stderr "\n=== Computation Statements ===\n"+  -- hPutStrLn stderr $ show eqs+  -- hPutStrLn stderr $ unlines . (map $ show . stmtUIDs) $ eqs++  hPutStrLn stderr "\n=== Statistics ===\n"+  let e  = length events+      n  = length eqs+      d  = treeDepth ct+      b  = fromIntegral (length . arcs $ ct ) / fromIntegral ((length . vertices $ ct) - (length . leafs $ ct))+  hPutStrLn stderr $ "e = " ++ show e+  hPutStrLn stderr $ "n = " ++ show n+  hPutStrLn stderr $ "d' = " ++ (show . length $ ds)+  -- hPutStrLn stderr $ "d = " ++ show d+  hPutStrLn stderr $ "b = " ++ show b++  -- hPutStrLn stderr "\n=== Debug Session ===\n"+  return (events, ti, ct, frt)++  where summarizeEvent e = show (eventUID e) ++ ": " ++ summarizeChange (change e)+        summarizeChange (Observe l _ _) = show l+        summarizeChange (Cons _ c)      = show c+        summarizeChange c               = show c+        showJ (Just s) = show s+        showJ Nothing  = "??"++logO :: FilePath -> IO a -> IO ()+logO filePath program = {- SCC "logO" -} do+  (_,_,compTree,_) <- runO' program+  writeFile filePath (showGraph compTree)+  return ()++  where showGraph g        = showWith g showVertex showArc+        showVertex RootVertex = ("root","")+        showVertex v       = ("\"" ++ (escape . showCompStmt) v ++ "\"", "")+        showArc _          = ""+        showCompStmt       = show . vertexStmt+++hPutStrList :: (Show a) => Handle -> [a] -> IO()+hPutStrList h []     = hPutStrLn h ""+hPutStrList h (c:cs) = do {hPutStrLn h (show c); hPutStrList h cs}++------------------------------------------------------------------------+-- Push mode option handling++data PushMode = Vanilla | Drop | Truncate++pushMode :: IORef PushMode+pushMode = unsafePerformIO $ newIORef Vanilla++setPushMode :: PushMode -> IO ()+setPushMode = writeIORef pushMode++getPushMode :: PushMode+getPushMode = unsafePerformIO $ readIORef pushMode++-- MF TODO: handle a bit nicer?+parseArgs :: [String] -> PushMode+parseArgs []      = Truncate -- default mode+parseArgs (arg:_) = case arg of+        "--PushVanilla"  -> Vanilla+        "--PushDrop"     -> Drop+        "--PushTruncate" -> Truncate+        _              -> error ("unknown option " ++ arg)+++------------------------------------------------------------------------+-- Algorithmic Debugging++debugSession :: Trace -> TraceInfo -> CompTree -> EventForest -> IO ()+debugSession trace traceInfo tree frt+  = do createDirectoryIfMissing True ".Hoed/wwwroot/css"+       treeRef <- newIORef tree+       startGUI defaultConfig+           { jsPort       = Just 10000+           , jsStatic     = Just "./.Hoed/wwwroot"+           } (guiMain trace traceInfo treeRef frt)

@@ -0,0 +1,311 @@+-- This file is part of the Haskell debugger Hoed.+--+-- Copyright (c) Maarten Faddegon, 2015++module Debug.Hoed.Pure.CompTree+( CompTree+, Vertex(..)+, mkCompTree+, isRootVertex+, vertexUID+, leafs+, ConstantValue(..)+, getLocation+, getMessage+, TraceInfo(..)+, traceInfo+)where++import Debug.Hoed.Pure.Render+import Debug.Hoed.Pure.Observe+import Debug.Hoed.Pure.EventForest++import Prelude hiding (Right)+import Data.Graph.Libgraph+import Data.List(nub,delete,(\\))+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++data Vertex = RootVertex | Vertex {vertexStmt :: CompStmt, vertexJmt :: Judgement} +  deriving (Eq,Show,Ord)++vertexUID :: Vertex -> UID+vertexUID RootVertex   = -1+vertexUID (Vertex s _) = stmtIdentifier s++type CompTree = Graph Vertex ()++isRootVertex :: Vertex -> Bool+isRootVertex RootVertex = True+isRootVertex _          = False++leafs :: CompTree -> [Vertex]+leafs g = filter (\v -> succs g v == []) (vertices g)++--------------------------------------------------------------------------------+-- Computation Tree++-- One computation statement can have multiple result-events. Sometime these add+-- new information, often the information is just a duplicate of what we already+-- know. With nub we remove the duplicates.++mkCompTree :: [CompStmt] -> [(UID,UID)] -> CompTree+mkCompTree cs ds = Graph RootVertex (vs) as++  where vs = RootVertex : map (\cs -> Vertex cs Unassessed) cs+        as = map (\(i,j) -> Arc (findVertex i) (findVertex j) ()) (nub ds)++        -- A mapping from stmtUID to Vertex of all CompStmts in cs+        vMap :: IntMap Vertex+        -- vMap = foldl (\m c -> let v = Vertex c Unassessed in foldl (\m' i -> IntMap.insert i v m') m (stmtUIDs c)) IntMap.empty cs+        vMap = foldl (\m c -> IntMap.insert (stmtIdentifier c) (Vertex c Unassessed) m) IntMap.empty cs++        -- Given an UID, get corresponding CompStmt (wrapped in a Vertex)+        findVertex :: UID -> Vertex+        findVertex (-1) = RootVertex+        findVertex a = case IntMap.lookup a vMap of+          Nothing  -> error $ "mkCompTree: Error, cannot find a statement with UID " ++ show a ++ "!\n"+                              ++ "We recorded statements with the following UIDs: " ++ (show . IntMap.keys) vMap ++ "\n"+                              ++ unlines (map (\c -> (show . stmtIdentifier) c ++ ": " ++ show c) cs)+          (Just v) -> v++------------------------------------------------------------------------------------------------------------------------++data ConstantValue = ConstantValue { valStmt :: UID, valLoc :: Location+                                   , valMin :: UID,  valMax :: UID }+                   | CVRoot+                  deriving Eq++instance Show ConstantValue where+  show CVRoot = "Root"+  show v = "Stmt-" ++ (show . valStmt $ v)+         ++ "-"    ++ (show . valLoc  $ v) +         ++ ": "   ++ (show . valMin  $ v) +         ++ "-"    ++ (show . valMax  $ v) ++------------------------------------------------------------------------------------------------------------------------++-- Add element x to the head of the list at key k.+insertCon :: Int -> a -> IntMap [a] -> IntMap [a]+insertCon k x = IntMap.insertWith (\[x'] xs->x':xs) k [x] -- where x == x'++------------------------------------------------------------------------------------------------------------------------++data TraceInfo = TraceInfo+  { topLvlFun      :: IntMap UID+                   -- references from the UID of an event to the UID of the corresponding top-level Fun event+  , locations      :: IntMap (ParentPosition -> Bool)+                   -- reference from parent UID and position to location+  , computations   :: Nesting+                   -- UIDs of active and paused computations of arguments/results of Fun events+  , messages       :: IntMap String+                   -- stored depth of the stack for every event+  , storedStack    :: IntMap [UID]+                   -- reference from parent UID and position to previous stack+  , dependencies   :: [(UID,UID)]+  }                -- the result+++------------------------------------------------------------------------------------------------------------------------++addMessage :: Event -> String -> TraceInfo -> TraceInfo+addMessage e msg s = s{ messages = (flip $ IntMap.insert i) (messages s) $ case IntMap.lookup i (messages s) of+  Nothing     -> msg+  (Just msg') -> msg' ++ ", " ++ msg }++  where i = eventUID e+++getMessage :: Event -> TraceInfo -> String+getMessage e s = case IntMap.lookup i (messages s) of+  Nothing    -> ""+  (Just msg) -> msg++  where i = eventUID e++------------------------------------------------------------------------------------------------------------------------++getLocation :: Event -> TraceInfo -> Bool+getLocation e s = getLocation' p++  where p = parentPosition . eventParent $ e+        j = (parentUID . eventParent $ e)+        (Just getLocation') = (IntMap.lookup j (locations s))++setLocation :: Event -> (ParentPosition -> Bool) -> TraceInfo -> TraceInfo+setLocation e getLoc s = s{locations=IntMap.insert i getLoc (locations s)}++  where i = eventUID e++------------------------------------------------------------------------------------------------------------------------++-- When we see a Fun event whose parent is not a Fun event it is a top level Fun event,+-- otherwise just copy the reference to the top level Fun event from the parent.+-- A top leven Fun event references itself.+seeFun :: Event -> TraceInfo -> TraceInfo+seeFun e s = s{ topLvlFun=case IntMap.lookup j (topLvlFun s) of+                  Nothing  -> IntMap.insert i i (topLvlFun s)+                  (Just a) -> IntMap.insert i a (topLvlFun s)+              }++  where i = eventUID e+        j = parentUID . eventParent $ e++-- Get the UID of the top-level Fun of the parent of event e+getTopLvlFun :: Event -> TraceInfo -> UID+getTopLvlFun e s = case IntMap.lookup j (topLvlFun s) of Nothing -> j; (Just a') -> a'++  where j = parentUID . eventParent $ e++-- Copy top-level Fun reference from the parent of e+cpyTopLvlFun :: Event -> TraceInfo -> TraceInfo+cpyTopLvlFun e s = s{topLvlFun=IntMap.insert i a (topLvlFun s)}++  where i = eventUID e+        a = getTopLvlFun e s++------------------------------------------------------------------------------------------------------------------------++data Span = Computing UID | Paused UID+type Nesting = [Span]++instance Show Span where+  show (Computing i) = show i+  show (Paused i)    = "(" ++ show i ++ ")"++showCs :: [Span] -> String+showCs []  = "< >"+showCs [c] = "< " ++ show c ++ " >"+showCs (c:cs) = foldl (\s c' -> s ++ ", " ++ show c') ("< " ++ show c) cs ++ " >"++getSpanUID (Computing j) = j+getSpanUID (Paused j)    = j++isSpan :: UID -> Span -> Bool+isSpan i s = i == getSpanUID s++start :: Event -> TraceInfo -> TraceInfo+start e s = m s{computations = cs}++  where i  = getTopLvlFun e s+        cs = Computing i : computations s+        m  = addMessage e $ "Start computation " ++ show i ++ ": " ++ showCs cs+++stop :: Event -> TraceInfo -> TraceInfo+stop e s = m s{computations = cs}++  where i  = getTopLvlFun e s+        cs = deleteFirst (computations s)+        m  = addMessage e $ "Stop computation " ++ show i ++ ": " ++ showCs cs+        deleteFirst [] = [] +        deleteFirst (s:ss) | isSpan i s = ss +                           | otherwise  = s : deleteFirst ss+++pause :: Event -> TraceInfo -> TraceInfo+pause e s = m s{computations=cs}++  where i  = getTopLvlFun e s+        cs = map pause' (computations s)+        m  = addMessage e $ "Pause computation " ++ show i ++ ": " ++ showCs cs++        pause' (Computing j) | i == j    = Paused i+                             | otherwise = Computing j+        pause' s = s+++resume :: Event -> TraceInfo -> TraceInfo+resume e s = m s{computations=cs}++  where i  = getTopLvlFun e s+        cs = map resume' (computations s)+        m  = addMessage e $ "Resume computation " ++ show i ++ ": " ++ showCs cs++        resume' (Paused j)   | i == j    = Computing i+                             | otherwise = Paused j+        resume' s = s+++activeComputations :: TraceInfo -> [UID]+activeComputations s = map getSpanUID . filter isActive $ computations s+  where isActive (Computing _) = True+        isActive _             = False+++------------------------------------------------------------------------------------------------------------------------++addDependency :: Event -> TraceInfo -> TraceInfo+addDependency e s = m s{dependencies = case d of (Just d') -> d':dependencies s; Nothing -> dependencies s}++  where d = case activeComputations s of+              []       -> Nothing+              [n]      -> Just (-1,n)  -- top-level function detected (may later add dependency from Root)+              (n:m:_)  -> Just (m,n)++        m = case d of+             Nothing   -> addMessage e ("does not add dependency")+             (Just d') -> addMessage e ("adds dependency " ++ show (fst d') ++ " -> " ++ show (snd d'))++------------------------------------------------------------------------------------------------------------------------++type ConsMap = IntMap [ParentPosition]++-- Iff an event is a constant then the UID of its parent and its ParentPosition+-- are elements of the ConsMap.+mkConsMap :: Trace -> ConsMap+mkConsMap = foldl loop IntMap.empty+  where loop :: IntMap [ParentPosition] -> Event -> IntMap [ParentPosition]+        loop m e = case change e of+          Cons{} -> insertCon (parentUID . eventParent $ e) (parentPosition . eventParent $ e) m+          _      -> m++-- Return True for an enter event corresponding to a constant event and for any constant event, return False otherwise.+corToCons :: ConsMap -> Event -> Bool+corToCons cs e = case IntMap.lookup j cs of+                    Nothing   -> False+                    (Just ps) -> p `elem` ps+  where j = (parentUID . eventParent $ e)+        p = parentPosition . eventParent $ e++------------------------------------------------------------------------------------------------------------------------++traceInfo :: Trace -> TraceInfo+traceInfo trc = foldl loop s0 trc++  where s0 :: TraceInfo+        s0 = TraceInfo IntMap.empty IntMap.empty [] IntMap.empty IntMap.empty [] ++        cs :: ConsMap+        cs = mkConsMap trc++        is :: IntSet+        is = foldl (\s e -> case change e of Cons{} -> IntSet.insert (eventUID e) s; _ -> s) IntSet.empty trc++        parentIsConstant :: Event -> Bool+        parentIsConstant e = IntSet.member (parentUID . eventParent $ e) is++        loop :: TraceInfo -> Event -> TraceInfo+        loop s e = let loc = getLocation e s+                   in case change e of+                        Observe{} -> setLocation e (\_->True) s++                        Fun{}     -> setLocation e (\q->case q of 0 -> not loc; 1 -> loc) +                                     . seeFun e $ s++                        -- Span start+                        Enter{}   -> if not . corToCons cs $ e then s else+                                     cpyTopLvlFun e +                                     $ case loc of+                                          True  -> (if parentIsConstant e then id else addDependency e) +                                                   $ start e s+                                          False -> pause e s++                        -- Span end+                        Cons{} ->  cpyTopLvlFun e +                                   . setLocation e (\_->loc)+                                   $ case loc of +                                       True  -> stop e s+                                       False -> resume e s

@@ -0,0 +1,521 @@+-- This file is part of the Haskell debugger Hoed.+--+-- Copyright (c) Maarten Faddegon, 2014-2015+{-# LANGUAGE CPP #-}++module Debug.Hoed.Pure.DemoGUI+where++import Prelude hiding(Right)+import Debug.Hoed.Pure.Render+import Debug.Hoed.Pure.CompTree+import Debug.Hoed.Pure.EventForest+import Debug.Hoed.Pure.Observe+import Data.Graph.Libgraph+import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny (startGUI,defaultConfig, Window, UI, (#), (#+), (#.), string, on,get,set)+import System.Process(system)+import Data.IORef+import Text.Regex.Posix+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.List(intersperse,nub,sort,sortBy+#if __GLASGOW_HASKELL__ >= 710+                , sortOn+#endif+                )++#if __GLASGOW_HASKELL__ < 710+sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn f  = map snd . sortOn' fst .  map (\x -> (f x, x))++sortOn' :: Ord b => (a -> b) -> [a] -> [a]+sortOn' f = sortBy (\x y -> compare (f x) (f y))+#endif++--------------------------------------------------------------------------------+-- The tabbed layout from which we select the different views++guiMain :: Trace -> TraceInfo -> IORef CompTree ->  EventForest -> Window -> UI ()+guiMain trace traceInfo treeRef frt window+  = do return window # set UI.title "Hoed debugging session"++       -- Get a list of vertices from the computation graph+       tree <- UI.liftIO $ readIORef treeRef+       let ns = filter (not . isRootVertex) (preorder tree)++       -- Shared memory+       filteredVerticesRef <- UI.liftIO $ newIORef ns+       currentVertexRef    <- UI.liftIO $ newIORef (vertexUID . head $ ns)+       regexRef            <- UI.liftIO $ newIORef ""+       imgCountRef         <- UI.liftIO $ newIORef (0 :: Int)++       -- Tabs to select which pane to display+       tab1 <- UI.button # set UI.text "Help"                  # set UI.style activeTab+       tab2 <- UI.button # set UI.text "Observe"               # set UI.style otherTab+       tab3 <- UI.button # set UI.text "Algorithmic debugging" # set UI.style otherTab+       tab4 <- UI.button # set UI.text "Events"                # set UI.style otherTab+       tabs <- UI.div    # set UI.style [("background-color","#D3D3D3")]  #+ (map return [tab1,tab2,tab3,tab4])++       let coloActive tab = do mapM_ (\t -> t # set UI.style otherTab) [return tab1,return tab2,return tab3,return tab4]; return tab # set UI.style activeTab++       help <- guiHelp # set UI.style [("margin-top","0.5em")]+       on UI.click tab1 $ \_ -> do+            coloActive tab1+            UI.getBody window # set UI.children [tabs,help]+       on UI.click tab2 $ \_ -> do+            coloActive tab2+            pane <- guiObserve treeRef currentVertexRef # set UI.style [("margin-top","0.5em")]+            UI.getBody window # set UI.children [tabs,pane]+       on UI.click tab3 $ \_ -> do+            coloActive tab3+            pane <- guiAlgoDeb treeRef filteredVerticesRef currentVertexRef regexRef imgCountRef # set UI.style [("margin-top","0.5em")]+            UI.getBody window # set UI.children [tabs,pane]+       on UI.click tab4 $ \_ -> do+         coloActive tab4+         pane <- guiTrace trace traceInfo # set UI.style [("margin-top","0.5em")]+         UI.getBody window # set UI.children [tabs,pane]++       UI.getBody window # set UI.style [("margin","0")] #+ (map return [tabs,help])+       return ()+++activeTab = ("background-color", "white") : tabstyle+otherTab  = ("background-color", "#f0f0f0") : tabstyle+tabstyle = [("-webkit-border-top-left-radius", "19"), ("-moz-border-top-left-radius", "19"), ("border-top-left-radius", "19px"),("-webkit-border-top-right-radius", "19"), ("-moz-border-top-right-radius", "19"), ("border-top-right-radius", "19px"), ("border-width", "medium medium 0px")]++--------------------------------------------------------------------------------+-- The help/welcome page++guiHelp :: UI UI.Element+guiHelp = UI.div # set UI.style [("margin-left", "20%"),("margin-right", "20%")] #+ +  [ UI.h1 # set UI.text "Welcome to Hoed"+  , UI.p # set UI.text "Hoed is a tracer and debugger for the language Haskell. You can trace a program by annotating functions in suspected modules. After running the program the trace can be viewed in different ways using a web browser. Use the tabs at the top of this page to select the view you want to use. Below we give a short explenation of each view."+  , UI.h2 # set UI.text "Observe"+  , UI.p # set UI.text "The observe view is useful to get a first impression of what is happening in your program, or to get an overview of the computation statements of a particular slice or pattern. At the top the list of slices and for each slice how many times it was reduced. Below the line a list of computation statements."+  , UI.h2 # set UI.text "Algorithmic Debugging"+  , UI.p # set UI.text "The trace is translated into a tree of computation statements for the algorithmic debugging view. You can freely browse this tree to get a better understanding of your program. If your program misbehaves, you can judge the computation statements in the tree as right or wrong according to your intention. When enough statements are judged the debugger tells you the location of the fault in your code."+  ] +++--------------------------------------------------------------------------------+-- The page showing the list of events in the trace++guiTrace :: Trace -> TraceInfo -> UI UI.Element+guiTrace trace traceInfo = do+  rows <- mapM (\e -> eventRow e traceInfo) (reverse trace)+  tbl  <- UI.table #+ map return rows+  UI.span #+ [return tbl]++eventRow :: Event -> TraceInfo -> UI UI.Element+eventRow e traceInfo = do+  sign <- UI.td # set UI.text (let sym = case getLocation e traceInfo of True  -> "* "; False -> "o "+                               in case change e of+                                    Observe{} -> " "+                                    Fun{}     -> " "+                                    Enter{}   -> sym+                                    Cons{}    -> sym)+  evnt <- UI.td # set UI.text (show e)+  msg <- UI.td # set UI.text (getMessage e traceInfo)+  UI.tr #+ map return [sign,evnt,msg]++getStk :: Event -> TraceInfo -> String+getStk e traceInfo = case change e of+  Enter{}  -> case IntMap.lookup (eventUID e) (storedStack traceInfo) of +              (Just stk) -> show stk+              Nothing    -> ""+  _        -> ""+++--------------------------------------------------------------------------------+-- The observe GUI++guiObserve :: IORef CompTree -> IORef Int -> UI UI.Element+guiObserve treeRef currentVertexRef = do+       (Graph _ vs _) <- UI.liftIO $ readIORef treeRef++       -- Alphabetical sorted list of slices, and for each slice how many computation statements+       -- there are for that slice+       let slices' = sort $ map (stmtLabel . vertexStmt) . filter (not . isRootVertex) $ vs+           slices  = nub slices'+           count slice = length (filter (==slice) slices')+           span s = UI.span # set UI.text s # set UI.style [("margin-right","1em")]+           spans = map (\(c,lbl) -> span $ show c ++ " " ++ lbl) $ zip (map count slices) slices+       div1 <- UI.div #+ spans++       -- Alphabetical sorted list of computation statements+       let vs_sorted = sortOn (stmtRes . vertexStmt) . filter (not . isRootVertex) $ vs+       div3 <- UI.form # set UI.style [("margin-left","2em")]+       updateRegEx currentVertexRef vs_sorted div3 "" -- with empty regex to fill div3 1st time++       -- The regexp filter+       matchField  <- UI.input+       on UI.valueChange matchField (updateRegEx currentVertexRef vs_sorted div3)+       div2 <- UI.div # set UI.style [("float","right")] # set UI.text "filter " #+ [return matchField]++       hr <- UI.hr+       UI.div  #+ map return [div1,hr,div2,div3]++updateRegEx :: IORef Int -> [Vertex] -> UI.Element -> String -> UI ()+updateRegEx currentVertexRef vs stmtDiv r = draw++  where draw = do (return stmtDiv) # set UI.children [] #+ csDivs; return ()++        vs_filtered = if r == "" then vs else filter (\v -> (stmtRes . vertexStmt) v =~ r) vs+        ss = map (stmtRes . vertexStmt) vs_filtered++        csDivs = map stmtToDiv vs_filtered++        stmtToDiv v = do+          i <- UI.liftIO $ readIORef currentVertexRef+          s <- UI.span # set UI.text (stmtRes . vertexStmt $ v)+          r <- UI.input # set UI.type_ "radio" # set UI.checked (i == vertexUID v)+          on UI.checkedChange r $ \_ -> checked v+          UI.div #+ [return r, return s]++        -- MF TODO: instead of re-drawing it would be prettier to just+        -- read out the old value of currentVertexRef and set the appropriate+        -- radio button's checked property to False.+        checked v = do+          UI.liftIO $ writeIORef currentVertexRef (vertexUID v)+          draw++--------------------------------------------------------------------------------+-- The algorithmic debugging GUI++guiAlgoDeb :: IORef CompTree -> IORef [Vertex] -> IORef Int -> IORef String -> IORef Int -> UI UI.Element+guiAlgoDeb treeRef filteredVerticesRef currentVertexRef regexRef imgCountRef = do++       -- Get a list of vertices from the computation graph+       tree <- UI.liftIO $ readIORef treeRef+       let ns = filter (not . isRootVertex) (preorder tree)++       -- Draw the computation graph+       img  <- UI.img +       redrawWith img imgCountRef treeRef filteredVerticesRef currentVertexRef+       img' <- UI.center #+ [UI.element img]++       -- Field to show computation statement(s) of current vertex+       compStmt <- UI.pre++       -- Menu to select which statement to show+       menu <- UI.select+       showStmt compStmt filteredVerticesRef currentVertexRef+       updateMenu menu treeRef currentVertexRef filteredVerticesRef+       let selectVertex' = selectVertex compStmt filteredVerticesRef currentVertexRef (redrawWith img imgCountRef treeRef)+       on UI.selectionChange menu selectVertex'++       -- Buttons for the various filters+       filterTxt    <- UI.span   # set UI.text "Filters: "+       showAllBut   <- UI.button # set UI.text "Show all"+       showSuccBut  <- UI.button # set UI.text "Show successors"+       showPredBut  <- UI.button # set UI.text "Show predecessors"+       showMatchBut <- UI.button # set UI.text "Matches "+       matchField   <- UI.input+       filters      <- UI.div #+ (map return [ filterTxt, showAllBut, showSuccBut, showPredBut+                                             , showMatchBut, matchField])++       on UI.valueChange matchField $ \s -> UI.liftIO $ writeIORef regexRef s+       let onClickFilter' = onClickFilter menu treeRef currentVertexRef filteredVerticesRef+                                          selectVertex' regexRef+       onClickFilter' showAllBut   ShowAll+       onClickFilter' showSuccBut  ShowSucc+       onClickFilter' showPredBut  ShowPred+       onClickFilter' showMatchBut ShowMatch++       -- Status+       status <- UI.span+       updateStatus status treeRef ++       -- Buttons to judge the current statement+       right <- UI.button # set UI.text "right"+       wrong <- UI.button # set UI.text "wrong"+       let onJudge = onClick status menu img imgCountRef treeRef +                             currentVertexRef filteredVerticesRef+       onJudge right Right+       onJudge wrong Wrong++       -- Populate the main screen+       hr <- UI.hr+       UI.div #+ (map UI.element [filters, menu, right, wrong, status, compStmt, hr,img'])+++preorder :: CompTree -> [Vertex]+preorder = getPreorder . getDfs++showStmt :: UI.Element -> IORef [Vertex] -> IORef Int -> UI ()+showStmt e filteredVerticesRef currentVertexRef = do +  mv <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef+  let s = case mv of+                Nothing  -> "Select vertex above to show details."+                (Just v) -> show . vertexStmt $ v+  UI.element e # set UI.text s+  return ()++data Filter = ShowAll | ShowSucc | ShowPred | ShowMatch++updateMenu :: UI.Element -> IORef CompTree+              -> IORef Int -> IORef [Vertex] -> UI ()+updateMenu menu treeRef currentVertexRef filteredVerticesRef = do+       g  <- UI.liftIO $ readIORef treeRef+       vs <- UI.liftIO $ readIORef filteredVerticesRef+       i  <- UI.liftIO $ readIORef currentVertexRef+       let j = pos (\v -> vertexUID v == i) vs+       let fs = faultyVertices g+       ops  <- mapM (\s->UI.option # set UI.text s)+                                $ if vs == [] then ["No matches found"]+                                  else map (summarizeVertex fs) vs+       (UI.element menu) # set UI.children []+       UI.element menu #+ (map UI.element ops)+       (UI.element menu) # set UI.selection (Just j)+       return ()++pos :: (a->Bool) -> [a] -> Int+pos p xs = case filter (\(_,x) -> p x) $ zip [0..] xs of +                []        -> -1+                ((i,_):_) -> i++vertexFilter :: Filter -> CompTree -> Vertex -> String -> [Vertex]+vertexFilter f g cv r = filter (not . isRootVertex) $ case f of +  ShowAll   -> preorder g+  ShowSucc  -> succs g cv+  ShowPred  -> preds g cv+  ShowMatch -> filter matches (preorder g)+    where matches RootVertex = False+          matches v    = show v =~ r++onClick :: UI.Element -> UI.Element -> UI.Element +           -> IORef Int-> IORef CompTree -> IORef Int -> IORef [Vertex]+           -> UI.Element -> Judgement-> UI ()+onClick status menu img imgCountRef treeRef currentVertexRef filteredVerticesRef b j = do+  on UI.click b $ \_ -> do+        (Just v) <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef+        replaceFilteredVertex v (v{vertexJmt=j})+        updateTree img imgCountRef treeRef (Just v) (\tree -> markNode tree v j)+        updateMenu menu treeRef currentVertexRef filteredVerticesRef+        updateStatus status treeRef++  where replaceFilteredVertex v w = do+          vs <- UI.liftIO $ readIORef filteredVerticesRef+          UI.liftIO $ writeIORef filteredVerticesRef $ map (\x -> if x == v then w else x) vs++lookupCurrentVertex :: IORef Int -> IORef [Vertex] -> IO (Maybe Vertex)+lookupCurrentVertex currentVertexRef filteredVerticesRef = do+  i  <- readIORef currentVertexRef+  vs <- readIORef filteredVerticesRef+  return $ case filter (\v->vertexUID v==i) vs of+                 []  -> Nothing+                 [v] -> Just v+                 vs   -> error $ "lookupCurrentVertex: UID " ++ show i ++ " identifies "+                                 ++ (show . length $ vs) ++ " computation statements"++selectVertex :: UI.Element -> IORef [Vertex] -> IORef Int  +        -> (IORef [Vertex] -> IORef Int -> UI ()) -> Maybe Int -> UI ()+selectVertex compStmt filteredVerticesRef currentVertexRef myRedraw mi = case mi of+        Just i  -> do vs <- UI.liftIO $ readIORef filteredVerticesRef+                      let v = vs !! i+                      UI.liftIO $ writeIORef currentVertexRef (vertexUID v)+                      showStmt compStmt filteredVerticesRef currentVertexRef+                      myRedraw filteredVerticesRef currentVertexRef +                      return ()+        Nothing -> return ()+++onClickFilter :: UI.Element -> IORef CompTree -> IORef Int -> IORef [Vertex] +                  -> (Maybe Int -> UI ()) -> IORef String -> UI.Element -> Filter -> UI ()+onClickFilter menu treeRef currentVertexRef filteredVerticesRef selectVertex' regexRef e fil = do+  on UI.click e $ \_ -> do+    mcv <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef+    g <- UI.liftIO $ readIORef treeRef+    r <- UI.liftIO $ readIORef regexRef+    let cv = case mcv of (Just v) -> v+                         Nothing  -> head . (filter $ not . isRootVertex) . preorder $ g+        applyFilter f = do UI.liftIO $ writeIORef filteredVerticesRef (vertexFilter f g cv r)+                           UI.liftIO $ writeIORef currentVertexRef 0+    applyFilter fil+    updateMenu menu treeRef currentVertexRef filteredVerticesRef+    selectVertex' (Just 0)++-- MF TODO: We may need to reconsider how Vertex is defined,+-- and how we determine equality. I think it could happen that+-- two vertices with equal equation but different stacks/relations+-- are now both changed.+markNode :: CompTree -> Vertex -> Judgement -> CompTree+markNode g v s = mapGraph f g+  where f RootVertex = RootVertex+        f v'         = if v' === v then v{vertexJmt=s} else v'++        (===) :: Vertex -> Vertex -> Bool+        v1 === v2 = (vertexStmt v1) == (vertexStmt v2)++data MaxStringLength = ShorterThan Int | Unlimited++shorten :: MaxStringLength -> String -> String+shorten Unlimited s = s+shorten (ShorterThan l) s+          | length s < l = s+          | l > 3        = take (l - 3) s ++ "..."+          | otherwise    = take l s++-- MF TODO: Maybe we should do something smart with witespace substitution here?+noNewlines :: String -> String+noNewlines = filter (/= '\n')++summarizeVertex :: [Vertex] -> Vertex -> String+-- summarizeVertex fs v = shorten (ShorterThan 27) (noNewlines . show . vertexStmt $ v) ++ s+summarizeVertex fs v = (noNewlines . show . vertexStmt $ v) ++ s+  where s = if v `elem` fs then " !!" else case vertexJmt v of+              Unassessed     -> " ??"+              Wrong          -> " :("+              Right          -> " :)"++updateStatus :: UI.Element -> IORef CompTree -> UI ()+updateStatus e compGraphRef = do+  g <- UI.liftIO $ readIORef compGraphRef+  let getLabel   = stmtLabel . vertexStmt+      isJudged v = vertexJmt v /= Unassessed+      slen       = show . length+      ns = filter (not . isRootVertex) (preorder g)+      js = filter isJudged ns+      fs = faultyVertices g+      txt = if length fs > 0 then " Fault detected in: " ++ getLabel (head fs)+                             else " Judged " ++ slen js ++ "/" ++ slen ns+  UI.element e # set UI.text txt+  return ()++updateTree :: UI.Element -> IORef Int -> IORef CompTree -> (Maybe Vertex) -> (CompTree -> CompTree)+           -> UI ()+updateTree img imgCountRef treeRef mcv f+  = do tree <- UI.liftIO $ readIORef treeRef+       UI.liftIO $ writeIORef treeRef (f tree)+       redraw img imgCountRef treeRef mcv++redrawWith :: UI.Element -> IORef Int -> IORef CompTree -> IORef [Vertex] -> IORef Int -> UI ()+redrawWith img imgCountRef treeRef filteredVerticesRef currentVertexRef = do+  mv <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef+  redraw img imgCountRef treeRef mv++redraw :: UI.Element -> IORef Int -> IORef CompTree -> (Maybe Vertex) -> UI ()+redraw img imgCountRef treeRef mcv+  = do tree <- UI.liftIO $ readIORef treeRef+       -- replace with the following line to "summarize" big trees  by+       -- dropping some nodes+       --UI.liftIO $ writeFile ".Hoed/debugTree.dot" (shw $ summarize tree mcv)+       UI.liftIO $ writeFile ".Hoed/debugTree.dot" (shw tree)+       UI.liftIO $ system $ "dot -Tpng -Gsize=9,5 -Gdpi=100 .Hoed/debugTree.dot "+                          ++ "> .Hoed/wwwroot/debugTree.png"+       i <- UI.liftIO $ readIORef imgCountRef+       UI.liftIO $ writeIORef imgCountRef (i+1)+       -- Attach counter to image url to reload image+       UI.element img # set UI.src ("static/debugTree.png#" ++ show i)+       return ()++  where shw g = showWith g (coloVertex $ faultyVertices g) showArc+        coloVertex fs v = ( "\"" ++ (show . vertexUID) v ++ ": "+                            ++ summarizeVertex fs v ++ "\""+                          , if isCurrentVertex mcv v then "style=filled fillcolor=yellow"+                                                     else ""+                          )+        showArc _  = ""++-- MF TODO: summarize now just "throws away" some vertices if there are too+-- many. Better would be to inject summarizing nodes (e.g. "and 25 more").+{-+summarize :: CompTree -> Maybe Vertex -> CompTree+summarize g mcv = Graph (root g) keep as+  where keep1 v = take 7 $ succs g v+        keep'   = nub $ RootVertex : foldl (\ks v -> ks ++ keep1 v) [] (vertices g)+        keep    = case filter (isCurrentVertex mcv) (vertices g) of+                        []    -> keep'+                        (w:_) -> if w `elem` keep' then keep' else w : keep+        as      = filter (\(Arc v w _) -> v `elem` keep && w `elem` keep) (arcs g)+-}++isCurrentVertex :: Maybe Vertex -> Vertex -> Bool+isCurrentVertex mcv v = case v of+  RootVertex -> False+  _    -> case mcv of +                Nothing           -> False+                (Just RootVertex) -> False+                (Just w)          -> vertexStmt v == vertexStmt w++faultyVertices :: CompTree -> [Vertex]+faultyVertices = findFaulty_dag getStatus+  where getStatus RootVertex = Right+        getStatus v    = vertexJmt v+++--------------------------------------------------------------------------------+-- The data flow GUI+{-+guiDDT :: ConstantTree -> IORef Int -> EventForest -> IORef Int -> IORef CompTree -> UI UI.Element+guiDDT ddt imgCountRef frt currentVertexRef treeRef = do+  (Graph _ vs _) <- UI.liftIO $ readIORef treeRef+  let idStmts = map (\(Vertex s _) -> (equIdentifier s, s)) . filter (not . isRootVertex) $ vs++  -- The current computation statement+  i  <- UI.liftIO $ readIORef currentVertexRef+  stmtDiv <- UI.div # set UI.text (case lookup i idStmts of +        Nothing  -> "?"+        (Just s) -> equRes s)++  -- Menu to select constant (floating on the right of the page) +  let (Graph _ cs _) = ddt+      cs_i = filter (\c -> case c of CVRoot -> False; _ -> valStmt c == i) cs+  cSel   <- UI.select #+ map (\c -> UI.option # set UI.text (shwConst c)) cs_i+  shwBut <- UI.button # set UI.text "Show me"+  selDiv <- UI.div # set UI.style [("float","right")] #+ [return shwBut, UI.span # set UI.text " where ", return cSel, UI.span # set UI.text " comes from."]++  -- The dynamic data dependency tree+  img <- UI.img+  drawDDT ddt img imgCountRef frt+  centImg <- UI.center #+ [UI.element img]++  UI.div #+ [return selDiv, return stmtDiv, UI.hr, return centImg]++  where shwConst c = shwLoc c ++ "\"" ++ (case lookup (valMax c) es of (Just e) -> render frt e; Nothing -> "?") ++ "\""+        shwLoc c = case (show . valLoc) c of "" -> ""; s -> s ++ ": "+        es = eventsByUID frt++updateStmt :: UI.Element -> IORef Int -> [CompStmt] -> Int -> UI ()+updateStmt stmtDiv currentVertexRef ss pos = do+  let s = ss !! pos+  return stmtDiv # set UI.text (equRes s)+  UI.liftIO $ writeIORef currentVertexRef (equIdentifier s)++drawDDT :: ConstantTree -> UI.Element -> IORef Int -> EventForest -> UI ()+drawDDT ddt img imgCountRef frt = do+  UI.liftIO $ writeFile ".Hoed/dynData.dot" (shw ddt)+  UI.liftIO $ system $ "dot -Tpng -Gsize=9,9 -Gdpi=100 .Hoed/dynData.dot > .Hoed/wwwroot/dynData.png"+  i <- UI.liftIO $ readIORef imgCountRef+  UI.liftIO $ writeIORef imgCountRef (i+1)+  UI.element img # set UI.src ("static/dynData.png#" ++ show i)+  return ()++  where shw g = showWith g shwConst shwArc+        shwConst c = ("Stmt-"++ (show . valStmt) c ++ "-" ++ (show . valLoc) c ++ ": " ++ case lookup (valMax c) es of (Just e) -> render frt e; Nothing -> "?","")+        shwArc _   = ""+        es = eventsByUID frt++eventsByUID :: EventForest -> [(UID,Event)]+-- eventsByUID = map (\e -> (eventUID e, e)) . foldl (\acc1 (_,es_p) -> foldl (\acc2 (_,e) -> e : acc2) acc1 es_p) []+eventsByUID = map (\e -> (eventUID e, e)) . map snd . concat . elems++render :: EventForest -> Event -> String+render frt r = dfsFold Infix pre post "" Trunk (Just r) frt+  where pre Nothing  _ = (++" _")+        pre (Just e) _ = case change e of+          (Observe s _ _ _) -> (++s)+          (Cons _ s)        -> (++" ("++s)+          Enter             -> id+          NoEnter           -> id+          Fun               -> (++"{\\")+        post Nothing  _ = id+        post (Just e) _ = case change e of+          (Observe s _ _ _) -> id+          (Cons _ s)        -> (++")")+          Enter             -> id+          NoEnter           -> id+          Fun               -> (++"}")++-}

@@ -0,0 +1,163 @@+-- This file is part of the Haskell debugger Hoed.+--+-- Copyright (c) Maarten Faddegon, 2015++module Debug.Hoed.Pure.EventForest +( EventForest(..)+, mkEventForest+, parentUIDLookup+, parentPosLookup++, InfixOrPrefix(..)+, Location(..)+, Visit+, dfsFold+, idVisit++, treeUIDs+, topLevelApps+, eventsInTree+, dfsChildren+, elems+) where+import Debug.Hoed.Pure.Observe+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap++-- Searchable mapping from UID of the parent and position in list of siblings+-- to a child event.+-- type EventForest = [(UID, [(ParentPosition, Event)])]+type EventForest = IntMap [(ParentPosition, Event)]++isRoot :: Event -> Bool+isRoot e = case change e of Observe{} -> True; _ -> False++elems :: EventForest -> [[(ParentPosition, Event)]]+elems = IntMap.elems++addEvent :: EventForest -> Event -> EventForest+addEvent frt e+  | isRoot e  = frt+  | otherwise = IntMap.insert i s frt+  where i  = parentUID . eventParent $ e+        p  = parentPosition . eventParent $ e+        ms = IntMap.lookup i frt+        s  = case ms of Nothing   -> [(p,e)]+                        (Just s') -> (p,e) : s'+++mkEventForest :: Trace -> EventForest+mkEventForest trc = foldl addEvent IntMap.empty trc++parentUIDLookup :: UID -> EventForest  -> [(ParentPosition,Event)]+parentUIDLookup i frt = case IntMap.lookup i frt of+  Nothing   -> []+  (Just es) -> es++parentPosLookup :: ParentPosition -> [(ParentPosition,Event)] -> [Event]+parentPosLookup p = map snd . filter ((==p) . fst)+++data InfixOrPrefix = Infix | Prefix++data Location = Trunk | ArgumentOf Location | ResultOf Location | FieldOf Int Location+  deriving Eq++instance Show Location where +   show Trunk            = ""+   show (ArgumentOf loc) = 'a' : show loc+   show (ResultOf   loc) = 'r' : show loc+   show (FieldOf n  loc) = 'f' : show n ++ show loc++data ArgOrRes = Arg | Res++-- Is the first location in the argument, or result subtree of the second location?+argOrRes :: Location -> Location -> ArgOrRes+argOrRes (ArgumentOf loc') loc = if loc == loc' then Arg else argOrRes loc' loc+argOrRes (ResultOf loc')   loc = if loc == loc' then Res else argOrRes loc' loc+argOrRes Trunk             _   = error $ "argOrRes: Second location is not on the path"+                                       ++ "between root and the first location."++type Visit a = Maybe Event -> Location -> a -> a++idVisit :: Visit a+idVisit _ _ z = z++++-- Given an event, return the list of (expected) children in depth-first order.+--+-- Nothing indicates that we expect an event (e.g. the argument of an application-+-- event) but it was not there.+--+-- An abstraction (LamEvent) can have more than one application. There is no+-- particular ordering and we just return the applications (AppEvents) in the+-- order we find them in the trace (i.e. evaluation order).++dfsChildren :: EventForest -> Event -> [Maybe Event]+dfsChildren frt e = case change e of+    Enter{}              -> manyByPosition 0 -- Should be Nothing?+    (Cons l _)           -> foldl (\acc x -> acc ++ manyByPosition x) [] [0..(l-1)]+    Observe{}            -> manyByPosition 0+    Fun                  -> manyByPosition 0 ++ manyByPosition 1++  where -- Find list of events by position+        byPosition :: [ParentPosition] -> [Maybe Event]+        byPosition = map (\pos -> lookup pos cs)++        manyByPosition :: ParentPosition -> [Maybe Event]+        manyByPosition pos = case filter (\(pos',_) -> pos == pos') cs of+          [] -> [Nothing]+          ts -> map (Just . snd) ts++        -- Events in the frt that list our event as parent (in no particular order).+        cs :: [(ParentPosition,Event)]+        cs = parentUIDLookup (eventUID e) frt++        +dfsFold :: InfixOrPrefix -> Visit a -> Visit a -> a +        -> Location -> (Maybe Event) -> EventForest -> a++dfsFold ip pre post z loc me frt +  = post me loc $ case me of+      Nothing -> z'+      (Just e) -> case change e of++        Fun -> let [arg,res] = cs+          in case ip of+            Prefix -> csFold $ zip cs [ArgumentOf loc,ArgumentOf loc,ResultOf loc,ResultOf loc]++            Infix  -> let z1 = dfsFold ip pre post z (ArgumentOf loc) arg frt+                          z2 = pre me loc z1+                      in  dfsFold ip pre post z2 (ResultOf loc) res frt++        Cons{} -> csFold $ zip cs $ map (\i -> FieldOf i loc) [1..]++        _ -> csFold $ zip cs (repeat loc)++  where z'  = pre me loc z++        cs :: [Maybe Event]+        cs = case me of (Just e) -> dfsChildren frt e; Nothing -> error "dfsFold filter failed"++        csFold = foldl (\z'' (c,loc') -> dfsFold ip pre post z'' loc' c frt) z'++treeUIDs :: EventForest -> Event -> [UID]+treeUIDs frt = (map eventUID) . eventsInTree frt++-- Given an event r, return depth first ordered list of events in the (sub)tree starting from r.+eventsInTree :: EventForest -> Event -> [Event]+eventsInTree frt r = reverse $ dfsFold Prefix add idVisit [] Trunk (Just r) frt+  where add (Just e) _ es = e : es+        add Nothing  _ es = es++-- Find all toplevel AppEvents for RootEvent r+topLevelApps :: EventForest -> Event -> [Event]+topLevelApps frt r = foldl appendApp []  $ dfsChildren frt r++appendApp :: [Event] -> Maybe Event -> [Event]+appendApp z me = case me of+  Nothing  -> z+  (Just e) -> case change e of Fun -> e : z+                               _   -> z+  

@@ -0,0 +1,1190 @@+\begin{code}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE CPP #-}++\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.Pure.Observe+  (+   -- * The main Hood API+  +    observeTempl+  , observe+  , observeCC+  , Observer(..)   -- contains a 'forall' typed observe (if supported).+  -- , Observing      -- a -> a+  , Observable(..) -- Class++   -- * For advanced users, that want to render their own datatypes.+  , (<<)           -- (Observable a) => ObserverM (a -> b) -> a -> ObserverM b+  , thunk          -- (Observable a) => a -> ObserverM a        +  , nothunk+  , send+  , observeBase+  , observeOpaque+  , observedTypes+  , Generic+  , Trace+  , Event(..)+  , Change(..)+  , Parent(..)+  , UID+  , ParentPosition+  , ThreadId(..)+  , isRootEvent+  , initUniq+  , startEventStream+  , endEventStream+  , ourCatchAllIO+  , peepUniq+  ) 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}++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(..))+{-+ ( catch+                , Exception(..)+                , throw+                ) as Exception+-}+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}++-- shallowShow :: Constructor c => t c (f :: * -> *) a -> [Char]+-- shallowShow = conName++\end{code}++Observing the children of Data types of kind *.++\begin{code}++-- Meta: data types+instance (GObservable a) => GObservable (M1 D d a) where+        gdmobserver m@(M1 x) cxt = M1 (gdmobserver x cxt)+        gdmObserveChildren = gthunk+        gdmShallowShow = error "gdmShallowShow not defined on <<Meta: data types>>"++-- Meta: Selectors+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      = error "gdmShallowShow not defined on <<Meta: selectors>>"++-- Meta: Constructors+instance (GObservable a, Constructor c) => GObservable (M1 C c a) where+        gdmobserver m1            = send (gdmShallowShow m1) (gdmObserveChildren m1)+        gdmObserveChildren (M1 x) = do {x' <- gdmObserveChildren x; return (M1 x')}+        gdmShallowShow            = conName++-- Unit: used for constructors without arguments+instance GObservable U1 where+        gdmobserver x _    = x+        gdmObserveChildren = return+        gdmShallowShow     = error "gdmShallowShow not defined on <<the unit type>>"++-- Sums: encode choice between constructors+instance (GObservable a, GObservable b) => GObservable (a :+: b) where+        gdmobserver (L1 x) = send (gdmShallowShow x) (gdmObserveChildren $ L1 x)+        gdmobserver (R1 x) = send (gdmShallowShow x) (gdmObserveChildren $ R1 x)+        gdmShallowShow (L1 x) = gdmShallowShow x+        gdmShallowShow (R1 x) = gdmShallowShow x+        gdmObserveChildren (L1 x) = do {x' <- gdmObserveChildren x; return (L1 x')}+        gdmObserveChildren (R1 x) = do {x' <- gdmObserveChildren x; return (R1 x')}++-- Products: encode multiple arguments to constructors+instance (GObservable a, GObservable b) => GObservable (a :*: b) where+        gdmobserver (a :*: b) cxt = (gdmobserver a cxt) :*: (gdmobserver b cxt)+        gdmObserveChildren (a :*: b) = do a'  <- gdmObserveChildren a+                                          b'  <- gdmObserveChildren b+                                          return (a' :*: b')+        gdmShallowShow = error "gdmShallowShow not defined on <<the product type>>"++-- Constants: additional parameters and recursion of kind *+instance (Observable a) => GObservable (K1 i a) where+        gdmobserver (K1 x) cxt = K1 $ observer x cxt+        gdmObserveChildren = gthunk+        gdmShallowShow = error "gdmShallowShow not defined on <<constant types>>"+\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+        = sendObserveFnPacket+            (do arg' <- thunk observer arg+                thunk observer (fn arg')+            ) cxt+\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 $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)+                        -- li <- (gListObserver s) MF TODO: should we do away with these?+                        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")) []++gobserverList :: Q Name -> Q [Dec]+gobserverList qn = do n  <- qn+                      cs <-listClauses qn+                      return [FunD n cs]+++\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)++listClauses :: Q Name -> Q [Clause]+listClauses n = do l1 <- listClause1 n +                   l2 <- listClause2 n +                   return [l1, l2]++-- observer (a:as) = send ":"  (return (:) << a << as)+listClause1 :: Q Name -> Q Clause+listClause1 qn+  = do { n <- qn+       ; let a'    = varP (mkName "a")+             a     = varE (mkName "a")+             as'   = varP (mkName "as")+             as    = varE (mkName "as") +             c'    = varP (mkName "c")+             c     = varE (mkName "c")+             t     = [| thunk $(varE n)|] -- MF TODO: or nothunk+             name  = mkName ":"+       ; clause [infixP a' name as', c']+           ( normalB [| send ":" ( compositionM $t+                                   ( compositionM $t+                                     ( return (:)+                                     ) $a+                                   ) $as+                                 ) $c+                     |]+           ) []+       }++-- observer []     = send "[]" (return [])+listClause2 :: Q Name -> Q Clause+listClause2 qn+  = do { n <- qn+       ; let c'    = varP (mkName "c")+             c     = varE (mkName "c")+       ; clause [wildP, c']+           ( normalB [| send "[]" (return []) $c |]+           ) []+       }++\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) -- 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+#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]++gobservableListInstance :: String -> Q [Dec]+gobservableListInstance s+  = do let qt = [t|forall a . [] a |]+       t  <- qt+       cn <- className s+       let ct = conT cn+       n  <- case t of+            (ForallT tvs _ t') -> [t| $ct $(return t') |]+            _                  -> [t| $ct $qt          |]+       m  <- gobserverList (methodName s)+       c  <- case t of +                (ForallT _ c' _)   -> return c'+                _                  -> return []+       return [InstanceD c n m]++-- MF TODO: what do we do with this?+-- gListObserver :: String -> Q [Dec]+-- gListObserver s+--   = do cn <- className s+--        let ct = conT cn+--            a  = VarT (mkName "a")+--            a' = return a+--        c <- return [ClassP cn a']+--        n <- [t| $ct [$a'] |]+--        m <- gobserverList (methodName s)+--        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 [| sendObserveFnPacket+                       ( do a' <- thunk $(varE n) $a+                            thunk $(varE n) ($f a')+                       ) $c+                  |]+         ) []+       }++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+-- MF TODO: if s == t then return True else isObservable' bs t+isObservable bs s t = isObservable' bs t++-- MF TODO this is a hack+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' bs (AppT t _)    = isObservable' bs t+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}++-- A mapping from typevars to the type they are bound to.++type TyVarMap = (Name, [(TyVarBndr,TypeOrPred)])++data TypeOrPred = T Type | P Pred+++-- MF TODO lookupBinding++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++-- Given a parametrized type, get a list with typevars and their bindings+-- e.g. [(a,Int), (b,Float)] in (MyData a b) Int Float++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++-- Given a parametrized type, get a list with its type variables+-- e.g. [a,b] in (MyData a b) Int Float++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)++-- Given a parametrized type, get a list with the bindings of type variables+-- e.g. [Int,Float] in (MyData a b) Int Float++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' _          = []++-- Given a parametrized type, get the name of the type constructor (e.g. Tree in Tree Int)++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'')++-- Given a type, get a list of type variables.++getTvs :: Q Type -> Q [TyVarBndr]+getTvs t = do {(ForallT tvs _ _) <- t; return tvs }++-- Given a type, get a list of constructors.++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")++observableCxt :: [TyVarBndr] -> Q Cxt+observableCxt tvs = return [classpObservable $ map (\v -> (tvname v)) tvs]++#if __GLASGOW_HASKELL__ >= 710+classpObservable :: [Type] -> Type+classpObservable = foldl AppT (ConT (mkName "Observable"))+#else+classpObservable :: [Type] -> Pred+classpObservable = ClassP (mkName "Observable")+#endif++qcontObservable :: Q Type+qcontObservable = return contObservable++contObservable :: Type+contObservable = ConT (mkName "Observable")++qtvname :: TyVarBndr -> Q Type+qtvname = return . tvname++tvname :: TyVarBndr -> Type+tvname (PlainTV  name  ) = VarT name+tvname (KindedTV name _) = VarT name++\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 "()" }++-- utilities for base types.+-- The strictness (by using seq) is the same +-- as the pattern matching done on other constructors.+-- we evalute to WHNF, and not further.++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 ErrorCall where+--   observer (ErrorCall a)        = send "ErrorCall"   (return ErrorCall << a)+++instance Observable Dynamic where { observer = observeOpaque "<Dynamic>" }+\end{code}+++%************************************************************************+%*                                                                      *+\subsection{Classes and Data Definitions}+%*                                                                      *+%************************************************************************++MF: why/when do we need these types?+\begin{code}+type Observing a = a -> a++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+                                { parentUID = parent+                                , parentPosition   = port+                                }) +                , port+1 )++gthunk :: (GObservable f) => f a -> ObserverM (f a)+gthunk a = ObserverM $ \ parent port ->+                ( gdmobserver_ a (Parent+                                { parentUID = parent+                                , parentPosition   = port+                                }) +                , port+1 )++nothunk :: a -> ObserverM a+nothunk a = ObserverM $ \ parent port ->+                ( observer__ a (Parent+                                { parentUID = parent+                                , parentPosition   = port+                                }) +                , port+1 )+++(<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b+-- fn << a = do { fn' <- fn ; a' <- thunk a ; return (fn' a') }+fn << a = gdMapM (thunk observer) fn a++gdMapM :: (Monad m)+        => (a -> m a)  -- f+        -> m (a -> b)  -- data constructor+        -> a           -- argument+        -> m b         -- data+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}+-- | 'observe' observes data structures in flight.+--  +-- An example of use is +--  @+--    map (+1) . observe \"intermeduate\" . map (+2)+--  @+--+-- In this example, we observe the value that flows from the producer+-- @map (+2)@ to the consumer @map (+1)@.+-- +-- 'observe' can also observe functions as well a structural values.+-- +{-# NOINLINE gobserve #-}+gobserve :: (a->Parent->a) -> TraceThreadId -> String -> a -> (a,Int)+gobserve f tti name a = generateContext f tti name a++{- | +Functions which you suspect of misbehaving are annotated with observe and+should have a cost centre set. The name of the function, the label of the cost+centre and the label given to observe need to be the same.++Consider the following function:++@triple x = x + x@++This function is annotated as follows:++> triple y = (observe "triple" (\x -> {# SCC "triple" #}  x + x)) y++To produce computation statements like:++@triple 3 = 6@++To observe a value its type needs to be of class Observable.+We provided instances for many types already.+If you have defined your own type, and want to observe a function+that takes a value of this type as argument or returns a value of this type,+an Observable instance can be derived as follows:++@  +  data MyType = MyNumber Int | MyName String deriving Generic++  instance Observable MyType+@+-}+{-# NOINLINE observe #-}+observe ::  (Observable a) => String -> a -> a+observe lbl = fst . (gobserve observer DoNotTraceThreadId lbl)++{-# NOINLINE observeCC #-}+observeCC ::  (Observable a) => String -> a -> a+observeCC lbl = fst . (gobserve observer TraceThreadId lbl)++{- This gets called before observer, allowing us to mark+ - we are entering a, before we do case analysis on+ - our object.+ -}++{-# NOINLINE observer_ #-}+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++{-# NOINLINE observer__ #-}+observer__ :: a -> Parent -> a+observer__ a context = sendNoEnterPacket a context++\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 -> String -> a -> (a,Int)+generateContext f tti label orig = unsafeWithUniq $ \node ->+     do { t <- myThreadId+        ; sendEvent node (Parent 0 0) (Observe label t node)+        ; return (observer_ f orig (Parent+                        { parentUID      = node+                        , parentPosition = 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 :: ObserverM a -> Parent -> a+sendObserveFnPacket fn context+  = unsafeWithUniq $ \ node ->+     do { let (r,_) = runMO fn node 0+        ; sendEvent node context Fun+        ; return r+        }+\end{code}+++%************************************************************************+%*                                                                      *+\subsection{Event stream}+%*                                                                      *+%************************************************************************++Trival output functions++\begin{code}+type Trace = [Event]++data Event = Event+                { eventUID     :: !UID      -- my UID+                , eventParent  :: !Parent+                , change       :: !Change+                }+        deriving (Eq)++data Change+        = Observe       !String         !ThreadId        !Int+        | Cons    !Int  !String+        | Enter+        | NoEnter+        | Fun+        deriving (Eq, Show)++type ParentPosition = Int++data Parent = Parent+        { parentUID      :: !UID            -- my parents UID+        , parentPosition :: !ParentPosition -- my branch number (e.g. the field of a data constructor)+        } deriving (Eq)++instance Show Event where+  show e = (show . eventUID $ e) ++ ": " ++ (show . change $ e) ++ " (" ++ (show . eventParent $ e) ++ ")"++instance Show Parent where+  show p = "P " ++ (show . parentUID $ p) ++ " " ++ (show . parentPosition $ p)++root = Parent 0 0++data ThreadId = ThreadIdUnknown | ThreadId Concurrent.ThreadId+        deriving (Show,Eq,Ord)+++isRootEvent :: Event -> Bool+isRootEvent e = case change e of Observe{} -> True; _ -> False++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 ()+           }++-- local+events :: IORef Trace+events = unsafePerformIO $ newIORef badEvents++badEvents :: Trace+badEvents = error "Bad Event Stream"++-- use as a trivial semiphore+{-# NOINLINE sendSem #-}+sendSem :: MVar ()+sendSem = unsafePerformIO $ newMVar ()+-- end local+\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++-- locals+{-# NOINLINE uniq #-}+uniq :: IORef UID+uniq = unsafePerformIO $ newIORef 1++{-# NOINLINE uniqSem #-}+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}++%************************************************************************

@@ -0,0 +1,105 @@+-- This file is part of the Haskell debugger Hoed.+--+-- Copyright (c) Maarten Faddegon, 2015++module Debug.Hoed.Pure.Prop where+-- ( judge+-- , Property(..)+-- ) where++import Debug.Hoed.Pure.Observe(Trace(..),UID,Event(..),Change(..))+import Debug.Hoed.Pure.Render(CompStmt(..))+import Debug.Hoed.Pure.CompTree(Vertex(..))+import Debug.Hoed.Pure.EventForest(EventForest,mkEventForest,dfsChildren)++import Prelude hiding (Right)+import Data.Graph.Libgraph(Judgement(..))+import System.Directory(createDirectoryIfMissing)+import System.Process(system)+import System.Exit(ExitCode(..))++------------------------------------------------------------------------------------------------------------------------++data Property = Property {moduleName :: String, propertyName :: String, searchPath :: String}++sourceFile = ".Hoed/exe/Main.hs"+exeFile    = ".Hoed/exe/Main"+outFile    = ".Hoed/exe/Main.out"++------------------------------------------------------------------------------------------------------------------------++judge' :: ExitCode -> String -> Judgement -> Judgement+judge' (ExitFailure _) _   j = j+judge' ExitSuccess     out j+  | out == "False\n" = Wrong+  | out == "True\n"  = j+  | otherwise     = j++judge :: Trace -> Property -> Vertex -> IO Vertex+judge trc prop v = do+  createDirectoryIfMissing True ".Hoed/exe"+  putStrLn $ "Picked statement identifier = " ++ show i+  generateCode+  compile+  exit' <- compile+  putStrLn $ "Exitted with " ++ show exit'+  exit  <- case exit' of (ExitFailure n) -> return (ExitFailure n)+                         ExitSuccess     -> evaluate+  out  <- readFile outFile+  putStrLn $ "Exitted with " ++ show exit+  putStrLn $ "Output is " ++ show out+  return v{vertexJmt=judge' exit out (vertexJmt v)}++  where generateCode = writeFile sourceFile (generate prop trc i)+        compile      = system $ "ghc -o " ++ exeFile ++ " " ++ sourceFile+        evaluate     = system $ exeFile ++ " &> " ++ outFile+        i            = (stmtIdentifier . vertexStmt) v++------------------------------------------------------------------------------------------------------------------------++generate :: Property -> Trace -> UID -> String+generate prop trc i = generateHeading prop ++ generateMain prop trc i++generateHeading :: Property -> String+generateHeading prop =+  "-- This file is generated by the Haskell debugger Hoed\n"+  ++ "import " ++ moduleName prop ++ "\n"++generateMain :: Property -> Trace -> UID -> String+generateMain prop trc i =+  "main = print $ " ++ propertyName prop ++ " " ++ generateArgs trc i ++ "\n"++generateArgs :: Trace -> UID -> String+generateArgs trc i = case dfsChildren frt e of+  [_,ma,_,_]  -> generateExpr frt ma+  xs          -> error ("generateArgs: dfsChildren (" ++ show e ++ ") = " ++ show xs)++  where frt = (mkEventForest trc)+        e   = (reverse trc) !! (i-1)++generateExpr :: EventForest -> Maybe Event -> String+generateExpr _ Nothing    = __+generateExpr frt (Just e) = -- enable to add events as comments to generated code: "{- " ++ show e ++ " -}" +++                            case change e of+  (Cons _ s) -> foldl (\acc c -> acc ++ " " ++ c) ("(" ++ s) cs ++ ") "+  Enter      -> ""+  _          -> "error \"cannot represent\""++  where cs = map (generateExpr frt) (dfsChildren frt e)++__ :: String+__ = "(error \"Request of value that was unevaluated in orignal program.\")"++------------------------------------------------------------------------------------------------------------------------+-- Some test data++p1 :: Property+p1 = Property "MyModule" "prop_never" "../Prop"+-- p1 = Property "MyModule" "prop_idemSimplify" "../Prop"++v1 :: Vertex+v1 = Vertex (CompStmt "bla" 1 "bla 3 = 4") Unassessed++t1, t2 :: IO ()+t1 = print $ generate p1 [] 1+t2 = do {judge [] p1 v1; return ()}

@@ -0,0 +1,398 @@+-- This file is part of the Haskell debugger Hoed.+--+-- Copyright (c) Maarten Faddegon, 2014+{-# LANGUAGE CPP #-}++module Debug.Hoed.Pure.Render+(CompStmt(..)+,renderCompStmts+,CDS+,eventsToCDS+,rmEntrySet+,simplifyCDSSet+) where+import Debug.Hoed.Pure.EventForest++import Prelude hiding(lookup)+import Debug.Hoed.Pure.Observe+import Data.List(sort,sortBy,partition,nub+#if __GLASGOW_HASKELL__ >= 710+                , sortOn+#endif+                )+import Data.Graph.Libgraph+import Data.Array as Array++head' :: String -> [a] -> a+head' msg [] = error msg+head' _   xs = head xs++#if __GLASGOW_HASKELL__ < 710+sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn f  = map snd . sortOn' fst .  map (\x -> (f x, x))++sortOn' :: Ord b => (a -> b) -> [a] -> [a]+sortOn' f = sortBy (\x y -> compare (f x) (f y))+#endif++------------------------------------------------------------------------+-- The CompStmt type++-- MF TODO: naming here is a bit of a mess. Needs refactoring.+-- Indentifier refers to an identifier users can explicitely give+-- to observe'. But UID is the unique number assigned to each event.+-- The field equIdentifier is not an Identifier, but the UID of the+-- event that starts the observation. And stmtUIDs is the list of+-- UIDs of all events that form the statement.++data CompStmt = CompStmt { stmtLabel      :: String+                         , stmtIdentifier :: UID+                         , stmtRes        :: String+                         }+                deriving (Eq, Ord)++instance Show CompStmt where+  show = stmtRes+  showList eqs eq = unlines (map show eqs) ++ eq+++------------------------------------------------------------------------+-- Render equations from CDS set++renderCompStmts :: CDSSet -> [CompStmt]+renderCompStmts = foldl (\acc set -> acc ++ renderCompStmt set) []++-- renderCompStmt: an observed function can be applied multiple times, each application+-- is rendered to a computation statement++renderCompStmt :: CDS -> [CompStmt]+renderCompStmt (CDSNamed name threadId dependsOn set uids')+  = map mkStmt statements+  where statements :: [(String,UID)]+        statements   = map (\(d,i) -> (pretty 120 d,i)) doc+        doc          = foldl (\a b -> a ++ renderNamedTop name b) [] output+        output       = cdssToOutput set++        mkStmt :: (String,UID) -> CompStmt+        mkStmt (s,i) = CompStmt name i s++renderNamedTop :: String -> Output -> [(DOC,UID)]+renderNamedTop name (OutData cds)+  =  map (\(args,res,Just i) -> (renderNamedFn name (args,res), i)) pairs++  where pairs' = findFn [cds]+        pairs  = (nub . sortOn argAndRes) pairs'+        -- local nub for sorted lists+        nub []                  = []+        nub (a:a':as) | a == a' = nub (a' : as)+        nub (a:as)              = a : nub as++        argAndRes (arg,res,_) = (arg,res)++-- %************************************************************************+-- %*                                                                   *+-- \subsection{The CDS and converting functions}+-- %*                                                                   *+-- %************************************************************************+++data CDS = CDSNamed      String ThreadId UID CDSSet [UID]+         | CDSCons       UID    String   [CDSSet]+         | CDSFun        UID             CDSSet CDSSet+         | CDSEntered    UID+         | CDSTerminated UID+        deriving (Show,Eq,Ord)++type CDSSet = [CDS]++eventsToCDS :: [Event] -> CDSSet+eventsToCDS pairs = getChild 0 0+   where+     frt :: EventForest+     frt = mkEventForest pairs++     res i = (!) out_arr i++     bnds = (0, length pairs)++     mid_arr :: Array Int [(Int,CDS)]+     mid_arr = accumArray (flip (:)) [] bnds+                [ (pnode,(pport,res node))+                | (Event node (Parent pnode pport) _) <- pairs+                ]++     out_arr = array bnds       -- never uses 0 index+                [ (node,getNode'' node e change)+                | e@(Event node _ change) <- pairs+                ]++     getNode'' ::  Int -> Event -> Change -> CDS+     getNode'' node e change =+       case change of+        (Observe str t i) -> let chd = getChild node 0+                               in CDSNamed str t (getId chd i) chd (treeUIDs frt e)+        (Enter)             -> CDSEntered node+        (NoEnter)           -> CDSTerminated node+        Fun                 -> CDSFun node (getChild node 0) (getChild node 1)+        (Cons portc cons)+                            -> CDSCons node cons +                                  [ getChild node n | n <- [0..(portc-1)]]++     getId []                  i = i+     getId ((CDSFun i _ _ ):_) _ = i+     getId (_:cs)              i = getId cs i++     getChild :: Int -> Int -> CDSSet+     getChild pnode pport =+        [ content+        | (pport',content) <- (!) mid_arr pnode+        , 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+   where+        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 ")")+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 +                                ]+                 )+              )++{- renderSet handles the various styles of CDSSet.+ -}++renderSet :: CDSSet -> DOC+renderSet = renderSet' 0 False++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 pairs) <>+                line <> text "}")++   where+        findFn_noUIDs :: CDSSet -> [([CDSSet],CDSSet)]+        findFn_noUIDs c = map (\(a,r,_) -> (a,r)) (findFn c)+        pairs = nub (sort (findFn_noUIDs cdss))+        -- local nub for sorted lists+        nub []                  = []+        nub (a:a':as) | a == a' = nub (a' : as)+        nub (a:as)              = a : nub as++renderFn :: ([CDSSet],CDSSet) -> DOC+renderFn (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+                )+               )++renderNamedFn :: String -> ([CDSSet],CDSSet) -> DOC+renderNamedFn name (args,res)+  = grp (nest 3 +            (  text name <> sep+            <> foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b) nil args +            <> sep <> text "= " <> renderSet' 0 False res+            )+        )++findFn :: CDSSet -> [([CDSSet],CDSSet, Maybe UID)]+findFn = foldr findFn' []++findFn' (CDSFun i arg res) rest =+    case findFn res of+       [(args',res',_)] -> (arg : args', res', Just i) : rest+       _                -> ([arg], res, Just i) : rest+findFn' other rest = ([],[other], Nothing) : rest++renderTops []   = nil+renderTops tops = line <> foldr (<>) nil (map renderTop tops)++renderTop :: Output -> DOC+renderTop (OutLabel str set extras) =+        nest 2 (text ("-- " ++ str) <> line <>+                renderSet set+                <> renderTops extras) <> line++rmEntry :: CDS -> CDS+rmEntry (CDSNamed str t i set us)= CDSNamed str t i (rmEntrySet set) us+rmEntry (CDSCons i str sets)       = CDSCons i str (map rmEntrySet sets)+rmEntry (CDSFun i a b)             = CDSFun i (rmEntrySet a) (rmEntrySet b)+rmEntry (CDSTerminated i)          = CDSTerminated i+rmEntry (CDSEntered i)             = error "found bad CDSEntered"++rmEntrySet = map rmEntry . filter noEntered+  where+        noEntered (CDSEntered _) = False+        noEntered _              = True++simplifyCDS :: CDS -> CDS+simplifyCDS (CDSNamed str t i set us) = CDSNamed str t i (simplifyCDSSet set) us+simplifyCDS (CDSCons _ "throw" +                  [[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)++simplifyCDS (CDSFun i a b) = CDSFun i (simplifyCDSSet a) (simplifyCDSSet b)++simplifyCDS (CDSTerminated i) = (CDSCons i "<?>" [])++simplifyCDSSet = map simplifyCDS ++spotString :: CDSSet -> Maybe String+spotString [CDSCons _ ":"+                [[CDSCons _ str []]+                ,rest+                ]+           ] +        = do { ch <- case reads str of+                       [(ch,"")] -> return ch+                       _ -> Nothing+             ; more <- spotString rest+             ; return (ch : more)+             }+spotString [CDSCons _ "[]" []] = return []+spotString other = Nothing++paren :: Bool -> DOC -> DOC+paren False doc = grp (nest 0 doc)+paren True  doc = grp (nest 0 (text "(" <> nest 0 doc <> brk <> text ")"))++sp :: DOC+sp = text " "++data Output = OutLabel String CDSSet [Output]+            | OutData  CDS+              deriving (Eq,Ord,Show)+++commonOutput :: [Output] -> [Output]+commonOutput = sortBy byLabel+  where+     byLabel (OutLabel lab _ _) (OutLabel lab' _ _) = compare lab lab'++cdssToOutput :: CDSSet -> [Output]+cdssToOutput =  map cdsToOutput++cdsToOutput (CDSNamed name _ _ cdsset _)+            = OutLabel name res1 res2+  where+      res1 = [ cdss | (OutData cdss) <- res ]+      res2 = [ out  | out@(OutLabel {}) <- res ]+      res  = cdssToOutput cdsset+cdsToOutput cons@(CDSCons {}) = OutData cons+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)+++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++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++fold x                  = grp (brk <> 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++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 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,x :<|> y):z) = better w k +                                (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++pretty                  :: Int -> DOC -> String+pretty w x              = layout (best w 0 x)

@@ -7,10 +7,12 @@ Stability   : experimental Portability : POSIX -Hoed is a tracer and debugger for the programming language Haskell. You can+Hoed.Stk is a tracer and debugger for the programming language Haskell. You can trace a program by annotating functions in suspected modules and linking your-program against standard profiling libraries. +program against standard profiling libraries. +Hoed.Pure is recommended over Hoed.Stk because to debug your program with Hoed.Pure you can optimize your program and do not need to enable profiling.+ After running the program a computation tree is constructed and displayed in a web browser. You can freely browse this tree to get a better understanding of your program. If your program misbehaves, you can judge the computation@@ -101,11 +103,11 @@  -- | run some code and return the CDS structure (for when you want to write your own debugger). debugO :: IO a -> IO [Event]-debugO program = +debugO program =      do { initUniq         ; startEventStream         ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]"-        ; ourCatchAllIO (do { program ; return () }) +        ; ourCatchAllIO (do { program ; return () })                         (hPutStrLn stderr . errorMsg)         ; events <- endEventStream         ; return events@@ -115,21 +117,21 @@ printO :: (Show a) => a -> IO () printO expr = runO (print expr) --- | print a string, with debugging +-- | print a string, with debugging putStrO :: String -> IO () putStrO expr = runO (putStr expr)  -- | The main entry point; run some IO code, and debug inside it. --   After the IO action is completed, an algorithmic debugging session is started at --   @http://localhost:10000/@ to which you can connect with your webbrowser.--- +-- -- For example: ----- @ +-- @ --   main = runO $ do print (triple 3) --                    print (triple 2) -- @--- +--  runO :: IO a -> IO () runO program = {- SCC "runO" -} do@@ -162,7 +164,7 @@   hPutStrLn stderr $ "b = " ++ show b    hPutStrLn stderr "\n=== Debug session === \n"-  hPutStrLn stderr (showWithStack eqs)+  -- hPutStrLn stderr (showWithStack eqs)   return ct  leafs g = filter (\v -> succs g v == []) (vertices g)@@ -175,15 +177,16 @@    where showGraph g        = showWith g showVertex showArc         showVertex Root    = ("root","")-        showVertex v       = (showCompStmts v ++ "\nwith stack "-                              ++ (show . equStack . head . equations $ v), "")+        showVertex v       = ("\"" ++ (escape . showCompStmts) v ++ "\nwith stack "+                              ++ (showStk . equStack . head . equations $ v) ++ "\"", "")         showArc _          = ""         showCompStmts      = showCompStmts' . equations         showCompStmts' [e] = show e-        showCompStmts' es  = foldl (\acc e-> acc ++ show e ++ ", ") "{" (init es) +        showCompStmts' es  = foldl (\acc e-> acc ++ show e ++ ", ") "{" (init es)                              ++ show (last es) ++ "}"--  +        showStk []         = "[]"+        showStk stk        = showStk' $ map (\lbl -> "\\\"" ++ lbl ++ "\\\"") stk+        showStk' (h:lbls)  = foldl (\lbl acc -> lbl ++ (',' : acc)) ('[' : h) lbls ++ "]"  hPutStrList :: (Show a) => Handle -> [a] -> IO() hPutStrList h []     = hPutStrLn h ""

@@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -O0 #-}  \end{code} @@ -119,8 +120,6 @@ For the TracedMonad instance of IO: \begin{code} import GHC.Base hiding (mapM)--- import Control.Monad.ST(RealWorld)--- import Control.Monad.State(State) \end{code}  \begin{code}@@ -223,7 +222,7 @@  -- Constants: additional parameters and recursion of kind * instance (Observable a) => GObservable (K1 i a) where-        gdmobserver (K1 x) cxt = K1 (observer_ observer x cxt)+        gdmobserver (K1 x) cxt = K1 (observer x cxt)          gdmObserveChildren = gthunk @@ -1161,6 +1160,8 @@ Trival output functions  \begin{code}+type Trace = [Event]+ data Event = Event                 { portId     :: !Int                 , parent     :: !Parent@@ -1183,7 +1184,7 @@ startEventStream :: IO () startEventStream = writeIORef events [] -endEventStream :: IO [Event]+endEventStream :: IO Trace endEventStream =         do { es <- readIORef events            ; writeIORef events badEvents @@ -1201,20 +1202,11 @@            ; putMVar sendSem ()            } ---- writeEvent :: FilePath -> Event -> IO ()--- writeEvent f e = appendFile f (show e)--- --- readEvents :: FilePath -> IO [Event]--- readEvents f = do---   s <- readFile f---   return (read s)- -- local-events :: IORef [Event]+events :: IORef Trace events = unsafePerformIO $ newIORef badEvents -badEvents :: [Event]+badEvents :: Trace badEvents = error "Bad Event Stream"  -- use as a trivial semiphore@@ -1234,10 +1226,12 @@ Use the single threaded version  \begin{code}+type UID = Int+ initUniq :: IO () initUniq = writeIORef uniq 1 -getUniq :: IO Int+getUniq :: IO UID getUniq     = do { takeMVar uniqSem          ; n <- readIORef uniq@@ -1246,12 +1240,12 @@          ; return n          } -peepUniq :: IO Int+peepUniq :: IO UID peepUniq = readIORef uniq  -- locals {-# NOINLINE uniq #-}-uniq :: IORef Int+uniq :: IORef UID uniq = unsafePerformIO $ newIORef 1  {-# NOINLINE uniqSem #-}@@ -1274,7 +1268,7 @@ --      ; startEventStream --      } -- --- closeObserveGlobal :: IO [Event]+-- closeObserveGlobal :: IO Trace -- closeObserveGlobal = --      do { evs <- endEventStream --         ; putStrLn ""

@@ -1,6 +1,7 @@ -- This file is part of the Haskell debugger Hoed. -- -- Copyright (c) Maarten Faddegon, 2014+{-# OPTIONS_GHC -auto-all #-}  module Debug.Hoed.Stk.Render (CompStmt(..)@@ -78,8 +79,11 @@ data CompStmt = CompStmt {equLabel :: String, equThreadId :: ThreadId                          , equIdentifier :: Int, equDependsOn :: Identifier                          , equRes :: String, equStack :: CallStack}-                deriving (Eq, Ord)+                deriving (Ord) +instance Eq CompStmt where+  s1 == s2 = {-# SCC "CompStmt.==" #-} equIdentifier s1 == equIdentifier s2+ instance Show CompStmt where   show e = equRes e -- ++ " with stack " ++ show (equStack e)   showList eqs eq = unlines (map show eqs) ++ eq@@ -166,7 +170,7 @@  data Bag = Bag {bagStack :: CallStack, bagStmts :: [CompStmt]} -instance Eq  Bag where b1 == b2 = bagStack b1 == bagStack b2+instance Eq  Bag where b1 == b2 = {-# SCC "Bag.==" #-} bagStack b1 == bagStack b2 instance Ord Bag where compare b1 b2 = cmpStk (bagStack b1) (bagStack b2)  bag :: (CompStmt -> CallStack) -> CompStmt -> Bag@@ -241,8 +245,15 @@ -- Computation graphs  data Vertex = Root | Vertex {equations :: [CompStmt], status :: Judgement}-              deriving (Eq,Show,Ord)+              deriving (Show,Ord) +instance Eq Vertex where +  v1 == v2 = {-# SCC "Vertex.==" #-} v1 === v2+                where Root === Root = True+                      Root === _    = False+                      _    === Root = False +                      (Vertex ss1 j1) === (Vertex ss2 j2) =  ss1 == ss2 && j1 == j2+ type CompGraph = Graph Vertex ()  isRoot Root = True@@ -267,14 +278,14 @@   where src ==> tgt = Arc src tgt ()  mkGraph :: [CompStmt] -> CompGraph-mkGraph cs = {-# SCC "mkGraph" #-} -- (dagify merge) -                                   addRoot-                                   . toVertices -                                   -- . sameThread -                                   -- . filterDependsJustOn-                                   -- . addSequenceDependencies-                                   . nubArcs-                                   $ g+mkGraph cs =  (dagify merge)+              . addRoot+              . toVertices +              -- . sameThread +              -- . filterDependsJustOn+              -- . addSequenceDependencies+              . nubArcs+              $ g   where g :: Graph CompStmt ()         g = let ts = mkTrees cs in Graph (head' msg cs) cs (pushDeps ts cs ++ callDeps ts cs)         msg = "mkGraph: No computation statements to construct graph from!"

@@ -1,7 +1,12 @@ name:                Hoed-version:             0.2.2-synopsis:            Lighweight algorithmic debugging based on observing intermediate values and the cost centre stack.--- description:         TODO+version:             0.3.0+synopsis:            Lighweight algorithmic debugging.+description:+    Hoed is a tracer and debugger for the programming language Haskell. You can trace a program by annotating functions in suspected modules and linking your program against standard profiling libraries.+    .+    To locate a defect with Hoed you annotate suspected functions and compile as usual. Then you run your program, information about the annotated functions is collected. Finally you connect to a debugging session using a webbrowser.+    .+    Hoed comes in two flavours: Hoed.Pure and Hoed.Stk. Hoed.Pure is recommended over Hoed.Stk: to debug your program with Hoed.Pure you can optimize your program and do not need to enable profiling. Hoed.Stk is Hoed as presented on PLDI 2015 and possibly has benefits over Hoed.Pure for debugging concurrent/parallel programs. homepage:            http://maartenfaddegon.nl license:             BSD3 license-file:        LICENSE@@ -11,22 +16,41 @@ category:            Debug, Trace build-type:          Simple cabal-version:       >=1.10-Extra-Source-Files:  changelog+Extra-Source-Files:  changelog, README.md  flag buildExamples   description: Build example executables.   default: False -flag validate-  description: Build validation executables.+flag validatePure+  description: Build test cases to validate Hoed-pure.   default: False +flag validateStk+  description: Build test cases to validate Hoed-stk.+  default: False++flag validateGeneric+  description: Build test cases to validate deriving Observable for Generic types.+  default: False++Source-repository head+    type:               git+    location:           git://github.com/MaartenFaddegon/Hoed.git+ library   exposed-modules:     Debug.Hoed.Stk+                       , Debug.Hoed.Pure   other-modules:       Debug.Hoed.Stk.Observe                        , Debug.Hoed.Stk.Render                        , Debug.Hoed.Stk.DemoGUI-  build-depends:       base >=4.6 && <5+                       , Debug.Hoed.Pure.Observe+                       , Debug.Hoed.Pure.EventForest+                       , Debug.Hoed.Pure.CompTree+                       , Debug.Hoed.Pure.Render+                       , Debug.Hoed.Pure.DemoGUI+                       , Debug.Hoed.Pure.Prop+  build-depends:       base >= 4 && <5                        , template-haskell                        , array, containers                        , process@@ -38,10 +62,7 @@                        , mtl                        , directory   default-language:    Haskell2010-  ghc-options:         -O0 -- --------------------------------------------------------------------------- -- -- A list of example-programs that bind to a debugging session after the@@ -53,7 +74,7 @@  Executable hoed-examples-Foldl   if flag(buildExamples)-    build-depends:       base >= 4 && < 5+    build-depends:       base >= 4.8 && < 5                          , Hoed                          , threepenny-gui                          , filepath@@ -360,22 +381,142 @@ -- --------------------------------------------------------------------------- -Executable hoed-tests-DoublingServer-  if flag(validate)+Executable hoed-tests-Generic-r0+  if flag(validateGeneric)     build-depends:       base >= 4 && < 5                          , Hoed+  else+    buildable: False+  main-is:             r0.hs+  hs-source-dirs:      tests/Generic+  default-language:    Haskell2010++Executable hoed-tests-Generic-t0+  if flag(validateGeneric)+    build-depends:       base >= 4 && < 5+                         , Hoed+  else+    buildable: False+  main-is:             t0.hs+  hs-source-dirs:      tests/Generic+  default-language:    Haskell2010++Executable hoed-tests-Generic-r1+  if flag(validateGeneric)+    build-depends:       base >= 4 && < 5+                         , Hoed+  else+    buildable: False+  main-is:             r1.hs+  hs-source-dirs:      tests/Generic+  default-language:    Haskell2010++Executable hoed-tests-Generic-t1+  if flag(validateGeneric)+    build-depends:       base >= 4 && < 5+                         , Hoed+  else+    buildable: False+  main-is:             t1.hs+  hs-source-dirs:      tests/Generic+  default-language:    Haskell2010++Executable hoed-tests-Generic-r2+  if flag(validateGeneric)+    build-depends:       base >= 4 && < 5+                         , Hoed+  else+    buildable: False+  main-is:             r2.hs+  hs-source-dirs:      tests/Generic+  default-language:    Haskell2010++Executable hoed-tests-Generic-t2+  if flag(validateGeneric)+    build-depends:       base >= 4 && < 5+                         , Hoed+  else+    buildable: False+  main-is:             t2.hs+  hs-source-dirs:      tests/Generic+  default-language:    Haskell2010++Executable hoed-tests-Generic-r3+  if flag(validateGeneric)+    build-depends:       base >= 4 && < 5+                         , Hoed+  else+    buildable: False+  main-is:             r3.hs+  hs-source-dirs:      tests/Generic+  default-language:    Haskell2010++Executable hoed-tests-Generic-t3+  if flag(validateGeneric)+    build-depends:       base >= 4 && < 5+                         , Hoed+  else+    buildable: False+  main-is:             t3.hs+  hs-source-dirs:      tests/Generic+  default-language:    Haskell2010++---------------------------------------------------------------------------++Executable hoed-tests-Pure-t1+  if flag(validatePure)+    build-depends:       base >= 4 && < 5, Hoed+  else+    buildable: False+  main-is:             t1.hs+  hs-source-dirs:      tests/Pure+  default-language:    Haskell2010++Executable hoed-tests-Pure-t2+  if flag(validatePure)+    build-depends:       base >= 4 && < 5, Hoed+  else+    buildable: False+  main-is:             t2.hs+  hs-source-dirs:      tests/Pure+  default-language:    Haskell2010++Executable hoed-tests-Pure-t3+  if flag(validatePure)+    build-depends:       base >= 4 && < 5, Hoed+  else+    buildable: False+  main-is:             t3.hs+  hs-source-dirs:      tests/Pure+  default-language:    Haskell2010++Executable hoed-tests-Pure-t4+  if flag(validatePure)+    build-depends:       base >= 4 && < 5, Hoed+  else+    buildable: False+  main-is:             t4.hs+  hs-source-dirs:      tests/Pure+  default-language:    Haskell2010++---------------------------------------------------------------------------++Executable hoed-tests-Stk-DoublingServer+  if flag(validateStk)+    build-depends:       base >= 4 && < 5+                         , Hoed                          , threepenny-gui                          , filepath                          , network   else     buildable: False   main-is:             DoublingServer.hs-  hs-source-dirs:      tests+  hs-source-dirs:      tests/Stk   default-language:    Haskell2010   ghc-options:         -O0 -Executable hoed-tests-Insort2-  if flag(validate)+Executable hoed-tests-Stk-Insort2+  if flag(validateStk)     build-depends:       base >= 4 && < 5                          , Hoed                          , threepenny-gui@@ -383,12 +524,12 @@   else     buildable: False   main-is:             Insort2.hs-  hs-source-dirs:      tests+  hs-source-dirs:      tests/Stk   default-language:    Haskell2010   ghc-options:         -O0 -Executable hoed-tests-Example1-  if flag(validate)+Executable hoed-tests-Stk-Example1+  if flag(validateStk)     build-depends:       base >= 4 && < 5                          , Hoed                          , threepenny-gui@@ -396,12 +537,12 @@   else     buildable: False   main-is:             Example1.hs-  hs-source-dirs:      tests+  hs-source-dirs:      tests/Stk   default-language:    Haskell2010   ghc-options:         -O0 -Executable hoed-tests-Example3-  if flag(validate)+Executable hoed-tests-Stk-Example3+  if flag(validateStk)     build-depends:       base >= 4 && < 5                          , Hoed                          , threepenny-gui@@ -409,12 +550,12 @@   else     buildable: False   main-is:             Example3.lhs-  hs-source-dirs:      tests+  hs-source-dirs:      tests/Stk   default-language:    Haskell2010   ghc-options:         -O0 -Executable hoed-tests-Example4-  if flag(validate)+Executable hoed-tests-Stk-Example4+  if flag(validateStk)     build-depends:       base >= 4 && < 5                          , Hoed                          , threepenny-gui@@ -422,12 +563,12 @@   else     buildable: False   main-is:             Example4.hs-  hs-source-dirs:      tests+  hs-source-dirs:      tests/Stk   default-language:    Haskell2010   ghc-options:         -O0 -Executable hoed-tests-IndirectRecursion-  if flag(validate)+Executable hoed-tests-Stk-IndirectRecursion+  if flag(validateStk)     build-depends:       base >= 4 && < 5                          , Hoed                          , threepenny-gui@@ -435,6 +576,6 @@   else     buildable: False   main-is:             IndirectRecursion.lhs-  hs-source-dirs:      tests+  hs-source-dirs:      tests/Stk   default-language:    Haskell2010   ghc-options:         -O0

@@ -0,0 +1,85 @@+# Hoed - A Lightweight Haskell Tracer and Debugger [![Build Status](https://travis-ci.org/MaartenFaddegon/Hoed.svg?branch=master)](https://travis-ci.org/MaartenFaddegon/Hoed)++Hoed is a tracer and debugger for the programming language Haskell.++## Using Hoed++To locate a defect with Hoed you annotate suspected functions and compile as usual. Then you run your program, information about the annotated functions is collected. Finally you connect to a debugging session using a webbrowser.++Let us consider the following program, a defective implementation of a parity function with a test property.++    isOdd :: Int -> Bool+    isOdd n = isEven (plusOne n)+    +    isEven :: Int -> Bool+    isEven n = mod2 n == 0+    +    plusOne :: Int -> Int+    plusOne n = n + 1+    +    mod2 :: Int -> Int+    mod2 n = div n 2+    +    prop_isOdd :: Int -> Bool+    prop_isOdd x = isOdd (2*x+1)+    +    main :: IO ()+    main = printO (prop_isOdd 1)+    +    main :: IO ()+    main = quickcheck prop_isOdd++Using the property-based test tool QuickCheck we find the counter example `1` for our property.++    ./MyProgram+    *** Failed! Falsifiable (after 1 test): 1++Hoed can help us determine which function is defective. We annotate the functions `isOdd`, `isEven`, `plusOne` and `mod2` as follows:++    import Debug.Hoed.Pure+    +    isOdd :: Int -> Bool+    isOdd = observe "isOdd" isOdd'+    isOdd' n = isEven (plusOne n)+    +    isEven :: Int -> Bool+    isEven = observe "isEven" isEven'+    isEven' n = mod2 n == 0+    +    plusOne :: Int -> Int+    plusOne = observe "plusOne" plusOne'+    plusOne' n = n + 1+    +    mod2 :: Int -> Int+    mod2 = observe "mod2" mod2'+    mod2' n = div n 2+    +    prop_isOdd :: Int -> Bool+    prop_isOdd x = isOdd (2*x+1)+    +    main :: IO ()+    main = printO (prop_isOdd 1)++After running the program a computation tree is constructed and displayed in a web browser.++    ./MyProgram+    False+    Listening on http://127.0.0.1:10000/++You can freely browse this tree to get a better understanding of your program. If your program misbehaves, you can judge the computation statements in the tree as 'right' or 'wrong' according to your intention. When enough statements are judged the debugger tells you the location of the fault in your code.++![Screenshot of Hoed][1]++## Installation++Hoed is available from Hackage and can be installed with Cabal.++    cabal install Hoed++## Other Tracers++Many of the ideas for Hoed come from the Hat project. Hoed is the Dutch word for a hat. Compared to Hoed, Hat can give more detailed traces. However, Hat requires all modules to be transformed and is therefore not practical for many real-world Haskell programs.++The idea to observe values with local annotations comes from the HOOD project. Unlike Hoed, HOOD does not give relations between observed values. HOOD also requires the programmer to write a class-instance for the type of the value they want to observe. With Hoed these instates can be derived automatically.++  [1]: http://www.cs.kent.ac.uk/people/rpg/mf357/hoedv2.0.0.png

@@ -1,76 +0,0 @@--- Based on the TrivialServer-example from Marlow, Parallel and Concurrent--- Programming in Haskell--{-# LANGUAGE StandaloneDeriving #-}--import System.IO-import Network-import Text.Printf-import Control.Monad-import Control.Concurrent-import Debug.Hoed(observe,Observable(..),logO,send)-import System.IO.Unsafe-import Data.List--twotimes :: Integer -> Integer-twotimes j = (observe "twotimes"-             ( \i -> {-# SCC "twotimes" #-} -                2 + i -- bug: should be 2 * i-             )) j--double :: String -> String-double = observe "double" -         $ \s -> {-# SCC "double" #-} show (twotimes (read s :: Integer))--loop h = do-  line <- hGetLine h-  if line == "end"-     then do hPutStrLn h ("Thank you for using the Haskell doubling service.")-             putStrLn $ "server: Terminated client " ++ show h-     else do hPutStrLn h (double line)-             loop h--talk :: Handle -> IO ()-talk h = do -  hSetBuffering h LineBuffering-  i <- myThreadId-  hPutStrLn h $ "Welcome on thread " ++ show i-  loop h--port :: Int-port = 44444--server :: Int -> Socket -> IO ()-server = observe "server" (\x sock -> {-# SCC "server" #-} server' x sock)-  where server' 0 _ = putStrLn "server: Shutting down."-        server' x sock = do-          (handle, host, port) <- accept sock-          printf "server: Accepted connection from %s: %s\n" host (show port)-          forkFinally (talk handle) (\_ -> hClose handle)-          server (x-1) sock--client :: Int -> IO ()-client x = do-  h <- connectTo "localhost" (PortNumber (fromIntegral port))-  hSetBuffering h LineBuffering-  let pr s = putStrLn $ "client-" ++ show x ++ ": " ++ s-  -  s <- hGetLine h; pr s -- Get and print the welcome message-  hPutStrLn h (show x)  -- Send x for doubling to the server-  s <- hGetLine h; pr s -- Get and print response from server-  hPutStrLn h "end"     -- Send goodbye message-  s <- hGetLine h; pr s -- Get and print response from server--main :: IO ()-main = logO "hoed-tests-DoublingServer.graph" $ withSocketsDo $ do-  sock <- listenOn (PortNumber (fromIntegral port))-  printf "server: Listening on port %d.\n" port-  forkIO (server 2 sock) -- Start server in own thread.-  client 2               -- Connect with two clients from this thread to the server.-  client 3-  threadDelay 1000       -- Give server-thread some time to terminate.--slices = []--instance Observable Handle where observer h = send (show h) (return h)-instance Observable Socket where observer s = send "socket" (return s)

@@ -1,9 +0,0 @@-import Debug.Hoed--f :: Int -> Int-f = observe "f" $ \x -> {-# SCC "f" #-} if x > 0 then g x else 0--g :: Int -> Int-g = observe "g" $ \x -> {-# SCC "g" #-} x `div` 2--main = logO "hoed-tests-Example1.graph" $ print ((f 2) + (f 0))

@@ -1,27 +0,0 @@-> {-# LANGUAGE TemplateHaskell, Rank2Types #-}-> import Debug.Hoed--> $(observedTypes "k" [])-> $(observedTypes "l" [])-> $(observedTypes "m" [])-> $(observedTypes "n" [])---> main = logO "hoed-tests-Example3.graph" $ print (k 1)--> k :: Int -> Int-> k  x = $(observeTempl "k") k' x-> k' x = {-# SCC "k" #-} k'' x-> k'' x = (l x) + (m $ x + 1)--> l :: Int -> Int-> l  x  = $(observeTempl "l") l' x-> l' x  = {-# SCC "l" #-} m x--> m :: Int -> Int-> m  x = $(observeTempl "m") m' x-> m' x = {-# SCC "m" #-} n x--> n :: Int -> Int-> n  x = $(observeTempl "n") n' x-> n' x = {-# SCC "n" #-} x

@@ -1,3 +0,0 @@-import Debug.Hoed--main = logO "hoed-tests-Example4.graph" $ print (observe "main" $ 42 :: Int)

@@ -0,0 +1,12 @@+import Debug.Hoed.Pure++data D = D Int +  deriving Show++instance Observable D where+  observer (D x) = send "D" $ return D << x++f = observe "f" f'+f' x = D x++main = logO "r0" $ print (f 3)

@@ -0,0 +1,15 @@+import Debug.Hoed.Pure++data D = D D | C Int +  deriving Show++instance Observable D where+  observer (D x) = send "D" $ return D << x+  observer (C i) = send "C" $ return C << i++f :: D -> Int+f = observe "f" f'+f' (C x) = x+f' (D d) = f d++main = logO "r0" $ print (f (D (C 3)))

@@ -0,0 +1,15 @@+import Debug.Hoed.Pure++data D = D D | T+  deriving (Show)++instance Observable D where+  observer (D x) = send "D" $ return D << x+  observer T     = send "T" $ return T++f :: D -> Int+f = observe "f" f'+f' T     = 1+f' (D _) = 0++main = logO "r0" $ print (f (D (D (D T))))

@@ -0,0 +1,15 @@+import Debug.Hoed.Pure++data Expr = Mul Expr Expr | Const Int | Exc+  deriving Show++instance Observable Expr where+  observer (Mul e1 e2) = send "Mul"   $ return Mul << e1 << e2+  observer (Const v)   = send "Const" $ return Const << v+  observer Exc         = send "Exc"   $ return Exc++one = observe "one" one'+one' (Mul expr (Const 1)) = expr+one' expr                 = expr++main = logO "g" $ print $ one (Mul (Const 1) (Const 1))

@@ -0,0 +1,12 @@+{-# LANGUAGE DeriveGeneric #-}+import Debug.Hoed.Pure++data D = D Int +  deriving (Show,Generic)++instance Observable D++f = observe "f" f'+f' x = D x++main = logO "t0" $ print (f 3)

@@ -0,0 +1,14 @@+{-# LANGUAGE DeriveGeneric #-}+import Debug.Hoed.Pure++data D = D D | C Int +  deriving (Show,Generic)++instance Observable D++f :: D -> Int+f = observe "f" f'+f' (C x) = x+f' (D d) = f d++main = logO "r0" $ print (f (D (C 3)))

@@ -0,0 +1,14 @@+{-# LANGUAGE DeriveGeneric #-}+import Debug.Hoed.Pure++data D = D D | T+  deriving (Show,Generic)++instance Observable D++f :: D -> Int+f = observe "f" f'+f' T     = 1+f' (D _) = 0++main = logO "r0" $ print (f (D (D (D T))))

@@ -0,0 +1,13 @@+{-# LANGUAGE DeriveGeneric #-}+import Debug.Hoed.Pure++data Expr = Mul Expr Expr | Const Int | Exc+  deriving (Show,Generic)++instance Observable Expr++one = observe "one" one'+one' (Mul expr (Const 1)) = expr+one' expr                 = expr++main = logO "g" $ print $ one (Mul (Const 1) (Const 1))

@@ -1,37 +0,0 @@-This is an example of how information is lost as a result of trunction of the-cost centre stack. The actual call graph is of this program is:--        main -> f 1 -> g 2 -> f 3 -> h 1--But with pushing "f" a second time the "g" label is also lost. Additionally-the h-statement is associated with the stack [f], which can either be from the-untruncated f statement or the truncated f statement. We therefore infer the-following call graph:--        main -> f 1 -> {f 3, g 2} -> h 1-                   \_________________^--> {-# LANGUAGE TemplateHaskell, Rank2Types #-}-> import Debug.Hoed--> $(observedTypes "f" [])-> $(observedTypes "g" [])-> $(observedTypes "h" [])--> f :: Int -> Int-> f   x = $(observeTempl "f") f' x-> f'  x = {-# SCC "f" #-} f'' x-> f'' 1 = g 2-> f'' x = h (x + 1)--> g :: Int -> Int-> g   x = $(observeTempl "g") g' x-> g'  x = {-# SCC "g" #-} g'' x-> g'' x = f (x + 1)--> h :: Int -> Int-> h   x = $(observeTempl "h") h' x-> h'  x = {-# SCC "h" #-} h'' x-> h'' x = (x+1)--> main = logO "hoed-tests-IndirectRecursion.graph" $ print (f 1)

@@ -1,39 +0,0 @@--- Haskell version of the buggy insertion sort as shown in Lee Naish--- A Declarative Debugging Scheme.------ As Insort1, but with observe rather than templated observers.--{-# LANGUAGE StandaloneDeriving #-}-import Debug.Hoed---- Insertion sort.--isort :: [Int] -> [Int]-isort ns = observe "isort" (\ns -> {-# SCC "isort" #-} isort' ns) ns-isort' []     = []-isort' (n:ns) = insert n (isort ns)---- Insert number into sorted list.--insert :: Int -> [Int] -> [Int]-insert n ms = (observe "insert" (\n ms -> {-# SCC "insert" #-} insert' n ms)) n ms-insert' :: Int -> [Int] -> [Int]-insert' n []      = [n]-insert' n (m:ms)-      | n <= m    = n : ms -- bug: `m' is missing in this case-      | otherwise = m : (insert n ms)--main = logO "hoed-tests-Insort2.graph" . print $-         (observe "result") ({-# SCC "result" #-} isort [1,2])---- Slices, these should be generated automatically from the original code.--slices-  = [ ("result",  "isort [1,2]")-    , ("isort" ,  "isort []     = []\n"-               ++ "isort (n:ns) = insert n (isort ns)")-    , ("insert",  " insert n []       = [n]\n"-               ++ " insert n (m:ms)\n"-               ++ "       | n <= m    = n : ms\n"-               ++ "       | otherwise = m : (insert n ms)\n")-    ]

@@ -0,0 +1,12 @@+import Debug.Hoed.Pure++f :: Int -> Int+f = observe "f" f'+f' x = if x > 0 then g x else 0++g :: Int -> Int+g = observe "g" g'+g' x = x `div` 2++main = logO "hoed-tests-Pure-t1.graph" $ print ((f 2) + (f 0))+

@@ -0,0 +1,19 @@+import Debug.Hoed.Pure++k :: Int -> Int+k  = observe "k" k'+k' x = (l x) + (m $ x + 1)++l :: Int -> Int+l  = observe "l" l'+l' x  = m x++m :: Int -> Int+m  = observe "m" m'+m' x = n x++n :: Int -> Int+n  = observe "n" n'+n' x = x++main = logO "hoed-tests-Pure-t2.graph" $ print (k 1)

@@ -0,0 +1,22 @@+-- Haskell version of the buggy insertion sort as shown in Lee Naish+-- A Declarative Debugging Scheme.++{-# LANGUAGE StandaloneDeriving #-}+import Debug.Hoed.Pure++-- Insertion sort.+isort :: [Int] -> [Int]+isort = observe "isort" isort'+isort' []     = []+isort' (n:ns) = insert n (isort ns)++-- Insert number into sorted list.+insert :: Int -> [Int] -> [Int]+insert = observe "insert" insert'+insert' :: Int -> [Int] -> [Int]+insert' n []      = [n]+insert' n (m:ms)+      | n <= m    = n : ms -- bug: `m' is missing in this case+      | otherwise = m : (insert n ms)++main = logO "hoed-tests-Pure-t3.graph" $ print (isort [1,2])

@@ -0,0 +1,25 @@+-- A defective implementation of a parity function with a test property.++import Debug.Hoed.Pure++isOdd :: Int -> Bool+isOdd = observe "isOdd" isOdd'+isOdd' n = isEven (plusOne n)++isEven :: Int -> Bool+isEven = observe "isEven" isEven'+isEven' n = mod2 n == 0++plusOne :: Int -> Int+plusOne = observe "plusOne" plusOne'+plusOne' n = n + 1++mod2 :: Int -> Int+mod2 = observe "mod2" mod2'+mod2' n = div n 2++prop_isOdd :: Int -> Bool+prop_isOdd x = isOdd (2*x+1)++main :: IO ()+main = logO "hoed-tests-Pure-t4.graph" $ print (prop_isOdd 1)

@@ -0,0 +1,74 @@+-- Based on the TrivialServer-example from Marlow, Parallel and Concurrent+-- Programming in Haskell++import System.IO+import Network+import Text.Printf+import Control.Monad+import Control.Concurrent+import Debug.Hoed.Stk(observe,Observable(..),logO,send)+import System.IO.Unsafe+import Data.List++twotimes :: Integer -> Integer+twotimes j = (observe "twotimes"+             ( \i -> {-# SCC "twotimes" #-} +                2 + i -- bug: should be 2 * i+             )) j++double :: String -> String+double = observe "double" +         $ \s -> {-# SCC "double" #-} show (twotimes (read s :: Integer))++loop h = do+  line <- hGetLine h+  if line == "end"+     then do hPutStrLn h ("Thank you for using the Haskell doubling service.")+             putStrLn $ "server: Terminated client " ++ show h+     else do hPutStrLn h (double line)+             loop h++talk :: Handle -> IO ()+talk h = do +  hSetBuffering h LineBuffering+  i <- myThreadId+  hPutStrLn h $ "Welcome on thread " ++ show i+  loop h++port :: Int+port = 44444++server :: Int -> Socket -> IO ()+server = observe "server" (\x sock -> {-# SCC "server" #-} server' x sock)+  where server' 0 _ = putStrLn "server: Shutting down."+        server' x sock = do+          (handle, host, port) <- accept sock+          printf "server: Accepted connection from %s: %s\n" host (show port)+          forkFinally (talk handle) (\_ -> hClose handle)+          server (x-1) sock++client :: Int -> IO ()+client x = do+  h <- connectTo "localhost" (PortNumber (fromIntegral port))+  hSetBuffering h LineBuffering+  let pr s = putStrLn $ "client-" ++ show x ++ ": " ++ s+  +  s <- hGetLine h; pr s -- Get and print the welcome message+  hPutStrLn h (show x)  -- Send x for doubling to the server+  s <- hGetLine h; pr s -- Get and print response from server+  hPutStrLn h "end"     -- Send goodbye message+  s <- hGetLine h; pr s -- Get and print response from server++main :: IO ()+main = logO "hoed-tests-Stk-DoublingServer.graph" $ withSocketsDo $ do+  sock <- listenOn (PortNumber (fromIntegral port))+  printf "server: Listening on port %d.\n" port+  forkIO (server 2 sock) -- Start server in own thread.+  client 2               -- Connect with two clients from this thread to the server.+  client 3+  threadDelay 1000       -- Give server-thread some time to terminate.++slices = []++instance Observable Handle where observer h = send (show h) (return h)+instance Observable Socket where observer s = send "socket" (return s)

@@ -0,0 +1,9 @@+import Debug.Hoed.Stk++f :: Int -> Int+f = observe "f" $ \x -> {-# SCC "f" #-} if x > 0 then g x else 0++g :: Int -> Int+g = observe "g" $ \x -> {-# SCC "g" #-} x `div` 2++main = logO "hoed-tests-Stk-Example1.graph" $ print ((f 2) + (f 0))

@@ -0,0 +1,27 @@+> {-# LANGUAGE TemplateHaskell, Rank2Types #-}+> import Debug.Hoed.Stk++> $(observedTypes "k" [])+> $(observedTypes "l" [])+> $(observedTypes "m" [])+> $(observedTypes "n" [])+++> main = logO "hoed-tests-Stk-Example3.graph" $ print (k 1)++> k :: Int -> Int+> k  x = $(observeTempl "k") k' x+> k' x = {-# SCC "k" #-} k'' x+> k'' x = (l x) + (m $ x + 1)++> l :: Int -> Int+> l  x  = $(observeTempl "l") l' x+> l' x  = {-# SCC "l" #-} m x++> m :: Int -> Int+> m  x = $(observeTempl "m") m' x+> m' x = {-# SCC "m" #-} n x++> n :: Int -> Int+> n  x = $(observeTempl "n") n' x+> n' x = {-# SCC "n" #-} x

@@ -0,0 +1,3 @@+import Debug.Hoed.Stk++main = logO "hoed-tests-Stk-Example4.graph" $ print (observe "main" $ 42 :: Int)

@@ -0,0 +1,37 @@+This is an example of how information is lost as a result of trunction of the+cost centre stack. The actual call graph is of this program is:++        main -> f 1 -> g 2 -> f 3 -> h 1++But with pushing "f" a second time the "g" label is also lost. Additionally+the h-statement is associated with the stack [f], which can either be from the+untruncated f statement or the truncated f statement. We therefore infer the+following call graph:++        main -> f 1 -> {f 3, g 2} -> h 1+                   \_________________^++> {-# LANGUAGE TemplateHaskell, Rank2Types #-}+> import Debug.Hoed.Stk++> $(observedTypes "f" [])+> $(observedTypes "g" [])+> $(observedTypes "h" [])++> f :: Int -> Int+> f   x = $(observeTempl "f") f' x+> f'  x = {-# SCC "f" #-} f'' x+> f'' 1 = g 2+> f'' x = h (x + 1)++> g :: Int -> Int+> g   x = $(observeTempl "g") g' x+> g'  x = {-# SCC "g" #-} g'' x+> g'' x = f (x + 1)++> h :: Int -> Int+> h   x = $(observeTempl "h") h' x+> h'  x = {-# SCC "h" #-} h'' x+> h'' x = (x+1)++> main = logO "hoed-tests-Stk-IndirectRecursion.graph" $ print (f 1)

@@ -0,0 +1,39 @@+-- Haskell version of the buggy insertion sort as shown in Lee Naish+-- A Declarative Debugging Scheme.+--+-- As Insort1, but with observe rather than templated observers.++{-# LANGUAGE StandaloneDeriving #-}+import Debug.Hoed.Stk++-- Insertion sort.++isort :: [Int] -> [Int]+isort ns = observe "isort" (\ns -> {-# SCC "isort" #-} isort' ns) ns+isort' []     = []+isort' (n:ns) = insert n (isort ns)++-- Insert number into sorted list.++insert :: Int -> [Int] -> [Int]+insert n ms = (observe "insert" (\n ms -> {-# SCC "insert" #-} insert' n ms)) n ms+insert' :: Int -> [Int] -> [Int]+insert' n []      = [n]+insert' n (m:ms)+      | n <= m    = n : ms -- bug: `m' is missing in this case+      | otherwise = m : (insert n ms)++main = logO "hoed-tests-Stk-Insort2.graph" . print $+         (observe "result") ({-# SCC "result" #-} isort [1,2])++-- Slices, these should be generated automatically from the original code.++slices+  = [ ("result",  "isort [1,2]")+    , ("isort" ,  "isort []     = []\n"+               ++ "isort (n:ns) = insert n (isort ns)")+    , ("insert",  " insert n []       = [n]\n"+               ++ " insert n (m:ms)\n"+               ++ "       | n <= m    = n : ms\n"+               ++ "       | otherwise = m : (insert n ms)\n")+    ]