{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module OptEnvConf.Test
( -- * Lint test
settingsLintSpec,
parserLintSpec,
parserLintTest,
-- * Parse tests
settingsParserArgsTest,
parserArgsTest,
settingsParserEnvTest,
parserEnvTest,
settingsParserConfTest,
parserConfTest,
settingsParserTest,
parserTest,
-- * Completion tests
settingsParserCompletionTest,
settingsParserCompletionDescriptionTest,
parserCompletionTest,
parserCompletionDescriptionTest,
-- * Reference documentation
goldenSettingsReferenceDocumentationSpec,
goldenParserReferenceDocumentationSpec,
pureGoldenReferenceDocumentation,
-- * Nix options
goldenSettingsNixOptionsSpec,
goldenParserNixOptionsSpec,
pureGoldenNixOptions,
module OptEnvConf,
)
where
import Data.Aeson as JSON
import Data.Char (isDigit)
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Stack (CallStack, HasCallStack, getCallStack, withFrozenCallStack)
import qualified GHC.Stack as Stack
import OptEnvConf
import OptEnvConf.Args
import OptEnvConf.Completion
import OptEnvConf.EnvMap as EnvMap
import OptEnvConf.Error
import OptEnvConf.Lint
import Test.Syd
import Text.Colour
settingsLintSpec :: forall a. (HasCallStack) => (HasParser a) => Spec
settingsLintSpec = withFrozenCallStack $ parserLintSpec (settingsParser @a)
parserLintSpec :: forall a. (HasCallStack) => Parser a -> Spec
parserLintSpec parser =
withFrozenCallStack $
specify "pass the lint test" $
parserLintTest parser
parserLintTest :: Parser a -> IO ()
parserLintTest parser =
case lintParser parser of
Nothing -> pure ()
Just errs ->
expectationFailure $ T.unpack $ renderChunksText With24BitColours $ renderLintErrors errs
settingsParserArgsTest :: (Show a, Eq a, HasParser a) => [String] -> a -> IO ()
settingsParserArgsTest = parserArgsTest settingsParser
parserArgsTest :: (Show a, Eq a) => Parser a -> [String] -> a -> IO ()
parserArgsTest parser args = parserTest parser args [] Nothing
settingsParserEnvTest :: (Show a, Eq a, HasParser a) => [(String, String)] -> a -> IO ()
settingsParserEnvTest = parserEnvTest settingsParser
parserEnvTest :: (Show a, Eq a) => Parser a -> [(String, String)] -> a -> IO ()
parserEnvTest parser envVars = parserTest parser [] envVars Nothing
settingsParserConfTest :: (Show a, Eq a, HasParser a) => JSON.Object -> a -> IO ()
settingsParserConfTest = parserConfTest settingsParser
parserConfTest :: (Show a, Eq a) => Parser a -> JSON.Object -> a -> IO ()
parserConfTest parser obj = parserTest parser [] [] (Just obj)
settingsParserTest :: (Show a, Eq a, HasParser a) => [String] -> [(String, String)] -> Maybe JSON.Object -> a -> IO ()
settingsParserTest = parserTest settingsParser
parserTest :: (Show a, Eq a) => Parser a -> [String] -> [(String, String)] -> Maybe JSON.Object -> a -> IO ()
parserTest parser args envVars mObject expected = do
errOrActual <- runParserOn allCapabilities Nothing parser (parseArgs args) (EnvMap.parse envVars) mObject
case errOrActual of
Left errs -> expectationFailure $ T.unpack $ renderChunksText With24BitColours $ renderErrors errs
Right actual -> actual `shouldBe` expected
settingsParserCompletionTest :: forall a. (HasParser a) => Int -> [String] -> [Completion String] -> IO ()
settingsParserCompletionTest = parserCompletionTest (settingsParser @a)
settingsParserCompletionDescriptionTest :: forall a. (HasParser a) => Int -> [String] -> [String] -> IO ()
settingsParserCompletionDescriptionTest = parserCompletionDescriptionTest (settingsParser @a)
parserCompletionTest :: Parser a -> Int -> [String] -> [Completion String] -> IO ()
parserCompletionTest p ix ws expected = do
let arg = fromMaybe "" $ listToMaybe $ drop ix ws
let completions = pureCompletionQuery p ix ws
evaluatedCompletions <- evalCompletions arg completions
let toStringCompletion c = c {completionSuggestion = completionResultValue (completionSuggestion c)}
map toStringCompletion evaluatedCompletions `shouldBe` expected
parserCompletionDescriptionTest :: Parser a -> Int -> [String] -> [String] -> IO ()
parserCompletionDescriptionTest p ix ws descriptions = do
let completions = pureCompletionQuery p ix ws
map completionDescription completions `shouldBe` map Just descriptions
goldenSettingsReferenceDocumentationSpec :: forall a. (HasCallStack) => (HasParser a) => FilePath -> String -> Spec
goldenSettingsReferenceDocumentationSpec path progname = withFrozenCallStack $ goldenParserReferenceDocumentationSpec (settingsParser @a) path progname
goldenParserReferenceDocumentationSpec :: (HasCallStack) => Parser a -> FilePath -> String -> Spec
goldenParserReferenceDocumentationSpec parser path progname = withFrozenCallStack $ do
specify "produces the same reference documentation as before" $
pureGoldenReferenceDocumentation path progname parser
pureGoldenReferenceDocumentation :: FilePath -> String -> Parser a -> GoldenTest Text
pureGoldenReferenceDocumentation path progname parser =
pureGoldenTextFile path $
renderChunksText With24BitColours $
renderReferenceDocumentation progname $
parserDocs parser
goldenSettingsNixOptionsSpec :: forall a. (HasCallStack) => (HasParser a) => FilePath -> Spec
goldenSettingsNixOptionsSpec path = withFrozenCallStack $ goldenParserNixOptionsSpec (settingsParser @a) path
goldenParserNixOptionsSpec :: (HasCallStack) => Parser a -> FilePath -> Spec
goldenParserNixOptionsSpec parser path = withFrozenCallStack $ do
specify "produces the nix options as before" $
pureGoldenNixOptions path parser
pureGoldenNixOptions :: (HasCallStack) => FilePath -> Parser a -> GoldenTest Text
pureGoldenNixOptions path parser =
pureGoldenTextFile path $
generatedFileComment Stack.callStack <> renderParserNixOptions parser
generatedFileComment :: CallStack -> T.Text
generatedFileComment cs =
let loc = case getCallStack cs of
(_, srcLoc) : _ ->
packageName (Stack.srcLocPackage srcLoc)
<> ":"
<> Stack.srcLocFile srcLoc
<> ":"
<> show (Stack.srcLocStartLine srcLoc)
[] -> "unknown"
in T.pack $
unlines $
map
("# " <>)
[ "DO NOT EDIT THIS FILE DIRECTLY",
"This file was generated by",
loc,
"To update this it, run the test with --golden-reset"
]
-- | Extract just the package name from a GHC package identifier.
--
-- GHC package identifiers look like: @name-version-hash-unitid@
-- This function returns just @name@.
packageName :: String -> String
packageName = go
where
go [] = []
go ('-' : rest)
| isVersion version = []
where
version = takeWhile (\c -> isDigit c || c == '.') rest
go (c : rest) = c : go rest
isVersion v = not (null v) && elem '.' v && all (\c -> isDigit c || c == '.') v