diff --git a/README.md b/README.md index 9db5ff7..1eb3543 100644 --- a/README.md +++ b/README.md @@ -19,7 +19,7 @@ __Contents:__ Consider this simplistic program that greets the user by name: ```haskell -import Graph.Trace (TraceDeep, traceM) +import Graph.Trace (TraceDeep, trace, traceM) import Data.Char (toUpper, toLower) main :: TraceDeep => IO () @@ -37,7 +37,9 @@ prompt str = do capitalize :: String -> String capitalize [] = [] -capitalize (x:xs) = toUpper x : map toLower xs +capitalize (x:xs) = + let result = toUpper x : map toLower xs + in trace ("result: " <> result) result greet :: String -> String -> IO () greet firstName lastName = @@ -81,7 +83,7 @@ run this program to generate the following trace of the call graph: ``` 3. Build your project (`cabal build all` or `stack build`). 4. Running your program should now generate a file called `.trace`. -5. Install [Graphviz](https://graphviz.org) and the `graph-trace-viz` program. +5. Install [Graphviz](https://graphviz.org) and the `graph-trace-viz` utility. Invoke `graph-trace-viz` within the same directory as the trace file. 6. There should now be a file such as `.html` which can be viewed in your browser. @@ -180,4 +182,9 @@ There are several known caveats you should be aware of: If you have a function binding that takes a rank-n quantified type as a parameter, this can cause compilation with the plugin to fail. With GHC 9.2 and above, giving a type signature to the binding will resolve the issue. -- The plugin does not support GHC versions less than 8.10 +- __View patterns__ + Traces for function calls in view patterns get associated to the node one + level up from the function using the view pattern. +- __Pattern synonyms__ + Function calls in pattern synonym matches do not get traced. +- The plugin does not support GHC versions less than 8.10.x diff --git a/Test.hs b/Test.hs deleted file mode 100644 index bdf19dc..0000000 --- a/Test.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -module DebugPlugin.Test where - -import Data.Kind -import GHC.TypeLits - -type Debug (str :: Symbol) = (?x :: String) - -test :: Debug "yo" => String -test = let ?x = newIP in - do ?x - where - newIP = ?x <> "test" - diff --git a/exe/app/Main.hs b/exe/app/Main.hs index 5420547..cc196e2 100644 --- a/exe/app/Main.hs +++ b/exe/app/Main.hs @@ -11,19 +11,29 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} --{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE PatternSynonyms #-} import Control.Monad import Control.Concurrent import Data.Functor.Identity (Identity(..)) import Graph.Trace ---import Debug.Trace +import qualified Debug.Trace as DT import Class import Data.Char +import qualified Data.List as L import qualified System.Random as Rand import System.IO.Unsafe +pattern Sorted :: (Trace, Ord a) => [a] -> [a] +pattern Sorted xs <- (DT.trace "sort2" mySort -> xs) where + Sorted xs = DT.trace "sort" mySort xs + +mySort :: (Trace, Ord a) => [a] -> [a] +mySort = L.sort + main :: TraceDeep => IO () main = do firstName <- prompt "Enter your first name" @@ -39,7 +49,9 @@ prompt str = do capitalize :: String -> String capitalize [] = [] -capitalize (x:xs) = toUpper x : map toLower xs +capitalize (x:xs) = + let result = toUpper x : map toLower xs + in trace ("result: " <> result) result greet :: String -> String -> IO () greet first last = @@ -67,100 +79,100 @@ greet first last = -- main :: Trace => IO () -- main = test' -test' :: Trace => IO () -test' = do - andAnother - trace "test\ntest" pure () - traceM "yo" - putStrLn $ deff (I 3) - x <- readLn - case x of - 3 -> putStrLn $ classy (I x) - _ -> pure () - putStrLn $ classier (I 5) - inWhere - let inLet :: Trace => IO () - inLet = do - letWhere - another - where letWhere = trace ("hello" \/& "two") pure () - inLet - !_ <- another - let letBound = letBoundThing - trace letBound pure () - trace "leaving" pure () - where - inWhere :: Trace => IO () - inWhere = do - innerWhere - where - innerWhere :: Trace => IO () - innerWhere = trace "innerWhere" pure () - -another :: Trace => IO () -another - | trace "another" True = do - pure () - | otherwise = pure () - -andAnother :: (Trace, Monad m) => m () -andAnother = trace "hello!" pure () - -letBoundThing :: Trace => String -letBoundThing = "bound by let" - -(\/&) :: String -> String -> String -a \/& b = the a <> ('\\' : b) - -the :: a -> a -the = id - -newtype I = I Int deriving Show - -instance Classy I where - classy :: Trace => I -> String - classy = boo - where - boo :: Trace => I -> String - boo i = trace (show i) "..." - -instance Classier I where - classier = show +-- test' :: Trace => IO () +-- test' = do +-- andAnother +-- trace "test\ntest" pure () +-- traceM "yo" +-- putStrLn $ deff (I 3) +-- x <- readLn +-- case x of +-- 3 -> putStrLn $ classy (I x) +-- _ -> pure () +-- putStrLn $ classier (I 5) +-- inWhere +-- let inLet :: Trace => IO () +-- inLet = do +-- letWhere +-- another +-- where letWhere = trace ("hello" \/& "two") pure () +-- inLet +-- !_ <- another +-- let letBound = letBoundThing +-- trace letBound pure () +-- trace "leaving" pure () +-- where +-- inWhere :: Trace => IO () +-- inWhere = do +-- innerWhere +-- where +-- innerWhere :: Trace => IO () +-- innerWhere = trace "innerWhere" pure () -- --- -- test :: (?x :: String) => IO () --- -- test = print ?x +-- another :: Trace => IO () +-- another +-- | trace "another" True = do +-- pure () +-- | otherwise = pure () -- -data FieldUpdate a - = FieldValue a - | FieldOmitted - | FieldNull - -mkUpdater :: f FieldUpdate - -> f Maybe - -> (forall a. f a -> a x) - -> Maybe x -mkUpdater update original getField = - case getField update of - FieldValue a -> Just a - FieldOmitted -> getField original - FieldNull -> Nothing - -data T f = - MkT - { t1 :: f Bool - , t2 :: f String - } - -type TY = forall x. (forall a. T a -> a x) -> Maybe x - --- zz :: Int --- zz = --- let x :: [forall x. x -> x] --- x = [id, id] --- in id head x 4 - -zzz :: Int -zzz = id head [1,2,3] +-- andAnother :: (Trace, Monad m) => m () +-- andAnother = trace "hello!" pure () +-- +-- letBoundThing :: Trace => String +-- letBoundThing = "bound by let" +-- +-- (\/&) :: String -> String -> String +-- a \/& b = the a <> ('\\' : b) +-- +-- the :: a -> a +-- the = id +-- +-- newtype I = I Int deriving Show +-- +-- instance Classy I where +-- classy :: Trace => I -> String +-- classy = boo +-- where +-- boo :: Trace => I -> String +-- boo i = trace (show i) "..." +-- +-- instance Classier I where +-- classier = show +-- -- +-- -- -- test :: (?x :: String) => IO () +-- -- -- test = print ?x +-- -- +-- data FieldUpdate a +-- = FieldValue a +-- | FieldOmitted +-- | FieldNull +-- +-- mkUpdater :: f FieldUpdate +-- -> f Maybe +-- -> (forall a. f a -> a x) +-- -> Maybe x +-- mkUpdater update original getField = +-- case getField update of +-- FieldValue a -> Just a +-- FieldOmitted -> getField original +-- FieldNull -> Nothing +-- +-- data T f = +-- MkT +-- { t1 :: f Bool +-- , t2 :: f String +-- } +-- +-- type TY = forall x. (forall a. T a -> a x) -> Maybe x +-- +-- -- zz :: Int +-- -- zz = +-- -- let x :: [forall x. x -> x] +-- -- x = [id, id] +-- -- in id head x 4 +-- +-- zzz :: Int +-- zzz = id head [1,2,3] -- zzzz :: T FieldUpdate -> T Maybe -> T Maybe -- zzzz update orig = diff --git a/graph-trace/src/Graph/Trace/Internal/Instrument.hs b/graph-trace/src/Graph/Trace/Internal/Instrument.hs index 3de1c3b..8a3d5bb 100644 --- a/graph-trace/src/Graph/Trace/Internal/Instrument.hs +++ b/graph-trace/src/Graph/Trace/Internal/Instrument.hs @@ -198,10 +198,14 @@ modifyMatch prop whereBindExpr debugNames match = do -- predicates, those that do will be addressed via recursion. -- It is also necesarry to descend into potential recursive wheres -- but the recursion needs to stop if a known name is found. - let stopCondition :: Ghc.HsBind Ghc.GhcRn -> Bool - stopCondition Ghc.FunBind{ Ghc.fun_id = Ghc.L _ funName } + let visitedBinding :: Ghc.HsBind Ghc.GhcRn -> Bool + visitedBinding Ghc.FunBind{ Ghc.fun_id = Ghc.L _ funName } = S.member funName visitedNames - stopCondition _ = False + visitedBinding _ = False + -- Do not instrument let bindings in view patterns. + isViewPat :: Ghc.Pat Ghc.GhcRn -> Bool + isViewPat Ghc.ViewPat{} = True + isViewPat _ = False -- recurse the entire match to add let bindings to all where clauses, -- including those belonging to let-bound terms at any nesting depth. @@ -218,7 +222,7 @@ modifyMatch prop whereBindExpr debugNames match = do , Ghc.grhssGRHSs = grhsList } } = Syb.everywhereBut - (Syb.mkQ False stopCondition) + (Syb.mkQ False visitedBinding `Syb.extQ` isViewPat) -- stop condition (Syb.mkT $ updateDebugIpInFunBind whereBindName) match diff --git a/images/demo.svg b/images/demo.svg index 3f5bde0..9248d38 100644 --- a/images/demo.svg +++ b/images/demo.svg @@ -1,104 +1,162 @@ - - - - + + + + -main138835950170271710 +main4942411025473464557 - - -main + + +main - - - -prompt + + + +prompt - - - -prompt + + + +prompt - - - -greet + + + +greet - + -prompt924477568213965436 +prompt15838094771100997091 - - - -← - -prompt + + + +← + +prompt - - -input: haskell + + +input: haskell - - - -capitalize + + + +capitalize - + -main138835950170271710:3->prompt924477568213965436 +main4942411025473464557:3->prompt15838094771100997091 - - + + - + -prompt8331185687311588863 +prompt12701524641738160021 - - - -← - -prompt + + + +← + +prompt - - -input: curry + + +input: curry - - - -capitalize + + + +capitalize - + -main138835950170271710:2->prompt8331185687311588863 +main4942411025473464557:2->prompt12701524641738160021 - - + + + + + + + +capitalize11864835160508626578 + + + + +← + +capitalize + + + + +result: Haskell + + + + + + + +prompt15838094771100997091:1->capitalize11864835160508626578 + + + + + + + + +capitalize2452944521898196652 + + + + +← + +capitalize + + + + +result: Curry + + + + + + + +prompt12701524641738160021:1->capitalize2452944521898196652 + + +