Debug.Do

Do.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}

-- | Print out the values of all names bound by statments,
-- either x <- y, or let x = y in a do-expression.
--
-- * Enable {-# LANGUAGE TemplateHaskell #-} in your module.
-- * Import Debug.Do
-- * Prefix bindings with _ to ignore them e.g. _foo.
--
-- Usage example:
--
-- $(tracing
--     [|do name <- Atto.anyWord8
--          let status = name /= ""
--          !value <- valueParser
--          pure value|])
--
-- Code produced:
--
-- do { name_a1ljV <- Atto.anyWord8;
--      Debug.Trace.trace (concat ["name: ", show name_a1ljV]) (return ());
--      let status_a1ljW = name_a1ljV /= ""
--      Debug.Trace.trace (concat ["status: ", show status_a1ljW]) (return ());
--      !value_a1ljX <- valueParser;
--      Debug.Trace.trace (concat ["value: ", show value_a1ljX]) (return ());
--      pure value_a1ljX }

module Debug.Do where

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

tracing :: Q Exp -> Q Exp
tracing =
  applying
    (\string ->
       AppE
         (AppE (VarE 'Debug.Trace.trace) string)
         (AppE (VarE 'return) (TupE [])))

logging :: Name -> Q Exp -> Q Exp
logging name = applying (\string -> AppE (VarE name) string)

applying :: (Exp -> Exp) -> Q Exp -> Q Exp
applying f gen = do
  e <- gen
  pure (everywhere (mkT transform) e)
  where
    transform =
      \case
        DoE stmts -> DoE (concatMap trace stmts)
        e -> e
    trace =
      \case
        ParS stmts -> [ParS (map (concatMap trace) stmts)]
        BindS pat e -> BindS pat e : map printing (names pat)
        LetS decs ->
          LetS decs :
          concatMap
            (\case
               ValD pat _ _ -> map printing (names pat)
               _ -> [])
            decs
        s -> [s]
    names =
      filter (not . isPrefixOf "_" . nameString) .
      mapMaybe
        (\case
           VarP name -> Just name
           AsP name _ -> Just name
           _ -> Nothing) .
      listify (const True)
    printing name =
      NoBindS
        (f
           (AppE
              (VarE 'fromString)
              (AppE
                 (VarE 'concat)
                 (ListE
                    [ LitE (StringL (nameString name ++ ": "))
                    , AppE (VarE 'show) (VarE name)
                    ]))))
    nameString (Name (OccName occ) _) = occ