diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. + + + diff --git a/debug.cabal b/debug.cabal --- a/debug.cabal +++ b/debug.cabal @@ -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 diff --git a/src/Debug.hs b/src/Debug.hs --- a/src/Debug.hs +++ b/src/Debug.hs @@ -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" diff --git a/src/Debug/Record.hs b/src/Debug/Record.hs --- a/src/Debug/Record.hs +++ b/src/Debug/Record.hs @@ -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, diff --git a/src/Debug/Variables.hs b/src/Debug/Variables.hs --- a/src/Debug/Variables.hs +++ b/src/Debug/Variables.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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"