{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Test.Tasty.Checklist
(
withChecklist
, CanCheck
, check
, discardCheck
, checkValues
, DerivedVal(Val, Got, Observe)
, CheckResult
, ChecklistFailures
, TestShow(testShow)
, testShowList
, multiLineDiff
)
where
import Control.Exception ( evaluate )
import Control.Monad ( join, unless )
import Control.Monad.Catch
import Control.Monad.IO.Class ( MonadIO, liftIO )
import Data.IORef
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Parameterized.Context as Ctx
import Data.Text ( Text )
import qualified Data.Text as T
import System.IO ( hFlush, hPutStrLn, stdout, stderr )
data ChecklistFailures = ChecklistFailures Text [CheckResult]
data CheckResult = CheckFailed CheckName (Maybe InputAsText) FailureMessage
| CheckMessage Text
newtype CheckName = CheckName { CheckName -> Text
checkName :: Text }
newtype InputAsText = InputAsText { InputAsText -> Text
inputAsText :: Text } deriving (InputAsText -> InputAsText -> Bool
(InputAsText -> InputAsText -> Bool)
-> (InputAsText -> InputAsText -> Bool) -> Eq InputAsText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InputAsText -> InputAsText -> Bool
== :: InputAsText -> InputAsText -> Bool
$c/= :: InputAsText -> InputAsText -> Bool
/= :: InputAsText -> InputAsText -> Bool
Eq, Eq InputAsText
Eq InputAsText
-> (InputAsText -> InputAsText -> Ordering)
-> (InputAsText -> InputAsText -> Bool)
-> (InputAsText -> InputAsText -> Bool)
-> (InputAsText -> InputAsText -> Bool)
-> (InputAsText -> InputAsText -> Bool)
-> (InputAsText -> InputAsText -> InputAsText)
-> (InputAsText -> InputAsText -> InputAsText)
-> Ord InputAsText
InputAsText -> InputAsText -> Bool
InputAsText -> InputAsText -> Ordering
InputAsText -> InputAsText -> InputAsText
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: InputAsText -> InputAsText -> Ordering
compare :: InputAsText -> InputAsText -> Ordering
$c< :: InputAsText -> InputAsText -> Bool
< :: InputAsText -> InputAsText -> Bool
$c<= :: InputAsText -> InputAsText -> Bool
<= :: InputAsText -> InputAsText -> Bool
$c> :: InputAsText -> InputAsText -> Bool
> :: InputAsText -> InputAsText -> Bool
$c>= :: InputAsText -> InputAsText -> Bool
>= :: InputAsText -> InputAsText -> Bool
$cmax :: InputAsText -> InputAsText -> InputAsText
max :: InputAsText -> InputAsText -> InputAsText
$cmin :: InputAsText -> InputAsText -> InputAsText
min :: InputAsText -> InputAsText -> InputAsText
Ord)
newtype FailureMessage = FailureMessage { FailureMessage -> Text
failureMessage :: Text }
instance Exception ChecklistFailures
instance Show CheckResult where
show :: CheckResult -> String
show (CheckFailed CheckName
what Maybe InputAsText
onValue FailureMessage
msg) =
let chknm :: String
chknm = if [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Text -> [Text]
T.lines (CheckName -> Text
checkName CheckName
what)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
then String
"check: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (CheckName -> Text
checkName CheckName
what)
else String
"check '" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (CheckName -> Text
checkName CheckName
what) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'"
chkmsg :: String
chkmsg = if Text -> Bool
T.null (FailureMessage -> Text
failureMessage FailureMessage
msg)
then String
""
else String
" with: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (FailureMessage -> Text
failureMessage FailureMessage
msg)
chkval :: String
chkval = case Maybe InputAsText
onValue of
Maybe InputAsText
Nothing -> String
""
Just InputAsText
i -> String
"\n using: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (InputAsText -> Text
inputAsText InputAsText
i)
in String
"Failed " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
chknm String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
chkmsg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
chkval
show (CheckMessage Text
txt) = String
"-- " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
txt
instance Show ChecklistFailures where
show :: ChecklistFailures -> String
show (ChecklistFailures Text
topMsg [CheckResult]
fails) =
let isMessage :: CheckResult -> Bool
isMessage = \case
CheckMessage Text
_ -> Bool
True
CheckResult
_ -> Bool
False
checkCnt :: Int
checkCnt = [CheckResult] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([CheckResult] -> Int) -> [CheckResult] -> Int
forall a b. (a -> b) -> a -> b
$ (CheckResult -> Bool) -> [CheckResult] -> [CheckResult]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CheckResult -> Bool) -> CheckResult -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckResult -> Bool
isMessage) [CheckResult]
fails
in String
"ERROR: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
topMsg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
checkCnt String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" checks failed in this checklist:\n -"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n -" (CheckResult -> String
forall a. Show a => a -> String
show (CheckResult -> String) -> [CheckResult] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CheckResult]
fails)
type CanCheck = (?checker :: IORef [CheckResult])
withChecklist :: (MonadIO m, MonadMask m)
=> Text -> (CanCheck => m a) -> m a
withChecklist :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Text -> (CanCheck => m a) -> m a
withChecklist Text
topMsg CanCheck => m a
t = do
IORef [CheckResult]
checks <- IO (IORef [CheckResult]) -> m (IORef [CheckResult])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [CheckResult]) -> m (IORef [CheckResult]))
-> IO (IORef [CheckResult]) -> m (IORef [CheckResult])
forall a b. (a -> b) -> a -> b
$ [CheckResult] -> IO (IORef [CheckResult])
forall a. a -> IO (IORef a)
newIORef [CheckResult]
forall a. Monoid a => a
mempty
a
r <- (let ?checker = CanCheck
IORef [CheckResult]
checks in m a
CanCheck => m a
t)
m a -> m () -> m a
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
do [CheckResult]
cs <- [CheckResult] -> [CheckResult]
forall a. [a] -> [a]
List.reverse ([CheckResult] -> [CheckResult])
-> IO [CheckResult] -> IO [CheckResult]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [CheckResult] -> IO [CheckResult]
forall a. IORef a -> IO a
readIORef IORef [CheckResult]
checks
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([CheckResult] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CheckResult]
cs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> IO ()
hFlush Handle
stdout
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
""
let pfx :: String
pfx = String
" WARN "
(CheckResult -> IO ()) -> [CheckResult] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ())
-> (CheckResult -> String) -> CheckResult -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
pfx String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (CheckResult -> String) -> CheckResult -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckResult -> String
forall a. Show a => a -> String
show) [CheckResult]
cs
Handle -> IO ()
hFlush Handle
stderr
)
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
[CheckResult]
collected <- [CheckResult] -> [CheckResult]
forall a. [a] -> [a]
List.reverse ([CheckResult] -> [CheckResult])
-> IO [CheckResult] -> IO [CheckResult]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [CheckResult] -> IO [CheckResult]
forall a. IORef a -> IO a
readIORef IORef [CheckResult]
checks
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([CheckResult] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CheckResult]
collected) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
ChecklistFailures -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Text -> [CheckResult] -> ChecklistFailures
ChecklistFailures Text
topMsg [CheckResult]
collected)
a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
check :: (CanCheck, TestShow a, MonadIO m)
=> Text -> (a -> Bool) -> a -> m ()
check :: forall a (m :: * -> *).
(CanCheck, TestShow a, MonadIO m) =>
Text -> (a -> Bool) -> a -> m ()
check = (a -> String)
-> Maybe InputAsText -> Text -> (a -> Bool) -> a -> m ()
forall (m :: * -> *) a.
(CanCheck, MonadIO m) =>
(a -> String)
-> Maybe InputAsText -> Text -> (a -> Bool) -> a -> m ()
checkShow a -> String
forall v. TestShow v => v -> String
testShow Maybe InputAsText
forall a. Maybe a
Nothing
checkShow :: (CanCheck, MonadIO m)
=> (a -> String)
-> Maybe InputAsText
-> Text -> (a -> Bool) -> a -> m ()
checkShow :: forall (m :: * -> *) a.
(CanCheck, MonadIO m) =>
(a -> String)
-> Maybe InputAsText -> Text -> (a -> Bool) -> a -> m ()
checkShow a -> String
showit Maybe InputAsText
failInput Text
what a -> Bool
eval a
val = do
Bool
r <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall a. a -> IO a
evaluate (a -> Bool
eval a
val)
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
r (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
let failtxt :: FailureMessage
failtxt = Text -> FailureMessage
FailureMessage (Text -> FailureMessage) -> Text -> FailureMessage
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
showit a
val
let chk :: CheckResult
chk = CheckName -> Maybe InputAsText -> FailureMessage -> CheckResult
CheckFailed (Text -> CheckName
CheckName Text
what) Maybe InputAsText
failInput FailureMessage
failtxt
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [CheckResult] -> ([CheckResult] -> [CheckResult]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef CanCheck
IORef [CheckResult]
?checker (CheckResult
chkCheckResult -> [CheckResult] -> [CheckResult]
forall a. a -> [a] -> [a]
:)
discardCheck :: (CanCheck, MonadIO m) => Text -> m ()
discardCheck :: forall (m :: * -> *). (CanCheck, MonadIO m) => Text -> m ()
discardCheck Text
what = do
let isCheck :: Text -> CheckResult -> Bool
isCheck Text
n (CheckFailed CheckName
n' Maybe InputAsText
_ FailureMessage
_) = Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== CheckName -> Text
checkName CheckName
n'
isCheck Text
_ (CheckMessage Text
_) = Bool
False
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [CheckResult] -> ([CheckResult] -> [CheckResult]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef CanCheck
IORef [CheckResult]
?checker ((CheckResult -> Bool) -> [CheckResult] -> [CheckResult]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CheckResult -> Bool) -> CheckResult -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CheckResult -> Bool
isCheck Text
what))
checkValues :: CanCheck
=> TestShow dType
=> dType -> Ctx.Assignment (DerivedVal dType) idx -> IO ()
checkValues :: forall dType (idx :: Ctx (*)).
(CanCheck, TestShow dType) =>
dType -> Assignment (DerivedVal dType) idx -> IO ()
checkValues dType
got Assignment (DerivedVal dType) idx
expF = do
IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> IO () -> IO (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall tp. Index idx tp -> DerivedVal dType tp -> IO ())
-> Assignment (DerivedVal dType) idx -> IO ()
forall {k} (m :: * -> *) (ctx :: Ctx k) (f :: k -> *).
Applicative m =>
(forall (tp :: k). Index ctx tp -> f tp -> m ())
-> Assignment f ctx -> m ()
Ctx.traverseWithIndex_ (dType -> Index idx tp -> DerivedVal dType tp -> IO ()
forall dType (idx :: Ctx (*)) valType.
(CanCheck, TestShow dType) =>
dType -> Index idx valType -> DerivedVal dType valType -> IO ()
chkValue dType
got) Assignment (DerivedVal dType) idx
expF
let groupByInp :: t CheckResult -> [CheckResult]
groupByInp t CheckResult
chks =
let gmap :: Map (Maybe InputAsText) [CheckResult]
gmap = (CheckResult
-> Map (Maybe InputAsText) [CheckResult]
-> Map (Maybe InputAsText) [CheckResult])
-> Map (Maybe InputAsText) [CheckResult]
-> t CheckResult
-> Map (Maybe InputAsText) [CheckResult]
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CheckResult
-> Map (Maybe InputAsText) [CheckResult]
-> Map (Maybe InputAsText) [CheckResult]
insByInp Map (Maybe InputAsText) [CheckResult]
forall a. Monoid a => a
mempty t CheckResult
chks
insByInp :: CheckResult
-> Map (Maybe InputAsText) [CheckResult]
-> Map (Maybe InputAsText) [CheckResult]
insByInp = \case
c :: CheckResult
c@(CheckFailed CheckName
_ Maybe InputAsText
mbi FailureMessage
_) -> ([CheckResult] -> [CheckResult] -> [CheckResult])
-> Maybe InputAsText
-> [CheckResult]
-> Map (Maybe InputAsText) [CheckResult]
-> Map (Maybe InputAsText) [CheckResult]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [CheckResult] -> [CheckResult] -> [CheckResult]
forall a. Semigroup a => a -> a -> a
(<>) Maybe InputAsText
mbi [CheckResult
c]
CheckMessage Text
_ -> Map (Maybe InputAsText) [CheckResult]
-> Map (Maybe InputAsText) [CheckResult]
forall a. a -> a
id
addGroup :: (Maybe InputAsText, [CheckResult])
-> [CheckResult] -> [CheckResult]
addGroup (Maybe InputAsText
mbi,[CheckResult]
gchks) =
let newChks :: [CheckResult]
newChks = CheckResult -> CheckResult
dropInput (CheckResult -> CheckResult) -> [CheckResult] -> [CheckResult]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CheckResult]
gchks
dropInput :: CheckResult -> CheckResult
dropInput (CheckFailed CheckName
nm Maybe InputAsText
_ FailureMessage
fmsg) =
if Text -> Maybe Text
forall a. a -> Maybe a
Just (FailureMessage -> Text
failureMessage FailureMessage
fmsg) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== (InputAsText -> Text
inputAsText (InputAsText -> Text) -> Maybe InputAsText -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe InputAsText
mbi)
then CheckName -> Maybe InputAsText -> FailureMessage -> CheckResult
CheckFailed CheckName
nm Maybe InputAsText
forall a. Maybe a
Nothing
(FailureMessage -> CheckResult) -> FailureMessage -> CheckResult
forall a b. (a -> b) -> a -> b
$ Text -> FailureMessage
FailureMessage Text
"<< ^^ above input ^^ >>"
else CheckName -> Maybe InputAsText -> FailureMessage -> CheckResult
CheckFailed CheckName
nm Maybe InputAsText
forall a. Maybe a
Nothing FailureMessage
fmsg
dropInput i :: CheckResult
i@(CheckMessage Text
_) = CheckResult
i
grpTitle :: Text
grpTitle = Text -> (InputAsText -> Text) -> Maybe InputAsText -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<no input identified>"
((Text
"Input for below: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (InputAsText -> Text) -> InputAsText -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputAsText -> Text
inputAsText)
Maybe InputAsText
mbi
in ([CheckResult] -> [CheckResult] -> [CheckResult]
forall a. Semigroup a => a -> a -> a
<> ([CheckResult]
newChks [CheckResult] -> [CheckResult] -> [CheckResult]
forall a. Semigroup a => a -> a -> a
<> [Text -> CheckResult
CheckMessage Text
grpTitle]))
in ((Maybe InputAsText, [CheckResult])
-> [CheckResult] -> [CheckResult])
-> [CheckResult]
-> [(Maybe InputAsText, [CheckResult])]
-> [CheckResult]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe InputAsText, [CheckResult])
-> [CheckResult] -> [CheckResult]
addGroup [CheckResult]
forall a. Monoid a => a
mempty ([(Maybe InputAsText, [CheckResult])] -> [CheckResult])
-> [(Maybe InputAsText, [CheckResult])] -> [CheckResult]
forall a b. (a -> b) -> a -> b
$ Map (Maybe InputAsText) [CheckResult]
-> [(Maybe InputAsText, [CheckResult])]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Maybe InputAsText) [CheckResult]
gmap
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef [CheckResult] -> ([CheckResult] -> [CheckResult]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef CanCheck
IORef [CheckResult]
?checker [CheckResult] -> [CheckResult]
forall {t :: * -> *}. Foldable t => t CheckResult -> [CheckResult]
groupByInp
chkValue :: CanCheck
=> TestShow dType
=> dType -> Ctx.Index idx valType -> DerivedVal dType valType -> IO ()
chkValue :: forall dType (idx :: Ctx (*)) valType.
(CanCheck, TestShow dType) =>
dType -> Index idx valType -> DerivedVal dType valType -> IO ()
chkValue dType
got Index idx valType
_idx =
let ti :: Maybe InputAsText
ti = InputAsText -> Maybe InputAsText
forall a. a -> Maybe a
Just (InputAsText -> Maybe InputAsText)
-> InputAsText -> Maybe InputAsText
forall a b. (a -> b) -> a -> b
$ Text -> InputAsText
InputAsText (Text -> InputAsText) -> Text -> InputAsText
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ dType -> String
forall v. TestShow v => v -> String
testShow dType
got
in \case
(Val Text
txt dType -> valType
fld valType
v) ->
let msg :: Text
msg = Text
txt
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"expected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tv Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"failed"
tv :: Text
tv = String -> Text
T.pack (valType -> String
forall v. TestShow v => v -> String
testShow valType
v)
in (valType -> String)
-> Maybe InputAsText
-> Text
-> (valType -> Bool)
-> valType
-> IO ()
forall (m :: * -> *) a.
(CanCheck, MonadIO m) =>
(a -> String)
-> Maybe InputAsText -> Text -> (a -> Bool) -> a -> m ()
checkShow valType -> String
forall v. TestShow v => v -> String
testShow Maybe InputAsText
ti Text
msg (valType
v valType -> valType -> Bool
forall a. Eq a => a -> a -> Bool
==) (valType -> IO ()) -> valType -> IO ()
forall a b. (a -> b) -> a -> b
$ dType -> valType
fld dType
got
(Observe Text
txt dType -> valType
fld valType
v valType -> valType -> String
observationReport) ->
let msg :: Text
msg = Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" observation failure"
in (valType -> String)
-> Maybe InputAsText
-> Text
-> (valType -> Bool)
-> valType
-> IO ()
forall (m :: * -> *) a.
(CanCheck, MonadIO m) =>
(a -> String)
-> Maybe InputAsText -> Text -> (a -> Bool) -> a -> m ()
checkShow (valType -> valType -> String
observationReport valType
v) Maybe InputAsText
ti Text
msg (valType
v valType -> valType -> Bool
forall a. Eq a => a -> a -> Bool
==) (valType -> IO ()) -> valType -> IO ()
forall a b. (a -> b) -> a -> b
$ dType -> valType
fld dType
got
(Got Text
txt dType -> Bool
fld) -> (Bool -> String)
-> Maybe InputAsText -> Text -> (Bool -> Bool) -> Bool -> IO ()
forall (m :: * -> *) a.
(CanCheck, MonadIO m) =>
(a -> String)
-> Maybe InputAsText -> Text -> (a -> Bool) -> a -> m ()
checkShow Bool -> String
forall v. TestShow v => v -> String
testShow Maybe InputAsText
ti Text
txt Bool -> Bool
forall a. a -> a
id (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ dType -> Bool
fld dType
got
data DerivedVal i d where
Val :: (TestShow d, Eq d) => Text -> (i -> d) -> d -> DerivedVal i d
Got :: Text -> (i -> Bool) -> DerivedVal i Bool
Observe :: (Eq d) => Text -> (i -> d) -> d -> (d -> d -> String) -> DerivedVal i d
class TestShow v where
testShow :: v -> String
default testShow :: Show v => v -> String
testShow = v -> String
forall a. Show a => a -> String
show
instance TestShow ()
instance TestShow Bool
instance TestShow Int
instance TestShow Integer
instance TestShow Float
instance TestShow Char
instance TestShow String
instance (TestShow a, TestShow b) => TestShow (a,b) where
testShow :: (a, b) -> String
testShow (a
a,b
b) = String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall v. TestShow v => v -> String
testShow a
a String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> b -> String
forall v. TestShow v => v -> String
testShow b
b String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
instance (TestShow a, TestShow b, TestShow c) => TestShow (a,b,c) where
testShow :: (a, b, c) -> String
testShow (a
a,b
b,c
c) = String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall v. TestShow v => v -> String
testShow a
a String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> b -> String
forall v. TestShow v => v -> String
testShow b
b String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> c -> String
forall v. TestShow v => v -> String
testShow c
c String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
testShowList :: TestShow v => [v] -> String
testShowList :: forall v. TestShow v => [v] -> String
testShowList [v]
l = String
"[ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
", " (v -> String
forall v. TestShow v => v -> String
testShow (v -> String) -> [v] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [v]
l)) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" ]"
multiLineDiff :: T.Text -> T.Text -> String
multiLineDiff :: Text -> Text -> String
multiLineDiff Text
expected Text
actual =
let dl :: (a, a) -> a
dl (a
e,a
a) = if a
e a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a then a -> a
forall {a}. (Semigroup a, IsString a) => a -> a
db a
e else a -> a -> a
forall {a}. (Semigroup a, IsString a) => a -> a -> a
de a
" ↱" a
e a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\n " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a -> a -> a
forall {a}. (Semigroup a, IsString a) => a -> a -> a
da a
" ↳" a
a
db :: a -> a
db a
b = a
"| > " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b
de :: a -> a -> a
de a
m a
e = a
"|" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
m a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"expect> " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
e
da :: a -> a -> a
da a
m a
a = a
"|" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
m a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"actual> " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a
el :: [Text]
el = Text -> Text
visible (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [Text]
T.lines Text
expected
al :: [Text]
al = Text -> Text
visible (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [Text]
T.lines Text
actual
visible :: Text -> Text
visible = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
" " Text
"␠"
(Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\n" Text
""
(Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\t" Text
"␉"
(Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\012" Text
"␍"
addnum :: Int -> T.Text -> T.Text
addnum :: Int -> Text -> Text
addnum Int
n Text
l = let nt :: Text
nt = String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n)
nl :: Int
nl = Text -> Int
T.length Text
nt
in Int -> Text -> Text
T.take (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nl) Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l
ll :: [a] -> Text
ll = String -> Text
T.pack (String -> Text) -> ([a] -> String) -> [a] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> ([a] -> Int) -> [a] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
tl :: Text -> Text
tl = String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Text -> Int) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
T.length
banner :: Text
banner = Text
"MISMATCH between "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall {a}. [a] -> Text
ll [Text]
el Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"l/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
tl Text
expected Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"c expected and "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall {a}. [a] -> Text
ll [Text]
al Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"l/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
tl Text
actual Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"c actual"
diffReport :: [Text]
diffReport = ((Int, Text) -> Text) -> [(Int, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Text -> Text) -> (Int, Text) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Text -> Text
addnum) ([(Int, Text)] -> [Text]) -> [(Int, Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$
[Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([Text] -> [(Int, Text)]) -> [Text] -> [(Int, Text)]
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$
[ ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Text) -> Text
forall {a}. (Eq a, Semigroup a, IsString a) => (a, a) -> a
dl ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
el [Text]
al
, (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
de Text
"∌ ") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
al) [Text]
el
, (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
da Text
"∹ ") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
el) [Text]
al
]
[[Text]] -> [[Text]] -> [[Text]]
forall a. Semigroup a => a -> a -> a
<> if [Text]
el [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
al
then let maxlen :: Int
maxlen = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Text -> Int
T.length Text
expected) (Text -> Int
T.length Text
actual)
end :: Text -> Text
end Text
x = Int -> Text -> Text
T.drop (Int
maxlen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
5) Text
x
in [ [ Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
de Text
"∌ ending " (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
visible (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
end Text
expected ]
, [ Text -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a -> a
da Text
"∹ ending " (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
visible (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
end Text
actual ]
]
else [[Text]]
forall a. Monoid a => a
mempty
details :: [Text]
details = Text
banner Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
diffReport
in if Text
expected Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
actual then String
"<no difference>" else Text -> String
T.unpack ([Text] -> Text
T.unlines [Text]
details)