diff options
author | Volpeon <github@volpeon.ink> | 2023-05-28 08:13:08 +0200 |
---|---|---|
committer | Volpeon <github@volpeon.ink> | 2023-05-28 08:13:08 +0200 |
commit | 8c49a30faa431b8b56a4b4926e7dae56b1311fea (patch) | |
tree | 6a103b49cdfe6df38fadad1f9d59521dd92ebf74 /test/Test/Expansion.hs | |
parent | Added Node Map Merging algorithm (diff) | |
download | hs-jsonld-8c49a30faa431b8b56a4b4926e7dae56b1311fea.tar.gz hs-jsonld-8c49a30faa431b8b56a4b4926e7dae56b1311fea.tar.bz2 hs-jsonld-8c49a30faa431b8b56a4b4926e7dae56b1311fea.zip |
Completed untested Flattening implementation
Diffstat (limited to 'test/Test/Expansion.hs')
-rw-r--r-- | test/Test/Expansion.hs | 117 |
1 files changed, 15 insertions, 102 deletions
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 @@ | |||
1 | module Test.Expansion (W3CExpansionTestList, expansionTests) where | 1 | module Test.Expansion (expansionTests) where |
2 | 2 | ||
3 | import Data.JLD.Prelude | 3 | import Data.JLD.Prelude |
4 | 4 | ||
5 | import Data.JLD (DocumentLoader (..), JLDExpansionParams (..), JLDVersion (..), expand, mimeType, toJldErrorCode) | ||
6 | import Data.JLD.Model.URI (parseUri) | ||
7 | |||
8 | import Test.Tasty | 5 | import Test.Tasty |
9 | import Test.Tasty.ExpectedFailure (ignoreTestBecause) | 6 | import Test.Tasty.ExpectedFailure (ignoreTestBecause) |
10 | import Test.Tasty.HUnit | 7 | import Test.Tasty.HUnit |
11 | 8 | ||
12 | import Data.Aeson (FromJSON, Value (..), (.:), (.:?)) | 9 | import Data.JLD (expand, toJldErrorCode) |
13 | import Data.Aeson.Types (FromJSON (..), prependFailure, typeMismatch) | ||
14 | import Data.Maybe (fromJust) | 10 | import Data.Maybe (fromJust) |
15 | import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, header, jsonResponse, req, responseBody, runReq, useHttpsURI, useURI) | 11 | import Test.Common (W3CTest (..), W3CTestList (..), W3CTestOption (..), fetchTest, parseExpansionOptions) |
16 | import Text.URI (URI, mkURI, relativeTo) | 12 | import Text.URI (mkURI, relativeTo) |
17 | |||
18 | data W3CExpansionTestOption = W3CExpansionTestOption | ||
19 | { w3cExpansionTestOptionSpecVersion :: Maybe Text | ||
20 | , w3cExpansionTestOptionProcessingMode :: Maybe Text | ||
21 | , w3cExpansionTestOptionBase :: Maybe Text | ||
22 | , w3cExpansionTestOptionExpandContext :: Maybe Text | ||
23 | } | ||
24 | deriving (Show) | ||
25 | |||
26 | instance FromJSON W3CExpansionTestOption where | ||
27 | parseJSON (Object v) = | ||
28 | W3CExpansionTestOption | ||
29 | <$> (v .:? "specVersion") | ||
30 | <*> (v .:? "processingMode") | ||
31 | <*> (v .:? "base") | ||
32 | <*> (v .:? "expandContext") | ||
33 | parseJSON invalid = prependFailure "parsing W3CExpansionTestOption failed, " (typeMismatch "Object" invalid) | ||
34 | |||
35 | data W3CExpansionTest = W3CExpansionTest | ||
36 | { w3cExpansionTestName :: Text | ||
37 | , w3cExpansionTestInput :: Text | ||
38 | , w3cExpansionTestExpect :: Maybe Text | ||
39 | , w3cExpansionTestExpectErrorCode :: Maybe Text | ||
40 | , w3cExpansionTestOption :: Maybe W3CExpansionTestOption | ||
41 | } | ||
42 | deriving (Show) | ||
43 | |||
44 | instance FromJSON W3CExpansionTest where | ||
45 | parseJSON (Object v) = | ||
46 | W3CExpansionTest | ||
47 | <$> (v .: "name") | ||
48 | <*> (v .: "input") | ||
49 | <*> (v .:? "expect") | ||
50 | <*> (v .:? "expectErrorCode") | ||
51 | <*> (v .:? "option") | ||
52 | parseJSON invalid = prependFailure "parsing W3CExpansionTest failed, " (typeMismatch "Object" invalid) | ||
53 | |||
54 | newtype W3CExpansionTestList = W3CExpansionTestList | ||
55 | { w3cExpansionSequence :: [W3CExpansionTest] | ||
56 | } | ||
57 | deriving (Show) | ||
58 | |||
59 | instance FromJSON W3CExpansionTestList where | ||
60 | parseJSON (Object v) = W3CExpansionTestList <$> (v .: "sequence") | ||
61 | parseJSON invalid = prependFailure "parsing W3CExpansionTestList failed, " (typeMismatch "Object" invalid) | ||
62 | 13 | ||
63 | documentLoader :: MonadIO m => DocumentLoader Text m | 14 | expansionTests :: W3CTestList -> TestTree |
64 | documentLoader = DocumentLoader \uri -> | 15 | expansionTests testList = testGroup "Expansion" <| uncurry expansionTest <$> zip (w3cSequence testList) [1 ..] |
65 | runReq defaultHttpConfig <| case useURI uri of | ||
66 | Just (Left (httpUri, options)) -> Right <. responseBody <$> req GET httpUri NoReqBody jsonResponse (options <> header "Accept" mimeType) | ||
67 | Just (Right (httpsUri, options)) -> Right <. responseBody <$> req GET httpsUri NoReqBody jsonResponse (options <> header "Accept" mimeType) | ||
68 | Nothing -> pure <| Left "Invalid URI" | ||
69 | 16 | ||
70 | fetchTest :: URI -> IO Value | 17 | expansionTest :: W3CTest -> Int -> TestTree |
71 | fetchTest url = do | 18 | expansionTest W3CTest{..} (show .> (<> ". " <> toString w3cTestName) -> testName) |
72 | let (reqUrl, reqOptions) = fromJust <| useHttpsURI url | 19 | | Just "json-ld-1.0" <- w3cTestOptionSpecVersion =<< w3cTestOption = |
73 | runReq defaultHttpConfig do | ||
74 | res <- req GET reqUrl NoReqBody jsonResponse (reqOptions <> header "Accept" mimeType) | ||
75 | pure <| responseBody res | ||
76 | |||
77 | parseOptions :: URI -> URI -> Maybe W3CExpansionTestOption -> IO (URI, JLDExpansionParams () IO -> JLDExpansionParams Text IO) | ||
78 | parseOptions baseUrl inputUrl maybeOptions = do | ||
79 | expandContext <- case maybeOptions >>= w3cExpansionTestOptionExpandContext of | ||
80 | Just rawUrl -> do | ||
81 | url <- fromJust <. (`relativeTo` baseUrl) <$> mkURI rawUrl | ||
82 | Just <$> fetchTest url | ||
83 | Nothing -> pure Nothing | ||
84 | |||
85 | let params p = | ||
86 | p | ||
87 | { jldExpansionParamsDocumentLoader = documentLoader | ||
88 | , jldExpansionParamsProcessingMode = case maybeOptions >>= w3cExpansionTestOptionProcessingMode of | ||
89 | Just "json-ld-1.0" -> JLD1_0 | ||
90 | Just "json-ld-1.1" -> JLD1_1 | ||
91 | _ -> jldExpansionParamsProcessingMode p | ||
92 | , jldExpansionParamsExpandContext = expandContext <|> jldExpansionParamsExpandContext p | ||
93 | } | ||
94 | |||
95 | pure (expandBaseUrl, params) | ||
96 | where | ||
97 | expandBaseUrl = fromMaybe inputUrl (parseUri =<< w3cExpansionTestOptionBase =<< maybeOptions) | ||
98 | |||
99 | expansionTests :: W3CExpansionTestList -> TestTree | ||
100 | expansionTests testList = testGroup "Expansion" <| uncurry expansionTest <$> (take 999 <. drop 0 <| zip (w3cExpansionSequence testList) [1 ..]) | ||
101 | |||
102 | expansionTest :: W3CExpansionTest -> Int -> TestTree | ||
103 | expansionTest W3CExpansionTest{..} (show .> (<> ". " <> toString w3cExpansionTestName) -> testName) | ||
104 | | Just "json-ld-1.0" <- w3cExpansionTestOptionSpecVersion =<< w3cExpansionTestOption = | ||
105 | ignoreTestBecause "specVersion json-ld-1.0 is not supported" | 20 | ignoreTestBecause "specVersion json-ld-1.0 is not supported" |
106 | <| testCase testName do pure () | 21 | <| testCase testName do pure () |
107 | -- | 22 | -- |
108 | | Just expectUrlRaw <- w3cExpansionTestExpect = | 23 | | Just expectUrlRaw <- w3cTestExpect = |
109 | testCase testName do | 24 | testCase testName do |
110 | baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" | 25 | baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" |
111 | inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cExpansionTestInput | 26 | inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput |
112 | expectUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI expectUrlRaw | 27 | expectUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI expectUrlRaw |
113 | 28 | ||
114 | inputJld <- fetchTest inputUrl | 29 | inputJld <- fetchTest inputUrl |
115 | expectJld <- fetchTest expectUrl | 30 | expectJld <- fetchTest expectUrl |
116 | 31 | ||
117 | (expandBaseUrl, params) <- parseOptions baseUrl inputUrl w3cExpansionTestOption | 32 | (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption |
118 | (result, _) <- expand inputJld expandBaseUrl params | 33 | (result, _) <- expand inputJld expandBaseUrl params |
119 | 34 | ||
120 | -- pTraceShowM (expectJLD, result) | ||
121 | |||
122 | result @?= Right expectJld | 35 | result @?= Right expectJld |
123 | -- | 36 | -- |
124 | | Just expectErrorRaw <- w3cExpansionTestExpectErrorCode = | 37 | | Just expectErrorRaw <- w3cTestExpectErrorCode = |
125 | testCase testName do | 38 | testCase testName do |
126 | baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" | 39 | baseUrl <- mkURI "https://w3c.github.io/json-ld-api/tests/" |
127 | inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cExpansionTestInput | 40 | inputUrl <- fromJust <. (`relativeTo` baseUrl) <$> mkURI w3cTestInput |
128 | 41 | ||
129 | inputJld <- fetchTest inputUrl | 42 | inputJld <- fetchTest inputUrl |
130 | 43 | ||
131 | (expandBaseUrl, params) <- parseOptions baseUrl inputUrl w3cExpansionTestOption | 44 | (expandBaseUrl, params) <- parseExpansionOptions baseUrl inputUrl w3cTestOption |
132 | (result, _) <- expand inputJld expandBaseUrl params | 45 | (result, _) <- expand inputJld expandBaseUrl params |
133 | 46 | ||
134 | (result |> first toJldErrorCode) @?= Left expectErrorRaw | 47 | (result |> first toJldErrorCode) @?= Left expectErrorRaw |