Reduce clutter in Debug using overloaded strings (#7)

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