Pretty.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# 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 unicode expected actual = case (recoverMultiLineString unicode expected, recoverMultiLineString unicode actual) of
  (Just expected_, Just actual_) -> (expected_, actual_)
  _ -> case (pretty unicode expected, pretty unicode actual) of
    (Just expected_, Just actual_) | expected_ /= actual_ -> (expected_, actual_)
    _ -> (expected, actual)

recoverString :: String -> Maybe String
recoverString xs = case xs of
  '"' : _ -> case reverse xs of
    '"' : _ -> readMaybe xs
    _ -> Nothing
  _ -> Nothing

recoverMultiLineString :: Bool -> String -> Maybe String
recoverMultiLineString unicode input = case recoverString input of
  Just r | shouldParseBack r -> Just r
  _ -> Nothing
  where
    shouldParseBack = (&&) <$> all isSafe <*> isMultiLine
    isMultiLine = lines >>> length >>> (> 1)
    isSafe c = (unicode || isAscii c) && not (isControl c) || c == '\n'

pretty :: Bool -> String -> Maybe String
pretty unicode = parseValue >=> render_
  where
    render_ :: Value -> Maybe String
    render_ value = guard (shouldParseBack value) >> Just (renderValue unicode value)

    shouldParseBack :: Value -> Bool
    shouldParseBack = go
      where
        go value = case value of
          Char _ -> False
          String _ -> True
          Number _ -> False
          Operator _ _ _ -> True
          Record _ _ -> True
          Constructor _ xs -> any go xs
          Tuple xs -> any go xs
          List xs -> any go xs

newtype Builder = Builder ShowS

instance Monoid Builder where
  mempty = Builder id
#if MIN_VERSION_base(4,11,0)
instance Semigroup Builder where
#endif
  Builder xs
#if MIN_VERSION_base(4,11,0)
    <>
#else
    `mappend`
#endif
    Builder ys = Builder (xs . ys)

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

intercalate :: Builder -> [Builder] -> Builder
intercalate x xs = mconcat $ intersperse x xs

shows :: Show a => a -> Builder
shows = Builder . Show.shows

instance IsString Builder where
  fromString = Builder . showString

renderValue :: Bool -> Value -> String
renderValue unicode = runBuilder . render 0
  where
    render :: Int -> Value -> Builder
    render indentation = \ case
      Char c -> shows c
      String str -> if unicode then Builder $ ushows str else shows str
      Number n -> fromString n
      Operator a name b -> render indentation a <> " " <> fromString name <> " " <> render indentation b
      Record name fields -> fromString name <> renderFields fields
      Constructor name values -> intercalate " " (fromString name : map (render indentation) values)
      Tuple [e@Record{}] -> render indentation e
      Tuple xs -> "(" <> intercalate ", " (map (render indentation) xs) <> ")"
      List xs -> "[" <> intercalate ", " (map (render indentation) xs) <> "]"
      where
        spaces :: Builder
        spaces = indentBy (succ indentation)

        renderFields :: [(String, Value)] -> Builder
        renderFields fields = mconcat [
            " {\n" <> spaces
          , intercalate (",\n" <> spaces) $ map renderField fields
          , "\n" <> indentBy indentation <> "}"
          ]

        renderField :: (String, Value) -> Builder
        renderField (name, value) = fromString name <> " = " <> render (succ indentation) value

    indentBy :: Int -> Builder
    indentBy n = fromString $ replicate (2 * n) ' '