what4-1.2: test/ConfigTest.hs
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
import Control.Exception ( displayException, try, SomeException(..), fromException )
import qualified Data.List as L
import Data.Parameterized.Context ( pattern Empty, pattern (:>) )
import Data.Parameterized.Some
import Data.Ratio ( (%) )
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Void
import qualified Prettyprinter as PP
import Test.Tasty
import Test.Tasty.Checklist
import Test.Tasty.HUnit
import What4.BaseTypes
import What4.Concrete
import What4.Config
testSetAndGet :: [TestTree]
testSetAndGet =
[
testCase "create multiple options" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"
o2 = configOption BaseIntegerRepr "optint"
o3 = configOption BaseBoolRepr "optbool"
o1' = mkOpt o1 stringOptSty Nothing Nothing
o2' = mkOpt o2 integerOptSty Nothing Nothing
o3' = mkOpt o3 boolOptSty Nothing Nothing
extendConfig [o3', o2', o1'] cfg
, testCase "create conflicting options" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "mainopt"
o2 = configOption BaseIntegerRepr "mainopt"
o1' = mkOpt o1 stringOptSty Nothing Nothing
o2' = mkOpt o2 integerOptSty Nothing Nothing
res <- try $ extendConfig [o2', o1'] cfg
wantOptCreateFailure "already exists with type" res
, testCase "create conflicting options at different levels" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "mainopt"
o2 = configOption BaseIntegerRepr "main.mainopt"
o1' = mkOpt o1 stringOptSty Nothing Nothing
o2' = mkOpt o2 integerOptSty Nothing Nothing
res <- try @SomeException $ extendConfig [o2', o1'] cfg
case res of
Right () -> return ()
Left e -> assertFailure $ "Unexpected exception: " <> displayException e
, testCase "create duplicate unicode options" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "mainopt"
o2 = configOption (BaseStringRepr UnicodeRepr) "mainopt"
o1' = mkOpt o1 stringOptSty Nothing Nothing
o2' = mkOpt o2 stringOptSty Nothing Nothing
res <- try @SomeException $ extendConfig [o2', o1'] cfg
case res of
Right () -> return ()
Left e -> assertFailure $ "Unexpected exception: " <> displayException e
, testCaseSteps "get unset value, no default" $ \step -> do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"
o2 = configOption BaseIntegerRepr "optint"
o3 = configOption BaseBoolRepr "optbool"
o1' = mkOpt o1 stringOptSty Nothing Nothing
o2' = mkOpt o2 integerOptSty Nothing Nothing
o3' = mkOpt o3 boolOptSty Nothing Nothing
extendConfig [o3', o2', o1'] cfg
access1 <- getOptionSetting o1 cfg
access2 <- getOptionSetting o2 cfg
access3 <- getOptionSetting o3 cfg
step "get unset string opt"
v1 <- getMaybeOpt access1
Nothing @=? v1
res1 <- try $ getOpt access1
wantOptGetFailure "not set" res1
step "get unset integer opt"
v2 <- getMaybeOpt access2
Nothing @=? v2
res2 <- try $ getOpt access2
wantOptGetFailure "not set" res2
step "get unset bool opt"
v3 <- getMaybeOpt access3
Nothing @=? v3
res3 <- try $ getOpt access3
wantOptGetFailure "not set" res3
, testCaseSteps "get unset value, with default" $ \step -> do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"
o2 = configOption BaseIntegerRepr "optint"
o3 = configOption BaseBoolRepr "optbool"
o1' = mkOpt o1 stringOptSty Nothing (Just $ ConcreteString "strval")
o2' = mkOpt o2 integerOptSty Nothing (Just $ ConcreteInteger 11)
o3' = mkOpt o3 boolOptSty Nothing (Just $ ConcreteBool True)
extendConfig [o3', o2', o1'] cfg
access1 <- getOptionSetting o1 cfg
access2 <- getOptionSetting o2 cfg
access3 <- getOptionSetting o3 cfg
step "get unset default string opt"
v1 <- getMaybeOpt access1
Just "strval" @=? v1
step "get unset default integer opt"
v2 <- getMaybeOpt access2
Just 11 @=? v2
step "get unset default bool opt"
v3 <- getMaybeOpt access3
Just True @=? v3
, testCaseSteps "get set value, with default" $ \step -> do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"
o2 = configOption BaseIntegerRepr "optint"
o3 = configOption BaseBoolRepr "optbool"
o1' = mkOpt o1 stringOptSty Nothing (Just $ ConcreteString "strval")
o2' = mkOpt o2 integerOptSty Nothing (Just $ ConcreteInteger 11)
o3' = mkOpt o3 boolOptSty Nothing (Just $ ConcreteBool True)
extendConfig [o3', o2', o1'] cfg
access1 <- getOptionSetting o1 cfg
access2 <- getOptionSetting o2 cfg
access3 <- getOptionSetting o3 cfg
step "set string opt"
res1 <- setOpt access1 "flibberty"
show <$> res1 @?= []
step "set bool opt"
res2 <- setOpt access3 False
show <$> res2 @?= []
step "set integer opt"
res3 <- setOpt access2 9945
show <$> res3 @?= []
step "get string opt"
v1 <- getMaybeOpt access1
Just "flibberty" @=? v1
step "get integer opt"
v2 <- getMaybeOpt access2
Just 9945 @=? v2
step "get bool opt"
v3 <- getMaybeOpt access3
Just False @=? v3
, testCaseSteps "set invalid values" $ \step -> do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"
o2 = configOption BaseIntegerRepr "optint"
o3 = configOption BaseRealRepr "optbool"
-- n.b. the default values are not checked by the style!
o1' = mkOpt o1 (enumOptSty
(Set.fromList ["eeny", "meeny", "miny", "mo" ]))
Nothing (Just $ ConcreteString "strval")
o2' = mkOpt o2 (integerWithRangeOptSty Unbounded (Inclusive 10))
Nothing (Just $ ConcreteInteger 11)
o3' = mkOpt o3 (realWithMinOptSty (Exclusive 1.23))
Nothing (Just $ ConcreteReal 0.0)
extendConfig [o3', o2', o1'] cfg
access1 <- getOptionSetting o1 cfg
access2 <- getOptionSetting o2 cfg
access3 <- getOptionSetting o3 cfg
step "initial defaults"
getMaybeOpt access1 >>= (@?= Just "strval")
getMaybeOpt access2 >>= (@?= Just 11)
getMaybeOpt access3 >>= (@?= Just (0 % 1 :: Rational))
step "set string opt invalidly"
-- Note: the strong typing prevents both of the following
-- setOpt access1 32
-- setOpt access1 False
res1 <- try $ setOpt access1 "frobozz"
wantOptSetFailure "invalid setting \"frobozz\"" res1
wantOptSetFailure "eeny, meeny, miny, mo" res1
(try @SomeException $ setOpt access1 "meeny") >>= \case
Right [] -> return ()
Right w -> assertFailure $ "Unexpected warnings: " <> show w
Left e -> assertFailure $ "Unexpected exception: " <> displayException e
step "set integer opt invalidly"
wantOptSetFailure "out of range" =<< (try $ setOpt access2 11)
wantOptSetFailure "expected integer value in (-∞, 10]" =<< (try $ setOpt access2 11)
(try @SomeException $ setOpt access2 10) >>= \case
Right [] -> return ()
Right w -> assertFailure $ "Unexpected warnings: " <> show w
Left e -> assertFailure $ "Unexpected exception: " <> displayException e
(try @SomeException $ setOpt access2 (-3)) >>= \case
Right [] -> return ()
Right w -> assertFailure $ "Unexpected warnings: " <> show w
Left e -> assertFailure $ "Unexpected exception: " <> displayException e
step "set real opt invalidly"
wantOptSetFailure "out of range" =<< (try $ setOpt access3 (0 % 3))
wantOptSetFailure "expected real value in (123 % 100, +∞)"
=<< (try $ setOpt access3 (0 % 3))
wantOptSetFailure "out of range" =<< (try $ setOpt access3 (1229 % 1000))
wantOptSetFailure "out of range" =<< (try $ setOpt access3 (123 % 100))
(try @SomeException $ setOpt access3 (123001 % 100000)) >>= \case
Right [] -> return ()
Right w -> assertFailure $ "Unexpected warnings: " <> show w
Left e -> assertFailure $ "Unexpected exception: " <> displayException e
, testCaseSteps "get and set option values by name" $ \step ->
withChecklist "multiple values" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "main.optstr"
o2 = configOption BaseIntegerRepr "main.set.cfg.optint"
o3 = configOption BaseBoolRepr "main.set.cfg.optbool"
o4 = configOption BaseIntegerRepr "alt.optint"
o1' = mkOpt o1 stringOptSty Nothing (Just $ ConcreteString "strval")
o2' = mkOpt o2 integerOptSty Nothing (Just $ ConcreteInteger 11)
o3' = mkOpt o3 boolOptSty Nothing (Just $ ConcreteBool True)
o4' = mkOpt o4 integerOptSty Nothing (Just $ ConcreteInteger 88)
extendConfig [o4', o3', o2', o1'] cfg
accessSome1 <- getOptionSettingFromText "main.optstr" cfg
accessSome2 <- getOptionSettingFromText "main.set.cfg.optint" cfg
accessSome3 <- getOptionSettingFromText "main.set.cfg.optbool" cfg
accessSome4 <- getOptionSettingFromText "alt.optint" cfg
access1 <- getOptionSetting o1 cfg
access2 <- getOptionSetting o2 cfg
access3 <- getOptionSetting o3 cfg
access4 <- getOptionSetting o4 cfg
step "getting with a Some OptionSetter requires type verification"
let cmpUnderSome :: Some OptionSetting -> T.Text -> IO ()
cmpUnderSome (Some getter) v =
case testEquality
(configOptionType (optionSettingName getter))
(BaseStringRepr UnicodeRepr) of
Just Refl -> do vt <- getMaybeOpt getter
Just v @=? vt
Nothing -> assertFailure "invalid option type"
cmpUnderSome accessSome1 "strval"
step "setting using special setting functions"
let goodNoWarn f s v =
(try @SomeException $ f s v) >>= \case
Right [] -> return ()
Right w -> assertFailure $ "Unexpected warnings: " <> show w
Left e -> assertFailure $ "Unexpected exception: " <> displayException e
goodNoWarn setUnicodeOpt accessSome1 "wild carrots"
goodNoWarn setIntegerOpt accessSome2 31
goodNoWarn setIntegerOpt accessSome4 42
goodNoWarn setBoolOpt accessSome3 False
step "verify set values"
(Just "wild carrots" @=?) =<< getMaybeOpt access1
(Just 31 @=?) =<< getMaybeOpt access2
(Just False @=?) =<< getMaybeOpt access3
(Just 42 @=?) =<< getMaybeOpt access4
step "cannot set values with wrong types"
-- Note that using an OptionSetting allows compile-time
-- elimination, but using a (Some OptionSetting) requires
-- run-time type witnessing and validation
wantOptSetFailure "type is a BaseStringRepr"
=<< (try $ setIntegerOpt accessSome1 54)
wantOptSetFailure "but given an integer"
=<< (try $ setIntegerOpt accessSome1 54)
wantOptSetFailure "type is a BaseStringRepr"
=<< (try $ setBoolOpt accessSome1 True)
wantOptSetFailure "but given a boolean"
=<< (try $ setBoolOpt accessSome1 True)
wantOptSetFailure "type is a BaseIntegerRepr"
=<< (try $ setUnicodeOpt accessSome2 "fresh tomatoes")
wantOptSetFailure "but given a text string"
=<< (try $ setUnicodeOpt accessSome2 "fresh tomatoes")
, testCaseSteps "get multiple values at once" $ \step ->
withChecklist "multiple values" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "main.optstr"
o2 = configOption BaseIntegerRepr "main.set.cfg.optint"
o3 = configOption BaseBoolRepr "main.set.cfg.optbool"
o4 = configOption BaseIntegerRepr "alt.optint"
o1' = mkOpt o1 stringOptSty Nothing (Just $ ConcreteString "strval")
o2' = mkOpt o2 integerOptSty Nothing (Just $ ConcreteInteger 11)
o3' = mkOpt o3 boolOptSty Nothing (Just $ ConcreteBool True)
o4' = mkOpt o4 integerOptSty Nothing (Just $ ConcreteInteger 88)
extendConfig [o4', o3', o2', o1'] cfg
access1 <- getOptionSetting o1 cfg
access3 <- getOptionSetting o3 cfg
access4 <- getOptionSetting o4 cfg
step "set string opt"
res1 <- setOpt access1 "flibberty"
show <$> res1 @?= []
step "set bool opt"
res2 <- setOpt access3 False
show <$> res2 @?= []
step "set alt int opt"
res4 <- setOpt access4 789
show <$> res4 @?= []
step "get main config values"
res <- getConfigValues "main.set" cfg
let msg = show . PP.pretty <$> res
msg `checkValues`
(Empty
:> Val "num values" length 2
:> Val "bool" (any (L.isInfixOf "main.set.cfg.optbool = False")) True
:> Val "int" (any (L.isInfixOf "main.set.cfg.optint = 11")) True
)
step "get all config values"
resAll <- getConfigValues "" cfg
let msgAll = show . PP.pretty <$> resAll
msgAll `checkValues`
(Empty
:> Val "num values" length 5
:> Val "bool" (any (L.isInfixOf "main.set.cfg.optbool = False")) True
:> Val "int" (any (L.isInfixOf "main.set.cfg.optint = 11")) True
:> Val "alt int" (any (L.isInfixOf "alt.optint = 789")) True
:> Val "str" (any (L.isInfixOf "main.optstr = \"flibberty\"")) True
:> Val "verbosity" (any (L.isInfixOf "verbosity = 0")) True
)
step "get specific config value"
resOne <- getConfigValues "alt.optint" cfg
let msgOne = show . PP.pretty <$> resOne
msgOne `checkValues`
(Empty
:> Val "num values" length 1
:> Val "alt int" (any (L.isInfixOf "alt.optint = 789")) True
)
step "get unknown config value"
resNope <- getConfigValues "fargle.bargle" cfg
let msgNope = show . PP.pretty <$> resNope
msgNope `checkValues` (Empty :> Val "num values" length 0)
]
testDeprecated :: [TestTree]
testDeprecated =
[
testCase "deprecation removal (case #1)" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "hello"
o1' = mkOpt o1 stringOptSty (Just "greeting") Nothing
extendConfig [deprecatedOpt [] o1'] cfg
setter <- getOptionSetting o1 cfg
res <- try $ setOpt setter "eh?"
case res of
Right warns ->
fmap show warns @?=
[ "DEPRECATED CONFIG OPTION WILL BE IGNORED: hello (no longer valid)"
]
Left (SomeException e) -> assertFailure $ show e
, testCase "deprecation rename (case #2)" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "hi"
o2 = configOption (BaseStringRepr UnicodeRepr) "hello"
o1' = deprecatedOpt [o2'] $
mkOpt o1 stringOptSty (Just "greeting") Nothing
o2' = mkOpt o2 stringOptSty (Just "greeting") Nothing
extendConfig [o2', o1'] cfg
setter <- getOptionSetting o1 cfg
res <- try $ setOpt setter "eh?"
case res of
Right warns ->
fmap show warns @?=
[ "DEPRECATED CONFIG OPTION USED: hi (renamed to: hello)"
]
Left (SomeException e) -> assertFailure $ show e
, testCase "deprecation rename (case #2), wrong order" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "yo"
o2 = configOption (BaseStringRepr UnicodeRepr) "hello"
o1' = deprecatedOpt [o2'] $
mkOpt o1 stringOptSty (Just "greeting") Nothing
o2' = mkOpt o2 stringOptSty (Just "greeting") Nothing
res <- try $ extendConfig [o1', o2'] cfg
wantOptCreateFailure
"replacement options must be inserted into Config \
\before this deprecated option"
res
, testCase "deprecation rename and re-typed (case #3)" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"
o2 = configOption BaseIntegerRepr "optnum"
o1' = deprecatedOpt [o2'] $
mkOpt o1 stringOptSty (Just "some opt") Nothing
o2' = mkOpt o2 integerOptSty (Just "some other opt") Nothing
extendConfig [o2', o1'] cfg
setter <- getOptionSetting o1 cfg
res <- try $ setOpt setter "eh?"
case res of
Right warns ->
fmap show warns @?=
[ "DEPRECATED CONFIG OPTION USED: optstr::BaseStringRepr UnicodeRepr (changed to: \"optnum\"::BaseIntegerRepr); this value may be ignored"
]
Left (SomeException e) -> assertFailure $ show e
, testCase "deprecation, multiple replacements (case #4)" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "url"
o2 = configOption (BaseStringRepr UnicodeRepr) "hostname"
o3 = configOption BaseIntegerRepr "port"
o1' = deprecatedOpt [o2', o3'] $
mkOpt o1 stringOptSty (Just "some opt") Nothing
o2' = mkOpt o2 stringOptSty (Just "some other opt") Nothing
o3' = mkOpt o3 integerOptSty (Just "some other opt") Nothing
extendConfig [o3', o2', o1'] cfg
setter <- getOptionSetting o1 cfg
res <- try $ setOpt setter "here?"
case res of
Right warns ->
fmap show warns @?=
[ "DEPRECATED CONFIG OPTION USED: url::BaseStringRepr UnicodeRepr (replaced by: \"hostname\"::BaseStringRepr UnicodeRepr, \"port\"::BaseIntegerRepr); this value may be ignored"
]
Left (SomeException e) -> assertFailure $ show e
, testCase "deprecation, multiple + removed/split (case #4,(#1,#3))" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "url"
o2 = configOption (BaseStringRepr UnicodeRepr) "hostname"
o3 = configOption BaseIntegerRepr "port"
o4 = configOption (BaseStringRepr UnicodeRepr) "host"
o5 = configOption (BaseStringRepr UnicodeRepr) "domain"
o1' = deprecatedOpt [o2', o3'] $
mkOpt o1 stringOptSty (Just "some opt") Nothing
o2' = deprecatedOpt [o4', o5'] $
mkOpt o2 stringOptSty (Just "some other opt") Nothing
o3' = deprecatedOpt [] $
mkOpt o3 integerOptSty (Just "some other opt") Nothing
o4' = mkOpt o4 stringOptSty (Nothing) Nothing
o5' = mkOpt o5 stringOptSty (Just "some opt") (Just $ ConcreteString "cow.barn")
extendConfig [ o4', o5', o2', o3', o1' ] cfg
setter <- getOptionSetting o1 cfg
res <- try $ setOpt setter "here?"
case res of
Right warns ->
fmap show warns @?=
[ "DEPRECATED CONFIG OPTION USED: url::BaseStringRepr UnicodeRepr (replaced by: \"host\"::BaseStringRepr UnicodeRepr, \"domain\"::BaseStringRepr UnicodeRepr); this value may be ignored"
]
Left (SomeException e) -> assertFailure $ show e
]
testHelp :: [TestTree]
testHelp =
[
testCase "builtin-only config help" $
withChecklist "builtins" $ do
cfg <- initialConfig 0 []
help <- configHelp "" cfg
help `checkValues`
(Empty
:> Val "num" length 1
:> Val "verbosity" (L.isInfixOf "verbosity =" . show . head) True
)
, testCaseSteps "three item (1 deprecated) config help" $ \step ->
withChecklist "three items" $ do
cfg <- initialConfig 0 []
let o1 = configOption (BaseStringRepr UnicodeRepr) "optstr"
o2 = configOption BaseIntegerRepr "optnum"
o3 = configOption BaseIntegerRepr "foo.bar.baz.num"
o1' = mkOpt o1 stringOptSty (Just "some opt") Nothing
o2' = mkOpt o2 integerOptSty (Just "some other opt") Nothing
o3' = mkOpt o3 integerOptSty (Just "foo stuff") Nothing
helpIncludes txts = any (\h -> all (\t -> L.isInfixOf t (show h)) txts)
extendConfig [o2', deprecatedOpt [o2'] o1', o3'] cfg
setter2 <- getOptionSetting o2 cfg
setRes <- setOpt setter2 13
setRes `checkValues` (Empty :> Val "no warnings" null True)
step "all help"
help <- configHelp "" cfg
help `checkValues`
(Empty
:> Val "num" length 4
:> Val "verbosity" (helpIncludes ["verbosity ="]) True
:> Val "option 1" (helpIncludes ["optstr"
, "some opt"
, "DEPRECATED!"
, "Suggest"
, "to \"optnum\""
]) True
:> Val "option 2" (helpIncludes ["optnum", "= 13", "some other opt"]) True
:> Val "option 3" (helpIncludes ["foo.bar.baz.num", "foo stuff"]) True
)
step "sub help"
subHelp <- configHelp "foo.bar" cfg
subHelp `checkValues`
(Empty
:> Val "num" length 1
:> Val "option 3" (helpIncludes ["foo.bar.baz.num", "foo stuff"]) True
)
step "specific help"
spec <- configHelp "optstr" cfg
spec `checkValues`
(Empty
:> Val "num" length 1
:> Val "spec name" (helpIncludes ["optstr"]) True
:> Val "spec opt help" (helpIncludes ["some opt"]) True
:> Val "spec opt help deprecated" (helpIncludes [ "DEPRECATED!"
, "Suggest"
, "to \"optnum\""
]) True
)
step "specific sub help"
subspec <- configHelp "foo.bar.baz.num" cfg
subspec `checkValues`
(Empty
:> Val "num" length 1
:> Val "option 3" (helpIncludes ["foo.bar.baz.num", "foo stuff"]) True
)
]
instance TestShow (PP.Doc Void) where testShow = show
instance TestShow [PP.Doc Void] where testShow = testShowList
instance TestShow [String] where testShow = testShowList
wantOptCreateFailure :: Show a => String -> Either SomeException a -> IO ()
wantOptCreateFailure withText res = case res of
Right r ->
assertFailure ("Expected '" <> withText <>
"' but completed successfully with: " <> show r)
Left err ->
case fromException err of
Just (e :: OptCreateFailure) ->
withText `L.isInfixOf` (show e) @?
("Expected '" <> withText <> "' exception error but got: " <>
displayException e)
_ -> assertFailure $
"Expected OptCreateFailure exception but got: " <>
displayException err
wantOptSetFailure :: Show a => String -> Either SomeException a -> IO ()
wantOptSetFailure withText res = case res of
Right r ->
assertFailure ("Expected '" <> withText <>
"' but completed successfully with: " <> show r)
Left err ->
case fromException err of
Just (e :: OptSetFailure) ->
withText `L.isInfixOf` (show e) @?
("Expected '" <> withText <> "' exception error but got: " <>
displayException e)
_ -> assertFailure $
"Expected OptSetFailure exception but got: " <>
displayException err
wantOptGetFailure :: Show a => String -> Either SomeException a -> IO ()
wantOptGetFailure withText res = case res of
Right r ->
assertFailure ("Expected '" <> withText <>
"' but completed successfully with: " <> show r)
Left err ->
case fromException err of
Just (e :: OptGetFailure) ->
withText `L.isInfixOf` (show e) @?
("Expected '" <> withText <> "' exception error but got: " <>
displayException e)
_ -> assertFailure $
"Expected OptGetFailure exception but got: " <>
displayException err
main :: IO ()
main = defaultMain $
testGroup "ConfigTests"
[ testGroup "Set and get" $ testSetAndGet
, testGroup "Deprecated Configs" $ testDeprecated
, testGroup "Config help" $ testHelp
]