diff --git a/rdf4h.cabal b/rdf4h.cabal --- a/rdf4h.cabal +++ b/rdf4h.cabal @@ -1,5 +1,5 @@ name: rdf4h -version: 3.0.2 +version: 3.0.3 synopsis: A library for RDF processing in Haskell description: 'RDF for Haskell' is a library for working with RDF in Haskell. @@ -24,10 +24,6 @@ extra-source-files: examples/ParseURLs.hs , examples/ESWC.hs -flag network-uri - description: Get Network.URI from the network-uri package - default: True - library exposed-modules: Data.RDF , Data.RDF.Namespace @@ -41,7 +37,7 @@ , Text.RDF.RDF4H.NTriplesSerializer , Text.RDF.RDF4H.XmlParser , Text.RDF.RDF4H.ParserUtils - build-depends: attoparsec >= 0.13.1.0 + build-depends: attoparsec , base >= 4.8.0.0 , bytestring , directory @@ -59,17 +55,13 @@ , hgal , parsers , mtl + , network-uri >= 2.6 + , network >= 2.6 if impl(ghc < 7.6) build-depends: ghc-prim - if flag(network-uri) - build-depends: network-uri >= 2.6, network >= 2.6 - else - build-depends: network-uri < 2.6, network < 2.6 - other-modules: Text.RDF.RDF4H.Interact hs-source-dirs: src - extensions: BangPatterns RankNTypes MultiParamTypeClasses Arrows FlexibleContexts OverloadedStrings DoAndIfThenElse ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields executable rdf4h @@ -78,16 +70,12 @@ , rdf4h , containers , text >= 1.2.1.0 + , network-uri >= 2.6 + , network >= 2.6 if impl(ghc < 7.6) build-depends: ghc-prim - if flag(network-uri) - build-depends: network-uri >= 2.6, network >= 2.6 - else - build-depends: network-uri < 2.6, network < 2.6 - - extensions: BangPatterns RankNTypes ScopedTypeVariables MultiParamTypeClasses OverloadedStrings ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields test-suite test-rdf4h @@ -101,7 +89,6 @@ W3C.RdfXmlTest W3C.W3CAssertions ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-name-shadowing -funbox-strict-fields - extensions: RankNTypes MultiParamTypeClasses Arrows FlexibleContexts OverloadedStrings build-depends: base >= 4.8.0.0 && < 6 , rdf4h , tasty @@ -114,14 +101,11 @@ , text >= 1.2.1.0 , directory , safe + , network-uri >= 2.6 + , network >= 2.6 if impl(ghc < 7.6) build-depends: ghc-prim - - if flag(network-uri) - build-depends: network-uri >= 2.6, network >= 2.6 - else - build-depends: network-uri < 2.6, network < 2.6 other-modules: W3C.TurtleTest hs-source-dirs: testsuite/tests diff --git a/src/Data/RDF/Query.hs b/src/Data/RDF/Query.hs --- a/src/Data/RDF/Query.hs +++ b/src/Data/RDF/Query.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Data.RDF.Query ( -- * Query functions diff --git a/src/Data/RDF/Types.hs b/src/Data/RDF/Types.hs --- a/src/Data/RDF/Types.hs +++ b/src/Data/RDF/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Data.RDF.Types ( @@ -548,7 +549,7 @@ -- equal. instance Eq LValue where (PlainL bs1) == (PlainL bs2) = bs1 == bs2 - (PlainLL bs1 bs1') == (PlainLL bs2 bs2') = bs1' == bs2' && bs1 == bs2 + (PlainLL bs1 bs1') == (PlainLL bs2 bs2') = T.toLower bs1' == T.toLower bs2' && bs1 == bs2 (TypedL bsType1 bs1) == (TypedL bsType2 bs2) = bsType1 == bsType2 && bs1 == bs2 _ == _ = False diff --git a/src/Text/RDF/RDF4H/NTriplesParser.hs b/src/Text/RDF/RDF4H/NTriplesParser.hs --- a/src/Text/RDF/RDF4H/NTriplesParser.hs +++ b/src/Text/RDF/RDF4H/NTriplesParser.hs @@ -252,44 +252,50 @@ -- parsec based parsers parseStringParsec :: (Rdf a) => T.Text -> Either ParseFailure (RDF a) -parseStringParsec bs = handleParse mkRdf (runParser nt_ntripleDoc () "" bs) +parseStringParsec bs = handleParsec mkRdf (runParser nt_ntripleDoc () "" bs) parseFileParsec :: (Rdf a) => String -> IO (Either ParseFailure (RDF a)) parseFileParsec path = - handleParse mkRdf . runParser nt_ntripleDoc () path + handleParsec mkRdf . runParser nt_ntripleDoc () path <$> TIO.readFile path parseURLParsec :: (Rdf a) => String -> IO (Either ParseFailure (RDF a)) parseURLParsec = _parseURL parseStringParsec +handleParsec :: {-forall rdf. (RDF rdf) => -} (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF a) -> + Either ParseError [Maybe Triple] -> + Either ParseFailure (RDF a) +handleParsec _mkRdf result +-- | T.length rem /= 0 = (Left $ ParseFailure $ "Invalid Document. Unparseable end of document: " ++ T.unpack rem) +-- | otherwise = + = case result of + Left err -> Left $ ParseFailure $ "Parse failure: \n" ++ show err + Right ts -> Right $ _mkRdf (catMaybes ts) Nothing (PrefixMappings Map.empty) + --------------------------------- --------------------------------- -- attoparsec based parsers +parseFileAttoparsec :: (Rdf a) => String -> IO (Either ParseFailure (RDF a)) +parseFileAttoparsec path = handleAttoparsec <$> TIO.readFile path + +parseURLAttoparsec :: (Rdf a) => String -> IO (Either ParseFailure (RDF a)) +parseURLAttoparsec = _parseURL handleAttoparsec + parseStringAttoparsec :: (Rdf a) => T.Text -> Either ParseFailure (RDF a) -parseStringAttoparsec bs = handleResult $ parse nt_ntripleDoc (T.encodeUtf8 bs) +parseStringAttoparsec = handleAttoparsec + +handleAttoparsec :: (Rdf a) => T.Text -> Either ParseFailure (RDF a) +handleAttoparsec bs = handleResult $ parse nt_ntripleDoc (T.encodeUtf8 bs) where handleResult res = case res of - Fail _ _ err -> error err + Fail _i _contexts err -> Left $ ParseFailure $ "Parse failure: \n" ++ show err + -- error $ + -- "\nnot consumed: " ++ show i + -- ++ "\ncontexts: " ++ show contexts + -- ++ "\nerror: " ++ show err Partial f -> handleResult (f (T.encodeUtf8 T.empty)) Done _ ts -> Right $ mkRdf (catMaybes ts) Nothing (PrefixMappings Map.empty) -parseFileAttoparsec :: (Rdf a) => String -> IO (Either ParseFailure (RDF a)) -parseFileAttoparsec path = parseStringAttoparsec <$> TIO.readFile path - -parseURLAttoparsec :: (Rdf a) => String -> IO (Either ParseFailure (RDF a)) -parseURLAttoparsec = _parseURL parseStringAttoparsec - --------------------------------- - - -handleParse :: {-forall rdf. (RDF rdf) => -} (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF a) -> - Either ParseError [Maybe Triple] -> - Either ParseFailure (RDF a) -handleParse _mkRdf result --- | T.length rem /= 0 = (Left $ ParseFailure $ "Invalid Document. Unparseable end of document: " ++ T.unpack rem) --- | otherwise = - = case result of - Left err -> Left $ ParseFailure $ "Parse failure: \n" ++ show err - Right ts -> Right $ _mkRdf (catMaybes ts) Nothing (PrefixMappings Map.empty) diff --git a/src/Text/RDF/RDF4H/TurtleParser.hs b/src/Text/RDF/RDF4H/TurtleParser.hs --- a/src/Text/RDF/RDF4H/TurtleParser.hs +++ b/src/Text/RDF/RDF4H/TurtleParser.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DoAndIfThenElse #-} + -- |An 'RdfParser' implementation for the Turtle format -- . @@ -786,7 +790,8 @@ parseStringAttoparsec bUrl docUrl bs = handleResult' $ parse (evalStateT t_turtleDoc (initialState bUrl docUrl)) (T.encodeUtf8 bs) where handleResult' res = case res of - Fail _ _ err -> error err + Fail _ _ err -> -- error err + Left $ ParseFailure $ "Parse failure: \n" ++ show err Partial f -> handleResult' (f (T.encodeUtf8 T.empty)) Done _ (ts,pms) -> Right $! mkRdf (F.toList ts) bUrl pms diff --git a/src/Text/RDF/RDF4H/XmlParser.hs b/src/Text/RDF/RDF4H/XmlParser.hs --- a/src/Text/RDF/RDF4H/XmlParser.hs +++ b/src/Text/RDF/RDF4H/XmlParser.hs @@ -1,4 +1,9 @@ -{-# Language Arrows,OverloadedStrings,DoAndIfThenElse,DeriveDataTypeable #-} +{-# LANGUAGE Arrows #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} -- |An parser for the RDF/XML format -- . @@ -7,7 +12,9 @@ XmlParser(XmlParser) ) where + import Control.Arrow ((>>>),(<<<),(&&&),(***),arr,returnA) +import Control.Arrow.ArrowList (arrL) import Control.Arrow.ArrowState (ArrowState,nextState) import Control.Exception import Data.List (isPrefixOf) @@ -15,10 +22,11 @@ import Data.Maybe import Data.Typeable import Text.RDF.RDF4H.ParserUtils -import Data.RDF.Types (Rdf,RDF,RdfParser(..),Node(BNodeGen),BaseUrl(..),Triple(..),Triples,Subject,Predicate,Object,PrefixMappings(..),ParseFailure(ParseFailure),mkRdf,lnode,plainL,plainLL,typedL,unode,bnode,unodeValidate) -import qualified Data.Text as T (Text,pack,unpack) +import Data.RDF.Types (Rdf,RDF,RdfParser(..),Node(BNodeGen),BaseUrl(..),Triple(..),Triples,Subject,Predicate,Object,PrefixMappings(..),ParseFailure(ParseFailure),mkRdf,lnode,plainL,plainLL,typedL,unode,bnode,unodeValidate,uriValidateString) +import qualified Data.Text as T -- (Text,pack,unpack) import qualified Data.Text.IO as TIO -import Text.XML.HXT.Core (ArrowXml,ArrowIf,XmlTree,IfThen((:->)),(>.),(>>.),first,neg,(<+>),expandURI,getName,getAttrValue,getAttrValue0,getAttrl,hasAttrValue,hasAttr,constA,choiceA,getChildren,ifA,arr2A,second,hasName,hasNamePrefix,isElem,isWhiteSpace,xshow,listA,isA,isText,getText,this,unlistA,orElse,sattr,mkelem,xreadDoc,runSLA) +import Text.XML.HXT.Core (ArrowXml,ArrowIf,XmlTree,IfThen((:->)),(>.),(>>.),first,neg,(<+>),expandURI,getName,getAttrValue,getAttrValue0,getAttrl,hasAttrValue,hasAttr,constA,choiceA,getChildren,ifA,arr2A,second,hasName,isElem,isWhiteSpace,xshow,listA,isA,isText,getText,this,unlistA,orElse,sattr,mkelem,xreadDoc,runSLA) + -- TODO: write QuickCheck tests for XmlParser instance for RdfParser. data XmlParser = XmlParser (Maybe BaseUrl) (Maybe T.Text) @@ -148,16 +156,18 @@ -- |Parse the current predicate element as a rdf:Description element (used when rdf:parseType = "Resource") parseAsResource :: forall a. (ArrowXml a, ArrowState GParseState a) => Node -> a (LParseState, XmlTree) Triple -parseAsResource n = updateState +parseAsResource n = + updateState >>> (arr2A parsePredicatesFromAttr <+> (second getName >>> arr (\(s, p) -> Triple (stateSubject s) ((unode . T.pack) p) n)) <+> (arr (\s -> s { stateSubject = n }) *** (getChildren >>> isElem) >>> parsePredicatesFromChildren)) -- |Read the attributes of an rdf:Description element. These correspond to the Predicate Object pairs of the Triple parsePredicatesFromAttr :: forall a. (ArrowXml a) => LParseState -> a XmlTree Triple -parsePredicatesFromAttr state = getAttrl - >>> (getName >>> neg isMetaAttr >>> mkUNode) &&& (getChildren >>> getText >>> arr (mkLiteralNode state)) - >>> arr (attachSubject (stateSubject state)) +parsePredicatesFromAttr state = + getAttrl + >>> (getName >>> neg isMetaAttr >>> mkUNode) &&& (getChildren >>> getText >>> arr (mkLiteralNode state)) + >>> arr (attachSubject (stateSubject state)) -- | Arrow to determine if special processing is required for an attribute isMetaAttr :: forall a. (ArrowXml a) => a String String @@ -197,7 +207,19 @@ -- -- And hence the use of `hasNamePrefix "rdf"` isValidPropElemName :: (ArrowXml a) => a XmlTree XmlTree -isValidPropElemName = hasNamePrefix "rdf" +isValidPropElemName = + hasName "rdf:Description" + <+> hasName "rdf:RDF" + <+> hasName "rdf:ID" + <+> hasName "rdf:about" + <+> hasName "rdf:bagID" + <+> hasName "rdf:parseType" + <+> hasName "rdf:resource" + <+> hasName "rdf:nodeID" + <+> hasName "rdf:aboutEach" + <+> hasName "rdf:aboutEachPrefix" + + -- isValidPropElemName = hasNamePrefix "rdf" -- hasName "rdf:Seq" -- <+> hasName "rdf:Bag" -- <+> hasName "rdf:Alt" @@ -226,7 +248,7 @@ , second (hasAttrValue "rdf:parseType" (== "Collection")) :-> (listA (defaultA >>> arr id &&& mkBlankNode) >>> mkCollectionTriples >>> unlistA) , second (hasAttr "rdf:datatype") :-> arr2A getTypedTriple -- for the following case, see rdfms-syntax-incomplete-error006 - , second (hasAttr "rdf:nodeID") :-> (neg (second (hasAttr "rdf:resource")) >>> arr2A getResourceTriple) + -- , second (hasAttr "rdf:nodeID") :-> (neg (second (hasAttr "rdf:resource")) >>> arr2A getResourceTriple) , second (hasAttr "rdf:nodeID") :-> arr2A getNodeIdTriple , second (hasAttr "rdf:ID") :-> (arr2A mkRelativeNode &&& defaultA >>> arr2A reifyTriple >>> unlistA) , second (hasAttr "rdf:resource") :-> arr2A validPropElemNames @@ -234,19 +256,21 @@ , second hasPredicateAttr :-> (defaultA <+> (mkBlankNode &&& arr id >>> arr2A parsePredicateAttr)) , this :-> defaultA ] + -- See: Issue http://www.w3.org/2000/03/rdf-tracking/#rdfms-rdf-names-use -- section: Illegal or unusual use of names from the RDF namespace -- -- Avoid making blank nodes for some property names. where validPropElemNames state = proc (predXml) -> do - p <- arr(unode . T.pack) <<< getName -< predXml - o <- getAttrValue "rdf:resource" -< predXml + p <- arr (unode . T.pack) <<< getName -< predXml + o <- getAttrValue0 "rdf:resource" -< predXml returnA -< Triple (stateSubject state) p (unode (T.pack o)) - defaultA = proc (state, predXml) -> do - p <- arr(unode . T.pack) <<< getName -< predXml - t <- arr2A (arr2A . parseObjectsFromChildren) <<< second (second getChildren) -< (state, (p, predXml)) - returnA -< t + defaultA = + proc (state, predXml) -> do + p <- arr (unode . T.pack) <<< getName -< predXml + t <- arr2A (arr2A . parseObjectsFromChildren) <<< second (second getChildren) -< (state, (p, predXml)) + returnA -< t -- parsePredicateAttr :: Node -> a (LParseState,XmlTree) Triple parsePredicateAttr n = (second getName >>> arr (\(s, p) -> Triple (stateSubject s) ((unode . T.pack) p) n)) <+> (first (arr (\s -> s { stateSubject = n })) >>> arr2A parsePredicatesFromAttr) @@ -270,13 +294,14 @@ parseObjectsFromChildren :: forall a. (ArrowIf a, ArrowXml a, ArrowState GParseState a) => LParseState -> Predicate -> a XmlTree Triple -parseObjectsFromChildren s p = choiceA - [ isText :-> (neg( isWhiteSpace) >>> getText >>> arr (Triple (stateSubject s) p . mkLiteralNode s)) - , isElem :-> (parseObjectDescription) - ] +parseObjectsFromChildren s p = + choiceA + [ isText :-> (neg( isWhiteSpace) >>> getText >>> arr (Triple (stateSubject s) p . mkLiteralNode s)) + , isElem :-> (parseObjectDescription) + ] where parseObjectDescription = proc desc -> do - _ <- (second (neg (hasAttr "rdf:nodeID")) &&& (second (neg (hasName "rdf:resource")))) -< (p,desc) + -- _ <- (second (neg (hasAttr "rdf:nodeID")) &&& (second (neg (hasName "rdf:resource")))) -< (p,desc) o <- mkNode s -< desc t0 <- arr (\(sub, (p', o)) -> Triple sub p' o) -< (stateSubject s, (p, o)) t <- arr fst <+> (parseDescription <<< arr snd) -< (t0, (s { stateSubject = o }, desc)) @@ -321,10 +346,10 @@ getTypedTriple state = nameToUNode &&& (attrExpandURI state "rdf:datatype" &&& xshow getChildren >>> arr (\(t, v) -> mkTypedLiteralNode (T.pack t) v)) >>> arr (attachSubject (stateSubject state)) -getResourceTriple :: forall a. (ArrowXml a) - => LParseState -> a XmlTree Triple -getResourceTriple state = nameToUNode &&& (attrExpandURI state "rdf:resource" >>> mkUNode) - >>> arr (attachSubject (stateSubject state)) +-- getResourceTriple :: forall a. (ArrowXml a) +-- => LParseState -> a XmlTree Triple +-- getResourceTriple state = nameToUNode &&& (attrExpandURI state "rdf:resource" >>> mkUNode) +-- >>> arr (attachSubject (stateSubject state)) getNodeIdTriple :: forall a. (ArrowXml a) => LParseState -> a XmlTree Triple @@ -371,12 +396,34 @@ nameToUNode = getName >>> mkUNode attrExpandURI :: forall a. (ArrowXml a) => LParseState -> String -> a XmlTree String -attrExpandURI state attr = getAttrValue attr &&& baseUrl >>> expandURI +attrExpandURI state attr = getAttrValue attr &&& baseUrl >>> my_expandURI where baseUrl = constA (case stateBaseUrl state of BaseUrl b -> T.unpack b) +my_expandURI :: ArrowXml a => a (String, String) String +my_expandURI + = arrL (maybeToList . uncurry my_expandURIString) + +my_expandURIString :: String -> String -> Maybe String +my_expandURIString uri base = + let absolute = if getPrefix uri == getPrefix base + then base ++ dropPrefix uri + else base ++ uri + in uriValidateString absolute + +dropPrefix :: String -> String +dropPrefix s = T.unpack $ T.drop 1 $ T.dropWhile (/= ':') (T.pack s) + +getPrefix :: String -> String +getPrefix s = + let pre = T.takeWhile (/= ':') (T.pack s) + in T.unpack $ + if (not (T.null pre)) + then (pre `T.append` ":") + else (T.pack "") + -- |Make a UNode from an absolute string mkUNode :: forall a. (ArrowIf a) => a String Node -mkUNode = choiceA [ (arr (isJust . unodeValidate . T.pack)) :-> (arr (fromJust . unodeValidate . T.pack)) +mkUNode = choiceA [ (arr (isJust . unodeValidate . T.pack)) :-> (arr (unode . T.pack)) , arr (\_ -> True) :-> arr (\uri -> throw (ParserException ("Invalid URI: " ++ uri))) ] diff --git a/testsuite/tests/Data/RDF/PropertyTests.hs b/testsuite/tests/Data/RDF/PropertyTests.hs --- a/testsuite/tests/Data/RDF/PropertyTests.hs +++ b/testsuite/tests/Data/RDF/PropertyTests.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} module Data.RDF.PropertyTests (graphTests,arbitraryTs) where diff --git a/testsuite/tests/Test.hs b/testsuite/tests/Test.hs --- a/testsuite/tests/Test.hs +++ b/testsuite/tests/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Main where @@ -15,6 +16,7 @@ import qualified W3C.RdfXmlTest as W3CRdfXmlTest import qualified W3C.TurtleTest as W3CTurtleTest import qualified Text.RDF.RDF4H.TurtleParser_ConformanceTest as TurtleUnitTest +import qualified Text.RDF.RDF4H.XmlParser_Test as XmlUnitTest suiteFilesDirTurtle,suiteFilesDirXml,suiteFilesDirNTriples :: T.Text suiteFilesDirTurtle = "rdf-tests/turtle/" @@ -78,7 +80,10 @@ (mkRdf :: Triples -> Maybe BaseUrl -> PrefixMappings -> RDF AdjHashMap))] , testGroup "parser-unit-tests-turtle" - TurtleUnitTest.allCTests + TurtleUnitTest.tests + , + testGroup "parser-unit-tests-xml" + XmlUnitTest.tests , testGroup "parser-w3c-tests-ntriples" diff --git a/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs b/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs --- a/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs +++ b/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs @@ -1,4 +1,7 @@ -module Text.RDF.RDF4H.TurtleParser_ConformanceTest where +module Text.RDF.RDF4H.TurtleParser_ConformanceTest + ( + tests + ) where -- Testing imports import Test.Tasty @@ -15,8 +18,8 @@ import Text.Printf import Text.RDF.RDF4H.TurtleParser -tests :: TestTree -tests = testGroup "TurtleParser" allCTests +-- tests :: TestTree +-- tests = testGroup "TurtleParser" allCTests -- A list of other tests to run, each entry of which is (directory, fname_without_ext). otherTestFiles :: [(String, String)] @@ -43,8 +46,8 @@ fpath :: String -> Int -> String -> String fpath name i ext = printf "data/ttl/conformance/%s-%02d.%s" name i ext :: String -allCTests :: [TestTree] -allCTests = ts1 ++ ts2 ++ ts3 +tests :: [TestTree] +tests = ts1 ++ ts2 ++ ts3 where ts1 = map (checkGoodConformanceTest) [0..30] ts2 = map (checkBadConformanceTest) [0..14] @@ -116,6 +119,8 @@ -- [] was parsed. equalNodes (BNode _) (BNodeGen _) = True equalNodes (BNodeGen _) (BNode _) = True + equalNodes (BNodeGen _) (BNodeGen _) = True + equalNodes (BNode _) (BNode _) = True equalNodes n1 n2 = n1 == n2 -- Returns a graph for a good ttl test that is intended to pass, and normalizes diff --git a/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs b/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs --- a/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs +++ b/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs @@ -1,44 +1,87 @@ -module Text.RDF.RDF4H.XmlParser_Test where +{-# LANGUAGE OverloadedStrings #-} +module Text.RDF.RDF4H.XmlParser_Test + ( + tests + ) where + -- todo: QuickCheck tests -- Testing imports import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.HUnit as TU -- Import common libraries to facilitate tests import qualified Data.Map as Map import Data.RDF.Query import Data.RDF.Graph.TList (TList) import Data.RDF.Types -import qualified Data.Text as T (Text, unlines) +import qualified Data.Text.IO as TIO +import qualified Data.Text as T (Text, pack, unlines) import Text.RDF.RDF4H.XmlParser +import Text.RDF.RDF4H.NTriplesParser +import Text.Printf -tests :: TestTree -tests = testGroup "XmlParser:parseXmlRDF" [ testCase "simpleStriping1" test_simpleStriping1 - , testCase "simpleStriping2" test_simpleStriping2 - , testCase "simpleSingleton1" test_simpleSingleton1 - , testCase "simpleSingleton2" test_simpleSingleton2 - , testCase "example07" test_parseXmlRDF_example07 - , testCase "example08" test_parseXmlRDF_example08 - , testCase "example09" test_parseXmlRDF_example09 - , testCase "example10" test_parseXmlRDF_example10 - , testCase "example11" test_parseXmlRDF_example11 - , testCase "example12" test_parseXmlRDF_example12 - , testCase "example13" test_parseXmlRDF_example13 - , testCase "example14" test_parseXmlRDF_example14 - , testCase "example15" test_parseXmlRDF_example15 - , testCase "example16" test_parseXmlRDF_example16 - , testCase "example17" test_parseXmlRDF_example17 - , testCase "example18" test_parseXmlRDF_example18 - , testCase "example19" test_parseXmlRDF_example19 - , testCase "example20" test_parseXmlRDF_example20 - , testCase "vCardPersonal" test_parseXmlRDF_vCardPersonal - , testCase "NML" test_parseXmlRDF_NML - , testCase "NML2" test_parseXmlRDF_NML2 - , testCase "NML3" test_parseXmlRDF_NML3 - ] +tests :: [TestTree] +tests = + [ testCase "simpleStriping1" test_simpleStriping1 + , testCase "simpleStriping2" test_simpleStriping2 + , testCase "simpleSingleton1" test_simpleSingleton1 + , testCase "simpleSingleton2" test_simpleSingleton2 + , testCase "vCardPersonal" test_parseXmlRDF_vCardPersonal + , testCase "NML" test_parseXmlRDF_NML + , testCase "NML2" test_parseXmlRDF_NML2 + , testCase "NML3" test_parseXmlRDF_NML3 + ] + ++ + map (uncurry checkGoodOtherTest) otherTestFiles +otherTestFiles :: [(String, String)] +otherTestFiles = [ ("data/xml", "example07") + , ("data/xml", "example08") + , ("data/xml", "example09") + , ("data/xml", "example10") + , ("data/xml", "example11") + , ("data/xml", "example12") + , ("data/xml", "example13") + , ("data/xml", "example14") + , ("data/xml", "example15") + , ("data/xml", "example16") + , ("data/xml", "example17") + , ("data/xml", "example18") + , ("data/xml", "example19") + , ("data/xml", "example20") + + -- https://github.com/robstewart57/rdf4h/issues/48 + , ("data/xml", "example22") + ] + +checkGoodOtherTest :: String -> String -> TestTree +checkGoodOtherTest dir fname = + let expGr = loadExpectedGraph1 (printf "%s/%s.out" dir fname :: String) + inGr = loadInputGraph1 dir fname + in doGoodConformanceTest expGr inGr $ printf "xml-%s" fname + +loadExpectedGraph1 :: String -> IO (Either ParseFailure (RDF TList)) +loadExpectedGraph1 fname = do + content <- TIO.readFile fname + return $ parseString NTriplesParser content + +loadInputGraph1 :: String -> String -> IO (Either ParseFailure (RDF TList)) +loadInputGraph1 dir fname = + TIO.readFile (printf "%s/%s.rdf" dir fname :: String) >>= + return . parseString (XmlParser Nothing (mkDocUrl1 testBaseUri fname)) >>= return . handleLoad + +doGoodConformanceTest :: IO (Either ParseFailure (RDF TList)) -> + IO (Either ParseFailure (RDF TList)) -> + String -> TestTree +doGoodConformanceTest expGr inGr testname = + let t1 = assertLoadSuccess (printf "expected (%s): " testname) expGr + t2 = assertLoadSuccess (printf " input (%s): " testname) inGr + t3 = assertEquivalent testname expGr inGr + in testGroup (printf "conformance-%s" testname) $ map (uncurry testCase) [("loading-expected-graph-data", t1), ("loading-input-graph-data", t2), ("comparing-graphs", t3)] + mkTextNode :: T.Text -> Node mkTextNode = lnode . plainL @@ -126,391 +169,7 @@ , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) ) --- * Document Element and XML Declaration -test_parseXmlRDF_example07 :: Assertion -test_parseXmlRDF_example07 = testParse - "\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \" - ( mkRdf [ Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar") - (unode "dc:title") - (mkTextNode "RDF/XML Syntax Specification (Revised)") - , Triple (BNodeGen 1) (unode "ex:fullName") (mkTextNode "Dave Beckett") - , Triple (BNodeGen 1) (unode "ex:homePage") (unode "http://purl.org/net/dajobe/") - , Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar") (unode "ex:editor") (BNodeGen 1) - ] - Nothing - ( PrefixMappings (Map.fromList [ ("dc", "http://purl.org/dc/elements/1.1/") - , ("ex", "http://example.org/stuff/1.0/") - , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) --- * Languages: xml:lang -test_parseXmlRDF_example08 :: Assertion -test_parseXmlRDF_example08 = testParse - "\ - \\ - \RDF/XML Syntax Specification (Revised)\ - \RDF/XML Syntax Specification (Revised)\ - \RDF/XML Syntax Specification (Revised)\ - \\ - \\ - \Der Baum\ - \Das Buch ist außergewöhnlich\ - \The Tree\ - \\ - \" - ( mkRdf [ Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar") - (unode "dc:title") - (mkTextNode "RDF/XML Syntax Specification (Revised)") - , Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar") - (unode "dc:title") - (lnode (plainLL ("RDF/XML Syntax Specification (Revised)") ("en"))) - , Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar") - (unode "dc:title") - (lnode (plainLL ("RDF/XML Syntax Specification (Revised)") ("en-US"))) - , Triple (unode "http://example.org/buecher/baum") - (unode "dc:title") - (lnode (plainLL ("Der Baum") ("de"))) - , Triple (unode "http://example.org/buecher/baum") - (unode "dc:description") - (lnode (plainLL ("Das Buch ist außergewöhnlich") ("de"))) - , Triple (unode "http://example.org/buecher/baum") - (unode "dc:title") - (lnode (plainLL ("The Tree") ("en"))) - ] - Nothing - ( PrefixMappings (Map.fromList [ ("dc", "http://purl.org/dc/elements/1.1/") - , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - --- * XML Literals: rdf:parseType="Literal" -test_parseXmlRDF_example09 :: Assertion -test_parseXmlRDF_example09 = testParse - "\ - \\ - \\ - \\ - \\ - \\ - \\ - \" - ( mkRdf [ Triple (unode "http://example.org/item01") - (unode "ex:prop") - (lnode (typedL ("\ - \\ - \\ - \") - ("http://www.w3.org/1999/02/22-rdf-syntax-ns#XMLLiteral"))) - ] - Nothing - ( PrefixMappings (Map.fromList [ ("ex", "http://example.org/stuff/1.0/") - , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - --- * Typed Literals: rdf:datatype -test_parseXmlRDF_example10 :: Assertion -test_parseXmlRDF_example10 = testParse - "\ - \\ - \123\ - \\ - \" - ( mkRdf [ Triple (unode "http://example.org/item01") - (unode "ex:size") - (lnode (typedL ("123") - ("http://www.w3.org/2001/XMLSchema#int"))) - ] - Nothing - ( PrefixMappings (Map.fromList [ ("ex", "http://example.org/stuff/1.0/") - , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - --- * Identifying Blank Nodes: rdf:nodeID -test_parseXmlRDF_example11 :: Assertion -test_parseXmlRDF_example11 = testParse - "\ - \\ - \\ - \\ - \\ - \\ - \\ - \" - ( mkRdf [ Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar") - (unode "dc:title") - (mkTextNode "RDF/XML Syntax Specification (Revised)") - , Triple (mkBNode "abc") (unode "ex:fullName") (mkTextNode "Dave Beckett") - , Triple (mkBNode "abc") (unode "ex:homePage") (unode "http://purl.org/net/dajobe/") - , Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar") - (unode "ex:editor") - (mkBNode "abc") - ] - Nothing - ( PrefixMappings (Map.fromList [ ("dc", "http://purl.org/dc/elements/1.1/") - , ("ex", "http://example.org/stuff/1.0/") - , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - where mkBNode = BNode - --- * Omitting Blank Nodes: rdf:parseType="Resource" -test_parseXmlRDF_example12 :: Assertion -test_parseXmlRDF_example12 = testParse - "\ - \\ - \\ - \Dave Beckett\ - \\ - \\ - \\ - \" - ( mkRdf [ Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar") - (unode "dc:title") - (mkTextNode "RDF/XML Syntax Specification (Revised)") - , Triple (BNodeGen 1) (unode "ex:fullName") (mkTextNode "Dave Beckett") - , Triple (BNodeGen 1) (unode "ex:homePage") (unode "http://purl.org/net/dajobe/") - , Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar") - (unode "ex:editor") - (BNodeGen 1) - ] - Nothing - ( PrefixMappings (Map.fromList [ ("dc", "http://purl.org/dc/elements/1.1/") - , ("ex", "http://example.org/stuff/1.0/") - , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - --- * Omitting Nodes: Property Attributes on an empty Property Element -test_parseXmlRDF_example13 :: Assertion -test_parseXmlRDF_example13 = testParse - "\ - \\ - \\ - \\ - \" - ( mkRdf [ Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar") - (unode "dc:title") - (mkTextNode "RDF/XML Syntax Specification (Revised)") - , Triple (BNodeGen 1) - (unode "ex:fullName") - (mkTextNode "Dave Beckett") - , Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar") - (unode "ex:editor") - (BNodeGen 1) - ] - Nothing - ( PrefixMappings (Map.fromList [ ("dc", "http://purl.org/dc/elements/1.1/") - , ("ex", "http://example.org/stuff/1.0/") - , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - --- * Typed Node Elements -test_parseXmlRDF_example14 :: Assertion -test_parseXmlRDF_example14 = testParse - "\ - \\ - \\ - \A marvelous thing\ - \\ - \" - ( mkRdf [ Triple (unode "http://example.org/thing") - (unode "rdf:type") - (unode "http://example.org/stuff/1.0/Document") - , Triple (unode "http://example.org/thing") - (unode "dc:title") - (mkTextNode "A marvelous thing") - ] - Nothing - ( PrefixMappings (Map.fromList [ ("dc", "http://purl.org/dc/elements/1.1/") - , ("ex", "http://example.org/stuff/1.0/") - , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - -test_parseXmlRDF_example15 :: Assertion -test_parseXmlRDF_example15 = testParse - "\ - \\ - \A marvelous thing\ - \\ - \" - ( mkRdf [ Triple (unode "http://example.org/thing") - (unode "rdf:type") - (unode "ex:Document") - , Triple (unode "http://example.org/thing") - (unode "dc:title") - (mkTextNode "A marvelous thing") - ] - Nothing - ( PrefixMappings (Map.fromList [ ("dc", "http://purl.org/dc/elements/1.1/") - , ("ex", "http://example.org/stuff/1.0/") - , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - --- * Abbreviating URIs: rdf:ID and xml:base -test_parseXmlRDF_example16 :: Assertion -test_parseXmlRDF_example16 = testParse - "\ - \\ - \\ - \\ - \" - ( mkRdf [ Triple (unode "http://example.org/here/#snack") (unode "ex:prop") (unode "http://example.org/here/fruit/apple") ] - Nothing - ( PrefixMappings (Map.fromList [ ("base", "http://example.org/here/") - , ("ex", "http://example.org/stuff/1.0/") - , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - --- * Container Membership Property Elements: rdf:li and rdf:_n -test_parseXmlRDF_example17 :: Assertion -test_parseXmlRDF_example17 = testParse - "\ - \\ - \\ - \\ - \\ - \\ - \" - ( mkRdf [ Triple (unode "http://example.org/favourite-fruit") - (unode "rdf:type") - (unode "rdf:Seq") - , Triple (unode "http://example.org/favourite-fruit") - (unode "rdf:_1") - (unode "http://example.org/banana") - , Triple (unode "http://example.org/favourite-fruit") - (unode "rdf:_2") - (unode "http://example.org/apple") - , Triple (unode "http://example.org/favourite-fruit") - (unode "rdf:_3") - (unode "http://example.org/pear") - ] - Nothing - ( PrefixMappings (Map.fromList [ ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - -test_parseXmlRDF_example18 :: Assertion -test_parseXmlRDF_example18 = testParse - "\ - \\ - \\ - \\ - \\ - \\ - \" - ( mkRdf [ Triple (unode "http://example.org/favourite-fruit") - (unode "rdf:type") - (unode "rdf:Seq") - , Triple (unode "http://example.org/favourite-fruit") - (unode "rdf:_1") - (unode "http://example.org/banana") - , Triple (unode "http://example.org/favourite-fruit") - (unode "rdf:_2") - (unode "http://example.org/apple") - , Triple (unode "http://example.org/favourite-fruit") - (unode "rdf:_3") - (unode "http://example.org/pear") - ] - Nothing - ( PrefixMappings (Map.fromList [ ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - --- * Collections: rdf:parseType="Collection" -test_parseXmlRDF_example19 :: Assertion -test_parseXmlRDF_example19 = testParse - "\ - \\ - \\ - \\ - \\ - \\ - \\ - \\ - \" - ( mkRdf [ Triple (unode "http://example.org/basket") (unode "ex:hasFruit") (BNodeGen 1) - , Triple (BNodeGen 1) - (unode "rdf:first") - (unode "http://example.org/banana") - , Triple (BNodeGen 1) - (unode "rdf:rest") - (BNodeGen 2) - , Triple (BNodeGen 2) - (unode "rdf:first") - (unode "http://example.org/apple") - , Triple (BNodeGen 2) - (unode "rdf:rest") - (BNodeGen 3) - , Triple (BNodeGen 3) - (unode "rdf:first") - (unode "http://example.org/pear") - , Triple (BNodeGen 3) - (unode "rdf:rest") - (unode "rdf:nil") - ] - Nothing - ( PrefixMappings (Map.fromList [ ("ex", "http://example.org/stuff/1.0/") - , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - --- * Reifying Statements: rdf:ID -test_parseXmlRDF_example20 :: Assertion -test_parseXmlRDF_example20 = testParse - "\ - \\ - \blah\ - \\ - \" - ( mkRdf [ Triple (unode "http://example.org/") - (unode "ex:prop") - (mkTextNode "blah") - , Triple (unode "http://example.org/triples/#triple1") - (unode "rdf:type") - (unode "rdf:Statement") - , Triple (unode "http://example.org/triples/#triple1") - (unode "rdf:subject") - (unode "http://example.org/") - , Triple (unode "http://example.org/triples/#triple1") - (unode "rdf:predicate") - (unode "ex:prop") - , Triple (unode "http://example.org/triples/#triple1") - (unode "rdf:object") - (mkTextNode "blah") - ] - ( Just (BaseUrl ("http://example.org/here/")) ) - ( PrefixMappings (Map.fromList [ ("ex", "http://example.org/stuff/1.0/") - , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) ) - ) - test_parseXmlRDF_vCardPersonal :: Assertion test_parseXmlRDF_vCardPersonal = testParse " String -> IO (Either ParseFailure (RDF a)) -> IO (Either ParseFailure (RDF a)) -> TU.Assertion +assertEquivalent testname r1 r2 = do + gr1 <- r1 + gr2 <- r2 + case equivalent gr1 gr2 of + Nothing -> TU.assert True + (Just msg) -> fail $ "Graph " ++ testname ++ " not equivalent to expected:\n" ++ msg + +-- Determines if graphs are equivalent, returning Nothing if so or else a diagnostic message. +-- First graph is expected graph, second graph is actual. +equivalent :: Rdf a => Either ParseFailure (RDF a) -> Either ParseFailure (RDF a) -> Maybe String +equivalent (Left _) _ = Nothing +equivalent _ (Left _) = Nothing +equivalent (Right gr1) (Right gr2) = test $! zip gr1ts gr2ts + where + gr1ts = uordered $ uniqTriplesOf gr1 -- triplesOf gr1 + gr2ts = uordered $ uniqTriplesOf gr2 -- triplesOf gr2 + test [] = Nothing + test ((t1,t2):ts) = + case compareTriple t1 t2 of + Nothing -> test ts + err -> err + compareTriple t1 t2 = + if equalNodes s1 s2 && equalNodes p1 p2 && equalNodes o1 o2 + then Nothing + else Just ("Expected:\n " ++ show t1 ++ "\nFound:\n " ++ show t2 ++ "\n") + where + (s1, p1, o1) = f t1 + (s2, p2, o2) = f t2 + f t = (subjectOf t, predicateOf t, objectOf t) + -- equalNodes (BNode fs1) (BNodeGen i) = T.reverse fs1 == T.pack ("_:genid" ++ show i) + -- equalNodes (BNode fs1) (BNodeGen i) = fs1 == T.pack ("_:genid" ++ show i) + + -- I'm not sure it's right to compare blank nodes with generated + -- blank nodes. This is because parsing an already generated blank + -- node is parsed as a blank node. Moreover, a parser is free to + -- generate the blank node how ever they wish. E.g. parsing [] could be: + -- + -- _:genid1 + -- + -- or + -- + -- _:Bb71dd4e4b81c097db8d7f79078bbc7c0 + -- + -- which just so happens to be what Apache Jena just created when + -- [] was parsed. + equalNodes (BNode _) (BNodeGen _) = True + equalNodes (BNodeGen _) (BNode _) = True + equalNodes (BNodeGen _) (BNodeGen _) = True + equalNodes (BNode _) (BNode _) = True + equalNodes n1 n2 = n1 == n2 + +assertLoadSuccess :: String -> IO (Either ParseFailure (RDF TList)) -> TU.Assertion +assertLoadSuccess idStr exprGr = do + g <- exprGr + case g of + Left (ParseFailure err) -> TU.assertFailure $ idStr ++ err + Right _ -> return () + +-- assertLoadFailure idStr exprGr = do +-- g <- exprGr +-- case g of +-- Left _ -> return () +-- Right _ -> TU.assertFailure $ "Bad test " ++ idStr ++ " loaded successfully." + +handleLoad :: Either ParseFailure (RDF TList) -> Either ParseFailure (RDF TList) +handleLoad res = + case res of + l@(Left _) -> l + (Right gr) -> Right $ mkRdf (map normalize (triplesOf gr)) (baseUrl gr) (prefixMappings gr) + +normalize :: Triple -> Triple +normalize t = let s' = normalizeN $ subjectOf t + p' = normalizeN $ predicateOf t + o' = normalizeN $ objectOf t + in triple s' p' o' +normalizeN :: Node -> Node +normalizeN (BNodeGen i) = BNode (T.pack $ "_:genid" ++ show i) +normalizeN n = n + +-- The Base URI to be used for all conformance tests: +testBaseUri :: String +testBaseUri = "http://www.w3.org/2001/sw/DataAccess/df1/tests/" + +mkDocUrl1 :: String -> String -> Maybe T.Text +mkDocUrl1 baseDocUrl fname = Just $ T.pack $ printf "%s%s.rdf" baseDocUrl fname diff --git a/testsuite/tests/W3C/Manifest.hs b/testsuite/tests/W3C/Manifest.hs --- a/testsuite/tests/W3C/Manifest.hs +++ b/testsuite/tests/W3C/Manifest.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module W3C.Manifest ( loadManifest, diff --git a/testsuite/tests/W3C/RdfXmlTest.hs b/testsuite/tests/W3C/RdfXmlTest.hs --- a/testsuite/tests/W3C/RdfXmlTest.hs +++ b/testsuite/tests/W3C/RdfXmlTest.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module W3C.RdfXmlTest where import Data.Maybe (fromJust) @@ -36,7 +38,8 @@ mfEntryToTest x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x mfBaseURIXml :: BaseUrl -mfBaseURIXml = BaseUrl "http://www.w3.org/2013/RDFXMLTests/" +-- mfBaseURIXml = BaseUrl "http://www.w3.org/2013/RDFXMLTests/" +mfBaseURIXml = BaseUrl "" testParser :: XmlParser testParser = XmlParser (Just mfBaseURIXml) Nothing diff --git a/testsuite/tests/W3C/TurtleTest.hs b/testsuite/tests/W3C/TurtleTest.hs --- a/testsuite/tests/W3C/TurtleTest.hs +++ b/testsuite/tests/W3C/TurtleTest.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module W3C.TurtleTest where import Test.Tasty