hs-bindgen-1.0.0.0: test/hs-bindgen/Test/HsBindgen/Unit/Tracer.hs
{-# OPTIONS_GHC -Wno-orphans #-}
module Test.HsBindgen.Unit.Tracer (tests) where
import Data.Data (Typeable)
import Data.Either (isLeft)
import Data.IORef (readIORef)
import Data.Proxy (Proxy (Proxy))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, testCase, (@?), (@?=))
import Test.Tasty.QuickCheck (Arbitrary (..), CoArbitrary, Fun, Function, Gen,
Property, elements, pattern Fn, testProperty,
(===))
import Text.SimplePrettyPrint qualified as PP
import HsBindgen.Util.Tracer
import Test.Common.HsBindgen.Trace.Predicate
import Test.Common.Util.Tasty
{-------------------------------------------------------------------------------
Tests
-------------------------------------------------------------------------------}
tests :: TestTree
tests = testGroup "Test.HsBindgen.Unit.Tracer" [
testGroup "DefaultLogLevel" [
testCase "none" $ assertMaxLevel [] Debug
, testCase "warning" $ assertMaxLevel [wn] Warning
, testCase "error" $ assertMaxLevel [er] Error
, testCase "error1" $ assertMaxLevel [wn, er] Error
, testCase "error2" $ assertMaxLevel [wn, er, wn] Error
, testCase "error3" $ assertMaxLevel [er, wn] Error
]
, testGroup "CustomLogLevel" [
testCase "none" $ assertMaxLevelWithDegrade [] Debug
, testCase "warning" $ assertMaxLevelWithDegrade [wn] Info
, testCase "warning1" $ assertMaxLevelWithDegrade [db, wn] Info
, testCase "warning2" $ assertMaxLevelWithDegrade [wn, db] Info
, testCase "warning3" $ assertMaxLevelWithDegrade [db, wn, db] Info
, testCase "error" $ assertMaxLevelWithDegrade [er] Info
, testCase "error1" $ assertMaxLevelWithDegrade [wn, er] Info
, testCase "error2" $ assertMaxLevelWithDegrade [wn, er, wn] Info
, testCase "error3" $ assertMaxLevelWithDegrade [er, wn] Info
, testGroup "semigroup" [
testProperty "const-log-level-last-wins" prop_constLevelLastWins
, testProperty "adapt-log-level-associative" prop_adaptLevelAssociative
, testProperty "adapt-log-level-unit" prop_adaptLevelUnit
]
]
, testGroup "LeftOnError" [
testCase "left" $ do
let tracerConf = quietTracerConfig {
verbosity = Verbosity Debug
}
res <- withTracer tracerConf $ \tracer -> do traceWith tracer $ withCallStack er
isLeft res @? "isLeft"
]
, testGroup "withTracePredicate" [
testCase "ok-debug" $
withPred defaultTracePredicate $ \tracer ->
traceWith tracer $ withCallStack db
, testCase "ok-info" $
withPred defaultTracePredicate $ \tracer ->
traceWith tracer $ withCallStack info
, testCase "!ok-notice" $
withPred defaultTracePredicate $ \tracer ->
traceWith tracer $ withCallStack notice
, testCase "!ok-warning" $
assertException "Expected TraceExpectationException" proxy $
withPred defaultTracePredicate $ \tracer ->
traceWith tracer $ withCallStack wn
, testCase "!ok-error" $
assertException "Expected TraceExpectationException" proxy $
withPred defaultTracePredicate $ \tracer ->
traceWith tracer $ withCallStack er
, testCase "ok-custom-warning" $
withPred expectWar $
\tracer -> do
traceWith tracer $ withCallStack wn
, testCase "ok-custom-error" $
withPred expectErr $
\tracer -> do
traceWith tracer $ withCallStack er
, testCase "!ok-custom-too-many" $
assertException "Expected TraceExpectationException" proxy $
withPred expectWar $
\tracer -> do
traceWith tracer $ withCallStack wn
traceWith tracer $ withCallStack wn
, testCase "!ok-custom-too-few" $
assertException "Expected TraceExpectationException" proxy $
withPred expectWar $
\tracer -> do
traceWith tracer $ withCallStack db
]
]
where
db = TestDebug "Debug message."
info = TestInfo "Info message."
notice = TestNotice "Notice message."
wn = TestWarning "Warning!"
er = TestError "Error!"
proxy = Proxy :: Proxy (TraceExpectationException TestTrace)
expectWar = singleTracePredicate $ \case
TestWarning _ -> Just $ Expected ()
_otherTrace -> Nothing
expectErr = singleTracePredicate $ \case
TestError _ -> Just $ Expected ()
_otherTrace -> Nothing
withPred :: (IsTrace Level a, Typeable a, Show a) =>
TracePredicate Level a -> (Tracer a -> IO b) -> IO b
withPred = withTracePredicate noReport
noReport :: a -> IO ()
noReport = const $ pure ()
{-------------------------------------------------------------------------------
Internal: infrastructure for generating test traces
-------------------------------------------------------------------------------}
data TestTrace =
TestDebug String
| TestInfo String
| TestNotice String
| TestWarning String
| TestError String
deriving stock (Show, Eq)
instance PrettyForTrace TestTrace where
prettyForTrace = \case
TestDebug x -> PP.string x
TestInfo x -> PP.string x
TestNotice x -> PP.string x
TestWarning x -> PP.string x
TestError x -> PP.string x
instance IsTrace Level TestTrace where
getDefaultLogLevel = \case
TestDebug _ -> Debug
TestInfo _ -> Info
TestNotice _ -> Notice
TestWarning _ -> Warning
TestError _ -> Error
getSource = const HsBindgen
getTraceId = const "test"
assertMaxLevel :: [TestTrace] -> Level -> Assertion
assertMaxLevel = assertMaxLevelWithCustomLogLevel mempty
alwaysLevel :: Level -> CustomLogLevel Level a
alwaysLevel level = CustomLogLevel $ const . const level
assertMaxLevelWithDegrade :: [TestTrace] -> Level -> Assertion
assertMaxLevelWithDegrade =
assertMaxLevelWithCustomLogLevel $ alwaysLevel Info
assertMaxLevelWithCustomLogLevel
:: CustomLogLevel Level TestTrace -> [TestTrace] -> Level -> Assertion
assertMaxLevelWithCustomLogLevel customLogLevel traces expectedLevel = do
lvl <- testTracerIO customLogLevel traces
lvl @?= expectedLevel
testTracerIO :: CustomLogLevel Level TestTrace -> [TestTrace] -> IO Level
testTracerIO customLogLevel traces = do
let tracerConfig :: TracerConfig Level TestTrace
tracerConfig = quietTracerConfig {
verbosity = Verbosity Debug
, customLogLevel = customLogLevel
}
-- NB: Use and test the tracer functionality provided by @hs-bindgen:lib@,
-- and not by the tests (e.g., 'withTracePredicate').
(TracerState maxLogLevel) <- withTracerUnsafe tracerConfig $ \tracer ref -> do
mapM_ (traceWith tracer . withCallStack) traces
readIORef ref
pure maxLogLevel
{-------------------------------------------------------------------------------
Property-based
-------------------------------------------------------------------------------}
instance Arbitrary Level where
arbitrary = elements [minBound .. maxBound]
instance CoArbitrary Level
instance Function Level
newtype ConstCustomLogLevel = ConstCustomLogLevel (
CustomLogLevel Level TestTrace
)
unConstCustomLogLevel :: ConstCustomLogLevel -> CustomLogLevel Level TestTrace
unConstCustomLogLevel (ConstCustomLogLevel x) = x
instance Show ConstCustomLogLevel where
show (ConstCustomLogLevel (CustomLogLevel f)) =
"ConstCustomLogLevel: " <> show (f (TestDebug "") Debug)
instance Arbitrary ConstCustomLogLevel where
arbitrary = do
lvl <- arbitrary :: Gen Level
pure $ ConstCustomLogLevel $ CustomLogLevel $ \_ -> const lvl
instance Arbitrary TestTrace where
arbitrary = do
c <- elements [TestDebug, TestInfo, TestNotice, TestWarning, TestError]
s <- arbitrary :: Gen String
pure $ c s
apply :: IsTrace l a => CustomLogLevel l a -> a -> l
apply (CustomLogLevel f) tr = f tr (getDefaultLogLevel tr)
applys :: IsTrace l a => [CustomLogLevel l a] -> a -> l
applys = apply . mconcat
prop_constLevelLastWins ::
[ConstCustomLogLevel] -> ConstCustomLogLevel -> TestTrace -> Property
prop_constLevelLastWins xs x tr =
applys (map unConstCustomLogLevel $ xs ++ [x]) tr
=== apply (unConstCustomLogLevel x) tr
prop_adaptLevelAssociative ::
Fun Level Level -> Fun Level Level -> Fun Level Level -> TestTrace -> Property
prop_adaptLevelAssociative (Fn f1) (Fn f2) (Fn f3) tr =
apply (c1 <> (c2 <> c3)) tr === apply ((c1 <> c2) <> c3) tr
where toCustomLogLevel f = CustomLogLevel $ \_ lvl -> f lvl
c1 = toCustomLogLevel f1
c2 = toCustomLogLevel f2
c3 = toCustomLogLevel f3
prop_adaptLevelUnit ::
Fun Level Level -> TestTrace -> Property
prop_adaptLevelUnit (Fn f) tr =
apply (mconcat $ pure c) tr === apply c tr
where c = CustomLogLevel $ \_ lvl -> f lvl