{- |
Copyright   : (c) Takayuki Muranushi, 2016
License     : BSD3
Maintainer  : whosekiteneverfly@gmail.com
Stability   : experimental


Provides a interactive printer for printing Unicode characters in ghci REPL. Our design goal is that 'uprint' produces String representations that are valid Haskell 'String' literals and uses as many Unicode printable characters as possible. Hence

@
read . ushow == id
@

see the tests of this package for detailed specifications.

__Example__

With 'print' :

@
$ __ghci__
...
> __["哈斯克尔7.6.1"]__
["\\21704\\26031\\20811\\23572\\&7.6.1"]
>
@

With 'uprint' :

@
$ __ghci -interactive-print=Text.Show.Unicode.uprint Text.Show.Unicode__
...
Ok, modules loaded: Text.Show.Unicode.
> __("Хорошо!",["哈斯克尔7.6.1的力量","感じる"])__
("Хорошо!",["哈斯克尔7.6.1的力量","感じる"])
> "改\\n行"
"改\\n行"
@

You can make 'uprint' the default interactive printer in several ways. One is to
@cabal install unicode-show@, and add the following lines to your @~/.ghci@ config file.

@
import qualified Text.Show.Unicode
:set -interactive-print=Text.Show.Unicode.uprint
@

-}

module Text.Show.Unicode (ushow, uprint, urecover, ushowWith, uprintWith, urecoverWith) where

import           Prelude ()
import           Test.Hspec.Core.Compat hiding (many, (<*>), (*>), (<*))

import           Data.Char                    (isAscii, isPrint)
import           Text.ParserCombinators.ReadP
import           Text.Read.Lex                (lexChar)
import qualified Data.List                     as L

infixl 4 <*

(<*) :: Monad m => m a -> m b -> m a
<* :: m a -> m b -> m a
(<*) = (m b -> m a -> m a) -> m a -> m b -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip m b -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)

-- Represents a replaced character using its literal form and its escaped form.
type Replacement = (String, String)

-- | Parse one Haskell character literal expression from a 'String' produced by 'show', and
--
--  * If the found char satisfies the predicate, replace the literal string with the character itself.
--  * Otherwise, leave the string as it was.
--  * Note that special delimiter sequence "\&" may appear in a string. c.f.  <https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6 Section 2.6 of the Haskell 2010 specification>.
recoverChar :: (Char -> Bool) -> ReadP Replacement
recoverChar :: (Char -> Bool) -> ReadP Replacement
recoverChar Char -> Bool
p = (String, Char) -> Replacement
represent ((String, Char) -> Replacement)
-> ReadP (String, Char) -> ReadP Replacement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Char -> ReadP (String, Char)
forall a. ReadP a -> ReadP (String, a)
gather ReadP Char
lexCharAndConsumeEmpties
  where
    represent :: (String, Char) -> Replacement
    represent :: (String, Char) -> Replacement
represent (String
o,Char
lc)
      -- This is too dirty a hack.
      -- However, I couldn't think of any other way to recover the & consumed by lexChar while not needlessly increasing the number of & by mis-detecting the escape sequence.
      | Char -> Bool
p Char
lc      =
        if String -> Char
forall a. [a] -> a
head String
o Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&&
        String
"\\&" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` String
o
        then (String
o, Char
lc Char -> String -> String
forall a. a -> [a] -> [a]
: String
"\\&")
        else (String
o, [Char
lc])
      | Bool
otherwise = (String
o, String
o)

-- | The base library lexChar has been handling & by itself since 4.9.1.0,
-- so consumeEmpties is a meaningless action,
-- but it makes sense for older versions of lexChar.
lexCharAndConsumeEmpties :: ReadP Char
lexCharAndConsumeEmpties :: ReadP Char
lexCharAndConsumeEmpties = ReadP Char
lexChar ReadP Char -> ReadP () -> ReadP Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
<* ReadP ()
consumeEmpties
    where
    -- Consumes the string "\&" repeatedly and greedily (will only produce one match)
    consumeEmpties :: ReadP ()
    consumeEmpties :: ReadP ()
consumeEmpties = do
        String
rest <- ReadP String
look
        case String
rest of
            (Char
'\\':Char
'&':String
_) -> String -> ReadP String
string String
"\\&" ReadP String -> ReadP () -> ReadP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReadP ()
consumeEmpties
            String
_ -> () -> ReadP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Show the input, and then replace Haskell character literals
-- with the character it represents, for any Unicode printable characters except backslash, single and double quotation marks.
-- If something fails, fallback to standard 'show'.
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

-- | Replace Haskell character literals with the character it represents, for
-- any Unicode printable characters except backslash, single and double
-- quotation marks.
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)

-- | A version of 'print' that uses 'ushow'.
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

-- | Show the input, and then replace character literals
-- with the character itself, for characters that satisfy the given predicate.
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

-- | Replace character literals with the character itself, for characters that
-- satisfy the given predicate.
urecoverWith :: (Char -> Bool) -> String -> String
urecoverWith :: (Char -> Bool) -> String -> String
urecoverWith Char -> Bool
p = Replacement -> [([Replacement], String)] -> String
go (String
"", String
"") ([([Replacement], String)] -> String)
-> (String -> [([Replacement], String)]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadP [Replacement] -> String -> [([Replacement], String)]
forall a. ReadP a -> ReadS a
readP_to_S (ReadP Replacement -> ReadP [Replacement]
forall a. ReadP a -> ReadP [a]
many (ReadP Replacement -> ReadP [Replacement])
-> ReadP Replacement -> ReadP [Replacement]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ReadP Replacement
recoverChar Char -> Bool
p)
  where
    go :: Replacement -> [([Replacement], String)] -> String
    go :: Replacement -> [([Replacement], String)] -> String
go Replacement
_  []            = String
""
    go Replacement
_  (([],String
""):[([Replacement], String)]
_)   = String
""
    go Replacement
_  (([Replacement]
rs,String
""):[([Replacement], String)]
_)   = Replacement -> String
forall a b. (a, b) -> b
snd (Replacement -> String) -> Replacement -> String
forall a b. (a -> b) -> a -> b
$ [Replacement] -> Replacement
forall a. [a] -> a
last [Replacement]
rs
    go Replacement
_  [([Replacement]
_,String
o)]       = String
o
    go Replacement
pr (([],String
_):[([Replacement], String)]
rest) = Replacement -> [([Replacement], String)] -> String
go Replacement
pr [([Replacement], String)]
rest
    go Replacement
_  (([Replacement]
rs,String
_):[([Replacement], String)]
rest) = let r :: Replacement
r = [Replacement] -> Replacement
forall a. [a] -> a
last [Replacement]
rs in Replacement -> String
forall a b. (a, b) -> b
snd Replacement
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ Replacement -> [([Replacement], String)] -> String
go Replacement
r [([Replacement], String)]
rest

-- | A version of 'print' that uses 'ushowWith'.
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