debug (empty) → 0.0
raw patch · 11 files changed
+664/−0 lines, 11 filesdep +basedep +containersdep +debugsetup-changed
Dependencies added: base, containers, debug, directory, extra, ghc-prim, js-jquery, template-haskell, uniplate
Files
- CHANGES.txt +3/−0
- LICENSE +30/−0
- README.md +45/−0
- Setup.hs +2/−0
- debug.cabal +60/−0
- html/debug.html +61/−0
- html/debug.js +105/−0
- src/Debug.hs +101/−0
- src/Debug/Record.hs +166/−0
- src/Debug/Variables.hs +53/−0
- test/Main.hs +38/−0
+ CHANGES.txt view
@@ -0,0 +1,3 @@+Changelog for Debug++ Initial version
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2017.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Neil Mitchell nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,45 @@+# Shake [](https://hackage.haskell.org/package/debug) [](https://www.stackage.org/package/debug) [](https://travis-ci.org/ndmitchell/debug) [](https://ci.appveyor.com/project/ndmitchell/debug)++Module for debugging Haskell programs. To use, take the functions that you are interested in debugging, e.g.:++```haskell+module QuickSort(quicksort) where+import Data.List++quicksort :: Ord a => [a] -> [a]+quicksort [] = []+quicksort (x:xs) = quicksort lt ++ [x] ++ quicksort gt+ where (lt, gt) = partition (<= x) xs+```++Turn on the `TemplateHaskell` and `ViewPatterns` extensions, import `Debug`, indent your code and place it under a call to `debug`, e.g.:++```haskell+{-# LANGUAGE TemplateHaskell, ViewPatterns #-}+module QuickSort(quicksort) where+import Data.List+import Debug++debug [d|+ quicksort :: Ord a => [a] -> [a]+ quicksort [] = []+ quicksort (x:xs) = quicksort lt ++ [x] ++ quicksort gt+ where (lt, gt) = partition (<= x) xs+ |]+```++We can now run our debugger with:++```console+$ ghci QuickSort.hs+GHCi, version 8.2.1: http://www.haskell.org/ghc/ :? for help+[1 of 1] Compiling QuickSort ( QuickSort.hs, interpreted )+Ok, 1 module loaded.+*QuickSort> quicksort "haskell"+"aehklls"+*QuickSort> debugView+```++The call to `debugView` starts a web browser to view the recorded information, looking something like:++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ debug.cabal view
@@ -0,0 +1,60 @@+cabal-version: >= 1.18+build-type: Simple+name: debug+version: 0.0+license: BSD3+license-file: LICENSE+category: Development, Debugging+author: Neil Mitchell <ndmitchell@gmail.com>+maintainer: Neil Mitchell <ndmitchell@gmail.com>+copyright: Neil Mitchell 2017+synopsis: Simple trace-based debugger+description:+ An easy to use debugger for viewing function calls and intermediate variables.+ To use, annotate the function under test, run the code, and view the generated web page.+ Full usage instructions are at "Debug".+homepage: https://github.com/ndmitchell/debug+bug-reports: https://github.com/ndmitchell/debug/issues+tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3+extra-doc-files:+ CHANGES.txt+ README.md++data-files:+ html/debug.html+ html/debug.js++source-repository head+ type: git+ location: https://github.com/ndmitchell/debug.git++library+ default-language: Haskell2010+ hs-source-dirs: src+ build-depends:+ base == 4.*,+ ghc-prim,+ extra,+ containers,+ directory,+ template-haskell,+ uniplate,+ js-jquery++ exposed-modules:+ Debug+ Debug.Record++ other-modules:+ Debug.Variables+ Paths_debug++test-suite debug-test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test++ build-depends:+ base == 4.*,+ debug
+ html/debug.html view
@@ -0,0 +1,61 @@+<!DOCTYPE HTML>+<html>+ <head>+ <title>Debug</title>+ <script src="https://code.jquery.com/jquery-3.2.1.min.js"></script>+ <script src="../trace.js"></script>+ <script src="debug.js"></script>+<style type="text/css">+body {height: 100%;}+h1, h2, ul {font-family: sans-serif;}+h1 {margin-bottom: 5px;}+ul {font-size: 10pt;}+h1 {font-size: 20pt; background-color: #d3d3d3; margin-top: 0; padding: 5px;}+#function-list a {text-decoration: none;}+h2 {margin-top: 0; margin-bottom: 5px; font-size: 12pt;}+td {vertical-align: top;}+abbr {text-decoration: none;}++.hs-keyglyph {color: red;}+.hs-keyword {color: blue;}+.hs-comment {color: green;}+.hs-str, .hs-chr {color: teal;}+</style>+ </head>+ <body>++<table style="height:100%;width:100%;">+ <tr>+ <td colspan="3">+ <h1>Haskell Debugger</h1>+ </td>+ </tr>+ <tr>+ <td rowspan="2" width="25%" style="padding-right:40px;">+ <h2>Functions</h1>+ <select id="function-drop" style="width:100%;"><option>(All)</option></select><br/>+ <input id="function-text" style="margin-top:5px;width:100%;" type="text" placeholder="Filter (using regex)" />+ <ul id="function-list"></ul>+ </td>+ <td>+ <h2>Source</h2>+ <pre id="function-source"></pre>+ </td>+ </tr>+ <tr>+ <td>+ <h2>Variables</h2>+ <ul id="function-variables"></ul>+ </td>+ <td>+ <!--+ <h2>Calls</h2>+ Call stack+ -->+ </td>+ </tr>+</table>+++ </body>+</html>
+ html/debug.js view
@@ -0,0 +1,105 @@+var hsLexer = /[a-zA-Z][a-zA-Z0-9]+|[\r\n]|./;+var symbols = "->:=()[]";++function escapeHTML(x)+{+ return x+ .replace(/&/g, "&")+ .replace(/</g, "<")+ .replace(/>/g, ">")+ .replace(/"/g, """)+ .replace(/'/g, "'");+}++function showCall(i)+{+ var t = trace.calls[i];+ var inf = trace.functions[t[""]];+ $source = $("#function-source").empty();+ var source = inf.source;+ while (source != "")+ {+ var res = hsLexer.exec(source);+ if (res == null || res[0].length == 0)+ {+ $source.append(source);+ break;+ }+ else+ {+ if (res[0] == "where")+ $source.append("<span class='hs-keyword'>where</a>");+ else if (symbols.indexOf(res[0]) != -1)+ $source.append("<span class='hs-keyglyph'>" + escapeHTML(res[0]) + "</a>");+ else if (res[0] in t)+ $source.append("<abbr title='" + escapeHTML(trace.variables[t[res[0]]]) + "'>" + escapeHTML(res[0]) + "</abbr>");+ else+ $source.append(res[0]);+ source = source.substr(res[0].length);+ }+ }+ $("#function-variables").empty();+ var variables = [];+ for (var s in t)+ {+ if (s == "") continue;+ variables.push(s + " = " + trace.variables[t[s]]);+ }+ variables = variables.sort();+ for (var i = 0; i < variables.length; i++)+ $("#function-variables").append($("<li>" + escapeHTML(variables[i]) + "</li>"));+}++function showCalls()+{+ var name = $("#function-drop").val();+ var regex = new RegExp();+ try {+ regex = new RegExp($("#function-text").val());+ } catch (e) {+ // Not a valid regex, just ignore it+ }++ var ul = $("#function-list").empty();+ for (var i = 0; i < trace.calls.length; i++)+ {+ var t = trace.calls[i];+ var inf = trace.functions[t[""]];+ if (name != "(All)" && name != inf.name) continue;+ var words = [];+ words.push(inf.name);+ for (var j = 0; j < inf.arguments.length; j++)+ {+ var v = inf.arguments[j];+ if (v in t)+ words.push(trace.variables[t[v]]);+ else+ words.push("_");+ }+ words.push("=");+ words.push(trace.variables[t[inf.result]]);+ var msg = words.join(" ");+ if (!regex.test(msg)) continue;+ ul.append($("<li><a href='javascript:showCall(" + i + ")'>" + escapeHTML(msg) + "</a></li>"));+ }+}++function init()+{+ var funcNames = [];+ for (var i = 0; i < trace.functions.length; i++)+ funcNames.push(trace.functions[i].name);+ funcNames = funcNames.sort();+ var drop = $("#function-drop");+ for (var i = 0; i < funcNames.length; i++)+ drop.append($("<option>" + escapeHTML(funcNames[i]) + "</option>"));++ $("#function-drop").change(showCalls);+ $("#function-text").change(showCalls).on("input", showCalls);+}++$(function(){+ init();+ showCalls();+ showCall(0);+});
+ src/Debug.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}++-- | Module for debugging Haskell programs. To use, take the functions that+-- you are interested in debugging, e.g.:+--+-- > module QuickSort(quicksort) where+-- > import Data.List+-- >+-- > quicksort :: Ord a => [a] -> [a]+-- > quicksort [] = []+-- > quicksort (x:xs) = quicksort lt ++ [x] ++ quicksort gt+-- > where (lt, gt) = partition (<= x) xs+--+-- Turn on the @TemplateHaskell@ and @ViewPatterns@ extensions, import "Debug",+-- indent your code and place it under a call to 'debug', e.g.:+--+-- > {-# LANGUAGE TemplateHaskell, ViewPatterns #-}+-- > module QuickSort(quicksort) where+-- > import Data.List+-- > import Debug+-- >+-- > debug [d|+-- > quicksort :: Ord a => [a] -> [a]+-- > quicksort [] = []+-- > quicksort (x:xs) = quicksort lt ++ [x] ++ quicksort gt+-- > where (lt, gt) = partition (<= x) xs+-- > |]+--+-- We can now run our debugger with:+--+-- > $ ghci QuickSort.hs+-- > GHCi, version 8.2.1: http://www.haskell.org/ghc/ :? for help+-- > [1 of 1] Compiling QuickSort ( QuickSort.hs, interpreted )+-- > Ok, 1 module loaded.+-- > *QuickSort> quicksort "haskell"+-- > "aehklls"+-- > *QuickSort> debugView+--+-- The final call to 'debugView' starts a web browser to view the recorded information.+-- Alternatively call 'debugSave' to write the web page to a known location.+--+-- For more ways to view the result (e.g. producing JSON) or record traces (without using+-- @TemplateHaskell@) see "Debug.Record".+module Debug(+ -- * Generate trace+ debug,+ -- * View a trace+ debugView, debugSave,+ -- * Clear a trace+ debugClear,+ ) where++import Debug.Record+import Data.List.Extra+import Data.Maybe+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Data.Generics.Uniplate.Data+++-- | A @TemplateHaskell@ wrapper to convert a normal function into a traced function.+-- For an example see "Debug". Inserts 'funInfo' and 'var' calls.+debug :: Q [Dec] -> Q [Dec]+debug q = do+ decs <- q+ let askSig x = find (\case SigD y _ -> x == y; _ -> False) decs+ mapM (adjustDec askSig) decs+++adjustDec :: (Name -> Maybe Dec) -> Dec -> Q Dec+-- try and shove in a "Show a =>" if we can+adjustDec askSig (SigD name (ForallT vars ctxt typ)) =+ return $ SigD name $ ForallT vars (nubOrd $ [AppT (ConT ''Show) x | x@VarT{} <- universe typ] ++ ctxt) typ+adjustDec askSig (SigD name typ) = adjustDec askSig $ SigD name $ ForallT [] [] typ+adjustDec askSig o@(FunD name clauses@(Clause arity _ _:_)) = do+ inner <- newName "inner"+ tag <- newName "tag"+ args <- sequence [newName $ "arg" ++ show i | i <- [1 .. length arity]]+ let addTag (Clause ps bod inner) = Clause (VarP tag:ps) bod inner+ let clauses2 = map addTag $ transformBi (adjustPat tag) clauses+ let args2 = [VarE 'var `AppE` VarE tag `AppE` toLitPre "$" a `AppE` VarE a | a <- args]+ let info = ConE 'Function `AppE`+ toLit name `AppE`+ LitE (StringL $ prettyPrint $ maybeToList (askSig name) ++ [o]) `AppE`+ ListE (map (toLitPre "$") args) `AppE`+ LitE (StringL "$result")+ let body2 = VarE 'var `AppE` VarE tag `AppE` LitE (StringL "$result") `AppE` foldl AppE (VarE inner) (VarE tag : args2)+ let body = VarE 'funInfo `AppE` info `AppE` LamE [VarP tag] body2+ return $ FunD name [Clause (map VarP args) (NormalB body) [FunD inner clauses2]]+adjustDec askSig x = return x++prettyPrint = pprint . transformBi f+ where f (Name x _) = Name x NameS -- avoid nasty qualifications++adjustPat :: Name -> Pat -> Pat+adjustPat tag (VarP x) = ViewP (VarE 'var `AppE` VarE tag `AppE` toLit x) (VarP x)+adjustPat tag x = x++toLit = toLitPre ""+toLitPre pre (Name (OccName x) _) = LitE $ StringL $ pre ++ x
+ src/Debug/Record.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- Dodgy Show instance, useful for debugging++-- | Module for recording and manipulating debug traces. For most users, the+-- @TemplateHaskell@ helpers in "Debug" should be sufficient.+module Debug.Record(+ -- * Recording+ Function(..),+ Call,+ funInfo, fun, var,+ -- * Viewing+ debugClear,+ debugPrint, debugJSON,+ debugView, debugSave+ ) where++import Debug.Variables+import Control.Exception+import Control.Monad+import Data.IORef+import Data.List.Extra+import System.IO+import System.Directory+import System.Process.Extra+import System.IO.Unsafe+import Text.Show.Functions() -- Make sure the Show for functions instance exists+import qualified Data.Map as Map+import qualified Language.Javascript.JQuery as JQuery+import Paths_debug+++-- | Metadata about a function, used to drive the HTML view.+data Function = Function+ {funName :: String -- ^ Function name+ ,funSource :: String -- ^ Function source, using @\n@ to break lines+ ,funArguments :: [String] -- ^ Variables for the arguments to the function+ ,funResult :: String -- ^ Variable for the result of the function+ }+ deriving (Eq,Ord,Show)++-- | A single function call, used to attach additional information+data Call = Call Function (IORef [(String, Var)])++{-# NOINLINE refVariables #-}+refVariables :: IORef Variables+refVariables = unsafePerformIO $ newIORef newVariables++{-# NOINLINE refCalls #-}+refCalls :: IORef [Call]+refCalls = unsafePerformIO $ newIORef []++-- | Clear all debug information. Useful when working in @ghci@ to reset+-- any previous debugging work and reduce the amount of output.+debugClear :: IO ()+debugClear = do+ writeIORef refVariables newVariables+ writeIORef refCalls []++-- | Print information about the observed function calls to 'stdout'.+-- Definitely not machine readable, usually not human readable either.+debugPrint :: IO ()+debugPrint = do+ funs <- readIORef refCalls+ forM_ (reverse funs) $ \(Call name vars) -> do+ putStrLn $ funName name+ vars <- readIORef vars+ forM_ (reverse vars) $ \(name, v) ->+ putStrLn $ " " ++ name ++ " = " ++ show v++-- | Obtain information about observed functions in JSON format.+-- The JSON format is not considered a stable part of the interface,+-- more presented as a back door to allow exploration of alternative+-- views.+debugJSON :: IO String+debugJSON = do+ vars <- readIORef refVariables+ vars <- return $ map (jsonString . varShow) $ listVariables vars+ calls <- readIORef refCalls+ let infos = nubOrd [x | Call x _ <- calls]+ let infoId = Map.fromList $ zip infos [0::Int ..]+ let funs = [jsonMap+ [("name",show funName)+ ,("source",show funSource)+ ,("arguments",show funArguments)+ ,("result",show funResult)+ ]+ | Function{..} <- infos]+ calls <- forM (reverse calls) $ \(Call info vars) -> do+ vars <- readIORef vars+ return $ jsonMap $ ("", show $ infoId Map.! info) : [(k, show $ varId v) | (k, v) <- reverse vars]+ return $+ "{\"functions\":\n" ++ jsonList funs +++ ",\"variables\":\n" ++ jsonList vars +++ ",\"calls\":\n" ++ jsonList (nubOrd calls) +++ "}"+ where+ jsonList [] = " []"+ jsonList (x:xs) = unlines $ (" [" ++ x) : map (" ," ++) xs ++ [" ]"]+ jsonMap xs = "{" ++ intercalate "," [jsonString k ++ ":" ++ v | (k,v) <- xs] ++ "}"+ jsonString = show++-- | Save information about observed functions to the specified file, in HTML format.+debugSave :: FilePath -> IO ()+debugSave file = do+ html <- readFile =<< getDataFileName "html/debug.html"+ debug <- readFile =<< getDataFileName "html/debug.js"+ jquery <- readFile =<< JQuery.file+ trace <- debugJSON+ let script a = "<script>\n" ++ a ++ "\n</script>"+ let f x | "trace.js" `isInfixOf` x = script ("var trace =\n" ++ trace ++ ";")+ | "debug.js" `isInfixOf` x = script debug+ | "code.jquery.com/jquery" `isInfixOf` x = script jquery+ | otherwise = x+ writeFile file $ unlines $ map f $ lines html++-- | Open a web browser showing information about observed functions.+debugView :: IO ()+debugView = do+ tdir <- getTemporaryDirectory+ file <- bracket+ (openTempFile tdir "debug.html")+ (hClose . snd)+ (return . fst)+ debugSave file+ system_ file+++#if __GLASGOW_HASKELL__ >= 800+-- On older GHC's this level of overlap leads to a compile error++-- | An orphan instance of 'Show' that maps anything without a 'Show' instance+-- to @?@. Suitable for use only when debugging.+instance {-# OVERLAPS #-} Show a where+ show _ = "?"+#endif++{-# NOINLINE fun #-}+-- | Called under a lambda with a function name to provide a unique context for+-- a particular call, e.g.:+--+-- > tracedAdd x y = fun "add" $ \t -> var t "x" x + var t "y" y+--+-- This function involves giving identity to function calls, so is unsafe,+-- and will only work under a lambda.+fun :: Show a => String -> (Call -> a) -> a+fun name = funInfo $ Function name [] [] []++-- | A version of 'fun' allowing you to pass further information about the+-- 'Function' which is used when showing debug views.+funInfo :: Show a => Function -> (Call -> a) -> a+{-# NOINLINE funInfo #-}+funInfo info f = unsafePerformIO $ do+ ref <- newIORef []+ let x = Call info ref+ atomicModifyIORef refCalls $ \v -> (x:v, ())+ return $ f x++{-# NOINLINE var #-}+-- | Used in conjunction with 'fun' to annotate variables. See 'fun' for an example.+var :: Show a => Call -> String -> a -> a+var (Call _ ref) name val = unsafePerformIO $ do+ var <- atomicModifyIORef refVariables $ addVariable val+ atomicModifyIORef ref $ \v -> ((name, var):v, ())+ return val
+ src/Debug/Variables.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+ -- Any moved from GHC.Prim to GHC.Types+ -- so import both and use unused imports to get compatibility++module Debug.Variables(+ Var, varId, varShow,+ Variables, listVariables, newVariables, addVariable+ ) where++import GHC.Types+import GHC.Prim+import Data.List.Extra+import Control.Exception+import System.IO.Unsafe+import Unsafe.Coerce+++data Variables = Variables+ Int -- Number in the array+ [(Any, String)] -- Entries, (key a, show a), indexed from [n..0]++data Var = Var Int String -- index into Variables, show a++instance Show Var where+ show (Var i s) = s ++ " @" ++ show i++varId :: Var -> Int+varId (Var x _) = x++varShow :: Var -> String+varShow (Var _ x) = x++newVariables :: Variables+newVariables = Variables 0 []++listVariables :: Variables -> [Var]+listVariables (Variables n xs) = [Var i s | (i,(_,s)) <- zipFrom 0 $ reverse xs]++addVariable :: Show a => a -> Variables -> (Variables, Var)+addVariable a vs@(Variables n xs) =+ case findIndex (\(key,_) -> ptrEqual key keyA) xs of+ Nothing -> (Variables (n+1) ((keyA,showA):xs), Var n showA)+ Just i -> (vs, Var (n-i-1) $ snd $ xs !! i)+ where+ keyA = unsafeCoerce a+ showA = show a++ptrEqual :: Any -> Any -> Bool+ptrEqual a b = unsafePerformIO $ do+ a <- evaluate a+ b <- evaluate b+ return (tagToEnum# (reallyUnsafePtrEquality# a b) :: Bool)
+ test/Main.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+-- {-# OPTIONS_GHC -dth-dec-file #-} -- turn on to debug TH++module Main(main) where++import Debug+import Debug.Record++debug [d|+ quicksort :: (a -> a -> Bool) -> [a] -> [a]+ quicksort op [] = []+ quicksort op (x:xs) = quicksort op lt ++ [x] ++ quicksort op gt+ where (lt, gt) = partition (op x) xs++ partition :: (a -> Bool) -> [a] -> ([a],[a])+ {-# INLINE partition #-}+ partition p xs = foldr (select p) ([],[]) xs++ select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a])+ select p x ~(ts,fs) | p x = (x:ts,fs)+ | otherwise = (ts, x:fs)+ |]++quicksort' :: (Ord a, Show a) => [a] -> [a]+quicksort' arg1 = fun "quicksort" $ \t -> quicksort'' t (var t "arg1" arg1)+quicksort'' t [] = []+quicksort'' t ((var t "x" -> x):(var t "xs" -> xs)) = quicksort' lt ++ [x] ++ quicksort' gt+ where (var t "lt" -> lt, var t "gt" -> gt) = partition (<= x) xs++main = do+ _ <- return ()+ debugClear+ print $ quicksort (<) "haskell"+ debugPrint+ writeFile "trace.js" . ("var trace =\n" ++) . (++ ";") =<< debugJSON+ debugSave "trace.html"+ print $ quicksort' "haskell"