{-# 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_ String -> String -> Bool
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 String -> String
forall a. [a] -> [a]
reverse String
xs of
    Char
'"' : String
_ -> String -> Maybe String
forall a. Read a => String -> Maybe a
readMaybe String
xs
    String
_ -> Maybe String
forall a. Maybe a
Nothing
  String
_ -> Maybe 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 -> String -> Maybe String
forall a. a -> Maybe a
Just String
r
  Maybe String
_ -> Maybe String
forall a. Maybe a
Nothing
  where
    shouldParseBack :: String -> Bool
shouldParseBack = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> (String -> Bool) -> String -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSafe (String -> Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall a b. (String -> a -> b) -> (String -> a) -> String -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Bool
isMultiLine
    isMultiLine :: String -> Bool
isMultiLine = String -> [String]
lines (String -> [String]) -> ([String] -> Bool) -> String -> Bool
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> (Int -> Bool) -> [String] -> Bool
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Int -> Int -> Bool
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 Char -> Char -> Bool
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 (String -> Maybe Value)
-> (Value -> Maybe String) -> String -> Maybe String
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 = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Value -> Bool
shouldParseBack Value
value) Maybe () -> Maybe String -> Maybe String
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Maybe String
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 -> (Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Value -> Bool
go [Value]
xs
          Tuple [Value]
xs -> (Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Value -> Bool
go [Value]
xs
          List [Value]
xs -> (Value -> Bool) -> [Value] -> Bool
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 = (String -> String) -> Builder
Builder String -> String
forall a. a -> a
id
#if MIN_VERSION_base(4,11,0)
instance Semigroup Builder where
#endif
  Builder String -> String
xs
#if MIN_VERSION_base(4,11,0)
    <> :: Builder -> Builder -> Builder
<>
#else
    `mappend`
#endif
    Builder String -> String
ys = (String -> String) -> Builder
Builder (String -> String
xs (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
ys)

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

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

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

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

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

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