From 8c49a30faa431b8b56a4b4926e7dae56b1311fea Mon Sep 17 00:00:00 2001 From: Volpeon Date: Sun, 28 May 2023 08:13:08 +0200 Subject: Completed untested Flattening implementation --- jsonld.cabal | 4 ++ src/Data/JLD.hs | 9 +++ src/Data/JLD/Flattening.hs | 44 ++++++++++++++ src/Data/JLD/Flattening/Global.hs | 7 +++ src/Data/JLD/Flattening/NodeMap.hs | 18 ++++-- src/Data/JLD/Model/NodeMap.hs | 16 ++++- test/Spec.hs | 23 +++++--- test/Test/Common.hs | 96 ++++++++++++++++++++++++++++++ test/Test/Expansion.hs | 117 +++++-------------------------------- test/Test/Flattening.hs | 51 ++++++++++++++++ 10 files changed, 268 insertions(+), 117 deletions(-) create mode 100644 src/Data/JLD/Flattening.hs create mode 100644 src/Data/JLD/Flattening/Global.hs create mode 100644 test/Test/Common.hs create mode 100644 test/Test/Flattening.hs diff --git a/jsonld.cabal b/jsonld.cabal index 9c9650c..0efa3b2 100644 --- a/jsonld.cabal +++ b/jsonld.cabal @@ -29,6 +29,8 @@ library Data.JLD.Expansion Data.JLD.Expansion.Context Data.JLD.Expansion.Global + Data.JLD.Flattening + Data.JLD.Flattening.Global Data.JLD.Flattening.NodeMap Data.JLD.Mime Data.JLD.Model.ActiveContext @@ -89,7 +91,9 @@ test-suite jsonld-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Test.Common Test.Expansion + Test.Flattening Paths_jsonld hs-source-dirs: test diff --git a/src/Data/JLD.hs b/src/Data/JLD.hs index c5c28eb..d7688d0 100644 --- a/src/Data/JLD.hs +++ b/src/Data/JLD.hs @@ -5,6 +5,7 @@ module Data.JLD ( JLDExpansionParams (..), JLDExpansionState (..), expand, + flatten, ) where import Data.JLD.Prelude @@ -15,6 +16,7 @@ import Data.JLD.Expansion (JLDEParams (..)) import Data.JLD.Expansion qualified as E (expand) import Data.JLD.Expansion.Context (buildActiveContext) import Data.JLD.Expansion.Global (JLDExpansionEnv (..), JLDExpansionState (..)) +import Data.JLD.Flattening qualified as F (flatten) import Data.JLD.Mime import Data.JLD.Model.ActiveContext (ActiveContext (..), newActiveContext) import Data.JLD.Model.Keyword (Keyword (..)) @@ -97,3 +99,10 @@ expand document baseUrl paramsFn = do Left err -> Left err pure (result', state') + +flatten :: Monad m => Value -> URI -> (JLDExpansionParams () m -> JLDExpansionParams e m) -> m (Either (JLDError e) Value, JLDExpansionState) +flatten document baseUrl paramsFn = do + (result, state') <- expand document baseUrl paramsFn + case result of + Left err -> pure (Left err, state') + Right expanded -> fmap (,state') <. runExceptT <| F.flatten expanded diff --git a/src/Data/JLD/Flattening.hs b/src/Data/JLD/Flattening.hs new file mode 100644 index 0000000..2bfd8dd --- /dev/null +++ b/src/Data/JLD/Flattening.hs @@ -0,0 +1,44 @@ +module Data.JLD.Flattening (flatten) where + +import Data.JLD.Prelude + +import Data.JLD.Flattening.NodeMap (buildNodeMap) + +import Data.Aeson (Array, Value (..)) +import Data.Foldable.WithIndex (FoldableWithIndex (..)) +import Data.JLD.Flattening.Global (JLDFlatteningT) +import Data.JLD.Model.Keyword (Keyword (..)) +import Data.JLD.Model.NodeMap (PropertyMap, SubjectMap, propsToKeyMap) +import Data.Map qualified as M (insert, lookup, member, singleton, size) +import Data.Vector qualified as V + +collectGraphsStep :: Text -> SubjectMap -> SubjectMap -> SubjectMap +collectGraphsStep graphName dg graph + | graphName == show KeywordDefault = dg + | otherwise = M.insert (Just graphName) entry' dg + where + -- 4.1. 4.2. + entry = case M.lookup (Just graphName) dg of + Just e -> e + Nothing -> M.singleton (Just <| show KeywordId) (String graphName) + + graphArray = Array <| foldl' collectNodesStep mempty graph + + entry' = M.insert (Just <| show KeywordGraph) graphArray entry + +collectNodesStep :: Array -> PropertyMap -> Array +collectNodesStep ar node + | M.size node == 1 && M.member (Just <| show KeywordId) node = ar + | otherwise = V.snoc ar (Object <| propsToKeyMap node) + +flatten :: Monad m => Value -> JLDFlatteningT e m Value +flatten element = do + -- 1. 2. + nodeMap <- fst <$> buildNodeMap element id + + -- 3. 4. + let defaultGraph = fromMaybe mempty <| M.lookup (show KeywordDefault) nodeMap + defaultGraph' = ifoldl' collectGraphsStep defaultGraph nodeMap + + -- 5. 6. 7. + pure <. Array <| foldl' collectNodesStep mempty defaultGraph' diff --git a/src/Data/JLD/Flattening/Global.hs b/src/Data/JLD/Flattening/Global.hs new file mode 100644 index 0000000..591d3ad --- /dev/null +++ b/src/Data/JLD/Flattening/Global.hs @@ -0,0 +1,7 @@ +module Data.JLD.Flattening.Global (JLDFlatteningT) where + +import Data.JLD.Prelude + +import Data.JLD.Error (JLDError) + +type JLDFlatteningT e m = ExceptT (JLDError e) m diff --git a/src/Data/JLD/Flattening/NodeMap.hs b/src/Data/JLD/Flattening/NodeMap.hs index 919aec7..65db9ab 100644 --- a/src/Data/JLD/Flattening/NodeMap.hs +++ b/src/Data/JLD/Flattening/NodeMap.hs @@ -2,8 +2,9 @@ module Data.JLD.Flattening.NodeMap (NodeMap, BNMParams (..), buildNodeMap, merge import Data.JLD.Prelude -import Data.JLD.Control.Monad.RES (REST, execREST, withErrorRES') +import Data.JLD.Control.Monad.RES (REST, runREST, withErrorRES') import Data.JLD.Error (JLDError (..)) +import Data.JLD.Flattening.Global (JLDFlatteningT) import Data.JLD.Model.IRI (isBlankIri) import Data.JLD.Model.Keyword (Keyword (..), isKeywordLike, isNotKeyword) import Data.JLD.Model.NodeMap (NodeMap, PropertyMap) @@ -12,7 +13,7 @@ import Data.JLD.Model.NodeObject (isNodeObject) import Data.JLD.Util (valueIsScalar, valueToArray, valueToNonNullArray) import Control.Monad.Except (MonadError (..)) -import Data.Aeson (Array, Key, Object, Value (..)) +import Data.Aeson (Array, Object, Value (..)) import Data.Aeson.Key qualified as K (toText) import Data.Aeson.KeyMap qualified as KM (filterWithKey, insert, lookup, member, singleton) import Data.Foldable.WithIndex (FoldableWithIndex (..), iforM_) @@ -85,7 +86,10 @@ bnmBuildNodeMap value paramsFn = do , bnmParamsActiveSubject = bnmEnvActiveSubject , bnmParamsActiveProperty = bnmEnvActiveProperty } - (nodeMap', list) <- buildNodeMap value params + (nodeMap', list) <- + buildNodeMap value params |> runExceptT >=> \case + Left err -> throwError <| Left err + Right a -> pure a bnmModifyNodeMap <| const nodeMap' pure list @@ -269,10 +273,12 @@ buildNodeMap' element = case element of -- _ -> pure () -buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> m (NodeMap, Maybe Array) +buildNodeMap :: Monad m => Value -> (BNMParams -> BNMParams) -> JLDFlatteningT e m (NodeMap, Maybe Array) buildNodeMap document paramsFn = do - BNMState{..} <- buildNodeMap' document |> execREST env st - pure (bnmStateNodeMap, bnmStateList) + (result, BNMState{..}) <- buildNodeMap' document |> runREST env st + case result of + Left (Left err) -> throwError err + _ -> pure (bnmStateNodeMap, bnmStateList) where BNMParams{..} = paramsFn diff --git a/src/Data/JLD/Model/NodeMap.hs b/src/Data/JLD/Model/NodeMap.hs index d0fb2f9..f76c662 100644 --- a/src/Data/JLD/Model/NodeMap.hs +++ b/src/Data/JLD/Model/NodeMap.hs @@ -10,13 +10,18 @@ module Data.JLD.Model.NodeMap ( hasKey2, hasKey3, memberArray, + propsToKeyMap, ) where import Data.JLD.Prelude hiding (modify) import Data.Aeson (Array, Value (..)) +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Foldable.WithIndex (FoldableWithIndex (..)) import Data.JLD.Util (valueToArray) -import Data.Map.Strict qualified as M (alter, insert, lookup, member) +import Data.Map.Strict qualified as M (alter, insert, lookup, member, toList) type PropertyKey = Maybe Text type PropertyMap = Map PropertyKey Value @@ -55,3 +60,12 @@ memberArray :: GraphKey -> SubjectKey -> PropertyKey -> Value -> NodeMap -> Bool memberArray graphName subject property value nodeMap = case lookup3 graphName subject property nodeMap of Just (Array a) -> value `elem` a _ -> False + +propsToKeyMap :: PropertyMap -> KeyMap Value +propsToKeyMap = + ifoldl' + ( \maybeKey km value -> case maybeKey of + Just key -> KM.insert (K.fromText key) value km + Nothing -> km + ) + mempty 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