Completed untested Flattening implementation

1 files changed, 51 insertions, 0 deletions

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"