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