Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Avoid OverloadedStrings #42

Merged
merged 1 commit into from
Mar 10, 2025
Merged

Avoid OverloadedStrings #42

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
86 changes: 41 additions & 45 deletions src/Regex/Internal/Debug.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,4 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module provides functions for visualizing @RE@s and @Parser@s.
Expand All @@ -19,7 +18,6 @@ import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Writer.CPS
import qualified Data.Foldable as F
import Data.Maybe (isJust)
import Data.String
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM

Expand All @@ -38,34 +36,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 "digraph RE {"
writeLn (str "digraph RE {")
_ <- go re0
writeLn "}"
writeLn (str "}")
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 ("RFmap" <+> dispsSt st) $ \i ->
withNew (str "RFmap" <+> dispsSt st) $ \i ->
go re1 >>= writeEdge i
RFmap_ _ re1 ->
withNew "RFmap_" $ \i ->
withNew (str "RFmap_") $ \i ->
go re1 >>= writeEdge i
RPure _ -> new "RPure"
RPure _ -> new (str "RPure")
RLiftA2 st _ re1 re2 ->
withNew ("RLiftA2" <+> dispsSt st) $ \i -> do
withNew (str "RLiftA2" <+> dispsSt st) $ \i -> do
go re1 >>= writeEdge i
go re2 >>= writeEdge i
REmpty -> new "REmpty"
REmpty -> new (str "REmpty")
RAlt re1 re2 ->
withNew "RAlt" $ \i -> do
withNew (str "RAlt") $ \i -> do
go re1 >>= writeEdge i
go re2 >>= writeEdge i
RFold st gr _ _ re1 ->
withNew ("RFold" <+> dispsSt st <+> dispsGr gr) $ \i ->
withNew (str "RFold" <+> dispsSt st <+> dispsGr gr) $ \i ->
go re1 >>= writeEdge i
RMany _ _ _ _ re1 ->
withNew "RMany" $ \i ->
withNew (str "RMany") $ \i ->
go re1 >>= writeEdge i

-----------
Expand All @@ -78,58 +76,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 "digraph Parser {"
writeLn (str "digraph Parser {")
_ <- go p0
writeLn "}"
writeLn (str "}")
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 ("PFmap" <+> dispsSt st) $ \i ->
withNew (str "PFmap" <+> dispsSt st) $ \i ->
go re1 >>= writeEdge i
PFmap_ node ->
withNew "PFmap_" $ \i -> do
writeLn $ "subgraph cluster" <> idStr i <> " {"
withNew (str "PFmap_") $ \i -> do
writeLn $ str "subgraph cluster" <> idStr i <> str " {"
j <- evalStateT (goNode node) IM.empty
writeLn "}"
writeLn (str "}")
writeEdge i j
PPure _ -> new "PPure"
PPure _ -> new (str "PPure")
PLiftA2 st _ re1 re2 ->
withNew ("PLiftA2" <+> dispsSt st) $ \i -> do
withNew (str "PLiftA2" <+> dispsSt st) $ \i -> do
go re1 >>= writeEdge i
go re2 >>= writeEdge i
PEmpty -> new "PEmpty"
PEmpty -> new (str "PEmpty")
PAlt _ re1 re2 res ->
withNew "PAlt" $ \i -> do
withNew (str "PAlt") $ \i -> do
go re1 >>= writeEdge i
go re2 >>= writeEdge i
F.traverse_ (go >=> writeEdge i) res
PMany _ _ _ _ _ re1 ->
withNew "PMany" $ \i ->
withNew (str "PMany") $ \i ->
go re1 >>= writeEdge i
PFoldGr _ st _ _ re1 ->
withNew ("PFoldGr" <+> dispsSt st) $ \i ->
withNew (str "PFoldGr" <+> dispsSt st) $ \i ->
go re1 >>= writeEdge i
PFoldMn _ st _ _ re1 ->
withNew ("PFoldMn" <+> dispsSt st) $ \i ->
withNew (str "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 "NAccept"
NAccept _ -> lift $ new (str "NAccept")
NGuard u n1 -> do
v <- gets $ IM.lookup (unUnique u)
case v of
Just i -> pure i
Nothing -> withNewT "NGuard" $ \i -> do
Nothing -> withNewT (str "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 "NEmpty"
NAlt n1 n2 ns -> withNewT "NAlt" $ \i -> do
NEmpty -> lift $ new (str "NEmpty")
NAlt n1 n2 ns -> withNewT (str "NAlt") $ \i -> do
goNode n1 >>= lift . writeEdge i
goNode n2 >>= lift . writeEdge i
F.traverse_ (goNode >=> lift . writeEdge i) ns
Expand All @@ -150,8 +148,8 @@ dispCharRanges = show . CS.ranges . CS.fromList

newtype Str = Str { runStr :: String -> String }

instance IsString Str where
fromString = Str . (++)
str :: String -> Str
str = Str . (++)

instance Semigroup Str where
s1 <> s2 = Str (runStr s1 . runStr s2)
Expand All @@ -161,20 +159,18 @@ instance Monoid Str where

dispsSt :: Strictness -> Str
dispsSt st = case st of
Strict -> "S"
NonStrict -> "NS"
Strict -> str "S"
NonStrict -> str "NS"

dispsGr :: Greediness -> Str
dispsGr gr = case gr of
Greedy -> "G"
Minimal -> "M"
Greedy -> str "G"
Minimal -> str "M"

labelToken :: String -> (c -> Maybe a) -> Maybe ([c], [c] -> String) -> Str
labelToken node t = maybe
(fromString node)
(\(cs, disp) ->
fromString node <+>
(fromString . escape . disp) (filter (isJust . t) cs))
(str node)
(\(cs, disp) -> str node <+> (str . escape . disp) (filter (isJust . t) cs))

escape :: String -> String
escape = init . tail' . show
Expand All @@ -183,15 +179,15 @@ escape = init . tail' . show
tail' [] = error "tail'"

(<+>) :: Str -> Str -> Str
s1 <+> s2 = s1 <> " " <> s2
s1 <+> s2 = s1 <> str " " <> s2
infixr 6 <+>

declNode :: Id -> Str -> Str
declNode i label =
idStr i <+>
"[label=\"" <>
str "[label=\"" <>
label <>
"\", ordering=\"out\"]"
str "\", ordering=\"out\"]"

type M = StateT Int (Writer Str)

Expand All @@ -201,16 +197,16 @@ execM = ($ "") . runStr . execWriter . flip runStateT 1
newtype Id = Id { unId :: String }

idStr :: Id -> Str
idStr = fromString . unId
idStr = str . unId

nxt :: M Id
nxt = state $ \i -> let !i' = i+1 in (Id (show i), i')

writeLn :: Str -> M ()
writeLn = lift . tell . (<> "\n")
writeLn = lift . tell . (<> str "\n")

writeEdge :: Id -> Id -> M ()
writeEdge fr to = writeLn $ idStr fr <> " -> " <> idStr to
writeEdge fr to = writeLn $ idStr fr <> str " -> " <> idStr to

new :: Str -> M Id
new node = do
Expand Down
Loading