rdf4h 3.0.1 → 3.0.2
raw patch · 17 files changed
+1420/−1285 lines, 17 filesdep +attoparsecdep +mtldep +parsersdep ~basePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: attoparsec, mtl, parsers
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Text.RDF.RDF4H.NTriplesParser: NTriplesParserCustom :: Parser -> NTriplesParserCustom
+ Text.RDF.RDF4H.NTriplesParser: data NTriplesParserCustom
+ Text.RDF.RDF4H.NTriplesParser: instance Data.RDF.Types.RdfParser Text.RDF.RDF4H.NTriplesParser.NTriplesParserCustom
+ Text.RDF.RDF4H.ParserUtils: Attoparsec :: Parser
+ Text.RDF.RDF4H.ParserUtils: Parsec :: Parser
+ Text.RDF.RDF4H.ParserUtils: _parseURL :: (Text -> Either ParseFailure (RDF rdfImpl)) -> String -> IO (Either ParseFailure (RDF rdfImpl))
+ Text.RDF.RDF4H.ParserUtils: data Parser
+ Text.RDF.RDF4H.ParserUtils: justTriples :: [Maybe Triple] -> [Triple]
+ Text.RDF.RDF4H.TurtleParser: TurtleParserCustom :: (Maybe BaseUrl) -> (Maybe Text) -> Parser -> TurtleParserCustom
+ Text.RDF.RDF4H.TurtleParser: data TurtleParserCustom
+ Text.RDF.RDF4H.TurtleParser: instance Data.RDF.Types.RdfParser Text.RDF.RDF4H.TurtleParser.TurtleParserCustom
- Data.RDF: hWriteH :: (RdfSerializer s, Rdf a) => s -> Handle -> RDF a -> IO ()
+ Data.RDF: hWriteH :: (RdfSerializer s, (Rdf a)) => s -> Handle -> RDF a -> IO ()
- Data.RDF: hWriteRdf :: (RdfSerializer s, Rdf a) => s -> Handle -> RDF a -> IO ()
+ Data.RDF: hWriteRdf :: (RdfSerializer s, (Rdf a)) => s -> Handle -> RDF a -> IO ()
- Data.RDF: parseFile :: (RdfParser p, Rdf a) => p -> String -> IO (Either ParseFailure (RDF a))
+ Data.RDF: parseFile :: (RdfParser p, (Rdf a)) => p -> String -> IO (Either ParseFailure (RDF a))
- Data.RDF: parseString :: (RdfParser p, Rdf a) => p -> Text -> Either ParseFailure (RDF a)
+ Data.RDF: parseString :: (RdfParser p, (Rdf a)) => p -> Text -> Either ParseFailure (RDF a)
- Data.RDF: parseURL :: (RdfParser p, Rdf a) => p -> String -> IO (Either ParseFailure (RDF a))
+ Data.RDF: parseURL :: (RdfParser p, (Rdf a)) => p -> String -> IO (Either ParseFailure (RDF a))
- Data.RDF: writeH :: (RdfSerializer s, Rdf a) => s -> RDF a -> IO ()
+ Data.RDF: writeH :: (RdfSerializer s, (Rdf a)) => s -> RDF a -> IO ()
- Data.RDF: writeRdf :: (RdfSerializer s, Rdf a) => s -> RDF a -> IO ()
+ Data.RDF: writeRdf :: (RdfSerializer s, (Rdf a)) => s -> RDF a -> IO ()
- Data.RDF.Types: hWriteH :: (RdfSerializer s, Rdf a) => s -> Handle -> RDF a -> IO ()
+ Data.RDF.Types: hWriteH :: (RdfSerializer s, (Rdf a)) => s -> Handle -> RDF a -> IO ()
- Data.RDF.Types: hWriteRdf :: (RdfSerializer s, Rdf a) => s -> Handle -> RDF a -> IO ()
+ Data.RDF.Types: hWriteRdf :: (RdfSerializer s, (Rdf a)) => s -> Handle -> RDF a -> IO ()
- Data.RDF.Types: parseFile :: (RdfParser p, Rdf a) => p -> String -> IO (Either ParseFailure (RDF a))
+ Data.RDF.Types: parseFile :: (RdfParser p, (Rdf a)) => p -> String -> IO (Either ParseFailure (RDF a))
- Data.RDF.Types: parseString :: (RdfParser p, Rdf a) => p -> Text -> Either ParseFailure (RDF a)
+ Data.RDF.Types: parseString :: (RdfParser p, (Rdf a)) => p -> Text -> Either ParseFailure (RDF a)
- Data.RDF.Types: parseURL :: (RdfParser p, Rdf a) => p -> String -> IO (Either ParseFailure (RDF a))
+ Data.RDF.Types: parseURL :: (RdfParser p, (Rdf a)) => p -> String -> IO (Either ParseFailure (RDF a))
- Data.RDF.Types: writeH :: (RdfSerializer s, Rdf a) => s -> RDF a -> IO ()
+ Data.RDF.Types: writeH :: (RdfSerializer s, (Rdf a)) => s -> RDF a -> IO ()
- Data.RDF.Types: writeRdf :: (RdfSerializer s, Rdf a) => s -> RDF a -> IO ()
+ Data.RDF.Types: writeRdf :: (RdfSerializer s, (Rdf a)) => s -> RDF a -> IO ()
Files
- bench/MainCriterion.hs +62/−16
- examples/ParseURLs.hs +1/−1
- rdf4h.cabal +13/−21
- src/Data/RDF/Types.hs +35/−56
- src/Text/RDF/RDF4H/Interact.hs +1/−1
- src/Text/RDF/RDF4H/NTriplesParser.hs +145/−131
- src/Text/RDF/RDF4H/ParserUtils.hs +4/−1
- src/Text/RDF/RDF4H/TurtleParser.hs +366/−314
- src/Text/RDF/RDF4H/XmlParser.hs +16/−16
- testsuite/tests/Data/RDF/Graph/AdjHashMap_Test.hs +0/−33
- testsuite/tests/Data/RDF/Graph/TList_Test.hs +0/−33
- testsuite/tests/Data/RDF/GraphTestUtils.hs +0/−561
- testsuite/tests/Data/RDF/PropertyTests.hs +631/−0
- testsuite/tests/Test.hs +80/−72
- testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs +26/−7
- testsuite/tests/W3C/NTripleTest.hs +16/−8
- testsuite/tests/W3C/TurtleTest.hs +24/−14
bench/MainCriterion.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, LambdaCase, RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-} module Main where @@ -6,7 +7,9 @@ import Criterion.Types import Criterion.Main import Data.RDF+import Text.RDF.RDF4H.ParserUtils import qualified Data.Text as T+import Control.DeepSeq (NFData) -- The `bills.102.rdf` XML file is needed to run this benchmark suite --@@ -42,12 +45,14 @@ defaultMainWith (defaultConfig {resamples = 100}) [ env- -- fawltyContent <- T.pack <$> readFile "data/ttl/fawlty1.ttl" (do rdfContent <- T.pack <$> readFile "bills.099.actions.rdf"+ fawltyContentTurtle <- T.pack <$> readFile "data/ttl/fawlty1.ttl"+ fawltyContentNTriples <- T.pack <$> readFile "data/nt/all-fawlty-towers.nt" let (Right rdf1) = parseString (XmlParser Nothing Nothing) rdfContent let (Right rdf2) = parseString (XmlParser Nothing Nothing) rdfContent+ triples = triplesOf rdf1 -- let (Right rdf3) = -- parseString (XmlParser Nothing Nothing) rdfContent -- let (Right rdf4) =@@ -55,21 +60,45 @@ return ( rdf1 :: RDF TList , rdf2 :: RDF AdjHashMap- )) $ \ ~(triplesList, adjMap) ->+ , triples :: Triples+ , fawltyContentNTriples :: T.Text+ , fawltyContentTurtle :: T.Text+ )) $ \ ~(triplesList, adjMap, triples, fawltyContentNTriples, fawltyContentTurtle) -> bgroup "rdf4h"- -- bgroup- -- "parsers"- -- [ bench "AdjHashMap" $- -- nf (parseTtlRDF :: T.Text -> RDF AdjHashMap) fawlty_towers- -- , bench "HashSP" $- -- nf (parseTtlRDF :: T.Text -> RDF HashSP) fawlty_towers- -- , bench "SP" $ nf (parseTtlRDF :: T.Text -> RDF SP) fawlty_towers- -- , bench "TList" $- -- nf (parseTtlRDF :: T.Text -> RDF TList) fawlty_towers- -- ]- -- ,- [ bgroup+ [ bgroup+ "parsers"+ [ bench "ntriples-parsec" $+ nf (\t ->+ let res = parseString (NTriplesParserCustom Parsec) t :: Either ParseFailure (RDF TList)+ in case res of+ Left e -> error (show e)+ Right rdfG -> rdfG+ ) fawltyContentNTriples+ , bench "ntriples-attoparsec" $+ nf (\t ->+ let res = parseString (NTriplesParserCustom Attoparsec) t :: Either ParseFailure (RDF TList)+ in case res of+ Left e -> error (show e)+ Right rdfG -> rdfG+ ) fawltyContentNTriples+ , bench "turtle-parsec" $+ nf (\t ->+ let res = parseString (TurtleParserCustom Nothing Nothing Parsec) t :: Either ParseFailure (RDF TList)+ in case res of+ Left e -> error (show e)+ Right rdfG -> rdfG+ ) fawltyContentTurtle+ , bench "turtle-attoparsec" $+ nf (\t ->+ let res = parseString (TurtleParserCustom Nothing Nothing Attoparsec) t :: Either ParseFailure (RDF TList)+ in case res of+ Left e -> error (show e)+ Right rdfG -> rdfG+ ) fawltyContentTurtle+ ]+ ,+ bgroup "query" (queryBench "TList" triplesList ++ queryBench "AdjHashMap" adjMap@@ -82,6 +111,11 @@ -- selectBench "SP" mapSP ++ selectBench "HashSP" hashMapSP ) , bgroup+ "add-remove-triples"+ (addRemoveTriples "TList" triples (empty :: RDF TList) triplesList+ ++ addRemoveTriples "AdjHashMap" triples (empty :: RDF AdjHashMap) adjMap+ )+ , bgroup "count_triples" [ bench "TList" (nf (length . triplesOf) triplesList) , bench "AdjHashMap" (nf (length . triplesOf) adjMap)@@ -89,8 +123,6 @@ ] ] - - selectBench :: Rdf a => String -> RDF a -> [Benchmark] selectBench label gr = [ bench (label ++ " SPO") $ nf selectGr (subjSelect,predSelect,objSelect,gr)@@ -124,3 +156,17 @@ , bench (label ++ " P") $ nf queryGr (queryNothing,predQuery,queryNothing,gr) , bench (label ++ " O") $ nf queryGr (queryNothing,queryNothing,objQuery,gr) ]++addRemoveTriples :: (NFData a,NFData (RDF a), Rdf a) => String -> Triples -> RDF a -> RDF a -> [Benchmark]+addRemoveTriples lbl triples emptyGr populatedGr =+ [ bench (lbl ++ "-add-triples") $ nf addTriples (triples,emptyGr)+ , bench (lbl ++ "-remove-triples") $ nf removeTriples (triples,populatedGr)+ ]++addTriples :: Rdf a => (Triples,RDF a) -> RDF a+addTriples (triples,emptyGr) =+ foldr (\t g -> addTriple g t) emptyGr triples++removeTriples :: Rdf a => (Triples,RDF a) -> RDF a+removeTriples (triples,populatedGr) =+ foldr (\t g -> removeTriple g t) populatedGr triples
examples/ParseURLs.hs view
@@ -9,7 +9,7 @@ -- returns a single String element: [\"Designing the Web for an Open Society\"]. timBernersLee :: IO () timBernersLee = do- Right (rdf::TriplesList) <- parseURL (XmlParser Nothing Nothing) "http://www.w3.org/People/Berners-Lee/card.rdf"+ Right (rdf::RDF TList) <- parseURL (XmlParser Nothing Nothing) "http://www.w3.org/People/Berners-Lee/card.rdf" let ts = query rdf (Just (UNode "http://www.w3.org/2011/Talks/0331-hyderabad-tbl/data#talk")) (Just (UNode "dct:title")) Nothing let talks = map (\(Triple _ _ (LNode (PlainL s))) -> s) ts print talks
rdf4h.cabal view
@@ -1,5 +1,5 @@ name: rdf4h-version: 3.0.1+version: 3.0.2 synopsis: A library for RDF processing in Haskell description: 'RDF for Haskell' is a library for working with RDF in Haskell.@@ -10,7 +10,7 @@ author: Calvin Smith, Rob Stewart, Slava Kravchenko copyright: (c) Calvin Smith, Rob Stewart, Slava Kravchenko-maintainer: Rob Stewart <robstewart@gmail.com>, Slava Kravchenko+maintainer: Rob Stewart <robstewart@gmail.com> homepage: https://github.com/robstewart57/rdf4h bug-reports: https://github.com/robstewart57/rdf4h/issues license: BSD3@@ -34,24 +34,19 @@ , Data.RDF.Types , Data.RDF.Query , Data.RDF.Graph.AdjHashMap- -- , Data.RDF.Graph.HashMapSP- -- , Data.RDF.Graph.MapSP- -- this is very slow- -- , Data.RDF.Graph.TPatriciaTree , Data.RDF.Graph.TList , Text.RDF.RDF4H.TurtleParser , Text.RDF.RDF4H.TurtleSerializer , Text.RDF.RDF4H.NTriplesParser , Text.RDF.RDF4H.NTriplesSerializer , Text.RDF.RDF4H.XmlParser- build-depends: base >= 3+ , Text.RDF.RDF4H.ParserUtils+ build-depends: attoparsec >= 0.13.1.0+ , base >= 4.8.0.0 , bytestring , directory , containers , parsec >= 3- -- was needed for the patricia tree RDF implementation,- -- which was too slow.- -- , fgl >= 5.5.2.0 , HTTP >= 4000.0.0 , hxt >= 9.3.1.2 , text >= 1.2.1.0@@ -62,6 +57,8 @@ , text-binary , utf8-string , hgal+ , parsers+ , mtl if impl(ghc < 7.6) build-depends: ghc-prim @@ -70,15 +67,14 @@ else build-depends: network-uri < 2.6, network < 2.6 - other-modules: Text.RDF.RDF4H.ParserUtils- , Text.RDF.RDF4H.Interact+ 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 main-is: src/Rdf4hParseMain.hs- build-depends: base >= 4 && < 6+ build-depends: base >= 4.8.0.0 && < 6 , rdf4h , containers , text >= 1.2.1.0@@ -97,12 +93,7 @@ test-suite test-rdf4h type: exitcode-stdio-1.0 main-is: Test.hs- other-modules: Data.RDF.GraphTestUtils- Data.RDF.Graph.AdjHashMap_Test- -- Data.RDF.Graph.HashSP_Test- -- Data.RDF.Graph.SP_Test- -- Data.RDF.Graph.TriplesPatriciaTree_Test- Data.RDF.Graph.TList_Test+ other-modules: Data.RDF.PropertyTests Text.RDF.RDF4H.TurtleParser_ConformanceTest Text.RDF.RDF4H.XmlParser_Test W3C.Manifest@@ -111,7 +102,7 @@ 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 && < 6+ build-depends: base >= 4.8.0.0 && < 6 , rdf4h , tasty , tasty-hunit@@ -139,7 +130,8 @@ type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: MainCriterion.hs- build-depends: base,+ build-depends: base >= 4.8.0.0,+ deepseq, criterion, rdf4h, text >= 1.2.1.0
src/Data/RDF/Types.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.RDF.Types ( @@ -48,7 +46,6 @@ import System.IO import Text.Printf import Data.Binary-import Control.Monad (guard) import Data.Map(Map) import Data.Maybe (fromJust) import GHC.Generics (Generic)@@ -57,11 +54,14 @@ import qualified Data.Map as Map import qualified Network.URI as Network (uriPath,parseURI) import Control.DeepSeq (NFData,rnf)-import Text.Parsec-import Text.Parsec.Text+import Text.Parsec(ParseError,parse) import Network.URI import Codec.Binary.UTF8.String +import Text.Parser.Char+import Text.Parser.Combinators+import Control.Applicative+ ------------------- -- LValue and constructor functions @@ -177,19 +177,17 @@ isRdfURI t = parse (isRdfURIParser <* eof) ("Invalid URI: " ++ T.unpack t) t -- [18] IRIREF from Turtle spec-isRdfURIParser :: GenParser () T.Text-isRdfURIParser = T.concat <$> many (T.singleton <$> noneOf (['\x00'..'\x20'] ++ [' ','<','>','"','{','}','|','^','`','\\']) <|> nt_uchar)+isRdfURIParser :: CharParsing m => m T.Text+isRdfURIParser = T.concat <$> many (T.singleton <$> noneOf (['\x00'..'\x20'] ++ " <>\"{}|^`\\") <|> nt_uchar) -- [10] UCHAR-nt_uchar :: GenParser () T.Text+nt_uchar :: CharParsing m => m T.Text nt_uchar =- (try (char '\\' >> char 'u' >> count 4 hexDigit >>= \cs -> return $ T.pack (uEscapedToXEscaped cs)) <|>- try (char '\\' >> char 'U' >> count 8 hexDigit >>= \cs -> return $ T.pack (uEscapedToXEscaped cs)))+ try (T.pack . uEscapedToXEscaped <$> (string "\\u" *> count 4 hexDigit)) <|>+ try (T.pack . uEscapedToXEscaped <$> (string "\\U" *> count 8 hexDigit)) uEscapedToXEscaped :: String -> String-uEscapedToXEscaped ss =- let str = ['\\','x'] ++ ss- in read ("\"" ++ str ++ "\"")+uEscapedToXEscaped ss = read ("\"\\x" ++ ss ++ "\"") -- |Validate a Text URI and return it in a @Just Text@ if it is -- valid, otherwise @Nothing@ is returned. See 'unodeValidate'.@@ -207,13 +205,12 @@ isRdfURIString = parse (isRdfURIParserS <* eof) ("Invalid URI: " ++ t) t isRdfURIParserS = many (validUriChar <|> nt_ucharS) nt_ucharS =- (try (char '\\' >> char 'u' >> count 4 hexDigit >>= return . head . uEscapedToXEscaped) <|>- try (char '\\' >> char 'U' >> count 8 hexDigit >>= return . head . uEscapedToXEscaped))+ try (head . uEscapedToXEscaped <$> (string "\\u" *> count 4 hexDigit)) <|>+ try (head . uEscapedToXEscaped <$> (string "\\U" *> count 8 hexDigit)) -- [18] IRIREF from Turtle spec- validUriChar = try $ do- c <- anyChar- guard $ not (c >= '\x00' && c <= '\x20') && c `notElem` [' ','<','>','"','{','}','|','^','`','\\']- return c+ validUriChar = try $ satisfy $ \c ->+ not (c >= '\x00' && c <= '\x20')+ && c `notElem` [' ','<','>','"','{','}','|','^','`','\\'] -- | Escapes @\Uxxxxxxxx@ and @\uxxxx@ character sequences according -- to the RDF specification.@@ -221,33 +218,16 @@ 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 (- try (do { _ <- char '\\'- ; _ <- char 'U'- ; 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 <- hexDigit- ; pos2 <- hexDigit- ; pos3 <- hexDigit- ; pos4 <- hexDigit- ; let str = ['\\','x',pos1,pos2,pos3,pos4]- ; return (read ("\"" ++ str ++ "\"") :: String)})+ unicodeEscParser :: (CharParsing m, Monad m) => m String+ unicodeEscParser =+ concat <$> many (+ try (do { str <- ("\\x"++) <$> (string "\\U" *> count 8 hexDigit)+ ; pure (read ("\"" ++ str ++ "\"") :: String)}) <|>- (anyChar >>= \c -> return [c]))- return (concat ss :: String)+ try (do { str <- ("\\x"++) <$> (string "\\u" *> count 4 hexDigit)+ ; pure (read ("\"" ++ str ++ "\"") :: String)})+ <|> (pure <$> anyChar)+ ) -- |Return a blank node using the given string identifier.@@ -336,9 +316,6 @@ -- the following: <http://www.w3.org/TR/rdf-concepts/#section-rdf-graph>. class (Generic rdfImpl, NFData rdfImpl) => Rdf rdfImpl where - -- -- |RDF type family- -- data RDF rdfImpl- -- |Return the base URL of this RDF, if any. baseUrl :: RDF rdfImpl -> Maybe BaseUrl @@ -414,7 +391,7 @@ showGraph :: RDF rdfImpl -> String instance (Rdf a) => Show (RDF a) where- show a = showGraph a+ show = showGraph -- |An RdfParser is a parser that knows how to parse 1 format of RDF and -- can parse an RDF document of that type from a string, a file, or a URL.@@ -735,7 +712,10 @@ doubleUri = "http://www.w3.org/2001/XMLSchema#double" _integerStr, _decimalStr, _doubleStr :: T.Text -> T.Text-_integerStr = T.dropWhile (== '0')+_integerStr t =+ if T.length t == 1+ then t+ else T.dropWhile (== '0') t -- exponent: [eE] ('-' | '+')? [0-9]+ -- ('-' | '+') ? ( [0-9]+ '.' [0-9]* exponent | '.' ([0-9])+ exponent | ([0-9])+ exponent )@@ -750,10 +730,9 @@ -- | Removes "file://" schema from URIs in 'UNode' nodes fileSchemeToFilePath :: Node -> Maybe T.Text-fileSchemeToFilePath (UNode fileScheme) =- if T.pack "file://" `T.isPrefixOf` fileScheme- then fmap (T.pack . Network.uriPath) (Network.parseURI (T.unpack fileScheme))- else if T.pack "http://" `T.isPrefixOf` fileScheme- then fmap (T.pack . Network.uriPath) (Network.parseURI (T.unpack fileScheme))- else Nothing+fileSchemeToFilePath (UNode fileScheme)+ | T.pack "file://" `T.isPrefixOf` fileScheme+ = fmap (T.pack . Network.uriPath) (Network.parseURI (T.unpack fileScheme))+ | T.pack "http://" `T.isPrefixOf` fileScheme+ = fmap (T.pack . Network.uriPath) (Network.parseURI (T.unpack fileScheme)) fileSchemeToFilePath _ = Nothing
src/Text/RDF/RDF4H/Interact.hs view
@@ -70,7 +70,7 @@ -- Load an RDF using the given parseFunc, parser, and the location (filesystem path -- or HTTP URL), calling error with the 'ParseFailure' message if unable to load -- or parse for any reason.-_load :: (RdfParser p, Rdf a) => +_load :: (Rdf a) => (p -> String -> IO (Either ParseFailure (RDF a))) -> p -> String -> IO (RDF a) _load parseFunc parser location = parseFunc parser location >>= _handle
src/Text/RDF/RDF4H/NTriplesParser.hs view
@@ -2,20 +2,26 @@ -- <http://www.w3.org/TR/rdf-testcases/#ntriples>. module Text.RDF.RDF4H.NTriplesParser- (NTriplesParser(NTriplesParser), ParseFailure)+ (NTriplesParser(NTriplesParser), NTriplesParserCustom(NTriplesParserCustom),ParseFailure) where import Prelude hiding (init,pred) import Data.RDF.Types import Text.RDF.RDF4H.ParserUtils-import Data.Char (isLetter, isDigit,isAlphaNum)+import Data.Attoparsec.ByteString (parse,IResult(..))+import Data.Char (isLetter, isDigit,isAlphaNum, isAsciiUpper, isAsciiLower) import Data.Map as Map (empty)-import Text.Parsec-import Text.Parsec.Text+import qualified Data.Text.Encoding as T+import Text.Parsec (runParser,ParseError) import qualified Data.Text as T import qualified Data.Text.IO as TIO-import Control.Monad (liftM,void,guard)+import Control.Monad (void) +import Text.Parser.Char+import Text.Parser.Combinators+import Control.Applicative+import Data.Maybe (catMaybes)+ -- |NTriplesParser is an 'RdfParser' implementation for parsing RDF in the -- NTriples format. It requires no configuration options. To use this parser, -- pass an 'NTriplesParser' value as the first argument to any of the@@ -23,31 +29,42 @@ -- class. data NTriplesParser = NTriplesParser --- |'NTriplesParser' is an instance of 'RdfParser'.+data NTriplesParserCustom = NTriplesParserCustom Parser++-- |'NTriplesParser' is an instance of 'RdfParser' using parsec based parsers. instance RdfParser NTriplesParser where- parseString _ = parseString'- parseFile _ = parseFile'- parseURL _ = parseURL'+ parseString _ = parseStringParsec+ parseFile _ = parseFileParsec+ parseURL _ = parseURLParsec +-- |'NTriplesParser' is an instance of 'RdfParser'.+instance RdfParser NTriplesParserCustom where+ parseString (NTriplesParserCustom Parsec) = parseStringParsec+ parseString (NTriplesParserCustom Attoparsec) = parseStringAttoparsec+ parseFile (NTriplesParserCustom Parsec) = parseFileParsec+ parseFile (NTriplesParserCustom Attoparsec) = parseFileAttoparsec+ parseURL (NTriplesParserCustom Parsec) = parseURLParsec+ parseURL (NTriplesParserCustom Attoparsec) = parseURLAttoparsec+ -- We define or redefine all here using same names as the spec, but with an -- 'nt_' prefix in order to avoid name clashes (e.g., ntripleDoc becomes -- nt_ntripleDoc). -- |nt_ntripleDoc is simply zero or more lines.-nt_ntripleDoc :: GenParser () [Maybe Triple]+nt_ntripleDoc :: (CharParsing m, Monad m) => m [Maybe Triple] nt_ntripleDoc = manyTill nt_line eof -nt_line :: GenParser () (Maybe Triple)+nt_line :: (CharParsing m, Monad m) => m (Maybe Triple) nt_line =- skipMany nt_space >>- ((nt_comment >>= \res -> return res)- <|> try (nt_triple >>= \res -> nt_eoln >> return res)- <|> try (nt_triple >>= \res -> char '#' >> manyTill anyChar nt_eoln >> return res)- <|> (nt_empty >>= \res -> nt_eoln >> return res))- >>= \res -> return res+ skipMany nt_space *>+ (nt_comment+ <|> try (nt_triple <* nt_eoln)+ <|> try (nt_triple <* char '#' <* manyTill anyChar nt_eoln)+ <|> (nt_empty <* nt_eoln)+ ) -nt_comment :: GenParser () (Maybe Triple)-nt_comment = char '#' >> manyTill anyChar nt_eoln >> return Nothing+nt_comment :: CharParsing m => m (Maybe Triple)+nt_comment = char '#' *> manyTill anyChar nt_eoln *> pure Nothing -- A triple consists of whitespace-delimited subject, predicate, and object, -- followed by optional whitespace and a period, and possibly more@@ -60,147 +77,126 @@ -- -- `optional` lets this nt_triple parser succeed even if there is not -- a space or tab character between resources or the object and the '.'.-nt_triple :: GenParser () (Maybe Triple)+nt_triple :: (CharParsing m, Monad m) => m (Maybe Triple) nt_triple = do- subj <- nt_subject- optional (skipMany1 nt_space)- pred <- nt_predicate- optional (skipMany1 nt_space)- obj <- nt_object- optional (skipMany1 nt_space)- void (char '.')- void (many nt_space)- return $ Just (Triple subj pred obj)-+ subj <- nt_subject <* optional (skipSome nt_space)+ pred <- nt_predicate <* optional (skipSome nt_space)+ obj <- nt_object <* optional (skipSome nt_space) <* char '.' <* many nt_space+ pure $ Just (Triple subj pred obj) -- [6] literal-nt_literal :: GenParser () LValue+nt_literal :: (CharParsing m, Monad m) => m LValue nt_literal = do- s' <- nt_string_literal_quote- let s = escapeRDFSyntax s'- option (plainL s) $ do- ((count 2 (char '^') >> nt_iriref >>= validateURI >>= isAbsoluteParser >>= \iri -> return (typedL s iri))- <|> (nt_langtag >>= \lang -> return (plainLL s lang)))+ s <- escapeRDFSyntax <$> nt_string_literal_quote+ option (plainL s) $+ (count 2 (char '^') *> nt_iriref >>= validateURI >>= isAbsoluteParser >>= \iri -> pure (typedL s iri))+ <|> (plainLL s <$> nt_langtag) -- [9] STRING_LITERAL_QUOTE-nt_string_literal_quote :: GenParser () T.Text+nt_string_literal_quote :: CharParsing m => m T.Text nt_string_literal_quote =- between (char '"') (char '"') $ do- T.concat <$> (many ((T.singleton <$> noneOf ['\x22','\x5C','\xA','\xD']) <|>+ between (char '"') (char '"') $+ T.concat <$> many ((T.singleton <$> noneOf ['\x22','\x5C','\xA','\xD']) <|> nt_echar <|>- nt_uchar))+ nt_uchar) -- [144s] LANGTAG-nt_langtag :: GenParser () T.Text+nt_langtag :: (CharParsing m, Monad m) => m T.Text nt_langtag = do- void (char '@')- ss <- many1 (satisfy (\ c -> isLetter c))- rest <- concat <$> many (char '-' >> many1 (satisfy (\ c -> isAlphaNum c)) >>= \lang_str -> return ('-':lang_str))- return (T.pack (ss ++ rest))+ ss <- char '@' *> some (satisfy isLetter)+ rest <- concat <$> many ((:) <$> char '-' <*> some (satisfy isAlphaNum))+ pure (T.pack (ss ++ rest)) -- [8] IRIREF-nt_iriref :: GenParser () T.Text-nt_iriref = do- between (char '<') (char '>') $ do- T.concat <$> many ( T.singleton <$> noneOf (['\x00'..'\x20'] ++ ['<','>','"','{','}','|','^','`','\\']) <|>- nt_uchar )+nt_iriref :: CharParsing m => m T.Text+nt_iriref =+ between (char '<') (char '>') $+ T.concat <$> many ( T.singleton <$> noneOf (['\x00'..'\x20'] ++ "<>\"{}|^`\\") <|> nt_uchar ) -- [153s] ECHAR-nt_echar :: GenParser () T.Text-nt_echar = try $ do- void (char '\\')- c2 <- anyChar- guard $ isEchar c2- return (T.pack [c2])+nt_echar :: CharParsing m => m T.Text+nt_echar = try $ T.singleton <$> (char '\\' *> satisfy isEchar) isEchar :: Char -> Bool isEchar = (`elem` ['t','b','n','r','f','"','\'','\\']) -- [10] UCHAR-nt_uchar :: GenParser () T.Text+nt_uchar :: CharParsing m => m T.Text nt_uchar =- (try (char '\\' >> char 'u' >> count 4 hexDigit >>= \cs -> return $ T.pack ('\\':'u':cs)) <|>- try (char '\\' >> char 'U' >> count 8 hexDigit >>= \cs -> return $ T.pack ('\\':'U':cs)))+ try (T.pack <$> ((++) <$> string "\\u" <*> count 4 hexDigit)) <|>+ try (T.pack <$> ((++) <$> string "\\U" <*> count 8 hexDigit)) -- nt_empty is a line that isn't a comment or a triple. They appear in the -- parsed output as Nothing, whereas a real triple appears as (Just triple).-nt_empty :: GenParser () (Maybe Triple)-nt_empty = skipMany nt_space >> return Nothing+nt_empty :: CharParsing m => m (Maybe Triple)+nt_empty = skipMany nt_space *> pure Nothing -- A subject is either a URI reference for a resource or a node id for a -- blank node.-nt_subject :: GenParser () Node+nt_subject :: (CharParsing m, Monad m) => m Node nt_subject =- liftM unode nt_uriref <|>- liftM bnode nt_blank_node_label+ unode <$> nt_uriref <|>+ bnode <$> nt_blank_node_label -- A predicate may only be a URI reference to a resource.-nt_predicate :: GenParser () Node-nt_predicate = liftM unode nt_uriref+nt_predicate :: (CharParsing m, Monad m) => m Node+nt_predicate = unode <$> nt_uriref -- An object may be either a resource (represented by a URI reference), -- a blank node (represented by a node id), or an object literal.-nt_object :: GenParser () Node+nt_object :: (CharParsing m, Monad m) => m Node nt_object =- liftM unode nt_uriref <|>- liftM bnode nt_blank_node_label <|>- liftM LNode nt_literal+ unode <$> nt_uriref <|>+ bnode <$> nt_blank_node_label <|>+ LNode <$> nt_literal -validateUNode :: T.Text -> GenParser () Node+validateUNode :: CharParsing m => T.Text -> m Node validateUNode t = case unodeValidate t of- Nothing -> unexpected ("Invalid URI in NTriples parser URI validation: " ++ show t)- Just u@(UNode{}) -> return u+ Just u@UNode{} -> pure u Just node -> unexpected ("Unexpected node in NTriples parser URI validation: " ++ show node)+ Nothing -> unexpected ("Invalid URI in NTriples parser URI validation: " ++ show t) -validateURI :: T.Text -> GenParser () T.Text+validateURI :: (CharParsing m, Monad m) => T.Text -> m T.Text validateURI t = do UNode uri <- validateUNode t- return uri+ pure uri -isAbsoluteParser :: T.Text -> GenParser () T.Text+isAbsoluteParser :: CharParsing m => T.Text -> m T.Text isAbsoluteParser t = if isAbsoluteUri t- then return t+ then pure t else unexpected ("Only absolute IRIs allowed in NTriples format, which this isn't: " ++ show t) -absoluteURI :: T.Text -> GenParser () T.Text-absoluteURI t = do- uri <- isAbsoluteParser t- return uri+absoluteURI :: CharParsing m => T.Text -> m T.Text+absoluteURI = isAbsoluteParser -- A URI reference is one or more nrab_character inside angle brackets.-nt_uriref :: GenParser () T.Text+nt_uriref :: (CharParsing m, Monad m) => m T.Text nt_uriref = between (char '<') (char '>') $ do unvalidatedUri <- many (satisfy ( /= '>'))- t <- validateURI (T.pack unvalidatedUri)- absoluteURI t+ absoluteURI =<< validateURI (T.pack unvalidatedUri) -- [141s] BLANK_NODE_LABEL-nt_blank_node_label :: GenParser () T.Text+nt_blank_node_label :: (CharParsing m, Monad m) => m T.Text nt_blank_node_label = do- void (char '_' >> char ':')- s1 <- (nt_pn_chars_u <|> satisfy isDigit)- s2 <- option "" $ try $ do- sub_dots <- many (char '.')- sub_s1 <- many1 nt_pn_chars- return (sub_dots ++ sub_s1)- return (T.pack ("_:" ++ [s1] ++ s2))+ void (char '_' *> char ':')+ s1 <- nt_pn_chars_u <|> satisfy isDigit+ s2 <- option "" $ try $ (++) <$> many (char '.') <*> some nt_pn_chars+ pure (T.pack ("_:" ++ s1:s2)) -- [157s] PN_CHARS_BASE -- Not used. It used to be. What's happened? {--nt_pn_chars_base :: GenParser () Char-nt_pn_chars_base = try $ do- c <- anyChar- guard $ isBaseChar c- return c+nt_pn_chars_base :: CharParsing m => m Char+nt_pn_chars_base = try $ satisfy isBaseChar c+ -} isBaseChar :: Char -> Bool isBaseChar c- = (c >= 'A' && c <= 'Z')- || (c >= 'a' && c <= 'z')+ = isAsciiUpper c+ || isAsciiLower c || (c >= '\x00C0' && c <= '\x00D6') || (c >= '\x00D8' && c <= '\x00F6') || (c >= '\x00F8' && c <= '\x02FF')@@ -216,66 +212,84 @@ -- [158s] PN_CHARS_U-nt_pn_chars_u :: GenParser () Char-nt_pn_chars_u = try $ do- c <- anyChar- guard $ c == '_' || c == ':' || isBaseChar c- return c+nt_pn_chars_u :: CharParsing m => m Char+nt_pn_chars_u = try $ satisfy $ \c -> c == '_' || c == ':' || isBaseChar c -- [160s] PN_CHARS-nt_pn_chars :: GenParser () Char-nt_pn_chars = nt_pn_chars_u <|> try (do- c <- anyChar- guard $ c == '-' || c == '\x00B7'+nt_pn_chars :: CharParsing m => m Char+nt_pn_chars = nt_pn_chars_u+ <|> try (satisfy $ \c ->+ c == '-' || c == '\x00B7' || isDigit c || (c >= '\x0300' && c <= '\x036F') || (c >= '\x203F' && c <= '\x2040')- return c ) -- End-of-line consists of either lf or crlf. -- We also test for eof and consider that to match as well.-nt_eoln :: GenParser () ()-nt_eoln = eof <|> void (nt_cr >> nt_lf) <|> void nt_lf+nt_eoln :: CharParsing m => m ()+nt_eoln = eof <|> void (nt_cr *> nt_lf) <|> void nt_lf -- Whitespace is either a space or tab character. We must avoid using the -- built-in space combinator here, because it includes newline.-nt_space :: GenParser () Char+nt_space :: CharParsing m => m Char nt_space = char ' ' <|> nt_tab --- Carriage return is \r.-nt_cr :: GenParser () Char+-- Carriage pure is \r.+nt_cr :: CharParsing m => m Char nt_cr = char '\r' -- Line feed is \n.-nt_lf :: GenParser () Char+nt_lf :: CharParsing m => m Char nt_lf = char '\n' -- Tab is \t.-nt_tab :: GenParser () Char+nt_tab :: CharParsing m => m Char nt_tab = char '\t' -parseString' :: (Rdf a) => T.Text -> Either ParseFailure (RDF a)-parseString' bs = handleParse mkRdf (runParser nt_ntripleDoc () "" bs)+---------------------------------+-- parsec based parsers -parseURL' :: (Rdf a) => String -> IO (Either ParseFailure (RDF a))-parseURL' = _parseURL parseString'+parseStringParsec :: (Rdf a) => T.Text -> Either ParseFailure (RDF a)+parseStringParsec bs = handleParse mkRdf (runParser nt_ntripleDoc () "" bs) -parseFile' :: (Rdf a) => String -> IO (Either ParseFailure (RDF a))-parseFile' path = liftM (handleParse mkRdf . runParser nt_ntripleDoc () path)- (TIO.readFile path)+parseFileParsec :: (Rdf a) => String -> IO (Either ParseFailure (RDF a))+parseFileParsec path =+ handleParse mkRdf . runParser nt_ntripleDoc () path+ <$> TIO.readFile path -handleParse :: {-forall rdf. (RDF rdf) => -} (Triples -> Maybe BaseUrl -> PrefixMappings -> (RDF a)) ->+parseURLParsec :: (Rdf a) => String -> IO (Either ParseFailure (RDF a))+parseURLParsec = _parseURL parseStringParsec++---------------------------------++---------------------------------+-- attoparsec based parsers++parseStringAttoparsec :: (Rdf a) => T.Text -> Either ParseFailure (RDF a)+parseStringAttoparsec bs = handleResult $ parse nt_ntripleDoc (T.encodeUtf8 bs)+ where+ handleResult res = case res of+ Fail _ _ err -> error 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+-- | otherwise =+ = case result of Left err -> Left $ ParseFailure $ "Parse failure: \n" ++ show err- Right ts -> Right $ _mkRdf (conv ts) Nothing (PrefixMappings Map.empty)- where- conv [] = []- conv (Nothing:ts) = conv ts- conv (Just t:ts) = t : conv ts+ Right ts -> Right $ _mkRdf (catMaybes ts) Nothing (PrefixMappings Map.empty)
src/Text/RDF/RDF4H/ParserUtils.hs view
@@ -1,5 +1,6 @@ module Text.RDF.RDF4H.ParserUtils(- _parseURL, justTriples+ _parseURL, justTriples,+ Parser(..) ) where import Data.RDF.Types@@ -12,6 +13,8 @@ import qualified Data.Text as T -- import qualified Data.Map as Map import Data.Maybe (fromMaybe)++data Parser = Parsec | Attoparsec -- | A convenience function for terminating a parse with a parse failure, using -- the given error message as the message for the failure.
src/Text/RDF/RDF4H/TurtleParser.hs view
@@ -2,28 +2,37 @@ -- <http://www.w3.org/TeamSubmission/turtle/>. module Text.RDF.RDF4H.TurtleParser(- TurtleParser(TurtleParser)+ TurtleParser(TurtleParser),+ TurtleParserCustom(TurtleParserCustom) ) where -import Data.Char (isLetter,isAlphaNum,toLower,toUpper)+import Data.Attoparsec.ByteString (parse,IResult(..))+import Data.Char (isLetter,isAlphaNum,toLower,toUpper,isDigit,isHexDigit) import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe import Data.RDF.Types import Data.RDF.Namespace import Text.RDF.RDF4H.ParserUtils-import Text.Parsec-import Text.Parsec.Text+import Text.Parsec (runParser,ParseError)+-- import Text.Parsec.Text (GenParser) import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Data.Text.IO as TIO import Data.Sequence(Seq, (|>)) import qualified Data.Sequence as Seq import qualified Data.Foldable as F-import Data.Char (isDigit) import Control.Monad +import Text.Parser.Char+import Text.Parser.Combinators+import Text.Parser.LookAhead+import Control.Applicative+import Control.Monad.State.Class+import Control.Monad.State.Strict+ -- |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 .@@ -36,12 +45,25 @@ -- class. data TurtleParser = TurtleParser (Maybe BaseUrl) (Maybe T.Text) --- |'TurtleParser' is an instance of 'RdfParser'.+data TurtleParserCustom = TurtleParserCustom (Maybe BaseUrl) (Maybe T.Text) Parser++-- |'TurtleParser' is an instance of 'RdfParser' using a parsec based parser. instance RdfParser TurtleParser where- parseString (TurtleParser bUrl dUrl) = parseString' bUrl dUrl- parseFile (TurtleParser bUrl dUrl) = parseFile' bUrl dUrl- parseURL (TurtleParser bUrl dUrl) = parseURL' bUrl dUrl+ parseString (TurtleParser bUrl dUrl) = parseStringParsec bUrl dUrl+ parseFile (TurtleParser bUrl dUrl) = parseFileParsec bUrl dUrl+ parseURL (TurtleParser bUrl dUrl) = parseURLParsec bUrl dUrl +-- |'TurtleParser' is an instance of 'RdfParser' using either a+-- parsec or an attoparsec based parser.+instance RdfParser TurtleParserCustom where+ parseString (TurtleParserCustom bUrl dUrl Parsec) = parseStringParsec bUrl dUrl+ parseString (TurtleParserCustom bUrl dUrl Attoparsec) = parseStringAttoparsec bUrl dUrl+ parseFile (TurtleParserCustom bUrl dUrl Parsec) = parseFileParsec bUrl dUrl+ parseFile (TurtleParserCustom bUrl dUrl Attoparsec) = parseFileAttoparsec bUrl dUrl+ parseURL (TurtleParserCustom bUrl dUrl Parsec) = parseURLParsec bUrl dUrl+ parseURL (TurtleParserCustom bUrl dUrl Attoparsec) = parseURLAttoparsec bUrl dUrl++ type ParseState = (Maybe BaseUrl, -- the current BaseUrl, may be Nothing initially, but not after it is once set Maybe T.Text, -- the docUrl, which never changes and is used to resolve <> in the document.@@ -56,280 +78,276 @@ Map String Int) -- grammar rule: [1] turtleDoc-t_turtleDoc :: GenParser ParseState (Seq Triple, PrefixMappings)+-- t_turtleDoc :: (CharParsing m, Monad m) => m (Seq Triple, PrefixMappings)+t_turtleDoc :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m (Seq Triple, PrefixMappings) t_turtleDoc =- many t_statement >> (eof <?> "eof") >> getState >>= \(_, _, _, pms, _, _, _, _, _, ts,_) -> return (ts, pms)+ many t_statement *> (eof <?> "eof") *> gets (\(_, _, _, pms, _, _, _, _, _, ts,_) -> (ts, pms)) -- grammar rule: [2] statement-t_statement :: GenParser ParseState ()-t_statement = d <|> t <|> void (many1 t_ws <?> "blankline-whitespace")+t_statement :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m ()+t_statement = d <|> t <|> void (some t_ws <?> "blankline-whitespace") where d = void- (try t_directive >>- (many t_ws <?> "directive-whitespace2"))+ (try t_directive+ *> (many t_ws <?> "directive-whitespace2")) t = void- (t_triples >> (many t_ws <?> "triple-whitespace1") >>- (char '.' <?> "end-of-triple-period") >>- (many t_ws <?> "triple-whitespace2"))+ (t_triples+ *> (many t_ws <?> "triple-whitespace1")+ *> (char '.' <?> "end-of-triple-period")+ *> (many t_ws <?> "triple-whitespace2")) -- grammar rule: [6] triples -- subject predicateObjectList | blankNodePropertyList predicateObjectList?-t_triples :: GenParser ParseState ()-t_triples = do- try (t_subject >> many t_ws >> t_predicateObjectList >> resetSubjectPredicate) <|> (setSubjBlankNodePropList >> t_blankNodePropertyList >> many t_ws >> optional (t_predicateObjectList) >> resetSubjectPredicate >> setNotSubjBlankNodePropList)+t_triples :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m ()+t_triples =+ try (t_subject *> many t_ws *> t_predicateObjectList *> resetSubjectPredicate)+ <|> (setSubjBlankNodePropList+ *> t_blankNodePropertyList+ *> many t_ws+ *> optional t_predicateObjectList+ *> resetSubjectPredicate+ *> setNotSubjBlankNodePropList) -- [14] blankNodePropertyList ::= '[' predicateObjectList ']'-t_blankNodePropertyList :: GenParser ParseState ()+t_blankNodePropertyList :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m () t_blankNodePropertyList = between (char '[') (char ']') $ do subjPropList <- isSubjPropList- blankNode <- liftM BNodeGen nextIdCounter+ blankNode <- BNodeGen <$> nextIdCounter unless subjPropList $ addTripleForObject blankNode pushSubj blankNode- (many t_ws >> t_predicateObjectList >> void (many t_ws))+ many t_ws *> t_predicateObjectList *> void (many t_ws) unless subjPropList $ void popSubj -- grammar rule: [3] directive-t_directive :: GenParser ParseState ()+t_directive :: (CharParsing m, MonadState ParseState m) => m () t_directive = t_prefixID <|> t_base <|> t_sparql_prefix <|> t_sparql_base -- grammar rule: [135s] iri -- IRIREF | PrefixedName-t_iri :: GenParser ParseState T.Text+t_iri :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m T.Text t_iri = try t_iriref <|> t_prefixedName -- grammar rule: [136s] PrefixedName-t_prefixedName :: GenParser ParseState T.Text-t_prefixedName = do- t <- try t_pname_ln <|> try t_pname_ns- return t+t_prefixedName :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m T.Text+t_prefixedName = try t_pname_ln <|> try t_pname_ns -- grammar rule: [4] prefixID-t_prefixID :: GenParser ParseState ()+t_prefixID :: (CharParsing m, MonadState ParseState m) => m () t_prefixID = do void (try (string "@prefix" <?> "@prefix-directive"))- pre <- (many1 t_ws <?> "whitespace-after-@prefix") >> option T.empty t_pn_prefix- void (char ':' >> (many1 t_ws <?> "whitespace-after-@prefix-colon"))+ pre <- (some t_ws <?> "whitespace-after-@prefix") *> option T.empty t_pn_prefix+ void (char ':' *> (some t_ws <?> "whitespace-after-@prefix-colon")) uriFrag <- t_iriref void (many t_ws <?> "prefixID-whitespace") void (char '.' <?> "end-of-prefixID-period")- (bUrl, dUrl, _, PrefixMappings pms, _, _, _, _, _, _, _) <- getState+ (bUrl, dUrl, _, PrefixMappings pms, _, _, _, _, _, _, _) <- get updatePMs $ Just (PrefixMappings $ Map.insert pre (absolutizeUrl bUrl dUrl uriFrag) pms)- return ()+ pure () -- grammar rule: [6s] sparqlPrefix-t_sparql_prefix :: GenParser ParseState ()+t_sparql_prefix :: (CharParsing m, MonadState ParseState m) => m () t_sparql_prefix = do void (try (caseInsensitiveString "PREFIX" <?> "@prefix-directive"))- pre <- (many1 t_ws <?> "whitespace-after-@prefix") >> option T.empty t_pn_prefix- void (char ':' >> (many1 t_ws <?> "whitespace-after-@prefix-colon"))+ pre <- (some t_ws <?> "whitespace-after-@prefix") *> option T.empty t_pn_prefix+ void (char ':' *> (some t_ws <?> "whitespace-after-@prefix-colon")) uriFrag <- t_iriref- (bUrl, dUrl, _, PrefixMappings pms, _, _, _, _, _, _, _) <- getState+ (bUrl, dUrl, _, PrefixMappings pms, _, _, _, _, _, _, _) <- get updatePMs $ Just (PrefixMappings $ Map.insert pre (absolutizeUrl bUrl dUrl uriFrag) pms)- return ()+ pure () -- grammar rule: [5] base-t_base :: GenParser ParseState ()+t_base :: (CharParsing m, MonadState ParseState m) => m () t_base = do void (try (string "@base" <?> "@base-directive"))- void (many1 t_ws <?> "whitespace-after-@base")+ void (some t_ws <?> "whitespace-after-@base") urlFrag <- t_iriref void (many t_ws <?> "base-whitespace")- (void (char '.') <?> "end-of-base-period")+ void (char '.') <?> "end-of-base-period" bUrl <- currBaseUrl dUrl <- currDocUrl updateBaseUrl (Just $ Just $ newBaseUrl bUrl (absolutizeUrl bUrl dUrl urlFrag)) -- grammar rule: [5s] sparqlBase-t_sparql_base :: GenParser ParseState ()+t_sparql_base :: (CharParsing m, MonadState ParseState m) => m () t_sparql_base = do void (try (caseInsensitiveString "BASE" <?> "@sparql-base-directive"))- void (many1 t_ws <?> "whitespace-after-BASE")+ void (some t_ws <?> "whitespace-after-BASE") urlFrag <- t_iriref bUrl <- currBaseUrl dUrl <- currDocUrl updateBaseUrl (Just $ Just $ newBaseUrl bUrl (absolutizeUrl bUrl dUrl urlFrag)) -t_verb :: GenParser ParseState ()+t_verb :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m () -- [9] verb ::= predicate | 'a'-t_verb = (try t_predicate <|> (char 'a' >> return rdfTypeNode)) >>= pushPred+t_verb = (try t_predicate <|> (char 'a' *> pure rdfTypeNode)) >>= pushPred -- grammar rule: [11] predicate-t_predicate :: GenParser ParseState Node-t_predicate = liftM UNode (t_iri <?> "resource")+t_predicate :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m Node+t_predicate = UNode <$> (t_iri <?> "resource") -- grammar rules: [139s] PNAME_NS-t_pname_ns :: GenParser ParseState T.Text+t_pname_ns :: (CharParsing m, MonadState ParseState m) => m T.Text t_pname_ns =do- pre <- option T.empty (try t_pn_prefix)- void (char ':')- (bUrl, _, _, pms, _, _, _, _, _, _, _) <- getState+ pre <- option T.empty (try t_pn_prefix) <* char ':'+ (bUrl, _, _, pms, _, _, _, _, _, _, _) <- get case resolveQName bUrl pre pms of- Just n -> return n+ Just n -> pure n Nothing -> unexpected ("Cannot resolve QName prefix: " ++ T.unpack pre) -- grammar rules: [168s] PN_LOCAL -- [168s] PN_LOCAL ::= (PN_CHARS_U | ':' | [0-9] | PLX) ((PN_CHARS | '.' | ':' | PLX)* (PN_CHARS | ':' | PLX))?-t_pn_local :: GenParser ParseState T.Text+t_pn_local :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m T.Text t_pn_local = do x <- t_pn_chars_u_str <|> string ":" <|> satisfy_str <|> t_plx xs <- option "" $ try $ do let recsve = (t_pn_chars_str <|> string ":" <|> t_plx) <|> (t_pn_chars_str <|> string ":" <|> t_plx <|> try (string "." <* lookAhead (try recsve))) <|>- (t_pn_chars_str <|> string ":" <|> t_plx <|> try (string "." >> notFollowedBy t_ws >> return "."))+ (t_pn_chars_str <|> string ":" <|> t_plx <|> try (string "." *> notFollowedBy t_ws *> pure ".")) concat <$> many recsve- return (T.pack (x ++ xs))+ pure (T.pack (x ++ xs)) where- satisfy_str = satisfy (flip in_range [('0', '9')]) >>= \c -> return [c]- t_pn_chars_str = t_pn_chars >>= \c -> return [c]- t_pn_chars_u_str = t_pn_chars_u >>= \c -> return [c]+ satisfy_str = pure <$> satisfy isDigit+ t_pn_chars_str = pure <$> t_pn_chars+ t_pn_chars_u_str = pure <$> t_pn_chars_u -- PERCENT | PN_LOCAL_ESC -- grammar rules: [169s] PLX-t_plx :: GenParser ParseState String+t_plx :: (CharParsing m, Monad m) => m String t_plx = t_percent <|> t_pn_local_esc_str where- t_pn_local_esc_str = do- c <- t_pn_local_esc- return ([c])+ t_pn_local_esc_str = pure <$> t_pn_local_esc -- '%' HEX HEX -- grammar rules: [170s] PERCENT-t_percent :: GenParser ParseState String-t_percent = do- void (char '%')- h1 <- t_hex- h2 <- t_hex- return (['%',h1,h2])+t_percent :: (CharParsing m, Monad m) => m String+t_percent = sequence [char '%',t_hex,t_hex] + -- grammar rules: [172s] PN_LOCAL_ESC-t_pn_local_esc :: GenParser ParseState Char-t_pn_local_esc = char '\\' >> oneOf "_~.-!$&'()*+,;=/?#@%"+t_pn_local_esc :: CharParsing m => m Char+t_pn_local_esc = char '\\' *> oneOf "_~.-!$&'()*+,;=/?#@%" -- grammar rules: [140s] PNAME_LN-t_pname_ln :: GenParser ParseState T.Text-t_pname_ln =- do pre <- t_pname_ns- name <- t_pn_local- return (pre `T.append` name)+t_pname_ln :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m T.Text+t_pname_ln = T.append <$> t_pname_ns <*> t_pn_local -- grammar rule: [10] subject -- [10] subject ::= iri | BlankNode | collection-t_subject :: GenParser ParseState ()+t_subject :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m () t_subject = iri <|> (t_blankNode >>= pushSubj) <|>- (liftM BNodeGen nextIdCounter >>= pushSubj- >> pushPred rdfFirstNode- >> pushSubjColl- >> t_collection)+ (BNodeGen <$> nextIdCounter >>= \x -> pushSubj x+ *> pushPred rdfFirstNode+ *> pushSubjColl+ *> t_collection) where- iri = liftM unode (try t_iri <?> "subject resource") >>= \s -> pushSubj s+ iri = unode <$> (try t_iri <?> "subject resource") >>= pushSubj -- [137s] BlankNode ::= BLANK_NODE_LABEL | ANON-t_blankNode :: GenParser ParseState Node+t_blankNode :: (CharParsing m, MonadState ParseState m) => m Node t_blankNode = do- genID <- (try t_blank_node_label <|> (t_anon >> return ""))+ genID <- try t_blank_node_label <|> (t_anon *> pure "") mp <- currGenIdLookup- node <-- case Map.lookup genID mp of- Nothing -> do- i <- nextIdCounter- let node = BNodeGen i- addGenIdLookup genID i- return node- Just i ->- return $ BNodeGen i- return node+ case Map.lookup genID mp of+ Nothing -> do+ i <- nextIdCounter+ let node = BNodeGen i+ addGenIdLookup genID i+ pure node+ Just i ->+ pure $ BNodeGen i -- TODO replicate the recursion technique from [168s] for ((..)* something)? -- [141s] BLANK_NODE_LABEL ::= '_:' (PN_CHARS_U | [0-9]) ((PN_CHARS | '.')* PN_CHARS)?-t_blank_node_label :: GenParser ParseState [Char]+t_blank_node_label :: (CharParsing m, MonadState ParseState m) => m String t_blank_node_label = do void (string "_:")- firstChar <- (t_pn_chars_u <|> oneOf ['0'..'9'])+ firstChar <- t_pn_chars_u <|> satisfy isDigit -- optional $ try $ do try $ do ss <- option "" $ do xs <- many (t_pn_chars <|> char '.') if null xs- then return xs+ then pure xs else if last xs == '.' then unexpected "'.' at the end of a blank node label"- else return xs- return (firstChar : ss)+ else pure xs+ pure (firstChar : ss) -- [162s] ANON ::= '[' WS* ']'-t_anon :: GenParser ParseState ()-t_anon = between (char '[') (char ']') (void (many t_ws))+t_anon :: CharParsing m => m ()+t_anon = between (char '[') (char ']') (skipMany t_ws) -- [7] predicateObjectList ::= verb objectList (';' (verb objectList)?)*-t_predicateObjectList :: GenParser ParseState ()-t_predicateObjectList = do+t_predicateObjectList :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m ()+t_predicateObjectList = void (sepEndBy1 (optional (try (do { t_verb- ; many1 t_ws+ ; some t_ws ; t_objectList- ; void popPred})))- (try (many t_ws >> char ';' >> many t_ws)))+ ; popPred})))+ (try (many t_ws *> char ';' *> many t_ws))) -- grammar rule: [8] objectlist -- [8] objectList ::= object (',' object)*-t_objectList :: GenParser ParseState ()+t_objectList :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m () t_objectList = -- t_object actually adds the triples- void- ((t_object <?> "object") >>- many (try (many t_ws >> char ',' >> many t_ws >> t_object)))+ () <$ ((t_object <?> "object")+ *> many (try (many t_ws *> char ',' *> many t_ws *> t_object))) -- grammar rule: [12] object -- [12] object ::= iri | BlankNode | collection | blankNodePropertyList | literal-t_object :: GenParser ParseState ()+t_object :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m () t_object = do inColl <- isInColl inSubjColl <- isInSubjColl onFirstItem <- onCollFirstItem let processObject =- (liftM UNode t_iri >>= addTripleForObject) <|>+ (UNode <$> t_iri >>= addTripleForObject) <|> (try t_blankNode >>= addTripleForObject) <|>- (try t_collection >> pushObjColl) <|>- (try t_blankNodePropertyList) <|>+ (try t_collection *> pushObjColl) <|>+ try t_blankNodePropertyList <|> (t_literal >>= addTripleForObject) case (inColl,inSubjColl,onFirstItem) of (False,_,_) -> processObject- (True,False,True) -> liftM BNodeGen nextIdCounter >>= \bSubj -> addTripleForObject bSubj- >> pushSubj bSubj >> pushPred rdfFirstNode >> processObject >> collFirstItemProcessed--- (True,True,True) -> processObject >> collFirstItemProcessed- (True,True,True) -> processObject >> collFirstItemProcessed >> popColl- (True,_,False) -> liftM BNodeGen nextIdCounter >>= \bSubj -> pushPred rdfRestNode >>- addTripleForObject bSubj >> popPred >> popSubj >>- pushSubj bSubj >> processObject+ (True,False,True) -> BNodeGen <$> nextIdCounter >>= \bSubj -> addTripleForObject bSubj+ *> pushSubj bSubj *> pushPred rdfFirstNode *> processObject *> collFirstItemProcessed+-- (True,True,True) -> processObject *> collFirstItemProcessed+ (True,True,True) -> processObject *> collFirstItemProcessed *> popColl+ (True,_,False) -> BNodeGen <$> nextIdCounter >>= \bSubj -> pushPred rdfRestNode *>+ addTripleForObject bSubj *> popPred *> popSubj *>+ pushSubj bSubj *> processObject -- collection: '(' ws* itemList? ws* ')' -- itemList: object (ws+ object)* -- grammar rule: [15] collection -- 15] collection ::= '(' object* ')'-t_collection :: GenParser ParseState ()+t_collection :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m () t_collection = between (char '(') (char ')') $ do beginColl- (try empty_list <|> non_empty_list)+ try empty_list <|> non_empty_list+ void (many t_ws) void finishColl -- popColl where non_empty_list = do- many1 (many t_ws >> t_object >> many t_ws)+ some (many t_ws *> t_object *> many t_ws) _inSubjColl <- isInSubjColl popPred pushPred rdfRestNode addTripleForObject rdfNilNode+ void popSubj -- popPred -- if inSubjColl then trace "is sub" popColl else trace "not sub" $ void popSubj- -- if inSubjColl then return () else trace "not sub" $ void popSubj+ -- if inSubjColl then pure () else trace "not sub" $ void popSubj empty_list = do- lookAhead (try (many t_ws >> char ')'))+ lookAhead (try (many t_ws *> char ')')) addTripleForObject rdfNilNode rdfTypeNode, rdfNilNode, rdfFirstNode, rdfRestNode :: Node@@ -344,30 +362,30 @@ xsdDecimalUri = mkUri xsd "decimal" xsdBooleanUri = mkUri xsd "boolean" -t_literal :: GenParser ParseState Node+t_literal :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m Node t_literal =- (try t_rdf_literal >>= \l -> return (LNode l)) <|>- liftM (`mkLNode` xsdDoubleUri) (try t_double) <|>- liftM (`mkLNode` xsdDecimalUri) (try t_decimal) <|>- liftM (`mkLNode` xsdIntUri) (try t_integer) <|>- liftM (`mkLNode` xsdBooleanUri) t_boolean- where+ LNode <$> try t_rdf_literal <|>+ (`mkLNode` xsdDoubleUri) <$> try t_double <|>+ (`mkLNode` xsdDecimalUri) <$> try t_decimal <|>+ (`mkLNode` xsdIntUri) <$> try t_integer <|>+ (`mkLNode` xsdBooleanUri) <$> t_boolean+ where mkLNode :: T.Text -> T.Text -> Node mkLNode bsType bs' = LNode (typedL bsType bs') -- [128s] RDFLiteral -- String (LANGTAG | '^^' iri)?-t_rdf_literal :: GenParser ParseState LValue+t_rdf_literal :: (MonadState ParseState m,CharParsing m, LookAheadParsing m) => m LValue t_rdf_literal = do str' <- t_string let str = escapeRDFSyntax str'- option (plainL str) $ do- (try (t_langtag >>= \lang -> return (plainLL str lang)) <|>- ((count 2 (char '^') >> t_iri >>= \iri -> return (typedL str iri))))+ option (plainL str) $+ try (t_langtag >>= \lang -> pure (plainLL str lang)) <|>+ (count 2 (char '^') *> t_iri >>= \iri -> pure (typedL str iri)) -- [17] String -- STRING_LITERAL_QUOTE | STRING_LITERAL_SINGLE_QUOTE | STRING_LITERAL_LONG_SINGLE_QUOTE | STRING_LITERAL_LONG_QUOTE-t_string :: GenParser ParseState T.Text+t_string :: (CharParsing m, Monad m) => m T.Text t_string = try t_string_literal_long_quote <|> try t_string_literal_long_single_quote <|> try t_string_literal_quote <|>@@ -375,18 +393,18 @@ -- [22] STRING_LITERAL_QUOTE -- '"' ([^#x22#x5C#xA#xD] | ECHAR | UCHAR)* '"'-t_string_literal_quote :: GenParser ParseState T.Text+t_string_literal_quote :: (CharParsing m, Monad m) => m T.Text t_string_literal_quote =- between (char '"') (char '"') $ do+ between (char '"') (char '"') $ T.concat <$> many (T.singleton <$> noneOf ['\x22','\x5C','\xA','\xD'] <|> t_echar <|> t_uchar) -- [23] STRING_LITERAL_SINGLE_QUOTE -- "'" ([^#x27#x5C#xA#xD] | ECHAR | UCHAR)* "'"-t_string_literal_single_quote :: GenParser ParseState T.Text+t_string_literal_single_quote :: (CharParsing m, Monad m) => m T.Text t_string_literal_single_quote =- between (char '\'') (char '\'') $ do+ between (char '\'') (char '\'') $ T.concat <$> many (T.singleton <$> noneOf ['\x27','\x5C','\xA','\xD'] <|> t_echar <|>@@ -394,128 +412,121 @@ -- [24] STRING_LITERAL_LONG_SINGLE_QUOTE -- "'''" (("'" | "''")? ([^'\] | ECHAR | UCHAR))* "'''"-t_string_literal_long_single_quote :: GenParser ParseState T.Text+t_string_literal_long_single_quote :: (CharParsing m, Monad m) => m T.Text t_string_literal_long_single_quote =- between ((string "'''")) ((string "'''")) $ do+ between (string "'''") (string "'''") $ do ss <- many $ try $ do s1 <- T.pack <$> option "" (try (string "''") <|> string "'") s2 <- T.singleton <$> noneOf ['\'','\\'] <|> t_echar <|> t_uchar- return (s1 `T.append` s2)- return (T.concat ss)+ pure (s1 `T.append` s2)+ pure (T.concat ss) -- [25] STRING_LITERAL_LONG_QUOTE -- '"""' (('"' | '""')? ([^"\] | ECHAR | UCHAR))* '"""'-t_string_literal_long_quote :: GenParser ParseState T.Text+t_string_literal_long_quote :: (CharParsing m, Monad m) => m T.Text t_string_literal_long_quote = between (string "\"\"\"") (string "\"\"\"") $ do ss <- many $ try $ do s1 <- T.pack <$> option "" (try (string "\"\"") <|> string "\"") s2 <- (T.singleton <$> noneOf ['"','\\']) <|> t_echar <|> t_uchar- return (s1 `T.append` s2)- return (T.concat ss)+ pure (s1 `T.append` s2)+ pure (T.concat ss) -- [144s] LANGTAG -- '@' [a-zA-Z]+ ('-' [a-zA-Z0-9]+)*-t_langtag :: GenParser ParseState T.Text+t_langtag :: (CharParsing m, Monad m) => m T.Text t_langtag = do- void (char '@')- ss <- many1 (satisfy (\ c -> isLetter c))- rest <- concat <$> many (char '-' >> many1 (satisfy (\ c -> isAlphaNum c)) >>= \lang_str -> return ('-':lang_str))- return (T.pack (ss ++ rest))+ ss <- char '@' *> some (satisfy isLetter)+ rest <- concat <$> many (char '-' *> some (satisfy isAlphaNum) >>= \lang_str -> pure ('-':lang_str))+ pure (T.pack (ss ++ rest)) -- [159s] ECHAR -- '\' [tbnrf"'\]-t_echar :: GenParser ParseState T.Text+t_echar :: (CharParsing m, Monad m) => m T.Text t_echar = try $ do- void (char '\\')- c2 <- oneOf ['t','b','n','r','f','"','\'','\\']- return $ case c2 of- 't' -> T.singleton '\t'- 'b' -> T.singleton '\b'- 'n' -> T.singleton '\n'- 'r' -> T.singleton '\r'- 'f' -> T.singleton '\f'- '"' -> T.singleton '\"'- '\'' -> T.singleton '\''- '\\' -> T.singleton '\\'- _ -> error "nt_echar: impossible error."+ c2 <- char '\\' *> oneOf ['t','b','n','r','f','"','\'','\\']+ case c2 of+ 't' -> pure $ T.singleton '\t'+ 'b' -> pure $ T.singleton '\b'+ 'n' -> pure $ T.singleton '\n'+ 'r' -> pure $ T.singleton '\r'+ 'f' -> pure $ T.singleton '\f'+ '"' -> pure $ T.singleton '\"'+ '\'' -> pure $ T.singleton '\''+ '\\' -> pure $ T.singleton '\\'+ _ -> fail "nt_echar: impossible error." -- [26] UCHAR -- '\u' HEX HEX HEX HEX | '\U' HEX HEX HEX HEX HEX HEX HEX HEX-t_uchar :: GenParser ParseState T.Text+t_uchar :: (CharParsing m, Monad m) => m T.Text t_uchar =- (try (string "\\u" >> count 4 hexDigit) >>= \cs -> return $ T.pack ('\\':'u':cs)) <|>- (char '\\' >> char 'U' >> count 8 hexDigit >>= \cs -> return $ T.pack ('\\':'U':cs))+ (try (string "\\u" *> count 4 hexDigit) >>= \cs -> pure $ T.pack ('\\':'u':cs)) <|>+ (char '\\' *> char 'U' *> count 8 hexDigit >>= \cs -> pure $ T.pack ('\\':'U':cs)) -- [19] INTEGER ::= [+-]? [0-9]+-t_integer :: GenParser ParseState T.Text+t_integer :: (CharParsing m, Monad m) => m T.Text t_integer = try $ do sign <- sign_parser <?> "+-"- ds <- many1 (oneOf ['0'..'9'] <?> "digit")- return $! ( T.pack sign `T.append` T.pack ds)+ ds <- some (satisfy isDigit <?> "digit")+ pure $! ( T.pack sign `T.append` T.pack ds) -- grammar rule: [21] DOUBLE -- [21] DOUBLE ::= [+-]? ([0-9]+ '.' [0-9]* EXPONENT | '.' [0-9]+ EXPONENT | [0-9]+ EXPONENT)-t_double :: GenParser ParseState T.Text+t_double :: (CharParsing m, Monad m) => m T.Text t_double = do sign <- sign_parser <?> "+-"- rest <- try (do { ds <- many1 (oneOf ['0'..'9']) <?> "digit";- void (char '.');- ds' <- many (oneOf ['0'..'9']) <?> "digit";+ rest <- try (do { ds <- (some (satisfy isDigit) <?> "digit") <* char '.';+ ds' <- many (satisfy isDigit) <?> "digit"; e <- t_exponent <?> "exponent";- return ( T.pack ds `T.snoc` '.' `T.append` T.pack ds' `T.append` e) }) <|>- try (do { void (char '.');- ds <- many1 (oneOf ['0'..'9']) <?> "digit";+ pure ( T.pack ds `T.snoc` '.' `T.append` T.pack ds' `T.append` e) }) <|>+ try (do { ds <- char '.' *> some (satisfy isDigit) <?> "digit"; e <- t_exponent <?> "exponent";- return ('.' `T.cons` T.pack ds `T.append` e) }) <|>- (do { ds <- many1 (oneOf ['0'..'9']) <?> "digit";+ pure ('.' `T.cons` T.pack ds `T.append` e) }) <|>+ (do { ds <- some (satisfy isDigit) <?> "digit"; e <- t_exponent <?> "exponent";- return ( T.pack ds `T.append` e) })- return $! T.pack sign `T.append` rest+ pure ( T.pack ds `T.append` e) })+ pure $! T.pack sign `T.append` rest -sign_parser :: GenParser ParseState String-sign_parser = option "" (oneOf "-+" >>= (\c -> return [c]))+sign_parser :: CharParsing m => m String+sign_parser = option "" (pure <$> oneOf "-+") -- [20] DECIMAL ::= [+-]? [0-9]* '.' [0-9]+-t_decimal :: GenParser ParseState T.Text+t_decimal :: (CharParsing m, Monad m) => m T.Text t_decimal = try $ do sign <- sign_parser- dig1 <- many (oneOf ['0'..'9'])- void (char '.')- dig2 <- many1 (oneOf ['0'..'9'])- return (T.pack sign `T.append` T.pack dig1 `T.append` T.pack "." `T.append` T.pack dig2)+ dig1 <- many (satisfy isDigit) <* char '.'+ dig2 <- some (satisfy isDigit)+ pure (T.pack sign `T.append` T.pack dig1 `T.append` T.pack "." `T.append` T.pack dig2) -t_exponent :: GenParser ParseState T.Text+t_exponent :: (CharParsing m, Monad m) => m T.Text t_exponent = do e <- oneOf "eE"- s <- option "" (oneOf "-+" >>= \c -> return [c])- ds <- many1 digit;- return $! (e `T.cons` ( T.pack s `T.append` T.pack ds))+ s <- option "" (pure <$> oneOf "-+")+ ds <- some digit+ pure $! (e `T.cons` ( T.pack s `T.append` T.pack ds)) -t_boolean :: GenParser ParseState T.Text+t_boolean :: CharParsing m => m T.Text t_boolean =- try (liftM T.pack (string "true") <|>- liftM T.pack (string "false"))+ T.pack <$> try (string "true" <|> string "false") -t_comment :: GenParser ParseState ()+t_comment :: CharParsing m => m () t_comment =- void (char '#' >> many (satisfy (\ c -> c /= '\n' && c /= '\r')))+ void (char '#' *> many (noneOf "\n\r")) -- [161s] WS ::= #x20 | #x9 | #xD | #xA-t_ws :: GenParser ParseState ()+t_ws :: CharParsing m => m () t_ws =- (void (try (char '\t' <|> char '\n' <|> char '\r' <|> char ' '))- <|> try t_comment)+ (void (try (oneOf "\t\n\r "))) <|> try t_comment <?> "whitespace-or-comment" -- grammar rule: [167s] PN_PREFIX-t_pn_prefix :: GenParser ParseState T.Text+t_pn_prefix :: (CharParsing m, MonadState ParseState m) => m T.Text t_pn_prefix = do i <- try t_pn_chars_base r <- option "" (many (try t_pn_chars <|> char '.')) -- TODO: ensure t_pn_chars is last char- return (T.pack (i:r))+ pure (T.pack (i:r)) -- [18] IRIREF-t_iriref :: GenParser ParseState T.Text+t_iriref :: (CharParsing m, MonadState ParseState m) => m T.Text t_iriref = between (char '<') (char '>') $ do iri <- T.concat <$> many ( T.singleton <$> noneOf (['\x00'..'\x20'] ++ ['<','>','"','{','}','|','^','`','\\']) <|>@@ -525,13 +536,13 @@ let iri' = escapeRDFSyntax iri validateURI (absolutizeUrl bUrl dUrl iri') -t_pn_chars :: GenParser ParseState Char+t_pn_chars :: CharParsing m => m Char t_pn_chars = t_pn_chars_u <|> char '-' <|> char '\x00B7' <|> satisfy f where f = flip in_range [('0', '9'), ('\x0300', '\x036F'), ('\x203F', '\x2040')] -- grammar rule: [163s] PN_CHARS_BASE-t_pn_chars_base :: GenParser ParseState Char+t_pn_chars_base :: CharParsing m => m Char t_pn_chars_base = try $ satisfy $ flip in_range blocks where blocks = [('A', 'Z'), ('a', 'z'), ('\x00C0', '\x00D6'),@@ -543,12 +554,14 @@ ('\x10000', '\xEFFFF')] -- grammar rule: [164s] PN_CHARS_U-t_pn_chars_u :: GenParser ParseState Char+t_pn_chars_u :: CharParsing m => m Char t_pn_chars_u = t_pn_chars_base <|> char '_' -- grammar rules: [171s] HEX-t_hex :: GenParser ParseState Char-t_hex = satisfy (\c -> isDigit c || (c >= 'A' && c <= 'F')) <?> "hexadecimal digit"+-- TODO Should this support lowercase hex characters? if so, use Char.isHexDigit+t_hex :: CharParsing m => m Char+-- t_hex = satisfy (\c -> isDigit c || (c >= 'A' && c <= 'F')) <?> "hexadecimal digit"+t_hex = satisfy isHexDigit <?> "hexadecimal digit" {-# INLINE in_range #-} in_range :: Char -> [(Char, Char)] -> Bool@@ -558,124 +571,127 @@ newBaseUrl Nothing url = BaseUrl url newBaseUrl (Just (BaseUrl bUrl)) url = BaseUrl $! mkAbsoluteUrl bUrl url -currGenIdLookup :: GenParser ParseState (Map String Int)-currGenIdLookup = getState >>= \(_, _, _, _, _, _, _, _, _, _,genMap) -> return genMap+currGenIdLookup :: MonadState ParseState m => m (Map String Int)+currGenIdLookup = gets $ \(_, _, _, _, _, _, _, _, _, _,genMap) -> genMap -addGenIdLookup :: String -> Int -> GenParser ParseState ()-addGenIdLookup genId counter = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts, genMap) ->- setState (bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts, Map.insert genId counter genMap)+addGenIdLookup :: MonadState ParseState m => String -> Int -> m ()+addGenIdLookup genId counter =+ modify $ \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts, genMap) ->+ (bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts, Map.insert genId counter genMap) -currBaseUrl :: GenParser ParseState (Maybe BaseUrl)-currBaseUrl = getState >>= \(bUrl, _, _, _, _, _, _, _, _, _,_) -> return bUrl+currBaseUrl :: MonadState ParseState m => m (Maybe BaseUrl)+currBaseUrl = gets $ \(bUrl, _, _, _, _, _, _, _, _, _,_) -> bUrl -currDocUrl :: GenParser ParseState (Maybe T.Text)-currDocUrl = getState >>= \(_, dUrl, _, _, _, _, _, _, _, _,_) -> return dUrl+currDocUrl :: MonadState ParseState m => m (Maybe T.Text)+currDocUrl = gets $ \(_, dUrl, _, _, _, _, _, _, _, _,_) -> dUrl -pushSubj :: Subject -> GenParser ParseState ()-pushSubj s = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts, genMap) ->- setState (bUrl, dUrl, i, pms, s:ss, ps, cs, subjC, subjBNodeList, ts, genMap)+pushSubj :: MonadState ParseState m => Subject -> m ()+pushSubj s = modify $ \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts, genMap) ->+ (bUrl, dUrl, i, pms, s:ss, ps, cs, subjC, subjBNodeList, ts, genMap) -popSubj :: GenParser ParseState Subject-popSubj = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts, genMap) ->- setState (bUrl, dUrl, i, pms, tail ss, ps, cs, subjC, subjBNodeList, ts, genMap) >>- when (null ss) (error "Cannot pop subject off empty stack.") >>- return (head ss)+popSubj :: (CharParsing m, MonadState ParseState m) => m Subject+popSubj = get >>= \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts, genMap) ->+ put (bUrl, dUrl, i, pms, tail ss, ps, cs, subjC, subjBNodeList, ts, genMap)+ *> when (null ss) (fail "Cannot pop subject off empty stack.")+ *> pure (head ss) -pushPred :: Predicate -> GenParser ParseState ()-pushPred p = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts, genMap) ->- setState (bUrl, dUrl, i, pms, ss, p:ps, cs, subjC, subjBNodeList, ts, genMap)+pushPred :: MonadState ParseState m => Predicate -> m ()+pushPred p = modify $ \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts, genMap) ->+ (bUrl, dUrl, i, pms, ss, p:ps, cs, subjC, subjBNodeList, ts, genMap) -popPred :: GenParser ParseState Predicate-popPred = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts, genMap) ->- setState (bUrl, dUrl, i, pms, ss, tail ps, cs, subjC, subjBNodeList, ts, genMap) >>- when (null ps) (error "Cannot pop predicate off empty stack.") >>- return (head ps)+popPred :: MonadState ParseState m => m Predicate+popPred = get >>= \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts, genMap) ->+ put (bUrl, dUrl, i, pms, ss, tail ps, cs, subjC, subjBNodeList, ts, genMap)+ *> when (null ps) (fail "Cannot pop predicate off empty stack.")+ *> pure (head ps) -isInColl :: GenParser ParseState Bool-isInColl = getState >>= \(_, _, _, _, _, _, cs, _, _, _, _) -> return . not . null $ cs+isInColl :: MonadState ParseState m => m Bool+isInColl = gets $ \(_, _, _, _, _, _, cs, _, _, _, _) -> not . null $ cs -isInSubjColl :: GenParser ParseState Bool-isInSubjColl = getState >>= \(_, _, _, _, _, _, _, xs, _, _, _) -> do- if null xs then return False else return (head xs)+isInSubjColl :: MonadState ParseState m => m Bool+isInSubjColl = gets $ \(_, _, _, _, _, _, _, xs, _, _, _) ->+ if null xs then False else (head xs) {--isInObjColl :: GenParser ParseState Bool-isInObjColl = getState >>= \(_, _, _, _, _, _, _, xs, _, _) -> do+isInObjColl :: (CharParsing m, MonadState ParseState m) => m Bool+isInObjColl = get >>= \(_, _, _, _, _, _, _, xs, _, _) -> do when (null xs) $ error "null in isInObjColl"- return (not (head xs))+ pure (not (head xs)) -} -pushSubjColl :: GenParser ParseState ()-pushSubjColl = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts, genMap) ->- setState (bUrl, dUrl, i, pms, s, p, cs, True:subjC, subjBNodeList, ts, genMap)+pushSubjColl :: MonadState ParseState m => m ()+pushSubjColl = modify $ \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts, genMap) ->+ (bUrl, dUrl, i, pms, s, p, cs, True:subjC, subjBNodeList, ts, genMap) -popColl :: GenParser ParseState ()-popColl = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts, genMap) -> do- when (null subjC) $ error "null in popColl"- setState (bUrl, dUrl, i, pms, s, p, cs, tail subjC, subjBNodeList, ts, genMap)+popColl :: (CharParsing m, MonadState ParseState m) => m ()+popColl = get >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts, genMap) -> do+ when (null subjC) $ fail "null in popColl"+ put (bUrl, dUrl, i, pms, s, p, cs, tail subjC, subjBNodeList, ts, genMap) -pushObjColl :: GenParser ParseState ()-pushObjColl = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts,genMap) ->- setState (bUrl, dUrl, i, pms, s, p, cs, False:subjC, subjBNodeList, ts,genMap)+pushObjColl :: MonadState ParseState m => m ()+pushObjColl = modify $ \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts,genMap) ->+ (bUrl, dUrl, i, pms, s, p, cs, False:subjC, subjBNodeList, ts,genMap) -isSubjPropList :: GenParser ParseState Bool-isSubjPropList = getState >>= \(_, _, _, _, _, _, _, _, subjBNodeList, _,_) -> do- return subjBNodeList+isSubjPropList :: MonadState ParseState m => m Bool+isSubjPropList = gets $ \(_, _, _, _, _, _, _, _, subjBNodeList, _,_) -> subjBNodeList {--isObjPropList :: GenParser ParseState Bool-isObjPropList = getState >>= \(_, _, _, _, _, _, _, _, subjBNodeList, _) -> do- return subjBNodeList+isObjPropList :: (CharParsing m, MonadState ParseState m) => m Bool+isObjPropList = get >>= \(_, _, _, _, _, _, _, _, subjBNodeList, _) -> do+ pure subjBNodeList -} -setSubjBlankNodePropList :: GenParser ParseState ()-setSubjBlankNodePropList = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, _, ts,genMap) ->- setState (bUrl, dUrl, i, pms, s, p, cs, subjC, True, ts,genMap)+setSubjBlankNodePropList :: MonadState ParseState m => m ()+setSubjBlankNodePropList =+ modify $ \(bUrl, dUrl, i, pms, s, p, cs, subjC, _, ts,genMap) ->+ (bUrl, dUrl, i, pms, s, p, cs, subjC, True, ts,genMap) -setNotSubjBlankNodePropList :: GenParser ParseState ()-setNotSubjBlankNodePropList = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, _, ts,genMap) ->- setState (bUrl, dUrl, i, pms, s, p, cs, subjC, True, ts,genMap)+setNotSubjBlankNodePropList :: MonadState ParseState m => m ()+setNotSubjBlankNodePropList =+ modify $ \(bUrl, dUrl, i, pms, s, p, cs, subjC, _, ts,genMap) ->+ (bUrl, dUrl, i, pms, s, p, cs, subjC, True, ts,genMap) --- setObjBlankNodePropList :: GenParser ParseState ()--- setObjBlankNodePropList = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, _, ts) ->--- setState (bUrl, dUrl, i, pms, s, p, cs, subjC, False, ts)+-- setObjBlankNodePropList :: (CharParsing m, Monad m) => m ()+-- setObjBlankNodePropList = get >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, _, ts) ->+-- put (bUrl, dUrl, i, pms, s, p, cs, subjC, False, ts) --- popBlankNodePropList :: GenParser ParseState ()--- popBlankNodePropList = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, _:subjBNodeList, ts) ->+-- popBlankNodePropList :: (CharParsing m, Monad m) => m ()+-- popBlankNodePropList = get >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, _:subjBNodeList, ts) -> -- when (null subjBNodeList) $ "no subj/obj flag to pop when exiting collection"--- setState (bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts)+-- put (bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts) -updateBaseUrl :: Maybe (Maybe BaseUrl) -> GenParser ParseState ()+updateBaseUrl :: MonadState ParseState m => Maybe (Maybe BaseUrl) -> m () updateBaseUrl val = _modifyState val no no no no no -- combines get_current and increment into a single function-nextIdCounter :: GenParser ParseState Int-nextIdCounter = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts,genMap) ->- setState (bUrl, dUrl, i+1, pms, s, p, cs, subjC, subjBNodeList, ts,genMap) >> return i+nextIdCounter :: MonadState ParseState m => m Int+nextIdCounter = get >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts,genMap) ->+ put (bUrl, dUrl, i+1, pms, s, p, cs, subjC, subjBNodeList, ts,genMap) *> pure i -updatePMs :: Maybe PrefixMappings -> GenParser ParseState ()+updatePMs :: MonadState ParseState m => Maybe PrefixMappings -> m () updatePMs val = _modifyState no no val no no no -- Register that we have begun processing a collection-beginColl :: GenParser ParseState ()-beginColl = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts,genMap) ->- setState (bUrl, dUrl, i, pms, s, p, True:cs, subjC, subjBNodeList, ts,genMap)+beginColl :: MonadState ParseState m => m ()+beginColl = modify $ \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts,genMap) ->+ (bUrl, dUrl, i, pms, s, p, True:cs, subjC, subjBNodeList, ts,genMap) -onCollFirstItem :: GenParser ParseState Bool-onCollFirstItem = getState >>= \(_, _, _, _, _, _, cs, _, _, _,_) -> return (not (null cs) && head cs)+onCollFirstItem :: MonadState ParseState m => m Bool+onCollFirstItem = gets $ \(_, _, _, _, _, _, cs, _, _, _,_) -> (not (null cs) && head cs) -collFirstItemProcessed :: GenParser ParseState ()-collFirstItemProcessed = getState >>= \(bUrl, dUrl, i, pms, s, p, _:cs, subjC, subjBNodeList, ts,genMap) ->- setState (bUrl, dUrl, i, pms, s, p, False:cs, subjC, subjBNodeList, ts,genMap)+collFirstItemProcessed :: MonadState ParseState m => m ()+collFirstItemProcessed =+ modify $ \(bUrl, dUrl, i, pms, s, p, _:cs, subjC, subjBNodeList, ts,genMap) ->+ (bUrl, dUrl, i, pms, s, p, False:cs, subjC, subjBNodeList, ts,genMap) -- Register that a collection is finished being processed; the bool value -- in the monad is *not* the value that was popped from the stack, but whether -- we are still processing a parent collection or have finished processing -- all collections and are no longer in a collection at all.-finishColl :: GenParser ParseState Bool-finishColl = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts,genMap) ->+finishColl :: MonadState ParseState m => m Bool+finishColl = get >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts,genMap) -> let cs' = drop 1 cs- in setState (bUrl, dUrl, i, pms, s, p, cs', subjC, subjBNodeList, ts,genMap) >> return (not $ null cs')+ in put (bUrl, dUrl, i, pms, s, p, cs', subjC, subjBNodeList, ts,genMap) *> pure (not $ null cs') -- Alias for Nothing for use with _modifyState calls, which can get very long with -- many Nothing values.@@ -683,19 +699,20 @@ no = Nothing -- Update the subject and predicate values of the ParseState to Nothing.-resetSubjectPredicate :: GenParser ParseState ()+resetSubjectPredicate :: MonadState ParseState m => m () resetSubjectPredicate =- getState >>= \(bUrl, dUrl, n, pms, _, _, cs, subjC, subjBNodeList, ts,genMap) ->- setState (bUrl, dUrl, n, pms, [], [], cs, subjC, subjBNodeList, ts,genMap)+ modify $ \(bUrl, dUrl, n, pms, _, _, cs, subjC, subjBNodeList, ts,genMap) ->+ (bUrl, dUrl, n, pms, [], [], cs, subjC, subjBNodeList, ts,genMap) -- Modifies the current parser state by updating any state values among the parameters -- that have non-Nothing values.-_modifyState :: Maybe (Maybe BaseUrl) -> Maybe (Int -> Int) -> Maybe PrefixMappings ->+_modifyState :: MonadState ParseState m =>+ Maybe (Maybe BaseUrl) -> Maybe (Int -> Int) -> Maybe PrefixMappings -> Maybe Subject -> Maybe Predicate -> Maybe (Seq Triple) ->- GenParser ParseState ()+ m () _modifyState mb_bUrl mb_n mb_pms mb_subj mb_pred mb_trps =- do (_bUrl, _dUrl, _n, _pms, _s, _p, _cs, _subjC, _subjBNodeList, _ts,genMap) <- getState- setState (fromMaybe _bUrl mb_bUrl,+ do (_bUrl, _dUrl, _n, _pms, _s, _p, _cs, _subjC, _subjBNodeList, _ts,genMap) <- get+ put (fromMaybe _bUrl mb_bUrl, _dUrl, maybe _n (const _n) mb_n, fromMaybe _pms mb_pms,@@ -706,15 +723,19 @@ _subjBNodeList, fromMaybe _ts mb_trps,genMap) -addTripleForObject :: Object -> GenParser ParseState ()+addTripleForObject :: (CharParsing m, MonadState ParseState m) => Object -> m () addTripleForObject obj =- do (bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts,genMap) <- getState+ do (bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts,genMap) <- get when (null ss) $ unexpected $ "No Subject with which to create triple for: " ++ show obj when (null ps) $ unexpected $ "No Predicate with which to create triple for: " ++ show obj- setState (bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts |> Triple (head ss) (head ps) obj,genMap)+ put (bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts |> Triple (head ss) (head ps) obj,genMap) ++---------------------------------+-- parsec based parsers+ -- |Parse the document at the given location URL as a Turtle document, using an optional @BaseUrl@ -- as the base URI, and using the given document URL as the URI of the Turtle document itself. --@@ -732,57 +753,88 @@ -- base URI against which the relative URI is resolved. -- -- Returns either a @ParseFailure@ or a new RDF containing the parsed triples.-parseURL' :: (Rdf a) =>+parseURLParsec :: (Rdf a) => 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. -> IO (Either ParseFailure (RDF a)) -- ^ The parse result, which is either a @ParseFailure@ or the RDF -- corresponding to the Turtle document.-parseURL' bUrl docUrl = _parseURL (parseString' bUrl docUrl)+parseURLParsec bUrl docUrl = _parseURL (parseStringParsec bUrl docUrl) -- |Parse the given file as a Turtle document. The arguments and return type have the same semantics -- as 'parseURL', except that the last @String@ argument corresponds to a filesystem location rather -- than a location URI. -- -- Returns either a @ParseFailure@ or a new RDF containing the parsed triples.-parseFile' :: (Rdf a) => Maybe BaseUrl -> Maybe T.Text -> String -> IO (Either ParseFailure (RDF a))-parseFile' bUrl docUrl fpath = do- TIO.readFile fpath >>= \bs' -> return $ handleResult bUrl (runParser t_turtleDoc initialState (maybe "" T.unpack docUrl) bs')- where initialState = (bUrl, docUrl, 1, PrefixMappings Map.empty, [], [], [], [], False, Seq.empty,Map.empty)+parseFileParsec :: (Rdf a) => Maybe BaseUrl -> Maybe T.Text -> String -> IO (Either ParseFailure (RDF a))+parseFileParsec bUrl docUrl fpath =+ TIO.readFile fpath >>= \bs' -> pure $ handleResult bUrl (runParser (evalStateT t_turtleDoc (initialState bUrl docUrl)) () (maybe "" T.unpack docUrl) bs') + -- |Parse the given string as a Turtle document. The arguments and return type have the same semantics -- as <parseURL>, except that the last @String@ argument corresponds to the Turtle document itself as -- a string rather than a location URI.-parseString' :: (Rdf a) => Maybe BaseUrl -> Maybe T.Text -> T.Text -> Either ParseFailure (RDF a)-parseString' bUrl docUrl ttlStr = handleResult bUrl (runParser t_turtleDoc initialState "" ttlStr)- where initialState = (bUrl, docUrl, 1, PrefixMappings Map.empty, [], [], [], [], False, Seq.empty,Map.empty)+parseStringParsec :: (Rdf a) => Maybe BaseUrl -> Maybe T.Text -> T.Text -> Either ParseFailure (RDF a)+parseStringParsec bUrl docUrl ttlStr = handleResult bUrl (runParser (evalStateT t_turtleDoc (initialState bUrl docUrl)) () "" ttlStr) ++---------------------------------+-- attoparsec based parsers++parseStringAttoparsec :: (Rdf a) => Maybe BaseUrl -> Maybe T.Text -> T.Text -> Either ParseFailure (RDF a)+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+ Partial f -> handleResult' (f (T.encodeUtf8 T.empty))+ Done _ (ts,pms) -> Right $! mkRdf (F.toList ts) bUrl pms++parseFileAttoparsec :: (Rdf a) => Maybe BaseUrl -> Maybe T.Text -> String -> IO (Either ParseFailure (RDF a))+parseFileAttoparsec bUrl docUrl path = parseStringAttoparsec bUrl docUrl <$> TIO.readFile path++parseURLAttoparsec :: (Rdf a) =>+ 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.+ -> IO (Either ParseFailure (RDF a))+ -- ^ The parse result, which is either a @ParseFailure@ or the RDF+ -- corresponding to the Turtle document.+parseURLAttoparsec bUrl docUrl = _parseURL (parseStringAttoparsec bUrl docUrl)++---------------------------------++initialState :: Maybe BaseUrl -> Maybe T.Text -> ParseState+initialState bUrl docUrl = (bUrl, docUrl, 1, PrefixMappings Map.empty, [], [], [], [], False, Seq.empty,Map.empty)++ handleResult :: Rdf a => Maybe BaseUrl -> Either ParseError (Seq Triple, PrefixMappings) -> Either ParseFailure (RDF a) handleResult bUrl result = 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 :: CharParsing m => T.Text -> m Node validateUNode t = case unodeValidate t of Nothing -> unexpected ("Invalid URI in Turtle parser URI validation: " ++ show t)- Just u@(UNode{}) -> return u+ Just u@UNode{} -> pure u Just node -> unexpected ("Unexpected node in Turtle parser URI validation: " ++ show node) -validateURI :: T.Text -> GenParser ParseState T.Text+validateURI :: (CharParsing m, Monad m) => T.Text -> m T.Text validateURI t = do UNode uri <- validateUNode t- return uri+ pure uri ++ -------------- -- auxiliary parsing functions -- Match the lowercase or uppercase form of 'c'-caseInsensitiveChar :: Char -> GenParser ParseState Char+caseInsensitiveChar :: CharParsing m => Char -> m Char caseInsensitiveChar c = char (toLower c) <|> char (toUpper c) -- Match the string 's', accepting either lowercase or uppercase form of each character-caseInsensitiveString :: String -> GenParser ParseState String+caseInsensitiveString :: (CharParsing m, Monad m) => String -> m String caseInsensitiveString s = try (mapM caseInsensitiveChar s) <?> "\"" ++ s ++ "\""
src/Text/RDF/RDF4H/XmlParser.hs view
@@ -7,7 +7,7 @@ XmlParser(XmlParser) ) where -import Control.Arrow (Arrow,(>>>),(<<<),(&&&),(***),arr,returnA)+import Control.Arrow ((>>>),(<<<),(&&&),(***),arr,returnA) import Control.Arrow.ArrowState (ArrowState,nextState) import Control.Exception import Data.List (isPrefixOf)@@ -139,7 +139,7 @@ <+> (second (getChildren >>> isElem) >>> parsePredicatesFromChildren) <+> (second (neg (hasName "rdf:Description") >>> neg (hasName "Description")) >>> arr2A readTypeTriple)) >>. replaceLiElems [] (1 :: Int)- where readTypeTriple :: (ArrowXml a, ArrowState GParseState a) => LParseState -> a XmlTree Triple+ where readTypeTriple :: (ArrowXml 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@@ -154,13 +154,13 @@ <+> (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, ArrowState GParseState a) => LParseState -> a XmlTree 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)) -- | Arrow to determine if special processing is required for an attribute-isMetaAttr :: forall a. (ArrowXml a, ArrowState GParseState a) => a String String+isMetaAttr :: forall a. (ArrowXml a) => a String String isMetaAttr = isA (== "rdf:about") <+> isA (== "rdf:nodeID") <+> isA (== "rdf:ID")@@ -196,7 +196,7 @@ -- _:a <rdf:foo> "foo" . -- -- And hence the use of `hasNamePrefix "rdf"`-isValidPropElemName :: (ArrowXml a, ArrowState GParseState a) => a XmlTree XmlTree+isValidPropElemName :: (ArrowXml a) => a XmlTree XmlTree isValidPropElemName = hasNamePrefix "rdf" -- hasName "rdf:Seq" -- <+> hasName "rdf:Bag"@@ -254,7 +254,7 @@ -- See https://www.w3.org/2000/03/rdf-tracking/ -- Section "Issue rdfms-rdf-names-use: Illegal or unusual use of names from the RDF namespace"-validPropElementName :: (ArrowXml a, ArrowState GParseState a) => a (LParseState,XmlTree) (LParseState,XmlTree)+validPropElementName :: (ArrowXml a) => a (LParseState,XmlTree) (LParseState,XmlTree) validPropElementName = proc (state,predXml) -> do neg (hasName "rdf:Description") -< predXml neg (hasName "rdf:RDF") -< predXml@@ -285,7 +285,7 @@ attachSubject :: Subject -> (Predicate, Object) -> Triple attachSubject s (p, o) = Triple s p o -reifyTriple :: forall a. (ArrowXml a, ArrowState GParseState a) => Subject -> a Triple Triples+reifyTriple :: forall a. (ArrowXml a) => Subject -> a Triple Triples reifyTriple node = arr (\(Triple s p o) -> [ Triple s p o , Triple node rdfType rdfStatement , Triple node rdfSubject s@@ -294,7 +294,7 @@ ]) -- |Updates the local state at a given node-updateState :: forall a. (ArrowXml a, ArrowState GParseState a)+updateState :: forall a. (ArrowXml a) => a (LParseState, XmlTree) (LParseState, XmlTree) updateState = ifA (second (hasAttr "xml:lang")) (arr2A readLang) (arr id) >>> ifA (second (hasAttr "xml:base")) (arr2A readBase) (arr id)@@ -302,11 +302,11 @@ readBase state = (getAttrValue0 "xml:base" >>> arr (\base -> state { stateBaseUrl = (BaseUrl . T.pack) base } ) ) &&& arr id -- |Read a Triple with an rdf:parseType of Literal-parseAsLiteralTriple :: forall a. (ArrowXml a, ArrowState GParseState a) => LParseState -> a XmlTree Triple+parseAsLiteralTriple :: forall a. (ArrowXml a) => LParseState -> a XmlTree Triple parseAsLiteralTriple state = (nameToUNode &&& (xshow getChildren >>> arr (mkTypedLiteralNode rdfXmlLiteral))) >>> arr (attachSubject (stateSubject state)) -mkCollectionTriples :: forall a. (ArrowXml a, ArrowState GParseState a) => a [(Triple, Node)] Triples+mkCollectionTriples :: forall a. (ArrowXml a) => a [(Triple, Node)] Triples mkCollectionTriples = arr (mkCollectionTriples' []) where mkCollectionTriples' [] ((Triple s1 p1 o1, n1):rest) = mkCollectionTriples' [Triple s1 p1 n1] ((Triple s1 p1 o1, n1):rest)@@ -317,16 +317,16 @@ mkCollectionTriples' _ [] = [] -- |Read a Triple and it's type when rdf:datatype is available-getTypedTriple :: forall a. (ArrowXml a, ArrowState GParseState a) => LParseState -> a XmlTree Triple+getTypedTriple :: forall a. (ArrowXml a) => LParseState -> a XmlTree Triple 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, ArrowState GParseState a)+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, ArrowState GParseState a)+getNodeIdTriple :: forall a. (ArrowXml a) => LParseState -> a XmlTree Triple getNodeIdTriple state = nameToUNode &&& (getAttrValue "rdf:nodeID" >>> arr (bnode . T.pack)) >>> arr (attachSubject (stateSubject state))@@ -342,7 +342,7 @@ -- See https://www.w3.org/2000/03/rdf-tracking/ -- Section "Issue rdfms-rdf-names-use: Illegal or unusual use of names from the RDF namespace"-validNodeElementName :: (ArrowXml a, ArrowState GParseState a) => a XmlTree XmlTree+validNodeElementName :: (ArrowXml a) => a XmlTree XmlTree validNodeElementName = neg (hasName "rdf:RDF") >>> neg (hasName "rdf:ID") >>> neg (hasName "rdf:about")@@ -375,13 +375,13 @@ where baseUrl = constA (case stateBaseUrl state of BaseUrl b -> T.unpack b) -- |Make a UNode from an absolute string-mkUNode :: forall a. (Arrow a, ArrowIf a) => a String Node+mkUNode :: forall a. (ArrowIf a) => a String Node mkUNode = choiceA [ (arr (isJust . unodeValidate . T.pack)) :-> (arr (fromJust . unodeValidate . T.pack)) , arr (\_ -> True) :-> arr (\uri -> throw (ParserException ("Invalid URI: " ++ uri))) ] -- |Make a UNode from a rdf:ID element, expanding relative URIs-mkRelativeNode :: forall a. (ArrowXml a, ArrowState GParseState a) => LParseState -> a XmlTree Node+mkRelativeNode :: forall a. (ArrowXml a) => LParseState -> a XmlTree Node mkRelativeNode s = (getAttrValue "rdf:ID" >>> arr (\x -> '#':x)) &&& baseUrl >>> expandURI >>> arr (unode . T.pack) where baseUrl = constA (case stateBaseUrl s of BaseUrl b -> T.unpack b)
− testsuite/tests/Data/RDF/Graph/AdjHashMap_Test.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module Data.RDF.Graph.AdjHashMap_Test (triplesOf',uniqTriplesOf',empty',mkRdf',addTriple',removeTriple') where--import Data.RDF.Types-import Data.RDF.Graph.AdjHashMap (AdjHashMap)-import Data.RDF.GraphTestUtils-import qualified Data.Map as Map-import Control.Monad--import Test.QuickCheck--instance Arbitrary (RDF AdjHashMap) where- arbitrary = liftM3 mkRdf arbitraryTs (return Nothing) (return $ PrefixMappings Map.empty)- --coarbitrary = undefined--empty' :: RDF AdjHashMap-empty' = empty--mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> RDF AdjHashMap-mkRdf' = mkRdf--triplesOf' :: RDF AdjHashMap -> Triples-triplesOf' = triplesOf--uniqTriplesOf' :: RDF AdjHashMap -> Triples-uniqTriplesOf' = uniqTriplesOf--addTriple' :: RDF AdjHashMap -> Triple -> RDF AdjHashMap-addTriple' = addTriple--removeTriple' :: RDF AdjHashMap -> Triple -> RDF AdjHashMap-removeTriple' = removeTriple
− testsuite/tests/Data/RDF/Graph/TList_Test.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module Data.RDF.Graph.TList_Test (empty',triplesOf',uniqTriplesOf',mkRdf',addTriple',removeTriple') where--import Control.Monad-import qualified Data.Map as Map-import Data.RDF.GraphTestUtils-import Data.RDF.Namespace-import Data.RDF.Graph.TList-import Data.RDF.Types-import Test.QuickCheck.Arbitrary--instance Arbitrary (RDF TList) where- arbitrary = liftM3 mkRdf arbitraryTs (return Nothing) (return $ PrefixMappings Map.empty)- --coarbitrary = undefined--empty' :: RDF TList-empty' = empty--mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> RDF TList-mkRdf' = mkRdf--triplesOf' :: RDF TList -> Triples-triplesOf' = triplesOf--uniqTriplesOf' :: RDF TList -> Triples-uniqTriplesOf' = uniqTriplesOf--addTriple' :: RDF TList -> Triple -> RDF TList-addTriple' = addTriple--removeTriple' :: RDF TList -> Triple -> RDF TList-removeTriple' = removeTriple
− testsuite/tests/Data/RDF/GraphTestUtils.hs
@@ -1,561 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module Data.RDF.GraphTestUtils (graphTests,arbitraryTs) where--import Data.RDF.Types-import Data.RDF.Query-import Data.RDF.Namespace-import Text.RDF.RDF4H.NTriplesSerializer-import qualified Data.Text as T-import Test.QuickCheck-import Data.List-import qualified Data.Set as Set-import qualified Data.Map as Map-import Control.Monad-import GHC.Generics ()-import System.Directory (removeFile)-import System.IO--import Test.Tasty-import Test.Tasty.QuickCheck-import Test.QuickCheck.Monadic (assert, monadicIO,run)--------------------------------------------------------- property based quick check test cases ---------------------------------------------------------graphTests- :: (Arbitrary (RDF rdf), Rdf rdf)- => TestName- -> (RDF rdf -> Triples) -- ^ triplesOf- -> (RDF rdf -> Triples) -- ^ uniqTriplesOf- -> RDF rdf -- ^ empty- -> (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) -- ^ mkRdf- -> (RDF rdf -> Triple -> RDF rdf) -- ^ addTriple- -> (RDF rdf -> Triple -> RDF rdf) -- ^ removeTriple- -> TestTree-graphTests testGroupName _triplesOf _uniqTriplesOf _empty _mkRdf _addTriple _removeTriple =- testGroup testGroupName- [- testProperty "empty" (p_empty _triplesOf _empty)- , testProperty "mkRdf_triplesOf" (p_mkRdf_triplesOf _triplesOf _mkRdf)- , testProperty "mkRdf_no_dupes" (p_mkRdf_no_dupes _uniqTriplesOf _mkRdf)- , testProperty "query_match_none" (p_query_match_none _mkRdf)- , testProperty "query_matched_spo" (p_query_matched_spo _triplesOf)- -- see comment above p_query_matched_spo_no_dupes for why this is disabled- -- , testProperty "query_matched_spo_no_dupes" (p_query_matched_spo_no_dupes _triplesOf _mkRdf)- , testProperty "query_unmatched_spo" (p_query_unmatched_spo _triplesOf)- , testProperty "query_match_s" (p_query_match_s _triplesOf)- , testProperty "query_match_p" (p_query_match_p _triplesOf)- , testProperty "query_match_o" (p_query_match_o _triplesOf)- , 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_s" (p_select_match_s _triplesOf)- , testProperty "select_match_p" (p_select_match_p _triplesOf)- , testProperty "select_match_o" (p_select_match_o _triplesOf)- , testProperty "select_match_sp" (p_select_match_sp _triplesOf)- , testProperty "select_match_so" (p_select_match_so _triplesOf)- , testProperty "select_match_po" (p_select_match_po _triplesOf)- , testProperty "select_match_spo" (p_select_match_spo _triplesOf)- , testProperty "reversed RDF handle write" (p_reverseRdfTest _mkRdf)-- -- adding and removing triples from a graph.- , testProperty "add_triple" (p_add_triple _mkRdf _triplesOf _addTriple)- , testProperty "remove_triple" (p_remove_triple _mkRdf _triplesOf _removeTriple)- , testProperty "remove_triple_from_graph" (p_remove_triple_from_graph _mkRdf _triplesOf _removeTriple)- , testProperty "remove_triple_from_singleton_graph_query_s" (p_remove_triple_from_singleton_graph_query_s _triplesOf _removeTriple)- , testProperty "remove_triple_from_singleton_graph_query_p" (p_remove_triple_from_singleton_graph_query_p _triplesOf _removeTriple)- , testProperty "remove_triple_from_singleton_graph_query_o" (p_remove_triple_from_singleton_graph_query_o _triplesOf _removeTriple)- ]--newtype SingletonGraph rdf = SingletonGraph { rdfGraph :: (RDF rdf) }--instance (Rdf rdf) => Arbitrary (SingletonGraph rdf) where- arbitrary = do- pref <- arbitraryPrefixMappings- baseU' <- arbitraryBaseUrl- baseU <- oneof [return (Just baseU'), return Nothing]- t <- liftM3 triple arbitraryS arbitraryP arbitraryO- return SingletonGraph { rdfGraph = (mkRdf [t] baseU pref) }--instance (Rdf rdf) => Show (SingletonGraph rdf) where- show singletonGraph = showGraph (rdfGraph singletonGraph)--instance Arbitrary BaseUrl where- arbitrary = arbitraryBaseUrl--instance Arbitrary PrefixMappings where- arbitrary = arbitraryPrefixMappings--arbitraryBaseUrl :: Gen BaseUrl-arbitraryBaseUrl = oneof $ map (return . BaseUrl . T.pack) ["http://example.com/a","http://asdf.org/b","http://asdf.org/c"]--arbitraryPrefixMappings :: Gen PrefixMappings-arbitraryPrefixMappings = 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 "eg3", T.pack "http://example.com/3")]]----- Test stubs, which just require the appropriate RDF impl function--- passed in to determine the implementation to be tested.---- empty RDF should have no triples-p_empty :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Bool-p_empty _triplesOf _empty = _triplesOf _empty == []---- triplesOf any RDF should return unique triples used to create it-p_mkRdf_triplesOf :: Rdf rdf => (RDF rdf -> Triples) -> (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) -> Triples -> Maybe BaseUrl -> PrefixMappings -> Bool-p_mkRdf_triplesOf _triplesOf _mkRdf ts bUrl pms =- uordered (_triplesOf (_mkRdf ts bUrl pms)) == uordered ts---- duplicate input triples should not be returned when--- uniqTriplesof is used-p_mkRdf_no_dupes :: Rdf rdf => (RDF rdf -> Triples) -> (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) -> Triples -> Maybe BaseUrl -> PrefixMappings -> Bool-p_mkRdf_no_dupes _uniqtriplesOf _mkRdf ts bUrl pms =- null ts || (sort result == uordered ts)- where- tsWithDupe = head ts : ts- result = _uniqtriplesOf $ _mkRdf tsWithDupe bUrl pms---- Note: in TriplesGraph and PatriciaTreeGraph `query` expands triples--- but `ts` here is not necessarily expanded. What is the correct--- property this test should check?------ query with all 3 wildcards should yield all triples in RDF-p_query_match_none :: Rdf rdf => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) -> Triples -> Maybe BaseUrl -> PrefixMappings -> Bool-p_query_match_none _mkRdf ts bUrl pms = uordered ts == uordered result- where- result = query (_mkRdf ts bUrl pms) Nothing Nothing Nothing---- query with no wildcard and a triple in the RDF should yield--- a singleton list with just the triple.-p_query_matched_spo :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_query_matched_spo _triplesOf rdf =- classify (null ts) "trivial" $- forAll (tripleFromGen _triplesOf rdf) f- where- ts = _triplesOf rdf- f t = case t of- Nothing -> True- (Just t') -> [t'] == queryT rdf t'--{- disabled:--- removing duplicates from `query` (and `select`) is deprecated, see--- https://github.com/cordawyn/rdf4h/commit/9dd4729908db8d2f80088706592adac81a0f3016------ query as in p_query_matched_spo after duplicating a triple in the--- RDF, so that we can verify that the results just have 1, even--- if the RDF itself doesn't ensure that there are no dupes internally.-p_query_matched_spo_no_dupes :: RDF rdf => (RDF rdf -> Triples) -> (Triples -> Maybe BaseUrl -> PrefixMappings -> rdf) -> rdf -> Property-p_query_matched_spo_no_dupes _triplesOf _mkRdf rdf =- classify (null ts) "trivial" $- forAll (tripleFromGen _triplesOf rdf) f- where- ts = _triplesOf rdf- f t = case t of- Nothing -> True- Just t' -> [t'] == queryT (mkRdfWithDupe _triplesOf _mkRdf rdf t') t'--}---- query with no wildcard and a triple no in the RDF should yield []-p_query_unmatched_spo :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Triple -> Property-p_query_unmatched_spo _triplesOf rdf t =- classify (t `elem` ts) "ignored" $- notElem t ts ==> [] == queryT rdf t- where- ts = _triplesOf rdf---- query with fixed subject and wildcards for pred and obj should yield--- a list with all triples having subject, and RDF minus result triples--- should yield all triple with unequal subjects.-p_query_match_s :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_query_match_s = mk_query_match_fn sameSubj f- where f t = (Just (subjectOf t), Nothing, Nothing)---- query w/ fixed predicate and wildcards for subj and obj should yield--- a list with all triples having predicate, and RDFgraph minus result triples--- should yield all triple with unequal predicates.-p_query_match_p :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_query_match_p = mk_query_match_fn samePred f- where f t = (Nothing, Just (predicateOf t), Nothing)---- likewise for fixed subject and predicate with object wildcard-p_query_match_o :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_query_match_o = mk_query_match_fn sameObj f- where f t = (Nothing, Nothing, Just (objectOf t))---- verify likewise for fixed subject and predicate with wildcard object-p_query_match_sp :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_query_match_sp = mk_query_match_fn same f- where same t1 t2 = sameSubj t1 t2 && samePred t1 t2- f t = (Just $ subjectOf t, Just $ predicateOf t, Nothing)---- fixed subject and object with wildcard predicate-p_query_match_so :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_query_match_so = mk_query_match_fn same f- where same t1 t2 = sameSubj t1 t2 && sameObj t1 t2- f t = (Just $ subjectOf t, Nothing, Just $ objectOf t)---- fixed predicate and object with wildcard subject-p_query_match_po :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_query_match_po = mk_query_match_fn same f- where same t1 t2 = samePred t1 t2 && sameObj t1 t2- f t = (Nothing, Just $ predicateOf t, Just $ objectOf t)--mk_query_match_fn :: Rdf rdf => (Triple -> Triple -> Bool)- -> (Triple -> (Maybe Node, Maybe Node, Maybe Node))- -> (RDF rdf -> Triples) -> RDF rdf -> Property-mk_query_match_fn tripleCompareFn mkPatternFn _triplesOf rdf =- forAll (tripleFromGen _triplesOf rdf) f- where- f :: Maybe Triple -> Bool- f Nothing = True- f (Just t) =- let- all_ts = _triplesOf rdf- all_ts_sorted = uordered all_ts- results = uordered $ queryC rdf (mkPatternFn t)- -- `notResults` is the difference of the two sets of triples- notResults = ldiff all_ts_sorted results- in- all (tripleCompareFn t) results &&- all (not . tripleCompareFn t) notResults--p_select_match_none :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Bool-p_select_match_none _triplesOf_not_used rdf = sort ts1 == sort ts2- where- ts1 = select rdf Nothing Nothing Nothing- -- ts2 = (nub . triplesOf) rdf-- -- may have duplicates, see comments in- -- https://github.com/cordawyn/rdf4h/commit/9dd4729908db8d2f80088706592adac81a0f3016- ts2 = triplesOf rdf--p_select_match_s :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_select_match_s =- p_select_match_fn same mkPattern- where- same = equivNode (==) subjectOf- mkPattern t = (Just (\n -> n == subjectOf t), Nothing, Nothing)--p_select_match_p :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_select_match_p =- p_select_match_fn same mkPattern- where- same = equivNode equiv predicateOf- equiv (UNode u1) (UNode u2) = T.last u1 == T.last u2- equiv _ _ = error "GraphTestUtils.p_select_match_p.equiv"- mkPattern t = (Nothing, Just (\n -> lastChar n == lastChar (predicateOf t)) , Nothing)- lastChar (UNode uri) = T.last uri- lastChar _ = error "GraphTestUtils.p_select_match_p.lastChar"---p_select_match_o :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_select_match_o =- p_select_match_fn same mkPattern- where- same = equivNode (/=) objectOf- mkPattern t = (Nothing, Nothing, Just (\n -> n /= objectOf t))--p_select_match_sp :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_select_match_sp =- p_select_match_fn same mkPattern- where- same t1 t2 = subjectOf t1 == subjectOf t2 && predicateOf t1 /= predicateOf t2- mkPattern t = (Just (\n -> n == subjectOf t), Just (\n -> n /= predicateOf t), Nothing)--p_select_match_so :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_select_match_so =- p_select_match_fn same mkPattern- where- same t1 t2 = subjectOf t1 /= subjectOf t2 && objectOf t1 == objectOf t2- mkPattern t = (Just (\n -> n /= subjectOf t), Nothing, Just (\n -> n == objectOf t))--p_select_match_po :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_select_match_po =- p_select_match_fn same mkPattern- where- same t1 t2 = predicateOf t1 == predicateOf t2 && objectOf t1 == objectOf t2- mkPattern t = (Nothing, Just (\n -> n == predicateOf t), Just (\n -> n == objectOf t))--p_select_match_spo :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Property-p_select_match_spo =- p_select_match_fn same mkPattern- where- same t1 t2 = subjectOf t1 == subjectOf t2 && predicateOf t1 == predicateOf t2 &&- objectOf t1 /= objectOf t2- mkPattern t = (Just (\n -> n == subjectOf t),- Just (\n -> n == predicateOf t),- Just (\n -> n /= objectOf t))---- |adding a triple to a graph.-p_add_triple- :: (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)- -> (RDF rdf -> Triples) -- ^ triplesOf- -> (RDF rdf -> Triple -> RDF rdf) -- ^ addTriple- -> Triples- -> Maybe BaseUrl- -> PrefixMappings- -> Triple -- ^ new triple to be added- -> Bool-p_add_triple _mkRdf _triplesOf _addTriple ts bUrl pms newTriple =- uordered (newTriple : _triplesOf oldGr)- == uordered (_triplesOf newGr) - where- oldGr = _mkRdf ts bUrl pms- newGr = _addTriple oldGr newTriple---- |removing a triple that may or may not be in a graph. If it is not,--- this operation is silently ignored.-p_remove_triple- :: (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)- -> (RDF rdf -> Triples) -- ^ triplesOf- -> (RDF rdf -> Triple -> RDF rdf) -- ^ removeTriple- -> Triples- -> Maybe BaseUrl- -> PrefixMappings- -> Triple -- ^ triple to be removed- -> Bool-p_remove_triple _mkRdf _triplesOf _removeTriple ts bUrl pms tripleToBeRemoved =- uordered (filter (/= tripleToBeRemoved) oldTriples)- == uordered newTriples- where- oldGr = _mkRdf ts bUrl pms- newGr = _removeTriple oldGr tripleToBeRemoved- oldTriples = _triplesOf oldGr- newTriples = _triplesOf newGr---- |removing a triple from a graph. The new graph should not contain--- any instances of the triple.-p_remove_triple_from_graph- :: (Rdf rdf)- => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)- -> (RDF rdf -> Triples) -- ^ triplesOf- -> (RDF rdf -> Triple -> RDF rdf) -- ^ removeTriple- -> Triples- -> Maybe BaseUrl- -> PrefixMappings- -> Property-p_remove_triple_from_graph _mkRdf _triplesOf _removeTriple ts bUrl pms =- classify (null ts) "p_remove_triple_from_graph tests were trivial" $- forAll (tripleFromGen _triplesOf (_mkRdf ts bUrl pms)) f- where- f :: Maybe Triple -> Bool- f Nothing = True- f (Just tripleToBeRemoved) =- p_remove_triple _mkRdf _triplesOf _removeTriple ts bUrl pms tripleToBeRemoved---- TODO: refactor the following 3 functions.---- |removing a triple from a graph that contained only that triple.--- Performing a ((Just s) Nothing Nothing) query should return an--- empty list.-p_remove_triple_from_singleton_graph_query_s- :: (Rdf rdf)- => (RDF rdf -> Triples) -- ^ triplesOf- -> (RDF rdf -> Triple -> RDF rdf) -- ^ removeTriple- -> SingletonGraph rdf- -> Bool-p_remove_triple_from_singleton_graph_query_s _tripleOf _removeTriple singletonGraph =- query newGr (Just s) Nothing Nothing == []- where- tripleInGraph@(Triple s _p _o) = head (_tripleOf (rdfGraph singletonGraph))- newGr = _removeTriple (rdfGraph singletonGraph) tripleInGraph---- |removing a triple from a graph that contained only that triple.--- Performing a (Nothing (Just p) Nothing) query should return an--- empty list.-p_remove_triple_from_singleton_graph_query_p- :: (Rdf rdf)- => (RDF rdf -> Triples) -- ^ triplesOf- -> (RDF rdf -> Triple -> RDF rdf) -- ^ removeTriple- -> SingletonGraph rdf- -> Bool-p_remove_triple_from_singleton_graph_query_p _tripleOf _removeTriple singletonGraph =- query newGr Nothing (Just p) Nothing == []- where- tripleInGraph@(Triple _s p _o) = head (_tripleOf (rdfGraph singletonGraph))- newGr = _removeTriple (rdfGraph singletonGraph) tripleInGraph---- |removing a triple from a graph that contained only that triple.--- Performing a (Nothing Nothing (Just o)) query should return an--- empty list.-p_remove_triple_from_singleton_graph_query_o- :: (Rdf rdf)- => (RDF rdf -> Triples) -- ^ triplesOf- -> (RDF rdf -> Triple -> RDF rdf) -- ^ removeTriple- -> SingletonGraph rdf- -> Bool-p_remove_triple_from_singleton_graph_query_o _tripleOf _removeTriple singletonGraph =- query newGr Nothing Nothing (Just o) == []- where- tripleInGraph@(Triple _s _p o) = head (_tripleOf (rdfGraph singletonGraph))- newGr = _removeTriple (rdfGraph singletonGraph) tripleInGraph-- --- p_query_match_none :: Rdf rdf => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) -> Triples -> Maybe BaseUrl -> PrefixMappings -> Bool--- p_query_match_none _mkRdf ts bUrl pms = uordered ts == uordered result- -- where- -- result = query (_mkRdf ts bUrl pms) Nothing Nothing Nothing---equivNode :: (Node -> Node -> Bool) -> (Triple -> Node) -> Triple -> Triple -> Bool-equivNode eqFn exFn t1 t2 = exFn t1 `eqFn` exFn t2--p_select_match_fn :: Rdf rdf => (Triple -> Triple -> Bool)- -> (Triple -> (NodeSelector, NodeSelector, NodeSelector))- -> (RDF rdf -> Triples) -> RDF rdf -> Property-p_select_match_fn tripleCompareFn mkPatternFn _triplesOf rdf =- forAll (tripleFromGen _triplesOf rdf) f- where- f :: Maybe Triple -> Bool- f Nothing = True- f (Just t) =- let- all_ts = triplesOf rdf- all_ts_sorted = uordered all_ts- results = uordered $ selectC rdf (mkPatternFn t)- notResults = ldiff all_ts_sorted results- in- all (tripleCompareFn t) results &&- all (not . tripleCompareFn t) notResults---- mkRdfWithDupe :: Rdf rdf => (RDF rdf -> Triples) -> (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) -> RDF rdf -> Triple -> RDF rdf--- mkRdfWithDupe _triplesOf _mkRdf rdf t = _mkRdf ts (baseUrl rdf) (prefixMappings rdf)--- where ts = t : _triplesOf rdf----- Utility functions and test data ... ------ a curried version of query that delegates to the actual query after unpacking--- curried maybe node pattern.-queryC :: Rdf rdf => RDF rdf -> (Maybe Node, Maybe Node, Maybe Node) -> Triples-queryC rdf (s, p, o) = query rdf s p o--selectC :: Rdf rdf => RDF rdf -> (NodeSelector, NodeSelector, NodeSelector) -> Triples-selectC rdf (s, p, o) = select rdf s p o---- uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d--- uncurry3 fn (x, y, z) = fn x y z---- curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d--- curry3 fn x y z = fn (x, y, z)---- debug :: String -> Triples -> Bool--- debug msg ts =--- unsafePerformIO $--- putStrLn msg >> mapM print ts >> return True--ldiff :: Triples -> Triples -> Triples-ldiff l1 l2 = Set.toList $(Set.fromList l1) `Set.difference` Set.fromList l2--sameSubj :: Triple -> Triple -> Bool-sameSubj t1 t2 = subjectOf t1 == subjectOf t2--samePred :: Triple -> Triple -> Bool-samePred t1 t2 = predicateOf t1 == predicateOf t2--sameObj :: Triple -> Triple -> Bool-sameObj t1 t2 = objectOf t1 == objectOf t2---- |pick a random triple from an RDF graph if the graph is not empty.-tripleFromGen :: Rdf rdf => (RDF rdf -> Triples) -> RDF rdf -> Gen (Maybe Triple)-tripleFromGen _triplesOf rdf =- if null ts- then return Nothing- else oneof $ map (return . Just) ts- where ts = _triplesOf rdf--queryT :: Rdf rdf => RDF rdf -> Triple -> Triples-queryT rdf t = query rdf (Just $ subjectOf t) (Just $ predicateOf t) (Just $ objectOf t)--languages :: [T.Text]-languages = [T.pack "fr", T.pack "en"]--datatypes :: [T.Text]-datatypes = map (mkUri xsd . T.pack) ["string", "int", "token"]--uris :: [T.Text]-uris = map (mkUri ex) [T.pack n `T.append` T.pack (show (i::Int)) | n <- ["foo", "bar", "quz", "zak"], i <- [0..9]]--plainliterals :: [LValue]-plainliterals = [plainLL lit lang | lit <- litvalues, lang <- languages]--typedliterals :: [LValue]-typedliterals = [typedL lit dtype | lit <- litvalues, dtype <- datatypes]--litvalues :: [T.Text]-litvalues = map T.pack ["hello", "world", "peace", "earth", "", "haskell"]--unodes :: [Node]-unodes = map UNode uris--bnodes :: [ Node]-bnodes = map (BNode . \i -> T.pack ":_genid" `T.append` T.pack (show (i::Int))) [1..5]--lnodes :: [Node]-lnodes = [LNode lit | lit <- plainliterals ++ typedliterals]--test_triples :: [Triple]-test_triples = [triple s p o | s <- unodes ++ bnodes, p <- unodes, o <- unodes ++ bnodes ++ lnodes]--maxN :: Int-maxN = min 100 (length test_triples - 1)--instance Arbitrary Triple where- arbitrary = liftM3 triple arbitraryS arbitraryP arbitraryO- --coarbitrary = undefined--instance Arbitrary Node where- arbitrary = oneof $ map return unodes- --coarbitrary = undefined---- arbitraryTNum :: Gen Int--- arbitraryTNum = choose (0, maxN - 1)--arbitraryTs :: Gen Triples-arbitraryTs = do- n <- sized (\_ -> choose (0, maxN))- sequence [arbitrary | _ <- [1..n]]---- arbitraryTriple :: Gen Triple--- arbitraryTriple = elements test_triples---- arbitraryN :: Gen Int--- arbitraryN = choose (0, maxN - 1)--arbitraryS, arbitraryP, arbitraryO :: Gen Node-arbitraryS = oneof $ map return $ unodes ++ bnodes-arbitraryP = oneof $ map return unodes-arbitraryO = oneof $ map return $ unodes ++ bnodes ++ lnodes--------------------------------------------------------- Unit test cases ----------------------------------------------------------- Reported by Daniel Bergey:--- https://github.com/robstewart57/rdf4h/issues/4--p_reverseRdfTest :: Rdf a => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF a) -> Property-p_reverseRdfTest _mkRdf = monadicIO $ do- fileContents <- Test.QuickCheck.Monadic.run $ do- (pathFile,hFile) <- openTempFile "." "tmp."- hWriteRdf NTriplesSerializer hFile rdfGraph- hClose hFile- contents <- readFile pathFile- removeFile pathFile- return contents- let expected = "<file:///this/is/not/a/palindrome> <file:///this/is/not/a/palindrome> \"literal string\" .\n"- assert $ expected == fileContents-- where- rdfGraph = _mkRdf ts (Just $ BaseUrl "file://") (ns_mappings [])-- ts :: [Triple]- ts = [Triple- (unode "file:///this/is/not/a/palindrome")- (unode "file:///this/is/not/a/palindrome")- (LNode . PlainL . T.pack $ "literal string")]
+ testsuite/tests/Data/RDF/PropertyTests.hs view
@@ -0,0 +1,631 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}++module Data.RDF.PropertyTests (graphTests,arbitraryTs) where++import Data.RDF+import Data.RDF.Namespace+import qualified Data.Text as T+import Test.QuickCheck+import Data.List+import qualified Data.Set as Set+import qualified Data.Map as Map+import Control.Monad+import GHC.Generics ()+import System.Directory (removeFile)+import System.IO++import Test.Tasty+import Test.Tasty.QuickCheck+import Test.QuickCheck.Monadic (assert, monadicIO,run)++----------------------------------------------------+-- property based quick check test cases --+----------------------------------------------------++graphTests+ :: (Arbitrary (RDF rdf), Rdf rdf)+ => TestName+ -> RDF rdf -- ^ empty+ -> (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) -- ^ mkRdf+ -> TestTree+graphTests testGroupName _empty _mkRdf =+ testGroup+ testGroupName+ [ testProperty "empty" (p_empty _empty)+ , testProperty "mkRdf_triplesOf" (p_mkRdf_triplesOf _mkRdf)+ , testProperty "mkRdf_no_dupes" (p_mkRdf_no_dupes _mkRdf)+ , testProperty "query_match_none" (p_query_match_none _mkRdf)+ , testProperty "query_matched_spo" (p_query_matched_spo _empty)+ -- see comment above p_query_matched_spo_no_dupes for why this is disabled+ -- , testProperty "query_matched_spo_no_dupes" (p_query_matched_spo_no_dupes _triplesOf _mkRdf)+ , testProperty "query_unmatched_spo" (p_query_unmatched_spo _empty)+ , testProperty "query_match_s" (p_query_match_s _empty)+ , testProperty "query_match_p" (p_query_match_p _empty)+ , testProperty "query_match_o" (p_query_match_o _empty)+ , testProperty "query_match_sp" (p_query_match_sp _empty)+ , testProperty "query_match_so" (p_query_match_so _empty)+ , testProperty "query_match_po" (p_query_match_po _empty)+ , testProperty "select_match_none" (p_select_match_none _empty)+ , testProperty "select_match_s" (p_select_match_s _empty)+ , testProperty "select_match_p" (p_select_match_p _empty)+ , testProperty "select_match_o" (p_select_match_o _empty)+ , testProperty "select_match_sp" (p_select_match_sp _empty)+ , testProperty "select_match_so" (p_select_match_so _empty)+ , testProperty "select_match_po" (p_select_match_po _empty)+ , testProperty "select_match_spo" (p_select_match_spo _empty)+ , testProperty "reversed RDF handle write" (p_reverseRdfTest _mkRdf)+ -- adding and removing triples from a graph.+ , testProperty "add_triple" (p_add_triple _mkRdf)+ , testProperty "remove_triple" (p_remove_triple _mkRdf)+ , testProperty+ "remove_triple_from_graph"+ (p_remove_triple_from_graph _mkRdf)+ , testProperty+ "remove_triple_from_singleton_graph_query_s"+ (p_remove_triple_from_singleton_graph_query_s _empty)+ , testProperty+ "remove_triple_from_singleton_graph_query_p"+ (p_remove_triple_from_singleton_graph_query_p _empty)+ , testProperty+ "remove_triple_from_singleton_graph_query_o"+ (p_remove_triple_from_singleton_graph_query_o _empty)+ , testProperty+ "p_add_then_remove_triples"+ (p_add_then_remove_triples _empty)+ ]++newtype SingletonGraph rdf = SingletonGraph+ { rdfGraph :: (RDF rdf)+ }++instance (Rdf rdf) =>+ Arbitrary (SingletonGraph rdf) where+ arbitrary = do+ pref <- arbitraryPrefixMappings+ baseU' <- arbitraryBaseUrl+ baseU <- oneof [return (Just baseU'), return Nothing]+ t <- liftM3 triple arbitraryS arbitraryP arbitraryO+ return SingletonGraph {rdfGraph = (mkRdf [t] baseU pref)}++instance (Rdf rdf) =>+ Show (SingletonGraph rdf) where+ show singletonGraph = showGraph (rdfGraph singletonGraph)++instance Arbitrary BaseUrl where+ arbitrary = arbitraryBaseUrl++instance Arbitrary PrefixMappings where+ arbitrary = arbitraryPrefixMappings++arbitraryBaseUrl :: Gen BaseUrl+arbitraryBaseUrl =+ oneof $+ map+ (return . BaseUrl . T.pack)+ ["http://example.com/a", "http://asdf.org/b", "http://asdf.org/c"]++arbitraryPrefixMappings :: Gen PrefixMappings+arbitraryPrefixMappings =+ 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 "eg3", T.pack "http://example.com/3")+ ]+ ]+++-- Test stubs, which just require the appropriate RDF impl function+-- passed in to determine the implementation to be tested.++-- empty RDF should have no triples+p_empty+ :: Rdf rdf+ => RDF rdf -> Bool+p_empty _empty = triplesOf _empty == []++-- triplesOf any RDF should return unique triples used to create it+p_mkRdf_triplesOf+ :: Rdf rdf+ => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)+ -> Triples+ -> Maybe BaseUrl+ -> PrefixMappings+ -> Bool+p_mkRdf_triplesOf _mkRdf ts bUrl pms =+ uordered (triplesOf (_mkRdf ts bUrl pms)) == uordered ts++-- duplicate input triples should not be returned when+-- uniqTriplesof is used+p_mkRdf_no_dupes+ :: Rdf rdf+ => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)+ -> Triples+ -> Maybe BaseUrl+ -> PrefixMappings+ -> Bool+p_mkRdf_no_dupes _mkRdf ts bUrl pms = null ts || (sort result == uordered ts)+ where+ tsWithDupe = head ts : ts+ result = uniqTriplesOf $ _mkRdf tsWithDupe bUrl pms++-- Note: in TriplesGraph and PatriciaTreeGraph `query` expands triples+-- but `ts` here is not necessarily expanded. What is the correct+-- property this test should check?+--+-- query with all 3 wildcards should yield all triples in RDF+p_query_match_none+ :: Rdf rdf+ => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)+ -> Triples+ -> Maybe BaseUrl+ -> PrefixMappings+ -> Bool+p_query_match_none _mkRdf ts bUrl pms = uordered ts == uordered result+ where+ result = query (_mkRdf ts bUrl pms) Nothing Nothing Nothing++-- query with no wildcard and a triple in the RDF should yield+-- a singleton list with just the triple.+p_query_matched_spo+ :: Rdf rdf+ => RDF rdf -> RDF rdf -> Property+p_query_matched_spo _unused rdf =+ classify (null ts) "trivial" $ forAll (tripleFromGen triplesOf rdf) f+ where+ ts = triplesOf rdf+ f t =+ case t of+ Nothing -> True+ (Just t') -> [t'] == queryT rdf t'++{- disabled:+-- removing duplicates from `query` (and `select`) is deprecated, see+-- https://github.com/cordawyn/rdf4h/commit/9dd4729908db8d2f80088706592adac81a0f3016+--+-- query as in p_query_matched_spo after duplicating a triple in the+-- RDF, so that we can verify that the results just have 1, even+-- if the RDF itself doesn't ensure that there are no dupes internally.+p_query_matched_spo_no_dupes :: RDF rdf => (RDF rdf -> Triples) -> (Triples -> Maybe BaseUrl -> PrefixMappings -> rdf) -> rdf -> Property+p_query_matched_spo_no_dupes _triplesOf _mkRdf rdf =+ classify (null ts) "trivial" $+ forAll (tripleFromGen _triplesOf rdf) f+ where+ ts = _triplesOf rdf+ f t = case t of+ Nothing -> True+ Just t' -> [t'] == queryT (mkRdfWithDupe _triplesOf _mkRdf rdf t') t'+-}++-- query with no wildcard and a triple no in the RDF should yield []+p_query_unmatched_spo+ :: Rdf rdf+ => RDF rdf -> Triple -> Property+p_query_unmatched_spo rdf t =+ classify (t `elem` ts) "ignored" $ notElem t ts ==> [] == queryT rdf t+ where+ ts = triplesOf rdf++-- query with fixed subject and wildcards for pred and obj should yield+-- a list with all triples having subject, and RDF minus result triples+-- should yield all triple with unequal subjects.+p_query_match_s+ :: Rdf rdf+ => RDF rdf -> RDF rdf -> Property+p_query_match_s _unused = mk_query_match_fn sameSubj f+ where+ f t = (Just (subjectOf t), Nothing, Nothing)++-- query w/ fixed predicate and wildcards for subj and obj should yield+-- a list with all triples having predicate, and RDFgraph minus result triples+-- should yield all triple with unequal predicates.+p_query_match_p+ :: Rdf rdf+ => RDF rdf -> RDF rdf -> Property+p_query_match_p _unused = mk_query_match_fn samePred f+ where+ f t = (Nothing, Just (predicateOf t), Nothing)++-- likewise for fixed subject and predicate with object wildcard+p_query_match_o+ :: Rdf rdf+ => RDF rdf -> RDF rdf -> Property+p_query_match_o _unused = mk_query_match_fn sameObj f+ where+ f t = (Nothing, Nothing, Just (objectOf t))++-- verify likewise for fixed subject and predicate with wildcard object+p_query_match_sp+ :: Rdf rdf+ => RDF rdf -> RDF rdf -> Property+p_query_match_sp _unsed = mk_query_match_fn same f+ where+ same t1 t2 = sameSubj t1 t2 && samePred t1 t2+ f t = (Just $ subjectOf t, Just $ predicateOf t, Nothing)++-- fixed subject and object with wildcard predicate+p_query_match_so+ :: Rdf rdf+ => RDF rdf -> RDF rdf -> Property+p_query_match_so _unused = mk_query_match_fn same f+ where+ same t1 t2 = sameSubj t1 t2 && sameObj t1 t2+ f t = (Just $ subjectOf t, Nothing, Just $ objectOf t)++-- fixed predicate and object with wildcard subject+p_query_match_po+ :: Rdf rdf+ => RDF rdf -> RDF rdf -> Property+p_query_match_po _unused = mk_query_match_fn same f+ where+ same t1 t2 = samePred t1 t2 && sameObj t1 t2+ f t = (Nothing, Just $ predicateOf t, Just $ objectOf t)++mk_query_match_fn+ :: Rdf rdf+ => (Triple -> Triple -> Bool)+ -> (Triple -> (Maybe Node, Maybe Node, Maybe Node))+ -> RDF rdf+ -> Property+mk_query_match_fn tripleCompareFn mkPatternFn rdf =+ forAll (tripleFromGen triplesOf rdf) f+ where+ f :: Maybe Triple -> Bool+ f Nothing = True+ f (Just t) =+ let all_ts = triplesOf rdf+ all_ts_sorted = uordered all_ts+ results = uordered $ queryC rdf (mkPatternFn t)+ -- `notResults` is the difference of the two sets of triples+ notResults = ldiff all_ts_sorted results+ in all (tripleCompareFn t) results &&+ all (not . tripleCompareFn t) notResults++p_select_match_none+ :: Rdf rdf+ => RDF rdf -> Bool+p_select_match_none rdf = sort ts1 == sort ts2+ where+ ts1 = select rdf Nothing Nothing Nothing+ -- ts2 = (nub . triplesOf) rdf+ -- may have duplicates, see comments in+ -- https://github.com/cordawyn/rdf4h/commit/9dd4729908db8d2f80088706592adac81a0f3016+ ts2 = triplesOf rdf++p_select_match_s+ :: Rdf rdf+ => RDF rdf -> Property+p_select_match_s = p_select_match_fn same mkPattern triplesOf+ where+ same = equivNode (==) subjectOf+ mkPattern t = (Just (\n -> n == subjectOf t), Nothing, Nothing)++p_select_match_p+ :: Rdf rdf+ => RDF rdf -> Property+p_select_match_p = p_select_match_fn same mkPattern triplesOf+ where+ same = equivNode equiv predicateOf+ equiv (UNode u1) (UNode u2) = T.last u1 == T.last u2+ equiv _ _ = error "GraphTestUtils.p_select_match_p.equiv"+ mkPattern t =+ (Nothing, Just (\n -> lastChar n == lastChar (predicateOf t)), Nothing)+ lastChar (UNode uri) = T.last uri+ lastChar _ = error "GraphTestUtils.p_select_match_p.lastChar"+++p_select_match_o :: Rdf rdf => RDF rdf -> Property+p_select_match_o =+ p_select_match_fn same mkPattern triplesOf+ where+ same = equivNode (/=) objectOf+ mkPattern t = (Nothing, Nothing, Just (\n -> n /= objectOf t))++p_select_match_sp :: Rdf rdf => RDF rdf -> Property+p_select_match_sp =+ p_select_match_fn same mkPattern triplesOf+ where+ same t1 t2 = subjectOf t1 == subjectOf t2 && predicateOf t1 /= predicateOf t2+ mkPattern t = (Just (\n -> n == subjectOf t), Just (\n -> n /= predicateOf t), Nothing)++p_select_match_so+ :: Rdf rdf+ => RDF rdf -> Property+p_select_match_so = p_select_match_fn same mkPattern triplesOf+ where+ same t1 t2 = subjectOf t1 /= subjectOf t2 && objectOf t1 == objectOf t2+ mkPattern t =+ (Just (\n -> n /= subjectOf t), Nothing, Just (\n -> n == objectOf t))++p_select_match_po+ :: Rdf rdf+ => RDF rdf -> RDF rdf -> Property+p_select_match_po _unsed = p_select_match_fn same mkPattern triplesOf+ where+ same t1 t2 = predicateOf t1 == predicateOf t2 && objectOf t1 == objectOf t2+ mkPattern t =+ (Nothing, Just (\n -> n == predicateOf t), Just (\n -> n == objectOf t))++p_select_match_spo+ :: (Rdf rdf)+ => RDF rdf -> RDF rdf -> Property+p_select_match_spo _unused = p_select_match_fn same mkPattern triplesOf+ where+ same t1 t2 =+ subjectOf t1 == subjectOf t2 &&+ predicateOf t1 == predicateOf t2 && objectOf t1 /= objectOf t2+ mkPattern t =+ ( Just (\n -> n == subjectOf t)+ , Just (\n -> n == predicateOf t)+ , Just (\n -> n /= objectOf t))++-- |adding a triple to a graph.+p_add_triple+ :: (Rdf rdf)+ => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)+ -> Triples+ -> Maybe BaseUrl+ -> PrefixMappings+ -> Triple -- ^ new triple to be added+ -> Bool+p_add_triple _mkRdf ts bUrl pms newTriple =+ uordered (newTriple : triplesOf oldGr) == uordered (triplesOf newGr)+ where+ oldGr = _mkRdf ts bUrl pms+ newGr = addTriple oldGr newTriple++-- |removing a triple that may or may not be in a graph. If it is not,+-- this operation is silently ignored.+p_remove_triple+ :: (Rdf rdf)+ => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)+ -> Triples+ -> Maybe BaseUrl+ -> PrefixMappings+ -> Triple -- ^ triple to be removed+ -> Bool+p_remove_triple _mkRdf ts bUrl pms tripleToBeRemoved =+ uordered (filter (/= tripleToBeRemoved) oldTriples) == uordered newTriples+ where+ oldGr = _mkRdf ts bUrl pms+ newGr = removeTriple oldGr tripleToBeRemoved+ oldTriples = triplesOf oldGr+ newTriples = triplesOf newGr++-- |removing a triple from a graph. The new graph should not contain+-- any instances of the triple.+p_remove_triple_from_graph+ :: (Rdf rdf)+ => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)+ -> Triples+ -> Maybe BaseUrl+ -> PrefixMappings+ -> Property+p_remove_triple_from_graph _mkRdf ts bUrl pms =+ classify (null ts) "p_remove_triple_from_graph tests were trivial" $+ forAll (tripleFromGen triplesOf (_mkRdf ts bUrl pms)) f+ where+ f :: Maybe Triple -> Bool+ f Nothing = True+ f (Just tripleToBeRemoved) =+ p_remove_triple _mkRdf ts bUrl pms tripleToBeRemoved++-- TODO: refactor the following 3 functions.++-- |removing a triple from a graph that contained only that triple.+-- Performing a ((Just s) Nothing Nothing) query should return an+-- empty list.+p_remove_triple_from_singleton_graph_query_s+ :: (Rdf rdf)+ => RDF rdf -> SingletonGraph rdf -> Bool+p_remove_triple_from_singleton_graph_query_s _unused singletonGraph =+ query newGr (Just s) Nothing Nothing == []+ where+ tripleInGraph@(Triple s _p _o) = head (triplesOf (rdfGraph singletonGraph))+ newGr = removeTriple (rdfGraph singletonGraph) tripleInGraph++-- |removing a triple from a graph that contained only that triple.+-- Performing a (Nothing (Just p) Nothing) query should return an+-- empty list.+p_remove_triple_from_singleton_graph_query_p+ :: (Rdf rdf)+ => RDF rdf -> SingletonGraph rdf -> Bool+p_remove_triple_from_singleton_graph_query_p _unused singletonGraph =+ query newGr Nothing (Just p) Nothing == []+ where+ tripleInGraph@(Triple _s p _o) = head (triplesOf (rdfGraph singletonGraph))+ newGr = removeTriple (rdfGraph singletonGraph) tripleInGraph++-- |removing a triple from a graph that contained only that triple.+-- Performing a (Nothing Nothing (Just o)) query should return an+-- empty list.+p_remove_triple_from_singleton_graph_query_o+ :: (Rdf rdf)+ => RDF rdf -> SingletonGraph rdf -> Bool+p_remove_triple_from_singleton_graph_query_o _unused singletonGraph =+ query newGr Nothing Nothing (Just o) == []+ where+ tripleInGraph@(Triple _s _p o) = head (triplesOf (rdfGraph singletonGraph))+ newGr = removeTriple (rdfGraph singletonGraph) tripleInGraph++p_add_then_remove_triples+ :: (Rdf rdf)+ => RDF rdf -- ^ empty+ -> Triples -- ^ triples to add then remove+ -> Bool+p_add_then_remove_triples _empty genTriples =+ let emptyGraph = _empty+ populatedGraph =+ foldr (\triple gr -> addTriple gr triple) emptyGraph genTriples+ emptiedGraph =+ foldr (\triple gr -> removeTriple gr triple) populatedGraph genTriples+ in triplesOf emptiedGraph == []++equivNode :: (Node -> Node -> Bool)+ -> (Triple -> Node)+ -> Triple+ -> Triple+ -> Bool+equivNode eqFn exFn t1 t2 = exFn t1 `eqFn` exFn t2++p_select_match_fn+ :: Rdf rdf+ => (Triple -> Triple -> Bool)+ -> (Triple -> (NodeSelector, NodeSelector, NodeSelector))+ -> (RDF rdf -> Triples)+ -> RDF rdf+ -> Property+p_select_match_fn tripleCompareFn mkPatternFn _triplesOf rdf =+ forAll (tripleFromGen _triplesOf rdf) f+ where+ f :: Maybe Triple -> Bool+ f Nothing = True+ f (Just t) =+ let all_ts = triplesOf rdf+ all_ts_sorted = uordered all_ts+ results = uordered $ selectC rdf (mkPatternFn t)+ notResults = ldiff all_ts_sorted results+ in all (tripleCompareFn t) results &&+ all (not . tripleCompareFn t) notResults++-- Utility functions and test data ... --++-- a curried version of query that delegates to the actual query after unpacking+-- curried maybe node pattern.+queryC+ :: Rdf rdf+ => RDF rdf -> (Maybe Node, Maybe Node, Maybe Node) -> Triples+queryC rdf (s, p, o) = query rdf s p o++selectC+ :: Rdf rdf+ => RDF rdf -> (NodeSelector, NodeSelector, NodeSelector) -> Triples+selectC rdf (s, p, o) = select rdf s p o++ldiff :: Triples -> Triples -> Triples+ldiff l1 l2 = Set.toList $(Set.fromList l1) `Set.difference` Set.fromList l2++sameSubj :: Triple -> Triple -> Bool+sameSubj t1 t2 = subjectOf t1 == subjectOf t2++samePred :: Triple -> Triple -> Bool+samePred t1 t2 = predicateOf t1 == predicateOf t2++sameObj :: Triple -> Triple -> Bool+sameObj t1 t2 = objectOf t1 == objectOf t2++-- |pick a random triple from an RDF graph if the graph is not empty.+tripleFromGen+ :: (RDF rdf -> Triples) -> RDF rdf -> Gen (Maybe Triple)+tripleFromGen _triplesOf rdf =+ if null ts+ then return Nothing+ else oneof $ map (return . Just) ts+ where+ ts = _triplesOf rdf++queryT+ :: Rdf rdf+ => RDF rdf -> Triple -> Triples+queryT rdf t =+ query rdf (Just $ subjectOf t) (Just $ predicateOf t) (Just $ objectOf t)++languages :: [T.Text]+languages = [T.pack "fr", T.pack "en"]++datatypes :: [T.Text]+datatypes = map (mkUri xsd . T.pack) ["string", "int", "token"]++uris :: [T.Text]+uris = map (mkUri ex) [T.pack n `T.append` T.pack (show (i::Int)) | n <- ["foo", "bar", "quz", "zak"], i <- [0..9]]++plainliterals :: [LValue]+plainliterals = [plainLL lit lang | lit <- litvalues, lang <- languages]++typedliterals :: [LValue]+typedliterals = [typedL lit dtype | lit <- litvalues, dtype <- datatypes]++litvalues :: [T.Text]+litvalues = map T.pack ["hello", "world", "peace", "earth", "", "haskell"]++unodes :: [Node]+unodes = map UNode uris++bnodes :: [ Node]+bnodes = map (BNode . \i -> T.pack ":_genid" `T.append` T.pack (show (i::Int))) [1..5]++lnodes :: [Node]+lnodes = [LNode lit | lit <- plainliterals ++ typedliterals]++test_triples :: [Triple]+test_triples =+ [ triple s p o+ | s <- unodes ++ bnodes+ , p <- unodes+ , o <- unodes ++ bnodes ++ lnodes+ ]++maxN :: Int+maxN = min 100 (length test_triples - 1)++instance Arbitrary Triple where+ arbitrary = liftM3 triple arbitraryS arbitraryP arbitraryO++instance Arbitrary Node where+ arbitrary = oneof $ map return unodes++arbitraryTs :: Gen Triples+arbitraryTs = do+ n <- sized (\_ -> choose (0, maxN))+ sequence [arbitrary | _ <- [1 .. n]]++-- arbitraryTriple :: Gen Triple+-- arbitraryTriple = elements test_triples++-- arbitraryN :: Gen Int+-- arbitraryN = choose (0, maxN - 1)++-- arbitraryTNum :: Gen Int+-- arbitraryTNum = choose (0, maxN - 1)++arbitraryS, arbitraryP, arbitraryO :: Gen Node+arbitraryS = oneof $ map return $ unodes ++ bnodes+arbitraryP = oneof $ map return unodes+arbitraryO = oneof $ map return $ unodes ++ bnodes ++ lnodes++----------------------------------------------------+-- Unit test cases --+----------------------------------------------------++-- Reported by Daniel Bergey:+-- https://github.com/robstewart57/rdf4h/issues/4++p_reverseRdfTest+ :: Rdf a+ => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF a) -> Property+p_reverseRdfTest _mkRdf =+ monadicIO $ do+ fileContents <-+ Test.QuickCheck.Monadic.run $ do+ (pathFile, hFile) <- openTempFile "." "tmp."+ hWriteRdf NTriplesSerializer hFile rdfGraph+ hClose hFile+ contents <- readFile pathFile+ removeFile pathFile+ return contents+ let expected =+ "<file:///this/is/not/a/palindrome> <file:///this/is/not/a/palindrome> \"literal string\" .\n"+ assert $ expected == fileContents+ where+ rdfGraph = _mkRdf ts (Just $ BaseUrl "file://") (ns_mappings [])+ ts :: [Triple]+ ts =+ [ Triple+ (unode "file:///this/is/not/a/palindrome")+ (unode "file:///this/is/not/a/palindrome")+ (LNode . PlainL . T.pack $ "literal string")+ ]
testsuite/tests/Test.hs view
@@ -1,24 +1,20 @@-module Main where--import Test.Tasty (defaultMain,testGroup)+{-# LANGUAGE FlexibleInstances #-} -import qualified Data.RDF.Graph.TList_Test as TList-import qualified Data.RDF.Graph.AdjHashMap_Test as AdjHashMap--- import qualified Data.RDF.Graph.HashSP_Test as HashSP--- import qualified Data.RDF.Graph.SP_Test as SP--- very slow implementation, disabled for now.--- import qualified Data.RDF.Graph.TriplesPatriciaTree_Test as TriplesPatriciaTree-import Data.RDF.Types-import qualified Text.RDF.RDF4H.XmlParser_Test as XmlParser-import qualified Text.RDF.RDF4H.TurtleParser_ConformanceTest as TurtleParser-import qualified W3C.TurtleTest as W3CTurtleTest-import qualified W3C.RdfXmlTest as W3CRdfXmlTest-import qualified W3C.NTripleTest as W3CNTripleTest-import Data.RDF.GraphTestUtils+module Main where +import Control.Monad+import qualified Data.Map as Map+import Data.RDF+import Data.RDF.PropertyTests import qualified Data.Text as T import System.Directory (getCurrentDirectory)+import Test.QuickCheck.Arbitrary+import Test.Tasty (defaultMain,testGroup) import W3C.Manifest+import qualified W3C.NTripleTest as W3CNTripleTest+import qualified W3C.RdfXmlTest as W3CRdfXmlTest+import qualified W3C.TurtleTest as W3CTurtleTest+import qualified Text.RDF.RDF4H.TurtleParser_ConformanceTest as TurtleUnitTest suiteFilesDirTurtle,suiteFilesDirXml,suiteFilesDirNTriples :: T.Text suiteFilesDirTurtle = "rdf-tests/turtle/"@@ -35,66 +31,78 @@ mfBaseURIXml = BaseUrl "http://www.w3.org/2013/RDFXMLTests/" mfBaseURINTriples = BaseUrl "http://www.w3.org/2013/N-TriplesTests/" +instance Arbitrary (RDF TList) where+ arbitrary =+ liftM3+ mkRdf+ arbitraryTs+ (return Nothing)+ (return $ PrefixMappings Map.empty) +instance Arbitrary (RDF AdjHashMap) where+ arbitrary =+ liftM3+ mkRdf+ arbitraryTs+ (return Nothing)+ (return $ PrefixMappings Map.empty)+ main :: IO ()-main = do- -- obtain manifest files for W3C tests before running tests- -- justification for separation: http://stackoverflow.com/a/33046723+main+-- obtain manifest files for W3C tests before running tests+-- justification for separation: http://stackoverflow.com/a/33046723+ = do dir <- getCurrentDirectory- let fileSchemeUri suitesDir = T.pack ("file://" ++ dir ++ "/" ++ T.unpack suitesDir)+ let fileSchemeUri suitesDir =+ T.pack ("file://" ++ dir ++ "/" ++ T.unpack suitesDir) turtleManifest <-- loadManifest mfPathTurtle (fileSchemeUri suiteFilesDirTurtle)-- xmlManifest <-- loadManifest mfPathXml (fileSchemeUri suiteFilesDirXml)-+ loadManifest mfPathTurtle (fileSchemeUri suiteFilesDirTurtle)+ xmlManifest <- loadManifest mfPathXml (fileSchemeUri suiteFilesDirXml) nTriplesManifest <-- loadManifest mfPathNTriples (fileSchemeUri suiteFilesDirNTriples)-+ loadManifest mfPathNTriples (fileSchemeUri suiteFilesDirNTriples) -- run tests defaultMain- (testGroup "rdf4h tests"- [ -- RDF graph API tests- graphTests "TList"- TList.triplesOf'- TList.uniqTriplesOf'- TList.empty'- TList.mkRdf'- TList.addTriple'- TList.removeTriple'-- , graphTests "AdjHashMap"- AdjHashMap.triplesOf'- AdjHashMap.uniqTriplesOf'- AdjHashMap.empty'- AdjHashMap.mkRdf'- AdjHashMap.addTriple'- AdjHashMap.removeTriple'-- -- , graphTests "HashSP"- -- HashSP.triplesOf'- -- HashSP.uniqTriplesOf'- -- HashSP.empty'- -- HashSP.mkRdf'-- -- , graphTests "SP"- -- SP.triplesOf'- -- SP.uniqTriplesOf'- -- SP.empty'- -- SP.mkRdf'-- -- , graphTests "TriplesPatriciaTree"- -- TriplesPatriciaTree.triplesOf'- -- TriplesPatriciaTree.uniqTriplesOf'- -- TriplesPatriciaTree.empty'- -- TriplesPatriciaTree.mkRdf'-- -- rdf4h unit tests- , TurtleParser.tests- , XmlParser.tests-- -- W3C tests- , W3CTurtleTest.tests turtleManifest- , W3CRdfXmlTest.tests xmlManifest- , W3CNTripleTest.tests nTriplesManifest- ])+ (testGroup+ "rdf4h tests"+ -- RDF graph API tests+ [ testGroup+ "property-tests"+ [(graphTests+ "TList"+ (empty :: RDF TList)+ (mkRdf :: Triples -> Maybe BaseUrl -> PrefixMappings -> RDF TList))+ ,+ (graphTests+ "AdjHashMap"+ (empty :: RDF AdjHashMap)+ (mkRdf :: Triples -> Maybe BaseUrl -> PrefixMappings -> RDF AdjHashMap))]+ ,+ testGroup "parser-unit-tests-turtle"+ TurtleUnitTest.allCTests+ ,+ testGroup+ "parser-w3c-tests-ntriples"+ [ testGroup+ "parser-w3c-tests-ntriples-parsec"+ [W3CNTripleTest.testsParsec nTriplesManifest]+ , testGroup+ "parser-w3c-tests-ntriples-attoparsec"+ [W3CNTripleTest.testsAttoparsec nTriplesManifest]+ ]+ ,+ testGroup+ "parser-w3c-tests-turtle"+ [ testGroup+ "parser-w3c-tests-turtle-parsec"+ [W3CTurtleTest.testsParsec turtleManifest]+ , testGroup+ "parser-w3c-tests-turtle-attoparsec"+ [W3CTurtleTest.testsAttoparsec turtleManifest]+ ]+ ,+ testGroup+ "parser-w3c-tests-xml"+ [ W3CRdfXmlTest.tests xmlManifest+ ]+ ]+ )
testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs view
@@ -27,6 +27,9 @@ ("data/ttl", "example6"), -- ("data/ttl", "example7"), -- rdf4h URIs support RFC3986, not unicode IRIs in RFC3987 ("data/ttl", "example8"),+ ("data/ttl", "example9"),+ ("data/ttl", "example10"),+ ("data/ttl", "example11"), ("data/ttl", "fawlty1") ] @@ -51,27 +54,27 @@ checkGoodConformanceTest i = let expGr = loadExpectedGraph "test" i inGr = loadInputGraph "test" i- in doGoodConformanceTest expGr inGr (printf "test %d" i :: String)+ in doGoodConformanceTest expGr inGr (printf "test-%d" i :: String) 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 "test using file \"%s\"" fname+ in doGoodConformanceTest expGr inGr $ printf "turtle-%s" fname -doGoodConformanceTest :: IO (Either ParseFailure (RDF TList)) -> - IO (Either ParseFailure (RDF TList)) -> +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)]+ in testGroup (printf "conformance-%s" testname) $ map (uncurry testCase) [("loading-expected-graph-data", t1), ("loading-input-graph-data", t2), ("comparing-graphs", t3)] checkBadConformanceTest :: Int -> TestTree checkBadConformanceTest i = let t = assertLoadFailure (show i) (loadInputGraph "bad" i)- in testCase (printf "Loading test %d (negative)" i) t+ in testCase (printf "loading-test-%d-negative" i) t -- Determines if graphs are equivalent, returning Nothing if so or else a diagnostic message. -- First graph is expected graph, second graph is actual.@@ -96,7 +99,23 @@ (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)+ -- 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 n1 n2 = n1 == n2 -- Returns a graph for a good ttl test that is intended to pass, and normalizes
testsuite/tests/W3C/NTripleTest.hs view
@@ -10,26 +10,34 @@ import Data.RDF.Types import Text.RDF.RDF4H.NTriplesParser+import Text.RDF.RDF4H.ParserUtils import Data.RDF.Graph.TList -tests :: Manifest -> TestTree-tests = runManifestTests mfEntryToTest+testsParsec :: Manifest -> TestTree+testsParsec = runManifestTests (mfEntryToTest testParserParsec) +testsAttoparsec :: Manifest -> TestTree+testsAttoparsec = runManifestTests (mfEntryToTest testParserAttoparsec)+ -- Functions to map manifest test entries to unit tests. -- They are defined here to avoid cluttering W3C.Manifest -- with functions that may not be needed to those who -- just want to parse Manifest files. -- TODO: They should probably be moved to W3C.Manifest after all.-mfEntryToTest :: TestEntry -> TestTree-mfEntryToTest (TestNTriplesPositiveSyntax nm _ _ act') =+mfEntryToTest :: NTriplesParserCustom -> TestEntry -> TestTree+mfEntryToTest testParser (TestNTriplesPositiveSyntax nm _ _ act') = let act = (UNode . fromJust . fileSchemeToFilePath) act' rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure (RDF TList)) in TU.testCase (T.unpack nm) $ assertIsParsed rdf-mfEntryToTest (TestNTriplesNegativeSyntax nm _ _ act') =+mfEntryToTest testParser (TestNTriplesNegativeSyntax nm _ _ act') = let act = (UNode . fromJust . fileSchemeToFilePath) act' rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure (RDF TList)) in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf-mfEntryToTest x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x+mfEntryToTest _ x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x -testParser :: NTriplesParser-testParser = NTriplesParser+testParserParsec :: NTriplesParserCustom+testParserParsec = NTriplesParserCustom Parsec++testParserAttoparsec :: NTriplesParserCustom+testParserAttoparsec = NTriplesParserCustom Attoparsec+
testsuite/tests/W3C/TurtleTest.hs view
@@ -13,34 +13,44 @@ import Data.RDF.Query import Text.RDF.RDF4H.TurtleParser import Text.RDF.RDF4H.NTriplesParser+import Text.RDF.RDF4H.ParserUtils import Data.RDF.Graph.TList -tests :: Manifest -> TestTree-tests = runManifestTests mfEntryToTest+testsParsec :: Manifest -> TestTree+testsParsec = runManifestTests (mfEntryToTest testParserParsec) -mfEntryToTest :: TestEntry -> TestTree-mfEntryToTest (TestTurtleEval nm _ _ act' res') =+testsAttoparsec :: Manifest -> TestTree+testsAttoparsec = runManifestTests (mfEntryToTest testParserAttoparsec)++mfEntryToTest :: TurtleParserCustom -> TestEntry -> TestTree+mfEntryToTest parser (TestTurtleEval nm _ _ act' res') = let act = (UNode . fromJust . fileSchemeToFilePath) act' res = (UNode . fromJust . fileSchemeToFilePath) res'- parsedRDF = parseFile testParser (nodeURI act) >>= return . fromEither :: IO (RDF TList)+ parsedRDF = parseFile parser (nodeURI act) >>= return . fromEither :: IO (RDF TList) expectedRDF = parseFile NTriplesParser (nodeURI res) >>= return . fromEither :: IO (RDF TList) in TU.testCase (T.unpack nm) $ assertIsIsomorphic parsedRDF expectedRDF-mfEntryToTest (TestTurtleNegativeEval nm _ _ act') =+mfEntryToTest parser (TestTurtleNegativeEval nm _ _ act') = let act = (UNode . fromJust . fileSchemeToFilePath) act'- rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure (RDF TList))+ rdf = parseFile parser (nodeURI act) :: IO (Either ParseFailure (RDF TList)) in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf-mfEntryToTest (TestTurtlePositiveSyntax nm _ _ act') =+mfEntryToTest parser (TestTurtlePositiveSyntax nm _ _ act') = let act = (UNode . fromJust . fileSchemeToFilePath) act'- rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure (RDF TList))+ rdf = parseFile parser (nodeURI act) :: IO (Either ParseFailure (RDF TList)) in TU.testCase (T.unpack nm) $ assertIsParsed rdf-mfEntryToTest (TestTurtleNegativeSyntax nm _ _ act') =+mfEntryToTest parser (TestTurtleNegativeSyntax nm _ _ act') = let act = (UNode . fromJust . fileSchemeToFilePath) act'- rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure (RDF TList))+ rdf = parseFile parser (nodeURI act) :: IO (Either ParseFailure (RDF TList)) in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf-mfEntryToTest x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x+mfEntryToTest _ x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x mfBaseURITurtle :: BaseUrl mfBaseURITurtle = BaseUrl "http://www.w3.org/2013/TurtleTests/" -testParser :: TurtleParser-testParser = TurtleParser (Just mfBaseURITurtle) Nothing+-- testParser :: TurtleParser+-- testParser = TurtleParser (Just mfBaseURITurtle) Nothing++testParserParsec :: TurtleParserCustom+testParserParsec = TurtleParserCustom (Just mfBaseURITurtle) Nothing Parsec++testParserAttoparsec :: TurtleParserCustom+testParserAttoparsec = TurtleParserCustom (Just mfBaseURITurtle) Nothing Attoparsec