From 92d3b9ee80f2e4d00703c28800c046cf71020be2 Mon Sep 17 00:00:00 2001 From: Soumik Sarkar Date: Sat, 2 Mar 2024 06:35:24 +0530 Subject: [PATCH] Reduce clutter in Debug using overloaded strings (#7) --- src/Regex/Internal/Debug.hs | 120 ++++++++++++++++++++---------------- 1 file changed, 68 insertions(+), 52 deletions(-) diff --git a/src/Regex/Internal/Debug.hs b/src/Regex/Internal/Debug.hs index 6a53e06..256e54d 100644 --- a/src/Regex/Internal/Debug.hs +++ b/src/Regex/Internal/Debug.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Regex.Internal.Debug ( reToDot @@ -13,7 +14,7 @@ import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Writer.CPS import qualified Data.Foldable as F import Data.Maybe (isJust) -import Data.Semigroup +import Data.String import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM @@ -32,34 +33,34 @@ import qualified Regex.Internal.CharSet as CS -- displayed. reToDot :: forall c a. Maybe ([c], [c] -> String) -> RE c a -> String reToDot ma re0 = execM $ do - writeLn $ showString "digraph RE {" + writeLn "digraph RE {" _ <- go re0 - writeLn $ showString "}" + writeLn "}" where go :: forall b. RE c b -> M Id go re = case re of RToken t -> new $ labelToken "RToken" t ma RFmap st _ re1 -> - withNew (showString "RFmap" ... dispsSt st) $ \i -> + withNew ("RFmap" <+> dispsSt st) $ \i -> go re1 >>= writeEdge i RFmap_ _ re1 -> - withNew (showString "RFmap_") $ \i -> + withNew "RFmap_" $ \i -> go re1 >>= writeEdge i - RPure _ -> new $ showString "RPure" + RPure _ -> new "RPure" RLiftA2 st _ re1 re2 -> - withNew (showString "RLiftA2" ... dispsSt st) $ \i -> do + withNew ("RLiftA2" <+> dispsSt st) $ \i -> do go re1 >>= writeEdge i go re2 >>= writeEdge i - REmpty -> new $ showString "REmpty" + REmpty -> new "REmpty" RAlt re1 re2 -> - withNew (showString "RAlt") $ \i -> do + withNew "RAlt" $ \i -> do go re1 >>= writeEdge i go re2 >>= writeEdge i RFold st gr _ _ re1 -> - withNew (showString "RFold" ... dispsSt st ... dispsGr gr) $ \i -> + withNew ("RFold" <+> dispsSt st <+> dispsGr gr) $ \i -> go re1 >>= writeEdge i RMany _ _ _ _ re1 -> - withNew (showString "RMany") $ \i -> + withNew "RMany" $ \i -> go re1 >>= writeEdge i ----------- @@ -72,58 +73,58 @@ reToDot ma re0 = execM $ do -- characters displayed. parserToDot :: forall c a. Maybe ([c], [c] -> String) -> Parser c a -> String parserToDot ma p0 = execM $ do - writeLn $ showString "digraph Parser {" + writeLn "digraph Parser {" _ <- go p0 - writeLn $ showString "}" + writeLn "}" where go :: forall b. Parser c b -> M Id go p = case p of PToken t -> new $ labelToken "PToken" t ma PFmap st _ re1 -> - withNew (showString "PFmap" ... dispsSt st) $ \i -> + withNew ("PFmap" <+> dispsSt st) $ \i -> go re1 >>= writeEdge i PFmap_ node -> - withNew (showString "PFmap_") $ \i -> do - writeLn $ showString ("subgraph cluster" ++ unId i ++ " {") + withNew "PFmap_" $ \i -> do + writeLn $ "subgraph cluster" <> idStr i <> " {" j <- evalStateT (goNode node) IM.empty - writeLn $ showString "}" + writeLn "}" writeEdge i j - PPure _ -> new $ showString "PPure" + PPure _ -> new "PPure" PLiftA2 st _ re1 re2 -> - withNew (showString "PLiftA2" ... dispsSt st) $ \i -> do + withNew ("PLiftA2" <+> dispsSt st) $ \i -> do go re1 >>= writeEdge i go re2 >>= writeEdge i - PEmpty -> new $ showString "PEmpty" + PEmpty -> new "PEmpty" PAlt _ re1 re2 res -> - withNew (showString "PAlt") $ \i -> do + withNew "PAlt" $ \i -> do go re1 >>= writeEdge i go re2 >>= writeEdge i F.traverse_ (go >=> writeEdge i) res PMany _ _ _ _ _ re1 -> - withNew (showString "PMany") $ \i -> + withNew "PMany" $ \i -> go re1 >>= writeEdge i PFoldGr _ st _ _ re1 -> - withNew (showString "PFoldGr" ... dispsSt st) $ \i -> + withNew ("PFoldGr" <+> dispsSt st) $ \i -> go re1 >>= writeEdge i PFoldMn _ st _ _ re1 -> - withNew (showString "PFoldMn" ... dispsSt st) $ \i -> + withNew ("PFoldMn" <+> dispsSt st) $ \i -> go re1 >>= writeEdge i goNode :: forall b. Node c b -> StateT (IntMap Id) M Id goNode n = case n of - NAccept _ -> lift $ new $ showString "NAccept" + NAccept _ -> lift $ new "NAccept" NGuard u n1 -> do v <- gets $ IM.lookup (unUnique u) case v of Just i -> pure i - Nothing -> withNewT (showString "NGuard") $ \i -> do + Nothing -> withNewT "NGuard" $ \i -> do modify' $ IM.insert (unUnique u) i goNode n1 >>= lift . writeEdge i NToken t n1 -> withNewT (labelToken "NToken" t ma) $ \i -> goNode n1 >>= lift . writeEdge i - NEmpty -> lift $ new $ showString "NEmpty" - NAlt n1 n2 ns -> withNewT (showString "NAlt") $ \i -> do + NEmpty -> lift $ new "NEmpty" + NAlt n1 n2 ns -> withNewT "NAlt" $ \i -> do goNode n1 >>= lift . writeEdge i goNode n2 >>= lift . writeEdge i F.traverse_ (goNode >=> lift . writeEdge i) ns @@ -139,62 +140,77 @@ dispCharRanges = show . CS.ranges . CS.fromList -- Common stuff ----------------- -dispsSt :: Strictness -> ShowS -dispsSt st = showString $ case st of +newtype Str = Str { runStr :: String -> String } + +instance IsString Str where + fromString = Str . (++) + +instance Semigroup Str where + s1 <> s2 = Str (runStr s1 . runStr s2) + +instance Monoid Str where + mempty = Str id + +dispsSt :: Strictness -> Str +dispsSt st = case st of Strict -> "S" NonStrict -> "NS" -dispsGr :: Greediness -> ShowS -dispsGr gr = showString $ case gr of +dispsGr :: Greediness -> Str +dispsGr gr = case gr of Greedy -> "G" Minimal -> "M" -labelToken :: String -> (c -> Maybe a) -> Maybe ([c], [c] -> String) -> ShowS +labelToken :: String -> (c -> Maybe a) -> Maybe ([c], [c] -> String) -> Str labelToken node t = maybe - (showString node) - (\(cs, disp) -> showString node ... - (showString . escape . disp) (filter (isJust . t) cs)) + (fromString node) + (\(cs, disp) -> + fromString node <+> + (fromString . escape . disp) (filter (isJust . t) cs)) escape :: String -> String escape = init . tail . show -(...) :: ShowS -> ShowS -> ShowS -s1 ... s2 = s1 . showChar ' ' . s2 -infixr 9 ... +(<+>) :: Str -> Str -> Str +s1 <+> s2 = s1 <> " " <> s2 +infixr 6 <+> -declNode :: Id -> ShowS -> ShowS +declNode :: Id -> Str -> Str declNode i label = - showString (unId i) ... - showString "[label=\"" . - label . - showString "\", ordering=\"out\"]" + idStr i <+> + "[label=\"" <> + label <> + "\", ordering=\"out\"]" -type M = StateT Int (Writer (Endo String)) +type M = StateT Int (Writer Str) execM :: M a -> String -execM = ($ "") . appEndo . execWriter . flip runStateT 1 +execM = ($ "") . runStr . execWriter . flip runStateT 1 newtype Id = Id { unId :: String } +idStr :: Id -> Str +idStr = fromString . unId + nxt :: M Id nxt = state $ \i -> let !i' = i+1 in (Id (show i), i') -writeLn :: ShowS -> M () -writeLn = lift . tell . Endo . (. showChar '\n') +writeLn :: Str -> M () +writeLn = lift . tell . (<> "\n") writeEdge :: Id -> Id -> M () -writeEdge fr to = writeLn $ showString (unId fr ++ " -> " ++ unId to) +writeEdge fr to = writeLn $ idStr fr <> " -> " <> idStr to -new :: ShowS -> M Id +new :: Str -> M Id new node = do i <- nxt writeLn $ declNode i node pure i -withNew :: ShowS -> (Id -> M a) -> M Id +withNew :: Str -> (Id -> M a) -> M Id withNew node f = runIdentityT $ withNewT node $ lift . f -withNewT :: (MonadTrans t, Monad (t M)) => ShowS -> (Id -> t M a) -> t M Id +withNewT :: (MonadTrans t, Monad (t M)) => Str -> (Id -> t M a) -> t M Id withNewT node f = do i <- lift $ new node _ <- f i