module Text.Show.Unicode (ushow, uprint, urecover, ushowWith, uprintWith, urecoverWith) where
import Control.Monad.Trans.State.Strict (StateT (StateT, runStateT),
get, put)
import Data.Char (isAscii, isPrint)
import qualified Data.List as L
import qualified Data.Ord as O
import Safe (minimumByMay)
import Text.ParserCombinators.ReadP (gather, readP_to_S)
import Text.Read.Lex (lexChar)
type Parser a = StateT String Maybe a
ushow :: Show a => a -> String
ushow :: a -> String
ushow = (Char -> Bool) -> a -> String
forall a. Show a => (Char -> Bool) -> a -> String
ushowWith Char -> Bool
shouldRecover
urecover :: String -> String
urecover :: String -> String
urecover = (Char -> Bool) -> String -> String
urecoverWith Char -> Bool
shouldRecover
shouldRecover :: Char -> Bool
shouldRecover :: Char -> Bool
shouldRecover Char
c = Char -> Bool
isPrint Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isAscii Char
c)
uprint :: Show a => a -> IO ()
uprint :: a -> IO ()
uprint = String -> IO ()
putStrLn (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
ushow
ushowWith :: Show a => (Char -> Bool) -> a -> String
ushowWith :: (Char -> Bool) -> a -> String
ushowWith Char -> Bool
p = (Char -> Bool) -> String -> String
urecoverWith Char -> Bool
p (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
urecoverWith :: (Char -> Bool) -> String -> String
urecoverWith :: (Char -> Bool) -> String -> String
urecoverWith Char -> Bool
p String
s =
case StateT String Maybe String -> String -> Maybe (String, String)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((Char -> Bool) -> StateT String Maybe String
recoverChars Char -> Bool
p) String
s of
Just (String
r, String
left) -> String
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
left
Maybe (String, String)
Nothing -> String
s
recoverChars :: (Char -> Bool) -> Parser String
recoverChars :: (Char -> Bool) -> StateT String Maybe String
recoverChars Char -> Bool
p = StateT String Maybe String
outsideLiteral
where
outsideLiteral :: StateT String Maybe String
outsideLiteral = do
String
notLit <- StateT String Maybe String
untilDoubleQuote
String
rest <- StateT String Maybe String
forall (m :: * -> *) s. Monad m => StateT s m s
get
case String
rest of
Char
'\"' : String
inLiteral -> do
String -> StateT String Maybe ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put String
inLiteral
(String
notLit String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\"' Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String)
-> StateT String Maybe String -> StateT String Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT String Maybe String
insideLiteral
String
_ ->
String -> StateT String Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> StateT String Maybe String)
-> String -> StateT String Maybe String
forall a b. (a -> b) -> a -> b
$ String
notLit String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest
insideLiteral :: StateT String Maybe String
insideLiteral = do
(String, Char)
recovered <- Parser (String, Char)
recoverCharInLiteral
case (String, Char)
recovered of
(String
"\"",Char
'"') -> (Char
'"' Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String)
-> StateT String Maybe String -> StateT String Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT String Maybe String
outsideLiteral
(String
s, Char
c)
| Char -> Bool
p Char
c -> (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String)
-> StateT String Maybe String -> StateT String Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT String Maybe String
insideLiteral
| Bool
otherwise -> (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> StateT String Maybe String -> StateT String Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT String Maybe String
insideLiteral
untilDoubleQuote :: StateT String Maybe String
untilDoubleQuote = (String -> Maybe (String, String)) -> StateT String Maybe String
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((String -> Maybe (String, String)) -> StateT String Maybe String)
-> (String -> Maybe (String, String)) -> StateT String Maybe String
forall a b. (a -> b) -> a -> b
$ (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just ((String, String) -> Maybe (String, String))
-> (String -> (String, String)) -> String -> Maybe (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\"')
recoverCharInLiteral :: Parser (String, Char)
recoverCharInLiteral :: Parser (String, Char)
recoverCharInLiteral = (String -> Maybe ((String, Char), String)) -> Parser (String, Char)
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((String -> Maybe ((String, Char), String))
-> Parser (String, Char))
-> (String -> Maybe ((String, Char), String))
-> Parser (String, Char)
forall a b. (a -> b) -> a -> b
$ \String
s ->
let result :: [((String, Char), String)]
result = ReadP (String, Char) -> ReadS (String, Char)
forall a. ReadP a -> ReadS a
readP_to_S (ReadP Char -> ReadP (String, Char)
forall a. ReadP a -> ReadP (String, a)
gather ReadP Char
lexChar) String
s
in (((String, Char), String) -> ((String, Char), String) -> Ordering)
-> [((String, Char), String)] -> Maybe ((String, Char), String)
forall a. (a -> a -> Ordering) -> [a] -> Maybe a
minimumByMay ((((String, Char), String) -> Int)
-> ((String, Char), String) -> ((String, Char), String) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
O.comparing (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> (((String, Char), String) -> String)
-> ((String, Char), String)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Char), String) -> String
forall a b. (a, b) -> b
snd)) [((String, Char), String)]
result
uprintWith :: Show a => (Char -> Bool) -> a -> IO ()
uprintWith :: (Char -> Bool) -> a -> IO ()
uprintWith Char -> Bool
p = String -> IO ()
putStrLn (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> a -> String
forall a. Show a => (Char -> Bool) -> a -> String
ushowWith Char -> Bool
p