debug 0.0.1 → 0.0.2
raw patch · 7 files changed
+84/−14 lines, 7 filesdep +ansi-wl-pprintPVP ok
version bump matches the API change (PVP)
Dependencies added: ansi-wl-pprint
API changes (from Hackage documentation)
+ Debug: debugPrint :: IO ()
Files
- CHANGES.txt +3/−0
- README.md +9/−0
- debug.cabal +4/−2
- src/Debug.hs +12/−3
- src/Debug/Record.hs +46/−8
- src/Debug/Variables.hs +1/−0
- test/Main.hs +9/−1
CHANGES.txt view
@@ -1,5 +1,8 @@ Changelog for Debug +0.0.2, released 2017-12-18+ #6, don't generate context for obviously-monadic things+ Make debugPrint a bit nicer 0.0.1, released 2017-12-18 Make debugView work on Linux 0.0, released 2017-12-15
README.md view
@@ -61,3 +61,12 @@ * [Hat](https://hackage.haskell.org/package/hat), good ideas, but I've never got it working. Compared to the above, `debug` stresses simplicitly of integration and user experience.++## FAQ++### Q: `debugView` fails talking about Wine?++A: If you get `wine: invalid directory "/home/f/.wine" in WINEPREFIX: not an absolute path` when running `debugView` that means `xdg-open` is handled by [Wine](https://www.winehq.org/). Fix that and it will work once more.+++
debug.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: debug-version: 0.0.1+version: 0.0.2 license: BSD3 license-file: LICENSE category: Development, Debugging@@ -40,7 +40,8 @@ template-haskell, open-browser, uniplate,- js-jquery+ js-jquery,+ ansi-wl-pprint exposed-modules: Debug@@ -58,4 +59,5 @@ build-depends: base == 4.*,+ extra, debug
src/Debug.hs view
@@ -46,7 +46,7 @@ -- * Generate trace debug, -- * View a trace- debugView, debugSave,+ debugView, debugSave, debugPrint, -- * Clear a trace debugClear, ) where@@ -68,10 +68,19 @@ mapM (adjustDec askSig) decs +-- | List all the type variables of kind * (or do the best you can)+kindStar :: Type -> Q [Name]+-- in Q so we should be able to use 'reify' to do a better job+kindStar t = return $+ nubOrd [x | VarT x <- universe t] \\ -- find all variables+ nubOrd [x | AppT (VarT x) _ <- universe t] -- delete the "obvious" ones++ 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 (ForallT vars ctxt typ)) = do+ vs <- kindStar typ+ return $ SigD name $ ForallT vars (nubOrd $ map (AppT (ConT ''Show) . VarT) vs ++ 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"
src/Debug/Record.hs view
@@ -21,6 +21,8 @@ import Control.Monad import Data.IORef import Data.List.Extra+import Data.Maybe+import Data.Tuple.Extra import System.IO import System.Directory import System.IO.Unsafe@@ -29,6 +31,7 @@ import qualified Language.Javascript.JQuery as JQuery import Web.Browser import Paths_debug+import Text.PrettyPrint.ANSI.Leijen as PP -- | Metadata about a function, used to drive the HTML view.@@ -58,16 +61,51 @@ writeIORef refVariables newVariables writeIORef refCalls [] --- | Print information about the observed function calls to 'stdout'.--- Definitely not machine readable, usually not human readable either.+-- | Print information about the observed function calls to 'stdout',+-- in a human-readable format. 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+ calls <- readIORef refCalls+ concs <- mapM getCall calls+ let docs = map call $ nubOrd $ reverse concs+ putDoc (vcat docs <> hardline)+ where+ -- "realise" the call (needed to nub them)+ getCall :: Call -> IO (Function, [(String, Var)])+ getCall (Call f is) = do sv <- readIORef is+ return (f, sv)++ call :: (Function, [(String, Var)]) -> Doc+ call (f, vs) =+ let ass = creaAssoc . reverse $ vs+ hdr = bold $ header ass f+ in hang 5 $ hdr <$$> body ass++ -- stripping the index+ creaAssoc :: [(String, Var)] -> [(String, String)]+ creaAssoc svs = map (second varShow) svs++ header :: [(String, String)] -> Function -> Doc+ header ass f = text "\n*" <+>+ text (funName f) <+>+ arguments ass <+>+ text "=" <+>+ result ass++ arguments :: [(String, String)] -> Doc+ arguments ass =+ let fass = filter (\(t, _) -> take 4 t == "$arg") ass+ args = map snd fass+ in hsep (map text args)++ result :: [(String, String)] -> Doc+ result = text . fromMaybe "no result!" . lookup "$result"++ body :: [(String, String)] -> Doc+ body svs = vsep $ map bodyLine svs++ bodyLine :: (String, String) -> Doc+ bodyLine (t, v) = text t <+> text "=" <+> text v -- | Obtain information about observed functions in JSON format. -- The JSON format is not considered a stable part of the interface,
src/Debug/Variables.hs view
@@ -21,6 +21,7 @@ [(Any, String)] -- Entries, (key a, show a), indexed from [n..0] data Var = Var Int String -- index into Variables, show a+ deriving (Eq,Ord) instance Show Var where show (Var i s) = s ++ " @" ++ show i
test/Main.hs view
@@ -6,6 +6,7 @@ import Debug import Debug.Record+import Control.Exception.Extra debug [d| quicksort :: (a -> a -> Bool) -> [a] -> [a]@@ -22,6 +23,11 @@ | otherwise = (ts, x:fs) |] +debug [d|+ foo :: m a -> m a+ foo = id+ |]+ quicksort' :: (Ord a, Show a) => [a] -> [a] quicksort' arg1 = fun "quicksort" $ \t -> quicksort'' t (var t "arg1" arg1) quicksort'' t [] = []@@ -32,7 +38,9 @@ _ <- return () debugClear print $ quicksort (<) "haskell"- debugPrint+ -- see https://github.com/feuerbach/ansi-terminal/issues/47 as this test fails on Appveyor+ try_ debugPrint writeFile "trace.js" . ("var trace =\n" ++) . (++ ";") =<< debugJSON debugSave "trace.html"+ print $ foo [1] print $ quicksort' "haskell"