Property.hs

{-# LANGUAGE OverloadedStrings #-}

{-|
Description:    

Copyright:      (c) 2021 Sam May
License:        GPL-3.0-or-later
Maintainer:     ag@eitilt.life

Stability:      experimental
Portability:    portable
-}
module Foreign.Libcdio.Logging.Test.Property
    ( properties
    ) where


import qualified Hedgehog as H
import qualified Hedgehog.Gen as H.G
import qualified Hedgehog.Range as H.R

import Foreign.Libcdio.Logging
import Foreign.Libcdio.Logging.Test.Classes

import Test.Libcdio.Property.Common

import Hedgehog ( (===) )


properties :: H.Group
properties = H.Group "Foreign.Libcdio.Logging"
    [ setGetCutoff
    , filtered
 -- , retrieval
    , persistance
    , clear
    ]


setGetCutoff :: Test
setGetCutoff = packTest "Cutoff level is successfully recovered" $ do
    H.evalIO setupLogger
    l <- H.forAll genLogLevel
    H.evalIO $ setLogCutoff l
    l' <- H.evalIO logCutoff
    l === l'


logTest :: ([LogEntry] -> LogLevel -> H.PropertyT IO ()) -> H.PropertyT IO ()
logTest prop = do
    H.evalIO setupLogger
    H.evalIO clearLog
    minLevel <- H.forAll genLogLevel
    msgs <- H.forAll $ H.G.list (H.R.linear 0 16) genLogEntry
    H.evalIO $ setLogCutoff minLevel
    H.evalIO $ mapM_ putLog msgs
    prop msgs minLevel
    H.evalIO clearLog


filtered :: Test
filtered = packTest "Log entries below the cutoff are hidden" . logTest $ \_ minLevel -> do
    msgs <- H.evalIO readLog
    H.annotateShow msgs
    H.assert . flip all msgs $ \msg -> logLevel msg >= minLevel

retrieval :: Test
retrieval = packTest "Log entries are read unchanged" . logTest $ \msgs minLevel -> do
    msgs' <- H.evalIO readLog
    filter (\msg -> logLevel msg >= minLevel) msgs === msgs'

persistance :: Test
persistance = packTest "'readLog' doesn't modify the logs" . logTest $ \_ _ -> do
    msgs <- H.evalIO readLog
    msgs' <- H.evalIO readLog
    msgs === msgs'

clear :: Test
clear = packTest "Clearing removes the entire log" . logTest $ \_ _ -> do
    H.evalIO clearLog
    msgs' <- H.evalIO readLog
    msgs' === []