rdf4h 4.0.1 → 4.0.2
raw patch · 7 files changed
+320/−285 lines, 7 filesdep −hgal
Dependencies removed: hgal
Files
- rdf4h.cabal +1/−2
- src/Data/RDF.hs +1/−0
- src/Data/RDF/Namespace.hs +6/−2
- src/Data/RDF/Query.hs +2/−28
- src/Rdf4hParseMain.hs +41/−35
- src/Text/RDF/RDF4H/XmlParser.hs +240/−192
- testsuite/tests/W3C/W3CAssertions.hs +29/−26
rdf4h.cabal view
@@ -1,5 +1,5 @@ name: rdf4h-version: 4.0.1+version: 4.0.2 synopsis: A library for RDF processing in Haskell description: 'RDF for Haskell' is a library for working with RDF in Haskell.@@ -62,7 +62,6 @@ , hashable , deepseq , binary- , hgal , parsers , mtl , network-uri >= 2.6
src/Data/RDF.hs view
@@ -11,6 +11,7 @@ module Data.RDF.IRI, module Data.RDF.Types, module Data.RDF.Query,+ module Data.RDF.Namespace, -- * RDF type class instances module Data.RDF.Graph.TList,
src/Data/RDF/Namespace.hs view
@@ -11,7 +11,7 @@ mkUri, prefixOf, uriOf, -- * Predefined namespace values- rdf, rdfs, dc, dct, owl, xml, xsd, skos, foaf, ex, ex2,+ rdf, rdfs, dc, dct, owl, schema, xml, xsd, skos, foaf, ex, ex2, standard_ns_mappings, ns_mappings ) where @@ -29,7 +29,7 @@ #endif standard_namespaces :: [Namespace]-standard_namespaces = [rdf, rdfs, dc, dct, owl, xsd, skos, foaf, ex, ex2]+standard_namespaces = [rdf, rdfs, dc, dct, schema, owl, xsd, skos, foaf, ex, ex2] -- |The set of common predefined namespaces as a 'PrefixMappings' value. standard_ns_mappings :: PrefixMappings@@ -62,6 +62,10 @@ -- |The OWL namespace. owl :: Namespace owl = mkPrefixedNS' "owl" "http://www.w3.org/2002/07/owl#"++-- |The Schema.org namespace+schema :: Namespace+schema = mkPrefixedNS' "schema" "http://schema.org/" -- |The XML Schema namespace. xml :: Namespace
src/Data/RDF/Query.hs view
@@ -18,7 +18,6 @@ -- * RDF graph functions isIsomorphic,- isGraphIsomorphic, expandTriples, fromEither, @@ -31,16 +30,12 @@ absolutizeTriple, absolutizeNode, absolutizeNodeUnsafe,- QueryException(..)+ QueryException (..), ) where import Control.Applicative ((<|>)) import Control.Exception-import Data.Graph (Graph, graphFromEdges)-import qualified Data.Graph.Automorphism as Automorphism-import qualified Data.HashMap.Strict as HashMap-import Data.HashMap.Strict (HashMap) import Data.List import Data.Maybe (fromMaybe) import Data.RDF.IRI@@ -136,7 +131,7 @@ compareNodeUnlessBlank (LNode l1) (LNode l2) = l1 == l2 compareNodeUnlessBlank (BNodeGen _) (BNode _) = True compareNodeUnlessBlank (BNode _) (BNodeGen _) = True- compareNodeUnlessBlank _ _ = False+ compareNodeUnlessBlank _ _ = False -- isn't this exhaustive already? compareTripleUnlessBlank :: Triple -> Triple -> Bool compareTripleUnlessBlank (Triple s1 p1 o1) (Triple s2 p2 o2) = compareNodeUnlessBlank s1 s2@@ -144,27 +139,6 @@ && compareNodeUnlessBlank o1 o2 normalize :: (Rdf a) => RDF a -> Triples normalize = sort . nub . expandTriples---- | Compares the structure of two graphs and returns 'True' if their--- graph structures are identical. This does not consider the nature--- of each node in the graph, i.e. the URI text of 'UNode' nodes,--- the generated index of a blank node, or the values in literal--- nodes. Unsafe because it assumes IRI resolution will succeed, may--- throw an 'IRIResolutionException` exception.-isGraphIsomorphic :: (Rdf a, Rdf b) => RDF a -> RDF b -> Bool-isGraphIsomorphic g1 g2 = Automorphism.isIsomorphic g1' g2'- where- g1' = rdfGraphToDataGraph g1- g2' = rdfGraphToDataGraph g2- rdfGraphToDataGraph :: Rdf c => RDF c -> Graph- rdfGraphToDataGraph g = dataGraph- where- triples = expandTriples g- triplesHashMap :: HashMap (Subject, Predicate) [Object]- triplesHashMap = HashMap.fromListWith (<>) [((s, p), [o]) | Triple s p o <- triples]- triplesGrouped :: [((Subject, Predicate), [Object])]- triplesGrouped = HashMap.toList triplesHashMap- (dataGraph, _, _) = (graphFromEdges . fmap (\((s, p), os) -> (s, p, os))) triplesGrouped -- | Expand the triples in a graph with the prefix map and base URL -- for that graph. Unsafe because it assumes IRI resolution will
src/Rdf4hParseMain.hs view
@@ -75,47 +75,53 @@ docUri = Just $ T.pack inputUri emptyPms = PrefixMappings Map.empty case (inputFormat, isUri $ T.pack inputUri) of- ("turtle", True) -> parseURL- (TurtleParser mInputUri docUri)- inputUri- >>= \(res :: Either ParseFailure (RDF TList)) ->- write outputFormat docUri emptyPms res- ("turtle", False) -> ( if inputUri /= "-"- then parseFile (TurtleParser mInputUri docUri) inputUri- else parseString (TurtleParser mInputUri docUri) <$> TIO.getContents- )- >>= \(res :: Either ParseFailure (RDF TList)) ->- write outputFormat docUri emptyPms res- ("ntriples", True) -> parseURL NTriplesParser inputUri- >>= \(res :: Either ParseFailure (RDF TList)) ->- write outputFormat Nothing emptyPms res- ("ntriples", False) -> ( if inputUri /= "-"- then parseFile NTriplesParser inputUri- else parseString NTriplesParser <$> TIO.getContents- )- >>= \(res :: Either ParseFailure (RDF TList)) ->- write outputFormat Nothing emptyPms res- ("xml", True) -> parseURL- (XmlParser mInputUri docUri)- inputUri- >>= \(res :: Either ParseFailure (RDF TList)) ->- write outputFormat docUri emptyPms res- ("xml", False) -> ( if inputUri /= "-"- then parseFile (XmlParser mInputUri docUri) inputUri- else parseString (XmlParser mInputUri docUri) <$> TIO.getContents- )- >>= \(res :: Either ParseFailure (RDF TList)) ->- write outputFormat docUri emptyPms res+ ("turtle", True) ->+ parseURL+ (TurtleParser mInputUri docUri)+ inputUri+ >>= \(res :: Either ParseFailure (RDF TList)) ->+ write outputFormat docUri emptyPms res+ ("turtle", False) ->+ ( if inputUri /= "-"+ then parseFile (TurtleParser mInputUri docUri) inputUri+ else parseString (TurtleParser mInputUri docUri) <$> TIO.getContents+ )+ >>= \(res :: Either ParseFailure (RDF TList)) ->+ write outputFormat docUri emptyPms res+ ("ntriples", True) ->+ parseURL NTriplesParser inputUri+ >>= \(res :: Either ParseFailure (RDF TList)) ->+ write outputFormat Nothing emptyPms res+ ("ntriples", False) ->+ ( if inputUri /= "-"+ then parseFile NTriplesParser inputUri+ else parseString NTriplesParser <$> TIO.getContents+ )+ >>= \(res :: Either ParseFailure (RDF TList)) ->+ write outputFormat Nothing emptyPms res+ ("xml", True) ->+ parseURL+ (XmlParser mInputUri docUri)+ inputUri+ >>= \(res :: Either ParseFailure (RDF TList)) ->+ write outputFormat docUri emptyPms res+ ("xml", False) ->+ ( if inputUri /= "-"+ then parseFile (XmlParser mInputUri docUri) inputUri+ else parseString (XmlParser mInputUri docUri) <$> TIO.getContents+ )+ >>= \(res :: Either ParseFailure (RDF TList)) ->+ write outputFormat docUri emptyPms res (str, _) -> putStrLn ("Invalid format: " <> str) >> exitFailure write :: (Rdf a) => String -> Maybe T.Text -> PrefixMappings -> Either ParseFailure (RDF a) -> IO () write format docUri pms res = case res of (Left (ParseFailure msg)) -> putStrLn msg >> exitWith (ExitFailure 1)- (Right rdf) -> doWriteRdf rdf+ (Right rdfG) -> doWriteRdf rdfG where- doWriteRdf rdf = case format of- "turtle" -> writeRdf (TurtleSerializer docUri pms) rdf- "ntriples" -> writeRdf NTriplesSerializer rdf+ doWriteRdf rdfG = case format of+ "turtle" -> writeRdf (TurtleSerializer docUri pms) rdfG+ "ntriples" -> writeRdf NTriplesSerializer rdfG unknown -> error $ "Unknown output format: " <> unknown -- Get the input base URI from the argument list or flags, using the
src/Text/RDF/RDF4H/XmlParser.hs view
@@ -1,33 +1,24 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} --- |An parser for the RDF/XML format--- <http://www.w3.org/TR/REC-rdf-syntax/>.-+-- | An parser for the RDF/XML format+-- <http://www.w3.org/TR/REC-rdf-syntax/>. module Text.RDF.RDF4H.XmlParser- ( XmlParser(..)- , parseXmlDebug- ) where--import Data.RDF.Types hiding (empty, resolveQName)-import qualified Data.RDF.Types as RDF-import Data.RDF.IRI-import Data.RDF.Graph.TList-import Text.RDF.RDF4H.ParserUtils hiding (Parser)-import Text.RDF.RDF4H.XmlParser.Identifiers-import Text.RDF.RDF4H.XmlParser.Xmlbf hiding (Node)-import qualified Text.RDF.RDF4H.XmlParser.Xeno as Xeno+ ( XmlParser (..),+ parseXmlDebug,+ )+where -import Control.Applicative-import Control.Monad-import Control.Monad.Except-import Control.Monad.State.Strict+import Control.Applicative+import Control.Monad+import Control.Monad.Except+import Control.Monad.State.Strict #if MIN_VERSION_base(4,9,0) #if !MIN_VERSION_base(4,11,0) import Data.Semigroup@@ -35,90 +26,107 @@ #endif #else #endif-import Data.Set (Set)-import qualified Data.Set as S-import qualified Data.Map as Map-import Data.Maybe+ #if MIN_VERSION_base(4,10,0) import Data.Either #else #endif-import Data.Bifunctor-import Data.HashSet (HashSet)-import qualified Data.HashSet as HS-import Data.HashMap.Strict (HashMap)+import Data.Bifunctor+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM-import Data.Text (Text)+import Data.HashSet (HashSet)+import qualified Data.HashSet as HS+import qualified Data.Map as Map+import Data.Maybe+import Data.RDF.Graph.TList+import Data.RDF.IRI+import Data.RDF.Types hiding (empty, resolveQName)+import qualified Data.RDF.Types as RDF+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Data.Text.IO as TIO import qualified Data.Text.Lazy as TL-import qualified Data.Text.Encoding as T-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Builder as BB+import Text.RDF.RDF4H.ParserUtils hiding (Parser)+import Text.RDF.RDF4H.XmlParser.Identifiers+import qualified Text.RDF.RDF4H.XmlParser.Xeno as Xeno+import Text.RDF.RDF4H.XmlParser.Xmlbf hiding (Node)+ -- import Xmlbf hiding (Node, State) -- import qualified Xmlbf.Xeno as Xeno instance RdfParser XmlParser where parseString (XmlParser bUrl dUrl) = parseXmlRDF bUrl dUrl- parseFile (XmlParser bUrl dUrl) = parseFile' bUrl dUrl- parseURL (XmlParser bUrl dUrl) = parseURL' bUrl dUrl+ parseFile (XmlParser bUrl dUrl) = parseFile' bUrl dUrl+ parseURL (XmlParser bUrl dUrl) = parseURL' bUrl dUrl --- |Configuration for the XML parser-data XmlParser =- XmlParser (Maybe BaseUrl) -- ^ The /default/ base URI to parse the document.- (Maybe Text) -- ^ The /retrieval URI/ of the XML document.+-- | Configuration for the XML parser+data XmlParser+ = XmlParser+ (Maybe BaseUrl)+ -- ^ The /default/ base URI to parse the document.+ (Maybe Text)+ -- ^ The /retrieval URI/ of the XML document. -parseFile' :: (Rdf a)- => Maybe BaseUrl- -> Maybe Text- -> FilePath- -> IO (Either ParseFailure (RDF a))+parseFile' ::+ (Rdf a) =>+ Maybe BaseUrl ->+ Maybe Text ->+ FilePath ->+ IO (Either ParseFailure (RDF a)) parseFile' bUrl dUrl fpath = parseXmlRDF bUrl dUrl <$> TIO.readFile fpath -parseURL' :: (Rdf a)- => Maybe BaseUrl- -- ^ The optional base URI of the document.- -> Maybe Text- -- ^ The document URI (i.e., the URI of the document itself); if Nothing, use location URI.- -> String- -- ^ The location URI from which to retrieve the XML document.- -> IO (Either ParseFailure (RDF a))- -- ^ The parse result, which is either a @ParseFailure@ or the RDF+parseURL' ::+ (Rdf a) =>+ -- | The optional base URI of the document.+ Maybe BaseUrl ->+ -- | The document URI (i.e., the URI of the document itself); if Nothing, use location URI.+ Maybe Text ->+ -- | The location URI from which to retrieve the XML document.+ String ->+ -- | The parse result, which is either a @ParseFailure@ or the RDF -- corresponding to the XML document.+ IO (Either ParseFailure (RDF a)) parseURL' bUrl docUrl = parseFromURL (parseXmlRDF bUrl docUrl) --- |The parser monad.+-- | The parser monad. type Parser = ParserT (ExceptT String (State ParseState)) --- |Local state for the parser (dependant on the parent xml elements)+-- | Local state for the parser (dependant on the parent xml elements) data ParseState = ParseState- { stateBaseUri :: Maybe BaseUrl- -- ^ The local base URI.- , stateIdSet :: Set Text- -- ^ The set of @rdf:ID@ found in the scope of the current base URI.- , statePrefixMapping :: PrefixMappings- -- ^ The namespace mapping.- , stateLang :: Maybe Text- -- ^ The local @xml:lang@- , stateNodeAttrs :: HashMap Text Text- -- ^ Current node RDF attributes.- , stateSubject :: Maybe Subject- -- ^ Current subject for triple construction.- , stateCollectionIndex :: Int- -- ^ Current collection index.- , stateGenId :: Int- } deriving(Show)+ { -- | The local base URI.+ stateBaseUri :: Maybe BaseUrl,+ -- | The set of @rdf:ID@ found in the scope of the current base URI.+ stateIdSet :: Set Text,+ -- | The namespace mapping.+ statePrefixMapping :: PrefixMappings,+ -- | The local @xml:lang@+ stateLang :: Maybe Text,+ -- | Current node RDF attributes.+ stateNodeAttrs :: HashMap Text Text,+ -- | Current subject for triple construction.+ stateSubject :: Maybe Subject,+ -- | Current collection index.+ stateCollectionIndex :: Int,+ stateGenId :: Int+ }+ deriving (Show) --- |Parse a xml Text to an RDF representation-parseXmlRDF :: (Rdf a)- => Maybe BaseUrl- -- ^ The base URI for the RDF if required- -> Maybe Text- -- ^ The request URI for the document to if available- -> Text- -- ^ The contents to parse- -> Either ParseFailure (RDF a)- -- ^ The RDF representation of the triples or ParseFailure+-- | Parse a xml Text to an RDF representation+parseXmlRDF ::+ (Rdf a) =>+ -- | The base URI for the RDF if required+ Maybe BaseUrl ->+ -- | The request URI for the document to if available+ Maybe Text ->+ -- | The contents to parse+ Text ->+ -- | The RDF representation of the triples or ParseFailure+ Either ParseFailure (RDF a) parseXmlRDF bUrl dUrl = parseRdf . parseXml where bUrl' = BaseUrl <$> dUrl <|> bUrl@@ -127,14 +135,14 @@ parseRdf' ns = join $ evalState (runExceptT (parseM rdfParser ns)) initState initState = ParseState bUrl' mempty mempty empty mempty empty 0 0 --- |A parser for debugging purposes.-parseXmlDebug- :: FilePath- -- ^ Path of the file to parse.- -> IO (RDF TList)+-- | A parser for debugging purposes.+parseXmlDebug ::+ -- | Path of the file to parse.+ FilePath ->+ IO (RDF TList) parseXmlDebug f = fromRight RDF.empty <$> parseFile (XmlParser (Just . BaseUrl $ "http://base-url.com/") (Just "http://doc-url.com/")) f --- |Document parser+-- | Document parser rdfParser :: Rdf a => Parser (RDF a) rdfParser = do bUri <- currentBaseUri@@ -142,8 +150,8 @@ pEndOfInput mkRdf triples bUri <$> currentPrefixMappings --- |Parser for @rdf:RDF@, if present.--- See: https://www.w3.org/TR/rdf-syntax-grammar/#RDF+-- | Parser for @rdf:RDF@, if present.+-- See: https://www.w3.org/TR/rdf-syntax-grammar/#RDF pRdf :: Parser Triples pRdf = pAnyElement $ do attrs <- pRDFAttrs@@ -152,18 +160,18 @@ unless (null attrs) $ throwError "rdf:RDF: The set of attributes should be empty." pNodeElementList --- |Parser for XML QName: resolve the namespace with the mapping in context.+-- | Parser for XML QName: resolve the namespace with the mapping in context. ----- Throws an error if the namespace is not defined.+-- Throws an error if the namespace is not defined. pQName :: Text -> Parser Text pQName qn = do pm <- currentPrefixMappings let qn' = resolveQName pm qn >>= validateIRI either throwError pure qn' --- |Process the attributes of an XML element.+-- | Process the attributes of an XML element. ----- To be called __once__ per XML element.+-- To be called __once__ per XML element. pRDFAttrs :: Parser (HashMap Text Text) pRDFAttrs = do -- Language (xml:lang)@@ -180,53 +188,49 @@ setNodeAttrs as pure as where- -- |Check if an XML attribute is a namespace definition- -- and if so add it to the mapping.- mkNameSpace- :: Map.Map Text Text- -- ^ Current namespace mapping- -> Text- -- ^ XML attribute to process- -> Text- -- ^ Value of the attribute- -> Map.Map Text Text+ mkNameSpace ::+ -- | Current namespace mapping+ Map.Map Text Text ->+ -- | XML attribute to process+ Text ->+ -- | Value of the attribute+ Text ->+ Map.Map Text Text mkNameSpace ns qn iri = let qn' = parseQName qn ns' = f <$> qn' <*> validateIRI iri- f (Nothing , "xmlns") iri' = Map.insert mempty iri' ns- f (Just "xmlns", prefix ) iri' = Map.insert prefix iri' ns- f _ _ = ns- in either (const ns) id ns'- -- |Check if an XML attribute is an RDF attribute- -- and if so resolve its URI and keep it.- mkRdfAttribute- :: PrefixMappings- -- ^ Namespace mapping- -> Maybe BaseUrl- -- ^ Base URI- -> HM.HashMap Text Text- -- ^ Current set of RDF attributes- -> Text- -- ^ XML attribute to process- -> Text- -- ^ Value of the attribute- -> HM.HashMap Text Text+ f (Nothing, "xmlns") iri' = Map.insert mempty iri' ns+ f (Just "xmlns", prefix) iri' = Map.insert prefix iri' ns+ f _ _ = ns+ in either (const ns) id ns'+ mkRdfAttribute ::+ -- | Namespace mapping+ PrefixMappings ->+ -- | Base URI+ Maybe BaseUrl ->+ -- | Current set of RDF attributes+ HM.HashMap Text Text ->+ -- | XML attribute to process+ Text ->+ -- | Value of the attribute+ Text ->+ HM.HashMap Text Text mkRdfAttribute pm bUri as qn v = let as' = parseQName qn >>= f -- [NOTE] Ignore XML reserved names f (Nothing, n) | T.isPrefixOf "xml" n = Right as- | otherwise = case bUri of- Nothing -> Right as -- [FIXME] manage missing base URI- Just (BaseUrl bUri') -> (\a -> HM.insert a v as) <$> resolveIRI bUri' n+ | otherwise = case bUri of+ Nothing -> Right as -- [FIXME] manage missing base URI+ Just (BaseUrl bUri') -> (\a -> HM.insert a v as) <$> resolveIRI bUri' n f qn'@(Just prefix, _) | T.isPrefixOf "xml" prefix = Right as | otherwise = (\a -> HM.insert a v as) <$> resolveQName' pm qn'- in either (const as) id as'+ in either (const as) id as' --- |Return the value of the requested RDF attribute using its URI.+-- | Return the value of the requested RDF attribute using its URI. ----- Fails if the attribute is not defined.+-- Fails if the attribute is not defined. pRDFAttr :: Text -> Parser Text pRDFAttr a = do as <- currentNodeAttrs@@ -239,8 +243,8 @@ pNodeElementList :: Parser Triples pNodeElementList = pWs *> (mconcat <$> some (keepState pNodeElement <* pWs)) --- |White spaces parser--- See: https://www.w3.org/TR/rdf-syntax-grammar/#ws+-- | White spaces parser+-- See: https://www.w3.org/TR/rdf-syntax-grammar/#ws pWs :: Parser () pWs = maybe True (T.all ws . TL.toStrict) <$> optional pText >>= guard where@@ -259,10 +263,10 @@ ts2 <- keepState pPropertyEltList setSubject (Just s) let ts = ts1 <> ts2- pure $ maybe ts (:ts) mt+ pure $ maybe ts (: ts) mt --- |Process the following parts of a @nodeElement@: URI, subject and @rdf:type@.--- See: https://www.w3.org/TR/rdf-syntax-grammar/#nodeElement+-- | Process the following parts of a @nodeElement@: URI, subject and @rdf:type@.+-- See: https://www.w3.org/TR/rdf-syntax-grammar/#nodeElement pSubject :: Parser (Node, Maybe Triple) pSubject = do -- Create the subject@@ -292,15 +296,17 @@ pPropertyAttrs :: Node -> Parser Triples pPropertyAttrs s = do attrs <- currentNodeAttrs- HM.elems <$> HM.traverseWithKey f attrs+ -- HM.elems <$> HM.traverseWithKey f attrs+ HM.elems <$> HM.traverseWithKey f (HM.delete rdfID attrs) where f attr value | not (isPropertyAttrURI attr) = throwError $ "URI not allowed for attribute: " <> T.unpack attr | attr == rdfType = pure $ Triple s rdfTypeNode (unode value) | otherwise = do- lang <- currentLang- pure $ let mkLiteral = maybe plainL (flip plainLL) lang- in Triple s (unode attr) (lnode (mkLiteral value))+ lang <- currentLang+ pure $+ let mkLiteral = maybe plainL (flip plainLL) lang+ in Triple s (unode attr) (lnode (mkLiteral value)) pLang :: Parser (Maybe Text) pLang = optional (pAttr "xml:lang")@@ -310,16 +316,18 @@ pBase = optional $ do uri <- pAttr "xml:base" -- Parse and remove fragment- BaseUrl <$> either- throwError- (pure . serializeIRI . removeIRIFragment)- (parseIRI uri)+ BaseUrl+ <$> either+ throwError+ (pure . serializeIRI . removeIRIFragment)+ (parseIRI uri) -- See: https://www.w3.org/TR/rdf-syntax-grammar/#propertyEltList pPropertyEltList :: Parser Triples-pPropertyEltList = pWs- *> resetCollectionIndex- *> fmap mconcat (many (pPropertyElt <* pWs))+pPropertyEltList =+ pWs+ *> resetCollectionIndex+ *> fmap mconcat (many (pPropertyElt <* pWs)) -- See: https://www.w3.org/TR/rdf-syntax-grammar/#propertyElt pPropertyElt :: Parser Triples@@ -341,7 +349,7 @@ where listExpansion u | u == rdfLi = nextCollectionIndex- | otherwise = pure u+ | otherwise = pure u -- See: https://www.w3.org/TR/rdf-syntax-grammar/#resourcePropertyElt pResourcePropertyElt :: Node -> Parser Triples@@ -358,7 +366,7 @@ let mt = flip Triple p <$> s <*> o -- Reify the triple ts2 <- maybe (pure mempty) (uncurry reifyTriple) (liftA2 (,) mi mt)- pure $ maybe (ts1 <> ts2) (:(ts1 <> ts2)) mt+ pure $ maybe (ts1 <> ts2) (: (ts1 <> ts2)) mt -- See: https://www.w3.org/TR/rdf-syntax-grammar/#literalPropertyElt pLiteralPropertyElt :: Node -> Parser Triples@@ -377,7 +385,7 @@ mt = (\s' -> Triple s' p o) <$> s -- Reify the triple ts <- maybe (pure mempty) (uncurry reifyTriple) (liftA2 (,) mi mt)- pure $ maybe ts (:ts) mt+ pure $ maybe ts (: ts) mt -- See: https://www.w3.org/TR/rdf-syntax-grammar/#parseTypeLiteralPropertyElt pParseTypeLiteralPropertyElt :: Node -> Parser Triples@@ -393,7 +401,7 @@ mt = (\s' -> Triple s' p o) <$> s -- Reify the triple ts <- maybe (pure mempty) (uncurry reifyTriple) (liftA2 (,) mi mt)- pure $ maybe ts (:ts) mt+ pure $ maybe ts (: ts) mt -- See: https://www.w3.org/TR/rdf-syntax-grammar/#parseTypeResourcePropertyElt pParseTypeResourcePropertyElt :: Node -> Parser Triples@@ -412,7 +420,7 @@ -- Explore children ts2 <- keepCollectionIndex pPropertyEltList --setSubject s- pure $ maybe (ts1 <> ts2) ((<> ts2) . (:ts1)) mt+ pure $ maybe (ts1 <> ts2) ((<> ts2) . (: ts1)) mt -- See: https://www.w3.org/TR/rdf-syntax-grammar/#parseTypeCollectionPropertyElt pParseTypeCollectionPropertyElt :: Node -> Parser Triples@@ -430,7 +438,7 @@ Nothing -> -- Empty collection let t = Triple s' p rdfNilNode- in ([t] <>) <$> maybe (pure mempty) (`reifyTriple` t) mi+ in ([t] <>) <$> maybe (pure mempty) (`reifyTriple` t) mi Just ts1 -> do -- Non empty collection s'' <- currentSubject@@ -476,22 +484,41 @@ case s of Nothing -> pure mempty Just s' -> do- mi <- optional pIdAttr <* removeNodeAttr rdfID- o <- pResourceAttr' <|> pNodeIdAttr' <|> newBNode+ -- mi <- optional pIdAttr -- <* removeNodeAttr rdfID+ --+ notNodeIdAndResource+ o <- pResourceAttr' <|> pNodeIdAttr' <|> rdfIdAttr' <|> newBNode let t = Triple s' p o -- Reify triple- ts1 <- maybe (pure mempty) (`reifyTriple` t) mi- ts2 <- pPropertyAttrs o- pure (t:ts1 <> ts2)+ ts1 <- -- maybe (pure mempty) (`reifyTriple` t) mi+ do+ x <- optional pIdAttr+ case x of+ Nothing -> mempty+ rdfIdSub -> maybe (pure mempty) (`reifyTriple` t) rdfIdSub+ -- ts2 <- mempty+ --+ -- attrs <- currentNodeAttrs+ --+ ts2 <-+ case o of+ (LNode _) -> mempty+ _ -> pPropertyAttrs o+ --+ pure (t : ts1 <> ts2) where+ -- pure (t : ts1)+ pResourceAttr' = unode <$> pResourceAttr <* removeNodeAttr rdfResource pNodeIdAttr' = BNode <$> pNodeIdAttr <* removeNodeAttr rdfNodeID+ rdfIdAttr' = pure (lnode (plainL "")) <* (void (pIdAttr <* removeNodeAttr rdfID) <|> noNodeAttrs) checkAllowedAttributes :: HashSet Text -> Parser () checkAllowedAttributes as = do attrs <- currentNodeAttrs let diffAttrs = HS.difference (HM.keysSet attrs) as unless (null diffAttrs) (throwError $ "Attributes not allowed: " <> show diffAttrs)+ -- See: https://www.w3.org/TR/rdf11-concepts/#dfn-rdf-xmlliteral, -- https://www.w3.org/TR/rdf-syntax-grammar/#literal pXMLLiteral :: Parser Text@@ -512,6 +539,16 @@ when notUnique (throwError $ "rdf:ID already used in this context: " <> T.unpack i) updateIdSet i +-- Cannot have rdf:nodeID and rdf:resource+notNodeIdAndResource :: Parser ()+notNodeIdAndResource = do+ attrs <- currentNodeAttrs+ guard+ ( (HM.member rdfNodeID attrs && not (HM.member rdfResource attrs))+ || (not (HM.member rdfNodeID attrs) && (HM.member rdfResource attrs))+ || (not (HM.member rdfNodeID attrs) && not (HM.member rdfResource attrs))+ )+ pNodeIdAttr :: Parser Text pNodeIdAttr = do i <- pRDFAttr rdfNodeID@@ -529,10 +566,12 @@ reifyTriple :: Text -> Triple -> Parser Triples reifyTriple i (Triple s p' o) = do n <- mkUNodeID i- pure [ Triple n rdfTypeNode rdfStatementNode- , Triple n rdfSubjectNode s- , Triple n rdfPredicateNode p'- , Triple n rdfObjectNode o ]+ pure+ [ Triple n rdfTypeNode rdfStatementNode,+ Triple n rdfSubjectNode s,+ Triple n rdfPredicateNode p',+ Triple n rdfObjectNode o+ ] -------------------------------------------------------------------------------- -- URI checks@@ -541,40 +580,43 @@ checkIRI msg iri = do bUri <- maybe mempty unBaseUrl <$> currentBaseUri case uriValidate iri of- Nothing -> throwError $ mconcat ["Malformed IRI for \"", msg, "\": ", T.unpack iri]+ Nothing -> throwError $ mconcat ["Malformed IRI for \"", msg, "\": ", T.unpack iri] Just iri' -> either throwError pure (resolveIRI bUri iri') -- https://www.w3.org/TR/rdf-syntax-grammar/#propertyAttributeURIs isPropertyAttrURI :: Text -> Bool-isPropertyAttrURI uri- = isNotCoreSyntaxTerm uri- && uri /= rdfDescription- && uri /= rdfLi- && isNotOldTerm uri+isPropertyAttrURI uri =+ isNotCoreSyntaxTerm uri+ && uri /= rdfDescription+ && uri /= rdfLi+ && isNotOldTerm uri -- https://www.w3.org/TR/rdf-syntax-grammar/#coreSyntaxTerms isNotCoreSyntaxTerm :: Text -> Bool-isNotCoreSyntaxTerm uri- = uri /= rdfTag && uri /= rdfID && uri /= rdfAbout- && uri /= rdfParseType && uri /= rdfResource- && uri /= rdfNodeID && uri /= rdfDatatype+isNotCoreSyntaxTerm uri =+ uri /= rdfTag && uri /= rdfID && uri /= rdfAbout+ && uri /= rdfParseType+ && uri /= rdfResource+ && uri /= rdfNodeID+ && uri /= rdfDatatype -- https://www.w3.org/TR/rdf-syntax-grammar/#oldTerms isNotOldTerm :: Text -> Bool-isNotOldTerm uri = uri /= rdfAboutEach- && uri /= rdfAboutEachPrefix- && uri /= rdfBagID+isNotOldTerm uri =+ uri /= rdfAboutEach+ && uri /= rdfAboutEachPrefix+ && uri /= rdfBagID -------------------------------------------------------------------------------- -- Parser's state utils --- |Create a new unique blank node+-- | Create a new unique blank node newBNode :: Parser Node newBNode = do- modify $ \st -> st { stateGenId = stateGenId st + 1 }+ modify $ \st -> st {stateGenId = stateGenId st + 1} BNodeGen . stateGenId <$> get --- |Process a parser, restoring the state except for stateGenId and stateIdSet+-- | Process a parser, restoring the state except for stateGenId and stateIdSet keepState :: Parser a -> Parser a keepState p = do st <- get@@ -587,8 +629,8 @@ is' = stateIdSet st' -- Update the set of ID if necessary if bUri /= bUri'- then put (st { stateGenId = i })- else put (st { stateGenId = i, stateIdSet = is <> is' })+ then put (st {stateGenId = i})+ else put (st {stateGenId = i, stateIdSet = is <> is'}) currentIdSet :: Parser (Set Text) currentIdSet = stateIdSet <$> get@@ -596,13 +638,18 @@ updateIdSet :: Text -> Parser () updateIdSet i = do is <- currentIdSet- modify (\st -> st { stateIdSet = S.insert i is })+ modify (\st -> st {stateIdSet = S.insert i is}) +noNodeAttrs :: Parser ()+noNodeAttrs = do+ atts <- currentNodeAttrs+ guard (HM.null atts)+ currentNodeAttrs :: Parser (HashMap Text Text) currentNodeAttrs = stateNodeAttrs <$> get setNodeAttrs :: HashMap Text Text -> Parser ()-setNodeAttrs as = modify (\st -> st { stateNodeAttrs = as })+setNodeAttrs as = modify (\st -> st {stateNodeAttrs = as}) removeNodeAttr :: Text -> Parser () removeNodeAttr a = HM.delete a <$> currentNodeAttrs >>= setNodeAttrs@@ -613,14 +660,14 @@ updatePrefixMappings :: PrefixMappings -> Parser PrefixMappings updatePrefixMappings pm = do pm' <- (<> pm) <$> currentPrefixMappings- modify (\st -> st { statePrefixMapping = pm' })+ modify (\st -> st {statePrefixMapping = pm'}) pure pm' currentCollectionIndex :: Parser Int currentCollectionIndex = stateCollectionIndex <$> get setCollectionIndex :: Int -> Parser ()-setCollectionIndex i = modify (\st -> st { stateCollectionIndex = i })+setCollectionIndex i = modify (\st -> st {stateCollectionIndex = i}) keepCollectionIndex :: Parser a -> Parser a keepCollectionIndex p = do@@ -630,33 +677,34 @@ -- See: https://www.w3.org/TR/rdf-syntax-grammar/#section-List-Expand nextCollectionIndex :: Parser Text nextCollectionIndex = do- modify $ \st -> st { stateCollectionIndex = stateCollectionIndex st + 1 }+ modify $ \st -> st {stateCollectionIndex = stateCollectionIndex st + 1} (rdfListIndex <>) . T.pack . show . stateCollectionIndex <$> get resetCollectionIndex :: Parser ()-resetCollectionIndex = modify $ \st -> st { stateCollectionIndex = 0 }+resetCollectionIndex = modify $ \st -> st {stateCollectionIndex = 0} currentBaseUri :: Parser (Maybe BaseUrl) currentBaseUri = stateBaseUri <$> get setBaseUri :: (Maybe BaseUrl) -> Parser ()-setBaseUri u = modify (\st -> st { stateBaseUri = u })+setBaseUri u = modify (\st -> st {stateBaseUri = u}) mkUNodeID :: Text -> Parser Node mkUNodeID t = mkUnode <$> currentBaseUri where- mkUnode = unode . \case- Nothing -> t- Just (BaseUrl u) -> mconcat [u, "#", t]+ mkUnode =+ unode . \case+ Nothing -> t+ Just (BaseUrl u) -> mconcat [u, "#", t] currentSubject :: Parser (Maybe Subject) currentSubject = stateSubject <$> get setSubject :: (Maybe Subject) -> Parser ()-setSubject s = modify (\st -> st { stateSubject = s })+setSubject s = modify (\st -> st {stateSubject = s}) currentLang :: Parser (Maybe Text) currentLang = stateLang <$> get setLang :: (Maybe Text) -> Parser ()-setLang lang = modify (\st -> st { stateLang = lang })+setLang lang = modify (\st -> st {stateLang = lang})
testsuite/tests/W3C/W3CAssertions.hs view
@@ -1,21 +1,22 @@ module W3C.W3CAssertions- ( runManifestTests- , assertIsIsomorphic- , assertIsParsed- , assertIsNotParsed- , nodeURI- ) where+ ( runManifestTests,+ assertIsIsomorphic,+ assertIsParsed,+ assertIsNotParsed,+ nodeURI,+ )+where -import Data.Semigroup ((<>))+import Data.RDF+import Data.Semigroup ((<>)) import qualified Data.Text as T-import Data.RDF import qualified Test.HUnit as TU-import Test.Tasty-import W3C.Manifest+import Test.Tasty+import W3C.Manifest runManifestTests :: (TestEntry -> TestTree) -> Manifest -> TestTree runManifestTests mfEntryToTest manifest =- testGroup (T.unpack $ description manifest) $ mfEntryToTest <$> entries manifest+ testGroup (T.unpack $ description manifest) $ mfEntryToTest <$> entries manifest assertIsIsomorphic :: IO (RDF TList) -> IO (RDF TList) -> IO () assertIsIsomorphic r1 r2 = do@@ -23,21 +24,23 @@ gr2 <- r2 TU.assertBool ("not isomorphic: " <> show gr1 <> " compared with " <> show gr2) (isSame gr1 gr2) -- (isGraphIsomorphic gr1 gr2) where- noBlankNodes g = (all noBlanks . expandTriples) g- noBlanks (Triple s p o) = not (blankNode s)- && not (blankNode p)- && not (blankNode o)- blankNode (BNode _) = True- blankNode (BNodeGen _) = True- blankNode _ = False- isSame g1 g2 =- if (noBlankNodes g1) && (noBlankNodes g2)- -- can compare URIs and literals as well as structure- then isIsomorphic g1 g2- -- cannot compare blank nodes with generated blank nodes,- -- so instead just compare the RDF graph structure of the- -- mf:action parsed RDF with the expected mf:result structure.- else isGraphIsomorphic g1 g2+ -- noBlankNodes g = (all noBlanks . expandTriples) g+ -- noBlanks (Triple s p o) =+ -- not (blankNode s)+ -- && not (blankNode p)+ -- && not (blankNode o)+ -- blankNode (BNode _) = True+ -- blankNode (BNodeGen _) = True+ -- blankNode _ = False+ isSame g1 g2 = isIsomorphic g1 g2++-- if (noBlankNodes g1) && (noBlankNodes g2)+-- -- can compare URIs and literals as well as structure+-- then isIsomorphic g1 g2+-- -- cannot compare blank nodes with generated blank nodes,+-- -- so instead just compare the RDF graph structure of the+-- -- mf:action parsed RDF with the expected mf:result structure.+-- else isGraphIsomorphic g1 g2 assertIsParsed :: IO (Either ParseFailure (RDF TList)) -> TU.Assertion assertIsParsed r1 = do