diff --git a/Debug/Hoed.hs b/Debug/Hoed.hs deleted file mode 100644 --- a/Debug/Hoed.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-| -Module : Debug.Hoed -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-2014 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. - -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. - -<> - -I work on this debugger in the context of my Ph.D. research. -Read more about the theory behind Hoed at . - -To use Hoed on your own program, annotate your program as described below. -For best results profiling is enabled and optimization disabled. -If you use cabal to build your project, this is be done with: - -> cabal configure --disable-optimization --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 . - --} - -module Debug.Hoed - ( -- * Basic annotations - observe - , runO - , printO - - -- * Experimental annotations - , observeTempl - , observedTypes - , observeCC - , observe' - , Identifier(..) - ,(*>>=),(>>==),(>>=*) - , logO - - -- * The Observable class - , Observer(..) - , Observable(..) - , (<<) - , thunk - , nothunk - , send - , observeBase - , observeOpaque - , debugO - , CDS(..) - , Generic - ) where - - -import Debug.Hoed.Observe -import Debug.Hoed.Render -import Debug.Hoed.DemoGUI - -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 Data.Graph.Libgraph -import Graphics.UI.Threepenny - -import System.Directory(createDirectoryIfMissing) - - --- %************************************************************************ --- %* * --- \subsection{External start functions} --- %* * --- %************************************************************************ - --- Run the observe ridden code. - --- | 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 { initUniq - ; startEventStream - ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]" - ; ourCatchAllIO (do { program ; return () }) - (hPutStrLn stderr . errorMsg) - ; events <- endEventStream - ; return (eventsToCDS events) - } - --- | Short for @runO . print@. -printO :: (Show a) => a -> IO () -printO expr = runO (print expr) - --- | 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 - let slices = [] -- MF TODO: this whole slices business should probably just go? - compGraph <- runO' program - debugSession slices compGraph - return () - -runO' :: IO a -> IO CompGraph -runO' program = {- SCC "runO" -} do - args <- getArgs - setPushMode (parseArgs args) - hPutStrLn stderr "=== program output ===\n" - cdss <- debugO program - let cdss1 = rmEntrySet cdss - let cdss2 = simplifyCDSSet cdss1 - let eqs = ((sortBy byStack) . renderCompStmts) cdss2 - hPutStrLn stderr "\n=== CDS's before rendering === \n" - hPutStrLn stderr (show cdss2) - hPutStrLn stderr "\n=== Debug session === \n" - hPutStrLn stderr (showWithStack eqs) - return (mkGraph eqs) - -logO :: FilePath -> IO a -> IO () -logO filePath program = {- SCC "logO" -} do - compGraph <- runO' program - writeFile filePath (showGraph compGraph) - return () - - where showGraph g = showWith g showVertex showArc - showVertex Root = ("root","") - showVertex v = (showCompStmts v ++ "\nwith stack " - ++ (show . equStack . head . equations $ v), "") - showArc _ = "" - showCompStmts = showCompStmts' . equations - showCompStmts' [e] = show e - showCompStmts' es = foldl (\acc e-> acc ++ show e ++ ", ") "{" (init es) - ++ show (last es) ++ "}" - - -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 :: [(String,String)] -> CompGraph -> IO () -debugSession slices tree - = do createDirectoryIfMissing True ".Hoed/wwwroot/css" - writeFile ".Hoed/wwwroot/debug.css" stylesheet - treeRef <- newIORef tree - startGUI defaultConfig - { tpPort = Just 10000 - , tpStatic = Just "./.Hoed/wwwroot" - } (demoGUI slices treeRef) - - -stylesheet - = "div {\n" - ++ " padding:0;\n" - ++ " margin:0;\n" - ++ "}\n" - ++ ".buttons {\n" - ++ " float:top;\n" - ++ " height:50vh;\n" - ++ " overflow-y: scroll;\n" - ++ " overflow-x: hidden;\n" - ++ "}\n" - ++ ".nowrap {\n" - ++ " white-space: nowrap;\n" - ++ "}\n" - ++ ".odd {\n" - ++ " background-color: lightgray;\n" - ++ " padding: 10px 0;\n" - ++ "}\n" - ++ ".even {\n" - ++ " background-color: white;\n" - ++ " padding: 10px 0;\n" - ++ "}\n" diff --git a/Debug/Hoed/DemoGUI.hs b/Debug/Hoed/DemoGUI.hs deleted file mode 100644 --- a/Debug/Hoed/DemoGUI.hs +++ /dev/null @@ -1,286 +0,0 @@ --- This file is part of the Haskell debugger Hoed. --- --- Copyright (c) Maarten Faddegon, 2014 - -module Debug.Hoed.DemoGUI -where - -import Prelude hiding(Right) -import Debug.Hoed.Render -import Data.Graph.Libgraph -import qualified Graphics.UI.Threepenny as UI -import Graphics.UI.Threepenny (startGUI,defaultConfig, loadFile - , Window, UI, (#), (#+), (#.), string, on - ) -import System.Process(system) -import Data.IORef -import Data.List(intersperse,nub) -import Text.Regex.Posix - --------------------------------------------------------------------------------- - -preorder :: CompGraph -> [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) -> showCompStmts v - UI.element e # UI.set UI.text s - return () - -data Filter = ShowAll | ShowSucc | ShowPred | ShowMatch - -demoGUI :: [(String,String)] -> IORef CompGraph -> Window -> UI () -demoGUI sliceDict treeRef window - = do return window # UI.set UI.title "Hoed debugging session" - UI.addStyleSheet window "debug.css" - - -- Get a list of vertices from the computation graph - tree <- UI.liftIO $ readIORef treeRef - let ns = filter (not . isRoot) (preorder tree) - - -- Shared memory - filteredVerticesRef <- UI.liftIO $ newIORef ns - currentVertexRef <- UI.liftIO $ newIORef (0 :: Int) - regexRef <- UI.liftIO $ newIORef "" - - -- Draw the computation graph - img <- UI.img - redraw img treeRef (Just $ head ns) - 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 treeRef - on UI.selectionChange menu selectVertex' - - -- Buttons for the various filters - filterTxt <- UI.span # UI.set UI.text "Filters: " - showAllBut <- UI.button # UI.set UI.text "Show all" - showSuccBut <- UI.button # UI.set UI.text "Show successors" - showPredBut <- UI.button # UI.set UI.text "Show predecessors" - showMatchBut <- UI.button # UI.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 # UI.set UI.text "right" - wrong <- UI.button # UI.set UI.text "wrong" - let onJudge = onClick status menu img treeRef - currentVertexRef filteredVerticesRef - onJudge right Right - onJudge wrong Wrong - - -- Populate the main screen - hr <- UI.hr - UI.getBody window #+ (map UI.element [filters, menu, right, wrong, status - , compStmt, hr,img']) - return () - -updateMenu :: UI.Element -> IORef CompGraph - -> IORef Int -> IORef [Vertex] -> UI () -updateMenu menu treeRef currentVertexRef filteredVerticesRef = do - g <- UI.liftIO $ readIORef treeRef - i <- UI.liftIO $ readIORef currentVertexRef - ns <- UI.liftIO $ readIORef filteredVerticesRef - let fs = faultyVertices g - ops <- mapM (\s->UI.option # UI.set UI.text s) - $ if ns == [] then ["No matches found"] - else map (summarizeVertex fs) ns - (UI.element menu) # UI.set UI.children [] - UI.element menu #+ (map UI.element ops) - (UI.element menu) # UI.set UI.selection (Just i) - return () - -vertexFilter :: Filter -> CompGraph -> Vertex -> String -> [Vertex] -vertexFilter f g cv r = filter (not . isRoot) $ case f of - ShowAll -> preorder g - ShowSucc -> succs g cv - ShowPred -> preds g cv - ShowMatch -> filter matches (preorder g) - where matches Root = False - matches v = showCompStmts v =~ r - -onClick :: UI.Element -> UI.Element -> UI.Element - -> IORef CompGraph -> IORef Int -> IORef [Vertex] - -> UI.Element -> Judgement-> UI () -onClick status menu img treeRef currentVertexRef filteredVerticesRef b j = do - on UI.click b $ \_ -> do - (Just v) <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef - replaceFilteredVertex v (v{status=j}) - updateTree img 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 - m <- readIORef filteredVerticesRef - return $ if i < length m then Just (m !! i) else Nothing - --- onSelectVertex :: UI.Element -> UI.Element -> IORef [Vertex] -> IORef Int --- -> (IORef [Vertex] -> IORef Int -> UI ()) -> UI () --- onSelectVertex menu compStmt filteredVerticesRef currentVertexRef myRedraw = do --- on UI.selectionChange menu $ \mi -> case mi of --- Just i -> do UI.liftIO $ writeIORef currentVertexRef i --- showStmt compStmt filteredVerticesRef currentVertexRef --- myRedraw filteredVerticesRef currentVertexRef --- return () --- Nothing -> return () - -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 UI.liftIO $ writeIORef currentVertexRef i - showStmt compStmt filteredVerticesRef currentVertexRef - myRedraw filteredVerticesRef currentVertexRef - return () - Nothing -> return () - - -onClickFilter :: UI.Element -> IORef CompGraph -> 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 . isRoot) . 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 :: CompGraph -> Vertex -> Judgement -> CompGraph -markNode g v s = mapGraph f g - where f Root = Root - f v' = if v' === v then v{status=s} else v' - - (===) :: Vertex -> Vertex -> Bool - v1 === v2 = (equations v1) == (equations 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') - -showCompStmts :: Vertex -> String -showCompStmts = commas . map show . equations - -summarizeVertex :: [Vertex] -> Vertex -> String -summarizeVertex fs v = shorten (ShorterThan 27) (noNewlines $ showCompStmts v) ++ s - where s = if v `elem` fs then " !!" else case status v of - Unassessed -> " ??" - Wrong -> " :(" - Right -> " :)" - -updateStatus :: UI.Element -> IORef CompGraph -> UI () -updateStatus e compGraphRef = do - g <- UI.liftIO $ readIORef compGraphRef - let getLabel = commas . (map equLabel) . equations - isJudged v = status v /= Unassessed - slen = show . length - ns = filter (not . isRoot) (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 # UI.set UI.text txt - return () - -updateTree :: UI.Element -> IORef CompGraph -> (Maybe Vertex) -> (CompGraph -> CompGraph) - -> UI () -updateTree img treeRef mcv f - = do tree <- UI.liftIO $ readIORef treeRef - UI.liftIO $ writeIORef treeRef (f tree) - redraw img treeRef mcv - -redrawWith :: UI.Element -> IORef CompGraph -> IORef [Vertex] -> IORef Int -> UI () -redrawWith img treeRef filteredVerticesRef currentVertexRef = do - mv <- UI.liftIO $ lookupCurrentVertex currentVertexRef filteredVerticesRef - redraw img treeRef mv - -redraw :: UI.Element -> IORef CompGraph -> (Maybe Vertex) -> UI () -redraw img treeRef mcv - = do tree <- UI.liftIO $ readIORef treeRef - UI.liftIO $ writeFile ".Hoed/debugTree.dot" (shw $ summarize tree mcv) - UI.liftIO $ system $ "dot -Tpng -Gsize=9,5 -Gdpi=100 .Hoed/debugTree.dot " - ++ "> .Hoed/wwwroot/debugTree.png" - url <- UI.loadFile "image/png" ".Hoed/wwwroot/debugTree.png" - UI.element img # UI.set UI.src url - return () - - where shw g = showWith g (coloVertex $ faultyVertices g) showArc - coloVertex fs 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 :: CompGraph -> Maybe Vertex -> CompGraph -summarize g mcv = Graph (root g) keep as - where keep1 v = take 7 $ succs g v - keep' = nub $ Root : 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 - Root -> False - _ -> case mcv of - Nothing -> False - (Just Root) -> False - (Just w) -> equations v == equations w - -commas :: [String] -> String -commas [e] = e -commas es = foldl (\acc e-> acc ++ e ++ ", ") "{" (init es) - ++ show (last es) ++ "}" - -faultyVertices :: CompGraph -> [Vertex] -faultyVertices = findFaulty_dag getStatus - where getStatus Root = Right - getStatus v = status v diff --git a/Debug/Hoed/Observe.lhs b/Debug/Hoed/Observe.lhs deleted file mode 100644 --- a/Debug/Hoed/Observe.lhs +++ /dev/null @@ -1,1281 +0,0 @@ -\begin{code} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} - -\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.Observe - ( - -- * The main Hood API - - observeTempl - , observe - , 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 - , CallStack - , emptyStack - , Event(..) - , Change(..) - , Parent(..) - , ThreadId(..) - , Identifier(..) - , initUniq - , startEventStream - , endEventStream - , ourCatchAllIO - , peepUniq - , ccsToStrings - ) where -\end{code} - - -%************************************************************************ -%* * -\subsection{Imports and infixing} -%* * -%************************************************************************ - -\begin{code} -import Prelude hiding (Right) -import qualified Prelude -import System.IO -import Data.Maybe -import Control.Monad -import Data.Array as Array -import Data.List -import Data.Char -import System.Environment - -import Language.Haskell.TH -import GHC.Generics - -import Data.IORef -import System.IO.Unsafe - -import Control.Concurrent(takeMVar,putMVar,MVar,newMVar) -import qualified Control.Concurrent as Concurrent -\end{code} - -Needed to access the cost centre stack: -\begin{code} -import GHC.Stack (ccLabel, getCurrentCCS, CostCentreStack,ccsCC,ccsParent,currentCallStack) -import GHC.Foreign as GHC -import GHC.Ptr -\end{code} - -For the TracedMonad instance of IO: -\begin{code} -import GHC.Base hiding (mapM) --- import Control.Monad.ST(RealWorld) --- import Control.Monad.State(State) -\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 = undefined - --- Meta: Constructors -instance (GObservable a, Constructor c) => GObservable (M1 C c a) where - gdmobserver m@(M1 x) cxt = M1 (send (gdmShallowShow m) (gdmObserveChildren x) cxt) - gdmObserveChildren = gthunk - gdmShallowShow = conName - --- Meta: Selectors --- | selName m == "" = M1 y --- | otherwise = M1 (send (selName m) (return y) cxt) -instance (GObservable a, Selector s) => GObservable (M1 S s a) where - gdmobserver m@(M1 x) cxt - | selName m == "" = M1 (gdmobserver x cxt) - | otherwise = M1 (send (selName m ++ " =") (gdmObserveChildren x) cxt) - gdmObserveChildren = gthunk - gdmShallowShow = undefined - --- Unit: used for constructors without arguments -instance GObservable U1 where - gdmobserver x _ = x - gdmObserveChildren = return - gdmShallowShow = undefined - --- Products: encode multiple arguments to constructors -instance (GObservable a, GObservable b) => GObservable (a :*: b) where - gdmobserver (a :*: b) cxt = error "gdmobserver product" - - gdmObserveChildren (a :*: b) = do a' <- gdmObserveChildren a - b' <- gdmObserveChildren b - return (a' :*: b') - - gdmShallowShow = undefined - --- Sums: encode choice between constructors -instance (GObservable a, GObservable b) => GObservable (a :+: b) where - gdmobserver (L1 x) cxt = L1 (gdmobserver x cxt) - gdmobserver (R1 x) cxt = R1 (gdmobserver x cxt) - - gdmObserveChildren (R1 x) = do {x' <- gdmObserveChildren x; return (R1 x')} - gdmObserveChildren (L1 x) = do {x' <- gdmObserveChildren x; return (L1 x')} - - gdmShallowShow = undefined - --- Constants: additional parameters and recursion of kind * -instance (Observable a) => GObservable (K1 i a) where - gdmobserver (K1 x) cxt = K1 (observer_ observer x cxt) - - gdmObserveChildren = gthunk - - gdmShallowShow = undefined -\end{code} - -Observing functions is done via the ad-hoc mechanism, because -we provide an instance definition the default is ignored for -this type. - -\begin{code} -instance (Observable a,Observable b) => Observable (a -> b) where - observer fn cxt arg = gdmFunObserver cxt fn arg -\end{code} - -Observing the children of Data types of kind *->*. - -\begin{code} -gdmFunObserver :: (Observable a,Observable b) => Parent -> (a->b) -> (a->b) -gdmFunObserver cxt fn arg - = let (app,stack) = getStack - $ sendObserveFnPacket stack - (do arg' <- thunk observer arg - thunk observer (fn arg') - ) cxt - in app -\end{code} - - - - -%************************************************************************ -%* * -\subsection{Cost Centre Stack} -%* * -%************************************************************************ - -\begin{code} - -type CallStack = [String] -emptyStack = [""] - -{-# NOINLINE getStack #-} -getStack :: a -> (a, CallStack) -getStack x = let stack = unsafePerformIO - $ do {ccs <- getCurrentCCS (); ccsToStrings ccs} - in (x, rev stack) - where rev [] = [] - -- rev s = reverse (tail s) - rev (h:s) = let s' = case h of "CAF" -> s - _ -> h:s - in reverse s' - - -ccsToStrings :: Ptr CostCentreStack -> IO [String] -ccsToStrings ccs0 = go ccs0 [] - where - go ccs acc - | ccs == nullPtr = return acc - | otherwise = do - cc <- ccsCC ccs - lbl <- GHC.peekCString utf8 =<< ccLabel cc - parent <- ccsParent ccs - if (lbl == "MAIN") - then return acc - else go parent (lbl : acc) - - -\end{code} - - -%************************************************************************ -%* * -\subsection{Generics} -%* * -%************************************************************************ - -Generate a new observe from generated observers and the gobserve mechanism. -Where gobserve is the 'classic' observe but parametrized. - -\begin{code} -observeTempl :: String -> Q Exp -observeTempl s = do n <- methodName s - let f = return $ VarE n - s' = stringE s - [| (\x-> fst (gobserve $f DoNotTraceThreadId UnknownId $s' x)) |] -\end{code} - -Generate class definition and class instances for list of types. - -\begin{code} -observedTypes :: String -> [Q Type] -> Q [Dec] -observedTypes s qt = do cd <- (genClassDef s) - ci <- foldM f [] qt - bi <- foldM g [] baseTypes - fi <- (gfunObserver s) - -- 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] - -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 - -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 [| let (app,stack) = getStack - $ sendObserveFnPacket stack - ( do a' <- thunk $(varE n) $a - thunk $(varE n) ($f a') - ) $c - in app - |] - ) [] - } - -gobserverFun :: Q Name -> Q [Dec] -gobserverFun qn - = do n <- qn - c <- gobserverFunClause n - cs <- return [c] - return [FunD n cs] - -gfunObserver :: String -> Q [Dec] -gfunObserver s - = do cn <- className s - let ct = conT cn - a = VarT (mkName "a") - b = VarT (mkName "b") - f = return $ AppT (AppT ArrowT a) b - p <- return $ AppT (ConT cn) a - q <- return $ AppT (ConT cn) b - 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 --- TH<2.10: isObservableP (ClassP n _) = return $ (nameBase n) == "Observable" -isObservableP (AppT (ConT n) _) = return $ (nameBase n) == "Observable" -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 - return $ case p of (AppT (ConT n) t) -> p : pbs - _ -> pbs - --- Given a parametrized type, get a list with its type variables --- e.g. [a,b] in (MyData a b) Int Float - -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] - -classpObservable :: [Type] -> Type -classpObservable = foldl AppT (ConT (mkName "Observable")) - -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 "" (return return << res) cxt -\end{code} - - - -The Exception *datatype* (not exceptions themselves!). - -\begin{code} -instance Observable SomeException where - observer e = send (" " ++ show e) (return e) - --- instance Observable ErrorCall where --- observer (ErrorCall a) = send "ErrorCall" (return ErrorCall << a) - - -instance Observable Dynamic where { observer = observeOpaque "" } -\end{code} - - -%************************************************************************ -%* * -\subsection{Classes and Data Definitions} -%* * -%************************************************************************ - -\begin{code} -type Observing a = a -> a -\end{code} - -MF: when do we need this type? - -\begin{code} -newtype Observer = O (forall a . (Observable a) => String -> a -> a) - --- defaultObservers :: (Observable a) => String -> (Observer -> a) -> a --- defaultObservers label fn = unsafeWithUniq $ \ node -> --- do { sendEvent node (Parent 0 0) (Observe label ThreadIdUnknown) --- ; let observe' sublabel a --- = unsafeWithUniq $ \ subnode -> --- do { sendEvent subnode (Parent node 0) --- (Observe sublabel ThreadIdUnknown) --- ; return (observer_ observer a (Parent --- { observeParent = subnode --- , observePort = 0 --- })) --- } --- ; return (observer_ observer (fn (O observe')) --- (Parent --- { observeParent = node --- , observePort = 0 --- })) --- } --- defaultFnObservers :: (Observable a, Observable b) --- => String -> (Observer -> a -> b) -> a -> b --- defaultFnObservers label fn arg = unsafeWithUniq $ \ node -> --- do { sendEvent node (Parent 0 0) (Observe label ThreadIdUnknown) --- ; let observe' sublabel a --- = unsafeWithUniq $ \ subnode -> --- do { sendEvent subnode (Parent node 0) --- (Observe sublabel ThreadIdUnknown) --- ; return (observer_ observer a (Parent --- { observeParent = subnode --- , observePort = 0 --- })) --- } --- ; return (observer_ observer (fn (O observe')) --- (Parent --- { observeParent = node --- , observePort = 0 --- }) arg) --- } -\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 - -instance Applicative ObserverM where - pure = return - (<*>) = ap - -instance Monad ObserverM where - return a = ObserverM (\ c i -> (a,i)) - fn >>= k = ObserverM (\ c i -> - case runMO fn c i of - (r,i2) -> runMO (k r) c i2 - ) - -thunk :: (a -> Parent -> a) -> a -> ObserverM a -thunk f a = ObserverM $ \ parent port -> - ( observer_ f a (Parent - { observeParent = parent - , observePort = port - }) - , port+1 ) - -gthunk :: (GObservable f) => f a -> ObserverM (f a) -gthunk a = ObserverM $ \ parent port -> - ( gdmobserver_ a (Parent - { observeParent = parent - , observePort = port - }) - , port+1 ) - -nothunk :: a -> ObserverM a -nothunk a = ObserverM $ \ parent port -> - ( observer__ a (Parent - { observeParent = parent - , observePort = port - }) - , port+1 ) - - -(<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b --- fn << a = 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 -> Identifier -> String -> a -> (a,Int) -gobserve f tti d name a = generateContext f tti d 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 UnknownId lbl) - -{-# NOINLINE observeCC #-} -observeCC :: (Observable a) => String -> a -> a -observeCC lbl = fst . (gobserve observer TraceThreadId UnknownId lbl) - -data Identifier = UnknownId | DependsJustOn Int | InSequenceAfter Int - deriving (Show, Eq, Ord) - -{-# NOINLINE observe' #-} -observe' :: (Observable a) => String -> Identifier -> a -> (a,Int) -observe' lbl d x = let (y,i) = (gobserve observer DoNotTraceThreadId d lbl) x - in (y, i) - -{- 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} - -\begin{code} -data Parent = Parent - { observeParent :: !Int -- my parent - , observePort :: !Int -- my branch number - } deriving (Show, Read) -root = Parent 0 0 -\end{code} - - -The functions that output the data. All are dirty. - -\begin{code} -unsafeWithUniq :: (Int -> IO a) -> a -unsafeWithUniq fn - = unsafePerformIO $ do { node <- getUniq - ; fn node - } -\end{code} - -\begin{code} -data TraceThreadId = TraceThreadId | DoNotTraceThreadId - -generateContext :: (a->Parent->a) -> TraceThreadId -> Identifier -> String -> a -> (a,Int) -generateContext f tti d label orig = unsafeWithUniq $ \ node -> - do { t <- myThreadId - ; sendEvent node (Parent 0 0) (Observe label t node d) - ; return (observer_ f orig (Parent - { observeParent = node - , observePort = 0 - }) - , node) - } - where myThreadId = case tti of - DoNotTraceThreadId -> return ThreadIdUnknown - TraceThreadId -> do t <- Concurrent.myThreadId - return (ThreadId t) - -send :: String -> ObserverM a -> Parent -> a -send consLabel fn context = unsafeWithUniq $ \ node -> - do { let (r,portCount) = runMO fn node 0 - ; sendEvent node context (Cons portCount consLabel) - ; return r - } - - -sendEnterPacket :: (a -> Parent -> a) -> a -> Parent -> a -sendEnterPacket f r context = unsafeWithUniq $ \ node -> - do { sendEvent node context Enter - ; ourCatchAllIO (evaluate (f r context)) - (handleExc context) - } - -gsendEnterPacket :: (GObservable f) => f a -> Parent -> f a -gsendEnterPacket r context = unsafeWithUniq $ \ node -> - do { sendEvent node context Enter - ; ourCatchAllIO (evaluate (gdmobserver r context)) - (handleExc context) - } - -sendNoEnterPacket :: a -> Parent -> a -sendNoEnterPacket r context = unsafeWithUniq $ \ node -> - do { sendEvent node context NoEnter - ; ourCatchAllIO (evaluate r) - (handleExc context) - } - -evaluate :: a -> IO a -evaluate a = a `seq` return a - - -sendObserveFnPacket :: CallStack -> ObserverM a -> Parent -> a -sendObserveFnPacket callStack fn context - = unsafeWithUniq $ \ node -> - do { let (r,_) = runMO fn node 0 - ; sendEvent node context (Fun callStack) - ; return r - } -\end{code} - - -%************************************************************************ -%* * -\subsection{Event stream} -%* * -%************************************************************************ - -Trival output functions - -\begin{code} -data Event = Event - { portId :: !Int - , parent :: !Parent - , change :: !Change - } - deriving (Show) - -data ThreadId = ThreadIdUnknown | ThreadId Concurrent.ThreadId - deriving (Show,Eq,Ord) - --- MF TODO: Shouldn't we just have the CallStack as part of Observe? -data Change - = Observe !String !ThreadId !Int !Identifier - | Cons !Int !String - | Enter - | NoEnter - | Fun !CallStack - deriving (Show) - -startEventStream :: IO () -startEventStream = writeIORef events [] - -endEventStream :: IO [Event] -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 () - } - - --- 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 = unsafePerformIO $ newIORef badEvents - -badEvents :: [Event] -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} -initUniq :: IO () -initUniq = writeIORef uniq 1 - -getUniq :: IO Int -getUniq - = do { takeMVar uniqSem - ; n <- readIORef uniq - ; writeIORef uniq $! (n + 1) - ; putMVar uniqSem () - ; return n - } - -peepUniq :: IO Int -peepUniq = readIORef uniq - --- locals -{-# NOINLINE uniq #-} -uniq :: IORef Int -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 [Event] --- 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} - -%************************************************************************ - -\begin{code} -(*>>=) :: Monad m => m a -> (Identifier -> (a -> m b, Int)) -> (m b, Identifier) -x *>>= f = let (g,i) = f UnknownId in (x >>= g,InSequenceAfter i) - -(>>==) :: Monad m => (m a, Identifier) -> (Identifier -> (a -> m b, Int)) -> (m b, Identifier) -(x,d) >>== f = let (g,i) = f d in (x >>= g,InSequenceAfter i) - -(>>=*) :: Monad m => (m a, Identifier) -> (Identifier -> (a -> m b, Int)) -> m b -(x,d) >>=* f = let (g,i) = f d in x >>= g -\end{code} diff --git a/Debug/Hoed/Render.hs b/Debug/Hoed/Render.hs deleted file mode 100644 --- a/Debug/Hoed/Render.hs +++ /dev/null @@ -1,627 +0,0 @@ --- This file is part of the Haskell debugger Hoed. --- --- Copyright (c) Maarten Faddegon, 2014 - -module Debug.Hoed.Render -(CompStmt(..) -,renderCompStmts -,byStack -,showWithStack - -,CompGraph(..) -,Vertex(..) -,mkGraph - -,CDS -,eventsToCDS -,rmEntrySet -,simplifyCDSSet -,isRoot -) -where - -import Prelude hiding(lookup) -import Debug.Hoed.Observe -import Data.List(sort,sortBy,partition,nub) -import Data.Graph.Libgraph -import Data.Array as Array -import Data.Tree.RBTree(RBTree(..),insertOrd,emptyRB,search) - -head' :: String -> [a] -> a -head' msg [] = error msg -head' _ xs = head xs - ------------------------------------------------------------------------- --- Render equations from CDS set - -renderCompStmts :: CDSSet -> [CompStmt] -renderCompStmts = map renderCompStmt - -renderCompStmt :: CDS -> CompStmt -renderCompStmt (CDSNamed name threadId identifier dependsOn set) - = CompStmt name threadId identifier dependsOn equation hstack - where equation = pretty 120 (commas doc) - (doc,stacks)= unzip rendered - rendered = map (renderNamedTop name) output - output = cdssToOutput set - commas [d] = d - commas ds = (foldl (\acc d -> acc <> d <> text ", ") (text "{") ds) <> text "}" - hstack = case stacks of - [] -> [] - (x:_) -> x - - --- renderCompStmt _ = CompStmt "??" ThreadIdUnknown (-1) UnknownId "??" emptyStack - -renderNamedTop :: String -> Output -> (DOC,CallStack) -renderNamedTop name (OutData cds) - = ( nest 2 $ foldl1 (\ a b -> a <> line <> text ", " <> b) (map (renderNamedFn name) pairs) - , callStack - ) - where (pairs',callStack) = findFn [cds] - pairs = (nub . (sort)) pairs' - -- local nub for sorted lists - nub [] = [] - nub (a:a':as) | a == a' = nub (a' : as) - nub (a:as) = a : nub as - -renderCallStack :: CallStack -> DOC -renderCallStack s - = text "With call stack: [" - <> foldl1 (\a b -> a <> text ", " <> b) - (map text s) - <> text "]" - ------------------------------------------------------------------------- --- The CompStmt type - -data CompStmt = CompStmt {equLabel :: String, equThreadId :: ThreadId - , equIdentifier :: Int, equDependsOn :: Identifier - , equRes :: String, equStack :: CallStack} - deriving (Eq, Ord) - -instance Show CompStmt where - show e = equRes e -- ++ " with stack " ++ show (equStack e) - showList eqs eq = unlines (map show eqs) ++ eq - -showWithStack :: [CompStmt] -> String -showWithStack eqs = unlines (map show' eqs) - where show' eq - = equRes eq ++ "\n\tWith call stack: " ++ showStack (equStack eq) - ++ "\n\tNext stack: " ++ showStack (nextStack eq) - ++ "\n\tThread id: " ++ show (equThreadId eq) - ++ "\n\tMy Obs id: " ++ show (equIdentifier eq) - ++ "\n\tDepends on Obs id: " ++ show (equDependsOn eq) - where showStack [] = "[-]" - showStack ss = (foldl (\s' s -> s' ++ s ++ ",") "[" ss) ++ "-]" - --- Compare equations by stack -byStack e1 e2 - = case compareStack (equStack e1) (equStack e2) of - EQ -> compare (equLabel e1) (equLabel e2) - d -> d - -compareStack s1 s2 - | l1 < l2 = LT - | l1 > l2 = GT - | l1 == l2 = c (zip s1 s2) - where l1 = length s1 - l2 = length s2 - c [] = EQ - c ((x,y):ss) = case compare x y of - EQ -> c ss - d -> d - ------------------------------------------------------------------------- --- Stack matching - --- nextStack = case getPushMode of --- Vanilla -> nextStack_vanilla --- Drop -> nextStack_drop --- Truncate -> nextStack_truncate -nextStack = nextStack_truncate - --- Always push onto top of stack -nextStack_vanilla :: CompStmt -> CallStack -nextStack_vanilla (CompStmt cc _ _ _ _ ccs) = cc:ccs - --- Drop on recursion -nextStack_drop :: CompStmt -> CallStack -nextStack_drop (CompStmt cc _ _ _ _ []) = [cc] -nextStack_drop (CompStmt cc _ _ _ _ ccs) - = if ccs `contains` cc - then ccs - else cc:ccs - --- Remove everything between recursion (e.g. [f,g,f,h] becomes [f,h]) -nextStack_truncate :: CompStmt -> CallStack -nextStack_truncate (CompStmt cc _ _ _ _ []) = [cc] -nextStack_truncate (CompStmt cc _ _ _ _ ccs) - = if ccs `contains` cc - then dropWhile (/= cc) ccs - else cc:ccs - -contains :: CallStack -> String -> Bool -contains ccs cc = filter (== cc) ccs /= [] - -call :: CallStack -> CallStack -> CallStack -call sApp sLam = sLam' ++ sApp - where (sPre,sApp',sLam') = commonPrefix sApp sLam - -commonPrefix :: CallStack -> CallStack -> (CallStack, CallStack, CallStack) -commonPrefix sApp sLam - = let (sPre,sApp',sLam') = span2 (==) (reverse sApp) (reverse sLam) - in (sPre, reverse sApp', reverse sLam') - -span2 :: (a -> a -> Bool) -> [a] -> [a] -> ([a], [a], [a]) -span2 f = s f [] - where s _ pre [] ys = (pre,[],ys) - s _ pre xs [] = (pre,xs,[]) - s f pre xs@(x:xs') ys@(y:ys') - | f x y = s f (x:pre) xs' ys' - | otherwise = (pre,xs,ys) - ------------------------------------------------------------------------- --- Bags are collections of computation statements with the same stack - -data Bag = Bag {bagStack :: CallStack, bagStmts :: [CompStmt]} - -instance Eq Bag where b1 == b2 = bagStack b1 == bagStack b2 -instance Ord Bag where compare b1 b2 = cmpStk (bagStack b1) (bagStack b2) - -bag :: (CompStmt -> CallStack) -> CompStmt -> Bag -bag s c = Bag (s c) [c] - -(+++) :: CompStmt -> Bag -> Bag -c +++ b = b{bagStmts = c : bagStmts b} - - -mkBags :: (CompStmt -> CallStack) -> [CompStmt] -> [Bag] -mkBags _ [] = [] -mkBags s cs = mkBags' (bag s fc) [] ocs - - where (fc:ocs) = sortBy (\c1 c2 -> cmpStk (s c1) (s c2)) cs - - mkBags' b bs [] = b:bs - mkBags' b bs (c:cs) - | bagStack b == s c = mkBags' (c +++ b) bs cs - | otherwise = mkBags' (bag s c) (b:bs) cs - ------------------------------------------------------------------------- --- RB trees to speed up computation graph construction - -type Tree = RBTree Bag - -mkTree :: (CompStmt -> CallStack) -> [CompStmt] -> Tree -mkTree s cs = foldl insertOrd emptyRB (mkBags s cs) - -mkTrees :: [CompStmt] -> (Tree,Tree) -mkTrees cs = (mkTree equStack cs, mkTree nextStack cs) - - -cmpStk :: CallStack -> CallStack -> Ordering -cmpStk [] [] = EQ -cmpStk s1 s2 = case compare (length s1) (length s2) of - EQ -> compare (head s1) (head s2) - ord -> ord - -lookup :: Tree -> CallStack -> [CompStmt] -lookup t s = case search (\s b -> cmpStk s (bagStack b)) t s of - (Just b) -> bagStmts b - Nothing -> [] - ------------------------------------------------------------------------- --- Inverse call - -stmts :: Tree -> (CallStack,CallStack) -> [(CompStmt,CompStmt)] -stmts t (s1,s2) = flattenStmts (lookup t s1, lookup t s2) - -flattenStmts :: ([a],[b]) -> [(a,b)] -flattenStmts (xs,ys) = foldl (\zs x->foldl (\zs' y->(x,y) : zs') zs ys) [] xs - -lacc :: CallStack -> [(CallStack,CallStack)] -lacc = expand . split - -expand :: [([a],[a])] -> [([a],[a])] -expand xs = foldl (\ys x -> ys ++ map (cat $ snd x) (expand' x)) [] xs - - where expand' (xs,[]) = [(xs,[])] - expand' (xs,y:ys) = (xs,y:ys) : expand' (xs,ys) - - cat sApp (xs,ys) = (sApp,xs++ys) - -split :: [a] -> [([a],[a])] -split [] = [] -split (x:xs) = split' [x] xs [] - - where split' _ [] zs = zs - split' xs (y:ys) zs = split' (xs++[y]) ys ((xs,y:ys):zs) - ------------------------------------------------------------------------- --- Computation graphs - -data Vertex = Root | Vertex {equations :: [CompStmt], status :: Judgement} - deriving (Eq,Show,Ord) - -type CompGraph = Graph Vertex () - -isRoot Root = True -isRoot _ = False - -pushDeps :: (Tree,Tree) -> [CompStmt] -> [Arc CompStmt ()] -pushDeps ts cs = concat (map (pushArcs ts) cs) - -pushArcs :: (Tree,Tree) -> CompStmt -> [Arc CompStmt ()] -pushArcs t p = map (\c -> p ==> c) (pushers t p) - where src ==> tgt = Arc src tgt () - -pushers :: (Tree,Tree) -> CompStmt -> [CompStmt] -pushers (ts,tn) c = lookup ts (nextStack c) - -callDeps :: (Tree,Tree) -> [CompStmt] -> [Arc CompStmt ()] -callDeps (_,t) cs = concat (map (callDep t) cs) - -callDep :: Tree -> CompStmt -> [Arc CompStmt ()] -callDep t c3 = foldl (\as (c2,c1) -> c1 ==> c2 : c2 ==> c3 : as) [] - (concat (map (stmts t) (lacc $ equStack c3))) - where src ==> tgt = Arc src tgt () - -mkGraph :: [CompStmt] -> CompGraph -mkGraph cs = {-# SCC "mkGraph" #-} (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!" - - nubArcs :: Graph CompStmt () -> Graph CompStmt () - nubArcs (Graph r vs as) = Graph r vs (nub as) - - sameThread :: Graph CompStmt () -> Graph CompStmt () - sameThread (Graph r vs as) = Graph r vs (filter (sameThread') as) - sameThread' (Arc v w _) - | equThreadId v == ThreadIdUnknown - || equThreadId w == ThreadIdUnknown - || equThreadId v == equThreadId w = True - | otherwise = False - - filterDependsJustOn :: Graph CompStmt () -> Graph CompStmt () - filterDependsJustOn (Graph r vs as) = Graph r vs (filter (filterDependsJustOn') as) - filterDependsJustOn' (Arc v w _) = case equDependsOn w of - (DependsJustOn i) -> i == equIdentifier v - _ -> True - - addSequenceDependencies :: Graph CompStmt () -> Graph CompStmt () - addSequenceDependencies (Graph r vs as) = Graph r vs (seqDeps vs ++ as) - seqDeps vs = [Arc v w () |v <- vs, w <- vs, seqDep v w] - seqDep v w = case equDependsOn w of - (InSequenceAfter i) -> i == equIdentifier v - _ -> False - - toVertices :: Graph CompStmt () -> CompGraph - toVertices = mapGraph (\s->Vertex [s] Unassessed) - - addRoot :: CompGraph -> CompGraph - addRoot (Graph _ vs as) = - let rs = filter (\(Vertex (s:_) _) -> equStack s == []) vs - es = map (\r -> Root ==> r) rs - in Graph Root (Root : vs) (es ++ as) - - merge :: [Vertex] -> Vertex - merge vs = let v = head' msgvs vs; cs' = map equations vs - in v{equations=foldl (++) [] cs'} - msgvs = "mkGraph.merge: No vertices to merge." - - src ==> tgt = Arc src tgt () - --- %************************************************************************ --- %* * --- \subsection{The CDS and converting functions} --- %* * --- %************************************************************************ - - -data CDS = CDSNamed String ThreadId Int Identifier CDSSet - | CDSCons Int String [CDSSet] - | CDSFun Int CDSSet CDSSet CallStack - | CDSEntered Int - | CDSTerminated Int - deriving (Show,Eq,Ord) - -type CDSSet = [CDS] - -eventsToCDS :: [Event] -> CDSSet -eventsToCDS pairs = getChild 0 0 - where - 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 change) - | (Event node _ change) <- pairs - ] - - getNode'' :: Int -> Change -> CDS - getNode'' node change = - case change of - (Observe str t i d) -> CDSNamed str t i d (getChild node 0) - (Enter) -> CDSEntered node - (NoEnter) -> CDSTerminated node - (Fun str) -> CDSFun node (getChild node 0) (getChild node 1) str - (Cons portc cons) - -> CDSCons node cons - [ getChild node n | n <- [0..(portc-1)]] - - 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 caller) pairs) <> - line <> text "}") - - where - (pairs',caller) = findFn cdss - pairs = (nub . sort) pairs' - -- local nub for sorted lists - nub [] = [] - nub (a:a':as) | a == a' = nub (a' : as) - nub (a:as) = a : nub as - -renderFn :: CallStack -> ([CDSSet],CDSSet) -> DOC -renderFn callStack (args, res) - = grp (nest 3 - (text "\\ " <> - foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b) - nil - args <> sep <> - text "-> " <> renderSet' 0 False res - ) - ) - -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 - ) - ) - - --- This is where the call stacks are merged. --- --- MF TODO: It would be beneficial for performance if we would only save the --- stack once at the top as we already do in the paper and our semantics test code - -findFn :: CDSSet -> ([([CDSSet],CDSSet)], CallStack) -findFn = foldr findFn' ([],[]) - -findFn' (CDSFun _ arg res caller) (rest,_) = - case findFn res of - ([(args',res')],caller') -> if caller' /= [] && caller' /= caller - then error "found two different stacks!" - else ((arg : args', res') : rest, caller) - _ -> (([arg], res) : rest, caller) -findFn' other (rest,caller) = (([],[other]) : rest, caller) - -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 d set) = CDSNamed str t i d (rmEntrySet set) -rmEntry (CDSCons i str sets) = CDSCons i str (map rmEntrySet sets) -rmEntry (CDSFun i a b str) = CDSFun i (rmEntrySet a) (rmEntrySet b) str -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 d set) = CDSNamed str t i d (simplifyCDSSet set) -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 str) = CDSFun 0 (simplifyCDSSet a) (simplifyCDSSet b) str - -simplifyCDS (CDSTerminated i) = (CDSCons 0 "" []) - -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) diff --git a/Debug/Hoed/Stk.hs b/Debug/Hoed/Stk.hs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/Stk.hs @@ -0,0 +1,252 @@ +{-| +Module : Debug.Hoed.Stk +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-2014 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. + +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. + +<> + +I work on this debugger in the context of my Ph.D. research. +Read more about the theory behind Hoed at . + +To use Hoed on your own program, annotate your program as described below. +For best results profiling is enabled and optimization disabled. +If you use cabal to build your project, this is be done with: + +> cabal configure --disable-optimization --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 . + +-} + +module Debug.Hoed.Stk + ( -- * Basic annotations + observe + , runO + , printO + + -- * Experimental annotations + , observeTempl + , observedTypes + , observeCC + , observe' + , Identifier(..) + ,(*>>=),(>>==),(>>=*) + , logO + + -- * The Observable class + , Observer(..) + , Observable(..) + , (<<) + , thunk + , nothunk + , send + , observeBase + , observeOpaque + , debugO + , CDS(..) + , Generic + ) where + + +import Debug.Hoed.Stk.Observe +import Debug.Hoed.Stk.Render +import Debug.Hoed.Stk.DemoGUI + +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 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 CDS structure (for when you want to write your own debugger). +debugO :: IO a -> IO [Event] +debugO program = + do { initUniq + ; startEventStream + ; let errorMsg e = "[Escaping Exception in Code : " ++ show e ++ "]" + ; ourCatchAllIO (do { program ; return () }) + (hPutStrLn stderr . errorMsg) + ; events <- endEventStream + ; return events + } + +-- | Short for @runO . print@. +printO :: (Show a) => a -> IO () +printO expr = runO (print expr) + +-- | 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 + let slices = [] -- MF TODO: this whole slices business should probably just go? + compGraph <- runO' program + debugSession slices compGraph + return () + +runO' :: IO a -> IO CompGraph +runO' program = {- SCC "runO" -} do + args <- getArgs + setPushMode (parseArgs args) + hPutStrLn stderr "=== program output ===\n" + events <- debugO program + let cdss = eventsToCDS events + let cdss1 = rmEntrySet cdss + let cdss2 = simplifyCDSSet cdss1 + let eqs = ((sortBy byStack) . renderCompStmts) cdss2 + let ct = mkGraph 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 $ "arc = " ++ show (length . arcs $ ct) + hPutStrLn stderr $ "d = " ++ show d + hPutStrLn stderr $ "b = " ++ show b + + hPutStrLn stderr "\n=== Debug session === \n" + hPutStrLn stderr (showWithStack eqs) + return ct + +leafs g = filter (\v -> succs g v == []) (vertices g) + +logO :: FilePath -> IO a -> IO () +logO filePath program = {- SCC "logO" -} do + compGraph <- runO' program + writeFile filePath (showGraph compGraph) + return () + + where showGraph g = showWith g showVertex showArc + showVertex Root = ("root","") + showVertex v = (showCompStmts v ++ "\nwith stack " + ++ (show . equStack . head . equations $ v), "") + showArc _ = "" + showCompStmts = showCompStmts' . equations + showCompStmts' [e] = show e + showCompStmts' es = foldl (\acc e-> acc ++ show e ++ ", ") "{" (init es) + ++ show (last es) ++ "}" + + + +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 :: [(String,String)] -> CompGraph -> IO () +debugSession slices tree + = do createDirectoryIfMissing True ".Hoed/wwwroot/css" + writeFile ".Hoed/wwwroot/debug.css" stylesheet + treeRef <- newIORef tree + startGUI defaultConfig + { jsPort = Just 10000 + , jsStatic = Just "./.Hoed/wwwroot" + } (demoGUI slices treeRef) + + +stylesheet + = "div {\n" + ++ " padding:0;\n" + ++ " margin:0;\n" + ++ "}\n" + ++ ".buttons {\n" + ++ " float:top;\n" + ++ " height:50vh;\n" + ++ " overflow-y: scroll;\n" + ++ " overflow-x: hidden;\n" + ++ "}\n" + ++ ".nowrap {\n" + ++ " white-space: nowrap;\n" + ++ "}\n" + ++ ".odd {\n" + ++ " background-color: lightgray;\n" + ++ " padding: 10px 0;\n" + ++ "}\n" + ++ ".even {\n" + ++ " background-color: white;\n" + ++ " padding: 10px 0;\n" + ++ "}\n" diff --git a/Debug/Hoed/Stk/DemoGUI.hs b/Debug/Hoed/Stk/DemoGUI.hs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/Stk/DemoGUI.hs @@ -0,0 +1,291 @@ +-- This file is part of the Haskell debugger Hoed. +-- +-- Copyright (c) Maarten Faddegon, 2014-2015 + +module Debug.Hoed.Stk.DemoGUI +where + +import Prelude hiding(Right) +import Debug.Hoed.Stk.Render +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 Data.List(intersperse,nub) +import Text.Regex.Posix + +-------------------------------------------------------------------------------- +-- The tabbed layout from which we select the different views + +preorder :: CompGraph -> [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) -> showCompStmts v + UI.element e # UI.set UI.text s + return () + +data Filter = ShowAll | ShowSucc | ShowPred | ShowMatch + +demoGUI :: [(String,String)] -> IORef CompGraph -> Window -> UI () +demoGUI sliceDict treeRef window + = do return window # UI.set UI.title "Hoed debugging session" + UI.addStyleSheet window "debug.css" + + -- Get a list of vertices from the computation graph + tree <- UI.liftIO $ readIORef treeRef + let ns = filter (not . isRoot) (preorder tree) + + -- Shared memory + filteredVerticesRef <- UI.liftIO $ newIORef ns + currentVertexRef <- UI.liftIO $ newIORef (0 :: Int) + regexRef <- UI.liftIO $ newIORef "" + imgCountRef <- UI.liftIO $ newIORef (0 :: Int) + + -- Draw the computation graph + img <- UI.img + redraw img imgCountRef treeRef (Just $ head ns) + 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 # UI.set UI.text "Filters: " + showAllBut <- UI.button # UI.set UI.text "Show all" + showSuccBut <- UI.button # UI.set UI.text "Show successors" + showPredBut <- UI.button # UI.set UI.text "Show predecessors" + showMatchBut <- UI.button # UI.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 # UI.set UI.text "right" + wrong <- UI.button # UI.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.getBody window #+ (map UI.element [filters, menu, right, wrong, status + , compStmt, hr,img']) + return () + +updateMenu :: UI.Element -> IORef CompGraph + -> IORef Int -> IORef [Vertex] -> UI () +updateMenu menu treeRef currentVertexRef filteredVerticesRef = do + g <- UI.liftIO $ readIORef treeRef + i <- UI.liftIO $ readIORef currentVertexRef + ns <- UI.liftIO $ readIORef filteredVerticesRef + let fs = faultyVertices g + ops <- mapM (\s->UI.option # UI.set UI.text s) + $ if ns == [] then ["No matches found"] + else map (summarizeVertex fs) ns + (UI.element menu) # UI.set UI.children [] + UI.element menu #+ (map UI.element ops) + (UI.element menu) # UI.set UI.selection (Just i) + return () + +vertexFilter :: Filter -> CompGraph -> Vertex -> String -> [Vertex] +vertexFilter f g cv r = filter (not . isRoot) $ case f of + ShowAll -> preorder g + ShowSucc -> succs g cv + ShowPred -> preds g cv + ShowMatch -> filter matches (preorder g) + where matches Root = False + matches v = showCompStmts v =~ r + +onClick :: UI.Element -> UI.Element -> UI.Element + -> IORef Int -> IORef CompGraph -> 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{status=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 + m <- readIORef filteredVerticesRef + return $ if i < length m then Just (m !! i) else Nothing + +-- onSelectVertex :: UI.Element -> UI.Element -> IORef [Vertex] -> IORef Int +-- -> (IORef [Vertex] -> IORef Int -> UI ()) -> UI () +-- onSelectVertex menu compStmt filteredVerticesRef currentVertexRef myRedraw = do +-- on UI.selectionChange menu $ \mi -> case mi of +-- Just i -> do UI.liftIO $ writeIORef currentVertexRef i +-- showStmt compStmt filteredVerticesRef currentVertexRef +-- myRedraw filteredVerticesRef currentVertexRef +-- return () +-- Nothing -> return () + +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 UI.liftIO $ writeIORef currentVertexRef i + showStmt compStmt filteredVerticesRef currentVertexRef + myRedraw filteredVerticesRef currentVertexRef + return () + Nothing -> return () + + +onClickFilter :: UI.Element -> IORef CompGraph -> 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 . isRoot) . 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 :: CompGraph -> Vertex -> Judgement -> CompGraph +markNode g v s = mapGraph f g + where f Root = Root + f v' = if v' === v then v{status=s} else v' + + (===) :: Vertex -> Vertex -> Bool + v1 === v2 = (equations v1) == (equations 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') + +showCompStmts :: Vertex -> String +showCompStmts = commas . map show . equations + +summarizeVertex :: [Vertex] -> Vertex -> String +summarizeVertex fs v = shorten (ShorterThan 27) (noNewlines $ showCompStmts v) ++ s + where s = if v `elem` fs then " !!" else case status v of + Unassessed -> " ??" + Wrong -> " :(" + Right -> " :)" + +updateStatus :: UI.Element -> IORef CompGraph -> UI () +updateStatus e compGraphRef = do + g <- UI.liftIO $ readIORef compGraphRef + let getLabel = commas . (map equLabel) . equations + isJudged v = status v /= Unassessed + slen = show . length + ns = filter (not . isRoot) (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 # UI.set UI.text txt + return () + +updateTree :: UI.Element -> IORef Int -> IORef CompGraph -> (Maybe Vertex) -> (CompGraph -> CompGraph) + -> 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 CompGraph -> 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 CompGraph -> (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 = ( "\"" ++ 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 :: CompGraph -> Maybe Vertex -> CompGraph +summarize g mcv = Graph (root g) keep as + where keep1 v = take 7 $ succs g v + keep' = nub $ Root : 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 + Root -> False + _ -> case mcv of + Nothing -> False + (Just Root) -> False + (Just w) -> equations v == equations w + +commas :: [String] -> String +commas [e] = e +commas es = foldl (\acc e-> acc ++ e ++ ", ") "{" (init es) + ++ show (last es) ++ "}" + +faultyVertices :: CompGraph -> [Vertex] +faultyVertices = findFaulty_dag getStatus + where getStatus Root = Right + getStatus v = status v diff --git a/Debug/Hoed/Stk/Observe.lhs b/Debug/Hoed/Stk/Observe.lhs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/Stk/Observe.lhs @@ -0,0 +1,1313 @@ +\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.Stk.Observe + ( + -- * The main Hood API + + observeTempl + , observe + , 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 + , CallStack + , emptyStack + , Event(..) + , Change(..) + , Parent(..) + , ThreadId(..) + , Identifier(..) + , initUniq + , startEventStream + , endEventStream + , ourCatchAllIO + , peepUniq + , ccsToStrings + ) where +\end{code} + + +%************************************************************************ +%* * +\subsection{Imports and infixing} +%* * +%************************************************************************ + +\begin{code} +import Prelude hiding (Right) +import qualified Prelude +import System.IO +import Data.Maybe +import Control.Monad +import Data.Array as Array +import Data.List +import Data.Char +import System.Environment + +import Language.Haskell.TH +import GHC.Generics + +import Data.IORef +import System.IO.Unsafe + +import Control.Concurrent(takeMVar,putMVar,MVar,newMVar) +import qualified Control.Concurrent as Concurrent +\end{code} + +Needed to access the cost centre stack: +\begin{code} +import GHC.Stack (ccLabel, getCurrentCCS, CostCentreStack,ccsCC,ccsParent,currentCallStack) +import GHC.Foreign as GHC +import GHC.Ptr +\end{code} + +For the TracedMonad instance of IO: +\begin{code} +import GHC.Base hiding (mapM) +-- import Control.Monad.ST(RealWorld) +-- import Control.Monad.State(State) +\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 = undefined + +-- Meta: Constructors +instance (GObservable a, Constructor c) => GObservable (M1 C c a) where + gdmobserver m@(M1 x) cxt = M1 (send (gdmShallowShow m) (gdmObserveChildren x) cxt) + gdmObserveChildren = gthunk + gdmShallowShow = conName + +-- Meta: Selectors +-- | selName m == "" = M1 y +-- | otherwise = M1 (send (selName m) (return y) cxt) +instance (GObservable a, Selector s) => GObservable (M1 S s a) where + gdmobserver m@(M1 x) cxt + | selName m == "" = M1 (gdmobserver x cxt) + | otherwise = M1 (send (selName m ++ " =") (gdmObserveChildren x) cxt) + gdmObserveChildren = gthunk + gdmShallowShow = undefined + +-- Unit: used for constructors without arguments +instance GObservable U1 where + gdmobserver x _ = x + gdmObserveChildren = return + gdmShallowShow = undefined + +-- Products: encode multiple arguments to constructors +instance (GObservable a, GObservable b) => GObservable (a :*: b) where + gdmobserver (a :*: b) cxt = error "gdmobserver product" + + gdmObserveChildren (a :*: b) = do a' <- gdmObserveChildren a + b' <- gdmObserveChildren b + return (a' :*: b') + + gdmShallowShow = undefined + +-- Sums: encode choice between constructors +instance (GObservable a, GObservable b) => GObservable (a :+: b) where + gdmobserver (L1 x) cxt = L1 (gdmobserver x cxt) + gdmobserver (R1 x) cxt = R1 (gdmobserver x cxt) + + gdmObserveChildren (R1 x) = do {x' <- gdmObserveChildren x; return (R1 x')} + gdmObserveChildren (L1 x) = do {x' <- gdmObserveChildren x; return (L1 x')} + + gdmShallowShow = undefined + +-- Constants: additional parameters and recursion of kind * +instance (Observable a) => GObservable (K1 i a) where + gdmobserver (K1 x) cxt = K1 (observer_ observer x cxt) + + gdmObserveChildren = gthunk + + gdmShallowShow = undefined +\end{code} + +Observing functions is done via the ad-hoc mechanism, because +we provide an instance definition the default is ignored for +this type. + +\begin{code} +instance (Observable a,Observable b) => Observable (a -> b) where + observer fn cxt arg = gdmFunObserver cxt fn arg +\end{code} + +Observing the children of Data types of kind *->*. + +\begin{code} +gdmFunObserver :: (Observable a,Observable b) => Parent -> (a->b) -> (a->b) +gdmFunObserver cxt fn arg + = let (app,stack) = getStack + $ sendObserveFnPacket stack + (do arg' <- thunk observer arg + thunk observer (fn arg') + ) cxt + in app +\end{code} + + + + +%************************************************************************ +%* * +\subsection{Cost Centre Stack} +%* * +%************************************************************************ + +\begin{code} + +type CallStack = [String] +emptyStack = [""] + +{-# NOINLINE getStack #-} +getStack :: a -> (a, CallStack) +getStack x = let stack = unsafePerformIO + $ do {ccs <- getCurrentCCS (); ccsToStrings ccs} + in (x, rev stack) + where rev [] = [] + -- rev s = reverse (tail s) + rev (h:s) = let s' = case h of "CAF" -> s + _ -> h:s + in reverse s' + + +ccsToStrings :: Ptr CostCentreStack -> IO [String] +ccsToStrings ccs0 = go ccs0 [] + where + go ccs acc + | ccs == nullPtr = return acc + | otherwise = do + cc <- ccsCC ccs + lbl <- GHC.peekCString utf8 =<< ccLabel cc + parent <- ccsParent ccs + if (lbl == "MAIN") + then return acc + else go parent (lbl : acc) + + +\end{code} + + +%************************************************************************ +%* * +\subsection{Generics} +%* * +%************************************************************************ + +Generate a new observe from generated observers and the gobserve mechanism. +Where gobserve is the 'classic' observe but parametrized. + +\begin{code} +observeTempl :: String -> Q Exp +observeTempl s = do n <- methodName s + let f = return $ VarE n + s' = stringE s + [| (\x-> fst (gobserve $f DoNotTraceThreadId UnknownId $s' x)) |] +\end{code} + +Generate class definition and class instances for list of types. + +\begin{code} +observedTypes :: String -> [Q Type] -> Q [Dec] +observedTypes s qt = do cd <- (genClassDef s) + ci <- foldM f [] qt + bi <- foldM g [] baseTypes + fi <- (gfunObserver s) + -- 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 [| let (app,stack) = getStack + $ sendObserveFnPacket stack + ( do a' <- thunk $(varE n) $a + thunk $(varE n) ($f a') + ) $c + in app + |] + ) [] + } + +gobserverFun :: Q Name -> Q [Dec] +gobserverFun qn + = do n <- qn + c <- gobserverFunClause n + cs <- return [c] + return [FunD n cs] + +gfunObserver :: String -> Q [Dec] +gfunObserver s + = do cn <- className s + let ct = conT cn + a = VarT (mkName "a") + b = VarT (mkName "b") + f = return $ AppT (AppT ArrowT a) b +#if __GLASGOW_HASKELL__ >= 710 + p <- return $ AppT (ConT cn) a + q <- return $ AppT (ConT cn) b +#else + let a' = return a + b' = return b + p <- return $ ClassP cn a' + q <- return $ ClassP cn b' +#endif + c <- return [p,q] + n <- [t| $ct $f |] + m <- gobserverFun (methodName s) + return [InstanceD c n m] + +\end{code} + +Creating a shallow representation for types of the Data class. + +\begin{code} +shallowShow :: Con -> ExpQ +shallowShow (NormalC name _) + = stringE (case (nameBase name) of "(,)" -> ","; s -> s) +\end{code} + +Observing the children of Data types of kind *. + +Note how we are forced to add the extra 'vars' argument that should +have the same unique name as the corresponding pattern. + +To implement observeChildren we also define a mapM and compositionM function. +To our knowledge there is no existing work that do this in a generic fashion +with Template Haskell. + +\begin{code} + +isObservable :: TyVarMap -> Type -> Type -> Q Bool +-- 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 "" (return return << res) cxt +\end{code} + + + +The Exception *datatype* (not exceptions themselves!). + +\begin{code} +instance Observable SomeException where + observer e = send (" " ++ show e) (return e) + +-- instance Observable ErrorCall where +-- observer (ErrorCall a) = send "ErrorCall" (return ErrorCall << a) + + +instance Observable Dynamic where { observer = observeOpaque "" } +\end{code} + + +%************************************************************************ +%* * +\subsection{Classes and Data Definitions} +%* * +%************************************************************************ + +\begin{code} +type Observing a = a -> a +\end{code} + +MF: when do we need this type? + +\begin{code} +newtype Observer = O (forall a . (Observable a) => String -> a -> a) + +-- defaultObservers :: (Observable a) => String -> (Observer -> a) -> a +-- defaultObservers label fn = unsafeWithUniq $ \ node -> +-- do { sendEvent node (Parent 0 0) (Observe label ThreadIdUnknown) +-- ; let observe' sublabel a +-- = unsafeWithUniq $ \ subnode -> +-- do { sendEvent subnode (Parent node 0) +-- (Observe sublabel ThreadIdUnknown) +-- ; return (observer_ observer a (Parent +-- { observeParent = subnode +-- , observePort = 0 +-- })) +-- } +-- ; return (observer_ observer (fn (O observe')) +-- (Parent +-- { observeParent = node +-- , observePort = 0 +-- })) +-- } +-- defaultFnObservers :: (Observable a, Observable b) +-- => String -> (Observer -> a -> b) -> a -> b +-- defaultFnObservers label fn arg = unsafeWithUniq $ \ node -> +-- do { sendEvent node (Parent 0 0) (Observe label ThreadIdUnknown) +-- ; let observe' sublabel a +-- = unsafeWithUniq $ \ subnode -> +-- do { sendEvent subnode (Parent node 0) +-- (Observe sublabel ThreadIdUnknown) +-- ; return (observer_ observer a (Parent +-- { observeParent = subnode +-- , observePort = 0 +-- })) +-- } +-- ; return (observer_ observer (fn (O observe')) +-- (Parent +-- { observeParent = node +-- , observePort = 0 +-- }) arg) +-- } +\end{code} + + +%************************************************************************ +%* * +\subsection{The ObserveM Monad} +%* * +%************************************************************************ + +The Observer monad, a simple state monad, +for placing numbers on sub-observations. + +\begin{code} +newtype ObserverM a = ObserverM { runMO :: Int -> Int -> (a,Int) } + +instance Functor ObserverM where + fmap = liftM + +#if __GLASGOW_HASKELL__ >= 710 +instance Applicative ObserverM where + pure = return + (<*>) = ap +#endif + +instance Monad ObserverM where + return a = ObserverM (\ c i -> (a,i)) + fn >>= k = ObserverM (\ c i -> + case runMO fn c i of + (r,i2) -> runMO (k r) c i2 + ) + +thunk :: (a -> Parent -> a) -> a -> ObserverM a +thunk f a = ObserverM $ \ parent port -> + ( observer_ f a (Parent + { observeParent = parent + , observePort = port + }) + , port+1 ) + +gthunk :: (GObservable f) => f a -> ObserverM (f a) +gthunk a = ObserverM $ \ parent port -> + ( gdmobserver_ a (Parent + { observeParent = parent + , observePort = port + }) + , port+1 ) + +nothunk :: a -> ObserverM a +nothunk a = ObserverM $ \ parent port -> + ( observer__ a (Parent + { observeParent = parent + , observePort = port + }) + , port+1 ) + + +(<<) :: (Observable a) => ObserverM (a -> b) -> a -> ObserverM b +-- fn << a = 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 -> Identifier -> String -> a -> (a,Int) +gobserve f tti d name a = generateContext f tti d 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 UnknownId lbl) + +{-# NOINLINE observeCC #-} +observeCC :: (Observable a) => String -> a -> a +observeCC lbl = fst . (gobserve observer TraceThreadId UnknownId lbl) + +data Identifier = UnknownId | DependsJustOn Int | InSequenceAfter Int + deriving (Show, Eq, Ord) + +{-# NOINLINE observe' #-} +observe' :: (Observable a) => String -> Identifier -> a -> (a,Int) +observe' lbl d x = let (y,i) = (gobserve observer DoNotTraceThreadId d lbl) x + in (y, i) + +{- 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} + +\begin{code} +data Parent = Parent + { observeParent :: !Int -- my parent + , observePort :: !Int -- my branch number + } deriving (Show, Read) +root = Parent 0 0 +\end{code} + + +The functions that output the data. All are dirty. + +\begin{code} +unsafeWithUniq :: (Int -> IO a) -> a +unsafeWithUniq fn + = unsafePerformIO $ do { node <- getUniq + ; fn node + } +\end{code} + +\begin{code} +data TraceThreadId = TraceThreadId | DoNotTraceThreadId + +generateContext :: (a->Parent->a) -> TraceThreadId -> Identifier -> String -> a -> (a,Int) +generateContext f tti d label orig = unsafeWithUniq $ \ node -> + do { t <- myThreadId + ; sendEvent node (Parent 0 0) (Observe label t node d) + ; return (observer_ f orig (Parent + { observeParent = node + , observePort = 0 + }) + , node) + } + where myThreadId = case tti of + DoNotTraceThreadId -> return ThreadIdUnknown + TraceThreadId -> do t <- Concurrent.myThreadId + return (ThreadId t) + +send :: String -> ObserverM a -> Parent -> a +send consLabel fn context = unsafeWithUniq $ \ node -> + do { let (r,portCount) = runMO fn node 0 + ; sendEvent node context (Cons portCount consLabel) + ; return r + } + + +sendEnterPacket :: (a -> Parent -> a) -> a -> Parent -> a +sendEnterPacket f r context = unsafeWithUniq $ \ node -> + do { sendEvent node context Enter + ; ourCatchAllIO (evaluate (f r context)) + (handleExc context) + } + +gsendEnterPacket :: (GObservable f) => f a -> Parent -> f a +gsendEnterPacket r context = unsafeWithUniq $ \ node -> + do { sendEvent node context Enter + ; ourCatchAllIO (evaluate (gdmobserver r context)) + (handleExc context) + } + +sendNoEnterPacket :: a -> Parent -> a +sendNoEnterPacket r context = unsafeWithUniq $ \ node -> + do { sendEvent node context NoEnter + ; ourCatchAllIO (evaluate r) + (handleExc context) + } + +evaluate :: a -> IO a +evaluate a = a `seq` return a + + +sendObserveFnPacket :: CallStack -> ObserverM a -> Parent -> a +sendObserveFnPacket callStack fn context + = unsafeWithUniq $ \ node -> + do { let (r,_) = runMO fn node 0 + ; sendEvent node context (Fun callStack) + ; return r + } +\end{code} + + +%************************************************************************ +%* * +\subsection{Event stream} +%* * +%************************************************************************ + +Trival output functions + +\begin{code} +data Event = Event + { portId :: !Int + , parent :: !Parent + , change :: !Change + } + deriving (Show) + +data ThreadId = ThreadIdUnknown | ThreadId Concurrent.ThreadId + deriving (Show,Eq,Ord) + +-- MF TODO: Shouldn't we just have the CallStack as part of Observe? +data Change + = Observe !String !ThreadId !Int !Identifier + | Cons !Int !String + | Enter + | NoEnter + | Fun !CallStack + deriving (Show) + +startEventStream :: IO () +startEventStream = writeIORef events [] + +endEventStream :: IO [Event] +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 () + } + + +-- 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 = unsafePerformIO $ newIORef badEvents + +badEvents :: [Event] +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} +initUniq :: IO () +initUniq = writeIORef uniq 1 + +getUniq :: IO Int +getUniq + = do { takeMVar uniqSem + ; n <- readIORef uniq + ; writeIORef uniq $! (n + 1) + ; putMVar uniqSem () + ; return n + } + +peepUniq :: IO Int +peepUniq = readIORef uniq + +-- locals +{-# NOINLINE uniq #-} +uniq :: IORef Int +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 [Event] +-- 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} + +%************************************************************************ + +\begin{code} +(*>>=) :: Monad m => m a -> (Identifier -> (a -> m b, Int)) -> (m b, Identifier) +x *>>= f = let (g,i) = f UnknownId in (x >>= g,InSequenceAfter i) + +(>>==) :: Monad m => (m a, Identifier) -> (Identifier -> (a -> m b, Int)) -> (m b, Identifier) +(x,d) >>== f = let (g,i) = f d in (x >>= g,InSequenceAfter i) + +(>>=*) :: Monad m => (m a, Identifier) -> (Identifier -> (a -> m b, Int)) -> m b +(x,d) >>=* f = let (g,i) = f d in x >>= g +\end{code} diff --git a/Debug/Hoed/Stk/Render.hs b/Debug/Hoed/Stk/Render.hs new file mode 100644 --- /dev/null +++ b/Debug/Hoed/Stk/Render.hs @@ -0,0 +1,627 @@ +-- This file is part of the Haskell debugger Hoed. +-- +-- Copyright (c) Maarten Faddegon, 2014 + +module Debug.Hoed.Stk.Render +(CompStmt(..) +,renderCompStmts +,byStack +,showWithStack + +,CompGraph(..) +,Vertex(..) +,mkGraph + +,CDS +,eventsToCDS +,rmEntrySet +,simplifyCDSSet +,isRoot +) +where + +import Prelude hiding(lookup) +import Debug.Hoed.Stk.Observe +import Data.List(sort,sortBy,partition,nub) +import Data.Graph.Libgraph +import Data.Array as Array +import Data.Tree.RBTree(RBTree(..),insertOrd,emptyRB,search) + +head' :: String -> [a] -> a +head' msg [] = error msg +head' _ xs = head xs + +------------------------------------------------------------------------ +-- Render equations from CDS set + +renderCompStmts :: CDSSet -> [CompStmt] +renderCompStmts = map renderCompStmt + +renderCompStmt :: CDS -> CompStmt +renderCompStmt (CDSNamed name threadId identifier dependsOn set) + = CompStmt name threadId identifier dependsOn equation hstack + where equation = pretty 120 (commas doc) + (doc,stacks)= unzip rendered + rendered = map (renderNamedTop name) output + output = cdssToOutput set + commas [d] = d + commas ds = (foldl (\acc d -> acc <> d <> text ", ") (text "{") ds) <> text "}" + hstack = case stacks of + [] -> [] + (x:_) -> x + + +-- renderCompStmt _ = CompStmt "??" ThreadIdUnknown (-1) UnknownId "??" emptyStack + +renderNamedTop :: String -> Output -> (DOC,CallStack) +renderNamedTop name (OutData cds) + = ( nest 2 $ foldl1 (\ a b -> a <> line <> text ", " <> b) (map (renderNamedFn name) pairs) + , callStack + ) + where (pairs',callStack) = findFn [cds] + pairs = (nub . (sort)) pairs' + -- local nub for sorted lists + nub [] = [] + nub (a:a':as) | a == a' = nub (a' : as) + nub (a:as) = a : nub as + +renderCallStack :: CallStack -> DOC +renderCallStack s + = text "With call stack: [" + <> foldl1 (\a b -> a <> text ", " <> b) + (map text s) + <> text "]" + +------------------------------------------------------------------------ +-- The CompStmt type + +data CompStmt = CompStmt {equLabel :: String, equThreadId :: ThreadId + , equIdentifier :: Int, equDependsOn :: Identifier + , equRes :: String, equStack :: CallStack} + deriving (Eq, Ord) + +instance Show CompStmt where + show e = equRes e -- ++ " with stack " ++ show (equStack e) + showList eqs eq = unlines (map show eqs) ++ eq + +showWithStack :: [CompStmt] -> String +showWithStack eqs = unlines (map show' eqs) + where show' eq + = equRes eq ++ "\n\tWith call stack: " ++ showStack (equStack eq) + ++ "\n\tNext stack: " ++ showStack (nextStack eq) + ++ "\n\tThread id: " ++ show (equThreadId eq) + ++ "\n\tMy Obs id: " ++ show (equIdentifier eq) + ++ "\n\tDepends on Obs id: " ++ show (equDependsOn eq) + where showStack [] = "[-]" + showStack ss = (foldl (\s' s -> s' ++ s ++ ",") "[" ss) ++ "-]" + +-- Compare equations by stack +byStack e1 e2 + = case compareStack (equStack e1) (equStack e2) of + EQ -> compare (equLabel e1) (equLabel e2) + d -> d + +compareStack s1 s2 + | l1 < l2 = LT + | l1 > l2 = GT + | l1 == l2 = c (zip s1 s2) + where l1 = length s1 + l2 = length s2 + c [] = EQ + c ((x,y):ss) = case compare x y of + EQ -> c ss + d -> d + +------------------------------------------------------------------------ +-- Stack matching + +-- nextStack = case getPushMode of +-- Vanilla -> nextStack_vanilla +-- Drop -> nextStack_drop +-- Truncate -> nextStack_truncate +nextStack = nextStack_truncate + +-- Always push onto top of stack +nextStack_vanilla :: CompStmt -> CallStack +nextStack_vanilla (CompStmt cc _ _ _ _ ccs) = cc:ccs + +-- Drop on recursion +nextStack_drop :: CompStmt -> CallStack +nextStack_drop (CompStmt cc _ _ _ _ []) = [cc] +nextStack_drop (CompStmt cc _ _ _ _ ccs) + = if ccs `contains` cc + then ccs + else cc:ccs + +-- Remove everything between recursion (e.g. [f,g,f,h] becomes [f,h]) +nextStack_truncate :: CompStmt -> CallStack +nextStack_truncate (CompStmt cc _ _ _ _ []) = [cc] +nextStack_truncate (CompStmt cc _ _ _ _ ccs) + = if ccs `contains` cc + then dropWhile (/= cc) ccs + else cc:ccs + +contains :: CallStack -> String -> Bool +contains ccs cc = filter (== cc) ccs /= [] + +call :: CallStack -> CallStack -> CallStack +call sApp sLam = sLam' ++ sApp + where (sPre,sApp',sLam') = commonPrefix sApp sLam + +commonPrefix :: CallStack -> CallStack -> (CallStack, CallStack, CallStack) +commonPrefix sApp sLam + = let (sPre,sApp',sLam') = span2 (==) (reverse sApp) (reverse sLam) + in (sPre, reverse sApp', reverse sLam') + +span2 :: (a -> a -> Bool) -> [a] -> [a] -> ([a], [a], [a]) +span2 f = s f [] + where s _ pre [] ys = (pre,[],ys) + s _ pre xs [] = (pre,xs,[]) + s f pre xs@(x:xs') ys@(y:ys') + | f x y = s f (x:pre) xs' ys' + | otherwise = (pre,xs,ys) + +------------------------------------------------------------------------ +-- Bags are collections of computation statements with the same stack + +data Bag = Bag {bagStack :: CallStack, bagStmts :: [CompStmt]} + +instance Eq Bag where b1 == b2 = bagStack b1 == bagStack b2 +instance Ord Bag where compare b1 b2 = cmpStk (bagStack b1) (bagStack b2) + +bag :: (CompStmt -> CallStack) -> CompStmt -> Bag +bag s c = Bag (s c) [c] + +(+++) :: CompStmt -> Bag -> Bag +c +++ b = b{bagStmts = c : bagStmts b} + + +mkBags :: (CompStmt -> CallStack) -> [CompStmt] -> [Bag] +mkBags _ [] = [] +mkBags s cs = mkBags' (bag s fc) [] ocs + + where (fc:ocs) = sortBy (\c1 c2 -> cmpStk (s c1) (s c2)) cs + + mkBags' b bs [] = b:bs + mkBags' b bs (c:cs) + | bagStack b == s c = mkBags' (c +++ b) bs cs + | otherwise = mkBags' (bag s c) (b:bs) cs + +------------------------------------------------------------------------ +-- RB trees to speed up computation graph construction + +type Tree = RBTree Bag + +mkTree :: (CompStmt -> CallStack) -> [CompStmt] -> Tree +mkTree s cs = foldl insertOrd emptyRB (mkBags s cs) + +mkTrees :: [CompStmt] -> (Tree,Tree) +mkTrees cs = (mkTree equStack cs, mkTree nextStack cs) + + +cmpStk :: CallStack -> CallStack -> Ordering +cmpStk [] [] = EQ +cmpStk s1 s2 = case compare (length s1) (length s2) of + EQ -> compare (head s1) (head s2) + ord -> ord + +lookup :: Tree -> CallStack -> [CompStmt] +lookup t s = case search (\s b -> cmpStk s (bagStack b)) t s of + (Just b) -> bagStmts b + Nothing -> [] + +------------------------------------------------------------------------ +-- Inverse call + +stmts :: Tree -> (CallStack,CallStack) -> [(CompStmt,CompStmt)] +stmts t (s1,s2) = flattenStmts (lookup t s1, lookup t s2) + +flattenStmts :: ([a],[b]) -> [(a,b)] +flattenStmts (xs,ys) = foldl (\zs x->foldl (\zs' y->(x,y) : zs') zs ys) [] xs + +lacc :: CallStack -> [(CallStack,CallStack)] +lacc = expand . split + +expand :: [([a],[a])] -> [([a],[a])] +expand xs = foldl (\ys x -> ys ++ map (cat $ snd x) (expand' x)) [] xs + + where expand' (xs,[]) = [(xs,[])] + expand' (xs,y:ys) = (xs,y:ys) : expand' (xs,ys) + + cat sApp (xs,ys) = (sApp,xs++ys) + +split :: [a] -> [([a],[a])] +split [] = [] +split (x:xs) = split' [x] xs [] + + where split' _ [] zs = zs + split' xs (y:ys) zs = split' (xs++[y]) ys ((xs,y:ys):zs) + +------------------------------------------------------------------------ +-- Computation graphs + +data Vertex = Root | Vertex {equations :: [CompStmt], status :: Judgement} + deriving (Eq,Show,Ord) + +type CompGraph = Graph Vertex () + +isRoot Root = True +isRoot _ = False + +pushDeps :: (Tree,Tree) -> [CompStmt] -> [Arc CompStmt ()] +pushDeps ts cs = concat (map (pushArcs ts) cs) + +pushArcs :: (Tree,Tree) -> CompStmt -> [Arc CompStmt ()] +pushArcs t p = map (\c -> p ==> c) (pushers t p) + where src ==> tgt = Arc src tgt () + +pushers :: (Tree,Tree) -> CompStmt -> [CompStmt] +pushers (ts,tn) c = lookup ts (nextStack c) + +callDeps :: (Tree,Tree) -> [CompStmt] -> [Arc CompStmt ()] +callDeps (_,t) cs = concat (map (callDep t) cs) + +callDep :: Tree -> CompStmt -> [Arc CompStmt ()] +callDep t c3 = foldl (\as (c2,c1) -> c1 ==> c2 : c2 ==> c3 : as) [] + (concat (map (stmts t) (lacc $ equStack c3))) + where src ==> tgt = Arc src tgt () + +mkGraph :: [CompStmt] -> CompGraph +mkGraph cs = {-# SCC "mkGraph" #-} -- (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!" + + nubArcs :: Graph CompStmt () -> Graph CompStmt () + nubArcs (Graph r vs as) = Graph r vs (nub as) + + sameThread :: Graph CompStmt () -> Graph CompStmt () + sameThread (Graph r vs as) = Graph r vs (filter (sameThread') as) + sameThread' (Arc v w _) + | equThreadId v == ThreadIdUnknown + || equThreadId w == ThreadIdUnknown + || equThreadId v == equThreadId w = True + | otherwise = False + + filterDependsJustOn :: Graph CompStmt () -> Graph CompStmt () + filterDependsJustOn (Graph r vs as) = Graph r vs (filter (filterDependsJustOn') as) + filterDependsJustOn' (Arc v w _) = case equDependsOn w of + (DependsJustOn i) -> i == equIdentifier v + _ -> True + + addSequenceDependencies :: Graph CompStmt () -> Graph CompStmt () + addSequenceDependencies (Graph r vs as) = Graph r vs (seqDeps vs ++ as) + seqDeps vs = [Arc v w () |v <- vs, w <- vs, seqDep v w] + seqDep v w = case equDependsOn w of + (InSequenceAfter i) -> i == equIdentifier v + _ -> False + + toVertices :: Graph CompStmt () -> CompGraph + toVertices = mapGraph (\s->Vertex [s] Unassessed) + + addRoot :: CompGraph -> CompGraph + addRoot (Graph _ vs as) = + let rs = filter (\(Vertex (s:_) _) -> equStack s == []) vs + es = map (\r -> Root ==> r) rs + in Graph Root (Root : vs) (es ++ as) + + merge :: [Vertex] -> Vertex + merge vs = let v = head' msgvs vs; cs' = map equations vs + in v{equations=foldl (++) [] cs'} + msgvs = "mkGraph.merge: No vertices to merge." + + src ==> tgt = Arc src tgt () + +-- %************************************************************************ +-- %* * +-- \subsection{The CDS and converting functions} +-- %* * +-- %************************************************************************ + + +data CDS = CDSNamed String ThreadId Int Identifier CDSSet + | CDSCons Int String [CDSSet] + | CDSFun Int CDSSet CDSSet CallStack + | CDSEntered Int + | CDSTerminated Int + deriving (Show,Eq,Ord) + +type CDSSet = [CDS] + +eventsToCDS :: [Event] -> CDSSet +eventsToCDS pairs = getChild 0 0 + where + 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 change) + | (Event node _ change) <- pairs + ] + + getNode'' :: Int -> Change -> CDS + getNode'' node change = + case change of + (Observe str t i d) -> CDSNamed str t i d (getChild node 0) + (Enter) -> CDSEntered node + (NoEnter) -> CDSTerminated node + (Fun str) -> CDSFun node (getChild node 0) (getChild node 1) str + (Cons portc cons) + -> CDSCons node cons + [ getChild node n | n <- [0..(portc-1)]] + + 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 caller) pairs) <> + line <> text "}") + + where + (pairs',caller) = findFn cdss + pairs = (nub . sort) pairs' + -- local nub for sorted lists + nub [] = [] + nub (a:a':as) | a == a' = nub (a' : as) + nub (a:as) = a : nub as + +renderFn :: CallStack -> ([CDSSet],CDSSet) -> DOC +renderFn callStack (args, res) + = grp (nest 3 + (text "\\ " <> + foldr (\ a b -> nest 0 (renderSet' 10 False a) <> sp <> b) + nil + args <> sep <> + text "-> " <> renderSet' 0 False res + ) + ) + +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 + ) + ) + + +-- This is where the call stacks are merged. +-- +-- MF TODO: It would be beneficial for performance if we would only save the +-- stack once at the top as we already do in the paper and our semantics test code + +findFn :: CDSSet -> ([([CDSSet],CDSSet)], CallStack) +findFn = foldr findFn' ([],[]) + +findFn' (CDSFun _ arg res caller) (rest,_) = + case findFn res of + ([(args',res')],caller') -> if caller' /= [] && caller' /= caller + then error "found two different stacks!" + else ((arg : args', res') : rest, caller) + _ -> (([arg], res) : rest, caller) +findFn' other (rest,caller) = (([],[other]) : rest, caller) + +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 d set) = CDSNamed str t i d (rmEntrySet set) +rmEntry (CDSCons i str sets) = CDSCons i str (map rmEntrySet sets) +rmEntry (CDSFun i a b str) = CDSFun i (rmEntrySet a) (rmEntrySet b) str +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 d set) = CDSNamed str t i d (simplifyCDSSet set) +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 str) = CDSFun 0 (simplifyCDSSet a) (simplifyCDSSet b) str + +simplifyCDS (CDSTerminated i) = (CDSCons 0 "" []) + +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) diff --git a/Hoed.cabal b/Hoed.cabal --- a/Hoed.cabal +++ b/Hoed.cabal @@ -1,5 +1,5 @@ name: Hoed -version: 0.2.1 +version: 0.2.2 synopsis: Lighweight algorithmic debugging based on observing intermediate values and the cost centre stack. -- description: TODO homepage: http://maartenfaddegon.nl @@ -22,17 +22,17 @@ default: False library - exposed-modules: Debug.Hoed - other-modules: Debug.Hoed.Observe - , Debug.Hoed.Render - , Debug.Hoed.DemoGUI + exposed-modules: Debug.Hoed.Stk + other-modules: Debug.Hoed.Stk.Observe + , Debug.Hoed.Stk.Render + , Debug.Hoed.Stk.DemoGUI build-depends: base >=4.6 && <5 , template-haskell , array, containers , process - , threepenny-gui == 0.5.* + , threepenny-gui == 0.6.* , filepath - , libgraph == 1.4 + , libgraph == 1.5 , RBTree == 0.0.5 , regex-posix , mtl @@ -73,19 +73,6 @@ else buildable: False main-is: HeadOnEmpty.hs - hs-source-dirs: examples - default-language: Haskell2010 - ghc-options: -O0 - -Executable hoed-examples-Ho - if flag(buildExamples) - build-depends: base >= 4 && < 5 - , Hoed - , threepenny-gui - , filepath - else - buildable: False - main-is: Ho.hs hs-source-dirs: examples default-language: Haskell2010 ghc-options: -O0 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +0.2.2 Maarten Faddegon 14 2015 + + * Use a preprocessor to make the library work with GHC 7.10, but also for older versions of GHC. This is related to the "The Applicative Monad Proposal" and the changes to Template Haskell in GHC 7.10 that are not backward compatibility with earlier versions of GHC. + 0.2.1 Maarten Faddegon 1 May 2015 * Small changes to make Hoed work with GHC 7.10 diff --git a/examples/Ho.hs b/examples/Ho.hs deleted file mode 100644 --- a/examples/Ho.hs +++ /dev/null @@ -1,13 +0,0 @@ -import Debug.Hoed - -app :: Observable a => (a->a) -> a -> a -app = observe "app" (\g y -> {-# SCC "app" #-} g y) - - -f :: Observable a => a -> a -f = observe "f" (\x -> {-# SCC "app" #-} x) - -k :: Int -k = 3 - -main = runO $ print (app f k)