diff --git a/bench/MainCriterion.hs b/bench/MainCriterion.hs --- a/bench/MainCriterion.hs +++ b/bench/MainCriterion.hs @@ -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 diff --git a/examples/ParseURLs.hs b/examples/ParseURLs.hs --- a/examples/ParseURLs.hs +++ b/examples/ParseURLs.hs @@ -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 diff --git a/rdf4h.cabal b/rdf4h.cabal --- a/rdf4h.cabal +++ b/rdf4h.cabal @@ -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 , Slava Kravchenko +maintainer: Rob Stewart 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 diff --git a/src/Data/RDF/Types.hs b/src/Data/RDF/Types.hs --- a/src/Data/RDF/Types.hs +++ b/src/Data/RDF/Types.hs @@ -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: . 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 diff --git a/src/Text/RDF/RDF4H/Interact.hs b/src/Text/RDF/RDF4H/Interact.hs --- a/src/Text/RDF/RDF4H/Interact.hs +++ b/src/Text/RDF/RDF4H/Interact.hs @@ -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 diff --git a/src/Text/RDF/RDF4H/NTriplesParser.hs b/src/Text/RDF/RDF4H/NTriplesParser.hs --- a/src/Text/RDF/RDF4H/NTriplesParser.hs +++ b/src/Text/RDF/RDF4H/NTriplesParser.hs @@ -2,20 +2,26 @@ -- . 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) diff --git a/src/Text/RDF/RDF4H/ParserUtils.hs b/src/Text/RDF/RDF4H/ParserUtils.hs --- a/src/Text/RDF/RDF4H/ParserUtils.hs +++ b/src/Text/RDF/RDF4H/ParserUtils.hs @@ -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. diff --git a/src/Text/RDF/RDF4H/TurtleParser.hs b/src/Text/RDF/RDF4H/TurtleParser.hs --- a/src/Text/RDF/RDF4H/TurtleParser.hs +++ b/src/Text/RDF/RDF4H/TurtleParser.hs @@ -2,28 +2,37 @@ -- . 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 , 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 ++ "\"" diff --git a/src/Text/RDF/RDF4H/XmlParser.hs b/src/Text/RDF/RDF4H/XmlParser.hs --- a/src/Text/RDF/RDF4H/XmlParser.hs +++ b/src/Text/RDF/RDF4H/XmlParser.hs @@ -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 "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) diff --git a/testsuite/tests/Data/RDF/Graph/AdjHashMap_Test.hs b/testsuite/tests/Data/RDF/Graph/AdjHashMap_Test.hs deleted file mode 100644 --- a/testsuite/tests/Data/RDF/Graph/AdjHashMap_Test.hs +++ /dev/null @@ -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 diff --git a/testsuite/tests/Data/RDF/Graph/TList_Test.hs b/testsuite/tests/Data/RDF/Graph/TList_Test.hs deleted file mode 100644 --- a/testsuite/tests/Data/RDF/Graph/TList_Test.hs +++ /dev/null @@ -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 diff --git a/testsuite/tests/Data/RDF/GraphTestUtils.hs b/testsuite/tests/Data/RDF/GraphTestUtils.hs deleted file mode 100644 --- a/testsuite/tests/Data/RDF/GraphTestUtils.hs +++ /dev/null @@ -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 = " \"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")] diff --git a/testsuite/tests/Data/RDF/PropertyTests.hs b/testsuite/tests/Data/RDF/PropertyTests.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/Data/RDF/PropertyTests.hs @@ -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 = + " \"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") + ] diff --git a/testsuite/tests/Test.hs b/testsuite/tests/Test.hs --- a/testsuite/tests/Test.hs +++ b/testsuite/tests/Test.hs @@ -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 + ] + ] + ) diff --git a/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs b/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs --- a/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs +++ b/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs @@ -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 diff --git a/testsuite/tests/W3C/NTripleTest.hs b/testsuite/tests/W3C/NTripleTest.hs --- a/testsuite/tests/W3C/NTripleTest.hs +++ b/testsuite/tests/W3C/NTripleTest.hs @@ -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 + diff --git a/testsuite/tests/W3C/TurtleTest.hs b/testsuite/tests/W3C/TurtleTest.hs --- a/testsuite/tests/W3C/TurtleTest.hs +++ b/testsuite/tests/W3C/TurtleTest.hs @@ -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