-- | "Golden tests" using 'ediff' comparison.
module Data.TreeDiff.Golden (
    ediffGolden,
) where

import Data.TreeDiff
import Prelude ()
import Prelude.Compat
import System.Console.ANSI (SGR (Reset), setSGRCode)
import Text.Parsec         (eof, parse)
import Text.Parsec.Text ()

import qualified Data.ByteString              as BS
import qualified Data.Text                    as T
import qualified Data.Text.Encoding           as TE
import qualified Text.PrettyPrint.ANSI.Leijen as WL

-- | Make a golden tests.
--
-- 'ediffGolden' is testing framework agnostic, thus the type
-- looks intimidating.
--
-- An example using @tasty-golden@,
-- 'goldenTest' is imported from "Test.Tasty.Golden.Advanced"
--
-- @
-- exTest :: TestTree
-- exTest = 'ediffGolden' goldenTest "golden test" "fixtures/ex.expr" $
--    action constructing actual value
-- @
--
-- The 'ediffGolden' will read an 'Expr' from provided path to golden file,
-- and compare it with a 'toExpr' of a result. If values differ,
-- the (compact) diff of two will be printed.
--
-- See <https://github.com/phadej/tree-diff/blob/master/tests/Tests.hs>
-- for a proper example.
--
ediffGolden
    :: (Eq a, ToExpr a)
    => (testName -> IO Expr -> IO Expr -> (Expr -> Expr -> IO (Maybe String)) -> (Expr -> IO ()) -> testTree) -- ^ 'goldenTest'
    -> testName  -- ^ test name
    -> FilePath  -- ^ path to "golden file"
    -> IO a      -- ^ result value
    -> testTree
ediffGolden :: (testName
 -> IO Expr
 -> IO Expr
 -> (Expr -> Expr -> IO (Maybe String))
 -> (Expr -> IO ())
 -> testTree)
-> testName -> String -> IO a -> testTree
ediffGolden testName
-> IO Expr
-> IO Expr
-> (Expr -> Expr -> IO (Maybe String))
-> (Expr -> IO ())
-> testTree
impl testName
testName String
fp IO a
x = testName
-> IO Expr
-> IO Expr
-> (Expr -> Expr -> IO (Maybe String))
-> (Expr -> IO ())
-> testTree
impl testName
testName IO Expr
expect IO Expr
actual Expr -> Expr -> IO (Maybe String)
forall a (m :: * -> *).
(Eq a, Monad m, ToExpr a) =>
a -> a -> m (Maybe String)
cmp Expr -> IO ()
wrt
  where
    actual :: IO Expr
actual = (a -> Expr) -> IO a -> IO Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Expr
forall a. ToExpr a => a -> Expr
toExpr IO a
x
    expect :: IO Expr
expect = do
        ByteString
contents <- String -> IO ByteString
BS.readFile String
fp
        case Parsec Text () Expr -> String -> Text -> Either ParseError Expr
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (Parsec Text () Expr
forall (m :: * -> *). (Monad m, TokenParsing m) => m Expr
exprParser Parsec Text () Expr
-> ParsecT Text () Identity () -> Parsec Text () Expr
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Text () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) String
fp (Text -> Either ParseError Expr) -> Text -> Either ParseError Expr
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TE.decodeUtf8 ByteString
contents of
            Left ParseError
err -> ParseError -> IO ()
forall a. Show a => a -> IO ()
print ParseError
err IO () -> IO Expr -> IO Expr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO Expr
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parse error"
            Right Expr
r  -> Expr -> IO Expr
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
r
    cmp :: a -> a -> m (Maybe String)
cmp a
a a
b
        | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b    = Maybe String -> m (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
        | Bool
otherwise = Maybe String -> m (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> m (Maybe String))
-> Maybe String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
            [SGR] -> String
setSGRCode [SGR
Reset] String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
showWL (Edit EditExpr -> Doc
ansiWlEditExprCompact (Edit EditExpr -> Doc) -> Edit EditExpr -> Doc
forall a b. (a -> b) -> a -> b
$ a -> a -> Edit EditExpr
forall a. ToExpr a => a -> a -> Edit EditExpr
ediff a
a a
b)
    wrt :: Expr -> IO ()
wrt Expr
expr = String -> ByteString -> IO ()
BS.writeFile String
fp (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Doc -> String
showWL (Doc -> Doc
WL.plain (Expr -> Doc
ansiWlExpr Expr
expr)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

showWL :: WL.Doc -> String
showWL :: Doc -> String
showWL Doc
doc = SimpleDoc -> String -> String
WL.displayS (Float -> Int -> Doc -> SimpleDoc
WL.renderSmart Float
0.4 Int
80 Doc
doc) String
""