{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.Hspec.Core.Formatters.Pretty (
  pretty2
#ifdef TEST
, pretty
, recoverString
, recoverMultiLineString
#endif
) where

import           Prelude ()
import           Test.Hspec.Core.Compat hiding (shows, intercalate)

import           Data.Char
import           Data.String
import           Data.List (intersperse)
import qualified Text.Show as Show

import           Test.Hspec.Core.Formatters.Pretty.Unicode
import           Test.Hspec.Core.Formatters.Pretty.Parser

pretty2 :: Bool -> String -> String -> (String, String)
pretty2 :: Bool -> String -> String -> (String, String)
pretty2 Bool
unicode String
expected String
actual = case (Bool -> String -> Maybe String
recoverMultiLineString Bool
unicode String
expected, Bool -> String -> Maybe String
recoverMultiLineString Bool
unicode String
actual) of
  (Just String
expected_, Just String
actual_) -> (String
expected_, String
actual_)
  (Maybe String, Maybe String)
_ -> case (Bool -> String -> Maybe String
pretty Bool
unicode String
expected, Bool -> String -> Maybe String
pretty Bool
unicode String
actual) of
    (Just String
expected_, Just String
actual_) | String
expected_ forall a. Eq a => a -> a -> Bool
/= String
actual_ -> (String
expected_, String
actual_)
    (Maybe String, Maybe String)
_ -> (String
expected, String
actual)

recoverString :: String -> Maybe String
recoverString :: String -> Maybe String
recoverString String
xs = case String
xs of
  Char
'"' : String
_ -> case forall a. [a] -> [a]
reverse String
xs of
    Char
'"' : String
_ -> forall a. Read a => String -> Maybe a
readMaybe String
xs
    String
_ -> forall a. Maybe a
Nothing
  String
_ -> forall a. Maybe a
Nothing

recoverMultiLineString :: Bool -> String -> Maybe String
recoverMultiLineString :: Bool -> String -> Maybe String
recoverMultiLineString Bool
unicode String
input = case String -> Maybe String
recoverString String
input of
  Just String
r | String -> Bool
shouldParseBack String
r -> forall a. a -> Maybe a
Just String
r
  Maybe String
_ -> forall a. Maybe a
Nothing
  where
    shouldParseBack :: String -> Bool
shouldParseBack = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSafe forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Bool
isMultiLine
    isMultiLine :: String -> Bool
isMultiLine = String -> [String]
lines forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (t :: * -> *) a. Foldable t => t a -> Int
length forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall a. Ord a => a -> a -> Bool
> Int
1)
    isSafe :: Char -> Bool
isSafe Char
c = (Bool
unicode Bool -> Bool -> Bool
|| Char -> Bool
isAscii Char
c) Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isControl Char
c) Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\n'

pretty :: Bool -> String -> Maybe String
pretty :: Bool -> String -> Maybe String
pretty Bool
unicode = String -> Maybe Value
parseValue forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Value -> Maybe String
render_
  where
    render_ :: Value -> Maybe String
    render_ :: Value -> Maybe String
render_ Value
value = forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Value -> Bool
shouldParseBack Value
value) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. a -> Maybe a
Just (Bool -> Value -> String
renderValue Bool
unicode Value
value)

    shouldParseBack :: Value -> Bool
    shouldParseBack :: Value -> Bool
shouldParseBack = Value -> Bool
go
      where
        go :: Value -> Bool
go Value
value = case Value
value of
          Char Char
_ -> Bool
False
          String String
_ -> Bool
True
          Rational Value
_ Value
_ -> Bool
False
          Number String
_ -> Bool
False
          Record String
_ [(String, Value)]
_ -> Bool
True
          Constructor String
_ [Value]
xs -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Value -> Bool
go [Value]
xs
          Tuple [Value]
xs -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Value -> Bool
go [Value]
xs
          List [Value]
xs -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Value -> Bool
go [Value]
xs

newtype Builder = Builder ShowS

instance Monoid Builder where
  mempty :: Builder
mempty = ShowS -> Builder
Builder forall a. a -> a
id
#if MIN_VERSION_base(4,11,0)
instance Semigroup Builder where
#endif
  Builder ShowS
xs
#if MIN_VERSION_base(4,11,0)
    <> :: Builder -> Builder -> Builder
<>
#else
    `mappend`
#endif
    Builder ShowS
ys = ShowS -> Builder
Builder (ShowS
xs forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
ys)

runBuilder :: Builder -> String
runBuilder :: Builder -> String
runBuilder (Builder ShowS
xs) = ShowS
xs String
""

intercalate :: Builder -> [Builder] -> Builder
intercalate :: Builder -> [Builder] -> Builder
intercalate Builder
x [Builder]
xs = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse Builder
x [Builder]
xs

shows :: Show a => a -> Builder
shows :: forall a. Show a => a -> Builder
shows = ShowS -> Builder
Builder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
Show.shows

instance IsString Builder where
  fromString :: String -> Builder
fromString = ShowS -> Builder
Builder forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString

renderValue :: Bool -> Value -> String
renderValue :: Bool -> Value -> String
renderValue Bool
unicode = Builder -> String
runBuilder forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Builder
render
  where
    render :: Value -> Builder
    render :: Value -> Builder
render Value
value = case Value
value of
      Char Char
c -> forall a. Show a => a -> Builder
shows Char
c
      String String
str -> if Bool
unicode then ShowS -> Builder
Builder forall a b. (a -> b) -> a -> b
$ String -> ShowS
ushows String
str else forall a. Show a => a -> Builder
shows String
str
      Rational Value
n Value
d -> Value -> Builder
render Value
n forall a. Semigroup a => a -> a -> a
<> Builder
" % " forall a. Semigroup a => a -> a -> a
<> Value -> Builder
render Value
d
      Number String
n -> forall a. IsString a => String -> a
fromString String
n
      Record String
name [(String, Value)]
fields -> forall a. IsString a => String -> a
fromString String
name forall a. Semigroup a => a -> a -> a
<> Builder
" {\n  " forall a. Semigroup a => a -> a -> a
<> (Builder -> [Builder] -> Builder
intercalate Builder
",\n  " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String, Value) -> Builder
renderField [(String, Value)]
fields) forall a. Semigroup a => a -> a -> a
<> Builder
"\n}"
      Constructor String
name [Value]
values -> Builder -> [Builder] -> Builder
intercalate Builder
" " (forall a. IsString a => String -> a
fromString String
name forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Value -> Builder
render [Value]
values)
      Tuple [e :: Value
e@Record{}] -> Value -> Builder
render Value
e
      Tuple [Value]
xs -> Builder
"(" forall a. Semigroup a => a -> a -> a
<> Builder -> [Builder] -> Builder
intercalate Builder
", " (forall a b. (a -> b) -> [a] -> [b]
map Value -> Builder
render [Value]
xs) forall a. Semigroup a => a -> a -> a
<> Builder
")"
      List [Value]
xs -> Builder
"[" forall a. Semigroup a => a -> a -> a
<> Builder -> [Builder] -> Builder
intercalate Builder
", " (forall a b. (a -> b) -> [a] -> [b]
map Value -> Builder
render [Value]
xs) forall a. Semigroup a => a -> a -> a
<> Builder
"]"

    renderField :: (String, Value) -> Builder
renderField (String
name, Value
value) = forall a. IsString a => String -> a
fromString String
name forall a. Semigroup a => a -> a -> a
<> Builder
" = " forall a. Semigroup a => a -> a -> a
<> Value -> Builder
render Value
value