Debugging megaparsec transofrmer using `MonadParsecDbg` class

Main.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | This module contains usage example of suggested `MonadParsecDbg` type class,
-- minimized, but, I hope, demonstrative
--
-- If someone have better solution, I would like to see it
module Main where

import Control.Monad.State
import Data.Void
import Text.Megaparsec hiding (State)
import qualified Text.Megaparsec.Debug

class Monad m => MonadParsecDbg m where
  dbg :: Show a => String -> m a -> m a

instance (VisualStream s, ShowErrorComponent e) => MonadParsecDbg (ParsecT e s m) where
  dbg = Text.Megaparsec.Debug.dbg

-- | This `Show s` constrained gives us opportunity to see state at each step
-- just as if it were build in Megaparsec
instance (Show s, MonadParsecDbg m) => MonadParsecDbg (StateT s m) where
  dbg str sma = StateT $ \s ->
    dbg str $ runStateT sma s

-- | Wrapping state in newtype to see it better in output
newtype Depth = Depth Int
  deriving (Eq, Ord, Show, Enum)

-- Two solutions for such test task: count 'x'/'y' symbols
-- situated in round brackets (correctly working with nested brackets)
-- Solutions are the same, except the types and first lines, where dbg function is called

-- | Composed monad-style with new `MonadParsecDebug` type class
xCounter :: (MonadParsec Void String m, MonadState Depth m, MonadParsecDbg m) => m Int
xCounter = do
  ch <- dbg "counter" $ optional anySingle
  case ch of
    Just '(' -> do
      modify succ
      xCounter
    Just ')' -> do
      modify pred
      xCounter
    Just 'x' -> do
      inBracket <- gets (> Depth 0)
      if inBracket
        then (+ 1) <$> xCounter
        else xCounter
    Just _ -> xCounter
    Nothing -> return 0

-- | The same solution with concrete transformers without `MonadParsecDebug`
yCounter :: StateT Depth (Parsec Void String) Int
yCounter = do
  ch <- lift $ Text.Megaparsec.Debug.dbg "counter" $ optional anySingle
  case ch of
    Just '(' -> do
      modify succ
      yCounter
    Just ')' -> do
      modify pred
      yCounter
    Just 'y' -> do
      inBracket <- gets (> Depth 0)
      if inBracket
        then (+ 1) <$> yCounter
        else yCounter
    Just _ -> yCounter
    Nothing -> return 0

-- Testing at the same sample
-- Output:
--
-- xCounter
-- counter> IN: "x(xa(x))a"
-- counter> MATCH (COK): 'x'
-- counter> VALUE: (Just 'x',Depth 0)
--
-- counter> IN: "(xa(x))a"
-- counter> MATCH (COK): '('
-- counter> VALUE: (Just '(',Depth 0)
--
-- counter> IN: "xa(x))a"
-- counter> MATCH (COK): 'x'
-- counter> VALUE: (Just 'x',Depth 1)
--
-- ...
-- yCounter
-- counter> IN: "y(ya(y))a"
-- counter> MATCH (COK): 'y'
-- counter> VALUE: Just 'y'
--
-- counter> IN: "(ya(y))a"
-- counter> MATCH (COK): '('
-- counter> VALUE: Just '('
--
-- counter> IN: "ya(y))a"
-- counter> MATCH (COK): 'y'
-- counter> VALUE: Just 'y'
-- ...
main :: IO ()
main = do
  putStrLn "xCounter"
  parseTest (evalStateT xCounter (Depth 0)) "x(xa(x))a"
  putStrLn "yCounter"
  parseTest (evalStateT yCounter (Depth 0)) "y(ya(y))a"