{-# 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           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 -> [Char] -> [Char] -> ([Char], [Char])
pretty2 Bool
unicode [Char]
expected [Char]
actual = case (Bool -> [Char] -> Maybe [Char]
recoverString Bool
unicode [Char]
expected, Bool -> [Char] -> Maybe [Char]
recoverString Bool
unicode [Char]
actual) of
  (Just [Char]
expected_, Just [Char]
actual_) -> ([Char]
expected_, [Char]
actual_)
  (Maybe [Char], Maybe [Char])
_ -> case (Bool -> [Char] -> Maybe [Char]
pretty Bool
unicode [Char]
expected, Bool -> [Char] -> Maybe [Char]
pretty Bool
unicode [Char]
actual) of
    (Just [Char]
expected_, Just [Char]
actual_) -> ([Char]
expected_, [Char]
actual_)
#if __GLASGOW_HASKELL__ >= 802
    (Maybe [Char], Maybe [Char])
_ -> ([Char]
expected, [Char]
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 -> [Char] -> Maybe [Char]
recoverString Bool
unicode [Char]
input = case forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
input of
  Just [Char]
r | [Char] -> Bool
shouldParseBack [Char]
r -> forall a. a -> Maybe a
Just [Char]
r
  Maybe [Char]
_ -> forall a. Maybe a
Nothing
  where
    shouldParseBack :: [Char] -> 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
<*> [Char] -> Bool
isMultiLine
    isMultiLine :: [Char] -> Bool
isMultiLine = [Char] -> [[Char]]
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 forall a b. (a -> b) -> a -> b
$ 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 -> [Char] -> Maybe [Char]
pretty Bool
unicode = [Char] -> Maybe Expression
parseExpression forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Expression -> Maybe [Char]
render_
  where
    render_ :: Expression -> Maybe String
    render_ :: Expression -> Maybe [Char]
render_ Expression
expr = forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Expression -> Bool
shouldParseBack Expression
expr) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. a -> Maybe a
Just (Bool -> Expression -> [Char]
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 [Char]
_) -> Bool
True
          Literal Literal
_ -> Bool
False
          Id [Char]
_ -> Bool
False
          App (Id [Char]
_) Expression
e -> Expression -> Bool
go Expression
e
          App Expression
_ Expression
_ -> Bool
False
          Parentheses Expression
e -> Expression -> Bool
go Expression
e
          Tuple [Expression]
xs -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Expression -> Bool
go [Expression]
xs
          List [Expression]
xs -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Expression -> Bool
go [Expression]
xs
          Record [Char]
_ [([Char], Expression)]
_ -> Bool
True

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 -> [Char]
runBuilder (Builder ShowS
xs) = ShowS
xs [Char]
""

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 :: [Char] -> Builder
fromString = ShowS -> Builder
Builder forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ShowS
showString

renderExpression :: Bool -> Expression -> String
renderExpression :: Bool -> Expression -> [Char]
renderExpression Bool
unicode = Builder -> [Char]
runBuilder 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 -> forall a. Show a => a -> Builder
shows Char
c
      String [Char]
str -> if Bool
unicode then ShowS -> Builder
Builder forall a b. (a -> b) -> a -> b
$ [Char] -> ShowS
ushows [Char]
str else forall a. Show a => a -> Builder
shows [Char]
str
      Integer Integer
n -> forall a. Show a => a -> Builder
shows Integer
n
      Rational [Char]
n -> forall a. IsString a => [Char] -> a
fromString [Char]
n

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

    renderField :: ([Char], Expression) -> Builder
renderField ([Char]
name, Expression
value) = forall a. IsString a => [Char] -> a
fromString [Char]
name forall a. Semigroup a => a -> a -> a
<> Builder
" = " forall a. Semigroup a => a -> a -> a
<> Expression -> Builder
render Expression
value