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

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

import           Control.Arrow
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
recoverString Bool
unicode String
expected, Bool -> String -> Maybe String
recoverString 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
actual_)
#if __GLASGOW_HASKELL__ >= 802
    (Maybe String, Maybe String)
_ -> (String
expected, String
actual)
#else
    _ -> (rec expected, rec actual)
  where
    rec = if unicode then urecover else id

    urecover :: String -> String
    urecover xs = maybe xs ushow $ readMaybe xs
#endif

recoverString :: Bool -> String -> Maybe String
recoverString :: Bool -> String -> Maybe String
recoverString Bool
unicode String
input = case String -> Maybe String
forall a. Read a => String -> Maybe a
readMaybe 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 (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 (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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ 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 Expression
parseExpression (String -> Maybe Expression)
-> (Expression -> Maybe String) -> String -> Maybe String
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Expression -> Maybe String
render_
  where
    render_ :: Expression -> Maybe String
    render_ :: Expression -> Maybe String
render_ Expression
expr = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Expression -> Bool
shouldParseBack Expression
expr) Maybe () -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Maybe String
forall a. a -> Maybe a
Just (Bool -> Expression -> String
renderExpression Bool
unicode Expression
expr)

    shouldParseBack :: Expression -> Bool
    shouldParseBack :: Expression -> Bool
shouldParseBack = Expression -> Bool
go
      where
        go :: Expression -> Bool
go Expression
expr = case Expression
expr of
          Literal (String String
_) -> Bool
True
          Literal Literal
_ -> Bool
False
          Id String
_ -> Bool
False
          App (Id String
_) Expression
e -> Expression -> Bool
go Expression
e
          App Expression
_ Expression
_ -> Bool
False
          Parentheses Expression
e -> Expression -> Bool
go Expression
e
          Tuple [Expression]
xs -> (Expression -> Bool) -> [Expression] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Expression -> Bool
go [Expression]
xs
          List [Expression]
xs -> (Expression -> Bool) -> [Expression] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Expression -> Bool
go [Expression]
xs
          Record String
_ [(String, Expression)]
_ -> Bool
True

newtype Builder = Builder ShowS

instance Monoid Builder where
  mempty :: Builder
mempty = ShowS -> Builder
Builder ShowS
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 ShowS -> ShowS -> ShowS
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 = [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 :: a -> Builder
shows = ShowS -> Builder
Builder (ShowS -> Builder) -> (a -> ShowS) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
Show.shows

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

renderExpression :: Bool -> Expression -> String
renderExpression :: Bool -> Expression -> String
renderExpression Bool
unicode = Builder -> String
runBuilder (Builder -> String)
-> (Expression -> Builder) -> Expression -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> Builder
render
  where
    renderLiteral :: Literal -> Builder
renderLiteral Literal
lit = case Literal
lit of
      Char Char
c -> Char -> Builder
forall a. Show a => a -> Builder
shows Char
c
      String String
str -> if Bool
unicode then ShowS -> Builder
Builder (ShowS -> Builder) -> ShowS -> Builder
forall a b. (a -> b) -> a -> b
$ String -> ShowS
ushows String
str else String -> Builder
forall a. Show a => a -> Builder
shows String
str
      Integer Integer
n -> Integer -> Builder
forall a. Show a => a -> Builder
shows Integer
n
      Rational Rational
n -> Rational -> Builder
forall a. Show a => a -> Builder
shows Rational
n

    render :: Expression -> Builder
    render :: Expression -> Builder
render Expression
expr = case Expression
expr of
      Literal Literal
lit -> Literal -> Builder
renderLiteral Literal
lit
      Id String
name -> String -> Builder
forall a. IsString a => String -> a
fromString String
name
      App Expression
a Expression
b -> Expression -> Builder
render Expression
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Expression -> Builder
render Expression
b
      Parentheses e :: Expression
e@Record{} -> Expression -> Builder
render Expression
e
      Parentheses Expression
e -> Builder
"(" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Expression -> Builder
render Expression
e Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"
      Tuple [Expression]
xs -> Builder
"(" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> [Builder] -> Builder
intercalate Builder
", " ((Expression -> Builder) -> [Expression] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Expression -> Builder
render [Expression]
xs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"
      List [Expression]
xs -> Builder
"[" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> [Builder] -> Builder
intercalate Builder
", " ((Expression -> Builder) -> [Expression] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Expression -> Builder
render [Expression]
xs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"]"
      Record String
name [(String, Expression)]
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, Expression) -> Builder)
-> [(String, Expression)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (String, Expression) -> Builder
renderField [(String, Expression)]
fields) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n}"

    renderField :: (String, Expression) -> Builder
renderField (String
name, Expression
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
<> Expression -> Builder
render Expression
value