From 8c49a30faa431b8b56a4b4926e7dae56b1311fea Mon Sep 17 00:00:00 2001 From: Volpeon Date: Sun, 28 May 2023 08:13:08 +0200 Subject: Completed untested Flattening implementation --- test/Test/Expansion.hs | 117 +++++++------------------------------------------ 1 file changed, 15 insertions(+), 102 deletions(-) (limited to 'test/Test/Expansion.hs') diff --git a/test/Test/Expansion.hs b/test/Test/Expansion.hs index 89024c6..b5b1e07 100644 --- a/test/Test/Expansion.hs +++ b/test/Test/Expansion.hs @@ -1,134 +1,47 @@ -module Test.Expansion (W3CExpansionTestList, expansionTests) where +module Test.Expansion (expansionTests) where import Data.JLD.Prelude -import Data.JLD (DocumentLoader (..), JLDExpansionParams (..), JLDVersion (..), expand, mimeType, toJldErrorCode) -import Data.JLD.Model.URI (parseUri) - import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Data.Aeson (FromJSON, Value (..), (.:), (.:?)) -import Data.Aeson.Types (FromJSON (..), prependFailure, typeMismatch) +import Data.JLD (expand, toJldErrorCode) import Data.Maybe (fromJust) -import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, jsonResponse, req, responseBody, runReq, useHttpsURI, useURI) -import Text.URI (URI, mkURI, relativeTo) - -data W3CExpansionTestOption = W3CExpansionTestOption - { w3cExpansionTestOptionSpecVersion :: Maybe Text - , w3cExpansionTestOptionProcessingMode :: Maybe Text - , w3cExpansionTestOptionBase :: Maybe Text - , w3cExpansionTestOptionExpandContext :: Maybe Text - } - deriving (Show) - -instance FromJSON W3CExpansionTestOption where - parseJSON (Object v) = - W3CExpansionTestOption - <$> (v .:? "specVersion") - <*> (v .:? "processingMode") - <*> (v .:? "base") - <*> (v .:? "expandContext") - parseJSON invalid = prependFailure "parsing W3CExpansionTestOption failed, " (typeMismatch "Object" invalid) - -data W3CExpansionTest = W3CExpansionTest - { w3cExpansionTestName :: Text - , w3cExpansionTestInput :: Text - , w3cExpansionTestExpect :: Maybe Text - , w3cExpansionTestExpectErrorCode :: Maybe Text - , w3cExpansionTestOption :: Maybe W3CExpansionTestOption - } - deriving (Show) - -instance FromJSON W3CExpansionTest where - parseJSON (Object v) = - W3CExpansionTest - <$> (v .: "name") - <*> (v .: "input") - <*> (v .:? "expect") - <*> (v .:? "expectErrorCode") - <*> (v .:? "option") - parseJSON invalid = prependFailure "parsing W3CExpansionTest failed, " (typeMismatch "Object" invalid) - -newtype W3CExpansionTestList = W3CExpansionTestList - { w3cExpansionSequence :: [W3CExpansionTest] - } - deriving (Show) - -instance FromJSON W3CExpansionTestList where - parseJSON (Object v) = W3CExpansionTestList <$> (v .: "sequence") - parseJSON invalid = prependFailure "parsing W3CExpansionTestList failed, " (typeMismatch "Object" invalid) +import Test.Common (W3CTest (..), W3CTestList (..), W3CTestOption (..), fetchTest, parseExpansionOptions) +import Text.URI (mkURI, relativeTo) -documentLoader :: MonadIO m => DocumentLoader Text m -documentLoader = DocumentLoader \uri -> - runReq defaultHttpConfig <| case useURI uri of - Just (Left (httpUri, options)) -> Right <. responseBody <$> req GET httpUri NoReqBody jsonResponse (options <> header "Accept" mimeType) - Just (Right (httpsUri, options)) -> Right <. responseBody <$> req GET httpsUri NoReqBody jsonResponse (options <> header "Accept" mimeType) - Nothing -> pure <| Left "Invalid URI" +expansionTests :: W3CTestList -> TestTree +expansionTests testList = testGroup "Expansion" <| uncurry expansionTest <$> zip (w3cSequence testList) [1 ..] -fetchTest :: URI -> IO Value -fetchTest url = do - let (reqUrl, reqOptions) = fromJust <| useHttpsURI url - runReq defaultHttpConfig do - res <- req GET reqUrl NoReqBody jsonResponse (reqOptions <> header "Accept" mimeType) - pure <| responseBody res - -parseOptions :: URI -> URI -> Maybe W3CExpansionTestOption -> IO (URI, JLDExpansionParams () IO -> JLDExpansionParams Text IO) -parseOptions baseUrl inputUrl maybeOptions = do - expandContext <- case maybeOptions >>= w3cExpansionTestOptionExpandContext of - Just rawUrl -> do - url <- fromJust <. (`relativeTo` baseUrl) <$> mkURI rawUrl - Just <$> fetchTest url - Nothing -> pure Nothing - - let params p = - p - { jldExpansionParamsDocumentLoader = documentLoader - , jldExpansionParamsProcessingMode = case maybeOptions >>= w3cExpansionTestOptionProcessingMode of - Just "json-ld-1.0" -> JLD1_0 - Just "json-ld-1.1" -> JLD1_1 - _ -> jldExpansionParamsProcessingMode p - , jldExpansionParamsExpandContext = expandContext <|> jldExpansionParamsExpandContext p - } - - pure (expandBaseUrl, params) - where - expandBaseUrl = fromMaybe inputUrl (parseUri =<< w3cExpansionTestOptionBase =<< maybeOptions) - -expansionTests :: W3CExpansionTestList -> TestTree -expansionTests testList = testGroup "Expansion" <| uncurry expansionTest <$> (take 999 <. drop 0 <| zip (w3cExpansionSequence testList) [1 ..]) - -expansionTest :: W3CExpansionTest -> Int -> TestTree -expansionTest W3CExpansionTest{..} (show .> (<> ". " <> toString w3cExpansionTestName) -> testName) - | Just "json-ld-1.0" <- w3cExpansionTestOptionSpecVersion =<< w3cExpansionTestOption = +expansionTest :: W3CTest -> Int -> TestTree +expansionTest W3CTest{..} (show .> (<> ". " <> toString w3cTestName) -> testName) + | Just "json-ld-1.0" <- w3cTestOptionSpecVersion =<< w3cTestOption = ignoreTestBecause "specVersion json-ld-1.0 is not supported" <| testCase testName do pure () -- - | Just expectUrlRaw <- w3cExpansionTestExpect = + | Just expectUrlRaw <- w3cTestExpect = testCase testName do baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" - inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cExpansionTestInput + inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput expectUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI expectUrlRaw inputJld <- fetchTest inputUrl expectJld <- fetchTest expectUrl - (expandBaseUrl, params) <- parseOptions baseUrl inputUrl w3cExpansionTestOption + (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption (result, _) <- expand inputJld expandBaseUrl params - -- pTraceShowM (expectJLD, result) - result @?= Right expectJld -- - | Just expectErrorRaw <- w3cExpansionTestExpectErrorCode = + | Just expectErrorRaw <- w3cTestExpectErrorCode = testCase testName do baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" - inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cExpansionTestInput + inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput inputJld <- fetchTest inputUrl - (expandBaseUrl, params) <- parseOptions baseUrl inputUrl w3cExpansionTestOption + (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption (result, _) <- expand inputJld expandBaseUrl params (result |> first toJldErrorCode) @?= Left expectErrorRaw -- cgit v1.2.3-54-g00ecf