Merge pull request #1 from ndmitchell/master

Updated fork

.gitignore

@@ -1,4 +1,5 @@
 /dist/
 /stack.yaml
 trace.js
-trace.html
+/output/
+.stack-work/

CHANGES.txt

@@ -1,5 +1,6 @@
 Changelog for Debug
 
+    #16, display values for intermediate function calls
     #8, change the Show desugaring
     #9, make the JSON format external
 0.0.2, released 2017-12-18

LICENSE

@@ -1,4 +1,4 @@
-Copyright Neil Mitchell 2017.
+Copyright Neil Mitchell 2017-2018.
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without

README.md

@@ -12,7 +12,7 @@ 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.:
+Turn on the `TemplateHaskell`, `ViewPatterns` and `PartialTypeSignatures` extensions, import `Debug`, indent your code and place it under a call to `debug`, e.g.:
 
 ```haskell
 {-# LANGUAGE TemplateHaskell, ViewPatterns, PartialTypeSignatures #-}
@@ -45,6 +45,25 @@ The call to `debugView` starts a web browser to view the recorded information, l
 
 ![Debug view output](debug.png)
 
+You can look play with the example results for various examples:
+
+* [`quicksort "haskell"`](https://ci.appveyor.com/api/projects/ndmitchell/debug/artifacts/quicksort.html) as above.
+* [`quicksortBy (<) "haskell"`](https://ci.appveyor.com/api/projects/ndmitchell/debug/artifacts/quicksortBy.html), like `quicksort` but using a comparison function and including a trace of `partition` itself.
+* [`lcm_gcd 6 15`](https://ci.appveyor.com/api/projects/ndmitchell/debug/artifacts/lcm_gcd.html), computing `lcm 6 15 ^^ gcd 6 15`.
+
+## Notes
+
+Calling the debugged function inside GHCi records the results for viewing inside the UI.
+The function can be called multiple times with different parameters, and the results of each
+individual run can be selected inside the UI.
+
+You can create multiple `debug [d|...]` blocks inside a module and you can also put more than one
+function inside a single block.
+
+A function being debugged can refer to another function also being debugged, but due to a limitation
+of Template Haskell, the definition of the function being called must occur above the point of its
+reference in the source module.
+
 ## Limitations
 
 This tool is quite new, so it has both limitations, places it is incomplete and bugs. Some notable issues:
@@ -68,3 +87,7 @@ Compared to the above, `debug` stresses simplicitly of integration and user expe
 ### 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.
+
+### Q: `debugView` fails with "error: Variable not in scope: debugView" ?
+
+A: Explicitly load the Debug module in GHCi via `:m + Debug`

appveyor.yml

@@ -2,8 +2,7 @@ build: off
 cache: "c:\\sr -> appveyor.yml"
 
 artifacts:
-- path: trace.html
-  name: trace
+- path: output/*.html
 
 test_script:
 - ps: Invoke-Expression (Invoke-WebRequest 'https://raw.githubusercontent.com/ndmitchell/neil/master/appveyor.ps1')

debug.cabal

@@ -7,7 +7,7 @@ license-file:       LICENSE
 category:           Development, Debugging
 author:             Neil Mitchell <ndmitchell@gmail.com>
 maintainer:         Neil Mitchell <ndmitchell@gmail.com>
-copyright:          Neil Mitchell 2017
+copyright:          Neil Mitchell 2017-2018
 synopsis:           Simple trace-based debugger
 description:
     An easy to use debugger for viewing function calls and intermediate variables.
@@ -51,6 +51,7 @@ library
     exposed-modules:
         Debug
         Debug.Record
+        Debug.Util
 
     other-modules:
         Debug.Variables
@@ -64,5 +65,7 @@ test-suite debug-test
 
     build-depends:
         base == 4.*,
+        directory,
         extra,
+        filepath,
         debug

src/Debug.hs

@@ -49,16 +49,17 @@ module Debug(
     -- * View a trace
     debugView, debugSave, debugPrint,
     -- * Clear a trace
-    debugClear,
+    debugClear
     ) where
 
-import Debug.Record
 import Control.Monad.Extra
-import Data.List.Extra
+import Data.Generics.Uniplate.Data
+import Data.List.Extra   
 import Data.Maybe
+import Debug.Record
+import Debug.Util
 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.
@@ -93,9 +94,79 @@ adjustDec askSig o@(FunD name clauses@(Clause arity _ _:_)) = do
             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]]
+    afterApps <- transformApps tag clauses2 
+    return $ FunD name [Clause (map VarP args) (NormalB body) [FunD inner afterApps]]
 adjustDec askSig x = return x
 
+transformApps :: Name -> [Clause] -> Q [Clause]
+transformApps tag clauses = mapM (appsFromClause tag) clauses
+
+appsFromClause :: Name -> Clause -> Q Clause
+appsFromClause tag cl@(Clause pats body decs) = do
+    newBody <- appsFromBody tag body
+    return $ Clause pats newBody decs
+
+appsFromBody :: Name -> Body -> Q Body
+appsFromBody _ b@(GuardedB _) = return b -- TODO: implement guards
+appsFromBody tag (NormalB e) = do 
+    newExp <- appsFromExp tag e
+    return (NormalB newExp)
+
+appsFromExp :: Name -> Exp -> Q Exp
+appsFromExp tag e@(AppE e1 e2) = do
+    newE1 <- appsFromExp tag e1
+    newE2 <- appsFromExp tag e2
+    adjustApp tag (AppE newE1 newE2)
+appsFromExp tag e@(LetE decs exp) = do
+    newDecs <- traverse (appsFromDec tag) decs   
+    newExp <- appsFromExp tag exp
+    return $ LetE newDecs newExp
+appsFromExp tag e@(InfixE e1May e2 e3May) = do
+    newE1 <- appsFromExpMay tag e1May
+    newE2 <- appsFromExp tag e2
+    newE3 <- appsFromExpMay tag e3May
+    adjustedE2 <- adjustApp tag (InfixE newE1 newE2 newE3)
+    return $ InfixE newE1 adjustedE2 newE3
+appsFromExp tag e = return e  
+
+appsFromExpMay :: Name -> Maybe Exp -> Q (Maybe Exp)
+appsFromExpMay tag Nothing = return Nothing
+appsFromExpMay tag (Just e) = sequence $ Just $ appsFromExp tag e   
+
+appsFromDec :: Name -> Dec -> Q Dec
+appsFromDec tag d@(ValD pat body dec) = do
+    newBody <- appsFromBody tag body
+    return $ ValD pat newBody dec
+appsFromDec tag d@(FunD name subClauses) = return d
+appsFromDec _ d = return d
+
+adjustApp :: Name -> Exp -> Q Exp
+adjustApp tag (AppE e1 e2) = do 
+    let displayName = expDisplayName e1
+    e1n <- newName displayName 
+    let viewP = ViewP (VarE 'var `AppE` VarE tag `AppE` LitE (StringL displayName)) (VarP e1n)
+    let result = LetE [ValD viewP (NormalB (AppE e1 e2)) []] (VarE e1n)
+    return result
+adjustApp tag e@(InfixE e1May e2 e3May) = do
+    let displayName = infixExpDisplayName e2
+    e2n <- newName displayName 
+    let viewP = ViewP (VarE 'var `AppE` VarE tag `AppE` LitE (StringL displayName)) (VarP e2n)
+    let _result = LetE [ValD viewP (NormalB (InfixE e1May e2 e3May)) []] (VarE e2n)  
+    return e2 -- when fixed, ---> return _result
+adjustApp _ e = return e
+
+-- Find the (unqualified) function name to use as the UI display name
+expDisplayName :: Exp -> String
+expDisplayName e = 
+    let name = removeLet $ (show . ppr) e
+    in '_' : removeExtraDigits (takeWhileEnd (/= '.') ((head . words) name))    
+
+-- Same as expDisplayName but for infix functions    
+infixExpDisplayName :: Exp -> String
+infixExpDisplayName e = 
+    let name = removeLet $ (show . ppr) e
+    in "_(" ++ removeExtraDigits (takeWhileEnd (/= '.') ((head . words) name)) 
+
 prettyPrint = pprint . transformBi f
     where f (Name x _) = Name x NameS -- avoid nasty qualifications
 

src/Debug/Util.hs

@@ -0,0 +1,25 @@
+-- | Module containing functions required by test code. Not part of the public interface. 
+module Debug.Util(
+    -- * Exported for tests only
+    removeLet,
+    removeExtraDigits
+    ) where
+
+import Data.List.Extra        
+
+-- | Discover the function name inside (possibly nested) let expressions
+--   Transform strings of the form "let (var tag "f" -> f) = f x in f_1" into "f'" 
+--   Each level of nesting gets a ' (prime) appeneded to the name
+removeLet :: String -> String
+removeLet str = loop "" str where
+   loop suffix s = if "let" `isInfixOf` fst (word1 s) 
+        then case stripInfix " = " s of
+            Just pair -> loop ('\'' : suffix) (snd pair)
+            Nothing -> s    -- this shouldn't happen...
+        else fst (word1 s) ++ suffix 
+
+-- | Remove possible _n suffix from discovered function names
+removeExtraDigits :: String -> String
+removeExtraDigits str = case stripInfixEnd "_" str of
+    Just s -> fst s
+    Nothing -> str

test/Main.hs

@@ -8,17 +8,29 @@ module Main(main) where
 
 import Debug
 import Debug.Record
+import Debug.Util
+import Data.List
 import Control.Exception.Extra
+import System.Directory
+import System.FilePath
+
+
+debug [d|
+   quicksort :: Ord a => [a] -> [a]
+   quicksort [] = []
+   quicksort (x:xs) = quicksort lt ++ [x] ++ quicksort gt
+       where (lt, gt) = partition (<= x) xs
+   |]
 
 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
+    quicksortBy :: (a -> a -> Bool) -> [a] -> [a]
+    quicksortBy op [] = []
+    quicksortBy op (x:xs) = quicksortBy op lt ++ [x] ++ quicksortBy op gt
+        where (lt, gt) = partitionBy (op x) xs
 
-    partition               :: (a -> Bool) -> [a] -> ([a],[a])
-    {-# INLINE partition #-}
-    partition p xs = foldr (select p) ([],[]) xs
+    partitionBy  :: (a -> Bool) -> [a] -> ([a],[a])
+    {-# INLINE partitionBy #-}
+    partitionBy p xs = foldr (select p) ([],[]) xs
 
     select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a])
     select p x ~(ts,fs) | p x       = (x:ts,fs)
@@ -33,20 +45,67 @@ debug [d|
 --    type2 _ = undefined
     |]
 
-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
+debug [d|
+    lcm_gcd :: (Integral a) => a -> a -> Double
+    lcm_gcd x y =
+        let least = lcm x y
+        in fromIntegral least ^^ gcd x y
+    |]
+--  expected:
+--      x, $arg1 = 6
+--      y, $arg2 = 15
+--      least = 30
+--      fromIntegral = 30.0
+--      lcm = 3
+--      (^^), $result = 2700
 
-main = do
+explicit :: (Ord a, Show a) => [a] -> [a]
+explicit = quicksort'
+    where
+        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
+
+
+example name expr = do
     _ <- return ()
+    putStrLn $ "Testing " ++ name
     debugClear
-    print $ quicksort (<) "haskell"
+    print expr
+    writeFile ("output" </> name <.> "js") . ("var trace =\n" ++) . (++ ";") =<< debugJSON
+    debugSave $ "output" </> name <.> "html"
     -- see https://github.com/feuerbach/ansi-terminal/issues/47 as this test fails on Appveyor
+    -- can remove once ansi-terminal-0.8 is available in Stackage LTS (which will be v11)
     try_ debugPrint
-    writeFile "trace.js" . ("var trace =\n" ++) . (++ ";") =<< debugJSON
-    debugSave "trace.html"
+    putStrLn "\n\n"
+
+main = do
+    createDirectoryIfMissing True "output"
+    example "quicksort" $ quicksort "haskell"
+    example "quicksortBy" $ quicksortBy (<) "haskell"
+    example "lcm_gcd" $ lcm_gcd 6 15
+    example "explicit" $ explicit "haskell"
+    copyFile "output/quicksort.js" "trace.js" -- useful for debugging the HTML
+
     evaluate type1
 --    evaluate type2
-    print $ quicksort' "haskell"
+
+    let a === b = if a == b then putStr "." else fail $ show (a, "/=", b)
+    removeExtraDigits "_quicksort_0" === "_quicksort"
+    removeLet let0 === "f"
+    removeLet let1 === "select_2'"
+    removeLet let2 === "Data.Foldable.foldr'"
+    removeLet let3 === "Data.Foldable.foldr''"
+    putStrLn " done"
+
+let0, let1, let2 :: String
+let0 = "f"
+let1 = "let (Debug.Record.var tag_0 \"_select_0\" -> _select_0_1) = select_2 p_3"
+let2 = "let (Debug.Record.var tag_0 \"_foldr\" -> _foldr_1) = Data.Foldable.foldr \
+        \(let (Debug.Record.var tag_0 \"_select_0\" -> _select_0_2) = select_3 p_4 \
+        \in _select_0_2)"
+let3 = "let (Debug.Record.var tag_0 \"_foldr'\" -> _foldr'_1) = (let (Debug.Record.var \tag_0 \
+       \\"_foldr\" -> _foldr_2) = Data.Foldable.foldr (let (Debug.Record.var tag_0 \"_select_0\" \
+       \-> _select_0_3) = select_4 p_5 in _select_0_3) in _foldr_2) ([], []) \
+       \in _foldr'_1"