From 8c49a30faa431b8b56a4b4926e7dae56b1311fea Mon Sep 17 00:00:00 2001
From: Volpeon <github@volpeon.ink>
Date: Sun, 28 May 2023 08:13:08 +0200
Subject: Completed untested Flattening implementation
---
test/Spec.hs | 23 ++++++----
test/Test/Common.hs | 96 +++++++++++++++++++++++++++++++++++++++
test/Test/Expansion.hs | 117 +++++++-----------------------------------------
test/Test/Flattening.hs | 51 +++++++++++++++++++++
4 files changed, 177 insertions(+), 110 deletions(-)
create mode 100644 test/Test/Common.hs
create mode 100644 test/Test/Flattening.hs
(limited to 'test')
diff --git a/test/Spec.hs b/test/Spec.hs
index c58bbfa..c85ac53 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,24 +1,31 @@
import Data.JLD.Prelude
-import Data.JLD.Mime (mimeType)
-import Test.Expansion (W3CExpansionTestList, expansionTests)
-
import Test.Tasty
+import Data.JLD.Mime (mimeType)
+import Test.Common (W3CTestList)
+import Test.Expansion (expansionTests)
+import Test.Flattening (flatteningTests)
+
import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, https, jsonResponse, req, responseBody, runReq, (/:))
-tests :: W3CExpansionTestList -> TestTree
-tests jldExpansionTestList =
+tests :: W3CTestList -> W3CTestList -> TestTree
+tests expansionTestList flatteningTestList =
testGroup
"Tests"
- [ expansionTests jldExpansionTestList
+ [ expansionTests expansionTestList
+ , flatteningTests flatteningTestList
]
main :: IO ()
main = do
- jldExpansionTestList <- runReq defaultHttpConfig do
+ expansionTestList <- runReq defaultHttpConfig do
responseBody <$> req GET w3cExpansionTestListUrl NoReqBody jsonResponse (header "Accept" mimeType)
- defaultMain <| tests jldExpansionTestList
+ flatteningTestList <- runReq defaultHttpConfig do
+ responseBody <$> req GET w3cFlatteningTestListUrl NoReqBody jsonResponse (header "Accept" mimeType)
+
+ defaultMain <| tests expansionTestList flatteningTestList
where
w3cExpansionTestListUrl = https "w3c.github.io" /: "json-ld-api" /: "tests" /: "expand-manifest.jsonld"
+ w3cFlatteningTestListUrl = https "w3c.github.io" /: "json-ld-api" /: "tests" /: "flatten-manifest.jsonld"
diff --git a/test/Test/Common.hs b/test/Test/Common.hs
new file mode 100644
index 0000000..ffc3264
--- /dev/null
+++ b/test/Test/Common.hs
@@ -0,0 +1,96 @@
+module Test.Common (W3CTestList (..), W3CTest (..), W3CTestOption (..), fetchTest, parseExpansionOptions) 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.Maybe (fromJust)
+import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, jsonResponse, req, responseBody, runReq, useHttpsURI, useURI)
+import Text.URI (URI, mkURI, relativeTo)
+
+data W3CTestOption = W3CTestOption
+ { w3cTestOptionSpecVersion :: Maybe Text
+ , w3cTestOptionProcessingMode :: Maybe Text
+ , w3cTestOptionBase :: Maybe Text
+ , w3cTestOptionExpandContext :: Maybe Text
+ }
+ deriving (Show)
+
+instance FromJSON W3CTestOption where
+ parseJSON (Object v) =
+ W3CTestOption
+ <$> (v .:? "specVersion")
+ <*> (v .:? "processingMode")
+ <*> (v .:? "base")
+ <*> (v .:? "expandContext")
+ parseJSON invalid = prependFailure "parsing W3CTestOption failed, " (typeMismatch "Object" invalid)
+
+data W3CTest = W3CTest
+ { w3cTestName :: Text
+ , w3cTestInput :: Text
+ , w3cTestExpect :: Maybe Text
+ , w3cTestExpectErrorCode :: Maybe Text
+ , w3cTestOption :: Maybe W3CTestOption
+ }
+ deriving (Show)
+
+instance FromJSON W3CTest where
+ parseJSON (Object v) =
+ W3CTest
+ <$> (v .: "name")
+ <*> (v .: "input")
+ <*> (v .:? "expect")
+ <*> (v .:? "expectErrorCode")
+ <*> (v .:? "option")
+ parseJSON invalid = prependFailure "parsing W3CTest failed, " (typeMismatch "Object" invalid)
+
+newtype W3CTestList = W3CTestList
+ { w3cSequence :: [W3CTest]
+ }
+ deriving (Show)
+
+instance FromJSON W3CTestList where
+ parseJSON (Object v) = W3CTestList <$> (v .: "sequence")
+ parseJSON invalid = prependFailure "parsing W3CTestList failed, " (typeMismatch "Object" invalid)
+
+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"
+
+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
+
+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 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
diff --git a/test/Test/Flattening.hs b/test/Test/Flattening.hs
new file mode 100644
index 0000000..bc64b88
--- /dev/null
+++ b/test/Test/Flattening.hs
@@ -0,0 +1,51 @@
+module Test.Flattening (flatteningTests) where
+
+import Data.JLD.Prelude
+
+import Test.Tasty
+import Test.Tasty.ExpectedFailure (ignoreTestBecause)
+import Test.Tasty.HUnit
+
+import Data.JLD (expand, flatten, toJldErrorCode)
+import Data.Maybe (fromJust)
+import Test.Common (W3CTest (..), W3CTestList (..), W3CTestOption (..), fetchTest, parseExpansionOptions)
+import Text.URI (mkURI, relativeTo)
+
+flatteningTests :: W3CTestList -> TestTree
+flatteningTests testList = testGroup "Flattening" <| uncurry flatteningTest <$> zip (w3cSequence testList) [1 ..]
+
+flatteningTest :: W3CTest -> Int -> TestTree
+flatteningTest 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, _) <- flatten 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, _) <- flatten inputJld expandBaseUrl params
+
+ (result |> first toJldErrorCode) @?= Left expectErrorRaw
+ --
+ | otherwise =
+ testCase testName do
+ assertFailure <| "Unhandled test type"
--
cgit v1.2.3-70-g09d2