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 @@
-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