1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
module Test.Flattening (flatteningTests) where
import Data.JLD.Prelude
import Test.Tasty
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
import Test.Tasty.HUnit
import Data.JLD (JLDFlatteningParams (..), JLDVersion (..), flatten, toJldErrorCode)
import Data.JLD.Model.URI (parseUri)
import Data.Maybe (fromJust)
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 ..]
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) <- parseFlatteningOptions 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) <- parseFlatteningOptions baseUrl inputUrl w3cTestOption
(result, _) <- flatten inputJld expandBaseUrl params
(result |> first toJldErrorCode) @?= Left expectErrorRaw
--
| otherwise =
testCase testName do
assertFailure <| "Unhandled test type"
|
