From b2c846b0daf9d6e26e1e2a07fecc848b4732baa0 Mon Sep 17 00:00:00 2001 From: Volpeon Date: Sun, 28 May 2023 10:18:49 +0200 Subject: Fixed flattening errors --- test/Test/Common.hs | 35 +++++------------------------------ test/Test/Expansion.hs | 29 ++++++++++++++++++++++++++--- test/Test/Flattening.hs | 36 +++++++++++++++++++++++++++++++----- 3 files changed, 62 insertions(+), 38 deletions(-) (limited to 'test') diff --git a/test/Test/Common.hs b/test/Test/Common.hs index ffc3264..e386551 100644 --- a/test/Test/Common.hs +++ b/test/Test/Common.hs @@ -1,24 +1,20 @@ -module Test.Common (W3CTestList (..), W3CTest (..), W3CTestOption (..), fetchTest, parseExpansionOptions) where +module Test.Common (W3CTestList (..), W3CTest (..), W3CTestOption (..), documentLoader, fetchTest) where import Data.JLD.Prelude -import Test.Tasty -import Test.Tasty.ExpectedFailure (ignoreTestBecause) -import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) - import Data.Aeson (FromJSON (..), Value (..), (.:), (.:?)) import Data.Aeson.Types (prependFailure, typeMismatch) -import Data.JLD (DocumentLoader (..), JLDExpansionParams (..), JLDVersion (..), mimeType, toJldErrorCode) -import Data.JLD.Model.URI (parseUri) +import Data.JLD (DocumentLoader (..), mimeType) import Data.Maybe (fromJust) import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, jsonResponse, req, responseBody, runReq, useHttpsURI, useURI) -import Text.URI (URI, mkURI, relativeTo) +import Text.URI (URI) data W3CTestOption = W3CTestOption { w3cTestOptionSpecVersion :: Maybe Text , w3cTestOptionProcessingMode :: Maybe Text , w3cTestOptionBase :: Maybe Text , w3cTestOptionExpandContext :: Maybe Text + , w3cTestOptionCompactArrays :: Maybe Bool } deriving (Show) @@ -29,6 +25,7 @@ instance FromJSON W3CTestOption where <*> (v .:? "processingMode") <*> (v .:? "base") <*> (v .:? "expandContext") + <*> (v .:? "compactArrays") parseJSON invalid = prependFailure "parsing W3CTestOption failed, " (typeMismatch "Object" invalid) data W3CTest = W3CTest @@ -72,25 +69,3 @@ fetchTest url = do runReq defaultHttpConfig do res <- req GET reqUrl NoReqBody jsonResponse (reqOptions <> header "Accept" mimeType) pure <| responseBody res - -parseExpansionOptions :: URI -> URI -> Maybe W3CTestOption -> IO (URI, JLDExpansionParams () IO -> JLDExpansionParams Text IO) -parseExpansionOptions baseUrl inputUrl maybeOptions = do - expandContext <- case maybeOptions >>= w3cTestOptionExpandContext 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 >>= w3cTestOptionProcessingMode 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 =<< w3cTestOptionBase =<< maybeOptions) diff --git a/test/Test/Expansion.hs b/test/Test/Expansion.hs index b5b1e07..0d553a7 100644 --- a/test/Test/Expansion.hs +++ b/test/Test/Expansion.hs @@ -6,10 +6,33 @@ import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Data.JLD (expand, toJldErrorCode) +import Data.JLD (JLDExpansionParams (..), JLDVersion (..), expand, toJldErrorCode) +import Data.JLD.Model.URI (parseUri) import Data.Maybe (fromJust) -import Test.Common (W3CTest (..), W3CTestList (..), W3CTestOption (..), fetchTest, parseExpansionOptions) -import Text.URI (mkURI, relativeTo) +import Test.Common (W3CTest (..), W3CTestList (..), W3CTestOption (..), documentLoader, fetchTest) +import Text.URI (URI, mkURI, relativeTo) + +parseExpansionOptions :: URI -> URI -> Maybe W3CTestOption -> IO (URI, JLDExpansionParams () IO -> JLDExpansionParams Text IO) +parseExpansionOptions baseUrl inputUrl maybeOptions = do + expandContext <- case maybeOptions >>= w3cTestOptionExpandContext 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 >>= w3cTestOptionProcessingMode 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 =<< w3cTestOptionBase =<< maybeOptions) expansionTests :: W3CTestList -> TestTree expansionTests testList = testGroup "Expansion" <| uncurry expansionTest <$> zip (w3cSequence testList) [1 ..] diff --git a/test/Test/Flattening.hs b/test/Test/Flattening.hs index bc64b88..76f5434 100644 --- a/test/Test/Flattening.hs +++ b/test/Test/Flattening.hs @@ -6,10 +6,36 @@ import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit -import Data.JLD (expand, flatten, toJldErrorCode) +import Data.JLD (JLDFlatteningParams (..), JLDVersion (..), flatten, toJldErrorCode) +import Data.JLD.Model.URI (parseUri) import Data.Maybe (fromJust) -import Test.Common (W3CTest (..), W3CTestList (..), W3CTestOption (..), fetchTest, parseExpansionOptions) -import Text.URI (mkURI, relativeTo) +import Test.Common (W3CTest (..), W3CTestList (..), W3CTestOption (..), documentLoader, fetchTest) +import Text.URI (URI, mkURI, relativeTo) + +parseFlatteningOptions :: URI -> URI -> Maybe W3CTestOption -> IO (URI, JLDFlatteningParams () IO -> JLDFlatteningParams Text IO) +parseFlatteningOptions baseUrl inputUrl maybeOptions = do + expandContext <- case maybeOptions >>= w3cTestOptionExpandContext of + Just rawUrl -> do + url <- fromJust <. (`relativeTo` baseUrl) <$> mkURI rawUrl + Just <$> fetchTest url + Nothing -> pure Nothing + + let params p = + p + { jldFlatteningParamsDocumentLoader = documentLoader + , jldFlatteningParamsProcessingMode = case maybeOptions >>= w3cTestOptionProcessingMode of + Just "json-ld-1.0" -> JLD1_0 + Just "json-ld-1.1" -> JLD1_1 + _ -> jldFlatteningParamsProcessingMode p + , jldFlatteningParamsExpandContext = expandContext <|> jldFlatteningParamsExpandContext p + , jldFlatteningParamsCompactArrays = case maybeOptions >>= w3cTestOptionCompactArrays of + Just b -> b + _ -> jldFlatteningParamsCompactArrays p + } + + pure (expandBaseUrl, params) + where + expandBaseUrl = fromMaybe inputUrl (parseUri =<< w3cTestOptionBase =<< maybeOptions) flatteningTests :: W3CTestList -> TestTree flatteningTests testList = testGroup "Flattening" <| uncurry flatteningTest <$> zip (w3cSequence testList) [1 ..] @@ -29,7 +55,7 @@ flatteningTest W3CTest{..} (show .> (<> ". " <> toString w3cTestName) -> testNam inputJld <- fetchTest inputUrl expectJld <- fetchTest expectUrl - (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption + (expandBaseUrl, params) <- parseFlatteningOptions baseUrl inputUrl w3cTestOption (result, _) <- flatten inputJld expandBaseUrl params result @?= Right expectJld @@ -41,7 +67,7 @@ flatteningTest W3CTest{..} (show .> (<> ". " <> toString w3cTestName) -> testNam inputJld <- fetchTest inputUrl - (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption + (expandBaseUrl, params) <- parseFlatteningOptions baseUrl inputUrl w3cTestOption (result, _) <- flatten inputJld expandBaseUrl params (result |> first toJldErrorCode) @?= Left expectErrorRaw -- cgit v1.2.3-70-g09d2