diff --git a/rdf4h.cabal b/rdf4h.cabal --- a/rdf4h.cabal +++ b/rdf4h.cabal @@ -1,5 +1,5 @@ name: rdf4h -version: 1.3.5 +version: 1.3.6 synopsis: A library for RDF processing in Haskell description: 'RDF for Haskell' is a library for working with RDF in Haskell. diff --git a/src/Data/RDF/MGraph.hs b/src/Data/RDF/MGraph.hs --- a/src/Data/RDF/MGraph.hs +++ b/src/Data/RDF/MGraph.hs @@ -20,6 +20,39 @@ -- |A map-based graph implementation. -- +-- This instance of 'RDF' is an adjacency map with each subject +-- mapping to a mapping from a predicate node to to the adjacent nodes +-- via that predicate. +-- +-- Given the following triples graph:: +-- +-- @ +-- (http:\/\/example.com\/s1,http:\/\/example.com\/p1,http:\/\/example.com\/o1) +-- (http:\/\/example.com\/s1,http:\/\/example.com\/p1,http:\/\/example.com\/o2) +-- (http:\/\/example.com\/s1,http:\/\/example.com\/p2,http:\/\/example.com\/o1) +-- (http:\/\/example.com\/s2,http:\/\/example.com\/p3,http:\/\/example.com\/o3) +-- @ +-- +-- where +-- +-- > hash "http://example.com/s1" = 1600134414 +-- > hash "http://example.com/s2" = 1600134413 +-- > hash "http://example.com/p1" = 1616912099 +-- > hash "http://example.com/p2" = 1616912096 +-- > hash "http://example.com/p3" = 1616912097 +-- > hash "http://example.com/o1" = 1935686794 +-- > hash "http://example.com/o2" = 1935686793 +-- > hash "http://example.com/o3" = 1935686792 +-- +-- the in-memory hashmap representation of the triples graph is: +-- +-- @ +-- key:1600134414, value:(key:1616912099, value:[1935686794 -- (..\/s1,..\/p1,..\/o1) +-- ,1935686793]; -- (..\/s1,..\/p1,..\/o2) +-- key:1616912096, value:[1935686794]); -- (..\/s1,..\/p2,..\/o1) +-- key:1600134413, value:(key:1616912097, value:[1935686792]) -- (..\/s1,..\/p3,..\/o3) +-- @ +-- -- Worst-case time complexity of the graph functions, with respect -- to the number of triples, are: -- diff --git a/src/Data/RDF/PatriciaTreeGraph.hs b/src/Data/RDF/PatriciaTreeGraph.hs --- a/src/Data/RDF/PatriciaTreeGraph.hs +++ b/src/Data/RDF/PatriciaTreeGraph.hs @@ -6,7 +6,6 @@ import Data.RDF.Query import Data.RDF.Types -import Control.DeepSeq (NFData(rnf)) import qualified Data.Graph.Inductive.Graph as G import qualified Data.Graph.Inductive.PatriciaTree as PT import qualified Data.Graph.Inductive.Query.DFS as DFS @@ -18,9 +17,6 @@ newtype PatriciaTreeGraph = PatriciaTreeGraph (PT.Gr Node Node,IntMap.IntMap Node, Maybe BaseUrl, PrefixMappings) deriving (Show) -instance NFData (PT.Gr Node Node) - where rnf x = seq x () - instance RDF PatriciaTreeGraph where baseUrl = baseUrl' prefixMappings = prefixMappings' @@ -269,7 +265,9 @@ ts1 = if thisNode == fromJust maybeObj then mkTriples idxLookup thisNode adjsIn' [] else [] - ts2 = mkTriples idxLookup thisNode [] adjsOut' + ts2 = if thisNode == fromJust maybeSubj + then mkTriples idxLookup thisNode [] adjsOut' + else [] in ts1 ++ ts2 cfun ( _ , _ , _ , _ ) = undefined -- not sure why this pattern is needed to exhaust cfun arg patterns 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 @@ -15,7 +15,7 @@ isUNode,isLNode,isBNode, -- * Miscellaneous - resolveQName, absolutizeUrl, isAbsoluteUri, mkAbsoluteUrl,fileSchemeToFilePath, + resolveQName, absolutizeUrl, isAbsoluteUri, mkAbsoluteUrl,escapeRDFSyntax,fileSchemeToFilePath, -- * RDF Type RDF(baseUrl,prefixMappings,addPrefixMappings,empty,mkRdf,triplesOf,uniqTriplesOf,select,query), @@ -151,44 +151,50 @@ -- |Validate a URI and return it in a @Just UNode@ if it is -- valid, otherwise @Nothing@ is returned. Performs the following: --- +-- -- 1. unescape unicode RDF literals -- 2. checks validity of this unescaped URI using 'isURI' from 'Network.URI' -- 3. if the unescaped URI is valid then 'Node' constructed with 'UNode' unodeValidate :: T.Text -> Maybe Node -unodeValidate t = if Network.isURI uri - then Just (UNode (T.pack uri)) +unodeValidate t = if Network.isURI (T.unpack uri) + then Just (UNode uri) else Nothing where - Right uri = parse unicodeEscParser "" (T.unpack t) + uri = escapeRDFSyntax t + +escapeRDFSyntax :: T.Text -> T.Text +escapeRDFSyntax t = T.pack uri + where + Right uri = parse unicodeEscParser "" (T.unpack t) unicodeEscParser :: Stream s m Char => ParsecT s u m String unicodeEscParser = do - ss <- many ( + ss <- many ( try (do { _ <- char '\\' ; _ <- char 'U' - ; pos1 <- digit - ; pos2 <- digit - ; pos3 <- digit - ; pos4 <- digit - ; pos5 <- digit - ; pos6 <- digit - ; pos7 <- digit - ; pos8 <- digit + ; pos1 <- hexDigit + ; pos2 <- hexDigit + ; pos3 <- hexDigit + ; pos4 <- hexDigit + ; pos5 <- hexDigit + ; pos6 <- hexDigit + ; pos7 <- hexDigit + ; pos8 <- hexDigit ; let str = ['\\','x',pos1,pos2,pos3,pos4,pos5,pos6,pos7,pos8] ; return (read ("\"" ++ str ++ "\"") :: String)}) <|> try (do { _ <- char '\\' ; _ <- char 'u' - ; pos1 <- digit - ; pos2 <- digit - ; pos3 <- digit - ; pos4 <- digit + ; pos1 <- hexDigit + ; pos2 <- hexDigit + ; pos3 <- hexDigit + ; pos4 <- hexDigit ; let str = ['\\','x',pos1,pos2,pos3,pos4] ; return (read ("\"" ++ str ++ "\"") :: String)}) <|> (anyChar >>= \c -> return [c])) - return (concat ss :: String) - + return (concat ss :: String) + + -- |Return a blank node using the given string identifier. {-# INLINE bnode #-} bnode :: T.Text -> Node @@ -368,26 +374,26 @@ writeH :: forall rdf. (RDF rdf) => s -> rdf -> IO () -- |Write some triples to a file handle using whatever configuration is specified - -- by the first argument. - -- - -- WARNING: if the serialization format has header-level information + -- by the first argument. + -- + -- WARNING: if the serialization format has header-level information -- that should be output (e.g., \@prefix declarations for Turtle), then you should -- use 'hWriteG' instead of this method unless you're sure this is safe to use, since - -- otherwise the resultant document will be missing the header information and + -- otherwise the resultant document will be missing the header information and -- will not be valid. hWriteTs :: s -> Handle -> Triples -> IO () -- |Write some triples to stdout; equivalent to @'hWriteTs' stdout@. writeTs :: s -> Triples -> IO () - -- |Write a single triple to the file handle using whatever configuration is + -- |Write a single triple to the file handle using whatever configuration is -- specified by the first argument. The same WARNING applies as to 'hWriteTs'. hWriteT :: s -> Handle -> Triple -> IO () -- |Write a single triple to stdout; equivalent to @'hWriteT' stdout@. writeT :: s -> Triple -> IO () - -- |Write a single node to the file handle using whatever configuration is + -- |Write a single node to the file handle using whatever configuration is -- specified by the first argument. The same WARNING applies as to 'hWriteTs'. hWriteN :: s -> Handle -> Node -> IO () @@ -689,4 +695,3 @@ then fmap (T.pack . Network.uriPath) (Network.parseURI (T.unpack fileScheme)) else Nothing fileSchemeToFilePath _ = Nothing - 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 @@ -8,7 +8,7 @@ import Prelude hiding (init,pred) import Data.RDF.Types import Text.RDF.RDF4H.ParserUtils -import Data.Char(isLetter, isDigit, isLower) +import Data.Char(isLetter, isDigit, isLower,isAlphaNum) import qualified Data.Map as Map import Text.Parsec import Text.Parsec.Text @@ -64,8 +64,8 @@ skipMany1 nt_space obj <- nt_object skipMany nt_space - char '.' - many nt_space + void (char '.') + void (many nt_space) return $ Just (Triple subj pred obj) -- A literal is either a language literal (with optional language @@ -76,11 +76,11 @@ -- the closing quote with ^^ followed by the URI of the datatype. nt_literal :: GenParser () LValue nt_literal = - do lit_str <- between_chars '"' '"' inner_literal + do lit_str <- between (char '"') (char '"') inner_literal liftM (plainLL lit_str) (char '@' >> nt_language) <|> liftM (typedL lit_str) (count 2 (char '^') >> nt_uriref) <|> return (plainL lit_str) - where inner_literal = liftM T.concat (manyTill inner_string (lookAhead $ char '"')) + where inner_literal = inner_string -- A language specifier of a language literal is any number of lowercase -- letters followed by any number of blocks consisting of a hyphen followed @@ -118,7 +118,7 @@ -- A URI reference is one or more nrab_character inside angle brackets. nt_uriref :: GenParser () T.Text -nt_uriref = between_chars '<' '>' (liftM T.pack (many (satisfy ( /= '>')))) +nt_uriref = between (char '<') (char '>') (liftM T.pack (many (satisfy ( /= '>')))) -- A node id is "_:" followed by a name. nt_nodeID :: GenParser () T.Text @@ -141,7 +141,7 @@ -- A character is any Unicode value from ASCII space to decimal 126 (tilde). is_character :: Char -> Bool -is_character c = c >= '\x0020' && c <= '\x007E' +is_character = isAlphaNum -- A non-quote character is a character that isn't the double-quote character. is_nonquote_char :: Char -> Bool @@ -194,9 +194,6 @@ b_nl = T.singleton '\n' b_slash = T.singleton '\\' b_quote = T.singleton '"' - -between_chars :: Char -> Char -> GenParser () T.Text -> GenParser () T.Text -between_chars start end parser = char start >> parser >>= \res -> char end >> return res parseString' :: forall rdf. (RDF rdf) => T.Text -> Either ParseFailure rdf parseString' bs = handleParse mkRdf (runParser nt_ntripleDoc () "" bs) 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,4 +1,4 @@ --- |An 'RdfParser' implementation for the Turtle format +-- |An 'RdfParser' implementation for the Turtle format -- . module Text.RDF.RDF4H.TurtleParser( @@ -22,9 +22,8 @@ import qualified Data.Foldable as F import Data.Char (isDigit) import Control.Monad -import Data.Maybe (fromMaybe) --- |An 'RdfParser' implementation for parsing RDF in the +-- |An 'RdfParser' implementation for parsing RDF in the -- Turtle format. It is an implementation of W3C Turtle grammar rules at -- http://www.w3.org/TR/turtle/#sec-grammar-grammar . -- It takes optional arguments representing the base URL to use @@ -38,7 +37,7 @@ -- |'TurtleParser' is an instance of 'RdfParser'. instance RdfParser TurtleParser where - parseString (TurtleParser bUrl dUrl) = parseString' bUrl dUrl + parseString (TurtleParser bUrl dUrl) = parseString' bUrl dUrl parseFile (TurtleParser bUrl dUrl) = parseFile' bUrl dUrl parseURL (TurtleParser bUrl dUrl) = parseURL' bUrl dUrl @@ -90,12 +89,12 @@ -- grammar rule: [4] prefixID t_prefixID :: GenParser ParseState () t_prefixID = - do try (string "@prefix" "@prefix-directive") + do void (try (string "@prefix" "@prefix-directive")) pre <- (many1 t_ws "whitespace-after-@prefix") >> option T.empty t_pn_prefix - char ':' >> (many1 t_ws "whitespace-after-@prefix-colon") + void (char ':' >> (many1 t_ws "whitespace-after-@prefix-colon")) uriFrag <- t_iriref - (many t_ws "prefixID-whitespace") - (char '.' "end-of-prefixID-period") + void (many t_ws "prefixID-whitespace") + void (char '.' "end-of-prefixID-period") (bUrl, dUrl, _, PrefixMappings pms, _, _, _, _) <- getState updatePMs $ Just (PrefixMappings $ Map.insert pre (absolutizeUrl bUrl dUrl uriFrag) pms) return () @@ -103,9 +102,9 @@ -- grammar rule: [6s] sparqlPrefix t_sparql_prefix :: GenParser ParseState () t_sparql_prefix = - do try (caseInsensitiveString "PREFIX" "@prefix-directive") + do void (try (caseInsensitiveString "PREFIX" "@prefix-directive")) pre <- (many1 t_ws "whitespace-after-@prefix") >> option T.empty t_pn_prefix - char ':' >> (many1 t_ws "whitespace-after-@prefix-colon") + void (char ':' >> (many1 t_ws "whitespace-after-@prefix-colon")) uriFrag <- t_iriref (bUrl, dUrl, _, PrefixMappings pms, _, _, _, _) <- getState updatePMs $ Just (PrefixMappings $ Map.insert pre (absolutizeUrl bUrl dUrl uriFrag) pms) @@ -114,11 +113,11 @@ -- grammar rule: [5] base t_base :: GenParser ParseState () t_base = - do try (string "@base" "@base-directive") - many1 t_ws "whitespace-after-@base" + do void (try (string "@base" "@base-directive")) + void (many1 t_ws "whitespace-after-@base") urlFrag <- t_iriref - (many t_ws "base-whitespace") - (char '.' "end-of-base-period") + void (many t_ws "base-whitespace") + (void (char '.') "end-of-base-period") bUrl <- currBaseUrl dUrl <- currDocUrl updateBaseUrl (Just $ Just $ newBaseUrl bUrl (absolutizeUrl bUrl dUrl urlFrag)) @@ -126,8 +125,8 @@ -- grammar rule: [5s] sparqlBase t_sparql_base :: GenParser ParseState () t_sparql_base = - do try (caseInsensitiveString "BASE" "@sparql-base-directive") - many1 t_ws "whitespace-after-BASE" + do void (try (caseInsensitiveString "BASE" "@sparql-base-directive")) + void (many1 t_ws "whitespace-after-BASE") urlFrag <- t_iriref bUrl <- currBaseUrl dUrl <- currDocUrl @@ -139,16 +138,21 @@ -- grammar rule: [11] predicate t_predicate :: GenParser ParseState Node t_predicate = liftM UNode (t_iri "resource") +-- res <- t_iri "resource" +-- validateUNode res t_nodeID :: GenParser ParseState T.Text -t_nodeID = do { try (string "_:"); cs <- t_name; return $! "_:" `T.append` cs } +t_nodeID = do { void (try (string "_:")); cs <- t_name; return $! "_:" `T.append` cs } -- grammar rules: [139s] PNAME_NS t_pname_ns :: GenParser ParseState T.Text t_pname_ns =do pre <- option T.empty (try t_pn_prefix) - char ':' - return pre + void (char ':') + (bUrl, _, _, pms, _, _, _, _) <- getState + case resolveQName bUrl pre pms of + Just n -> return n + Nothing -> unexpected ("Cannot resolve QName prefix: " ++ T.unpack pre) -- grammar rules: [168s] PN_LOCAL t_pn_local :: GenParser ParseState T.Text @@ -165,6 +169,7 @@ -- PERCENT | PN_LOCAL_ESC -- grammar rules: [169s] PLX +t_plx :: GenParser ParseState String t_plx = t_percent <|> t_pn_local_esc_str where t_pn_local_esc_str = do @@ -173,13 +178,15 @@ -- '%' HEX HEX -- grammar rules: [170s] PERCENT +t_percent :: GenParser ParseState String t_percent = do - char '%' + void (char '%') h1 <- t_hex h2 <- t_hex - return ([h1,h2]) + return (['%',h1,h2]) -- grammar rules: [172s] PN_LOCAL_ESC +t_pn_local_esc :: GenParser ParseState Char t_pn_local_esc = char '\\' >> oneOf "_~.-!$&'()*+,;=/?#@%" -- grammar rules: [140s] PNAME_LN @@ -187,10 +194,7 @@ t_pname_ln = do pre <- t_pname_ns name <- t_pn_local - (bUrl, _, _, pms, _, _, _, _) <- getState - case resolveQName bUrl pre pms of - Just n -> return $ n `T.append` name - Nothing -> unexpected ("Cannot resolve QName prefix: " ++ T.unpack pre) + return (pre `T.append` name) -- grammar rule: [10] subject t_subject :: GenParser ParseState () @@ -207,15 +211,15 @@ (nextIdCounter >>= pushSubj . BNodeGen >> many t_ws >> t_predicateObjectList >> many t_ws) - + -- verb objectList (';' (verb objectList)?)* -- -- verb ws+ objectList ( ws* ';' ws* verb ws+ objectList )* (ws* ';')? -- grammar rule: [7] predicateObjectlist t_predicateObjectList :: GenParser ParseState () t_predicateObjectList = - do sepEndBy1 (try (t_verb >> many1 t_ws >> t_objectList >> popPred)) (try (many t_ws >> char ';' >> optional (char ';') >> many t_ws)) - return () + do void (sepEndBy1 (try (t_verb >> many1 t_ws >> t_objectList >> popPred)) (try (many t_ws >> char ';' >> optional (char ';') >> many t_ws))) +-- return () -- grammar rule: [8] objectlist t_objectList :: GenParser ParseState () @@ -244,13 +248,13 @@ -- itemList: object (ws+ object)* -- grammar rule: [15] collection t_collection:: GenParser ParseState () -t_collection = +t_collection = -- ( object1 object2 ) is short for: -- [ rdf:first object1; rdf:rest [ rdf:first object2; rdf:rest rdf:nil ] ] -- ( ) is short for the resource: rdf:nil between (char '(') (char ')') $ do beginColl - many t_ws + void (many t_ws) emptyColl <- option True (try t_object >> many t_ws >> return False) if emptyColl then void (addTripleForObject rdfNilNode) else void @@ -258,7 +262,7 @@ pushPred rdfRestNode >> addTripleForObject rdfNilNode >> popPred >> popSubj) - finishColl + void finishColl return () blank_as_obj :: GenParser ParseState () @@ -271,7 +275,7 @@ poList where genBlank = liftM BNodeGen (try (string "[]") >> nextIdCounter) - poList = between (char '[') (char ']') $ + poList = between (char '[') (char ']') $ liftM BNodeGen nextIdCounter >>= \bSubj -> -- generate new bnode void (addTripleForObject bSubj >> -- add triple with bnode as object @@ -304,7 +308,8 @@ str_literal :: GenParser ParseState Node str_literal = - do str <- t_quotedString "quotedString" + do str' <- t_quotedString "quotedString" + let str = escapeRDFSyntax str' liftM (LNode . typedL str) (try (count 2 (char '^')) >> t_iri) <|> liftM (lnode . plainLL str) (char '@' >> t_language) <|> @@ -319,13 +324,13 @@ t_longString :: GenParser ParseState T.Text t_longString = - try ( do { tripleQuoteDbl; + try ( do { void tripleQuoteDbl; strVal <- liftM T.concat (many longString_char); - tripleQuoteDbl; + void tripleQuoteDbl; return strVal }) <|> - try ( do { tripleQuoteSingle; + try ( do { void tripleQuoteSingle; strVal <- liftM T.concat (many longString_char); - tripleQuoteSingle; + void tripleQuoteSingle; return strVal }) where tripleQuoteDbl = count 3 (char '"') @@ -344,11 +349,11 @@ t_double = do sign <- sign_parser "+-" rest <- try (do { ds <- many1 digit "digit"; - char '.'; + void (char '.'); ds' <- many digit "digit"; e <- t_exponent "exponent"; return ( T.pack ds `T.snoc` '.' `T.append` T.pack ds' `T.append` e) }) <|> - try (do { char '.'; + try (do { void (char '.'); ds <- many1 digit "digit"; e <- t_exponent "exponent"; return ('.' `T.cons` T.pack ds `T.append` e) }) <|> @@ -363,8 +368,8 @@ t_decimal :: GenParser ParseState T.Text t_decimal = do sign <- sign_parser - rest <- try (do ds <- many digit "digit"; char '.'; ds' <- option "" (many digit); return (ds ++ ('.':ds'))) - <|> try (do { char '.'; ds <- many1 digit "digit"; return ('.':ds) }) + rest <- try (do ds <- many digit "digit"; void (char '.'); ds' <- option "" (many digit); return (ds ++ ('.':ds'))) + <|> try (do { void (char '.'); ds <- many1 digit "digit"; return ('.':ds) }) <|> many1 digit "digit" return $ T.pack sign `T.append` T.pack rest @@ -393,7 +398,7 @@ t_language :: GenParser ParseState T.Text t_language = do initial <- many1 lower; - rest <- many (do {char '-'; cs <- many1 (lower <|> digit); return ( T.pack ('-':cs))}) + rest <- many (do {void (char '-'); cs <- many1 (lower <|> digit); return ( T.pack ('-':cs))}) return $! ( T.pack initial `T.append` T.concat rest) identifier :: GenParser ParseState Char -> GenParser ParseState Char -> GenParser ParseState T.Text @@ -417,9 +422,8 @@ do frag <- liftM (T.pack . concat) (many t_ucharacter) bUrl <- currBaseUrl dUrl <- currDocUrl - case unodeValidate (absolutizeUrl bUrl dUrl frag) of - Nothing -> unexpected ("Invalid URI in Turtle parser: " ++ show (absolutizeUrl bUrl dUrl frag)) - Just (UNode t) -> return t + let frag' = escapeRDFSyntax frag + validateURI (absolutizeUrl bUrl dUrl frag') -- We make this String rather than T.Text because we want -- t_relativeURI (the only place it's used) to have chars so that @@ -446,7 +450,7 @@ where specialChar = oneOf "\t\n\r" >>= bs1 escapedChar = - do char '\\' + do void (char '\\') (char 't' >> bs1 '\t') <|> (char 'n' >> bs1 '\n') <|> (char 'r' >> bs1 '\r') <|> (char '\\' >> bs1 '\\') <|> (char '"' >> bs1 '"') twoDoubleQuote = string "\"\"" >> notFollowedBy (char '"') >> bs "\"\"" @@ -485,7 +489,7 @@ t_scharacter_in_dquot = (try (string "\\\"") >> return (T.singleton '"')) <|> (try (string "\\'") >> return (T.singleton '\'')) - <|> try (do {char '\\'; + <|> try (do {void (char '\\'); (char 't' >> return (T.singleton '\t')) <|> (char 'n' >> return (T.singleton '\n')) <|> (char 'r' >> return (T.singleton '\r'))}) -- echaracter part 1 @@ -498,7 +502,7 @@ t_scharacter_in_squot = (try (string "\\'") >> return (T.singleton '\'')) <|> (try (string "\\\"") >> return (T.singleton '"')) - <|> try (do {char '\\'; + <|> try (do {void (char '\\'); (char 't' >> return (T.singleton '\t')) <|> (char 'n' >> return (T.singleton '\n')) <|> (char 'r' >> return (T.singleton '\r'))}) -- echaracter part 1 @@ -627,19 +631,19 @@ -- -- The @BaseUrl@ is used as the base URI within the document for resolving any relative URI references. -- It may be changed within the document using the @\@base@ directive. At any given point, the current --- base URI is the most recent @\@base@ directive, or if none, the @BaseUrl@ given to @parseURL@, or +-- base URI is the most recent @\@base@ directive, or if none, the @BaseUrl@ given to @parseURL@, or -- if none given, the document URL given to @parseURL@. For example, if the @BaseUrl@ were --- @http:\/\/example.org\/@ and a relative URI of @\@ were encountered (with no preceding @\@base@ +-- @http:\/\/example.org\/@ and a relative URI of @\@ were encountered (with no preceding @\@base@ -- directive), then the relative URI would expand to @http:\/\/example.org\/b@. -- -- The document URL is for the purpose of resolving references to 'this document' within the document, -- and may be different than the actual location URL from which the document is retrieved. Any reference --- to @\<>@ within the document is expanded to the value given here. Additionally, if no @BaseUrl@ is +-- to @\<>@ within the document is expanded to the value given here. Additionally, if no @BaseUrl@ is -- given and no @\@base@ directive has appeared before a relative URI occurs, this value is used as the -- base URI against which the relative URI is resolved. -- -- Returns either a @ParseFailure@ or a new RDF containing the parsed triples. -parseURL' :: forall rdf. (RDF rdf) => +parseURL' :: forall rdf. (RDF rdf) => Maybe BaseUrl -- ^ The optional base URI of the document. -> Maybe T.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 Turtle document. @@ -658,7 +662,7 @@ TIO.readFile fpath >>= \bs' -> return $ handleResult bUrl (runParser t_turtleDoc initialState (maybe "" T.unpack docUrl) bs') where initialState = (bUrl, docUrl, 1, PrefixMappings Map.empty, [], [], [], Seq.empty) --- |Parse the given string as a Turtle document. The arguments and return type have the same semantics +-- |Parse the given string as a Turtle document. The arguments and return type have the same semantics -- as , except that the last @String@ argument corresponds to the Turtle document itself as -- a string rather than a location URI. parseString' :: forall rdf. (RDF rdf) => Maybe BaseUrl -> Maybe T.Text -> T.Text -> Either ParseFailure rdf @@ -670,6 +674,18 @@ case result of (Left err) -> Left (ParseFailure $ show err) (Right (ts, pms)) -> Right $! mkRdf (F.toList ts) bUrl pms + +validateUNode :: T.Text -> GenParser ParseState Node +validateUNode t = + case unodeValidate t of + Nothing -> unexpected ("Invalid URI in Turtle parser URI validation: " ++ show t) + Just u@(UNode{}) -> return u + Just node -> unexpected ("Unexpected node in Turtle parser URI validation: " ++ show node) + +validateURI :: T.Text -> GenParser ParseState T.Text +validateURI t = do + UNode uri <- validateUNode t + return uri -------------- -- auxiliary parsing functions diff --git a/src/Text/RDF/RDF4H/TurtleSerializer.hs b/src/Text/RDF/RDF4H/TurtleSerializer.hs --- a/src/Text/RDF/RDF4H/TurtleSerializer.hs +++ b/src/Text/RDF/RDF4H/TurtleSerializer.hs @@ -156,7 +156,7 @@ writeLiteralString:: Handle -> T.Text -> IO () writeLiteralString h bs = do hPutChar h '"' - T.foldl' writeChar (return True) bs + void (T.foldl' writeChar (return True) bs) hPutChar h '"' where writeChar :: IO Bool -> Char -> IO Bool 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,4 @@ -{-# Language Arrows,OverloadedStrings,DoAndIfThenElse #-} +{-# Language Arrows,OverloadedStrings,DoAndIfThenElse,DeriveDataTypeable #-} -- |An parser for the RDF/XML format -- . @@ -18,8 +18,7 @@ import Data.RDF.Types (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 qualified Data.Text.IO as TIO -import Text.XML.HXT.Core (ArrowXml,ArrowIf,ArrowChoice,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,fatal,canonicalizeAllNodes) - +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) @@ -135,7 +134,7 @@ <+> (second (getChildren >>> isElem) >>> parsePredicatesFromChildren) <+> (second (neg (hasName "rdf:Description") >>> neg (hasName "Description")) >>> arr2A readTypeTriple)) >>. replaceLiElems [] (1 :: Int) - where readTypeTriple :: forall a. (ArrowXml a, ArrowState GParseState a) => LParseState -> a XmlTree Triple + where readTypeTriple :: (ArrowXml a, ArrowState GParseState a) => LParseState -> a XmlTree Triple readTypeTriple state = getName >>> arr (Triple (stateSubject state) rdfType . unode . T.pack) replaceLiElems acc n (Triple s p o : rest) | p == (unode . T.pack) "rdf:li" = replaceLiElems (Triple s ((unode . T.pack) ("rdf:_" ++ show n)) o : acc) (n + 1) rest diff --git a/testsuite/tests/Data/RDF/GraphTestUtils.hs b/testsuite/tests/Data/RDF/GraphTestUtils.hs --- a/testsuite/tests/Data/RDF/GraphTestUtils.hs +++ b/testsuite/tests/Data/RDF/GraphTestUtils.hs @@ -43,7 +43,7 @@ , testProperty "query_match_sp" (p_query_match_sp _triplesOf) , testProperty "query_match_so" (p_query_match_so _triplesOf) , testProperty "query_match_po" (p_query_match_po _triplesOf) - , testProperty "select_match_none" (p_select_match_none _triplesOf) + , testProperty "select_match_none" (p_select_match_none _triplesOf) , testProperty "select_match_s" (p_select_match_s _triplesOf) , testProperty "select_match_p" (p_select_match_p _triplesOf) , testProperty "select_match_o" (p_select_match_o _triplesOf) @@ -57,13 +57,14 @@ instance Arbitrary BaseUrl where - arbitrary = oneof $ map (return . BaseUrl . T.pack) ["http://example.com/a", "http://asdf.org/b"] + arbitrary = oneof $ map (return . BaseUrl . T.pack) ["http://example.com/a","http://asdf.org/b","http://asdf.org/c"] --coarbitrary = undefined instance Arbitrary PrefixMappings where arbitrary = oneof [return $ PrefixMappings Map.empty, return $ PrefixMappings $ Map.fromAscList [(T.pack "eg1", T.pack "http://example.com/1"), - (T.pack "eg2", T.pack "http://example.com/2")]] + (T.pack "eg2", T.pack "http://example.com/2"), + (T.pack "eg3", T.pack "http://example.com/3")]] --coarbitrary = undefined -- Test stubs, which just require the appropriate RDF impl function diff --git a/testsuite/tests/Test.hs b/testsuite/tests/Test.hs --- a/testsuite/tests/Test.hs +++ b/testsuite/tests/Test.hs @@ -36,5 +36,5 @@ ++ XmlParser.tests ++ W3CTurtleTest.tests ++ W3CRdfXmlTest.tests - -- ++ W3CNTripleTest.tests -- contains infinite loop + ++ W3CNTripleTest.tests )