{- |
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           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)

-- | Create a parser for less dependencies. ReadP is too slow
type Parser a = StateT String Maybe a


-- | 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 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
'\"')


-- | Parse one Haskell character literal expression from a 'String' produced by 'show', and
--   returns the pair of the string before parsed with the parsed character.
--  * 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>.
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
          -- The longest match result should leave the shortest string.
          -- So choose the result with the minimum length left.
       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


-- | 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