diff --git a/bench/MainCriterion.hs b/bench/MainCriterion.hs --- a/bench/MainCriterion.hs +++ b/bench/MainCriterion.hs @@ -27,12 +27,16 @@ main = defaultMain [ env (readFile "bills.102.ttl") $ \ ~(ttl_countries) -> bgroup "parse" [ - bench "TriplesGraph" $ - nf (parseTurtle :: String -> TriplesGraph) ttl_countries - , bench "MGraph" $ - nf (parseTurtle :: String -> MGraph) ttl_countries - , bench "PatriciaTreeGraph" $ - nf (parseTurtle :: String -> PatriciaTreeGraph) ttl_countries + bench "HashMapS" $ + nf (parseTurtle :: String -> HashMapS) ttl_countries + , bench "HashMapSP" $ + nf (parseTurtle :: String -> HashMapSP) ttl_countries + , bench "MapSP" $ + nf (parseTurtle :: String -> MapSP) ttl_countries + , bench "TriplesList" $ + nf (parseTurtle :: String -> TriplesList) ttl_countries + , bench "ListPatriciaTree" $ + nf (parseTurtle :: String -> TriplesPatriciaTree) ttl_countries ] , @@ -40,24 +44,32 @@ let (Right rdf1) = parseString (TurtleParser Nothing Nothing) (T.pack ttl_countries) let (Right rdf2) = parseString (TurtleParser Nothing Nothing) (T.pack ttl_countries) let (Right rdf3) = parseString (TurtleParser Nothing Nothing) (T.pack ttl_countries) - return (rdf1 :: PatriciaTreeGraph,rdf2 :: TriplesGraph,rdf3 :: MGraph) ) - $ \ ~(patriciaTreeCountries,triplesGraph,mGraph) -> + let (Right rdf4) = parseString (TurtleParser Nothing Nothing) (T.pack ttl_countries) + let (Right rdf5) = parseString (TurtleParser Nothing Nothing) (T.pack ttl_countries) + return (rdf1 :: TriplesPatriciaTree,rdf2 :: TriplesList,rdf3 :: HashMapS,rdf4 :: MapSP,rdf5::HashMapSP) ) + $ \ ~(triplesPatriciaTree,triplesList,hashMapS,mapSP,hashMapSP) -> bgroup "query" - (queryBench "TriplesGraph" triplesGraph - ++ queryBench "MGraph" mGraph - ++ queryBench "PatriciaTreeGraph" patriciaTreeCountries) + (queryBench "TriplesList" triplesList + ++ queryBench "HashMapS" hashMapS + ++ queryBench "MapSP" mapSP + ++ queryBench "HashMapSP" hashMapSP + ++ queryBench "TriplesPatriciaTree" triplesPatriciaTree) , env (do ttl_countries <- readFile "bills.102.ttl" let (Right rdf1) = parseString (TurtleParser Nothing Nothing) (T.pack ttl_countries) let (Right rdf2) = parseString (TurtleParser Nothing Nothing) (T.pack ttl_countries) let (Right rdf3) = parseString (TurtleParser Nothing Nothing) (T.pack ttl_countries) - return (rdf1 :: PatriciaTreeGraph,rdf2 :: TriplesGraph,rdf3 :: MGraph) ) - $ \ ~(patriciaTreeCountries,triplesGraph,mGraph) -> + let (Right rdf4) = parseString (TurtleParser Nothing Nothing) (T.pack ttl_countries) + let (Right rdf5) = parseString (TurtleParser Nothing Nothing) (T.pack ttl_countries) + return (rdf1 :: TriplesPatriciaTree,rdf2 :: TriplesList,rdf3 :: HashMapS,rdf4 :: MapSP,rdf5 :: HashMapSP) ) + $ \ ~(triplesPatriciaTree,triplesList,hashMapS,mapSP,hashMapSP) -> bgroup "select" - (selectBench "TriplesGraph" triplesGraph - ++ selectBench "MGraph" mGraph - ++ selectBench "PatriciaTreeGraph" patriciaTreeCountries) + (selectBench "TriplesList" triplesList + ++ selectBench "HashMapS" hashMapS + ++ selectBench "MapSP" mapSP + ++ selectBench "HashMapSP" hashMapSP + ++ selectBench "TriplesPatriciaTree" triplesPatriciaTree) ] selectBench :: forall rdf. RDF rdf => String -> rdf -> [Benchmark] @@ -66,6 +78,8 @@ , bench (label ++ " SP") $ nf selectGr (subjSelect,predSelect,selectNothing,gr) , bench (label ++ " S") $ nf selectGr (subjSelect,selectNothing,selectNothing,gr) , bench (label ++ " PO") $ nf selectGr (selectNothing,predSelect,objSelect,gr) + , bench (label ++ " SO") $ nf selectGr (subjSelect,selectNothing,objSelect,gr) + , bench (label ++ " P") $ nf selectGr (selectNothing,predSelect,selectNothing,gr) , bench (label ++ " O") $ nf selectGr (selectNothing,selectNothing,objSelect,gr) ] @@ -87,5 +101,7 @@ , bench (label ++ " SP") $ nf queryGr (subjQuery,predQuery,queryNothing,gr) , bench (label ++ " S") $ nf queryGr (subjQuery,queryNothing,queryNothing,gr) , bench (label ++ " PO") $ nf queryGr (queryNothing,predQuery,objQuery,gr) + , bench (label ++ " SO") $ nf queryGr (subjQuery,queryNothing,objQuery,gr) + , bench (label ++ " P") $ nf queryGr (queryNothing,predQuery,queryNothing,gr) , bench (label ++ " O") $ nf queryGr (queryNothing,queryNothing,objQuery,gr) ] 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::TriplesGraph) <- parseURL (XmlParser Nothing Nothing) "http://www.w3.org/People/Berners-Lee/card.rdf" + Right (rdf::TriplesList) <- 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: 1.3.6 +version: 2.0.0 synopsis: A library for RDF processing in Haskell description: 'RDF for Haskell' is a library for working with RDF in Haskell. @@ -19,14 +19,10 @@ build-type: Simple category: RDF stability: Experimental -tested-with: GHC==7.6.3, GHC==7.8.3 +tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.2 extra-tmp-files: test extra-source-files: examples/ParseURLs.hs -flag small_base - description: Choose the new smaller, split-up base package. - default: False - flag network-uri description: Get Network.URI from the network-uri package default: True @@ -36,19 +32,21 @@ , Data.RDF.Namespace , Data.RDF.Types , Data.RDF.Query - , Data.RDF.MGraph - , Data.RDF.PatriciaTreeGraph - , Data.RDF.TriplesGraph + , Data.RDF.Graph.HashMapS + , Data.RDF.Graph.HashMapSP + , Data.RDF.Graph.MapSP + , Data.RDF.Graph.TriplesPatriciaTree + , Data.RDF.Graph.TriplesList , Text.RDF.RDF4H.TurtleParser , Text.RDF.RDF4H.TurtleSerializer , Text.RDF.RDF4H.NTriplesParser , Text.RDF.RDF4H.NTriplesSerializer , Text.RDF.RDF4H.XmlParser - if flag(small_base) - build-depends: base >= 3, bytestring, directory, containers - else - build-depends: base < 3 - build-depends: parsec >= 3 + build-depends: base >= 3 + , bytestring + , directory + , containers + , parsec >= 3 , fgl >= 5.5.2.0 , HTTP >= 4000.0.0 , hxt >= 9.3.1.2 @@ -58,6 +56,8 @@ , deepseq , binary , text-binary + , utf8-string + , hgal if impl(ghc < 7.6) build-depends: ghc-prim @@ -69,16 +69,13 @@ other-modules: Text.RDF.RDF4H.ParserUtils , Text.RDF.RDF4H.Interact hs-source-dirs: src - extensions: BangPatterns RankNTypes MultiParamTypeClasses Arrows FlexibleContexts OverloadedStrings - ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields -O2 + 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 - if flag(small_base) - build-depends: base >= 3, bytestring - else - build-depends: base >= 4 && < 6 - build-depends: rdf4h + build-depends: base >= 4 && < 6 + , rdf4h , containers , text >= 1.2.1.0 @@ -97,27 +94,29 @@ type: exitcode-stdio-1.0 main-is: Test.hs other-modules: Data.RDF.GraphTestUtils - Data.RDF.MGraph_Test - Data.RDF.PatriciaTreeGraph_Test + Data.RDF.Graph.HashMapS_Test + Data.RDF.Graph.HashMapSP_Test + Data.RDF.Graph.MapSP_Test + Data.RDF.Graph.TriplesPatriciaTree_Test + Data.RDF.Graph.TriplesList_Test Text.RDF.RDF4H.TurtleParser_ConformanceTest Text.RDF.RDF4H.XmlParser_Test - Data.RDF.TriplesGraph_Test W3C.Manifest W3C.NTripleTest W3C.RdfXmlTest + W3C.W3CAssertions ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-name-shadowing -funbox-strict-fields extensions: RankNTypes MultiParamTypeClasses Arrows FlexibleContexts OverloadedStrings build-depends: base >= 4 && < 6 , rdf4h - , test-framework >= 0.2.3 - , test-framework-quickcheck2 - , test-framework-hunit >= 0.2.7 + , tasty + , tasty-hunit + , tasty-quickcheck , QuickCheck >= 1.2.0.0 , HUnit >= 1.2.2.1 , bytestring , containers , text >= 1.2.1.0 - , knob , directory , safe @@ -141,7 +140,6 @@ rdf4h, text >= 1.2.1.0 ghc-options: -Wall - -O2 source-repository head type: git diff --git a/src/Data/RDF.hs b/src/Data/RDF.hs --- a/src/Data/RDF.hs +++ b/src/Data/RDF.hs @@ -7,16 +7,18 @@ RdfSerializer(..), RdfParser(..), - -- * Export types and query functions + -- * RDF types and query functions module Data.RDF.Types, module Data.RDF.Query, - -- * Export RDF type class instances - module Data.RDF.TriplesGraph, - module Data.RDF.MGraph, - module Data.RDF.PatriciaTreeGraph, + -- * RDF type class instances + module Data.RDF.Graph.TriplesList, + module Data.RDF.Graph.HashMapS, + module Data.RDF.Graph.HashMapSP, + module Data.RDF.Graph.MapSP, + module Data.RDF.Graph.TriplesPatriciaTree, - -- * Export RDF parsers and serializers + -- * RDF parsers and serializers module Text.RDF.RDF4H.NTriplesSerializer, module Text.RDF.RDF4H.NTriplesParser, module Text.RDF.RDF4H.TurtleSerializer, @@ -26,9 +28,11 @@ where import Data.RDF.Namespace -import Data.RDF.TriplesGraph -import Data.RDF.MGraph -import Data.RDF.PatriciaTreeGraph +import Data.RDF.Graph.TriplesList +import Data.RDF.Graph.HashMapS +import Data.RDF.Graph.HashMapSP +import Data.RDF.Graph.MapSP +import Data.RDF.Graph.TriplesPatriciaTree import Text.RDF.RDF4H.NTriplesSerializer import Text.RDF.RDF4H.TurtleSerializer import Text.RDF.RDF4H.NTriplesParser diff --git a/src/Data/RDF/Graph/HashMapS.hs b/src/Data/RDF/Graph/HashMapS.hs new file mode 100644 --- /dev/null +++ b/src/Data/RDF/Graph/HashMapS.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving #-} +-- |A graph implementation mapping hashed S to a mapping of +-- hashed P to hashed O, backed by 'Data.HashMap'. + +module Data.RDF.Graph.HashMapS (HashMapS) where + +import Prelude hiding (pred) +import Control.DeepSeq (NFData) +import Data.RDF.Types +import Data.RDF.Query +import Data.RDF.Namespace +import qualified Data.Map as Map +import Data.Hashable() +import Data.HashMap.Strict(HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet(HashSet) +import qualified Data.HashSet as Set +import Data.List + +-- |A map-based graph implementation. +-- +-- This instance of 'RDF' is an adjacency map with each subject +-- mapping to a mapping from a predicate node to to the adjacent nodes +-- via that predicate. +-- +-- Given the following triples graph:: +-- +-- @ +-- (http:\/\/example.com\/s1,http:\/\/example.com\/p1,http:\/\/example.com\/o1) +-- (http:\/\/example.com\/s1,http:\/\/example.com\/p1,http:\/\/example.com\/o2) +-- (http:\/\/example.com\/s1,http:\/\/example.com\/p2,http:\/\/example.com\/o1) +-- (http:\/\/example.com\/s2,http:\/\/example.com\/p3,http:\/\/example.com\/o3) +-- @ +-- +-- where +-- +-- > hash "http://example.com/s1" = 1600134414 +-- > hash "http://example.com/s2" = 1600134413 +-- > hash "http://example.com/p1" = 1616912099 +-- > hash "http://example.com/p2" = 1616912096 +-- > hash "http://example.com/p3" = 1616912097 +-- > hash "http://example.com/o1" = 1935686794 +-- > hash "http://example.com/o2" = 1935686793 +-- > hash "http://example.com/o3" = 1935686792 +-- +-- the in-memory hashmap representation of the triples graph is: +-- +-- @ +-- key:1600134414, value:(key:1616912099, value:[1935686794 -- (..\/s1,..\/p1,..\/o1) +-- ,1935686793]; -- (..\/s1,..\/p1,..\/o2) +-- key:1616912096, value:[1935686794]); -- (..\/s1,..\/p2,..\/o1) +-- key:1600134413, value:(key:1616912097, value:[1935686792]) -- (..\/s1,..\/p3,..\/o3) +-- @ +-- +-- Worst-case time complexity of the graph functions, with respect +-- to the number of triples, are: +-- +-- * 'empty' : O(1) +-- +-- * 'mkRdf' : O(n) +-- +-- * 'triplesOf': O(n) +-- +-- * 'select' : O(n) +-- +-- * 'query' : O(log n) +newtype HashMapS = HashMapS (TMaps, Maybe BaseUrl, PrefixMappings) + deriving (NFData) + +instance RDF HashMapS where + baseUrl = baseUrl' + prefixMappings = prefixMappings' + addPrefixMappings = addPrefixMappings' + empty = empty' + mkRdf = mkRdf' + triplesOf = triplesOf' + uniqTriplesOf = uniqTriplesOf' + select = select' + query = query' + +instance Show HashMapS where + show gr = concatMap (\t -> show t ++ "\n") (triplesOf gr) + +-- some convenience type alias for readability + +-- An adjacency map for a subject, mapping from a predicate node to +-- to the adjacent nodes via that predicate. +type AdjacencyMap = HashMap Predicate (HashSet Node) + +type Adjacencies = HashSet Node + +type TMap = HashMap Node AdjacencyMap +type TMaps = (TMap, TMap) + + +baseUrl' :: HashMapS -> Maybe BaseUrl +baseUrl' (HashMapS (_, baseURL, _)) = baseURL + +prefixMappings' :: HashMapS -> PrefixMappings +prefixMappings' (HashMapS (_, _, pms)) = pms + +addPrefixMappings' :: HashMapS -> PrefixMappings -> Bool -> HashMapS +addPrefixMappings' (HashMapS (ts, baseURL, pms)) pms' replace = + let merge = if replace then flip mergePrefixMappings else mergePrefixMappings + in HashMapS (ts, baseURL, merge pms pms') + +empty' :: HashMapS +empty' = HashMapS ((HashMap.empty, HashMap.empty), Nothing, PrefixMappings Map.empty) + +mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> HashMapS +mkRdf' ts baseURL pms = HashMapS (mergeTs (HashMap.empty, HashMap.empty) ts, baseURL, pms) + +mergeTs :: TMaps -> [Triple] -> TMaps +mergeTs = foldl' mergeT + where + mergeT :: TMaps -> Triple -> TMaps + mergeT m t = mergeT' m (subjectOf t) (predicateOf t) (objectOf t) + +mergeT' :: TMaps -> Subject -> Predicate -> Object -> TMaps +mergeT' (spo, ops) s p o = (mergeT'' spo s p o, mergeT'' ops o p s) + +mergeT'' :: TMap -> Subject -> Predicate -> Object -> TMap +mergeT'' m s p o = + if s `HashMap.member` m then + (if p `HashMap.member` adjs then HashMap.insert s addPredObj m + else HashMap.insert s addNewPredObjMap m) + else HashMap.insert s newPredMap m + where + adjs = HashMap.lookupDefault HashMap.empty s m + newPredMap :: HashMap Predicate (HashSet Object) + newPredMap = HashMap.singleton p (Set.singleton o) + addNewPredObjMap :: HashMap Predicate (HashSet Object) + addNewPredObjMap = HashMap.insert p (Set.singleton o) adjs + addPredObj :: HashMap Predicate (HashSet Object) + addPredObj = HashMap.insert p (Set.insert o (get p adjs)) adjs + --get :: (Ord k, Hashable k) => k -> HashMap k v -> v + get = HashMap.lookupDefault Set.empty + +-- 3 following functions support triplesOf +triplesOf' :: HashMapS -> Triples +triplesOf' (HashMapS ((spoMap, _), _, _)) = concatMap (uncurry tripsSubj) subjPredMaps + where subjPredMaps = HashMap.toList spoMap + +-- naive implementation for now +uniqTriplesOf' :: HashMapS -> Triples +uniqTriplesOf' = nub . expandTriples + +tripsSubj :: Subject -> AdjacencyMap -> Triples +tripsSubj s adjMap = concatMap (uncurry (tfsp s)) (HashMap.toList adjMap) + where tfsp = tripsForSubjPred + +tripsForSubjPred :: Subject -> Predicate -> Adjacencies -> Triples +tripsForSubjPred s p adjs = map (Triple s p) (Set.toList adjs) + +-- supports select +select' :: HashMapS -> NodeSelector -> NodeSelector -> NodeSelector -> Triples +select' (HashMapS ((spoMap,_),_,_)) subjFn predFn objFn = + map (\(s,p,o) -> Triple s p o) $ Set.toList $ sel1 subjFn predFn objFn spoMap + +sel1 :: NodeSelector -> NodeSelector -> NodeSelector -> TMap -> HashSet (Node, Node, Node) +sel1 (Just subjFn) p o spoMap = + Set.unions $ map (sel2 p o) $ filter (\(x,_) -> subjFn x) $ HashMap.toList spoMap +sel1 Nothing p o spoMap = Set.unions $ map (sel2 p o) $ HashMap.toList spoMap + +sel2 :: NodeSelector -> NodeSelector -> (Node, HashMap Node (HashSet Node)) -> HashSet (Node, Node, Node) +sel2 (Just predFn) mobjFn (s, ps) = + Set.map (\(p,o) -> (s,p,o)) $ + foldl' Set.union Set.empty $ + map (sel3 mobjFn) poMapS :: HashSet (Node, Node, Node) + where + poMapS :: [(Node, HashSet Node)] + poMapS = filter (\(k,_) -> predFn k) $ HashMap.toList ps +sel2 Nothing mobjFn (s, ps) = + Set.map (\(p,o) -> (s,p,o)) $ + foldl' Set.union Set.empty $ + map (sel3 mobjFn) poMaps + where + poMaps = HashMap.toList ps + +sel3 :: NodeSelector -> (Node, HashSet Node) -> HashSet (Node, Node) +sel3 (Just objFn) (p, os) = Set.map (\o -> (p, o)) $ Set.filter objFn os +sel3 Nothing (p, os) = Set.map (\o -> (p, o)) os + +-- support query +query' :: HashMapS -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples +query' (HashMapS (m,_ , _)) subj pred obj = map f $ Set.toList $ q1 subj pred obj m + where f (s, p, o) = Triple s p o + +q1 :: Maybe Node -> Maybe Node -> Maybe Node -> TMaps -> HashSet (Node, Node, Node) +q1 (Just s) p o (spoMap, _ ) = q2 p o (s, HashMap.lookupDefault HashMap.empty s spoMap) +q1 s p (Just o) (_ , opsMap) = Set.map (\(o',p',s') -> (s',p',o')) $ q2 p s (o, HashMap.lookupDefault HashMap.empty o opsMap) +q1 Nothing p o (spoMap, _ ) = Set.unions $ map (q2 p o) $ HashMap.toList spoMap + +q2 :: Maybe Node -> Maybe Node -> (Node, HashMap Node (HashSet Node)) -> HashSet (Node, Node, Node) +q2 (Just p) o (s, pmap) = + maybe Set.empty (Set.map (\ (p', o') -> (s, p', o')) . q3 o . (p,)) $ HashMap.lookup p pmap +q2 Nothing o (s, pmap) = Set.map (\(x,y) -> (s,x,y)) $ Set.unions $ map (q3 o) opmaps + where opmaps ::[(Node, HashSet Node)] + opmaps = HashMap.toList pmap + +q3 :: Maybe Node -> (Node, HashSet Node) -> HashSet (Node, Node) +q3 (Just o) (p, os) = if o `Set.member` os then Set.singleton (p, o) else Set.empty +q3 Nothing (p, os) = Set.map (\o -> (p, o)) os diff --git a/src/Data/RDF/Graph/HashMapSP.hs b/src/Data/RDF/Graph/HashMapSP.hs new file mode 100644 --- /dev/null +++ b/src/Data/RDF/Graph/HashMapSP.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving #-} +-- |A graph implementation mapping (S,P) pairs to O, backed by 'Data.Map'. + +module Data.RDF.Graph.HashMapSP (HashMapSP) where + +import Prelude hiding (pred) +import Control.DeepSeq (NFData) +import Data.RDF.Types +import Data.RDF.Query +import Data.RDF.Namespace +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map as Map +import Data.List + +-- |A map-based graph implementation. + +newtype HashMapSP = HashMapSP (SPMap, Maybe BaseUrl, PrefixMappings) + deriving (NFData) + +instance RDF HashMapSP where + baseUrl = baseUrl' + prefixMappings = prefixMappings' + addPrefixMappings = addPrefixMappings' + empty = empty' + mkRdf = mkRdf' + triplesOf = triplesOf' + uniqTriplesOf = uniqTriplesOf' + select = select' + query = query' + +instance Show HashMapSP where + show gr = concatMap (\t -> show t ++ "\n") (triplesOf gr) + +type SPMap = HashMap (Subject,Predicate) [Object] + +baseUrl' :: HashMapSP -> Maybe BaseUrl +baseUrl' (HashMapSP (_, baseURL, _)) = baseURL + +prefixMappings' :: HashMapSP -> PrefixMappings +prefixMappings' (HashMapSP (_, _, pms)) = pms + +addPrefixMappings' :: HashMapSP -> PrefixMappings -> Bool -> HashMapSP +addPrefixMappings' (HashMapSP (tsMap, baseURL, pms)) pms' replace = + let merge = if replace then flip mergePrefixMappings else mergePrefixMappings + in HashMapSP (tsMap, baseURL, merge pms pms') + +empty' :: HashMapSP +empty' = HashMapSP (HashMap.empty, Nothing, PrefixMappings Map.empty) + +mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> HashMapSP +mkRdf' triples baseURL pms = HashMapSP (tsMap, baseURL, pms) + where + tsMap = sortAndGroup triples + sortAndGroup xs = HashMap.fromListWith (++) [((s,p), [o]) | Triple s p o <- xs] + +triplesOf' :: HashMapSP -> Triples +triplesOf' (HashMapSP (tsMap,_,_)) = (concatMap (\((s,p),oList) -> map (Triple s p) oList) . HashMap.toList) tsMap + +uniqTriplesOf' :: HashMapSP -> Triples +uniqTriplesOf' = nub . expandTriples + +select' :: HashMapSP -> NodeSelector -> NodeSelector -> NodeSelector -> Triples +select' gr Nothing Nothing Nothing = + triplesOf' gr + +select' (HashMapSP (tsMap,_,_)) Nothing (Just pSelector) Nothing = + HashMap.foldrWithKey findTripleWithP [] tsMap + where + findTripleWithP (s,p) oList ts = if pSelector p + then map (Triple s p) oList ++ ts + else ts + +select' (HashMapSP (tsMap,_,_)) Nothing Nothing (Just oSelector) = + HashMap.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = map (Triple s p) (filter oSelector oList) ++ ts + +select' (HashMapSP (tsMap,_,_)) Nothing (Just pSelector) (Just oSelector) = + HashMap.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = if pSelector p + then map (Triple s p) (filter oSelector oList) ++ ts + else ts + +select' (HashMapSP (tsMap,_,_)) (Just sSelector) Nothing Nothing = + HashMap.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = if sSelector s + then map (Triple s p) oList ++ ts + else ts + +select' (HashMapSP (tsMap,_,_)) (Just sSelector) (Just pSelector) Nothing = + HashMap.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = if sSelector s && pSelector p + then map (Triple s p) oList ++ ts + else ts + +select' (HashMapSP (tsMap,_,_)) (Just sSelector) Nothing (Just oSelector) = + HashMap.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = if sSelector s + then map (Triple s p) (filter oSelector oList) ++ ts + else ts + +select' (HashMapSP (tsMap,_,_)) (Just sSelector) (Just pSelector) (Just oSelector) = + HashMap.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = if sSelector s && pSelector p + then map (Triple s p) (filter oSelector oList) ++ ts + else ts + +query' :: HashMapSP -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples +query' gr Nothing Nothing Nothing = + triplesOf' gr + +query' (HashMapSP (tsMap,_,_)) Nothing (Just p) Nothing = + HashMap.foldrWithKey findTripleWithP [] tsMap + where + findTripleWithP (s,p') oList ts = if p == p' + then map (Triple s p) oList ++ ts + else ts + +query' (HashMapSP (tsMap,_,_)) Nothing Nothing (Just o) = + HashMap.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = map (Triple s p) (filter (== o) oList) ++ ts + +query' (HashMapSP (tsMap,_,_)) Nothing (Just p) (Just o) = + HashMap.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p') oList ts = if p == p' + then map (Triple s p) (filter (== o) oList) ++ ts + else ts + +query' (HashMapSP (tsMap,_,_)) (Just s) Nothing Nothing = + HashMap.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s',p) oList ts = if s == s' + then map (Triple s p) oList ++ ts + else ts + +-- optimal pattern for this HashMapSP instance +query' (HashMapSP (tsMap,_,_)) (Just s) (Just p) Nothing = + (map (Triple s p) . HashMap.lookupDefault [] (s,p)) tsMap + +query' (HashMapSP (tsMap,_,_)) (Just s) Nothing (Just o) = + HashMap.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s',p) oList ts = if s == s' + then map (Triple s p) (filter (== o) oList) ++ ts + else ts + +query' (HashMapSP (tsMap,_,_)) (Just s) (Just p) (Just o) = + HashMap.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s',p') oList ts = if s == s' && p == p' + then map (Triple s p) (filter (== o) oList) ++ ts + else ts diff --git a/src/Data/RDF/Graph/MapSP.hs b/src/Data/RDF/Graph/MapSP.hs new file mode 100644 --- /dev/null +++ b/src/Data/RDF/Graph/MapSP.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving #-} +-- |A graph implementation mapping (S,P) pairs to O, backed by 'Data.Map'. + +module Data.RDF.Graph.MapSP (MapSP) where + +import Prelude hiding (pred) +import Control.DeepSeq (NFData) +import Data.RDF.Types +import Data.RDF.Query +import Data.RDF.Namespace +import Data.Map (Map) +import qualified Data.Map as Map +import Data.List + +-- |A map-based graph implementation. +-- +-- This instance of 'RDF' is an adjacency map with each subject +-- mapping to a mapping from a predicate node to to the adjacent nodes +-- via that predicate. +-- +-- Given the following triples graph:: +-- +-- @ +-- (http:\/\/example.com\/s1,http:\/\/example.com\/p1,http:\/\/example.com\/o1) +-- (http:\/\/example.com\/s1,http:\/\/example.com\/p1,http:\/\/example.com\/o2) +-- (http:\/\/example.com\/s1,http:\/\/example.com\/p2,http:\/\/example.com\/o1) +-- (http:\/\/example.com\/s2,http:\/\/example.com\/p3,http:\/\/example.com\/o3) +-- @ +-- +-- the in-memory map representation of the triples graph is: +-- +-- @ +-- key:(http:\/\/example.com\/s1,http:\/\/example.com\/p1), +-- value:[http:\/\/example.com\/o1,http:\/\/example.com\/o2]; +-- +-- key:(http:\/\/example.com\/s1,http:\/\/example.com\/p2), +-- value:[http:\/\/example.com\/o1]; +-- +-- key:(http:\/\/example.com\/s2,http:\/\/example.com\/p3), +-- value:[http:\/\/example.com\/o3]; +-- @ + +newtype MapSP = MapSP (SPMap, Maybe BaseUrl, PrefixMappings) + deriving (NFData) + +instance RDF MapSP where + baseUrl = baseUrl' + prefixMappings = prefixMappings' + addPrefixMappings = addPrefixMappings' + empty = empty' + mkRdf = mkRdf' + triplesOf = triplesOf' + uniqTriplesOf = uniqTriplesOf' + select = select' + query = query' + +instance Show MapSP where + show gr = concatMap (\t -> show t ++ "\n") (triplesOf gr) + +type SPMap = Map (Subject,Predicate) [Object] + +baseUrl' :: MapSP -> Maybe BaseUrl +baseUrl' (MapSP (_, baseURL, _)) = baseURL + +prefixMappings' :: MapSP -> PrefixMappings +prefixMappings' (MapSP (_, _, pms)) = pms + +addPrefixMappings' :: MapSP -> PrefixMappings -> Bool -> MapSP +addPrefixMappings' (MapSP (tsMap, baseURL, pms)) pms' replace = + let merge = if replace then flip mergePrefixMappings else mergePrefixMappings + in MapSP (tsMap, baseURL, merge pms pms') + +empty' :: MapSP +empty' = MapSP (Map.empty, Nothing, PrefixMappings Map.empty) + +mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> MapSP +mkRdf' triples baseURL pms = MapSP (tsMap, baseURL, pms) + where + tsMap = sortAndGroup triples + sortAndGroup xs = Map.fromListWith (++) [((s,p), [o]) | Triple s p o <- xs] + +triplesOf' :: MapSP -> Triples +triplesOf' (MapSP (tsMap,_,_)) = (concatMap (\((s,p),oList) -> map (Triple s p) oList) . Map.toList) tsMap + +uniqTriplesOf' :: MapSP -> Triples +uniqTriplesOf' = nub . expandTriples + +select' :: MapSP -> NodeSelector -> NodeSelector -> NodeSelector -> Triples +select' gr Nothing Nothing Nothing = + triplesOf' gr + +select' (MapSP (tsMap,_,_)) Nothing (Just pSelector) Nothing = + Map.foldrWithKey findTripleWithP [] tsMap + where + findTripleWithP (s,p) oList ts = if pSelector p + then map (Triple s p) oList ++ ts + else ts + +select' (MapSP (tsMap,_,_)) Nothing Nothing (Just oSelector) = + Map.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = map (Triple s p) (filter oSelector oList) ++ ts + +select' (MapSP (tsMap,_,_)) Nothing (Just pSelector) (Just oSelector) = + Map.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = if pSelector p + then map (Triple s p) (filter oSelector oList) ++ ts + else ts + +select' (MapSP (tsMap,_,_)) (Just sSelector) Nothing Nothing = + Map.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = if sSelector s + then map (Triple s p) oList ++ ts + else ts + +select' (MapSP (tsMap,_,_)) (Just sSelector) (Just pSelector) Nothing = + Map.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = if sSelector s && pSelector p + then map (Triple s p) oList ++ ts + else ts + +select' (MapSP (tsMap,_,_)) (Just sSelector) Nothing (Just oSelector) = + Map.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = if sSelector s + then map (Triple s p) (filter oSelector oList) ++ ts + else ts + +select' (MapSP (tsMap,_,_)) (Just sSelector) (Just pSelector) (Just oSelector) = + Map.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = if sSelector s && pSelector p + then map (Triple s p) (filter oSelector oList) ++ ts + else ts + +query' :: MapSP -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples +query' gr Nothing Nothing Nothing = + triplesOf' gr + +query' (MapSP (tsMap,_,_)) Nothing (Just p) Nothing = + Map.foldrWithKey findTripleWithP [] tsMap + where + findTripleWithP (s,p') oList ts = if p == p' + then map (Triple s p) oList ++ ts + else ts + +query' (MapSP (tsMap,_,_)) Nothing Nothing (Just o) = + Map.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p) oList ts = map (Triple s p) (filter (== o) oList) ++ ts + +query' (MapSP (tsMap,_,_)) Nothing (Just p) (Just o) = + Map.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s,p') oList ts = if p == p' + then map (Triple s p) (filter (== o) oList) ++ ts + else ts + +query' (MapSP (tsMap,_,_)) (Just s) Nothing Nothing = + Map.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s',p) oList ts = if s == s' + then map (Triple s p) oList ++ ts + else ts + +-- optimal pattern for this MapSP instance +query' (MapSP (tsMap,_,_)) (Just s) (Just p) Nothing = + (map (Triple s p) . Map.findWithDefault [] (s,p)) tsMap + +query' (MapSP (tsMap,_,_)) (Just s) Nothing (Just o) = + Map.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s',p) oList ts = if s == s' + then map (Triple s p) (filter (== o) oList) ++ ts + else ts + +query' (MapSP (tsMap,_,_)) (Just s) (Just p) (Just o) = + Map.foldrWithKey findTripleWithS [] tsMap + where + findTripleWithS (s',p') oList ts = if s == s' && p == p' + then map (Triple s p) (filter (== o) oList) ++ ts + else ts diff --git a/src/Data/RDF/Graph/TriplesList.hs b/src/Data/RDF/Graph/TriplesList.hs new file mode 100644 --- /dev/null +++ b/src/Data/RDF/Graph/TriplesList.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving , DeriveGeneric #-} + +-- |"TriplesGraph" contains a list-backed graph implementation suitable +-- for smallish graphs or for temporary graphs that will not be queried. +-- It maintains the triples in the order that they are given in, and is +-- especially useful for holding N-Triples, where it is often desirable +-- to preserve the order of the triples when they were originally parsed. +-- Duplicate triples are not filtered. If you might have duplicate triples, +-- use @MGraph@ instead, which is also more efficient. However, the query +-- functions of this graph (select, query) remove duplicates from their +-- result triples (but triplesOf does not) since it is usually cheap +-- to do so. +module Data.RDF.Graph.TriplesList (TriplesList) where + +import Prelude hiding (pred) +import Control.DeepSeq (NFData) +import Data.Binary +import qualified Data.Map as Map +import Data.RDF.Namespace +import Data.RDF.Query +import Data.RDF.Types +import Data.List (nub) +import GHC.Generics + +-- |A simple implementation of the 'RDF' type class that represents +-- the graph internally as a list of triples. +-- +-- Note that this type of RDF is fine for interactive +-- experimentation and querying of smallish (<10,000 triples) graphs, +-- but there are better options for larger graphs or graphs that you +-- will do many queries against (e.g., @MGraph@ is faster for queries). +-- +-- The time complexity of the functions (where n == num_triples) are: +-- +-- * 'empty' : O(1) +-- +-- * 'mkRdf' : O(n) +-- +-- * 'triplesOf': O(1) +-- +-- * 'select' : O(n) +-- +-- * 'query' : O(n) +newtype TriplesList = TriplesList (Triples, Maybe BaseUrl, PrefixMappings) + deriving (Generic,NFData) + +instance Binary TriplesList + +instance RDF TriplesList where + baseUrl = baseUrl' + prefixMappings = prefixMappings' + addPrefixMappings = addPrefixMappings' + empty = empty' + mkRdf = mkRdf' + triplesOf = triplesOf' + uniqTriplesOf = uniqTriplesOf' + select = select' + query = query' + +instance Show TriplesList where + show gr = concatMap (\t -> show t ++ "\n") (triplesOf gr) + +prefixMappings' :: TriplesList -> PrefixMappings +prefixMappings' (TriplesList (_, _, pms)) = pms + +addPrefixMappings' :: TriplesList -> PrefixMappings -> Bool -> TriplesList +addPrefixMappings' (TriplesList (ts, baseURL, pms)) pms' replace = + let merge = if replace then flip mergePrefixMappings else mergePrefixMappings + in TriplesList (ts, baseURL, merge pms pms') + +baseUrl' :: TriplesList -> Maybe BaseUrl +baseUrl' (TriplesList (_, baseURL, _)) = baseURL + +empty' :: TriplesList +empty' = TriplesList ([], Nothing, PrefixMappings Map.empty) + +-- We no longer remove duplicates here, as it is very time consuming and is often not +-- necessary (raptor does not seem to remove dupes either). Instead, we remove dupes +-- from the results of the select' and query' functions, since it is cheap to do +-- there in most cases, but not when triplesOf' is called. +mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> TriplesList +mkRdf' ts baseURL pms = TriplesList (ts, baseURL, pms) + +triplesOf' :: TriplesList -> Triples +triplesOf' (TriplesList (ts, _, _)) = ts + +uniqTriplesOf' :: TriplesList -> Triples +uniqTriplesOf' = nub . expandTriples + +select' :: TriplesList -> NodeSelector -> NodeSelector -> NodeSelector -> Triples +select' g s p o = filter (matchSelect s p o) $ triplesOf g + +query' :: TriplesList -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples +query' g s p o = filter (matchPattern s p o) $ triplesOf g + +matchSelect :: NodeSelector -> NodeSelector -> NodeSelector -> Triple -> Bool +matchSelect s p o t = + match s (subjectOf t) && match p (predicateOf t) && match o (objectOf t) + where + match Nothing _ = True + match (Just fn) n = fn n + +matchPattern :: Maybe Subject -> Maybe Predicate -> Maybe Object -> Triple -> Bool +matchPattern subj pred obj t = smatch t && pmatch t && omatch t + where + smatch trp = matchNode subj (subjectOf trp) + pmatch trp = matchNode pred (predicateOf trp) + omatch trp = matchNode obj (objectOf trp) + +matchNode :: Maybe Node -> Node -> Bool +matchNode Nothing _ = True +matchNode (Just n1) n2 = n1 == n2 diff --git a/src/Data/RDF/Graph/TriplesPatriciaTree.hs b/src/Data/RDF/Graph/TriplesPatriciaTree.hs new file mode 100644 --- /dev/null +++ b/src/Data/RDF/Graph/TriplesPatriciaTree.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, BangPatterns #-} + +module Data.RDF.Graph.TriplesPatriciaTree (TriplesPatriciaTree) where + +import Data.RDF.Namespace +import Data.RDF.Query +import Data.RDF.Types + +import Control.DeepSeq (NFData) +import qualified Data.Graph.Inductive.Graph as G +import qualified Data.Graph.Inductive.PatriciaTree as PT +import qualified Data.Graph.Inductive.Query.DFS as DFS +import qualified Data.IntMap as IntMap +import Data.List +import qualified Data.Map as Map +import Data.Maybe + +newtype TriplesPatriciaTree = TriplesPatriciaTree (PT.Gr Node Node,IntMap.IntMap Node, Maybe BaseUrl, PrefixMappings) + deriving (Show,NFData) + +instance RDF TriplesPatriciaTree where + baseUrl = baseUrl' + prefixMappings = prefixMappings' + addPrefixMappings = addPrefixMappings' + empty = empty' + mkRdf = mkRdf' + triplesOf = triplesOf' + uniqTriplesOf = uniqTriplesOf' + select = select' + query = query' + +empty' :: TriplesPatriciaTree +empty' = TriplesPatriciaTree (G.empty,IntMap.empty, Nothing, PrefixMappings Map.empty) + +prefixMappings' :: TriplesPatriciaTree -> PrefixMappings +prefixMappings' (TriplesPatriciaTree (_,_,_,pms')) = pms' + +addPrefixMappings' :: TriplesPatriciaTree -> PrefixMappings -> Bool -> TriplesPatriciaTree +addPrefixMappings' (TriplesPatriciaTree (g, idxLookup, baseURL, pms)) pms' replace = + let merge = if replace then flip mergePrefixMappings else mergePrefixMappings + in TriplesPatriciaTree (g, idxLookup, baseURL, merge pms pms') + +baseUrl' :: TriplesPatriciaTree -> Maybe BaseUrl +baseUrl' (TriplesPatriciaTree _) = Nothing + +data AutoIncrMap = AutoIncrMap + { theMap :: Map.Map Node (Int,Node) + , idxPtr :: !Int } + +{- +init -> [] +insert www -> [0,www] +insert ttt -> [1,ttt] +insert ttt -> [1,ttt] +-} +insertIncr :: Node -> AutoIncrMap -> (Int,AutoIncrMap) +insertIncr !node mp = + let x = Map.lookup node (theMap mp) + in if isJust x + then + let (i,_) = fromJust x + in (i,mp) + else + let curIdx = idxPtr mp + mp' = mp { idxPtr = curIdx + 1 + , theMap = Map.insert node (idxPtr mp, node) (theMap mp) } + in (curIdx, mp') + +mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> TriplesPatriciaTree +mkRdf' ts base' pms' = + -- step 1: subjects and objects assigned node ID (an Int) + let (mp,ledges) = foldl' f ((AutoIncrMap Map.empty 0),[]) ts + + -- step 2: for all triples, create arc with + -- - predicate node the arc label + -- - subject the source node ID + -- - object the target node ID + f (mp',edges) (Triple s p o) = + let (sIdx,mp'') = insertIncr s mp' + (oIdx,mp''') = insertIncr o mp'' + edge = (sIdx,oIdx,p) + in (mp''',edge : edges) + + lnodes = Map.elems (theMap mp) + intIdx = IntMap.fromList lnodes + ptGraph = G.mkGraph lnodes ledges + + in TriplesPatriciaTree (ptGraph ,intIdx, base', pms') + +triplesOf' :: TriplesPatriciaTree -> Triples +triplesOf' (TriplesPatriciaTree (g,idxLookup,_,_)) = + map (\(sIdx,oIdx,p) -> + let [s,o] = map (\idx -> fromJust $ IntMap.lookup idx idxLookup) [sIdx,oIdx] + in Triple s p o) (G.labEdges g) + +uniqTriplesOf' :: TriplesPatriciaTree -> Triples +uniqTriplesOf' ptG@(TriplesPatriciaTree (g,idxLookup,_,_)) = + nub $ map (\(sIdx,oIdx,p) -> + let [s,o] = map (\idx -> fromJust $ IntMap.lookup idx idxLookup) [sIdx,oIdx] + in expandTriple (prefixMappings ptG) (Triple s p o)) (G.labEdges g) + +mkTriples :: IntMap.IntMap Node -> Node -> [(Node, IntMap.Key)] -> [(Node, IntMap.Key)] -> [Triple] +mkTriples idxLookup thisNode adjsIn adjsOut = + let ts1 = map (\(predNode,subjIdx) -> + let s = fromJust (IntMap.lookup subjIdx idxLookup) + in Triple s predNode thisNode + ) adjsIn + + ts2 = map (\(predNode,objIdx) -> + let o = fromJust (IntMap.lookup objIdx idxLookup) + in Triple thisNode predNode o + ) adjsOut + in ts1 ++ ts2 + +select' :: TriplesPatriciaTree -> NodeSelector -> NodeSelector -> NodeSelector -> Triples +select' (TriplesPatriciaTree (g,idxLookup,_,_)) maybeSubjSel maybePredSel maybeObjSel = + + let cfun ( adjsIn , _nodeIdx , thisNode , adjsOut ) + | isNothing maybeSubjSel && isNothing maybePredSel && isNothing maybeObjSel = + mkTriples idxLookup thisNode adjsIn adjsOut + + | isJust maybeSubjSel && isNothing maybePredSel && isNothing maybeObjSel = + let adjsIn' = filter (\(_p,idxSubj) -> fromJust maybeSubjSel (fromJust (IntMap.lookup idxSubj idxLookup))) adjsIn + ts1 = mkTriples idxLookup thisNode adjsIn' [] + ts2 = if fromJust maybeSubjSel thisNode + then mkTriples idxLookup thisNode [] adjsOut + else [] + in ts1 ++ ts2 + | isNothing maybeSubjSel && isJust maybePredSel && isNothing maybeObjSel = + let adjsIn' = filter (\(p,_idxSubj) -> fromJust maybePredSel p ) adjsIn + adjsOut' = filter (\(p,_idxObj) -> fromJust maybePredSel p ) adjsOut + ts1 = if not (null adjsIn') + then mkTriples idxLookup thisNode adjsIn' [] + else [] + ts2 = if not (null adjsOut') + then mkTriples idxLookup thisNode [] adjsOut' + else [] + in ts1 ++ ts2 + + | isNothing maybeSubjSel && isNothing maybePredSel && isJust maybeObjSel = + let adjsOut' = filter (\(_p,idxObj) -> fromJust maybeObjSel (fromJust (IntMap.lookup idxObj idxLookup)) ) adjsOut + ts1 = mkTriples idxLookup thisNode [] adjsOut' + ts2 = if fromJust maybeObjSel thisNode + then mkTriples idxLookup thisNode adjsIn [] + else [] + in ts1 ++ ts2 + + | isJust maybeSubjSel && isJust maybePredSel && isNothing maybeObjSel = + let adjsIn' = filter (\(p,idxSubj) -> fromJust maybeSubjSel (fromJust (IntMap.lookup idxSubj idxLookup)) + && fromJust maybePredSel p ) adjsIn + adjsOut' = filter (\(p,_idxObj) -> fromJust maybePredSel p ) adjsOut + ts1 = mkTriples idxLookup thisNode adjsIn' [] + ts2 = if fromJust maybeSubjSel thisNode + then mkTriples idxLookup thisNode [] adjsOut' + else [] + in ts1 ++ ts2 + + | isJust maybeSubjSel && isNothing maybePredSel && isJust maybeObjSel = + let adjsIn' = filter (\(_p,idxSubj) -> fromJust maybeSubjSel (fromJust (IntMap.lookup idxSubj idxLookup)) ) adjsIn + adjsOut' = filter (\(_p,idxObj) -> fromJust maybeObjSel (fromJust (IntMap.lookup idxObj idxLookup)) ) adjsOut + ts1 = if fromJust maybeObjSel thisNode + then mkTriples idxLookup thisNode adjsIn' [] + else [] + ts2 = if fromJust maybeSubjSel thisNode + then mkTriples idxLookup thisNode [] adjsOut' + else [] + in ts1 ++ ts2 + + | isNothing maybeSubjSel && isJust maybePredSel && isJust maybeObjSel = + let adjsIn' = filter (\(p,_idxSubj) -> fromJust maybePredSel p ) adjsIn + adjsOut' = filter (\(p,idxObj) -> fromJust maybeObjSel (fromJust (IntMap.lookup idxObj idxLookup)) + && fromJust maybePredSel p ) adjsOut + ts1 = if fromJust maybeObjSel thisNode + then mkTriples idxLookup thisNode adjsIn' [] + else [] + ts2 = mkTriples idxLookup thisNode [] adjsOut' + in ts1 ++ ts2 + + | isJust maybeSubjSel && isJust maybePredSel && isJust maybeObjSel = + let adjsIn' = filter (\(p,idxSubj) -> fromJust maybeSubjSel (fromJust (IntMap.lookup idxSubj idxLookup)) + && fromJust maybePredSel p ) adjsIn + adjsOut' = filter (\(p,idxObj) -> fromJust maybeObjSel (fromJust (IntMap.lookup idxObj idxLookup)) + && fromJust maybePredSel p ) adjsOut + ts1 = if fromJust maybeObjSel thisNode + then mkTriples idxLookup thisNode adjsIn' [] + else [] + ts2 = if fromJust maybeSubjSel thisNode + then mkTriples idxLookup thisNode [] adjsOut' + else [] + in ts1 ++ ts2 + + cfun ( _ , _ , _ , _) = undefined -- not sure why this pattern is needed to exhaust cfun arg patterns + + in concat $ DFS.dfsWith' cfun g + +query' :: TriplesPatriciaTree -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples +query' (TriplesPatriciaTree (g,idxLookup,_,_)) maybeSubj maybePred maybeObj = + + let cfun ( adjsIn , _nodeIdx , thisNode , adjsOut ) + | isNothing maybeSubj && isNothing maybePred && isNothing maybeObj = + mkTriples idxLookup thisNode adjsIn adjsOut + + | isJust maybeSubj && isNothing maybePred && isNothing maybeObj = + let adjsIn' = filter (\(_p,idxSubj) -> fromJust (IntMap.lookup idxSubj idxLookup) == fromJust maybeSubj ) adjsIn + ts1 = mkTriples idxLookup thisNode adjsIn' [] + ts2 = if thisNode == fromJust maybeSubj + then mkTriples idxLookup thisNode [] adjsOut + else [] + in ts1 ++ ts2 + + | isNothing maybeSubj && isJust maybePred && isNothing maybeObj = + let adjsIn' = filter (\(p,_idxSubj) -> p == fromJust maybePred ) adjsIn + adjsOut' = filter (\(p,_idxObj) -> p == fromJust maybePred ) adjsOut + ts1 = if not (null adjsIn') + then mkTriples idxLookup thisNode adjsIn' [] + else [] + ts2 = if not (null adjsOut') + then mkTriples idxLookup thisNode [] adjsOut' + else [] + in ts1 ++ ts2 + + | isNothing maybeSubj && isNothing maybePred && isJust maybeObj = + let adjsOut' = filter (\(_p,idxObj) -> fromJust (IntMap.lookup idxObj idxLookup) == fromJust maybeObj ) adjsOut + ts1 = mkTriples idxLookup thisNode [] adjsOut' + ts2 = if thisNode == fromJust maybeObj + then mkTriples idxLookup thisNode adjsIn [] + else [] + in ts1 ++ ts2 + + | isJust maybeSubj && isJust maybePred && isNothing maybeObj = + let adjsIn' = filter (\(p,idxSubj) -> fromJust (IntMap.lookup idxSubj idxLookup) == fromJust maybeSubj + && p == fromJust maybePred ) adjsIn + adjsOut' = filter (\(p,_idxObj) -> p == fromJust maybePred ) adjsOut + ts1 = mkTriples idxLookup thisNode adjsIn' [] + ts2 = if thisNode == fromJust maybeSubj + then mkTriples idxLookup thisNode [] adjsOut' + else [] + in ts1 ++ ts2 + + | isJust maybeSubj && isNothing maybePred && isJust maybeObj = + let adjsIn' = filter (\(_p,idxSubj) -> fromJust (IntMap.lookup idxSubj idxLookup) == fromJust maybeSubj ) adjsIn + adjsOut' = filter (\(_p,idxObj) -> fromJust (IntMap.lookup idxObj idxLookup) == fromJust maybeObj ) adjsOut + ts1 = if thisNode == fromJust maybeObj + then mkTriples idxLookup thisNode adjsIn' [] + else [] + ts2 = if thisNode == fromJust maybeSubj + then mkTriples idxLookup thisNode [] adjsOut' + else [] + in ts1 ++ ts2 + + | isNothing maybeSubj && isJust maybePred && isJust maybeObj = + let adjsIn' = filter (\(p,_idxSubj) -> p == fromJust maybePred ) adjsIn + adjsOut' = filter (\(p,idxObj) -> fromJust (IntMap.lookup idxObj idxLookup) == fromJust maybeObj + && p == fromJust maybePred ) adjsOut + ts1 = if thisNode == fromJust maybeObj + then mkTriples idxLookup thisNode adjsIn' [] + else [] + ts2 = mkTriples idxLookup thisNode [] adjsOut' + in ts1 ++ ts2 + + | isJust maybeSubj && isJust maybePred && isJust maybeObj = + let adjsIn' = filter (\(p,idxSubj) -> fromJust (IntMap.lookup idxSubj idxLookup) == fromJust maybeSubj + && p == fromJust maybePred ) adjsIn + adjsOut' = filter (\(p,idxObj) -> fromJust (IntMap.lookup idxObj idxLookup) == fromJust maybeObj + && p == fromJust maybePred ) adjsOut + ts1 = if thisNode == fromJust maybeObj + then mkTriples idxLookup thisNode adjsIn' [] + else [] + ts2 = if thisNode == fromJust maybeSubj + then mkTriples idxLookup thisNode [] adjsOut' + else [] + in ts1 ++ ts2 + + cfun ( _ , _ , _ , _ ) = undefined -- not sure why this pattern is needed to exhaust cfun arg patterns + + in concat $ DFS.dfsWith' cfun g diff --git a/src/Data/RDF/MGraph.hs b/src/Data/RDF/MGraph.hs deleted file mode 100644 --- a/src/Data/RDF/MGraph.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving #-} --- |A simple graph implementation backed by 'Data.HashMap'. - -module Data.RDF.MGraph(MGraph, empty, mkRdf, triplesOf, uniqTriplesOf, select, query) - -where - -import Prelude hiding (pred) -import Control.DeepSeq (NFData) -import Data.RDF.Types -import Data.RDF.Query -import Data.RDF.Namespace -import qualified Data.Map as Map -import Data.Hashable() -import Data.HashMap.Strict(HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.HashSet(HashSet) -import qualified Data.HashSet as Set -import Data.List - --- |A map-based graph implementation. --- --- This instance of 'RDF' is an adjacency map with each subject --- mapping to a mapping from a predicate node to to the adjacent nodes --- via that predicate. --- --- Given the following triples graph:: --- --- @ --- (http:\/\/example.com\/s1,http:\/\/example.com\/p1,http:\/\/example.com\/o1) --- (http:\/\/example.com\/s1,http:\/\/example.com\/p1,http:\/\/example.com\/o2) --- (http:\/\/example.com\/s1,http:\/\/example.com\/p2,http:\/\/example.com\/o1) --- (http:\/\/example.com\/s2,http:\/\/example.com\/p3,http:\/\/example.com\/o3) --- @ --- --- where --- --- > hash "http://example.com/s1" = 1600134414 --- > hash "http://example.com/s2" = 1600134413 --- > hash "http://example.com/p1" = 1616912099 --- > hash "http://example.com/p2" = 1616912096 --- > hash "http://example.com/p3" = 1616912097 --- > hash "http://example.com/o1" = 1935686794 --- > hash "http://example.com/o2" = 1935686793 --- > hash "http://example.com/o3" = 1935686792 --- --- the in-memory hashmap representation of the triples graph is: --- --- @ --- key:1600134414, value:(key:1616912099, value:[1935686794 -- (..\/s1,..\/p1,..\/o1) --- ,1935686793]; -- (..\/s1,..\/p1,..\/o2) --- key:1616912096, value:[1935686794]); -- (..\/s1,..\/p2,..\/o1) --- key:1600134413, value:(key:1616912097, value:[1935686792]) -- (..\/s1,..\/p3,..\/o3) --- @ --- --- Worst-case time complexity of the graph functions, with respect --- to the number of triples, are: --- --- * 'empty' : O(1) --- --- * 'mkRdf' : O(n) --- --- * 'triplesOf': O(n) --- --- * 'select' : O(n) --- --- * 'query' : O(log n) -newtype MGraph = MGraph (TMaps, Maybe BaseUrl, PrefixMappings) - deriving (NFData) - -instance RDF MGraph where - baseUrl = baseUrl' - prefixMappings = prefixMappings' - addPrefixMappings = addPrefixMappings' - empty = empty' - mkRdf = mkRdf' - triplesOf = triplesOf' - uniqTriplesOf = uniqTriplesOf' - select = select' - query = query' - -instance Show MGraph where - show gr = concatMap (\t -> show t ++ "\n") (triplesOf gr) - --- some convenience type alias for readability - --- An adjacency map for a subject, mapping from a predicate node to --- to the adjacent nodes via that predicate. -type AdjacencyMap = HashMap Predicate (HashSet Node) - -type Adjacencies = HashSet Node - -type TMap = HashMap Node AdjacencyMap -type TMaps = (TMap, TMap) - - -baseUrl' :: MGraph -> Maybe BaseUrl -baseUrl' (MGraph (_, baseURL, _)) = baseURL - -prefixMappings' :: MGraph -> PrefixMappings -prefixMappings' (MGraph (_, _, pms)) = pms - -addPrefixMappings' :: MGraph -> PrefixMappings -> Bool -> MGraph -addPrefixMappings' (MGraph (ts, baseURL, pms)) pms' replace = - let merge = if replace then flip mergePrefixMappings else mergePrefixMappings - in MGraph (ts, baseURL, merge pms pms') - -empty' :: MGraph -empty' = MGraph ((HashMap.empty, HashMap.empty), Nothing, PrefixMappings Map.empty) - -mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> MGraph -mkRdf' ts baseURL pms = MGraph (mergeTs (HashMap.empty, HashMap.empty) ts, baseURL, pms) - -mergeTs :: TMaps -> [Triple] -> TMaps -mergeTs = foldl' mergeT - where - mergeT :: TMaps -> Triple -> TMaps - mergeT m t = mergeT' m (subjectOf t) (predicateOf t) (objectOf t) - -mergeT' :: TMaps -> Subject -> Predicate -> Object -> TMaps -mergeT' (spo, ops) s p o = (mergeT'' spo s p o, mergeT'' ops o p s) - -mergeT'' :: TMap -> Subject -> Predicate -> Object -> TMap -mergeT'' m s p o = - if s `HashMap.member` m then - (if p `HashMap.member` adjs then HashMap.insert s addPredObj m - else HashMap.insert s addNewPredObjMap m) - else HashMap.insert s newPredMap m - where - adjs = HashMap.lookupDefault HashMap.empty s m - newPredMap :: HashMap Predicate (HashSet Object) - newPredMap = HashMap.singleton p (Set.singleton o) - addNewPredObjMap :: HashMap Predicate (HashSet Object) - addNewPredObjMap = HashMap.insert p (Set.singleton o) adjs - addPredObj :: HashMap Predicate (HashSet Object) - addPredObj = HashMap.insert p (Set.insert o (get p adjs)) adjs - --get :: (Ord k, Hashable k) => k -> HashMap k v -> v - get = HashMap.lookupDefault Set.empty - --- 3 following functions support triplesOf -triplesOf' :: MGraph -> Triples -triplesOf' (MGraph ((spoMap, _), _, _)) = concatMap (uncurry tripsSubj) subjPredMaps - where subjPredMaps = HashMap.toList spoMap - --- naive implementation for now -uniqTriplesOf' :: MGraph -> Triples -uniqTriplesOf' = nub . expandTriples - -tripsSubj :: Subject -> AdjacencyMap -> Triples -tripsSubj s adjMap = concatMap (uncurry (tfsp s)) (HashMap.toList adjMap) - where tfsp = tripsForSubjPred - -tripsForSubjPred :: Subject -> Predicate -> Adjacencies -> Triples -tripsForSubjPred s p adjs = map (Triple s p) (Set.toList adjs) - --- supports select -select' :: MGraph -> NodeSelector -> NodeSelector -> NodeSelector -> Triples -select' (MGraph ((spoMap,_),_,_)) subjFn predFn objFn = - map (\(s,p,o) -> Triple s p o) $ Set.toList $ sel1 subjFn predFn objFn spoMap - -sel1 :: NodeSelector -> NodeSelector -> NodeSelector -> TMap -> HashSet (Node, Node, Node) -sel1 (Just subjFn) p o spoMap = - Set.unions $ map (sel2 p o) $ filter (\(x,_) -> subjFn x) $ HashMap.toList spoMap -sel1 Nothing p o spoMap = Set.unions $ map (sel2 p o) $ HashMap.toList spoMap - -sel2 :: NodeSelector -> NodeSelector -> (Node, HashMap Node (HashSet Node)) -> HashSet (Node, Node, Node) -sel2 (Just predFn) mobjFn (s, ps) = - Set.map (\(p,o) -> (s,p,o)) $ - foldl' Set.union Set.empty $ - map (sel3 mobjFn) poMapS :: HashSet (Node, Node, Node) - where - poMapS :: [(Node, HashSet Node)] - poMapS = filter (\(k,_) -> predFn k) $ HashMap.toList ps -sel2 Nothing mobjFn (s, ps) = - Set.map (\(p,o) -> (s,p,o)) $ - foldl' Set.union Set.empty $ - map (sel3 mobjFn) poMaps - where - poMaps = HashMap.toList ps - -sel3 :: NodeSelector -> (Node, HashSet Node) -> HashSet (Node, Node) -sel3 (Just objFn) (p, os) = Set.map (\o -> (p, o)) $ Set.filter objFn os -sel3 Nothing (p, os) = Set.map (\o -> (p, o)) os - --- support query -query' :: MGraph -> Maybe Node -> Maybe Predicate -> Maybe Node -> Triples -query' (MGraph (m,_ , _)) subj pred obj = map f $ Set.toList $ q1 subj pred obj m - where f (s, p, o) = Triple s p o - -q1 :: Maybe Node -> Maybe Node -> Maybe Node -> TMaps -> HashSet (Node, Node, Node) -q1 (Just s) p o (spoMap, _ ) = q2 p o (s, HashMap.lookupDefault HashMap.empty s spoMap) -q1 s p (Just o) (_ , opsMap) = Set.map (\(o',p',s') -> (s',p',o')) $ q2 p s (o, HashMap.lookupDefault HashMap.empty o opsMap) -q1 Nothing p o (spoMap, _ ) = Set.unions $ map (q2 p o) $ HashMap.toList spoMap - -q2 :: Maybe Node -> Maybe Node -> (Node, HashMap Node (HashSet Node)) -> HashSet (Node, Node, Node) -q2 (Just p) o (s, pmap) = - maybe Set.empty (Set.map (\ (p', o') -> (s, p', o')) . q3 o . (p,)) $ HashMap.lookup p pmap -q2 Nothing o (s, pmap) = Set.map (\(x,y) -> (s,x,y)) $ Set.unions $ map (q3 o) opmaps - where opmaps ::[(Node, HashSet Node)] - opmaps = HashMap.toList pmap - -q3 :: Maybe Node -> (Node, HashSet Node) -> HashSet (Node, Node) -q3 (Just o) (p, os) = if o `Set.member` os then Set.singleton (p, o) else Set.empty -q3 Nothing (p, os) = Set.map (\o -> (p, o)) os diff --git a/src/Data/RDF/PatriciaTreeGraph.hs b/src/Data/RDF/PatriciaTreeGraph.hs deleted file mode 100644 --- a/src/Data/RDF/PatriciaTreeGraph.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, BangPatterns #-} - -module Data.RDF.PatriciaTreeGraph where - -import Data.RDF.Namespace -import Data.RDF.Query -import Data.RDF.Types - -import qualified Data.Graph.Inductive.Graph as G -import qualified Data.Graph.Inductive.PatriciaTree as PT -import qualified Data.Graph.Inductive.Query.DFS as DFS -import qualified Data.IntMap as IntMap -import Data.List -import qualified Data.Map as Map -import Data.Maybe - -newtype PatriciaTreeGraph = PatriciaTreeGraph (PT.Gr Node Node,IntMap.IntMap Node, Maybe BaseUrl, PrefixMappings) - deriving (Show) - -instance RDF PatriciaTreeGraph where - baseUrl = baseUrl' - prefixMappings = prefixMappings' - addPrefixMappings = addPrefixMappings' - empty = empty' - mkRdf = mkRdf' - triplesOf = triplesOf' - uniqTriplesOf = uniqTriplesOf' - select = select' - query = query' - -empty' :: PatriciaTreeGraph -empty' = PatriciaTreeGraph (G.empty,IntMap.empty, Nothing, PrefixMappings Map.empty) - -prefixMappings' :: PatriciaTreeGraph -> PrefixMappings -prefixMappings' (PatriciaTreeGraph (_,_,_,pms')) = pms' - -addPrefixMappings' :: PatriciaTreeGraph -> PrefixMappings -> Bool -> PatriciaTreeGraph -addPrefixMappings' (PatriciaTreeGraph (g, idxLookup, baseURL, pms)) pms' replace = - let merge = if replace then flip mergePrefixMappings else mergePrefixMappings - in PatriciaTreeGraph (g, idxLookup, baseURL, merge pms pms') - -baseUrl' :: PatriciaTreeGraph -> Maybe BaseUrl -baseUrl' (PatriciaTreeGraph _) = Nothing - -data AutoIncrMap = AutoIncrMap - { theMap :: Map.Map Node (Int,Node) - , idxPtr :: !Int } - -{- -init -> [] -insert www -> [0,www] -insert ttt -> [1,ttt] -insert ttt -> [1,ttt] --} -insertIncr :: Node -> AutoIncrMap -> (Int,AutoIncrMap) -insertIncr !node mp = - let x = Map.lookup node (theMap mp) - in if isJust x - then - let (i,_) = fromJust x - in (i,mp) - else - let curIdx = idxPtr mp - mp' = mp { idxPtr = curIdx + 1 - , theMap = Map.insert node (idxPtr mp, node) (theMap mp) } - in (curIdx, mp') - -mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> PatriciaTreeGraph -mkRdf' ts base' pms' = - -- step 1: subjects and objects assigned node ID (an Int) - let (mp,ledges) = foldl' f ((AutoIncrMap Map.empty 0),[]) ts - - -- step 2: for all triples, create arc with - -- - predicate node the arc label - -- - subject the source node ID - -- - object the target node ID - f (mp',edges) (Triple s p o) = - let (sIdx,mp'') = insertIncr s mp' - (oIdx,mp''') = insertIncr o mp'' - edge = (sIdx,oIdx,p) - in (mp''',edge : edges) - - lnodes = Map.elems (theMap mp) - intIdx = IntMap.fromList lnodes - ptGraph = G.mkGraph lnodes ledges - - in PatriciaTreeGraph (ptGraph ,intIdx, base', pms') - -triplesOf' :: PatriciaTreeGraph -> Triples -triplesOf' (PatriciaTreeGraph (g,idxLookup,_,_)) = - map (\(sIdx,oIdx,p) -> - let [s,o] = map (\idx -> fromJust $ IntMap.lookup idx idxLookup) [sIdx,oIdx] - in Triple s p o) (G.labEdges g) - -uniqTriplesOf' :: PatriciaTreeGraph -> Triples -uniqTriplesOf' ptG@(PatriciaTreeGraph (g,idxLookup,_,_)) = - nub $ map (\(sIdx,oIdx,p) -> - let [s,o] = map (\idx -> fromJust $ IntMap.lookup idx idxLookup) [sIdx,oIdx] - in expandTriple (prefixMappings ptG) (Triple s p o)) (G.labEdges g) - -mkTriples :: IntMap.IntMap Node -> Node -> [(Node, IntMap.Key)] -> [(Node, IntMap.Key)] -> [Triple] -mkTriples idxLookup thisNode adjsIn adjsOut = - let ts1 = map (\(predNode,subjIdx) -> - let s = fromJust (IntMap.lookup subjIdx idxLookup) - in Triple s predNode thisNode - ) adjsIn - - ts2 = map (\(predNode,objIdx) -> - let o = fromJust (IntMap.lookup objIdx idxLookup) - in Triple thisNode predNode o - ) adjsOut - in ts1 ++ ts2 - -select' :: PatriciaTreeGraph -> NodeSelector -> NodeSelector -> NodeSelector -> Triples -select' (PatriciaTreeGraph (g,idxLookup,_,_)) maybeSubjSel maybePredSel maybeObjSel = - - let cfun ( adjsIn , _nodeIdx , thisNode , adjsOut ) - | isNothing maybeSubjSel && isNothing maybePredSel && isNothing maybeObjSel = - mkTriples idxLookup thisNode adjsIn adjsOut - - | isJust maybeSubjSel && isNothing maybePredSel && isNothing maybeObjSel = - let adjsIn' = filter (\(_p,idxSubj) -> fromJust maybeSubjSel (fromJust (IntMap.lookup idxSubj idxLookup))) adjsIn - ts1 = mkTriples idxLookup thisNode adjsIn' [] - ts2 = if fromJust maybeSubjSel thisNode - then mkTriples idxLookup thisNode [] adjsOut - else [] - in ts1 ++ ts2 - | isNothing maybeSubjSel && isJust maybePredSel && isNothing maybeObjSel = - let adjsIn' = filter (\(p,_idxSubj) -> fromJust maybePredSel p ) adjsIn - adjsOut' = filter (\(p,_idxObj) -> fromJust maybePredSel p ) adjsOut - ts1 = if not (null adjsIn') - then mkTriples idxLookup thisNode adjsIn' [] - else [] - ts2 = if not (null adjsOut') - then mkTriples idxLookup thisNode [] adjsOut' - else [] - in ts1 ++ ts2 - - | isNothing maybeSubjSel && isNothing maybePredSel && isJust maybeObjSel = - let adjsOut' = filter (\(_p,idxObj) -> fromJust maybeObjSel (fromJust (IntMap.lookup idxObj idxLookup)) ) adjsOut - ts1 = mkTriples idxLookup thisNode [] adjsOut' - ts2 = if fromJust maybeObjSel thisNode - then mkTriples idxLookup thisNode adjsIn [] - else [] - in ts1 ++ ts2 - - | isJust maybeSubjSel && isJust maybePredSel && isNothing maybeObjSel = - let adjsIn' = filter (\(p,idxSubj) -> fromJust maybeSubjSel (fromJust (IntMap.lookup idxSubj idxLookup)) - && fromJust maybePredSel p ) adjsIn - adjsOut' = filter (\(p,_idxObj) -> fromJust maybePredSel p ) adjsOut - ts1 = mkTriples idxLookup thisNode adjsIn' [] - ts2 = if fromJust maybeSubjSel thisNode - then mkTriples idxLookup thisNode [] adjsOut' - else [] - in ts1 ++ ts2 - - | isJust maybeSubjSel && isNothing maybePredSel && isJust maybeObjSel = - let adjsIn' = filter (\(_p,idxSubj) -> fromJust maybeSubjSel (fromJust (IntMap.lookup idxSubj idxLookup)) ) adjsIn - adjsOut' = filter (\(_p,idxObj) -> fromJust maybeObjSel (fromJust (IntMap.lookup idxObj idxLookup)) ) adjsOut - ts1 = if fromJust maybeObjSel thisNode - then mkTriples idxLookup thisNode adjsIn' [] - else [] - ts2 = if fromJust maybeSubjSel thisNode - then mkTriples idxLookup thisNode [] adjsOut' - else [] - in ts1 ++ ts2 - - | isNothing maybeSubjSel && isJust maybePredSel && isJust maybeObjSel = - let adjsIn' = filter (\(p,_idxSubj) -> fromJust maybePredSel p ) adjsIn - adjsOut' = filter (\(p,idxObj) -> fromJust maybeObjSel (fromJust (IntMap.lookup idxObj idxLookup)) - && fromJust maybePredSel p ) adjsOut - ts1 = if fromJust maybeObjSel thisNode - then mkTriples idxLookup thisNode adjsIn' [] - else [] - ts2 = mkTriples idxLookup thisNode [] adjsOut' - in ts1 ++ ts2 - - | isJust maybeSubjSel && isJust maybePredSel && isJust maybeObjSel = - let adjsIn' = filter (\(p,idxSubj) -> fromJust maybeSubjSel (fromJust (IntMap.lookup idxSubj idxLookup)) - && fromJust maybePredSel p ) adjsIn - adjsOut' = filter (\(p,idxObj) -> fromJust maybeObjSel (fromJust (IntMap.lookup idxObj idxLookup)) - && fromJust maybePredSel p ) adjsOut - ts1 = if fromJust maybeObjSel thisNode - then mkTriples idxLookup thisNode adjsIn' [] - else [] - ts2 = if fromJust maybeSubjSel thisNode - then mkTriples idxLookup thisNode [] adjsOut' - else [] - in ts1 ++ ts2 - - cfun ( _ , _ , _ , _) = undefined -- not sure why this pattern is needed to exhaust cfun arg patterns - - in concat $ DFS.dfsWith' cfun g - -query' :: PatriciaTreeGraph -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples -query' (PatriciaTreeGraph (g,idxLookup,_,_)) maybeSubj maybePred maybeObj = - - let cfun ( adjsIn , _nodeIdx , thisNode , adjsOut ) - | isNothing maybeSubj && isNothing maybePred && isNothing maybeObj = - mkTriples idxLookup thisNode adjsIn adjsOut - - | isJust maybeSubj && isNothing maybePred && isNothing maybeObj = - let adjsIn' = filter (\(_p,idxSubj) -> fromJust (IntMap.lookup idxSubj idxLookup) == fromJust maybeSubj ) adjsIn - ts1 = mkTriples idxLookup thisNode adjsIn' [] - ts2 = if thisNode == fromJust maybeSubj - then mkTriples idxLookup thisNode [] adjsOut - else [] - in ts1 ++ ts2 - - | isNothing maybeSubj && isJust maybePred && isNothing maybeObj = - let adjsIn' = filter (\(p,_idxSubj) -> p == fromJust maybePred ) adjsIn - adjsOut' = filter (\(p,_idxObj) -> p == fromJust maybePred ) adjsOut - ts1 = if not (null adjsIn') - then mkTriples idxLookup thisNode adjsIn' [] - else [] - ts2 = if not (null adjsOut') - then mkTriples idxLookup thisNode [] adjsOut' - else [] - in ts1 ++ ts2 - - | isNothing maybeSubj && isNothing maybePred && isJust maybeObj = - let adjsOut' = filter (\(_p,idxObj) -> fromJust (IntMap.lookup idxObj idxLookup) == fromJust maybeObj ) adjsOut - ts1 = mkTriples idxLookup thisNode [] adjsOut' - ts2 = if thisNode == fromJust maybeObj - then mkTriples idxLookup thisNode adjsIn [] - else [] - in ts1 ++ ts2 - - | isJust maybeSubj && isJust maybePred && isNothing maybeObj = - let adjsIn' = filter (\(p,idxSubj) -> fromJust (IntMap.lookup idxSubj idxLookup) == fromJust maybeSubj - && p == fromJust maybePred ) adjsIn - adjsOut' = filter (\(p,_idxObj) -> p == fromJust maybePred ) adjsOut - ts1 = mkTriples idxLookup thisNode adjsIn' [] - ts2 = if thisNode == fromJust maybeSubj - then mkTriples idxLookup thisNode [] adjsOut' - else [] - in ts1 ++ ts2 - - | isJust maybeSubj && isNothing maybePred && isJust maybeObj = - let adjsIn' = filter (\(_p,idxSubj) -> fromJust (IntMap.lookup idxSubj idxLookup) == fromJust maybeSubj ) adjsIn - adjsOut' = filter (\(_p,idxObj) -> fromJust (IntMap.lookup idxObj idxLookup) == fromJust maybeObj ) adjsOut - ts1 = if thisNode == fromJust maybeObj - then mkTriples idxLookup thisNode adjsIn' [] - else [] - ts2 = if thisNode == fromJust maybeSubj - then mkTriples idxLookup thisNode [] adjsOut' - else [] - in ts1 ++ ts2 - - | isNothing maybeSubj && isJust maybePred && isJust maybeObj = - let adjsIn' = filter (\(p,_idxSubj) -> p == fromJust maybePred ) adjsIn - adjsOut' = filter (\(p,idxObj) -> fromJust (IntMap.lookup idxObj idxLookup) == fromJust maybeObj - && p == fromJust maybePred ) adjsOut - ts1 = if thisNode == fromJust maybeObj - then mkTriples idxLookup thisNode adjsIn' [] - else [] - ts2 = mkTriples idxLookup thisNode [] adjsOut' - in ts1 ++ ts2 - - | isJust maybeSubj && isJust maybePred && isJust maybeObj = - let adjsIn' = filter (\(p,idxSubj) -> fromJust (IntMap.lookup idxSubj idxLookup) == fromJust maybeSubj - && p == fromJust maybePred ) adjsIn - adjsOut' = filter (\(p,idxObj) -> fromJust (IntMap.lookup idxObj idxLookup) == fromJust maybeObj - && p == fromJust maybePred ) adjsOut - ts1 = if thisNode == fromJust maybeObj - then mkTriples idxLookup thisNode adjsIn' [] - else [] - ts2 = if thisNode == fromJust maybeSubj - then mkTriples idxLookup thisNode [] adjsOut' - else [] - in ts1 ++ ts2 - - cfun ( _ , _ , _ , _ ) = undefined -- not sure why this pattern is needed to exhaust cfun arg patterns - - in concat $ DFS.dfsWith' cfun g diff --git a/src/Data/RDF/Query.hs b/src/Data/RDF/Query.hs --- a/src/Data/RDF/Query.hs +++ b/src/Data/RDF/Query.hs @@ -4,10 +4,10 @@ equalSubjects, equalPredicates, equalObjects, subjectOf, predicateOf, objectOf, isEmpty, rdfContainsNode, tripleContainsNode, - listSubjectsWithPredicate, listObjectsOfPredicate, + subjectsWithPredicate, objectsOfPredicate, -- * RDF graph functions - isIsomorphic, expandTriples, fromEither, + isIsomorphic, isGraphIsomorphic, expandTriples, fromEither, -- * expansion functions expandTriple, expandNode, expandURI, @@ -22,7 +22,10 @@ import qualified Data.RDF.Namespace as NS (toPMList, uriOf, rdf) import qualified Data.Text as T import Data.Maybe (catMaybes) - +import Data.Graph (Graph,graphFromEdges) +import qualified Data.Graph.Automorphism as Automorphism +import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict (HashMap) -- |Answer the subject node of the triple. {-# INLINE subjectOf #-} @@ -50,7 +53,7 @@ -- Note that it doesn't perform namespace expansion! tripleContainsNode :: Node -> Triple -> Bool {-# INLINE tripleContainsNode #-} -tripleContainsNode node t = +tripleContainsNode node t = subjectOf t == node || predicateOf t == node || objectOf t == node -- |Determine whether two triples have equal subjects. @@ -75,20 +78,12 @@ in null ts -- |Lists of all subjects of triples with the given predicate. -listSubjectsWithPredicate :: RDF rdf => rdf -> Predicate -> [Subject] -listSubjectsWithPredicate rdf pred = - listNodesWithPredicate rdf pred subjectOf +subjectsWithPredicate :: RDF rdf => rdf -> Predicate -> [Subject] +subjectsWithPredicate rdf pred = map subjectOf $ query rdf Nothing (Just pred) Nothing -- |Lists of all objects of triples with the given predicate. -listObjectsOfPredicate :: RDF rdf => rdf -> Predicate -> [Object] -listObjectsOfPredicate rdf pred = - listNodesWithPredicate rdf pred objectOf - -listNodesWithPredicate :: RDF rdf => rdf -> Predicate -> (Triple -> Node) -> [Node] -listNodesWithPredicate rdf pred f = - let ts = triplesOf rdf - xs = filter (\t -> predicateOf t == pred) ts - in map f xs +objectsOfPredicate :: RDF rdf => rdf -> Predicate -> [Object] +objectsOfPredicate rdf pred = map objectOf $ query rdf Nothing (Just pred) Nothing -- |Convert a parse result into an RDF if it was successful -- and error and terminate if not. @@ -98,6 +93,8 @@ (Left err) -> error (show err) (Right rdf) -> rdf +-- graphFromEdges :: Ord key => [(node, key, [key])] -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex) + -- |This determines if two RDF representations are equal regardless of blank -- node names, triple order and prefixes. In math terms, this is the \simeq -- latex operator, or ~= @@ -121,6 +118,25 @@ normalize :: forall rdf. (RDF rdf) => rdf -> Triples normalize = sort . nub . expandTriples + +-- | Compares the structure of two graphs and returns 'True' if +-- their graph structures are identical. This does not consider the nature of +-- each node in the graph, i.e. the URI text of 'UNode' nodes, the generated +-- index of a blank node, or the values in literal nodes. +isGraphIsomorphic :: forall rdf1 rdf2. (RDF rdf1, RDF rdf2) => rdf1 -> rdf2 -> Bool +isGraphIsomorphic g1 g2 = Automorphism.isIsomorphic g1' g2' + where + g1' = rdfGraphToDataGraph g1 + g2' = rdfGraphToDataGraph g2 + rdfGraphToDataGraph :: RDF rdf3 => rdf3 -> Graph + rdfGraphToDataGraph g = dataGraph + where + triples = expandTriples g + triplesHashMap :: HashMap (Subject,Predicate) [Object] + triplesHashMap = HashMap.fromListWith (++) [((s,p), [o]) | Triple s p o <- triples] + triplesGrouped :: [((Subject,Predicate),[Object])] + triplesGrouped = HashMap.toList triplesHashMap + (dataGraph,_,_) = (graphFromEdges . map (\((s,p),os) -> (s,p,os))) triplesGrouped -- |Expand the triples in a graph with the prefix map and base URL for that -- graph. diff --git a/src/Data/RDF/TriplesGraph.hs b/src/Data/RDF/TriplesGraph.hs deleted file mode 100644 --- a/src/Data/RDF/TriplesGraph.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving , DeriveGeneric #-} - --- |"TriplesGraph" contains a list-backed graph implementation suitable --- for smallish graphs or for temporary graphs that will not be queried. --- It maintains the triples in the order that they are given in, and is --- especially useful for holding N-Triples, where it is often desirable --- to preserve the order of the triples when they were originally parsed. --- Duplicate triples are not filtered. If you might have duplicate triples, --- use @MGraph@ instead, which is also more efficient. However, the query --- functions of this graph (select, query) remove duplicates from their --- result triples (but triplesOf does not) since it is usually cheap --- to do so. -module Data.RDF.TriplesGraph(TriplesGraph, empty, mkRdf, triplesOf, uniqTriplesOf, select, query) - -where - -import Prelude hiding (pred) -import Control.DeepSeq (NFData) -import Data.Binary -import qualified Data.Map as Map -import Data.RDF.Namespace -import Data.RDF.Query -import Data.RDF.Types -import Data.List (nub) -import GHC.Generics - --- |A simple implementation of the 'RDF' type class that represents --- the graph internally as a list of triples. --- --- Note that this type of RDF is fine for interactive --- experimentation and querying of smallish (<10,000 triples) graphs, --- but there are better options for larger graphs or graphs that you --- will do many queries against (e.g., @MGraph@ is faster for queries). --- --- The time complexity of the functions (where n == num_triples) are: --- --- * 'empty' : O(1) --- --- * 'mkRdf' : O(n) --- --- * 'triplesOf': O(1) --- --- * 'select' : O(n) --- --- * 'query' : O(n) -newtype TriplesGraph = TriplesGraph (Triples, Maybe BaseUrl, PrefixMappings) - deriving (Generic,NFData) - -instance Binary TriplesGraph - -instance RDF TriplesGraph where - baseUrl = baseUrl' - prefixMappings = prefixMappings' - addPrefixMappings = addPrefixMappings' - empty = empty' - mkRdf = mkRdf' - triplesOf = triplesOf' - uniqTriplesOf = uniqTriplesOf' - select = select' - query = query' - -instance Show TriplesGraph where - show gr = concatMap (\t -> show t ++ "\n") (triplesOf gr) - -prefixMappings' :: TriplesGraph -> PrefixMappings -prefixMappings' (TriplesGraph (_, _, pms)) = pms - -addPrefixMappings' :: TriplesGraph -> PrefixMappings -> Bool -> TriplesGraph -addPrefixMappings' (TriplesGraph (ts, baseURL, pms)) pms' replace = - let merge = if replace then flip mergePrefixMappings else mergePrefixMappings - in TriplesGraph (ts, baseURL, merge pms pms') - -baseUrl' :: TriplesGraph -> Maybe BaseUrl -baseUrl' (TriplesGraph (_, baseURL, _)) = baseURL - -empty' :: TriplesGraph -empty' = TriplesGraph ([], Nothing, PrefixMappings Map.empty) - --- We no longer remove duplicates here, as it is very time consuming and is often not --- necessary (raptor does not seem to remove dupes either). Instead, we remove dupes --- from the results of the select' and query' functions, since it is cheap to do --- there in most cases, but not when triplesOf' is called. -mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> TriplesGraph -mkRdf' ts baseURL pms = TriplesGraph (ts, baseURL, pms) - -triplesOf' :: TriplesGraph -> Triples -triplesOf' (TriplesGraph (ts, _, _)) = ts - -uniqTriplesOf' :: TriplesGraph -> Triples -uniqTriplesOf' = nub . expandTriples - -select' :: TriplesGraph -> NodeSelector -> NodeSelector -> NodeSelector -> Triples -select' g s p o = filter (matchSelect s p o) $ triplesOf g - -query' :: TriplesGraph -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples -query' g s p o = filter (matchPattern s p o) $ triplesOf g - -matchSelect :: NodeSelector -> NodeSelector -> NodeSelector -> Triple -> Bool -matchSelect s p o t = - match s (subjectOf t) && match p (predicateOf t) && match o (objectOf t) - where - match Nothing _ = True - match (Just fn) n = fn n - -matchPattern :: Maybe Subject -> Maybe Predicate -> Maybe Object -> Triple -> Bool -matchPattern subj pred obj t = smatch t && pmatch t && omatch t - where - smatch trp = matchNode subj (subjectOf trp) - pmatch trp = matchNode pred (predicateOf trp) - omatch trp = matchNode obj (objectOf trp) - -matchNode :: Maybe Node -> Node -> Bool -matchNode Nothing _ = True -matchNode (Just n1) n2 = n1 == n2 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 @@ -9,7 +9,7 @@ -- * Constructor functions plainL,plainLL,typedL, - unode,bnode,lnode,triple,unodeValidate, + unode,bnode,lnode,triple,unodeValidate,uriValidate,uriValidateString, -- * Node query function isUNode,isLNode,isBNode, @@ -40,14 +40,19 @@ 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) import Data.Hashable(Hashable) import qualified Data.List as List import qualified Data.Map as Map -import qualified Network.URI as Network (isURI,uriPath,parseURI) +import qualified Network.URI as Network (uriPath,parseURI) import Control.DeepSeq (NFData,rnf) import Text.Parsec +import Text.Parsec.Text +import Network.URI +import Codec.Binary.UTF8.String ------------------- -- LValue and constructor functions @@ -67,7 +72,7 @@ -- |A typed literal value consisting of the literal value and -- the URI of the datatype of the value, respectively. | TypedL !T.Text !T.Text - deriving Generic + deriving (Generic,Show) instance Binary LValue @@ -118,7 +123,7 @@ -- for more -- information. | LNode !LValue - deriving Generic + deriving (Generic,Show) instance Binary Node @@ -156,12 +161,54 @@ -- 2. checks validity of this unescaped URI using 'isURI' from 'Network.URI' -- 3. if the unescaped URI is valid then 'Node' constructed with 'UNode' unodeValidate :: T.Text -> Maybe Node -unodeValidate t = if Network.isURI (T.unpack uri) - then Just (UNode uri) - else Nothing - where - uri = escapeRDFSyntax t +unodeValidate t = case isRdfURI t of + Left _err -> Nothing + Right uri -> Just (UNode uri) +isRdfURI :: T.Text -> Either ParseError T.Text +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) + +-- [10] UCHAR +nt_uchar :: GenParser () 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))) + +uEscapedToXEscaped :: String -> String +uEscapedToXEscaped ss = + let str = ['\\','x'] ++ ss + in read ("\"" ++ str ++ "\"") + +-- |Validate a Text URI and return it in a @Just Text@ if it is +-- valid, otherwise @Nothing@ is returned. See 'unodeValidate'. +uriValidate :: T.Text -> Maybe T.Text +uriValidate t = case isRdfURI t of + Left _err -> Nothing + Right uri -> Just uri + +-- |Same as 'uriValidate', but on 'String' rather than 'T.Text' +uriValidateString :: String -> Maybe String +uriValidateString t = case isRdfURIString of + Left _err -> Nothing + Right uri -> Just uri + where + 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)) + -- [18] IRIREF from Turtle spec + validUriChar = try $ do + c <- anyChar + guard $ not (c >= '\x00' && c <= '\x20') && c `notElem` [' ','<','>','"','{','}','|','^','`','\\'] + return c + +-- | Escapes @\Uxxxxxxxx@ and @\uxxxx@ character sequences according +-- to the RDF specification. escapeRDFSyntax :: T.Text -> T.Text escapeRDFSyntax t = T.pack uri where @@ -214,7 +261,7 @@ -- See for -- more information. data Triple = Triple !Node !Node !Node - deriving (Generic) + deriving (Generic,Show) instance Binary Triple @@ -254,8 +301,15 @@ isLNode _ = False {-# INLINE isAbsoluteUri #-} +-- | returns @True@ if URI is absolute. isAbsoluteUri :: T.Text -> Bool -isAbsoluteUri = Network.isURI . T.unpack +isAbsoluteUri = not + . uriIsRelative + . fromJust + . parseURIReference + . escapeURIString isUnescapedInURI + . encodeString + . T.unpack -- |A type class for ADTs that expose views to clients. class View a b where @@ -524,23 +578,6 @@ instance Hashable LValue --- String representations of the various data types; generally NTriples-like. - -instance Show Triple where - show (Triple s p o) = - printf "Triple(%s,%s,%s)" (show s) (show p) (show o) - -instance Show Node where - show (UNode uri) = "UNode(" ++ show uri ++ ")" - show (BNode i) = "BNode(" ++ show i ++ ")" - show (BNodeGen genId) = "BNodeGen(" ++ show genId ++ ")" - show (LNode lvalue) = "LNode(" ++ show lvalue ++ ")" - -instance Show LValue where - show (PlainL lit) = "PlainL(" ++ T.unpack lit ++ ")" - show (PlainLL lit lang) = "PlainLL(" ++ T.unpack lit ++ ", " ++ T.unpack lang ++ ")" - show (TypedL lit dtype) = "TypedL(" ++ T.unpack lit ++ "," ++ show dtype ++ ")" - ------------------------ -- Prefix mappings @@ -581,14 +618,13 @@ ----------------- -- Miscellaneous helper functions used throughout the project --- Resolve a prefix using the given prefix mappings and base URL. If the prefix is --- empty, then the base URL will be used if there is a base URL and if the map --- does not contain an entry for the empty prefix. +-- | Resolve a prefix using the given prefix mappings and base URL. If the prefix is +-- empty, then the base URL will be used if there is a base URL and +-- if the map does not contain an entry for the empty prefix. resolveQName :: Maybe BaseUrl -> T.Text -> PrefixMappings -> Maybe T.Text resolveQName mbaseUrl prefix (PrefixMappings pms') = case (mbaseUrl, T.null prefix) of (Just (BaseUrl base), True) -> Just $ Map.findWithDefault base T.empty pms' - (Nothing, True) -> Nothing (_, _ ) -> Map.lookup prefix pms' {- alternative implementation from Text.RDF.RDF4H.ParserUtils @@ -607,8 +643,8 @@ err2 = error ("Cannot resolve QName prefix: " ++ T.unpack prefix) -} --- Resolve a URL fragment found on the right side of a prefix mapping --- by converting it to an absolute URL if possible. +-- | Resolve a URL fragment found on the right side of a prefix mapping +-- by converting it to an absolute URL if possible. absolutizeUrl :: Maybe BaseUrl -> Maybe T.Text -> T.Text -> T.Text absolutizeUrl mbUrl mdUrl urlFrag = if isAbsoluteUri urlFrag then urlFrag else @@ -642,12 +678,11 @@ -} {-# INLINE mkAbsoluteUrl #-} --- Make an absolute URL by returning as is if already an absolute URL and otherwise --- appending the URL to the given base URL. +-- | Make an absolute URL by returning as is if already an absolute URL and otherwise +-- appending the URL to the given base URL. mkAbsoluteUrl :: T.Text -> T.Text -> T.Text mkAbsoluteUrl base url = - if isAbsoluteUri url then url else base `T.append` url - + if isAbsoluteUri url then url else base `T.append` url ----------------- -- Internal canonicalize functions, don't export diff --git a/src/Rdf4hParseMain.hs b/src/Rdf4hParseMain.hs --- a/src/Rdf4hParseMain.hs +++ b/src/Rdf4hParseMain.hs @@ -6,7 +6,7 @@ module Main where import Data.RDF.Types -import Data.RDF.TriplesGraph +import Data.RDF.Graph.TriplesList import Text.RDF.RDF4H.NTriplesParser import Text.RDF.RDF4H.NTriplesSerializer import Text.RDF.RDF4H.TurtleParser @@ -65,22 +65,22 @@ ("turtle", True) -> parseURL (TurtleParser mInputUri docUri) inputUri >>= - \ (res :: Either ParseFailure TriplesGraph) -> + \ (res :: Either ParseFailure TriplesList) -> write outputFormat docUri emptyPms res ("turtle", False) -> (if inputUri /= "-" then parseFile (TurtleParser mInputUri docUri) inputUri else liftM (parseString (TurtleParser mInputUri docUri)) TIO.getContents) >>= - \ (res :: Either ParseFailure TriplesGraph) -> + \ (res :: Either ParseFailure TriplesList) -> write outputFormat docUri emptyPms res ("ntriples", True) -> parseURL NTriplesParser inputUri >>= - \ (res :: Either ParseFailure TriplesGraph) -> + \ (res :: Either ParseFailure TriplesList) -> write outputFormat Nothing emptyPms res ("ntriples", False) -> (if inputUri /= "-" then parseFile NTriplesParser inputUri else liftM (parseString NTriplesParser) TIO.getContents) >>= - \ (res :: Either ParseFailure TriplesGraph) -> + \ (res :: Either ParseFailure TriplesList) -> write outputFormat Nothing emptyPms res (str, _) -> putStrLn ("Invalid format: " ++ str) >> exitFailure 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 @@ -17,8 +17,8 @@ import qualified Data.Text as T import Data.RDF.Types hiding (baseUrl) -import Data.RDF.TriplesGraph() -import Data.RDF.MGraph() +import Data.RDF.Graph.TriplesList() +import Data.RDF.Graph.HashMapS() import Text.RDF.RDF4H.NTriplesParser import Text.RDF.RDF4H.TurtleParser 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 @@ -1,24 +1,24 @@ --- |A parser for RDF in N-Triples format +-- |A parser for RDF in N-Triples format -- . -module Text.RDF.RDF4H.NTriplesParser( - NTriplesParser(NTriplesParser), ParseFailure -) where +module Text.RDF.RDF4H.NTriplesParser + (NTriplesParser(NTriplesParser), ParseFailure) + where import Prelude hiding (init,pred) import Data.RDF.Types import Text.RDF.RDF4H.ParserUtils -import Data.Char(isLetter, isDigit, isLower,isAlphaNum) -import qualified Data.Map as Map +import Data.Char (isLetter, isDigit,isAlphaNum) +import Data.Map as Map (empty) import Text.Parsec import Text.Parsec.Text import qualified Data.Text as T import qualified Data.Text.IO as TIO -import Control.Monad (liftM,void) +import Control.Monad (liftM,void,guard) -- |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 +-- pass an 'NTriplesParser' value as the first argument to any of the -- 'parseString', 'parseFile', or 'parseURL' methods of the 'RdfParser' type -- class. data NTriplesParser = NTriplesParser @@ -38,60 +38,90 @@ nt_ntripleDoc = manyTill nt_line eof nt_line :: GenParser () (Maybe Triple) -nt_line = +nt_line = skipMany nt_space >> - (nt_comment <|> nt_triple <|> nt_empty) >>= - \res -> nt_eoln >> return res + ((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 --- A comment consists of an initial # character, followed by any number of --- characters except cr or lf. The spec is redundant in specifying that --- comment is hash followed by "character - (cr | lf)", since character --- is already defined as the range #x0020-#x007E, so cr #x000D and --- lf #x000A are both already excluded. This returns Nothing as we are --- ignoring comments for now. nt_comment :: GenParser () (Maybe Triple) -nt_comment = char '#' >> skipMany nt_character >> return Nothing +nt_comment = char '#' >> manyTill anyChar nt_eoln >> return Nothing -- A triple consists of whitespace-delimited subject, predicate, and object, -- followed by optional whitespace and a period, and possibly more -- whitespace. +-- +-- NTriples W3C test "minimal_whitespace" proposes no space: +-- +-- "tests absense of whitespace between subject, predicate, object and +-- end-of-statement" +-- +-- `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 = do subj <- nt_subject - skipMany1 nt_space + optional (skipMany1 nt_space) pred <- nt_predicate - skipMany1 nt_space + optional (skipMany1 nt_space) obj <- nt_object - skipMany nt_space + optional (skipMany1 nt_space) void (char '.') void (many nt_space) return $ Just (Triple subj pred obj) --- A literal is either a language literal (with optional language --- specified) or a datatype literal (with required datatype --- specified). The literal value is always enclosed in double --- quotes. A language literal may have '@' after the closing quote, --- followed by a language specifier. A datatype literal follows --- the closing quote with ^^ followed by the URI of the datatype. +-- [6] literal nt_literal :: GenParser () LValue -nt_literal = - do lit_str <- between (char '"') (char '"') inner_literal - liftM (plainLL lit_str) (char '@' >> nt_language) <|> - liftM (typedL lit_str) (count 2 (char '^') >> nt_uriref) <|> - return (plainL lit_str) - where inner_literal = inner_string +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))) --- A language specifier of a language literal is any number of lowercase --- letters followed by any number of blocks consisting of a hyphen followed --- by one or more lowercase letters or digits. -nt_language :: GenParser () T.Text -nt_language = - do str <- liftM T.pack (many (satisfy (\ c -> c == '-' || isLower c))) - if T.null str || T.last str == '-' || T.head str == '-' - then fail ("Invalid language string: '" ++ T.unpack str ++ "'") - else return str +-- [9] STRING_LITERAL_QUOTE +nt_string_literal_quote :: GenParser () T.Text +nt_string_literal_quote = + between (char '"') (char '"') $ do + T.concat <$> (many ((T.singleton <$> noneOf ['\x22','\x5C','\xA','\xD']) <|> + nt_echar <|> + nt_uchar)) +-- [144s] LANGTAG +nt_langtag :: GenParser () 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)) + +-- [8] IRIREF +nt_iriref :: GenParser () T.Text +nt_iriref = do + between (char '<') (char '>') $ do + 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]) + +isEchar :: Char -> Bool +isEchar = (`elem` ['t','b','n','r','f','"','\'','\\']) + +-- [10] UCHAR +nt_uchar :: GenParser () 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))) + -- 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) @@ -102,7 +132,7 @@ nt_subject :: GenParser () Node nt_subject = liftM unode nt_uriref <|> - liftM bnode nt_nodeID + liftM bnode nt_blank_node_label -- A predicate may only be a URI reference to a resource. nt_predicate :: GenParser () Node @@ -113,40 +143,97 @@ nt_object :: GenParser () Node nt_object = liftM unode nt_uriref <|> - liftM bnode nt_nodeID <|> + liftM bnode nt_blank_node_label <|> liftM LNode nt_literal +validateUNode :: T.Text -> GenParser () Node +validateUNode t = + case unodeValidate t of + Nothing -> unexpected ("Invalid URI in NTriples parser URI validation: " ++ show t) + Just u@(UNode{}) -> return u + Just node -> unexpected ("Unexpected node in NTriples parser URI validation: " ++ show node) + +validateURI :: T.Text -> GenParser () T.Text +validateURI t = do + UNode uri <- validateUNode t + return uri + +isAbsoluteParser :: T.Text -> GenParser () T.Text +isAbsoluteParser t = + if isAbsoluteUri t + then return 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 + -- A URI reference is one or more nrab_character inside angle brackets. nt_uriref :: GenParser () T.Text -nt_uriref = between (char '<') (char '>') (liftM T.pack (many (satisfy ( /= '>')))) +nt_uriref = between (char '<') (char '>') $ do + unvalidatedUri <- many (satisfy ( /= '>')) + t <- validateURI (T.pack unvalidatedUri) + absoluteURI t --- A node id is "_:" followed by a name. -nt_nodeID :: GenParser () T.Text -nt_nodeID = char '_' >> char ':' >> nt_name >>= \n -> - return ('_' `T.cons` (':' `T.cons` n)) +-- [141s] BLANK_NODE_LABEL +nt_blank_node_label :: GenParser () 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)) --- A name is a letter followed by any number of alpha-numeric characters. -nt_name :: GenParser () T.Text -nt_name = - do init <- letter - rest <- many (satisfy isLetterOrDigit) - return $ T.pack (init:rest) +-- [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 +-} -isLetterOrDigit :: Char -> Bool -isLetterOrDigit c = isLetter c || isDigit c +isBaseChar :: Char -> Bool +isBaseChar c + = (c >= 'A' && c <= 'Z') + || (c >= 'a' && c <= 'z') + || (c >= '\x00C0' && c <= '\x00D6') + || (c >= '\x00D8' && c <= '\x00F6') + || (c >= '\x00F8' && c <= '\x02FF') + || (c >= '\x0370' && c <= '\x037D') + || (c >= '\x037F' && c <= '\x1FFF') + || (c >= '\x200C' && c <= '\x200D') + || (c >= '\x2070' && c <= '\x218F') + || (c >= '\x2C00' && c <= '\x2FEF') + || (c >= '\x3001' && c <= '\xD7FF') + || (c >= '\xF900' && c <= '\xFDCF') + || (c >= '\xFDF0' && c <= '\xFFFD') + || (c >= '\x10000' && c <= '\xEFFFF') --- An nt_character is any character except a double quote character. -nt_character :: GenParser () Char -nt_character = satisfy is_nonquote_char --- A character is any Unicode value from ASCII space to decimal 126 (tilde). -is_character :: Char -> Bool -is_character = isAlphaNum +-- [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 --- A non-quote character is a character that isn't the double-quote character. -is_nonquote_char :: Char -> Bool -is_nonquote_char c = is_character c && c/= '"' +-- [160s] PN_CHARS +nt_pn_chars :: GenParser () Char +nt_pn_chars = nt_pn_chars_u <|> try (do + c <- anyChar + guard $ 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 () () @@ -169,32 +256,6 @@ nt_tab :: GenParser () Char nt_tab = char '\t' --- An inner_string is a fragment of a string (this is used inside double --- quotes), and consists of the non-quote characters allowed and the --- standard escapes for a backslash (\\), a tab (\t), a carriage return (\r), --- a newline (\n), a double-quote (\"), a 4-digit Unicode escape (\uxxxx --- where x is a hexadecimal digit), and an 8-digit Unicode escape --- (\Uxxxxxxxx where x is a hexadecimaldigit). -inner_string :: GenParser () T.Text -inner_string = - try (char '\\' >> - ((char 't' >> return b_tab) <|> - (char 'r' >> return b_ret) <|> - (char 'n' >> return b_nl) <|> - (char '\\' >> return b_slash) <|> - (char '"' >> return b_quote) <|> - (char 'u' >> count 4 hexDigit >>= \cs -> return $ T.pack ('\\':'u':cs)) <|> - (char 'U' >> count 8 hexDigit >>= \cs -> return $ T.pack ('\\':'U':cs)))) - <|> liftM T.pack - (many (satisfy (\ c -> is_nonquote_char c && c /= '\\'))) - -b_tab, b_ret, b_nl, b_slash, b_quote :: T.Text -b_tab = T.singleton '\t' -b_ret = T.singleton '\r' -b_nl = T.singleton '\n' -b_slash = T.singleton '\\' -b_quote = T.singleton '"' - parseString' :: forall rdf. (RDF rdf) => T.Text -> Either ParseFailure rdf parseString' bs = handleParse mkRdf (runParser nt_ntripleDoc () "" bs) @@ -210,7 +271,7 @@ Either ParseFailure rdf handleParse _mkRdf result -- | T.length rem /= 0 = (Left $ ParseFailure $ "Invalid Document. Unparseable end of document: " ++ T.unpack rem) - | otherwise = + | otherwise = case result of Left err -> Left $ ParseFailure $ "Parse failure: \n" ++ show err Right ts -> Right $ _mkRdf (conv ts) Nothing (PrefixMappings Map.empty) diff --git a/src/Text/RDF/RDF4H/TurtleParser.hs b/src/Text/RDF/RDF4H/TurtleParser.hs --- a/src/Text/RDF/RDF4H/TurtleParser.hs +++ b/src/Text/RDF/RDF4H/TurtleParser.hs @@ -7,7 +7,7 @@ where -import Data.Char (toLower,toUpper) +import Data.Char (isLetter,isAlphaNum,toLower,toUpper) import Data.Maybe import Data.RDF.Types import Data.RDF.Namespace @@ -49,12 +49,14 @@ [Subject], -- stack of current subject nodes, if we have parsed a subject but not finished the triple [Predicate], -- stack of current predicate nodes, if we've parsed a predicate but not finished the triple [Bool], -- a stack of values to indicate that we're processing a (possibly nested) collection; top True indicates just started (on first element) + [Bool], -- when in a collection, is it a subject collection or not + Bool, -- when in a blank node property list, is it a subject collection or not Seq Triple) -- the triples encountered while parsing; always added to on the right side -- grammar rule: [1] turtleDoc t_turtleDoc :: GenParser ParseState (Seq Triple, PrefixMappings) t_turtleDoc = - many t_statement >> (eof "eof") >> getState >>= \(_, _, _, pms, _, _, _, ts) -> return (ts, pms) + many t_statement >> (eof "eof") >> getState >>= \(_, _, _, pms, _, _, _, _, _, ts) -> return (ts, pms) -- grammar rule: [2] statement t_statement :: GenParser ParseState () @@ -69,14 +71,27 @@ (many t_ws "triple-whitespace2")) -- grammar rule: [6] triples +-- subject predicateObjectList | blankNodePropertyList predicateObjectList? t_triples :: GenParser ParseState () -t_triples = t_subject >> (many1 t_ws "subject-predicate-whitespace") >> t_predicateObjectList >> resetSubjectPredicate +t_triples = do + 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 = between (char '[') (char ']') $ do + subjPropList <- isSubjPropList + blankNode <- liftM BNodeGen nextIdCounter + unless subjPropList $ addTripleForObject blankNode + pushSubj blankNode + (many t_ws >> t_predicateObjectList >> void (many t_ws)) + unless subjPropList $ void popSubj + -- grammar rule: [3] directive t_directive :: GenParser ParseState () 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 = try t_iriref <|> t_prefixedName @@ -95,7 +110,7 @@ uriFrag <- t_iriref void (many t_ws "prefixID-whitespace") void (char '.' "end-of-prefixID-period") - (bUrl, dUrl, _, PrefixMappings pms, _, _, _, _) <- getState + (bUrl, dUrl, _, PrefixMappings pms, _, _, _, _, _, _) <- getState updatePMs $ Just (PrefixMappings $ Map.insert pre (absolutizeUrl bUrl dUrl uriFrag) pms) return () @@ -106,7 +121,7 @@ pre <- (many1 t_ws "whitespace-after-@prefix") >> option T.empty t_pn_prefix void (char ':' >> (many1 t_ws "whitespace-after-@prefix-colon")) uriFrag <- t_iriref - (bUrl, dUrl, _, PrefixMappings pms, _, _, _, _) <- getState + (bUrl, dUrl, _, PrefixMappings pms, _, _, _, _, _, _) <- getState updatePMs $ Just (PrefixMappings $ Map.insert pre (absolutizeUrl bUrl dUrl uriFrag) pms) return () @@ -133,34 +148,33 @@ updateBaseUrl (Just $ Just $ newBaseUrl bUrl (absolutizeUrl bUrl dUrl urlFrag)) t_verb :: GenParser ParseState () +-- [9] verb ::= predicate | 'a' t_verb = (try t_predicate <|> (char 'a' >> return rdfTypeNode)) >>= pushPred -- grammar rule: [11] predicate t_predicate :: GenParser ParseState Node t_predicate = liftM UNode (t_iri "resource") --- res <- t_iri "resource" --- validateUNode res -t_nodeID :: GenParser ParseState T.Text -t_nodeID = do { void (try (string "_:")); cs <- t_name; return $! "_:" `T.append` cs } - -- grammar rules: [139s] PNAME_NS t_pname_ns :: GenParser ParseState T.Text t_pname_ns =do pre <- option T.empty (try t_pn_prefix) void (char ':') - (bUrl, _, _, pms, _, _, _, _) <- getState + (bUrl, _, _, pms, _, _, _, _, _, _) <- getState case resolveQName bUrl pre pms of - Just n -> return n + Just n -> return 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 = do x <- t_pn_chars_u_str <|> string ":" <|> satisfy_str <|> t_plx - xs <- option "" $ do - ys <- many ( t_pn_chars_str <|> string "." <|> string ":" <|> t_plx ) - return (concat ys) + 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 ".")) + concat <$> many recsve return (T.pack (x ++ xs)) where satisfy_str = satisfy (flip in_range [('0', '9')]) >>= \c -> return [c] @@ -194,34 +208,61 @@ t_pname_ln = do pre <- t_pname_ns name <- t_pn_local - return (pre `T.append` name) + return (pre `T.append` name) -- grammar rule: [10] subject +-- [10] subject ::= iri | BlankNode | collection t_subject :: GenParser ParseState () t_subject = iri <|> - simpleBNode <|> - nodeId <|> - between (char '[') (char ']') poList + (t_blankNode >>= pushSubj) <|> + (liftM BNodeGen nextIdCounter >>= pushSubj + >> pushPred rdfFirstNode + >> pushSubjColl + >> t_collection) where - iri = liftM unode (try t_iri "subject resource") >>= pushSubj - nodeId = liftM BNode (try t_nodeID "subject nodeID") >>= pushSubj - simpleBNode = try (string "[]") >> nextIdCounter >>= pushSubj . BNodeGen - poList = void - (nextIdCounter >>= pushSubj . BNodeGen >> many t_ws >> - t_predicateObjectList >> - many t_ws) + iri = liftM unode (try t_iri "subject resource") >>= \s -> pushSubj s --- verb objectList (';' (verb objectList)?)* --- --- verb ws+ objectList ( ws* ';' ws* verb ws+ objectList )* (ws* ';')? --- grammar rule: [7] predicateObjectlist +-- [137s] BlankNode ::= BLANK_NODE_LABEL | ANON +t_blankNode :: GenParser ParseState Node +t_blankNode = do + (try t_blank_node_label <|> t_anon) + i <- nextIdCounter + let node = BNodeGen i + return node + +-- 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 () +t_blank_node_label = do + void (string "_:") + void (t_pn_chars_u <|> oneOf ['0'..'9']) + optional $ try $ do + ss <- option "" $ do + xs <- many (t_pn_chars <|> char '.') + if null xs + then return xs + else if last xs == '.' + then unexpected "'.' at the end of a blank node label" + else return xs + return ss + +-- [162s] ANON ::= '[' WS* ']' +t_anon :: GenParser ParseState () +t_anon = between (char '[') (char ']') (void (many t_ws)) + +-- [7] predicateObjectList ::= verb objectList (';' (verb objectList)?)* t_predicateObjectList :: GenParser ParseState () -t_predicateObjectList = - do void (sepEndBy1 (try (t_verb >> many1 t_ws >> t_objectList >> popPred)) (try (many t_ws >> char ';' >> optional (char ';') >> many t_ws))) --- return () +t_predicateObjectList = do + void (sepEndBy1 + (optional (try (do { t_verb + ; many1 t_ws + ; t_objectList + ; void popPred}))) + (try (many t_ws >> char ';' >> many t_ws))) -- grammar rule: [8] objectlist +-- [8] objectList ::= object (',' object)* t_objectList :: GenParser ParseState () t_objectList = -- t_object actually adds the triples void @@ -229,60 +270,57 @@ 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 = - do inColl <- isInColl -- whether this object is in a collection - onFirstItem <- onCollFirstItem -- whether we're on the first item of the collection - let processObject = (t_literal >>= addTripleForObject) <|> - (liftM UNode t_iri >>= addTripleForObject) <|> - blank_as_obj <|> t_collection - case (inColl, onFirstItem) of - (False, _) -> processObject - (True, True) -> liftM BNodeGen nextIdCounter >>= \bSubj -> addTripleForObject bSubj >> - pushSubj bSubj >> pushPred rdfFirstNode >> processObject >> collFirstItemProcessed - (True, False) -> liftM BNodeGen nextIdCounter >>= \bSubj -> pushPred rdfRestNode >> - addTripleForObject bSubj >> popPred >> popSubj >> - pushSubj bSubj >> processObject +t_object = do + inColl <- isInColl + inSubjColl <- isInSubjColl + onFirstItem <- onCollFirstItem + let processObject = + (liftM UNode t_iri >>= addTripleForObject) <|> + (try t_blankNode >>= addTripleForObject) <|> + (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 -- collection: '(' ws* itemList? ws* ')' -- itemList: object (ws+ object)* -- grammar rule: [15] collection -t_collection:: GenParser ParseState () +-- 15] collection ::= '(' object* ')' +t_collection :: GenParser ParseState () t_collection = - -- ( object1 object2 ) is short for: - -- [ rdf:first object1; rdf:rest [ rdf:first object2; rdf:rest rdf:nil ] ] - -- ( ) is short for the resource: rdf:nil - between (char '(') (char ')') $ - do beginColl - void (many t_ws) - emptyColl <- option True (try t_object >> many t_ws >> return False) - if emptyColl then void (addTripleForObject rdfNilNode) else - void - (many (many t_ws >> try t_object >> many t_ws) >> popPred >> - pushPred rdfRestNode >> - addTripleForObject rdfNilNode >> - popPred >> popSubj) - void finishColl - return () + between (char '(') (char ')') $ do + beginColl + (try empty_list <|> non_empty_list) + void finishColl + -- popColl + where + non_empty_list = do + many1 (many t_ws >> t_object >> many t_ws) -blank_as_obj :: GenParser ParseState () -blank_as_obj = - -- if a node id, like _:a1, then create a BNode and add the triple - (liftM BNode t_nodeID >>= addTripleForObject) <|> - -- if a simple blank like [], do likewise - (genBlank >>= addTripleForObject) <|> - -- if a blank containing a predicateObjectList, like [ :b :c; :b :d ] - poList - where - genBlank = liftM BNodeGen (try (string "[]") >> nextIdCounter) - poList = between (char '[') (char ']') $ - liftM BNodeGen nextIdCounter >>= \bSubj -> -- generate new bnode - void - (addTripleForObject bSubj >> -- add triple with bnode as object - many t_ws >> pushSubj bSubj >> -- push bnode as new subject - t_predicateObjectList >> popSubj >> many t_ws) -- process polist, which uses bnode as subj, then pop bnode + _inSubjColl <- isInSubjColl + popPred + pushPred rdfRestNode + addTripleForObject rdfNilNode + -- popPred + -- if inSubjColl then trace "is sub" popColl else trace "not sub" $ void popSubj + -- if inSubjColl then return () else trace "not sub" $ void popSubj + + empty_list = do + lookAhead (try (many t_ws >> char ')')) + addTripleForObject rdfNilNode + rdfTypeNode, rdfNilNode, rdfFirstNode, rdfRestNode :: Node rdfTypeNode = UNode $ mkUri rdf "type" rdfNilNode = UNode $ mkUri rdf "nil" @@ -297,67 +335,129 @@ t_literal :: GenParser ParseState Node t_literal = - try str_literal <|> - liftM (`mkLNode` xsdDoubleUri) (try t_double) <|> - liftM (`mkLNode` xsdIntUri) (try t_integer) <|> - liftM (`mkLNode` xsdDecimalUri) (try t_decimal) <|> + (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 + where mkLNode :: T.Text -> T.Text -> Node mkLNode bsType bs' = LNode (typedL bsType bs') -str_literal :: GenParser ParseState Node -str_literal = - do str' <- t_quotedString "quotedString" - let str = escapeRDFSyntax str' - liftM (LNode . typedL str) - (try (count 2 (char '^')) >> t_iri) <|> - liftM (lnode . plainLL str) (char '@' >> t_language) <|> - return (lnode $ plainL str) - -t_quotedString :: GenParser ParseState T.Text -t_quotedString = try t_longString <|> t_string +-- [128s] RDFLiteral +-- String (LANGTAG | '^^' iri)? +t_rdf_literal :: GenParser ParseState 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)))) --- a non-long string: any number of scharacters (echaracter without ") inside doublequotes or singlequotes. +-- [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 = liftM T.concat (between (char '"') (char '"') (many t_scharacter_in_dquot) <|> between (char '\'') (char '\'') (many t_scharacter_in_squot)) +t_string = try t_string_literal_long_quote <|> + try t_string_literal_long_single_quote <|> + try t_string_literal_quote <|> + t_string_literal_single_quote -t_longString :: GenParser ParseState T.Text -t_longString = - try ( do { void tripleQuoteDbl; - strVal <- liftM T.concat (many longString_char); - void tripleQuoteDbl; - return strVal }) <|> - try ( do { void tripleQuoteSingle; - strVal <- liftM T.concat (many longString_char); - void tripleQuoteSingle; - return strVal }) - where - tripleQuoteDbl = count 3 (char '"') - tripleQuoteSingle = count 3 (char '\'') +-- [22] STRING_LITERAL_QUOTE +-- '"' ([^#x22#x5C#xA#xD] | ECHAR | UCHAR)* '"' +t_string_literal_quote :: GenParser ParseState T.Text +t_string_literal_quote = + between (char '"') (char '"') $ do + 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 = + between (char '\'') (char '\'') $ do + T.concat <$> + many (T.singleton <$> noneOf ['\x27','\x5C','\xA','\xD'] <|> + t_echar <|> + t_uchar) + +-- [24] STRING_LITERAL_LONG_SINGLE_QUOTE +-- "'''" (("'" | "''")? ([^'\] | ECHAR | UCHAR))* "'''" +t_string_literal_long_single_quote :: GenParser ParseState T.Text +t_string_literal_long_single_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) + +-- [25] STRING_LITERAL_LONG_QUOTE +-- '"""' (('"' | '""')? ([^"\] | ECHAR | UCHAR))* '"""' +t_string_literal_long_quote :: GenParser ParseState 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) + +-- [144s] LANGTAG +-- '@' [a-zA-Z]+ ('-' [a-zA-Z0-9]+)* +t_langtag :: GenParser ParseState 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)) + +-- [159s] ECHAR +-- '\' [tbnrf"'\] +t_echar :: GenParser ParseState 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." + +-- [26] UCHAR +-- '\u' HEX HEX HEX HEX | '\U' HEX HEX HEX HEX HEX HEX HEX HEX +t_uchar :: GenParser ParseState 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)) + +-- [19] INTEGER ::= [+-]? [0-9]+ t_integer :: GenParser ParseState T.Text -t_integer = +t_integer = try $ do sign <- sign_parser "+-" - ds <- many1 digit "digit" - notFollowedBy (char '.') - -- integer must be in canonical format, with no leading plus sign or leading zero + ds <- many1 (oneOf ['0'..'9'] "digit") return $! ( 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 = do sign <- sign_parser "+-" - rest <- try (do { ds <- many1 digit "digit"; + rest <- try (do { ds <- many1 (oneOf ['0'..'9']) "digit"; void (char '.'); - ds' <- many digit "digit"; + ds' <- many (oneOf ['0'..'9']) "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 digit "digit"; + ds <- many1 (oneOf ['0'..'9']) "digit"; e <- t_exponent "exponent"; return ('.' `T.cons` T.pack ds `T.append` e) }) <|> - try (do { ds <- many1 digit "digit"; + (do { ds <- many1 (oneOf ['0'..'9']) "digit"; e <- t_exponent "exponent"; return ( T.pack ds `T.append` e) }) return $! T.pack sign `T.append` rest @@ -365,13 +465,14 @@ sign_parser :: GenParser ParseState String sign_parser = option "" (oneOf "-+" >>= (\c -> return [c])) +-- [20] DECIMAL ::= [+-]? [0-9]* '.' [0-9]+ t_decimal :: GenParser ParseState T.Text -t_decimal = - do sign <- sign_parser - rest <- try (do ds <- many digit "digit"; void (char '.'); ds' <- option "" (many digit); return (ds ++ ('.':ds'))) - <|> try (do { void (char '.'); ds <- many1 digit "digit"; return ('.':ds) }) - <|> many1 digit "digit" - return $ T.pack sign `T.append` T.pack rest +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) t_exponent :: GenParser ParseState T.Text t_exponent = do e <- oneOf "eE" @@ -388,81 +489,36 @@ t_comment = void (char '#' >> many (satisfy (\ c -> c /= '\n' && c /= '\r'))) +-- [161s] WS ::= #x20 | #x9 | #xD | #xA t_ws :: GenParser ParseState () t_ws = (void (try (char '\t' <|> char '\n' <|> char '\r' <|> char ' ')) <|> try t_comment) "whitespace-or-comment" - -t_language :: GenParser ParseState T.Text -t_language = - do initial <- many1 lower; - rest <- many (do {void (char '-'); cs <- many1 (lower <|> digit); return ( T.pack ('-':cs))}) - return $! ( T.pack initial `T.append` T.concat rest) - -identifier :: GenParser ParseState Char -> GenParser ParseState Char -> GenParser ParseState T.Text -identifier initial rest = initial >>= \i -> many rest >>= \r -> return ( T.pack (i:r)) - -- grammar rule: [167s] PN_PREFIX t_pn_prefix :: GenParser ParseState T.Text t_pn_prefix = do i <- try t_pn_chars_base - r <- option "" (many (try t_pn_chars <|> char '.')) + r <- option "" (many (try t_pn_chars <|> char '.')) -- TODO: ensure t_pn_chars is last char return (T.pack (i:r)) -t_name :: GenParser ParseState T.Text -t_name = identifier t_pn_chars_u t_pn_chars - +-- [18] IRIREF t_iriref :: GenParser ParseState T.Text -t_iriref = between (char '<') (char '>') t_relativeURI - -t_relativeURI :: GenParser ParseState T.Text -t_relativeURI = - do frag <- liftM (T.pack . concat) (many t_ucharacter) - bUrl <- currBaseUrl - dUrl <- currDocUrl - let frag' = escapeRDFSyntax frag - validateURI (absolutizeUrl bUrl dUrl frag') - --- We make this String rather than T.Text because we want --- t_relativeURI (the only place it's used) to have chars so that --- when it creates a T.Text it can all be in one chunk. -t_ucharacter :: GenParser ParseState String -t_ucharacter = - try (liftM T.unpack unicode_escape) <|> - try (string "\\>") <|> - liftM T.unpack (non_ctrl_char_except ">") +t_iriref = + between (char '<') (char '>') $ do + iri <- T.concat <$> many ( T.singleton <$> noneOf (['\x00'..'\x20'] ++ ['<','>','"','{','}','|','^','`','\\']) <|> + t_uchar ) + bUrl <- currBaseUrl + dUrl <- currDocUrl + let iri' = escapeRDFSyntax iri + validateURI (absolutizeUrl bUrl dUrl iri') t_pn_chars :: GenParser ParseState Char t_pn_chars = t_pn_chars_u <|> char '-' <|> char '\x00B7' <|> satisfy f where f = flip in_range [('0', '9'), ('\x0300', '\x036F'), ('\x203F', '\x2040')] -longString_char :: GenParser ParseState T.Text -longString_char = - specialChar <|> -- \r|\n|\t as single char - try escapedChar <|> -- an backslash-escaped tab, newline, linefeed, backslash or doublequote - try twoDoubleQuote <|> -- two doublequotes not followed by a doublequote - try oneDoubleQuote <|> -- a single doublequote - safeNonCtrlChar <|> -- anything but a single backslash or doublequote - try unicode_escape -- a unicode escape sequence (\uxxxx or \Uxxxxxxxx) - where - specialChar = oneOf "\t\n\r" >>= bs1 - escapedChar = - do void (char '\\') - (char 't' >> bs1 '\t') <|> (char 'n' >> bs1 '\n') <|> (char 'r' >> bs1 '\r') <|> - (char '\\' >> bs1 '\\') <|> (char '"' >> bs1 '"') - twoDoubleQuote = string "\"\"" >> notFollowedBy (char '"') >> bs "\"\"" - oneDoubleQuote = char '"' >> notFollowedBy (char '"') >> bs1 '"' - safeNonCtrlChar = non_ctrl_char_except "\\\"" - -bs1 :: Char -> GenParser ParseState T.Text -bs1 = return . T.singleton - -bs :: String -> GenParser ParseState T.Text -bs = return . T.pack - -- grammar rule: [163s] PN_CHARS_BASE t_pn_chars_base :: GenParser ParseState Char t_pn_chars_base = try $ satisfy $ flip in_range blocks @@ -483,44 +539,6 @@ t_hex :: GenParser ParseState Char t_hex = satisfy (\c -> isDigit c || (c >= 'A' && c <= 'F')) "hexadecimal digit" --- characters used in (non-long) strings; any echaracters except ", or an escaped \" --- echaracter - #x22 ) | '\"' -t_scharacter_in_dquot :: GenParser ParseState T.Text -t_scharacter_in_dquot = - (try (string "\\\"") >> return (T.singleton '"')) - <|> (try (string "\\'") >> return (T.singleton '\'')) - <|> try (do {void (char '\\'); - (char 't' >> return (T.singleton '\t')) <|> - (char 'n' >> return (T.singleton '\n')) <|> - (char 'r' >> return (T.singleton '\r'))}) -- echaracter part 1 - <|> unicode_escape - <|> (non_ctrl_char_except "\\\"" >>= \s -> return $! s) -- echaracter part 2 minus " - --- characters used in (non-long) strings; any echaracters except ', or an escaped \' --- echaracter - #x22 ) | '\'' -t_scharacter_in_squot :: GenParser ParseState T.Text -t_scharacter_in_squot = - (try (string "\\'") >> return (T.singleton '\'')) - <|> (try (string "\\\"") >> return (T.singleton '"')) - <|> try (do {void (char '\\'); - (char 't' >> return (T.singleton '\t')) <|> - (char 'n' >> return (T.singleton '\n')) <|> - (char 'r' >> return (T.singleton '\r'))}) -- echaracter part 1 - <|> unicode_escape - <|> (non_ctrl_char_except "\\'" >>= \s -> return $! s) -- echaracter part 2 minus ' - -unicode_escape :: GenParser ParseState T.Text -unicode_escape = - (char '\\' >> return (T.singleton '\\')) >> - ((char '\\' >> return "\\\\") <|> - (char 'u' >> count 4 t_hex >>= \cs -> return $! "\\u" `T.append` T.pack cs) <|> - (char 'U' >> count 8 t_hex >>= \cs -> return $! "\\U" `T.append` T.pack cs)) - -non_ctrl_char_except :: String -> GenParser ParseState T.Text -non_ctrl_char_except cs = - liftM T.singleton - (satisfy (\ c -> c <= '\1114111' && (c >= ' ' && c `notElem` cs))) - {-# INLINE in_range #-} in_range :: Char -> [(Char, Char)] -> Bool in_range c = any (\(c1, c2) -> c >= c1 && c <= c2) @@ -530,65 +548,116 @@ newBaseUrl (Just (BaseUrl bUrl)) url = BaseUrl $! mkAbsoluteUrl bUrl url currBaseUrl :: GenParser ParseState (Maybe BaseUrl) -currBaseUrl = getState >>= \(bUrl, _, _, _, _, _, _, _) -> return bUrl +currBaseUrl = getState >>= \(bUrl, _, _, _, _, _, _, _, _, _) -> return bUrl currDocUrl :: GenParser ParseState (Maybe T.Text) -currDocUrl = getState >>= \(_, dUrl, _, _, _, _, _, _) -> return dUrl +currDocUrl = getState >>= \(_, dUrl, _, _, _, _, _, _, _, _) -> return dUrl pushSubj :: Subject -> GenParser ParseState () -pushSubj s = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, ts) -> - setState (bUrl, dUrl, i, pms, s:ss, ps, cs, ts) +pushSubj s = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts) -> + setState (bUrl, dUrl, i, pms, s:ss, ps, cs, subjC, subjBNodeList, ts) popSubj :: GenParser ParseState Subject -popSubj = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, ts) -> - setState (bUrl, dUrl, i, pms, tail ss, ps, cs, ts) >> +popSubj = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts) -> + setState (bUrl, dUrl, i, pms, tail ss, ps, cs, subjC, subjBNodeList, ts) >> when (null ss) (error "Cannot pop subject off empty stack.") >> return (head ss) pushPred :: Predicate -> GenParser ParseState () -pushPred p = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, ts) -> - setState (bUrl, dUrl, i, pms, ss, p:ps, cs, ts) +pushPred p = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts) -> + setState (bUrl, dUrl, i, pms, ss, p:ps, cs, subjC, subjBNodeList, ts) popPred :: GenParser ParseState Predicate -popPred = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, ts) -> - setState (bUrl, dUrl, i, pms, ss, tail ps, cs, ts) >> +popPred = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts) -> + setState (bUrl, dUrl, i, pms, ss, tail ps, cs, subjC, subjBNodeList, ts) >> when (null ps) (error "Cannot pop predicate off empty stack.") >> return (head ps) isInColl :: GenParser ParseState Bool -isInColl = getState >>= \(_, _, _, _, _, _, cs, _) -> return . not . null $ cs +isInColl = getState >>= \(_, _, _, _, _, _, cs, _, _, _) -> return . not . null $ cs +isInSubjColl :: GenParser ParseState Bool +isInSubjColl = getState >>= \(_, _, _, _, _, _, _, xs, _, _) -> do + if null xs then return False else return (head xs) + +{- +isInObjColl :: GenParser ParseState Bool +isInObjColl = getState >>= \(_, _, _, _, _, _, _, xs, _, _) -> do + when (null xs) $ error "null in isInObjColl" + return (not (head xs)) +-} + +pushSubjColl :: GenParser ParseState () +pushSubjColl = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts) -> + setState (bUrl, dUrl, i, pms, s, p, cs, True:subjC, subjBNodeList, ts) + +popColl :: GenParser ParseState () +popColl = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts) -> do + when (null subjC) $ error "null in popColl" + setState (bUrl, dUrl, i, pms, s, p, cs, tail subjC, subjBNodeList, ts) + +pushObjColl :: GenParser ParseState () +pushObjColl = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts) -> + setState (bUrl, dUrl, i, pms, s, p, cs, False:subjC, subjBNodeList, ts) + +isSubjPropList :: GenParser ParseState Bool +isSubjPropList = getState >>= \(_, _, _, _, _, _, _, _, subjBNodeList, _) -> do + return subjBNodeList + +{- +isObjPropList :: GenParser ParseState Bool +isObjPropList = getState >>= \(_, _, _, _, _, _, _, _, subjBNodeList, _) -> do + return subjBNodeList +-} + +setSubjBlankNodePropList :: GenParser ParseState () +setSubjBlankNodePropList = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, _, ts) -> + setState (bUrl, dUrl, i, pms, s, p, cs, subjC, True, ts) + +setNotSubjBlankNodePropList :: GenParser ParseState () +setNotSubjBlankNodePropList = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, _, ts) -> + setState (bUrl, dUrl, i, pms, s, p, cs, subjC, True, ts) + +-- 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) + +-- popBlankNodePropList :: GenParser ParseState () +-- popBlankNodePropList = getState >>= \(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) + updateBaseUrl :: Maybe (Maybe BaseUrl) -> GenParser ParseState () 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, ts) -> - setState (bUrl, dUrl, i+1, pms, s, p, cs, ts) >> return i +nextIdCounter = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts) -> + setState (bUrl, dUrl, i+1, pms, s, p, cs, subjC, subjBNodeList, ts) >> return i updatePMs :: Maybe PrefixMappings -> GenParser ParseState () 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, ts) -> - setState (bUrl, dUrl, i, pms, s, p, True:cs, ts) +beginColl = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts) -> + setState (bUrl, dUrl, i, pms, s, p, True:cs, subjC, subjBNodeList, ts) onCollFirstItem :: GenParser ParseState Bool -onCollFirstItem = getState >>= \(_, _, _, _, _, _, cs, _) -> return (not (null cs) && head cs) +onCollFirstItem = getState >>= \(_, _, _, _, _, _, cs, _, _, _) -> return (not (null cs) && head cs) collFirstItemProcessed :: GenParser ParseState () -collFirstItemProcessed = getState >>= \(bUrl, dUrl, i, pms, s, p, _:cs, ts) -> - setState (bUrl, dUrl, i, pms, s, p, False:cs, ts) +collFirstItemProcessed = getState >>= \(bUrl, dUrl, i, pms, s, p, _:cs, subjC, subjBNodeList, ts) -> + setState (bUrl, dUrl, i, pms, s, p, False:cs, subjC, subjBNodeList, ts) -- 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, ts) -> +finishColl = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, subjC, subjBNodeList, ts) -> let cs' = drop 1 cs - in setState (bUrl, dUrl, i, pms, s, p, cs', ts) >> return (not $ null cs') + in setState (bUrl, dUrl, i, pms, s, p, cs', subjC, subjBNodeList, ts) >> return (not $ null cs') -- Alias for Nothing for use with _modifyState calls, which can get very long with -- many Nothing values. @@ -598,8 +667,8 @@ -- Update the subject and predicate values of the ParseState to Nothing. resetSubjectPredicate :: GenParser ParseState () resetSubjectPredicate = - getState >>= \(bUrl, dUrl, n, pms, _, _, cs, ts) -> - setState (bUrl, dUrl, n, pms, [], [], cs, ts) + getState >>= \(bUrl, dUrl, n, pms, _, _, cs, subjC, subjBNodeList, ts) -> + setState (bUrl, dUrl, n, pms, [], [], cs, subjC, subjBNodeList, ts) -- Modifies the current parser state by updating any state values among the parameters -- that have non-Nothing values. @@ -607,7 +676,7 @@ Maybe Subject -> Maybe Predicate -> Maybe (Seq Triple) -> GenParser ParseState () _modifyState mb_bUrl mb_n mb_pms mb_subj mb_pred mb_trps = - do (_bUrl, _dUrl, _n, _pms, _s, _p, _cs, _ts) <- getState + do (_bUrl, _dUrl, _n, _pms, _s, _p, _cs, _subjC, _subjBNodeList, _ts) <- getState setState (fromMaybe _bUrl mb_bUrl, _dUrl, maybe _n (const _n) mb_n, @@ -615,16 +684,18 @@ maybe _s (: _s) mb_subj, maybe _p (: _p) mb_pred, _cs, + _subjC, + _subjBNodeList, fromMaybe _ts mb_trps) addTripleForObject :: Object -> GenParser ParseState () addTripleForObject obj = - do (bUrl, dUrl, i, pms, ss, ps, cs, ts) <- getState + do (bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts) <- getState 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, ts |> Triple (head ss) (head ps) obj) + setState (bUrl, dUrl, i, pms, ss, ps, cs, subjC, subjBNodeList, ts |> Triple (head ss) (head ps) obj) -- |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. @@ -658,16 +729,16 @@ -- -- Returns either a @ParseFailure@ or a new RDF containing the parsed triples. parseFile' :: forall rdf. (RDF rdf) => Maybe BaseUrl -> Maybe T.Text -> String -> IO (Either ParseFailure rdf) -parseFile' bUrl docUrl fpath = +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, [], [], [], Seq.empty) + where initialState = (bUrl, docUrl, 1, PrefixMappings Map.empty, [], [], [], [], False, Seq.empty) -- |Parse the given string as a Turtle document. The arguments and return type have the same semantics -- as , except that the last @String@ argument corresponds to the Turtle document itself as -- a string rather than a location URI. parseString' :: forall rdf. (RDF rdf) => Maybe BaseUrl -> Maybe T.Text -> T.Text -> Either ParseFailure rdf parseString' bUrl docUrl ttlStr = handleResult bUrl (runParser t_turtleDoc initialState "" ttlStr) - where initialState = (bUrl, docUrl, 1, PrefixMappings Map.empty, [], [], [], Seq.empty) + where initialState = (bUrl, docUrl, 1, PrefixMappings Map.empty, [], [], [], [], False, Seq.empty) handleResult :: RDF rdf => Maybe BaseUrl -> Either ParseError (Seq Triple, PrefixMappings) -> Either ParseFailure rdf handleResult bUrl result = diff --git a/testsuite/tests/Data/RDF/Graph/HashMapSP_Test.hs b/testsuite/tests/Data/RDF/Graph/HashMapSP_Test.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/Data/RDF/Graph/HashMapSP_Test.hs @@ -0,0 +1,24 @@ +module Data.RDF.Graph.HashMapSP_Test (triplesOf',uniqTriplesOf',empty',mkRdf') where + +import Data.RDF.Types +import Data.RDF.Graph.HashMapSP (HashMapSP) +import Data.RDF.GraphTestUtils +import qualified Data.Map as Map +import Control.Monad + +import Test.QuickCheck + +instance Arbitrary HashMapSP where + arbitrary = liftM3 mkRdf arbitraryTs (return Nothing) (return $ PrefixMappings Map.empty) + +empty' :: HashMapSP +empty' = empty + +mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> HashMapSP +mkRdf' = mkRdf + +triplesOf' :: HashMapSP -> Triples +triplesOf' = triplesOf + +uniqTriplesOf' :: HashMapSP -> Triples +uniqTriplesOf' = uniqTriplesOf diff --git a/testsuite/tests/Data/RDF/Graph/HashMapS_Test.hs b/testsuite/tests/Data/RDF/Graph/HashMapS_Test.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/Data/RDF/Graph/HashMapS_Test.hs @@ -0,0 +1,25 @@ +module Data.RDF.Graph.HashMapS_Test (triplesOf',uniqTriplesOf',empty',mkRdf') where + +import Data.RDF.Types +import Data.RDF.Graph.HashMapS (HashMapS) +import Data.RDF.GraphTestUtils +import qualified Data.Map as Map +import Control.Monad + +import Test.QuickCheck + +instance Arbitrary HashMapS where + arbitrary = liftM3 mkRdf arbitraryTs (return Nothing) (return $ PrefixMappings Map.empty) + --coarbitrary = undefined + +empty' :: HashMapS +empty' = empty + +mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> HashMapS +mkRdf' = mkRdf + +triplesOf' :: HashMapS -> Triples +triplesOf' = triplesOf + +uniqTriplesOf' :: HashMapS -> Triples +uniqTriplesOf' = uniqTriplesOf diff --git a/testsuite/tests/Data/RDF/Graph/MapSP_Test.hs b/testsuite/tests/Data/RDF/Graph/MapSP_Test.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/Data/RDF/Graph/MapSP_Test.hs @@ -0,0 +1,25 @@ +module Data.RDF.Graph.MapSP_Test (triplesOf',uniqTriplesOf',empty',mkRdf') where + +import Data.RDF.Types +import Data.RDF.Graph.MapSP (MapSP) +import Data.RDF.GraphTestUtils +import qualified Data.Map as Map +import Control.Monad + +import Test.QuickCheck + +instance Arbitrary MapSP where + arbitrary = liftM3 mkRdf arbitraryTs (return Nothing) (return $ PrefixMappings Map.empty) + --coarbitrary = undefined + +empty' :: MapSP +empty' = empty + +mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> MapSP +mkRdf' = mkRdf + +triplesOf' :: MapSP -> Triples +triplesOf' = triplesOf + +uniqTriplesOf' :: MapSP -> Triples +uniqTriplesOf' = uniqTriplesOf diff --git a/testsuite/tests/Data/RDF/Graph/TriplesList_Test.hs b/testsuite/tests/Data/RDF/Graph/TriplesList_Test.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/Data/RDF/Graph/TriplesList_Test.hs @@ -0,0 +1,25 @@ +module Data.RDF.Graph.TriplesList_Test (empty',triplesOf',uniqTriplesOf',mkRdf') where + +import Control.Monad +import qualified Data.Map as Map +import Data.RDF.GraphTestUtils +import Data.RDF.Namespace +import Data.RDF.Graph.TriplesList +import Data.RDF.Types +import Test.QuickCheck.Arbitrary + +instance Arbitrary TriplesList where + arbitrary = liftM3 mkRdf arbitraryTs (return Nothing) (return $ PrefixMappings Map.empty) + --coarbitrary = undefined + +empty' :: TriplesList +empty' = empty + +mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> TriplesList +mkRdf' = mkRdf + +triplesOf' :: TriplesList -> Triples +triplesOf' = triplesOf + +uniqTriplesOf' :: TriplesList -> Triples +uniqTriplesOf' = uniqTriplesOf diff --git a/testsuite/tests/Data/RDF/Graph/TriplesPatriciaTree_Test.hs b/testsuite/tests/Data/RDF/Graph/TriplesPatriciaTree_Test.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/Data/RDF/Graph/TriplesPatriciaTree_Test.hs @@ -0,0 +1,25 @@ +module Data.RDF.Graph.TriplesPatriciaTree_Test (triplesOf',uniqTriplesOf',empty',mkRdf') where + +import Data.RDF.Types +import Data.RDF.Graph.TriplesPatriciaTree (TriplesPatriciaTree) +import Data.RDF.GraphTestUtils +import qualified Data.Map as Map +import Control.Monad + +import Test.QuickCheck + +instance Arbitrary TriplesPatriciaTree where + arbitrary = liftM3 mkRdf arbitraryTs (return Nothing) (return $ PrefixMappings Map.empty) + --coarbitrary = undefined + +empty' :: TriplesPatriciaTree +empty' = empty + +mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> TriplesPatriciaTree +mkRdf' = mkRdf + +triplesOf' :: TriplesPatriciaTree -> Triples +triplesOf' = triplesOf + +uniqTriplesOf' :: TriplesPatriciaTree -> Triples +uniqTriplesOf' = uniqTriplesOf diff --git a/testsuite/tests/Data/RDF/GraphTestUtils.hs b/testsuite/tests/Data/RDF/GraphTestUtils.hs --- a/testsuite/tests/Data/RDF/GraphTestUtils.hs +++ b/testsuite/tests/Data/RDF/GraphTestUtils.hs @@ -1,9 +1,5 @@ module Data.RDF.GraphTestUtils where -import Control.Applicative ((<$>)) -import Data.ByteString (pack) -import qualified Data.ByteString.Char8 as C -import Data.Knob import Data.RDF.Types import Data.RDF.Query import Data.RDF.Namespace @@ -14,11 +10,12 @@ import qualified Data.Set as Set import qualified Data.Map as Map import Control.Monad +import System.Directory (removeFile) import System.IO.Unsafe(unsafePerformIO) import System.IO -import Test.Framework (Test,TestName,testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Tasty +import Test.Tasty.QuickCheck import Test.QuickCheck.Monadic (assert, monadicIO,run) ---------------------------------------------------- @@ -26,8 +23,8 @@ ---------------------------------------------------- graphTests :: forall rdf. (Arbitrary rdf, RDF rdf, Show rdf) - => TestName -> (rdf -> Triples) -> (rdf -> Triples) -> rdf -> (Triples -> Maybe BaseUrl -> PrefixMappings -> rdf) -> [Test] -graphTests testGroupName _triplesOf _uniqTriplesOf _empty _mkRdf = [ testGroup testGroupName + => TestName -> (rdf -> Triples) -> (rdf -> Triples) -> rdf -> (Triples -> Maybe BaseUrl -> PrefixMappings -> rdf) -> TestTree +graphTests testGroupName _triplesOf _uniqTriplesOf _empty _mkRdf = testGroup testGroupName [ testProperty "empty" (p_empty _triplesOf _empty) , testProperty "mkRdf_triplesOf" (p_mkRdf_triplesOf _triplesOf _mkRdf) @@ -53,7 +50,6 @@ , testProperty "select_match_spo" (p_select_match_spo _triplesOf) , testProperty "reversed RDF handle write" (p_reverseRdfTest _mkRdf) ] - ] instance Arbitrary BaseUrl where @@ -400,12 +396,13 @@ p_reverseRdfTest :: RDF rdf => (Triples -> Maybe BaseUrl -> PrefixMappings -> rdf) -> Property p_reverseRdfTest _mkRdf = monadicIO $ do - fileContents <- run $ do - knob <- newKnob (pack []) - h <- newFileHandle knob "test.rdf" WriteMode - hWriteRdf NTriplesSerializer h rdfGraph - hClose h - C.unpack <$> Data.Knob.getContents knob + 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 diff --git a/testsuite/tests/Data/RDF/MGraph_Test.hs b/testsuite/tests/Data/RDF/MGraph_Test.hs deleted file mode 100644 --- a/testsuite/tests/Data/RDF/MGraph_Test.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Data.RDF.MGraph_Test (triplesOf',uniqTriplesOf',empty',mkRdf') where - -import Data.RDF.Types -import Data.RDF.MGraph (MGraph) -import Data.RDF.GraphTestUtils -import qualified Data.Map as Map -import Control.Monad - -import Test.QuickCheck - -instance Arbitrary MGraph where - arbitrary = liftM3 mkRdf arbitraryTs (return Nothing) (return $ PrefixMappings Map.empty) - --coarbitrary = undefined - -empty' :: MGraph -empty' = empty - -mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> MGraph -mkRdf' = mkRdf - -triplesOf' :: MGraph -> Triples -triplesOf' = triplesOf - -uniqTriplesOf' :: MGraph -> Triples -uniqTriplesOf' = uniqTriplesOf diff --git a/testsuite/tests/Data/RDF/PatriciaTreeGraph_Test.hs b/testsuite/tests/Data/RDF/PatriciaTreeGraph_Test.hs deleted file mode 100644 --- a/testsuite/tests/Data/RDF/PatriciaTreeGraph_Test.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Data.RDF.PatriciaTreeGraph_Test (triplesOf',uniqTriplesOf',empty',mkRdf') where - -import Data.RDF.Types -import Data.RDF.PatriciaTreeGraph (PatriciaTreeGraph) -import Data.RDF.GraphTestUtils -import qualified Data.Map as Map -import Control.Monad - -import Test.QuickCheck - -instance Arbitrary PatriciaTreeGraph where - arbitrary = liftM3 mkRdf arbitraryTs (return Nothing) (return $ PrefixMappings Map.empty) - --coarbitrary = undefined - -empty' :: PatriciaTreeGraph -empty' = empty - -mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> PatriciaTreeGraph -mkRdf' = mkRdf - -triplesOf' :: PatriciaTreeGraph -> Triples -triplesOf' = triplesOf - -uniqTriplesOf' :: PatriciaTreeGraph -> Triples -uniqTriplesOf' = uniqTriplesOf diff --git a/testsuite/tests/Data/RDF/TriplesGraph_Test.hs b/testsuite/tests/Data/RDF/TriplesGraph_Test.hs deleted file mode 100644 --- a/testsuite/tests/Data/RDF/TriplesGraph_Test.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Data.RDF.TriplesGraph_Test (empty',triplesOf',uniqTriplesOf',mkRdf') where - -import Control.Monad -import qualified Data.Map as Map -import Data.RDF.GraphTestUtils -import Data.RDF.Namespace -import Data.RDF.TriplesGraph -import Data.RDF.Types -import Test.QuickCheck.Arbitrary - -instance Arbitrary TriplesGraph where - arbitrary = liftM3 mkRdf arbitraryTs (return Nothing) (return $ PrefixMappings Map.empty) - --coarbitrary = undefined - -empty' :: TriplesGraph -empty' = empty - -mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> TriplesGraph -mkRdf' = mkRdf - -triplesOf' :: TriplesGraph -> Triples -triplesOf' = triplesOf - -uniqTriplesOf' :: TriplesGraph -> Triples -uniqTriplesOf' = uniqTriplesOf diff --git a/testsuite/tests/Test.hs b/testsuite/tests/Test.hs --- a/testsuite/tests/Test.hs +++ b/testsuite/tests/Test.hs @@ -1,40 +1,95 @@ module Main where -import Test.Framework (defaultMain) +import Test.Tasty (defaultMain,testGroup) -import qualified Data.RDF.TriplesGraph_Test as TriplesGraph -import qualified Data.RDF.MGraph_Test as MGraph -import qualified Data.RDF.PatriciaTreeGraph_Test as PatriciaTreeGraph +import qualified Data.RDF.Graph.TriplesList_Test as TriplesList +import qualified Data.RDF.Graph.HashMapS_Test as HashMapS +import qualified Data.RDF.Graph.HashMapSP_Test as HashMapSP +import qualified Data.RDF.Graph.MapSP_Test as MapSP +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 +import Data.RDF.GraphTestUtils +import qualified Data.Text as T +import System.Directory (getCurrentDirectory) +import W3C.Manifest + +suiteFilesDirTurtle,suiteFilesDirXml,suiteFilesDirNTriples :: T.Text +suiteFilesDirTurtle = "rdf-tests/turtle/" +suiteFilesDirXml = "rdf-tests/rdf-xml/" +suiteFilesDirNTriples = "rdf-tests/ntriples/" + +mfPathTurtle,mfPathXml,mfPathNTriples :: T.Text +mfPathTurtle = T.concat [suiteFilesDirTurtle, "manifest.ttl"] +mfPathXml = T.concat [suiteFilesDirXml, "manifest.ttl"] +mfPathNTriples = T.concat [suiteFilesDirNTriples, "manifest.ttl"] + +mfBaseURITurtle,mfBaseURIXml,mfBaseURINTriples :: BaseUrl +mfBaseURITurtle = BaseUrl "http://www.w3.org/2013/TurtleTests/" +mfBaseURIXml = BaseUrl "http://www.w3.org/2013/RDFXMLTests/" +mfBaseURINTriples = BaseUrl "http://www.w3.org/2013/N-TriplesTests/" + + main :: IO () -main = defaultMain ( - graphTests "TriplesGraph" - TriplesGraph.triplesOf' - TriplesGraph.uniqTriplesOf' - TriplesGraph.empty' - TriplesGraph.mkRdf' +main = do + -- obtain manifest files for W3C tests before running tests + -- justification for separation: http://stackoverflow.com/a/33046723 + dir <- getCurrentDirectory + let fileSchemeUri suitesDir = T.pack ("file://" ++ dir ++ "/" ++ T.unpack suitesDir) + turtleManifest <- + loadManifest mfPathTurtle (fileSchemeUri suiteFilesDirTurtle) - ++ graphTests "MGraph" - MGraph.triplesOf' - MGraph.uniqTriplesOf' - MGraph.empty' - MGraph.mkRdf' + xmlManifest <- + loadManifest mfPathXml (fileSchemeUri suiteFilesDirXml) - ++ graphTests "PatriciaTreeGraph" - PatriciaTreeGraph.triplesOf' - PatriciaTreeGraph.uniqTriplesOf' - PatriciaTreeGraph.empty' - PatriciaTreeGraph.mkRdf' + nTriplesManifest <- + loadManifest mfPathNTriples (fileSchemeUri suiteFilesDirNTriples) - ++ TurtleParser.tests - ++ XmlParser.tests - ++ W3CTurtleTest.tests - ++ W3CRdfXmlTest.tests - ++ W3CNTripleTest.tests - ) + -- run tests + defaultMain + (testGroup "rdf4h tests" + [ -- RDF graph API tests + graphTests "TriplesList" + TriplesList.triplesOf' + TriplesList.uniqTriplesOf' + TriplesList.empty' + TriplesList.mkRdf' + + , graphTests "HashMapS" + HashMapS.triplesOf' + HashMapS.uniqTriplesOf' + HashMapS.empty' + HashMapS.mkRdf' + + , graphTests "HashMapSP" + HashMapSP.triplesOf' + HashMapSP.uniqTriplesOf' + HashMapSP.empty' + HashMapSP.mkRdf' + + , graphTests "MapSP" + MapSP.triplesOf' + MapSP.uniqTriplesOf' + MapSP.empty' + MapSP.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 + ]) diff --git a/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs b/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs --- a/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs +++ b/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs @@ -1,23 +1,22 @@ module Text.RDF.RDF4H.TurtleParser_ConformanceTest where -- Testing imports -import Test.Framework.Providers.API -import Test.Framework.Providers.HUnit -import qualified Test.HUnit as TU +import Test.Tasty +import Test.Tasty.HUnit as TU -- Import common libraries to facilitate tests import Control.Monad (liftM) import Data.RDF.GraphTestUtils import Data.RDF.Query -import Data.RDF.TriplesGraph +import Data.RDF.Graph.TriplesList import Data.RDF.Types import qualified Data.Text as T import qualified Data.Text.IO as TIO import Text.Printf import Text.RDF.RDF4H.TurtleParser -tests :: [Test] -tests = [ testGroup "TurtleParser" allCTests ] +tests :: TestTree +tests = testGroup "TurtleParser" allCTests -- A list of other tests to run, each entry of which is (directory, fname_without_ext). otherTestFiles :: [(String, String)] @@ -41,40 +40,38 @@ fpath :: String -> Int -> String -> String fpath name i ext = printf "data/ttl/conformance/%s-%02d.%s" name i ext :: String -allCTests :: [Test] +allCTests :: [TestTree] allCTests = ts1 ++ ts2 ++ ts3 where - ts1 = map (buildTest . checkGoodConformanceTest) [0..30] - ts2 = map (buildTest . checkBadConformanceTest) [0..14] - ts3 = map (buildTest . uncurry checkGoodOtherTest) otherTestFiles + ts1 = map (checkGoodConformanceTest) [0..30] + ts2 = map (checkBadConformanceTest) [0..14] + ts3 = map (uncurry checkGoodOtherTest) otherTestFiles -checkGoodConformanceTest :: Int -> IO Test +checkGoodConformanceTest :: Int -> TestTree checkGoodConformanceTest i = - do - expGr <- loadExpectedGraph "test" i - inGr <- loadInputGraph "test" i - doGoodConformanceTest expGr inGr (printf "test %d" i :: String) + let expGr = loadExpectedGraph "test" i + inGr = loadInputGraph "test" i + in doGoodConformanceTest expGr inGr (printf "test %d" i :: String) -checkGoodOtherTest :: String -> String -> IO Test +checkGoodOtherTest :: String -> String -> TestTree checkGoodOtherTest dir fname = - do - expGr <- loadExpectedGraph1 (printf "%s/%s.out" dir fname :: String) - inGr <- loadInputGraph1 dir fname - doGoodConformanceTest expGr inGr $ printf "test using file \"%s\"" 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 -doGoodConformanceTest :: Either ParseFailure TriplesGraph -> - Either ParseFailure TriplesGraph -> - String -> IO Test -doGoodConformanceTest expGr inGr testname = do +doGoodConformanceTest :: IO (Either ParseFailure TriplesList) -> + IO (Either ParseFailure TriplesList) -> + 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 - return $ 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 -> IO Test -checkBadConformanceTest i = do - let t = loadInputGraph "bad" i >>= assertLoadFailure (show i) - return $ testCase (printf "Loading test %d (negative)" i) t +checkBadConformanceTest :: Int -> TestTree +checkBadConformanceTest i = + let t = assertLoadFailure (show i) (loadInputGraph "bad" i) + 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. @@ -104,17 +101,17 @@ -- Returns a graph for a good ttl test that is intended to pass, and normalizes -- triples into a format so that they can be compared with the expected output triples. -loadInputGraph :: String -> Int -> IO (Either ParseFailure TriplesGraph) +loadInputGraph :: String -> Int -> IO (Either ParseFailure TriplesList) loadInputGraph name n = TIO.readFile (fpath name n "ttl") >>= return . parseString (TurtleParser mtestBaseUri (mkDocUrl testBaseUri name n)) >>= return . handleLoad -loadInputGraph1 :: String -> String -> IO (Either ParseFailure TriplesGraph) +loadInputGraph1 :: String -> String -> IO (Either ParseFailure TriplesList) loadInputGraph1 dir fname = TIO.readFile (printf "%s/%s.ttl" dir fname :: String) >>= return . parseString (TurtleParser mtestBaseUri (mkDocUrl1 testBaseUri fname)) >>= return . handleLoad -handleLoad :: Either ParseFailure TriplesGraph -> Either ParseFailure TriplesGraph +handleLoad :: Either ParseFailure TriplesList -> Either ParseFailure TriplesList handleLoad res = case res of l@(Left _) -> l @@ -129,24 +126,32 @@ normalizeN (BNodeGen i) = BNode (T.pack $ "_:genid" ++ show i) normalizeN n = n -loadExpectedGraph :: String -> Int -> IO (Either ParseFailure TriplesGraph) +loadExpectedGraph :: String -> Int -> IO (Either ParseFailure TriplesList) loadExpectedGraph name n = loadExpectedGraph1 (fpath name n "out") -loadExpectedGraph1 :: String -> IO (Either ParseFailure TriplesGraph) +loadExpectedGraph1 :: String -> IO (Either ParseFailure TriplesList) loadExpectedGraph1 fname = liftM (parseString (TurtleParser mtestBaseUri (mkDocUrl1 testBaseUri fname))) (TIO.readFile fname) -assertLoadSuccess, assertLoadFailure :: String -> Either ParseFailure TriplesGraph -> TU.Assertion -assertLoadSuccess idStr (Left (ParseFailure err)) = TU.assertFailure $ idStr ++ err -assertLoadSuccess _ (Right _) = return () -assertLoadFailure _ (Left _) = return () -assertLoadFailure idStr _ = TU.assertFailure $ "Bad test " ++ idStr ++ " loaded successfully." +assertLoadSuccess, assertLoadFailure :: String -> IO (Either ParseFailure TriplesList) -> TU.Assertion +assertLoadSuccess idStr exprGr = do + g <- exprGr + case g of + Left (ParseFailure err) -> TU.assertFailure $ idStr ++ err + Right _ -> return () -assertEquivalent :: RDF rdf => String -> Either ParseFailure rdf -> Either ParseFailure rdf -> TU.Assertion -assertEquivalent testname r1 r2 = - case equiv of +assertLoadFailure idStr exprGr = do + g <- exprGr + case g of + Left _ -> return () + Right _ -> TU.assertFailure $ "Bad test " ++ idStr ++ " loaded successfully." + +assertEquivalent :: RDF rdf => String -> IO (Either ParseFailure rdf) -> IO (Either ParseFailure rdf) -> TU.Assertion +assertEquivalent testname r1 r2 = do + gr1 <- r1 + gr2 <- r2 + case equivalent gr1 gr2 of Nothing -> TU.assert True (Just msg) -> fail $ "Graph " ++ testname ++ " not equivalent to expected:\n" ++ msg - where equiv = equivalent r1 r2 mkDocUrl :: String -> String -> Int -> Maybe T.Text mkDocUrl baseDocUrl fname testNum = Just $ T.pack $ printf "%s%s-%02d.ttl" baseDocUrl fname testNum diff --git a/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs b/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs --- a/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs +++ b/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs @@ -3,55 +3,52 @@ -- todo: QuickCheck tests -- Testing imports -import Test.Framework (Test,testGroup) -import Test.Framework.Providers.HUnit -import Test.HUnit (Assertion,assertBool,assertFailure) +import Test.Tasty +import Test.Tasty.HUnit -- Import common libraries to facilitate tests import qualified Data.Map as Map import Data.RDF.Query -import Data.RDF.TriplesGraph (TriplesGraph) +import Data.RDF.Graph.TriplesList (TriplesList) import Data.RDF.Types import qualified Data.Text as T (Text, unlines) import Text.RDF.RDF4H.XmlParser -tests :: [Test] -tests = [ testGroup "XmlParser:parseXmlRDF" [ testCase "simpleStriping1" test_simpleStriping1 - , testCase "simpleStriping2" test_simpleStriping2 - , testCase "simpleSingleton1" test_simpleSingleton1 - , testCase "simpleSingleton2" test_simpleSingleton2 - , testCase "example07" test_parseXmlRDF_example07 - , testCase "example08" test_parseXmlRDF_example08 - , testCase "example09" test_parseXmlRDF_example09 - , testCase "example10" test_parseXmlRDF_example10 - , testCase "example11" test_parseXmlRDF_example11 - , testCase "example12" test_parseXmlRDF_example12 - , testCase "example13" test_parseXmlRDF_example13 - , testCase "example14" test_parseXmlRDF_example14 - , testCase "example15" test_parseXmlRDF_example15 - , testCase "example16" test_parseXmlRDF_example16 - , testCase "example17" test_parseXmlRDF_example17 - , testCase "example18" test_parseXmlRDF_example18 - , testCase "example19" test_parseXmlRDF_example19 - , testCase "example20" test_parseXmlRDF_example20 - , testCase "vCardPersonal" test_parseXmlRDF_vCardPersonal - , testCase "NML" test_parseXmlRDF_NML - , testCase "NML2" test_parseXmlRDF_NML2 - , testCase "NML3" test_parseXmlRDF_NML3 - ] - ] - +tests :: TestTree +tests = testGroup "XmlParser:parseXmlRDF" [ testCase "simpleStriping1" test_simpleStriping1 + , testCase "simpleStriping2" test_simpleStriping2 + , testCase "simpleSingleton1" test_simpleSingleton1 + , testCase "simpleSingleton2" test_simpleSingleton2 + , testCase "example07" test_parseXmlRDF_example07 + , testCase "example08" test_parseXmlRDF_example08 + , testCase "example09" test_parseXmlRDF_example09 + , testCase "example10" test_parseXmlRDF_example10 + , testCase "example11" test_parseXmlRDF_example11 + , testCase "example12" test_parseXmlRDF_example12 + , testCase "example13" test_parseXmlRDF_example13 + , testCase "example14" test_parseXmlRDF_example14 + , testCase "example15" test_parseXmlRDF_example15 + , testCase "example16" test_parseXmlRDF_example16 + , testCase "example17" test_parseXmlRDF_example17 + , testCase "example18" test_parseXmlRDF_example18 + , testCase "example19" test_parseXmlRDF_example19 + , testCase "example20" test_parseXmlRDF_example20 + , testCase "vCardPersonal" test_parseXmlRDF_vCardPersonal + , testCase "NML" test_parseXmlRDF_NML + , testCase "NML2" test_parseXmlRDF_NML2 + , testCase "NML3" test_parseXmlRDF_NML3 + ] mkTextNode :: T.Text -> Node mkTextNode = lnode . plainL -testParse :: T.Text -> TriplesGraph -> Assertion +testParse :: T.Text -> TriplesList -> Assertion testParse exRDF ex = case parsed of Right result -> assertBool ("expected: " ++ show ex ++ "but got: " ++ show result) - (isIsomorphic (result :: TriplesGraph) (ex :: TriplesGraph)) + (isIsomorphic (result :: TriplesList) (ex :: TriplesList)) Left (ParseFailure err) -> assertFailure err where parsed = parseString (XmlParser Nothing Nothing) exRDF diff --git a/testsuite/tests/W3C/Manifest.hs b/testsuite/tests/W3C/Manifest.hs --- a/testsuite/tests/W3C/Manifest.hs +++ b/testsuite/tests/W3C/Manifest.hs @@ -5,7 +5,7 @@ TestEntry(..) ) where -import Data.RDF.TriplesGraph +import Data.RDF.Graph.TriplesList import Data.RDF.Query import Data.RDF.Types import Data.RDF.Namespace @@ -100,10 +100,14 @@ deriving (Show) -- TODO: Perhaps these should be pulled from the manifest graph +rdfType,rdfsComment,rdfsLabel,rdftApproval,rdfsApproval,mfName,mfManifest,mfAction, + mfResult,mfEntries,mfEntailmentRegime,mfRecognizedDatatypes,mfUnrecognizedDatatypes :: Node + rdfType = unode $ mkUri rdf "type" rdfsComment = unode $ mkUri rdfs "comment" -rdftTestTurtleEval = unode "http://www.w3.org/ns/rdftest#TestTurtleEval" -rdftTestTurtleNegativeEval = unode "http://www.w3.org/ns/rdftest#TestTurtleNegativeEval" +rdfsLabel = unode $ mkUri rdfs "label" +-- rdftTestTurtleEval = unode "http://www.w3.org/ns/rdftest#TestTurtleEval" +-- rdftTestTurtleNegativeEval = unode "http://www.w3.org/ns/rdftest#TestTurtleNegativeEval" rdftApproval = unode "http://www.w3.org/ns/rdftest#approval" rdfsApproval = unode $ mkUri rdfs "approval" -- FIXME: incorrect namespace "rdfs:approval" in rdf-mt/manifest.ttl, must be "rdft:approval" mfName = unode "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#name" @@ -122,21 +126,21 @@ parseFile testParser (T.unpack manifestPath) >>= return . rdfToManifest . fromEither where testParser = TurtleParser (Just $ BaseUrl baseIRI) Nothing -rdfToManifest :: TriplesGraph -> Manifest +rdfToManifest :: TriplesList -> Manifest rdfToManifest rdf = Manifest desc tpls where desc = lnodeText $ objectOf $ headDef (error ("query empty: subject mf:node & predicate mf:name in:\n\n" ++ show (triplesOf rdf))) descNode -- FIXME: Inconsistent use of nodes for describing the manifest (W3C bug) - descNode = query rdf (Just manifestNode) (Just rdfsComment) Nothing + descNode = query rdf (Just manifestNode) (Just rdfsLabel) Nothing ++ query rdf (Just manifestNode) (Just mfName) Nothing -- descNode = query rdf (Just manifestNode) (Just mfName) Nothing tpls = map (rdfToTestEntry rdf) $ rdfCollectionToList rdf collectionHead collectionHead = objectOf $ headDef (error "query: mf:node & mf:entries") $ query rdf (Just manifestNode) (Just mfEntries) Nothing manifestNode = headDef (error "manifestSubjectNodes yielding empty list") $ manifestSubjectNodes rdf -rdfToTestEntry :: TriplesGraph -> Node -> TestEntry +rdfToTestEntry :: TriplesList -> Node -> TestEntry rdfToTestEntry rdf teSubject = triplesToTestEntry rdf $ query rdf (Just teSubject) Nothing Nothing -triplesToTestEntry :: TriplesGraph -> Triples -> TestEntry +triplesToTestEntry :: TriplesList -> Triples -> TestEntry triplesToTestEntry rdf ts = case objectByPredicate rdfType ts of (UNode "http://www.w3.org/ns/rdftest#TestTurtleEval") -> mkTestTurtleEval ts @@ -184,7 +188,7 @@ action = objectByPredicate mfAction ts } -mkPositiveEntailmentTest :: Triples -> TriplesGraph -> TestEntry +mkPositiveEntailmentTest :: Triples -> TriplesList -> TestEntry mkPositiveEntailmentTest ts rdf = PositiveEntailmentTest { name = lnodeText $ objectByPredicate mfName ts, comment = lnodeText $ objectByPredicate rdfsComment ts, @@ -202,7 +206,7 @@ uDT = rdfCollectionToList rdf uDTCollectionHead uDTCollectionHead = objectByPredicate mfUnrecognizedDatatypes ts -mkNegativeEntailmentTest :: Triples -> TriplesGraph -> TestEntry +mkNegativeEntailmentTest :: Triples -> TriplesList -> TestEntry mkNegativeEntailmentTest ts rdf = NegativeEntailmentTest { name = lnodeText $ objectByPredicate mfName ts, comment = lnodeText $ objectByPredicate rdfsComment ts, @@ -250,7 +254,7 @@ } mkTestNTriplesNegativeSyntax :: Triples -> TestEntry -mkTestNTriplesNegativeSyntax ts = TestNTriplesPositiveSyntax { +mkTestNTriplesNegativeSyntax ts = TestNTriplesNegativeSyntax { name = lnodeText $ objectByPredicate mfName ts, comment = lnodeText $ objectByPredicate rdfsComment ts, approval = objectByPredicate rdftApproval ts, @@ -262,10 +266,10 @@ objectByPredicate :: Predicate -> Triples -> Object objectByPredicate p = objectOf . fromJust . L.find (\t -> predicateOf t == p) -manifestSubjectNodes :: TriplesGraph -> [Subject] +manifestSubjectNodes :: TriplesList -> [Subject] manifestSubjectNodes rdf = subjectNodes rdf [mfManifest] -subjectNodes :: TriplesGraph -> [Object] -> [Subject] +subjectNodes :: TriplesList -> [Object] -> [Subject] subjectNodes rdf = (map subjectOf) . concatMap queryType where queryType n = query rdf Nothing (Just rdfType) (Just n) @@ -290,15 +294,15 @@ -- | second argument (`tip`) is the "collection head" ( in the example above), -- | (all triples with and pairs). -- TODO: Looks useful. Move it to RDF4H lib? -rdfCollectionToList :: TriplesGraph -> Node -> [Node] +rdfCollectionToList :: TriplesList -> Node -> [Node] rdfCollectionToList _ (UNode("http://www.w3.org/1999/02/22-rdf-syntax-ns#nil")) = [] rdfCollectionToList rdf tip = concatMap (tripleToList rdf) $ nextCollectionTriples rdf tip -tripleToList :: TriplesGraph -> Triple -> [Node] +tripleToList :: TriplesList -> Triple -> [Node] tripleToList _ (Triple _ (UNode("http://www.w3.org/1999/02/22-rdf-syntax-ns#first")) n@(UNode _)) = [n] tripleToList rdf (Triple _ (UNode("http://www.w3.org/1999/02/22-rdf-syntax-ns#rest")) tip) = rdfCollectionToList rdf tip tripleToList _ _ = error "Invalid collection format" -nextCollectionTriples :: TriplesGraph -> Node -> Triples +nextCollectionTriples :: TriplesList -> Node -> Triples nextCollectionTriples rdf tip@(BNodeGen _) = query rdf (Just tip) Nothing Nothing nextCollectionTriples _ _ = error "Invalid collection format" 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 @@ -1,58 +1,35 @@ module W3C.NTripleTest where import Data.Maybe (fromJust) -import Test.Framework.Providers.API -import Test.Framework.Providers.HUnit -import qualified Test.HUnit as TU +import Test.Tasty +import qualified Test.Tasty.HUnit as TU import qualified Data.Text as T -import System.Directory import W3C.Manifest +import W3C.W3CAssertions import Data.RDF.Types import Text.RDF.RDF4H.NTriplesParser -import Data.RDF.TriplesGraph - -suiteFilesDir = "data/w3c/n3/" - -mfPath = T.concat [suiteFilesDir, "manifest.ttl"] -mfBaseURI = BaseUrl "http://www.w3.org/2013/N-TriplesTests/" - -tests :: [Test] -tests = [ buildTest allNTripleTests ] +import Data.RDF.Graph.TriplesList -allNTripleTests :: IO Test -allNTripleTests = do - dir <- getCurrentDirectory - let fileSchemeURI = T.pack ("file://" ++ dir ++ "/" ++ T.unpack suiteFilesDir) - m <- loadManifest mfPath fileSchemeURI - return $ testGroup (T.unpack $ description m) $ map (buildTest . mfEntryToTest) $ entries m +tests :: Manifest -> TestTree +tests = runManifestTests mfEntryToTest -- 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 -> IO Test -mfEntryToTest (TestNTriplesPositiveSyntax nm _ _ act') = do +mfEntryToTest :: TestEntry -> TestTree +mfEntryToTest (TestNTriplesPositiveSyntax nm _ _ act') = let act = (UNode . fromJust . fileSchemeToFilePath) act' - rdf <- parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesGraph) - return $ testCase (T.unpack nm) $ TU.assert $ isParsed rdf -mfEntryToTest (TestNTriplesNegativeSyntax nm _ _ act') = do + rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesList) + in TU.testCase (T.unpack nm) $ assertIsParsed rdf +mfEntryToTest (TestNTriplesNegativeSyntax nm _ _ act') = let act = (UNode . fromJust . fileSchemeToFilePath) act' - rdf <- parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesGraph) - return $ testCase (T.unpack nm) $ TU.assert $ isNotParsed rdf + rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesList) + in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf mfEntryToTest x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x - -isParsed :: Either a b -> Bool -isParsed (Left _) = False -isParsed (Right _) = True - -isNotParsed :: Either a b -> Bool -isNotParsed = not . isParsed - -nodeURI :: Node -> String -nodeURI = \(UNode u) -> T.unpack u testParser :: NTriplesParser testParser = NTriplesParser diff --git a/testsuite/tests/W3C/RdfXmlTest.hs b/testsuite/tests/W3C/RdfXmlTest.hs --- a/testsuite/tests/W3C/RdfXmlTest.hs +++ b/testsuite/tests/W3C/RdfXmlTest.hs @@ -1,62 +1,42 @@ module W3C.RdfXmlTest where import Data.Maybe (fromJust) -import Test.Framework.Providers.API -import Test.Framework.Providers.HUnit -import qualified Test.HUnit as TU +import Test.Tasty +import qualified Test.Tasty.HUnit as TU import qualified Data.Text as T -import System.Directory import W3C.Manifest +import W3C.W3CAssertions import Data.RDF.Types import Data.RDF.Query import Text.RDF.RDF4H.XmlParser import Text.RDF.RDF4H.NTriplesParser -import Data.RDF.TriplesGraph - -suiteFilesDir = "data/w3c/rdf-xml/" - -mfPath = T.concat [suiteFilesDir, "manifest.ttl"] -mfBaseURI = BaseUrl "http://www.w3.org/2013/RDFXMLTests/" - -tests :: [Test] -tests = [ buildTest allRdfXmlTests ] +import Data.RDF.Graph.TriplesList -allRdfXmlTests :: IO Test -allRdfXmlTests = do - dir <- getCurrentDirectory - let fileSchemeURI = T.pack ("file://" ++ dir ++ "/" ++ T.unpack suiteFilesDir) - m <- loadManifest mfPath fileSchemeURI - return $ testGroup (T.unpack $ description m) $ map (buildTest . mfEntryToTest) $ entries m +tests :: Manifest -> TestTree +tests = runManifestTests mfEntryToTest -- 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 -> IO Test -mfEntryToTest (TestXMLEval nm _ _ act' res') = do +mfEntryToTest :: TestEntry -> TestTree +mfEntryToTest (TestXMLEval nm _ _ act' res') = let act = (UNode . fromJust . fileSchemeToFilePath) act' - let res = (UNode . fromJust . fileSchemeToFilePath) res' - parsedRDF <- parseFile testParser (nodeURI act) >>= return . fromEither :: IO TriplesGraph - expectedRDF <- parseFile NTriplesParser (nodeURI res) >>= return . fromEither :: IO TriplesGraph - return $ testCase (T.unpack nm) $ TU.assert $ isIsomorphic parsedRDF expectedRDF -mfEntryToTest (TestXMLNegativeSyntax nm _ _ act') = do + res = (UNode . fromJust . fileSchemeToFilePath) res' + parsedRDF = parseFile testParser (nodeURI act) >>= return . fromEither :: IO TriplesList + expectedRDF = parseFile NTriplesParser (nodeURI res) >>= return . fromEither :: IO TriplesList + in TU.testCase (T.unpack nm) $ assertIsIsomorphic parsedRDF expectedRDF +mfEntryToTest (TestXMLNegativeSyntax nm _ _ act') = let act = (UNode . fromJust . fileSchemeToFilePath) act' - rdf <- parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesGraph) - return $ testCase (T.unpack nm) $ TU.assert $ isNotParsed rdf + rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesList) + in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf mfEntryToTest x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x -isParsed :: Either a b -> Bool -isParsed (Left _) = False -isParsed (Right _) = True - -isNotParsed :: Either a b -> Bool -isNotParsed = not . isParsed - -nodeURI :: Node -> String -nodeURI = \(UNode u) -> T.unpack u +mfBaseURIXml :: BaseUrl +mfBaseURIXml = BaseUrl "http://www.w3.org/2013/RDFXMLTests/" testParser :: XmlParser -testParser = XmlParser (Just mfBaseURI) Nothing +testParser = XmlParser (Just mfBaseURIXml) Nothing diff --git a/testsuite/tests/W3C/TurtleTest.hs b/testsuite/tests/W3C/TurtleTest.hs --- a/testsuite/tests/W3C/TurtleTest.hs +++ b/testsuite/tests/W3C/TurtleTest.hs @@ -1,73 +1,46 @@ module W3C.TurtleTest where -import Test.Framework.Providers.API -import Test.Framework.Providers.HUnit -import qualified Test.HUnit as TU +import Test.Tasty +import qualified Test.Tasty.HUnit as TU + import Data.Maybe (fromJust) import qualified Data.Text as T -import Network.URI (parseURI,uriPath) -import System.Directory (getCurrentDirectory) import W3C.Manifest +import W3C.W3CAssertions import Data.RDF.Types import Data.RDF.Query import Text.RDF.RDF4H.TurtleParser import Text.RDF.RDF4H.NTriplesParser -import Data.RDF.TriplesGraph - -suiteFilesDir :: T.Text -suiteFilesDir = "data/w3c/turtle/TurtleTests/" - -mfPath = T.concat [suiteFilesDir, "manifest.ttl"] -mfBaseURI = BaseUrl "http://www.w3.org/2013/TurtleTests/" - -tests :: [Test] -tests = [ buildTest allTurtleTests ] - -allTurtleTests :: IO Test -allTurtleTests = do - dir <- getCurrentDirectory - let fileSchemeURI = T.pack ("file://" ++ dir ++ "/" ++ T.unpack suiteFilesDir) - m <- loadManifest mfPath fileSchemeURI - return $ testGroup (T.unpack $ description m) $ map (buildTest . mfEntryToTest) $ entries m +import Data.RDF.Graph.TriplesList +tests :: Manifest -> TestTree +tests = runManifestTests mfEntryToTest --- 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 -> IO Test -mfEntryToTest (TestTurtleEval nm _ _ act' res') = do +mfEntryToTest :: TestEntry -> TestTree +mfEntryToTest (TestTurtleEval nm _ _ act' res') = let act = (UNode . fromJust . fileSchemeToFilePath) act' - let res = (UNode . fromJust . fileSchemeToFilePath) res' - parsedRDF <- parseFile testParser (nodeURI act) >>= return . fromEither :: IO TriplesGraph - expectedRDF <- parseFile NTriplesParser (nodeURI res) >>= return . fromEither :: IO TriplesGraph - return $ testCase (T.unpack nm) $ TU.assert $ isIsomorphic parsedRDF expectedRDF -mfEntryToTest (TestTurtleNegativeEval nm _ _ act') = do + res = (UNode . fromJust . fileSchemeToFilePath) res' + parsedRDF = parseFile testParser (nodeURI act) >>= return . fromEither :: IO TriplesList + expectedRDF = parseFile NTriplesParser (nodeURI res) >>= return . fromEither :: IO TriplesList + in TU.testCase (T.unpack nm) $ assertIsIsomorphic parsedRDF expectedRDF +mfEntryToTest (TestTurtleNegativeEval nm _ _ act') = let act = (UNode . fromJust . fileSchemeToFilePath) act' - rdf <- parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesGraph) - return $ testCase (T.unpack nm) $ TU.assert $ isNotParsed rdf -mfEntryToTest (TestTurtlePositiveSyntax nm _ _ act') = do + rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesList) + in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf +mfEntryToTest (TestTurtlePositiveSyntax nm _ _ act') = let act = (UNode . fromJust . fileSchemeToFilePath) act' - rdf <- parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesGraph) - return $ testCase (T.unpack nm) $ TU.assert $ isParsed rdf -mfEntryToTest (TestTurtleNegativeSyntax nm _ _ act') = do + rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesList) + in TU.testCase (T.unpack nm) $ assertIsParsed rdf +mfEntryToTest (TestTurtleNegativeSyntax nm _ _ act') = let act = (UNode . fromJust . fileSchemeToFilePath) act' - rdf <- parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesGraph) - return $ testCase (T.unpack nm) $ TU.assert $ isNotParsed rdf + rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesList) + in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf mfEntryToTest x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x -isParsed :: Either a b -> Bool -isParsed (Left _) = False -isParsed (Right _) = True - -isNotParsed :: Either a b -> Bool -isNotParsed = not . isParsed - -nodeURI :: Node -> String -nodeURI = \(UNode u) -> T.unpack u +mfBaseURITurtle :: BaseUrl +mfBaseURITurtle = BaseUrl "http://www.w3.org/2013/TurtleTests/" testParser :: TurtleParser -testParser = TurtleParser (Just mfBaseURI) Nothing +testParser = TurtleParser (Just mfBaseURITurtle) Nothing diff --git a/testsuite/tests/W3C/W3CAssertions.hs b/testsuite/tests/W3C/W3CAssertions.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/W3C/W3CAssertions.hs @@ -0,0 +1,54 @@ +module W3C.W3CAssertions where + +import qualified Data.Text as T +import Data.RDF +import qualified Test.HUnit as TU +import Test.Tasty +import W3C.Manifest + +runManifestTests :: (TestEntry -> TestTree) -> Manifest -> TestTree +runManifestTests mfEntryToTest manifest = + testGroup (T.unpack $ description manifest) $ map mfEntryToTest $ entries manifest + +assertIsIsomorphic :: forall rdf1 rdf2. + (Show rdf1, Show rdf2, RDF rdf1, RDF rdf2) => + IO rdf1 -> IO rdf2 -> IO () +assertIsIsomorphic r1 r2 = do + gr1 <- r1 + gr2 <- r2 + TU.assertBool ("not isomorphic: " ++ show gr1 ++ " compared with " ++ show gr2) (isSame gr1 gr2) -- (isGraphIsomorphic gr1 gr2) + + where + noBlankNodes g = (all noBlanks . expandTriples) g + noBlanks (Triple s p o) = not (blankNode s) + && not (blankNode p) + && not (blankNode o) + blankNode (BNode _) = True + blankNode (BNodeGen _) = True + blankNode _ = False + isSame g1 g2 = + if (noBlankNodes g1) && (noBlankNodes g2) + -- can compare URIs and literals as well as structure + then isIsomorphic g1 g2 + -- cannot compare blank nodes with generated blank nodes, + -- so instead just compare the RDF graph structure of the + -- mf:action parsed RDF with the expected mf:result structure. + else isGraphIsomorphic g1 g2 + +assertIsParsed :: (Show rdf, RDF rdf) => IO (Either ParseFailure rdf) -> TU.Assertion +assertIsParsed r1 = do + gr1 <- r1 + TU.assertBool ("unable to parse, reason:\n" ++ show gr1) (isParsed gr1) + +assertIsNotParsed :: (Show rdf, RDF rdf) => IO (Either ParseFailure rdf) -> TU.Assertion +assertIsNotParsed r1 = do + gr1 <- r1 + TU.assertBool ("parsed unexpectantly:\n" ++ show gr1) (not (isParsed gr1)) + +isParsed :: Either a b -> Bool +isParsed (Left _) = False +isParsed (Right _) = True + +nodeURI :: Node -> String +nodeURI (UNode u) = T.unpack u +nodeURI node = error $ "W3CAssertions: unexpected node in `nodeURI`: " ++ show node