Fixed flattening errors

3 files changed, 62 insertions, 38 deletions

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