module Test.Expansion (expansionTests) where import Data.JLD.Prelude import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit import Data.JLD (JLDExpansionParams (..), JLDVersion (..), expand, toJldErrorCode) import Data.JLD.Model.URI (parseUri) import Data.Maybe (fromJust) 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 ..] 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 <- w3cTestExpect = testCase testName do baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput expectUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI expectUrlRaw inputJld <- fetchTest inputUrl expectJld <- fetchTest expectUrl (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption (result, _) <- expand inputJld expandBaseUrl params result @?= Right expectJld -- | Just expectErrorRaw <- w3cTestExpectErrorCode = testCase testName do baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput inputJld <- fetchTest inputUrl (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption (result, _) <- expand inputJld expandBaseUrl params (result |> first toJldErrorCode) @?= Left expectErrorRaw -- | otherwise = testCase testName do assertFailure <| "Unhandled test type"