Trace all bound names in Haskell

Trace.hs

{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE LambdaCase, ViewPatterns #-}

-- | Trace declarations or expression bindings.
{-
tracing [d|
  ...
  |]

-}

module Trace (tracing) where

import           Data.Generics
import           Data.List
import           Data.Maybe
import           Data.String
import qualified Debug.Trace
import           Language.Haskell.TH.Syntax

{-# NOINLINE showShort #-}
showShort :: (Show a) => String -> a -> String
showShort label = ellipsis . (\x -> label ++ " = " ++ x) . show
  where
    ellipsis xs =
      if length (take 80 xs) == 80
        then take 77 xs ++ "..."
        else xs

tracing :: Data t => Q t -> Q t
tracing gen = do
  e <- gen
  pure (everywhere (mkT tracePatVars) e)
  where
    tracePatVars =
      \case
        VarP name
          | isPrintableName name -> ViewP (tracePat name) (VarP name)
        p -> p
    tracePat name =
      LamE
        [VarP var]
        (AppE
           (AppE
              (VarE 'Debug.Trace.trace)
              (AppE
                 (AppE (VarE 'showShort) (LitE (StringL (nameString name))))
                 (VarE var)))
           (VarE var))
      where
        var = mkName "x"
    nameString (Name (OccName occ) _) = occ
    isPrintableName = not . isPrefixOf "_" . nameString