rdf4h 5.1.0 → 5.2.0
raw patch · 21 files changed
+1606/−2408 lines, 21 filesdep +xmlbfdep +xmlbf-xenodep ~base
Dependencies added: xmlbf, xmlbf-xeno
Dependency ranges changed: base
Files
- rdf4h.cabal +7/−9
- src/Data/RDF/Graph/AdjHashMap.hs +92/−86
- src/Data/RDF/Graph/AlgebraicGraph.hs +6/−7
- src/Data/RDF/Graph/TList.hs +55/−53
- src/Data/RDF/Namespace.hs +73/−50
- src/Data/RDF/Query.hs +8/−8
- src/Data/RDF/Types.hs +2/−2
- src/Data/RDF/Vocabulary/Generator/VocabularyGenerator.hs +29/−22
- src/Rdf4hParseMain.hs +5/−5
- src/Text/RDF/RDF4H/TurtleSerializer.hs +10/−8
- src/Text/RDF/RDF4H/TurtleSerializer/Internal.hs +43/−30
- src/Text/RDF/RDF4H/XmlParser.hs +258/−242
- src/Text/RDF/RDF4H/XmlParser/Identifiers.hs +64/−49
- src/Text/RDF/RDF4H/XmlParser/Xeno.hs +0/−95
- src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs +0/−954
- testsuite/tests/Data/RDF/PropertyTests.hs +305/−253
- testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs +2/−3
- testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs +393/−299
- testsuite/tests/W3C/Manifest.hs +219/−195
- testsuite/tests/W3C/RdfXmlTest.hs +15/−16
- testsuite/tests/W3C/TurtleTest.hs +20/−22
rdf4h.cabal view
@@ -1,5 +1,5 @@ name: rdf4h-version: 5.1.0+version: 5.2.0 synopsis: A library for RDF processing in Haskell description: 'RDF for Haskell' is a library for working with RDF in Haskell.@@ -72,7 +72,7 @@ , Text.RDF.RDF4H.ParserUtils , Text.RDF.RDF4H.TurtleSerializer.Internal build-depends: attoparsec- , base >= 4.8.0.0+ , base >= 4.8.0.0 && < 5 , bytestring , filepath , containers@@ -88,8 +88,8 @@ , parsers , mtl , network-uri >= 2.6- -- , xmlbf >= 0.6- -- , xmlbf-xeno+ , xmlbf >= 0.7+ , xmlbf-xeno >= 0.2.2 , lifted-base , http-conduit >= 2.2.0 , mmorph@@ -98,8 +98,6 @@ , html-entities , xeno , template-haskell >= 2.18.0- other-modules: Text.RDF.RDF4H.XmlParser.Xmlbf- , Text.RDF.RDF4H.XmlParser.Xeno if impl(ghc < 7.6) build-depends: ghc-prim if !impl(ghc >= 8.0)@@ -110,7 +108,7 @@ executable rdf4h default-language: Haskell2010 main-is: src/Rdf4hParseMain.hs- build-depends: base >= 4.8.0.0 && < 6+ build-depends: base >= 4.8.0.0 && < 5 , rdf4h , containers , text >= 1.2.1.0@@ -137,7 +135,7 @@ W3C.TurtleTest W3C.RdfXmlTest W3C.W3CAssertions- build-depends: base >= 4.8.0.0 && < 6+ build-depends: base >= 4.8.0.0 && < 5 , rdf4h , tasty , tasty-hunit@@ -164,7 +162,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: MainCriterion.hs- build-depends: base >= 4.8.0.0,+ build-depends: base >= 4.8.0.0 && < 5, deepseq, criterion, rdf4h,
src/Data/RDF/Graph/AdjHashMap.hs view
@@ -1,15 +1,14 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}---- |A graph implementation mapping hashed S to a mapping of--- hashed P to hashed O, backed by 'Data.HashMap'.+{-# LANGUAGE TypeFamilies #-} +-- | A graph implementation mapping hashed S to a mapping of+-- hashed P to hashed O, backed by 'Data.HashMap'. module Data.RDF.Graph.AdjHashMap (AdjHashMap) where import Prelude hiding (pred)@@ -20,90 +19,90 @@ #endif #else #endif-import Data.List+import Control.DeepSeq (NFData)+import Control.Monad (mfilter) import Data.Binary (Binary)-import Data.RDF.Types-import Data.RDF.Query-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 Control.Monad (mfilter)-import Control.DeepSeq (NFData)+import Data.Hashable ()+import qualified Data.List as List+import Data.RDF.Query+import Data.RDF.Types import GHC.Generics --- |A map-based graph implementation.+-- | 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 the adjacent nodes--- via that predicate.+-- This instance of 'RDF' is an adjacency map with each subject+-- mapping to a mapping from a predicate node to the adjacent nodes+-- via that predicate. ----- Given the following triples graph::+-- 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)--- @+-- @+-- (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+-- 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+-- > 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:+-- 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)--- @+-- @+-- 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:+-- Worst-case time complexity of the graph functions, with respect+-- to the number of triples, are: ----- * 'empty' : O(1)+-- * 'empty' : O(1) ----- * 'mkRdf' : O(n)+-- * 'mkRdf' : O(n) ----- * 'triplesOf': O(n)+-- * 'triplesOf': O(n) ----- * 'select' : O(n)+-- * 'select' : O(n) ----- * 'query' : O(log n)--- newtype HashS = HashS (TMaps, Maybe BaseUrl, PrefixMappings)--- deriving (NFData)-+-- * 'query' : O(log n)+-- newtype HashS = HashS (TMaps, Maybe BaseUrl, PrefixMappings)+-- deriving (NFData) data AdjHashMap deriving (Generic) instance Binary AdjHashMap+ instance NFData AdjHashMap -data instance RDF AdjHashMap = AdjHashMap (TMaps, Maybe BaseUrl, PrefixMappings)- deriving (NFData,Generic)+newtype instance RDF AdjHashMap = AdjHashMap (TMaps, Maybe BaseUrl, PrefixMappings)+ deriving (NFData, Generic) instance Rdf AdjHashMap where- baseUrl = baseUrl'- prefixMappings = prefixMappings'+ baseUrl = baseUrl'+ prefixMappings = prefixMappings' addPrefixMappings = addPrefixMappings'- empty = empty'- mkRdf = mkRdf'- triplesOf = triplesOf'- uniqTriplesOf = uniqTriplesOf'- select = select'- query = query'- showGraph = showGraph'- addTriple = addTriple'- removeTriple = removeTriple'+ empty = empty'+ mkRdf = mkRdf'+ triplesOf = triplesOf'+ uniqTriplesOf = uniqTriplesOf'+ select = select'+ query = query'+ showGraph = showGraph'+ addTriple = addTriple'+ removeTriple = removeTriple' -- instance Show (AdjHashMap) where -- show (AdjHashMap ((spoMap, _), _, _)) =@@ -113,9 +112,10 @@ showGraph' :: RDF AdjHashMap -> String showGraph' ((AdjHashMap ((spoMap, _), _, _))) =- let ts = concatMap (uncurry tripsSubj) subjPredMaps- where subjPredMaps = HashMap.toList spoMap- in concatMap (\t -> show t <> "\n") ts+ let ts = concatMap (uncurry tripsSubj) subjPredMaps+ where+ subjPredMaps = HashMap.toList spoMap+ in concatMap (\t -> show t <> "\n") ts -- instance Show (RDF AdjHashMap) where -- show gr = concatMap (\t -> show t <> "\n") (triplesOf gr)@@ -125,11 +125,13 @@ -- An adjacency map for a subject, mapping from a predicate node to -- to the adjacent nodes via that predicate. type AdjacencyMap = HashMap Predicate Adjacencies+ type Adjacencies = HashSet Node -type TMap = HashMap Node AdjacencyMap-type TMaps = (TMap, TMap)+type TMap = HashMap Node AdjacencyMap +type TMaps = (TMap, TMap)+ baseUrl' :: RDF AdjHashMap -> Maybe BaseUrl baseUrl' (AdjHashMap (_, baseURL, _)) = baseURL @@ -139,7 +141,7 @@ addPrefixMappings' :: RDF AdjHashMap -> PrefixMappings -> Bool -> RDF AdjHashMap addPrefixMappings' (AdjHashMap (ts, baseURL, pms)) pms' replace = let merge = if replace then flip (<>) else (<>)- in AdjHashMap (ts, baseURL, merge pms pms')+ in AdjHashMap (ts, baseURL, merge pms pms') empty' :: RDF AdjHashMap empty' = AdjHashMap ((mempty, mempty), Nothing, PrefixMappings mempty)@@ -150,7 +152,7 @@ addTriple' :: RDF AdjHashMap -> Triple -> RDF AdjHashMap addTriple' (AdjHashMap (tmaps, baseURL, pms)) t = let newTMaps = mergeTs tmaps [t]- in AdjHashMap (newTMaps, baseURL, pms)+ in AdjHashMap (newTMaps, baseURL, pms) removeTriple' :: RDF AdjHashMap -> Triple -> RDF AdjHashMap removeTriple' (AdjHashMap ((spo, ops), baseURL, pms)) (Triple s p o) =@@ -162,61 +164,65 @@ removeO o' os = mfilter (not . null) $ Set.delete o' <$> os mergeTs :: TMaps -> Triples -> TMaps-mergeTs = foldl' mergeT+mergeTs = List.foldl' mergeT where mergeT :: TMaps -> Triple -> TMaps mergeT (spo, ops) (Triple s p o) = (insertT s p o spo, insertT o p s ops) insertT :: Node -> Predicate -> Node -> TMap -> TMap- insertT s p o = let newPO = HashMap.singleton p (Set.singleton o)- in HashMap.insertWith (HashMap.unionWith mappend) s newPO+ insertT s p o =+ let newPO = HashMap.singleton p (Set.singleton o)+ in HashMap.insertWith (HashMap.unionWith mappend) s newPO -- 3 following functions support triplesOf triplesOf' :: RDF AdjHashMap -> Triples triplesOf' (AdjHashMap ((spoMap, _), _, _)) = concatMap (uncurry tripsSubj) subjPredMaps- where subjPredMaps = HashMap.toList spoMap+ where+ subjPredMaps = HashMap.toList spoMap -- naive implementation for now uniqTriplesOf' :: RDF AdjHashMap -> Triples-uniqTriplesOf' = nub . expandTriples+uniqTriplesOf' = List.nub . expandTriples tripsSubj :: Subject -> AdjacencyMap -> Triples tripsSubj s adjMap = concatMap (tfsp s) (HashMap.toList adjMap)- where tfsp s' (p, m) = Triple s' p <$> Set.toList m+ where+ tfsp s' (p, m) = Triple s' p <$> Set.toList m -- supports select select' :: RDF AdjHashMap -> NodeSelector -> NodeSelector -> NodeSelector -> Triples select' r Nothing Nothing Nothing = triplesOf r-select' (AdjHashMap ((_, ops),_,_)) Nothing p o = selectSPO o p Nothing (\a b c -> Triple c b a) ops-select' (AdjHashMap ((spo, _),_,_)) s p o = selectSPO s p o Triple spo+select' (AdjHashMap ((_, ops), _, _)) Nothing p o = selectSPO o p Nothing (\a b c -> Triple c b a) ops+select' (AdjHashMap ((spo, _), _, _)) s p o = selectSPO s p o Triple spo selectSPO :: NodeSelector -> NodeSelector -> NodeSelector -> (Node -> Node -> Node -> Triple) -> TMap -> Triples-selectSPO Nothing p o t = concatMap (selectPO p o t) . HashMap.toList+selectSPO Nothing p o t = concatMap (selectPO p o t) . HashMap.toList selectSPO (Just s) p o t = concatMap (selectPO p o t) . filter (s . fst) . HashMap.toList selectPO :: NodeSelector -> NodeSelector -> (Node -> Node -> Node -> Triple) -> (Node, AdjacencyMap) -> Triples-selectPO Nothing o t (s, po) = concatMap (selectO o t s) . HashMap.toList $ po+selectPO Nothing o t (s, po) = concatMap (selectO o t s) . HashMap.toList $ po selectPO (Just p) o t (s, po) = concatMap (selectO o t s) . filter (p . fst) . HashMap.toList $ po selectO :: NodeSelector -> (Node -> Node -> Node -> Triple) -> Node -> (Node, Adjacencies) -> Triples selectO o t s (p, os) = t s p <$> Set.toList os'- where os' = maybe os (`Set.filter` os) o+ where+ os' = maybe os (`Set.filter` os) o -- support query query' :: RDF AdjHashMap -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples query' r Nothing Nothing Nothing = triplesOf r-query' (AdjHashMap ((_, ops), _, _)) Nothing p o = querySPO o p Nothing (\a b c -> Triple c b a) ops-query' (AdjHashMap ((spo, _), _, _)) s p o = querySPO s p o Triple spo+query' (AdjHashMap ((_, ops), _, _)) Nothing p o = querySPO o p Nothing (\a b c -> Triple c b a) ops+query' (AdjHashMap ((spo, _), _, _)) s p o = querySPO s p o Triple spo querySPO :: Maybe Node -> Maybe Node -> Maybe Node -> (Node -> Node -> Node -> Triple) -> TMap -> Triples-querySPO Nothing p o t = concatMap (uncurry $ queryPO p o t) . HashMap.toList+querySPO Nothing p o t = concatMap (uncurry $ queryPO p o t) . HashMap.toList querySPO (Just s) p o t = maybe mempty (queryPO p o t s) . HashMap.lookup s queryPO :: Maybe Node -> Maybe Node -> (Node -> Node -> Node -> Triple) -> Node -> AdjacencyMap -> Triples-queryPO Nothing o t s po = concatMap (uncurry $ queryO o t s) . HashMap.toList $ po+queryPO Nothing o t s po = concatMap (uncurry $ queryO o t s) . HashMap.toList $ po queryPO (Just p) o t s po = maybe mempty (queryO o t s p) $ HashMap.lookup p po queryO :: Maybe Node -> (Node -> Node -> Node -> Triple) -> Node -> Node -> Adjacencies -> Triples-queryO Nothing t s p os = t s p <$> Set.toList os+queryO Nothing t s p os = t s p <$> Set.toList os queryO (Just o) t s p os | o `Set.member` os = [t s p o]- | otherwise = mempty+ | otherwise = mempty
src/Data/RDF/Graph/AlgebraicGraph.hs view
@@ -35,12 +35,11 @@ instance NFData AlgebraicGraph -data instance RDF AlgebraicGraph- = AlgebraicGraph- { _graph :: G.Graph (HashSet Node) Node,- _baseUrl :: Maybe BaseUrl,- _prefixMappings :: PrefixMappings- }+data instance RDF AlgebraicGraph = AlgebraicGraph+ { _graph :: G.Graph (HashSet Node) Node,+ _baseUrl :: Maybe BaseUrl,+ _prefixMappings :: PrefixMappings+ } deriving (Generic, NFData) instance Rdf AlgebraicGraph where@@ -64,7 +63,7 @@ toTriples (ps, s, o) = [Triple s p o | p <- HS.toList ps] showGraph' :: RDF AlgebraicGraph -> String-showGraph' r = concatMap (\t -> show t ++ "\n") (expandTriples r)+showGraph' r = concatMap (\t -> show t <> "\n") (expandTriples r) addPrefixMappings' :: RDF AlgebraicGraph -> PrefixMappings -> Bool -> RDF AlgebraicGraph addPrefixMappings' (AlgebraicGraph g baseURL pms) pms' replace =
src/Data/RDF/Graph/TList.hs view
@@ -1,22 +1,21 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-}-+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-} --- |"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.+-- | "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.TList (TList) where import Prelude@@ -29,70 +28,70 @@ #endif import Control.DeepSeq (NFData) import Data.Binary+import Data.List (nub) import Data.RDF.Namespace import Data.RDF.Query-import Data.RDF.Types (RDF,Rdf(..),Triple(..),Subject,Predicate,Object,NodeSelector,Triples,BaseUrl)-import Data.List (nub)+import Data.RDF.Types (BaseUrl, NodeSelector, Object, Predicate, RDF, Rdf (..), Subject, Triple (..), Triples) import GHC.Generics --- |A simple implementation of the 'RDF' type class that represents--- the graph internally as a list of triples.+-- | 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).+-- 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:+-- The time complexity of the functions (where n == num_triples) are: ----- * 'empty' : O(1)+-- * 'empty' : O(1) ----- * 'mkRdf' : O(n)+-- * 'mkRdf' : O(n) ----- * 'triplesOf': O(1)+-- * 'triplesOf': O(1) ----- * 'select' : O(n)+-- * 'select' : O(n) ----- * 'query' : O(n)-+-- * 'query' : O(n) data TList deriving (Generic) instance Binary TList+ instance NFData TList -data instance RDF TList = TListC (Triples, Maybe BaseUrl, PrefixMappings)- deriving (Generic,NFData)+newtype instance RDF TList = TListC (Triples, Maybe BaseUrl, PrefixMappings)+ deriving (Generic, NFData) instance Rdf TList where- baseUrl = baseUrl'- prefixMappings = prefixMappings'+ baseUrl = baseUrl'+ prefixMappings = prefixMappings' addPrefixMappings = addPrefixMappings'- empty = empty'- mkRdf = mkRdf'- addTriple = addTriple'- removeTriple = removeTriple'- triplesOf = triplesOf'- uniqTriplesOf = uniqTriplesOf'- select = select'- query = query'- showGraph = showGraph'+ empty = empty'+ mkRdf = mkRdf'+ addTriple = addTriple'+ removeTriple = removeTriple'+ triplesOf = triplesOf'+ uniqTriplesOf = uniqTriplesOf'+ select = select'+ query = query'+ showGraph = showGraph' showGraph' :: RDF TList -> String showGraph' gr = concatMap (\t -> show t <> "\n") (expandTriples gr) prefixMappings' :: RDF TList -> PrefixMappings-prefixMappings' (TListC(_, _, pms)) = pms+prefixMappings' (TListC (_, _, pms)) = pms addPrefixMappings' :: RDF TList -> PrefixMappings -> Bool -> RDF TList-addPrefixMappings' (TListC(ts, baseURL, pms)) pms' replace =+addPrefixMappings' (TListC (ts, baseURL, pms)) pms' replace = let merge = if replace then flip (<>) else (<>)- in TListC(ts, baseURL, merge pms pms')+ in TListC (ts, baseURL, merge pms pms') baseUrl' :: RDF TList -> Maybe BaseUrl-baseUrl' (TListC(_, baseURL, _)) = baseURL+baseUrl' (TListC (_, baseURL, _)) = baseURL empty' :: RDF TList-empty' = TListC(mempty, Nothing, PrefixMappings mempty)+empty' = TListC (mempty, Nothing, PrefixMappings mempty) -- 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@@ -102,14 +101,15 @@ mkRdf' ts baseURL pms = TListC (ts, baseURL, pms) addTriple' :: RDF TList -> Triple -> RDF TList-addTriple' (TListC (ts, bURL, preMapping)) t = TListC (t:ts,bURL,preMapping)+addTriple' (TListC (ts, bURL, preMapping)) t = TListC (t : ts, bURL, preMapping) removeTriple' :: RDF TList -> Triple -> RDF TList-removeTriple' (TListC (ts, bURL, preMapping)) t = TListC (newTs,bURL,preMapping)- where newTs = filter (/= t) ts+removeTriple' (TListC (ts, bURL, preMapping)) t = TListC (newTs, bURL, preMapping)+ where+ newTs = filter (/= t) ts triplesOf' :: RDF TList -> Triples-triplesOf' ((TListC(ts, _, _))) = ts+triplesOf' ((TListC (ts, _, _))) = ts uniqTriplesOf' :: RDF TList -> Triples uniqTriplesOf' = nub . expandTriples@@ -122,8 +122,10 @@ matchSelect :: NodeSelector -> NodeSelector -> NodeSelector -> Triple -> Bool matchSelect s p o (Triple s' p' o') = match s s' && match p p' && match o o'- where match fn n = maybe True ($ n) fn+ where+ match fn n = maybe True ($ n) fn matchPattern :: Maybe Subject -> Maybe Predicate -> Maybe Object -> Triple -> Bool matchPattern s p o (Triple s' p' o') = match s s' && match p p' && match o o'- where match n1 n2 = maybe True (==n2) n1+ where+ match n1 n2 = maybe True (== n2) n1
src/Data/RDF/Namespace.hs view
@@ -1,24 +1,44 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} --- |Defines types and utility functions related to namespaces, and--- some predefined values for commonly used namespaces, such as--- rdf, xsd, dublin core, etc.+-- | Defines types and utility functions related to namespaces, and+-- some predefined values for commonly used namespaces, such as+-- rdf, xsd, dublin core, etc.+module Data.RDF.Namespace+ ( -- * Namespace types and functions+ Namespace (..),+ mkPlainNS,+ mkPrefixedNS,+ mkPrefixedNS',+ PrefixMapping (PrefixMapping),+ PrefixMappings (PrefixMappings),+ toPMList,+ mkUri,+ prefixOf,+ uriOf, -module Data.RDF.Namespace(- -- * Namespace types and functions- Namespace(..), mkPlainNS, mkPrefixedNS, mkPrefixedNS',- PrefixMapping(PrefixMapping), PrefixMappings(PrefixMappings), toPMList,- mkUri,- prefixOf, uriOf,- -- * Predefined namespace values- rdf, rdfs, dc, dct, owl, schema, xml, xsd, skos, foaf, ex, ex2,- standard_ns_mappings, ns_mappings-) where+ -- * Predefined namespace values+ rdf,+ rdfs,+ dc,+ dct,+ owl,+ schema,+ xml,+ xsd,+ skos,+ foaf,+ ex,+ ex2,+ standard_ns_mappings,+ ns_mappings,+ )+where -import Data.Maybe (catMaybes)-import qualified Data.Text as T-import Data.RDF.Types import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import Data.RDF.Types+import qualified Data.Text as T #if MIN_VERSION_base(4,9,0) #if !MIN_VERSION_base(4,11,0) -- lts 10 says not needed@@ -31,97 +51,100 @@ standard_namespaces :: [Namespace] standard_namespaces = [rdf, rdfs, dc, dct, schema, owl, xsd, skos, foaf, ex, ex2] --- |The set of common predefined namespaces as a 'PrefixMappings' value.+-- | The set of common predefined namespaces as a 'PrefixMappings' value. standard_ns_mappings :: PrefixMappings-standard_ns_mappings = ns_mappings standard_namespaces+standard_ns_mappings = ns_mappings standard_namespaces --- |Takes a list of 'Namespace's and returns 'PrefixMappings'.+-- | Takes a list of 'Namespace's and returns 'PrefixMappings'. ns_mappings :: [Namespace] -> PrefixMappings-ns_mappings ns = PrefixMappings $ Map.fromList $ catMaybes $- fmap (\n -> case n of- (PrefixedNS pre uri) -> Just (pre, uri)- PlainNS _ -> Nothing- ) ns+ns_mappings ns =+ PrefixMappings $+ Map.fromList $+ mapMaybe+ ( \case+ (PrefixedNS pre uri) -> Just (pre, uri)+ PlainNS _ -> Nothing+ )+ ns --- |The RDF namespace.+-- | The RDF namespace. rdf :: Namespace rdf = mkPrefixedNS' "rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#" --- |The RDF Schema namespace.+-- | The RDF Schema namespace. rdfs :: Namespace rdfs = mkPrefixedNS' "rdfs" "http://www.w3.org/2000/01/rdf-schema#" --- |The Dublin Core namespace.+-- | The Dublin Core namespace. dc :: Namespace dc = mkPrefixedNS' "dc" "http://purl.org/dc/elements/1.1/" --- |The Dublin Core terms namespace.+-- | The Dublin Core terms namespace. dct :: Namespace dct = mkPrefixedNS' "dct" "http://purl.org/dc/terms/" --- |The OWL namespace.+-- | The OWL namespace. owl :: Namespace owl = mkPrefixedNS' "owl" "http://www.w3.org/2002/07/owl#" --- |The Schema.org namespace+-- | The Schema.org namespace schema :: Namespace schema = mkPrefixedNS' "schema" "http://schema.org/" --- |The XML Schema namespace.+-- | The XML Schema namespace. xml :: Namespace xml = mkPrefixedNS' "xml" "http://www.w3.org/XML/1998/namespace" --- |The XML Schema namespace.+-- | The XML Schema namespace. xsd :: Namespace xsd = mkPrefixedNS' "xsd" "http://www.w3.org/2001/XMLSchema#" --- |The SKOS namespace.+-- | The SKOS namespace. skos :: Namespace skos = mkPrefixedNS' "skos" "http://www.w3.org/2004/02/skos/core#" --- |The friend of a friend namespace.+-- | The friend of a friend namespace. foaf :: Namespace foaf = mkPrefixedNS' "foaf" "http://xmlns.com/foaf/0.1/" --- |Example namespace #1.+-- | Example namespace #1. ex :: Namespace ex = mkPrefixedNS' "ex" "http://www.example.org/" --- |Example namespace #2.+-- | Example namespace #2. ex2 :: Namespace ex2 = mkPrefixedNS' "ex2" "http://www2.example.org/" --- |View the prefix mappings as a list of key-value pairs. The PM in--- in the name is to reduce name clashes if used without qualifying.+-- | View the prefix mappings as a list of key-value pairs. The PM in+-- in the name is to reduce name clashes if used without qualifying. toPMList :: PrefixMappings -> [(T.Text, T.Text)] toPMList (PrefixMappings m) = Map.toList m --- |Make a URI consisting of the given namespace and the given localname.+-- | Make a URI consisting of the given namespace and the given localname. mkUri :: Namespace -> T.Text -> T.Text mkUri ns local = uriOf ns `T.append` local ---- |Make a namespace for the given URI reference.+-- | Make a namespace for the given URI reference. mkPlainNS :: T.Text -> Namespace mkPlainNS = PlainNS --- |Make a namespace having the given prefix for the given URI reference,--- respectively.+-- | Make a namespace having the given prefix for the given URI reference,+-- respectively. mkPrefixedNS :: T.Text -> T.Text -> Namespace mkPrefixedNS = PrefixedNS --- |Make a namespace having the given prefix for the given URI reference,--- respectively, using strings which will be converted to bytestrings--- automatically.+-- | Make a namespace having the given prefix for the given URI reference,+-- respectively, using strings which will be converted to bytestrings+-- automatically. mkPrefixedNS' :: String -> String -> Namespace mkPrefixedNS' s1 s2 = mkPrefixedNS (T.pack s1) (T.pack s2) --- |Determine the URI of the given namespace.+-- | Determine the URI of the given namespace. uriOf :: Namespace -> T.Text-uriOf (PlainNS uri) = uri+uriOf (PlainNS uri) = uri uriOf (PrefixedNS _ uri) = uri --- |Determine the prefix of the given namespace, if it has one.+-- | Determine the prefix of the given namespace, if it has one. prefixOf :: Namespace -> Maybe T.Text-prefixOf (PlainNS _) = Nothing+prefixOf (PlainNS _) = Nothing prefixOf (PrefixedNS p _) = Just p
src/Data/RDF/Query.hs view
@@ -36,7 +36,7 @@ import Control.Applicative ((<|>)) import Control.Exception-import Data.List+import qualified Data.List as List import Data.Maybe (fromMaybe) import Data.RDF.IRI import qualified Data.RDF.Namespace as NS@@ -93,15 +93,15 @@ equalObjects (Triple _ _ o1) (Triple _ _ o2) = o1 == o2 -- | Determines whether the 'RDF' contains zero triples.-isEmpty :: Rdf a => RDF a -> Bool+isEmpty :: (Rdf a) => RDF a -> Bool isEmpty = null . triplesOf -- | Lists of all subjects of triples with the given predicate.-subjectsWithPredicate :: Rdf a => RDF a -> Predicate -> [Subject]+subjectsWithPredicate :: (Rdf a) => RDF a -> Predicate -> [Subject] subjectsWithPredicate rdf pred = subjectOf <$> query rdf Nothing (Just pred) Nothing -- | Lists of all objects of triples with the given predicate.-objectsOfPredicate :: Rdf a => RDF a -> Predicate -> [Object]+objectsOfPredicate :: (Rdf a) => RDF a -> Predicate -> [Object] objectsOfPredicate rdf pred = objectOf <$> query rdf Nothing (Just pred) Nothing -- | Convert a parse result into an RDF if it was successful@@ -112,7 +112,7 @@ -- | Convert a list of triples into a sorted list of unique triples. uordered :: Triples -> Triples-uordered = sort . nub+uordered = List.sort . List.nub -- graphFromEdges :: Ord key => [(node, key, [key])] -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex) @@ -138,7 +138,7 @@ && compareNodeUnlessBlank p1 p2 && compareNodeUnlessBlank o1 o2 normalize :: (Rdf a) => RDF a -> Triples- normalize = sort . nub . expandTriples+ normalize = List.sort . List.nub . expandTriples -- | Expand the triples in a graph with the prefix map and base URL -- for that graph. Unsafe because it assumes IRI resolution will@@ -162,7 +162,7 @@ -- Also expands "a" to "http://www.w3.org/1999/02/22-rdf-syntax-ns#type". expandURI :: PrefixMappings -> Text -> Text expandURI _ "a" = NS.mkUri NS.rdf "type"-expandURI pms iri = fromMaybe iri $ foldl' f Nothing (NS.toPMList pms)+expandURI pms iri = fromMaybe iri $ List.foldl' f Nothing (NS.toPMList pms) where f :: Maybe Text -> (Text, Text) -> Maybe Text f x (p, u) = x <|> (T.append u <$> T.stripPrefix (T.append p ":") iri)@@ -181,7 +181,7 @@ Right t -> Right (unode t) absolutizeNode _ n = Right n -data QueryException+newtype QueryException = IRIResolutionException String deriving (Show)
src/Data/RDF/Types.hs view
@@ -83,7 +83,7 @@ import Control.DeepSeq (NFData, rnf) import Control.Monad (guard, (<=<)) import Data.Binary-import Data.Char (chr, ord)+import Data.Char (chr, isDigit, ord) import Data.Either (isRight) import Data.Hashable (Hashable) import qualified Data.List as List@@ -256,7 +256,7 @@ seq t' <$> go (k - 1) t' {-# INLINE getHex #-} getHex c- | '0' <= c && c <= '9' = pure (ord c - ord '0')+ | isDigit c = pure (ord c - ord '0') | 'A' <= c && c <= 'F' = pure (ord c - ord 'A' + 10) | 'a' <= c && c <= 'f' = pure (ord c - ord 'a' + 10) | otherwise = A.empty
src/Data/RDF/Vocabulary/Generator/VocabularyGenerator.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -6,7 +7,7 @@ ) where -import Control.Monad (join)+-- import Control.Monad (join) import Data.Char (isLower) import Data.List (nub, sortBy) import qualified Data.Map as M@@ -58,20 +59,20 @@ loadGraph :: String -> IO (RDF AdjHashMap) loadGraph file =- parseFile (TurtleParser Nothing Nothing) file >>= \result -> case result of+ parseFile (TurtleParser Nothing Nothing) file >>= \case Left err -> error $ show err Right rdfGraph -> return rdfGraph -vocabulary :: Rdf a => RDF a -> Q [Dec]+vocabulary :: (Rdf a) => RDF a -> Q [Dec] vocabulary graph = let nameDecls = do subject <- nub $ subjectOf <$> triplesOf graph iri <- maybeToList $ toIRI subject name <- maybeToList $ iriToName iri- let comment = combineComments .- sequenceA .- fmap (nodeToComment . objectOf) $- query graph (Just subject) (Just rdfsCommentNode) Nothing+ let comment =+ combineComments+ . traverse (nodeToComment . objectOf)+ $ query graph (Just subject) (Just rdfsCommentNode) Nothing return (name, declareIRI name iri comment) (PrefixMappings prefixMappings') = prefixMappings graph namespaceDecls = do@@ -96,15 +97,15 @@ mkPrefixedNSFun = VarE $ mkName "Data.RDF.Namespace.mkPrefixedNS" nodeToComment :: Node -> Maybe Text-nodeToComment (UNode uri) = Just $ "See \\<<" <> uri <> ">\\>."-nodeToComment (BNode _) = Nothing-nodeToComment (BNodeGen _) = Nothing-nodeToComment (LNode (PlainL l)) = Just l+nodeToComment (UNode uri) = Just $ "See \\<<" <> uri <> ">\\>."+nodeToComment (BNode _) = Nothing+nodeToComment (BNodeGen _) = Nothing+nodeToComment (LNode (PlainL l)) = Just l nodeToComment (LNode (PlainLL l _)) = Just l-nodeToComment (LNode (TypedL l _)) = Just l+nodeToComment (LNode (TypedL l _)) = Just l combineComments :: Maybe [Text] -> Maybe Text-combineComments = join . fmap combineComments'+combineComments = (combineComments' =<<) where combineComments' [] = Nothing combineComments' comments = Just . T.intercalate "\n" $ comments@@ -116,16 +117,20 @@ declareIRI name iri comment = let iriLiteral = LitE . StringL $ T.unpack iri unodeLiteral = AppE unodeFun $ AppE packFun iriLiteral- in funD_doc name [return $ Clause [] (NormalB unodeLiteral) []]- (T.unpack <$> comment)- [Nothing]+ in funD_doc+ name+ [return $ Clause [] (NormalB unodeLiteral) []]+ (T.unpack <$> comment)+ [Nothing] declareIRIs :: [Name] -> Q Dec declareIRIs names = let iriList = ListE (VarE <$> names)- in funD_doc (mkName "iris") [return $ Clause [] (NormalB iriList) []]- (Just $ "All IRIs in this vocabulary.")- [Nothing]+ in funD_doc+ (mkName "iris")+ [return $ Clause [] (NormalB iriList) []]+ (Just "All IRIs in this vocabulary.")+ [Nothing] -- namespace = mkPrefixedNS "ogit" "http://www.purl.org/ogit/" declarePrefix :: Name -> Text -> Text -> Q Dec@@ -133,9 +138,11 @@ let prefixLiteral = AppE packFun . LitE . StringL . T.unpack $ prefix iriLiteral = AppE packFun . LitE . StringL . T.unpack $ iri namespace = AppE (AppE mkPrefixedNSFun prefixLiteral) iriLiteral- in funD_doc name [return $ Clause [] (NormalB namespace) []]- (Just $ "Namespace prefix for \\<<" <> T.unpack iri <> ">\\>.")- [Nothing]+ in funD_doc+ name+ [return $ Clause [] (NormalB namespace) []]+ (Just $ "Namespace prefix for \\<<" <> T.unpack iri <> ">\\>.")+ [Nothing] iriToName :: Text -> Maybe Name iriToName iri = mkName . T.unpack . escape <$> (lastMay . filter (not . T.null) . T.split (`elem` separators)) iri
src/Rdf4hParseMain.hs view
@@ -10,7 +10,7 @@ import Control.Monad import Data.Char (isLetter)-import Data.List+import qualified Data.List as List import qualified Data.Map as Map import Data.RDF #if MIN_VERSION_base(4,9,0)@@ -45,7 +45,7 @@ ) ) let debug = Debug `elem` opts- inputUri = head args+ inputUri = List.head args inputFormat = getWithDefault (InputFormat "turtle") opts outputFormat = getWithDefault (OutputFormat "ntriples") opts inputBaseUri = getInputBaseUri inputUri args opts@@ -133,9 +133,9 @@ -- arg is silently discarded. getInputBaseUri :: String -> [String] -> [Flag] -> String getInputBaseUri inputUri args flags =- if null $ tail args+ if null $ List.tail args then getWithDefault (InputBaseUri inputUri) flags- else getWithDefault (InputBaseUri (head $ tail args)) flags+ else getWithDefault (InputBaseUri (List.head $ tail args)) flags -- Determine if the bytestring represents a URI, which is currently -- decided solely by checking for a colon in the string.@@ -149,7 +149,7 @@ -- return the string value of the first argument. getWithDefault :: Flag -> [Flag] -> String getWithDefault def args =- case find (== def) args of+ case List.find (== def) args of Nothing -> strValue def Just val -> strValue val
src/Text/RDF/RDF4H/TurtleSerializer.hs view
@@ -2,9 +2,7 @@ -- | An RDF serializer for Turtle -- <http://www.w3.org/TeamSubmission/turtle/>.-module Text.RDF.RDF4H.TurtleSerializer- (TurtleSerializer (TurtleSerializer))-where+module Text.RDF.RDF4H.TurtleSerializer (TurtleSerializer (TurtleSerializer)) where #if MIN_VERSION_base(4,9,0) #if !MIN_VERSION_base(4,11,0)@@ -48,14 +46,14 @@ -- configurable somehow, so that if the user really doesn't want any extra -- prefix declarations added, that is possible. -_writeRdf :: Rdf a => Handle -> Maybe T.Text -> RDF a -> IO ()+_writeRdf :: (Rdf a) => Handle -> Maybe T.Text -> RDF a -> IO () _writeRdf h mdUrl rdf = writeHeader h bUrl pms' >> writeTriples h mdUrl pms' ts >> hPutChar h '\n' where bUrl = baseUrl rdf -- a merged set of prefix mappings using those from the standard_ns_mappings -- that are not defined already (union is left-biased).- pms' = PrefixMappings $ (asMap $ prefixMappings rdf)+ pms' = PrefixMappings (asMap $ prefixMappings rdf) asMap (PrefixMappings x) = x ts = triplesOf rdf @@ -73,7 +71,9 @@ writePrefix :: Handle -> (T.Text, T.Text) -> IO () writePrefix h (pre, uri) =- hPutStr h "@prefix " >> T.hPutStr h pre >> hPutStr h ": "+ hPutStr h "@prefix "+ >> T.hPutStr h pre+ >> hPutStr h ": " >> hPutChar h '<' >> T.hPutStr h uri >> hPutStr h "> ."@@ -98,7 +98,8 @@ writeSubjGroup :: Handle -> Maybe T.Text -> PrefixMappings -> Triples -> IO () writeSubjGroup _ _ _ [] = return () writeSubjGroup h dUrl pms ts@(t : _) =- writeNode h dUrl (subjectOf t) pms >> hPutChar h ' '+ writeNode h dUrl (subjectOf t) pms+ >> hPutChar h ' ' >> writePredGroup h dUrl pms (head ts') >> mapM_ (\t' -> hPutStr h ";\n\t" >> writePredGroup h dUrl pms t') (tail ts') >> hPutStrLn h " ."@@ -113,7 +114,8 @@ writePredGroup h docUrl pms (t : ts) = -- The doesn't rule out <> in either the predicate or object (as well as subject), -- so we pass the docUrl through to writeNode in all cases.- writeNode h docUrl (predicateOf t) pms >> hPutChar h ' '+ writeNode h docUrl (predicateOf t) pms+ >> hPutChar h ' ' >> writeNode h docUrl (objectOf t) pms >> mapM_ (\t' -> hPutStr h ", " >> writeNode h docUrl (objectOf t') pms) ts
src/Text/RDF/RDF4H/TurtleSerializer/Internal.hs view
@@ -1,54 +1,67 @@ {-# LANGUAGE OverloadedStrings #-} module Text.RDF.RDF4H.TurtleSerializer.Internal- ( findMapping- , writeUNodeUri+ ( findMapping,+ writeUNodeUri, ) where -import Data.Foldable (fold)-import Data.List (elemIndex)+import Data.List (elemIndex) import qualified Data.Map as Map-import Data.Monoid (Any(..), getAny)-import Data.RDF.Namespace hiding (rdf)+import Data.Monoid (Any (..), getAny)+import Data.RDF.Namespace hiding (rdf) import qualified Data.Text as T import qualified Data.Text.IO as T-import System.IO+import System.IO --- |Converts an aliased URI (e.g., 'rdf:subject') to a tuple whose first element--- is the full (non-aliased) URI and whose second element is the target/path--- portion (the part after the colon in the aliased URI).-findMapping :: PrefixMappings -- ^The 'PrefixMappings' to be searched for the prefix that may be a part of the URI.- -> T.Text -- ^The URI.- -> Maybe (T.Text, T.Text)+-- | Converts an aliased URI (e.g., 'rdf:subject') to a tuple whose first element+-- is the full (non-aliased) URI and whose second element is the target/path+-- portion (the part after the colon in the aliased URI).+findMapping ::+ -- | The 'PrefixMappings' to be searched for the prefix that may be a part of the URI.+ PrefixMappings ->+ -- | The URI.+ T.Text ->+ Maybe (T.Text, T.Text) findMapping (PrefixMappings pms) aliasedURI = do (prefix, target) <- splitAliasedURI aliasedURI uri <- Map.lookup prefix pms pure (uri, target) --- |Writes the given 'UNode' to the given 'Handle'.-writeUNodeUri :: Handle -- ^The Handle to write to- -> T.Text -- ^The text from a UNode- -> PrefixMappings -- ^The 'PrefixMappings' which should contain a mapping for any prefix found in the URI.- -> IO ()+-- | Writes the given 'UNode' to the given 'Handle'.+writeUNodeUri ::+ -- | The Handle to write to+ Handle ->+ -- | The text from a UNode+ T.Text ->+ -- | The 'PrefixMappings' which should contain a mapping for any prefix found in the URI.+ PrefixMappings ->+ IO () writeUNodeUri h uri _ = if (isQName uri)- then T.hPutStr h uri- else hPutChar h '<' >> T.hPutStr h uri >> hPutChar h '>'+ then T.hPutStr h uri+ else hPutChar h '<' >> T.hPutStr h uri >> hPutChar h '>' isQName :: T.Text -> Bool isQName = not . isFullURI- where isFullURI :: T.Text -> Bool- isFullURI = getAny . foldMap (Any .) [ ("http://" `T.isPrefixOf`)- , ("https://" `T.isPrefixOf`)- , ("file://" `T.isPrefixOf`)- ]+ where+ isFullURI :: T.Text -> Bool+ isFullURI =+ getAny+ . foldMap+ (Any .)+ [ ("http://" `T.isPrefixOf`),+ ("https://" `T.isPrefixOf`),+ ("file://" `T.isPrefixOf`)+ ] --- |Given an aliased URI (e.g., 'rdf:subject') return a tuple whose first--- element is the alias ('rdf') and whose second part is the path or fragment--- ('subject').-splitAliasedURI :: T.Text -- ^Aliased URI.- -> Maybe (T.Text, T.Text)+-- | Given an aliased URI (e.g., 'rdf:subject') return a tuple whose first+-- element is the alias ('rdf') and whose second part is the path or fragment+-- ('subject').+splitAliasedURI ::+ -- | Aliased URI.+ T.Text ->+ Maybe (T.Text, T.Text) splitAliasedURI uri = do let uriStr = T.unpack uri i <- elemIndex ':' uriStr
src/Text/RDF/RDF4H/XmlParser.hs view
@@ -1,33 +1,32 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} --- |An parser for the RDF/XML format--- <http://www.w3.org/TR/REC-rdf-syntax/>.-+-- | An parser for the RDF/XML format+-- <http://www.w3.org/TR/REC-rdf-syntax/>. module Text.RDF.RDF4H.XmlParser- ( XmlParser(..)- , parseXmlDebug- ) where+ ( XmlParser (..),+ parseXmlDebug,+ )+where -import Data.RDF.Types hiding (empty, resolveQName)+import Control.Applicative+import Control.Monad+import Control.Monad.Except+import Control.Monad.State.Strict+import Data.RDF.Graph.TList+import Data.RDF.IRI+import Data.RDF.Types hiding (empty, resolveQName) import qualified Data.RDF.Types as RDF-import Data.RDF.IRI-import Data.RDF.Graph.TList-import Text.RDF.RDF4H.ParserUtils hiding (Parser)-import Text.RDF.RDF4H.XmlParser.Identifiers-import Text.RDF.RDF4H.XmlParser.Xmlbf hiding (Node)-import qualified Text.RDF.RDF4H.XmlParser.Xeno as Xeno--import Control.Applicative-import Control.Monad-import Control.Monad.Except-import Control.Monad.State.Strict+import Text.RDF.RDF4H.ParserUtils hiding (Parser)+import Text.RDF.RDF4H.XmlParser.Identifiers #if MIN_VERSION_base(4,9,0) #if !MIN_VERSION_base(4,11,0) import Data.Semigroup@@ -35,90 +34,96 @@ #endif #else #endif-import Data.Set (Set)-import qualified Data.Set as S import qualified Data.Map as Map-import Data.Maybe+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as S #if MIN_VERSION_base(4,10,0) import Data.Either #else #endif-import Data.Bifunctor-import Data.HashSet (HashSet)-import qualified Data.HashSet as HS-import Data.HashMap.Strict (HashMap)+import Data.Bifunctor+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM-import Data.Text (Text)+import Data.HashSet (HashSet)+import qualified Data.HashSet as HS+import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.IO as TIO-import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as T-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Builder as BB--- import Xmlbf hiding (Node, State)--- import qualified Xmlbf.Xeno as Xeno+import qualified Data.Text.IO as TIO+import Xmlbf hiding (Node)+import qualified Xmlbf.Xeno as Xeno instance RdfParser XmlParser where parseString (XmlParser bUrl dUrl) = parseXmlRDF bUrl dUrl- parseFile (XmlParser bUrl dUrl) = parseFile' bUrl dUrl- parseURL (XmlParser bUrl dUrl) = parseURL' bUrl dUrl+ parseFile (XmlParser bUrl dUrl) = parseFile' bUrl dUrl+ parseURL (XmlParser bUrl dUrl) = parseURL' bUrl dUrl --- |Configuration for the XML parser-data XmlParser =- XmlParser (Maybe BaseUrl) -- ^ The /default/ base URI to parse the document.- (Maybe Text) -- ^ The /retrieval URI/ of the XML document.+-- | Configuration for the XML parser+data XmlParser+ = XmlParser+ -- | The /default/ base URI to parse the document.+ (Maybe BaseUrl)+ -- | The /retrieval URI/ of the XML document.+ (Maybe Text) -parseFile' :: (Rdf a)- => Maybe BaseUrl- -> Maybe Text- -> FilePath- -> IO (Either ParseFailure (RDF a))+parseFile' ::+ (Rdf a) =>+ Maybe BaseUrl ->+ Maybe Text ->+ FilePath ->+ IO (Either ParseFailure (RDF a)) parseFile' bUrl dUrl fpath = parseXmlRDF bUrl dUrl <$> TIO.readFile fpath -parseURL' :: (Rdf a)- => Maybe BaseUrl- -- ^ The optional base URI of the document.- -> Maybe Text- -- ^ The document URI (i.e., the URI of the document itself); if Nothing, use location URI.- -> String- -- ^ The location URI from which to retrieve the XML document.- -> IO (Either ParseFailure (RDF a))- -- ^ The parse result, which is either a @ParseFailure@ or the RDF+parseURL' ::+ (Rdf a) =>+ -- | The optional base URI of the document.+ Maybe BaseUrl ->+ -- | The document URI (i.e., the URI of the document itself); if Nothing, use location URI.+ Maybe Text ->+ -- | The location URI from which to retrieve the XML document.+ String ->+ -- | The parse result, which is either a @ParseFailure@ or the RDF -- corresponding to the XML document.+ IO (Either ParseFailure (RDF a)) parseURL' bUrl docUrl = parseFromURL (parseXmlRDF bUrl docUrl) --- |The parser monad.-type Parser = ParserT (ExceptT String (State ParseState))+-- | The parser monad.+type RdfXmlParser = ParserT (ExceptT String (State ParseState)) --- |Local state for the parser (dependant on the parent xml elements)+-- | Local state for the parser (dependant on the parent xml elements) data ParseState = ParseState- { stateBaseUri :: Maybe BaseUrl- -- ^ The local base URI.- , stateIdSet :: Set Text- -- ^ The set of @rdf:ID@ found in the scope of the current base URI.- , statePrefixMapping :: PrefixMappings- -- ^ The namespace mapping.- , stateLang :: Maybe Text- -- ^ The local @xml:lang@- , stateNodeAttrs :: HashMap Text Text- -- ^ Current node RDF attributes.- , stateSubject :: Maybe Subject- -- ^ Current subject for triple construction.- , stateCollectionIndex :: Int- -- ^ Current collection index.- , stateGenId :: Int- } deriving(Show)+ { -- | The local base URI.+ stateBaseUri :: Maybe BaseUrl,+ -- | The set of @rdf:ID@ found in the scope of the current base URI.+ stateIdSet :: Set Text,+ -- | The namespace mapping.+ statePrefixMapping :: PrefixMappings,+ -- | The local @xml:lang@+ stateLang :: Maybe Text,+ -- | Current node RDF attributes.+ stateNodeAttrs :: HashMap Text Text,+ -- | Current subject for triple construction.+ stateSubject :: Maybe Subject,+ -- | Current collection index.+ stateCollectionIndex :: Int,+ stateGenId :: Int+ }+ deriving (Show) --- |Parse a xml Text to an RDF representation-parseXmlRDF :: (Rdf a)- => Maybe BaseUrl- -- ^ The base URI for the RDF if required- -> Maybe Text- -- ^ The request URI for the document to if available- -> Text- -- ^ The contents to parse- -> Either ParseFailure (RDF a)- -- ^ The RDF representation of the triples or ParseFailure+-- | Parse a xml Text to an RDF representation+parseXmlRDF ::+ (Rdf a) =>+ -- | The base URI for the RDF if required+ Maybe BaseUrl ->+ -- | The request URI for the document to if available+ Maybe Text ->+ -- | The contents to parse+ Text ->+ -- | The RDF representation of the triples or ParseFailure+ Either ParseFailure (RDF a) parseXmlRDF bUrl dUrl = parseRdf . parseXml where bUrl' = BaseUrl <$> dUrl <|> bUrl@@ -127,44 +132,44 @@ parseRdf' ns = join $ evalState (runExceptT (parseM rdfParser ns)) initState initState = ParseState bUrl' mempty mempty empty mempty empty 0 0 --- |A parser for debugging purposes.-parseXmlDebug- :: FilePath- -- ^ Path of the file to parse.- -> IO (RDF TList)+-- | A parser for debugging purposes.+parseXmlDebug ::+ -- | Path of the file to parse.+ FilePath ->+ IO (RDF TList) parseXmlDebug f = fromRight RDF.empty <$> parseFile (XmlParser (Just . BaseUrl $ "http://base-url.com/") (Just "http://doc-url.com/")) f --- |Document parser-rdfParser :: Rdf a => Parser (RDF a)+-- | Document parser+rdfParser :: (Rdf a) => RdfXmlParser (RDF a) rdfParser = do bUri <- currentBaseUri triples <- (pRdf <* pWs) <|> pNodeElementList pEndOfInput mkRdf triples bUri <$> currentPrefixMappings --- |Parser for @rdf:RDF@, if present.--- See: https://www.w3.org/TR/rdf-syntax-grammar/#RDF-pRdf :: Parser Triples+-- | RdfXmlParser for @rdf:RDF@, if present.+-- See: https://www.w3.org/TR/rdf-syntax-grammar/#RDF+pRdf :: RdfXmlParser Triples pRdf = pAnyElement $ do attrs <- pRDFAttrs uri <- pName >>= pQName guard (uri == rdfTag)- unless (null attrs) $ throwError "rdf:RDF: The set of attributes should be empty."+ unless (null attrs) (throwError "rdf:RDF: The set of attributes should be empty.") pNodeElementList --- |Parser for XML QName: resolve the namespace with the mapping in context.+-- | RdfXmlParser for XML QName: resolve the namespace with the mapping in context. ----- Throws an error if the namespace is not defined.-pQName :: Text -> Parser Text+-- Throws an error if the namespace is not defined.+pQName :: Text -> RdfXmlParser Text pQName qn = do pm <- currentPrefixMappings let qn' = resolveQName pm qn >>= validateIRI either throwError pure qn' --- |Process the attributes of an XML element.+-- | Process the attributes of an XML element. ----- To be called __once__ per XML element.-pRDFAttrs :: Parser (HashMap Text Text)+-- To be called __once__ per XML element.+pRDFAttrs :: RdfXmlParser (HashMap Text Text) pRDFAttrs = do -- Language (xml:lang) liftA2 (<|>) pLang currentLang >>= setLang@@ -180,54 +185,54 @@ setNodeAttrs as pure as where- -- |Check if an XML attribute is a namespace definition+ -- \|Check if an XML attribute is a namespace definition -- and if so add it to the mapping.- mkNameSpace- :: Map.Map Text Text- -- ^ Current namespace mapping- -> Text- -- ^ XML attribute to process- -> Text- -- ^ Value of the attribute- -> Map.Map Text Text+ mkNameSpace ::+ Map.Map Text Text ->+ -- \^ Current namespace mapping+ Text ->+ -- \^ XML attribute to process+ Text ->+ -- \^ Value of the attribute+ Map.Map Text Text mkNameSpace ns qn iri = let qn' = parseQName qn ns' = f <$> qn' <*> validateIRI iri- f (Nothing , "xmlns") iri' = Map.insert mempty iri' ns- f (Just "xmlns", prefix ) iri' = Map.insert prefix iri' ns- f _ _ = ns- in either (const ns) id ns'- -- |Check if an XML attribute is an RDF attribute+ f (Nothing, "xmlns") iri' = Map.insert mempty iri' ns+ f (Just "xmlns", prefix) iri' = Map.insert prefix iri' ns+ f _ _ = ns+ in fromRight ns ns'+ -- \|Check if an XML attribute is an RDF attribute -- and if so resolve its URI and keep it.- mkRdfAttribute- :: PrefixMappings- -- ^ Namespace mapping- -> Maybe BaseUrl- -- ^ Base URI- -> HM.HashMap Text Text- -- ^ Current set of RDF attributes- -> Text- -- ^ XML attribute to process- -> Text- -- ^ Value of the attribute- -> HM.HashMap Text Text+ mkRdfAttribute ::+ PrefixMappings ->+ -- \^ Namespace mapping+ Maybe BaseUrl ->+ -- \^ Base URI+ HM.HashMap Text Text ->+ -- \^ Current set of RDF attributes+ Text ->+ -- \^ XML attribute to process+ Text ->+ -- \^ Value of the attribute+ HM.HashMap Text Text mkRdfAttribute pm bUri as qn v = let as' = parseQName qn >>= f -- [NOTE] Ignore XML reserved names f (Nothing, n) | T.isPrefixOf "xml" n = Right as- | otherwise = case bUri of+ | otherwise = case bUri of Nothing -> Right as -- [FIXME] manage missing base URI Just (BaseUrl bUri') -> (\a -> HM.insert a v as) <$> resolveIRI bUri' n f qn'@(Just prefix, _) | T.isPrefixOf "xml" prefix = Right as | otherwise = (\a -> HM.insert a v as) <$> resolveQName' pm qn'- in either (const as) id as'+ in fromRight as as' --- |Return the value of the requested RDF attribute using its URI.+-- | Return the value of the requested RDF attribute using its URI. ----- Fails if the attribute is not defined.-pRDFAttr :: Text -> Parser Text+-- Fails if the attribute is not defined.+pRDFAttr :: Text -> RdfXmlParser Text pRDFAttr a = do as <- currentNodeAttrs maybe@@ -236,19 +241,19 @@ (HM.lookup a as) -- See: https://www.w3.org/TR/rdf-syntax-grammar/#nodeElementList-pNodeElementList :: Parser Triples+pNodeElementList :: RdfXmlParser Triples pNodeElementList = pWs *> (mconcat <$> some (keepState pNodeElement <* pWs)) --- |White spaces parser--- See: https://www.w3.org/TR/rdf-syntax-grammar/#ws-pWs :: Parser ()-pWs = maybe True (T.all ws . TL.toStrict) <$> optional pText >>= guard+-- | White spaces parser+-- See: https://www.w3.org/TR/rdf-syntax-grammar/#ws+pWs :: RdfXmlParser ()+pWs = optional pText >>= guard . maybe True (T.all ws) where -- See: https://www.w3.org/TR/2000/REC-xml-20001006#NT-S ws c = c == '\x20' || c == '\x09' || c == '\x0d' || c == '\x0a' -- https://www.w3.org/TR/rdf-syntax-grammar/#nodeElement-pNodeElement :: Parser Triples+pNodeElement :: RdfXmlParser Triples pNodeElement = pAnyElement $ do -- Process attributes void pRDFAttrs@@ -259,11 +264,11 @@ ts2 <- keepState pPropertyEltList setSubject (Just s) let ts = ts1 <> ts2- pure $ maybe ts (:ts) mt+ pure $ maybe ts (: ts) mt --- |Process the following parts of a @nodeElement@: URI, subject and @rdf:type@.--- See: https://www.w3.org/TR/rdf-syntax-grammar/#nodeElement-pSubject :: Parser (Node, Maybe Triple)+-- | Process the following parts of a @nodeElement@: URI, subject and @rdf:type@.+-- See: https://www.w3.org/TR/rdf-syntax-grammar/#nodeElement+pSubject :: RdfXmlParser (Node, Maybe Triple) pSubject = do -- Create the subject -- [TODO] check the attributes that only one of the following may work@@ -289,7 +294,7 @@ else empty -- See: https://www.w3.org/TR/rdf-syntax-grammar/#propertyAttr-pPropertyAttrs :: Node -> Parser Triples+pPropertyAttrs :: Node -> RdfXmlParser Triples pPropertyAttrs s = do attrs <- currentNodeAttrs HM.elems <$> HM.traverseWithKey f attrs@@ -299,30 +304,33 @@ | attr == rdfType = pure $ Triple s rdfTypeNode (unode value) | otherwise = do lang <- currentLang- pure $ let mkLiteral = maybe plainL (flip plainLL) lang- in Triple s (unode attr) (lnode (mkLiteral value))+ pure $+ let mkLiteral = maybe plainL (flip plainLL) lang+ in Triple s (unode attr) (lnode (mkLiteral value)) -pLang :: Parser (Maybe Text)+pLang :: RdfXmlParser (Maybe Text) pLang = optional (pAttr "xml:lang") -- [TODO] resolve base uri in context-pBase :: Parser (Maybe BaseUrl)+pBase :: RdfXmlParser (Maybe BaseUrl) pBase = optional $ do uri <- pAttr "xml:base" -- Parse and remove fragment- BaseUrl <$> either- throwError- (pure . serializeIRI . removeIRIFragment)- (parseIRI uri)+ BaseUrl+ <$> either+ throwError+ (pure . serializeIRI . removeIRIFragment)+ (parseIRI uri) -- See: https://www.w3.org/TR/rdf-syntax-grammar/#propertyEltList-pPropertyEltList :: Parser Triples-pPropertyEltList = pWs- *> resetCollectionIndex- *> fmap mconcat (many (pPropertyElt <* pWs))+pPropertyEltList :: RdfXmlParser Triples+pPropertyEltList =+ pWs+ *> resetCollectionIndex+ *> fmap mconcat (many (pPropertyElt <* pWs)) -- See: https://www.w3.org/TR/rdf-syntax-grammar/#propertyElt-pPropertyElt :: Parser Triples+pPropertyElt :: RdfXmlParser Triples pPropertyElt = pAnyElement $ do -- Process attributes void pRDFAttrs@@ -341,10 +349,10 @@ where listExpansion u | u == rdfLi = nextCollectionIndex- | otherwise = pure u+ | otherwise = pure u -- See: https://www.w3.org/TR/rdf-syntax-grammar/#resourcePropertyElt-pResourcePropertyElt :: Node -> Parser Triples+pResourcePropertyElt :: Node -> RdfXmlParser Triples pResourcePropertyElt p = do pWs -- [NOTE] We need to restore part of the state after exploring the element' children.@@ -358,10 +366,10 @@ let mt = flip Triple p <$> s <*> o -- Reify the triple ts2 <- maybe (pure mempty) (uncurry reifyTriple) (liftA2 (,) mi mt)- pure $ maybe (ts1 <> ts2) (:(ts1 <> ts2)) mt+ pure $ maybe (ts1 <> ts2) (: (ts1 <> ts2)) mt -- See: https://www.w3.org/TR/rdf-syntax-grammar/#literalPropertyElt-pLiteralPropertyElt :: Node -> Parser Triples+pLiteralPropertyElt :: Node -> RdfXmlParser Triples pLiteralPropertyElt p = do l <- pText -- No children@@ -372,15 +380,14 @@ s <- currentSubject lang <- currentLang -- Generated triple- let l' = TL.toStrict l- o = lnode . fromMaybe (plainL l') $ (typedL l' <$> dt) <|> (plainLL l' <$> lang)+ let o = lnode . fromMaybe (plainL l) $ (typedL l <$> dt) <|> (plainLL l <$> lang) mt = (\s' -> Triple s' p o) <$> s -- Reify the triple ts <- maybe (pure mempty) (uncurry reifyTriple) (liftA2 (,) mi mt)- pure $ maybe ts (:ts) mt+ pure $ maybe ts (: ts) mt -- See: https://www.w3.org/TR/rdf-syntax-grammar/#parseTypeLiteralPropertyElt-pParseTypeLiteralPropertyElt :: Node -> Parser Triples+pParseTypeLiteralPropertyElt :: Node -> RdfXmlParser Triples pParseTypeLiteralPropertyElt p = do pt <- pRDFAttr rdfParseType guard (pt == "Literal")@@ -393,10 +400,10 @@ mt = (\s' -> Triple s' p o) <$> s -- Reify the triple ts <- maybe (pure mempty) (uncurry reifyTriple) (liftA2 (,) mi mt)- pure $ maybe ts (:ts) mt+ pure $ maybe ts (: ts) mt -- See: https://www.w3.org/TR/rdf-syntax-grammar/#parseTypeResourcePropertyElt-pParseTypeResourcePropertyElt :: Node -> Parser Triples+pParseTypeResourcePropertyElt :: Node -> RdfXmlParser Triples pParseTypeResourcePropertyElt p = do pt <- pRDFAttr rdfParseType guard (pt == "Resource")@@ -411,11 +418,11 @@ setSubject (Just o) -- Explore children ts2 <- keepCollectionIndex pPropertyEltList- --setSubject s- pure $ maybe (ts1 <> ts2) ((<> ts2) . (:ts1)) mt+ -- setSubject s+ pure $ maybe (ts1 <> ts2) ((<> ts2) . (: ts1)) mt -- See: https://www.w3.org/TR/rdf-syntax-grammar/#parseTypeCollectionPropertyElt-pParseTypeCollectionPropertyElt :: Node -> Parser Triples+pParseTypeCollectionPropertyElt :: Node -> RdfXmlParser Triples pParseTypeCollectionPropertyElt p = do pt <- pRDFAttr rdfParseType guard (pt == "Collection")@@ -430,7 +437,7 @@ Nothing -> -- Empty collection let t = Triple s' p rdfNilNode- in ([t] <>) <$> maybe (pure mempty) (`reifyTriple` t) mi+ in ([t] <>) <$> maybe (pure mempty) (`reifyTriple` t) mi Just ts1 -> do -- Non empty collection s'' <- currentSubject@@ -460,7 +467,7 @@ pure $ mconcat [ts1, ts2, ts3] -- See: https://www.w3.org/TR/rdf-syntax-grammar/#parseTypeOtherPropertyElt-pParseTypeOtherPropertyElt :: Node -> Parser Triples+pParseTypeOtherPropertyElt :: Node -> RdfXmlParser Triples pParseTypeOtherPropertyElt _p = do pt <- pRDFAttr rdfParseType guard (pt /= "Resource" && pt /= "Literal" && pt /= "Collection")@@ -470,7 +477,7 @@ throwError "Not implemented: rdf:parseType = other" -- See: https://www.w3.org/TR/rdf-syntax-grammar/#emptyPropertyElt-pEmptyPropertyElt :: Node -> Parser Triples+pEmptyPropertyElt :: Node -> RdfXmlParser Triples pEmptyPropertyElt p = do s <- currentSubject case s of@@ -482,23 +489,24 @@ -- Reify triple ts1 <- maybe (pure mempty) (`reifyTriple` t) mi ts2 <- pPropertyAttrs o- pure (t:ts1 <> ts2)+ pure (t : ts1 <> ts2) where pResourceAttr' = unode <$> pResourceAttr <* removeNodeAttr rdfResource pNodeIdAttr' = BNode <$> pNodeIdAttr <* removeNodeAttr rdfNodeID -checkAllowedAttributes :: HashSet Text -> Parser ()+checkAllowedAttributes :: HashSet Text -> RdfXmlParser () checkAllowedAttributes as = do attrs <- currentNodeAttrs let diffAttrs = HS.difference (HM.keysSet attrs) as unless (null diffAttrs) (throwError $ "Attributes not allowed: " <> show diffAttrs)+ -- See: https://www.w3.org/TR/rdf11-concepts/#dfn-rdf-xmlliteral, -- https://www.w3.org/TR/rdf-syntax-grammar/#literal-pXMLLiteral :: Parser Text+pXMLLiteral :: RdfXmlParser Text pXMLLiteral = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . encode <$> pChildren -pIdAttr :: Parser Text+pIdAttr :: RdfXmlParser Text pIdAttr = do i <- pRDFAttr rdfID i' <- either throwError pure (checkRdfId i)@@ -506,76 +514,83 @@ checkIdIsUnique i' pure i' -checkIdIsUnique :: Text -> Parser ()+checkIdIsUnique :: Text -> RdfXmlParser () checkIdIsUnique i = do notUnique <- S.member i <$> currentIdSet when notUnique (throwError $ "rdf:ID already used in this context: " <> T.unpack i) updateIdSet i -pNodeIdAttr :: Parser Text+pNodeIdAttr :: RdfXmlParser Text pNodeIdAttr = do i <- pRDFAttr rdfNodeID either throwError pure (checkRdfId i) -pAboutAttr :: Parser Text+pAboutAttr :: RdfXmlParser Text pAboutAttr = pRDFAttr rdfAbout >>= checkIRI "rdf:about" -pResourceAttr :: Parser Text+pResourceAttr :: RdfXmlParser Text pResourceAttr = pRDFAttr rdfResource >>= checkIRI "rdf:resource" -pDatatypeAttr :: Parser Text+pDatatypeAttr :: RdfXmlParser Text pDatatypeAttr = pRDFAttr rdfDatatype >>= checkIRI "rdf:datatype" -reifyTriple :: Text -> Triple -> Parser Triples+reifyTriple :: Text -> Triple -> RdfXmlParser Triples reifyTriple i (Triple s p' o) = do n <- mkUNodeID i- pure [ Triple n rdfTypeNode rdfStatementNode- , Triple n rdfSubjectNode s- , Triple n rdfPredicateNode p'- , Triple n rdfObjectNode o ]+ pure+ [ Triple n rdfTypeNode rdfStatementNode,+ Triple n rdfSubjectNode s,+ Triple n rdfPredicateNode p',+ Triple n rdfObjectNode o+ ] -------------------------------------------------------------------------------- -- URI checks -checkIRI :: String -> Text -> Parser Text+checkIRI :: String -> Text -> RdfXmlParser Text checkIRI msg iri = do bUri <- maybe mempty unBaseUrl <$> currentBaseUri case uriValidate iri of- Nothing -> throwError $ mconcat ["Malformed IRI for \"", msg, "\": ", T.unpack iri]+ Nothing -> throwError $ mconcat ["Malformed IRI for \"", msg, "\": ", T.unpack iri] Just iri' -> either throwError pure (resolveIRI bUri iri') -- https://www.w3.org/TR/rdf-syntax-grammar/#propertyAttributeURIs isPropertyAttrURI :: Text -> Bool-isPropertyAttrURI uri- = isNotCoreSyntaxTerm uri- && uri /= rdfDescription- && uri /= rdfLi- && isNotOldTerm uri+isPropertyAttrURI uri =+ isNotCoreSyntaxTerm uri+ && uri /= rdfDescription+ && uri /= rdfLi+ && isNotOldTerm uri -- https://www.w3.org/TR/rdf-syntax-grammar/#coreSyntaxTerms isNotCoreSyntaxTerm :: Text -> Bool-isNotCoreSyntaxTerm uri- = uri /= rdfTag && uri /= rdfID && uri /= rdfAbout- && uri /= rdfParseType && uri /= rdfResource- && uri /= rdfNodeID && uri /= rdfDatatype+isNotCoreSyntaxTerm uri =+ uri /= rdfTag+ && uri /= rdfID+ && uri /= rdfAbout+ && uri /= rdfParseType+ && uri /= rdfResource+ && uri /= rdfNodeID+ && uri /= rdfDatatype -- https://www.w3.org/TR/rdf-syntax-grammar/#oldTerms isNotOldTerm :: Text -> Bool-isNotOldTerm uri = uri /= rdfAboutEach- && uri /= rdfAboutEachPrefix- && uri /= rdfBagID+isNotOldTerm uri =+ uri /= rdfAboutEach+ && uri /= rdfAboutEachPrefix+ && uri /= rdfBagID -------------------------------------------------------------------------------- -- Parser's state utils --- |Create a new unique blank node-newBNode :: Parser Node+-- | Create a new unique blank node+newBNode :: RdfXmlParser Node newBNode = do- modify $ \st -> st { stateGenId = stateGenId st + 1 }+ modify $ \st -> st {stateGenId = stateGenId st + 1} BNodeGen . stateGenId <$> get --- |Process a parser, restoring the state except for stateGenId and stateIdSet-keepState :: Parser a -> Parser a+-- | Process a parser, restoring the state except for stateGenId and stateIdSet+keepState :: RdfXmlParser a -> RdfXmlParser a keepState p = do st <- get let bUri = stateBaseUri st@@ -587,76 +602,77 @@ is' = stateIdSet st' -- Update the set of ID if necessary if bUri /= bUri'- then put (st { stateGenId = i })- else put (st { stateGenId = i, stateIdSet = is <> is' })+ then put (st {stateGenId = i})+ else put (st {stateGenId = i, stateIdSet = is <> is'}) -currentIdSet :: Parser (Set Text)+currentIdSet :: RdfXmlParser (Set Text) currentIdSet = stateIdSet <$> get -updateIdSet :: Text -> Parser ()+updateIdSet :: Text -> RdfXmlParser () updateIdSet i = do is <- currentIdSet- modify (\st -> st { stateIdSet = S.insert i is })+ modify (\st -> st {stateIdSet = S.insert i is}) -currentNodeAttrs :: Parser (HashMap Text Text)+currentNodeAttrs :: RdfXmlParser (HashMap Text Text) currentNodeAttrs = stateNodeAttrs <$> get -setNodeAttrs :: HashMap Text Text -> Parser ()-setNodeAttrs as = modify (\st -> st { stateNodeAttrs = as })+setNodeAttrs :: HashMap Text Text -> RdfXmlParser ()+setNodeAttrs as = modify (\st -> st {stateNodeAttrs = as}) -removeNodeAttr :: Text -> Parser ()-removeNodeAttr a = HM.delete a <$> currentNodeAttrs >>= setNodeAttrs+removeNodeAttr :: Text -> RdfXmlParser ()+removeNodeAttr a = currentNodeAttrs >>= setNodeAttrs . HM.delete a -currentPrefixMappings :: Parser PrefixMappings+currentPrefixMappings :: RdfXmlParser PrefixMappings currentPrefixMappings = statePrefixMapping <$> get -updatePrefixMappings :: PrefixMappings -> Parser PrefixMappings+updatePrefixMappings :: PrefixMappings -> RdfXmlParser PrefixMappings updatePrefixMappings pm = do pm' <- (<> pm) <$> currentPrefixMappings- modify (\st -> st { statePrefixMapping = pm' })+ modify (\st -> st {statePrefixMapping = pm'}) pure pm' -currentCollectionIndex :: Parser Int+currentCollectionIndex :: RdfXmlParser Int currentCollectionIndex = stateCollectionIndex <$> get -setCollectionIndex :: Int -> Parser ()-setCollectionIndex i = modify (\st -> st { stateCollectionIndex = i })+setCollectionIndex :: Int -> RdfXmlParser ()+setCollectionIndex i = modify (\st -> st {stateCollectionIndex = i}) -keepCollectionIndex :: Parser a -> Parser a+keepCollectionIndex :: RdfXmlParser a -> RdfXmlParser a keepCollectionIndex p = do i <- currentCollectionIndex p <* setCollectionIndex i -- See: https://www.w3.org/TR/rdf-syntax-grammar/#section-List-Expand-nextCollectionIndex :: Parser Text+nextCollectionIndex :: RdfXmlParser Text nextCollectionIndex = do- modify $ \st -> st { stateCollectionIndex = stateCollectionIndex st + 1 }+ modify $ \st -> st {stateCollectionIndex = stateCollectionIndex st + 1} (rdfListIndex <>) . T.pack . show . stateCollectionIndex <$> get -resetCollectionIndex :: Parser ()-resetCollectionIndex = modify $ \st -> st { stateCollectionIndex = 0 }+resetCollectionIndex :: RdfXmlParser ()+resetCollectionIndex = modify $ \st -> st {stateCollectionIndex = 0} -currentBaseUri :: Parser (Maybe BaseUrl)+currentBaseUri :: RdfXmlParser (Maybe BaseUrl) currentBaseUri = stateBaseUri <$> get -setBaseUri :: (Maybe BaseUrl) -> Parser ()-setBaseUri u = modify (\st -> st { stateBaseUri = u })+setBaseUri :: (Maybe BaseUrl) -> RdfXmlParser ()+setBaseUri u = modify (\st -> st {stateBaseUri = u}) -mkUNodeID :: Text -> Parser Node+mkUNodeID :: Text -> RdfXmlParser Node mkUNodeID t = mkUnode <$> currentBaseUri where- mkUnode = unode . \case- Nothing -> t- Just (BaseUrl u) -> mconcat [u, "#", t]+ mkUnode =+ unode . \case+ Nothing -> t+ Just (BaseUrl u) -> mconcat [u, "#", t] -currentSubject :: Parser (Maybe Subject)+currentSubject :: RdfXmlParser (Maybe Subject) currentSubject = stateSubject <$> get -setSubject :: (Maybe Subject) -> Parser ()-setSubject s = modify (\st -> st { stateSubject = s })+setSubject :: (Maybe Subject) -> RdfXmlParser ()+setSubject s = modify (\st -> st {stateSubject = s}) -currentLang :: Parser (Maybe Text)+currentLang :: RdfXmlParser (Maybe Text) currentLang = stateLang <$> get -setLang :: (Maybe Text) -> Parser ()-setLang lang = modify (\st -> st { stateLang = lang })+setLang :: (Maybe Text) -> RdfXmlParser ()+setLang lang = modify (\st -> st {stateLang = lang})
src/Text/RDF/RDF4H/XmlParser/Identifiers.hs view
@@ -1,26 +1,27 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TupleSections #-} module Text.RDF.RDF4H.XmlParser.Identifiers ( -- rdf:ID validation- checkRdfId+ checkRdfId, -- Qualified names- , resolveQName, resolveQName'- , parseQName- ) where-+ resolveQName,+ resolveQName',+ parseQName,+ )+where #if !MIN_VERSION_base(4,13,0) import Data.Functor ((<$)) #else #endif-import Control.Applicative (liftA2, Alternative(..))-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Map as Map-import Data.Attoparsec.Text (Parser, (<?>))+import Control.Applicative (Alternative (..))+import Data.Attoparsec.Text (Parser, (<?>)) import qualified Data.Attoparsec.Text as P+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T #if MIN_VERSION_base(4,9,0) #if !MIN_VERSION_base(4,11,0) import Data.Semigroup ((<>))@@ -28,18 +29,19 @@ #endif #else #endif-import Data.RDF.Namespace+import Data.Char (isAsciiLower, isAsciiUpper, isDigit)+import Data.RDF.Namespace -------------------------------------------------------------------------------- -- rdf:ID --- |Validate the value of @rdf:ID@.+-- | Validate the value of @rdf:ID@. ----- See: https://www.w3.org/TR/rdf-syntax-grammar/#rdf-id-checkRdfId- :: Text- -- ^ Value of a @rdf:ID@ attribute to validate.- -> Either String Text+-- See: https://www.w3.org/TR/rdf-syntax-grammar/#rdf-id+checkRdfId ::+ -- | Value of a @rdf:ID@ attribute to validate.+ Text ->+ Either String Text checkRdfId t = t <$ parseId t parseId :: Text -> Either String Text@@ -48,36 +50,36 @@ -------------------------------------------------------------------------------- -- Qualified names --- |Parse and resolve a qualified name.+-- | Parse and resolve a qualified name. ----- See: https://www.w3.org/TR/xml-names/#ns-qualnames-resolveQName- :: PrefixMappings- -- ^ Namespace mapping to resolve q qualified name.- -> Text- -- ^ Raw qualified name to process.- -> Either String Text+-- See: https://www.w3.org/TR/xml-names/#ns-qualnames+resolveQName ::+ -- | Namespace mapping to resolve q qualified name.+ PrefixMappings ->+ -- | Raw qualified name to process.+ Text ->+ Either String Text resolveQName pm qn = parseQName qn >>= resolveQName' pm --- |Resolve a qualified name.-resolveQName'- :: PrefixMappings- -- ^ Namespace mapping to resolve q qualified name.- -> (Maybe Text, Text)- -- ^ (namespace, local name)- -> Either String Text+-- | Resolve a qualified name.+resolveQName' ::+ -- | Namespace mapping to resolve q qualified name.+ PrefixMappings ->+ -- | (namespace, local name)+ (Maybe Text, Text) ->+ Either String Text resolveQName' (PrefixMappings pm) (Nothing, name) = case Map.lookup mempty pm of- Nothing -> Left $ mconcat ["Cannot resolve QName \"", T.unpack name, "\": no default namespace defined."]+ Nothing -> Left $ mconcat ["Cannot resolve QName \"", T.unpack name, "\": no default namespace defined."] Just iri -> Right $ iri <> name resolveQName' (PrefixMappings pm) (Just prefix, name) = case Map.lookup prefix pm of- Nothing -> Left $ mconcat ["Cannot resolve QName: prefix \"", T.unpack prefix, "\" not defined"]+ Nothing -> Left $ mconcat ["Cannot resolve QName: prefix \"", T.unpack prefix, "\" not defined"] Just iri -> Right $ iri <> name --- |Parse a qualified name.+-- | Parse a qualified name. ----- See: https://www.w3.org/TR/xml-names/#ns-qualnames+-- See: https://www.w3.org/TR/xml-names/#ns-qualnames parseQName :: Text -> Either String (Maybe Text, Text) parseQName = P.parseOnly $ pQName <* (P.endOfInput <?> "Unexpected characters at the end of a QName") @@ -85,7 +87,8 @@ -- https://www.w3.org/TR/xml-names/#NT-QName pQName :: Parser (Maybe Text, Text) pQName = pPrefixedName <|> pUnprefixedNamed- where pUnprefixedNamed = (empty,) <$> pLocalPart+ where+ pUnprefixedNamed = (empty,) <$> pLocalPart -- https://www.w3.org/TR/xml-names/#NT-PrefixedName pPrefixedName :: Parser (Maybe Text, Text)@@ -104,14 +107,26 @@ where pNameStartChar = P.satisfy isValidFirstCharId pNameRest = P.takeWhile isValidRestCharId- isValidFirstCharId c- = ('A' <= c && c <= 'Z') || c == '_' || ('a' <= c && c <= 'z')- || ('\xC0' <= c && c <= '\xD6') || ('\xD8' <= c && c <= '\xF6')- || ('\xF8' <= c && c <= '\x2FF') || ('\x370' <= c && c <= '\x37D')- || ('\x37F' <= c && c <= '\x1FFF') || ('\x200C' <= c && c <= '\x200D')- || ('\x2070' <= c && c <= '\x218F') || ('\x2C00' <= c && c <= '\x2FEF')- || ('\x3001' <= c && c <= '\xD7FF') || ('\xF900' <= c && c <= '\xFDCF')- || ('\xFDF0' <= c && c <= '\xFFFD') || ('\x10000' <= c && c <= '\xEFFFF')- isValidRestCharId c = isValidFirstCharId c- || c == '-' || c == '.' || ('0' <= c && c <= '9')- || ('\x0300' <= c && c <= '\x036F') || ('\x203F' <= c && c <= '\x2040')+ isValidFirstCharId c =+ isAsciiUpper c+ || c == '_'+ || isAsciiLower c+ || ('\xC0' <= c && c <= '\xD6')+ || ('\xD8' <= c && c <= '\xF6')+ || ('\xF8' <= c && c <= '\x2FF')+ || ('\x370' <= c && c <= '\x37D')+ || ('\x37F' <= c && c <= '\x1FFF')+ || ('\x200C' <= c && c <= '\x200D')+ || ('\x2070' <= c && c <= '\x218F')+ || ('\x2C00' <= c && c <= '\x2FEF')+ || ('\x3001' <= c && c <= '\xD7FF')+ || ('\xF900' <= c && c <= '\xFDCF')+ || ('\xFDF0' <= c && c <= '\xFFFD')+ || ('\x10000' <= c && c <= '\xEFFFF')+ isValidRestCharId c =+ isValidFirstCharId c+ || c == '-'+ || c == '.'+ || isDigit c+ || ('\x0300' <= c && c <= '\x036F')+ || ('\x203F' <= c && c <= '\x2040')
− src/Text/RDF/RDF4H/XmlParser/Xeno.hs
@@ -1,95 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}--{-- Files Xmlbf and Xeno have been taken from:- https://gitlab.com/k0001/xmlbf-- Which is licensed under Apache License 2.0.-- Read the comments in the Xmlbf.hs file for the reason why.--}--module Text.RDF.RDF4H.XmlParser.Xeno- ( fromXenoNode- , fromRawXml- ) where--import qualified Data.Bifunctor as Bif-import qualified Data.ByteString as B-import qualified Data.HashMap.Strict as HM-#if !MIN_VERSION_base(4,13,0)-import Data.Monoid ((<>))-#else-#endif-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TB-import qualified Data.Text.Encoding as T-import Data.Traversable (for)-import qualified HTMLEntities.Decoder-import qualified Xeno.DOM as Xeno-import qualified Text.RDF.RDF4H.XmlParser.Xmlbf as Xmlbf------------------------------------------------------------------------------------- Xeno support---- | Convert a 'Xeno.Node' from "Xeno.DOM" into an 'Element' from "Xmlbf".-fromXenoNode- :: Xeno.Node -- ^ A 'Xeno.Node' from "Xeno.DOM".- -> Either String Xmlbf.Node -- ^ A 'Xmlbf.Node' from "Xmlbf".-fromXenoNode x = do- n <- decodeUtf8 (Xeno.name x)- as <- for (Xeno.attributes x) $ \(k,v) -> do- (,) <$> decodeUtf8 k <*> unescapeXmlUtf8 v- cs <- for (Xeno.contents x) $ \case- Xeno.Element n1 -> fromXenoNode n1- Xeno.Text bs -> Xmlbf.text' =<< unescapeXmlUtf8Lazy bs- Xeno.CData bs -> Xmlbf.text' =<< decodeUtf8Lazy bs- Xmlbf.element' n (HM.fromList as) cs---- | Parses a given UTF8-encoded raw XML fragment into @a@, using the @xeno@--- Haskell library, so all of @xeno@'s parsing quirks apply.------ You can provide the output of this function as input to "Xmlbf"'s--- 'Xmlbf.parse'.------ The given XML can contain more zero or more text or element nodes.------ Surrounding whitespace is not stripped.-fromRawXml- :: B.ByteString -- ^ Raw XML fragment.- -> Either String [Xmlbf.Node] -- ^ 'Xmlbf.Node's from "Xmlbf"-fromRawXml = \bs -> case Xeno.parse ("<x>" <> dropBomUtf8 bs <> "</x>") of- Left e -> Left ("Malformed XML: " ++ show e)- Right n -> fromXenoNode n >>= \case- Xmlbf.Element "x" _ cs -> Right cs- _ -> Left "Unknown result from fromXenoNode. Please report this as a bug."---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Miscellaneous--decodeUtf8 :: B.ByteString -> Either String T.Text-{-# INLINE decodeUtf8 #-}-decodeUtf8 bs = Bif.first show (T.decodeUtf8' bs)--decodeUtf8Lazy :: B.ByteString -> Either String TL.Text-{-# INLINE decodeUtf8Lazy #-}-decodeUtf8Lazy bs = fmap TL.fromStrict (decodeUtf8 bs)--unescapeXmlUtf8 :: B.ByteString -> Either String T.Text-{-# INLINE unescapeXmlUtf8 #-}-unescapeXmlUtf8 bs = fmap TL.toStrict (unescapeXmlUtf8Lazy bs)--unescapeXmlUtf8Lazy :: B.ByteString -> Either String TL.Text-{-# INLINE unescapeXmlUtf8Lazy #-}-unescapeXmlUtf8Lazy bs = do- t <- decodeUtf8 bs- pure (TB.toLazyText (HTMLEntities.Decoder.htmlEncodedText t))--dropBomUtf8 :: B.ByteString -> B.ByteString-{-# INLINE dropBomUtf8 #-}-dropBomUtf8 bs | B.isPrefixOf "\xEF\xBB\xBF" bs = B.drop 3 bs- | otherwise = bs
− src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs
@@ -1,954 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}--{-- Files Xmlbf and Xeno have been taken from:- https://gitlab.com/k0001/xmlbf-- Which is licensed under Apache License 2.0.-- Justification- ~~~~~~~~~~~~~-- The monad transformer in xmlbf introduced by:- https://gitlab.com/k0001/xmlbf/merge_requests/5-- Enabled rdf4h to adopt the xmlbf library in favour of the existing- arrows based XML RDF parser, which failed many of the tests in- the W3C rdf-tests repository.-- It was later decided to remove the monad transformer:- https://gitlab.com/k0001/xmlbf/issues/25-- But this happened before a release was made, so rdf4h could not- depend on any version of xmlbf for this monad transformer.-- Future plans- ~~~~~~~~~~~~-- Ideally, rdf4h should depend on the xmlbf and xmlbf-xeno libraries,- rather than having this file and and the Xeno file in this rdf4h- repository. For that, either:-- 1. the monad transformer should be re-added to xmlbf-- 2. use the StateT transformer on top of xmlbf as suggested in- https://gitlab.com/k0001/xmlbf/issues/25#note_178094971-- This has been tried, but the resulting implementation fails many- rdf-tests W3C tests. See:- https://github.com/robstewart57/rdf4h/tree/statet-rdfxml--}---- | XML back and forth!------ @xmlbf@ provides high-level tools for encoding and decoding XML.------ @xmlbf@ provides tools like 'dfpos' and 'dfposM' for finding a fixpoint--- of an XML fragment.------ @xmlbf@ provides 'FromXml' and 'ToXml' typeclasses intended to be used as the--- familiar 'Data.Aeson.FromJSON' and 'Data.Aeson.ToXml' from the @aeson@--- package.------ @xmlbf@ doesn't do any parsing of raw XML on its own. Instead, one should--- use @xmlbf@ together with libraries like--- [xmlbf-xeno](https://hackage.haskell.org/package/xmlbf-xeno) or--- [xmlbf-xmlhtml](https://hackage.haskell.org/package/xmlbf-xmlhtml) for--- this.-module Text.RDF.RDF4H.XmlParser.Xmlbf {--}- ( -- * Parsing- parse- , parseM- -- ** Low-level- , ParserT- , parserT- , runParserT- , ParserState- , initialParserState-- -- * Parsers- , pElement- , pAnyElement- , pName- , pAttr- , pAttrs- , pChildren- , pText- , pEndOfInput-- -- * Rendering- , encode-- -- * Nodes- , Node- , node-- , pattern Element- , element- , element'-- , pattern Text- , text- , text'-- -- * Fixpoints- , dfpos- , dfposM- , dfpre- , dfpreM-- -- * Typeclasses- , FromXml(fromXml)- , ToXml(toXml)- ) --}- where--import Control.Applicative (Alternative(empty, (<|>)), liftA2)-import Control.DeepSeq (NFData(rnf))-import Control.Monad (MonadPlus(mplus, mzero), join, when, ap)-import qualified Control.Monad.Catch as Ex-import Control.Monad.Error.Class (MonadError(catchError, throwError))-import Control.Monad.Cont (MonadCont(callCC))-import qualified Control.Monad.Fail-import Control.Monad.Fix (MonadFix(mfix))-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Morph (MFunctor(hoist))-import Control.Monad.Reader.Class (MonadReader(local, ask))-import Control.Monad.State.Class (MonadState(state))-import Control.Monad.Trans (MonadTrans(lift))-import Control.Monad.Zip (MonadZip(mzipWith))-import Control.Selective (Selective(select))-import qualified Data.ByteString.Builder as BB-import qualified Data.ByteString.Builder.Prim as BBP-import qualified Data.Char as Char-import Data.Foldable (for_, toList)-import Data.Functor.Identity (Identity(Identity), runIdentity)-import qualified Data.HashMap.Strict as HM-import Data.Kind (Type)-#if MIN_VERSION_base(4,9,0)-#if !MIN_VERSION_base(4,11,0)-import Data.Semigroup-#else-#endif-#else-#endif-import Data.Sequence (Seq)-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import Data.Traversable (for)-import Data.Word (Word8)-------------------------------------------------------------------------------------- | Either a text or an element node in an XML fragment body.------ Construct with 'text' or 'element'. Destruct with 'Text' or 'Element'.-data Node- = Element' !T.Text !(HM.HashMap T.Text T.Text) ![Node]- | Text' !TL.Text- deriving (Eq)--instance NFData Node where- rnf = \case- Element' n as cs -> rnf n `seq` rnf as `seq` rnf cs `seq` ()- Text' t -> rnf t `seq` ()- {-# INLINABLE rnf #-}--instance Show Node where- showsPrec n = \x -> showParen (n > 10) $ case x of- Text' t -> showString "Text " . showsPrec 0 t- Element' t as cs ->- showString "Element " .- showsPrec 0 t . showChar ' ' .- showsPrec 0 (HM.toList as) . showChar ' ' .- showsPrec 0 cs---- | Destruct an element 'Node'.-pattern Element :: T.Text -> HM.HashMap T.Text T.Text -> [Node] -> Node-pattern Element t as cs <- Element' t as cs-#if MIN_VERSION_base(4,10,0)-{-# COMPLETE Element #-} -- TODO this leads to silly pattern matching warnings-#endif- --- | Destruct a text 'Node'.-pattern Text :: TL.Text -> Node-pattern Text t <- Text' t-#if MIN_VERSION_base(4,10,0)-{-# COMPLETE Text #-} -- TODO this leads to silly pattern matching warnings-#endif- --- | Case analysis for a 'Node'.-node- :: (T.Text -> HM.HashMap T.Text T.Text -> [Node] -> a)- -- ^ Transform an 'Element' node.- -> (TL.Text -> a)- -- ^ Transform a 'Text' node.- -> Node- -> a-{-# INLINE node #-}-node fe ft = \case- Text' t -> ft t- Element' t as cs -> fe t as cs---- | Normalizes 'Node's by concatenating consecutive 'Text' nodes.-normalize :: [Node] -> [Node]-{-# INLINE normalize #-}-normalize = \case- -- Note that @'Text' ""@ is forbidden by construction, actually. But we do- -- take care of it in case the 'Node' was constructed unsafely somehow.- Text' "" : ns -> normalize ns- Text' a : Text' b : ns -> normalize (text (a <> b) <> ns)- Text' a : ns -> Text' a : normalize ns- Element' t as cs : ns -> Element' t as (normalize cs) : normalize ns- [] -> []---- | Construct a XML fragment body containing a single 'Text' 'Node', if--- possible.------ This function will return empty list if it is not possible to construct the--- 'Text' with the given input. To learn more about /why/ it was not possible to--- construct it, use 'text'' instead.------ Using 'text'' rather than 'text' is recommended, so that you are forced to--- acknowledge a failing situation in case it happens. However, 'text' is at--- times more convenient to use. For example, when you know statically the input--- is valid.-text- :: TL.Text -- ^ Lazy 'TL.Text'.- -> [Node]-{-# INLINE text #-}-text t = case text' t of- Right x -> [x]- Left _ -> []---- | Construct a 'Text' 'Node', if possible.------ Returns 'Left' if the 'Text' 'Node' can't be created, with an explanation--- of why.-text'- :: TL.Text -- ^ Lazy 'TL.Text'.- -> Either String Node-{-# INLINE text' #-}-text' = \case- "" -> Left "Empty text"- t -> Right (Text' t)---- | Construct a XML fragment body containing a single 'Element' 'Node', if--- possible.------ This function will return empty list if it is not possible to construct the--- 'Element' with the given input. To learn more about /why/ it was not possible--- to construct it, use 'element' instead.------ Using 'element'' rather than 'element' is recommended, so that you are forced--- to acknowledge a failing situation in case it happens. However, 'element' is--- at times more convenient to use, whenever you know the input is valid.-element- :: T.Text -- ^ Element' name as a strict 'T.Text'.- -> HM.HashMap T.Text T.Text -- ^ Attributes as strict 'T.Text' pairs.- -> [Node] -- ^ Children.- -> [Node]-{-# INLINE element #-}-element t hm ns = case element' t hm ns of- Right x -> [x]- Left _ -> []---- | Construct an 'Element' 'Node'.------ Returns 'Left' if the 'Element' 'Node' can't be created, with an explanation--- of why.-element'- :: T.Text -- ^ Element' name as a strict 'T.Text'.- -> HM.HashMap T.Text T.Text -- ^ Attributes as strict 'T.Text' pairs.- -> [Node] -- ^ Children.- -> Either String Node-element' t0 hm0 ns0 = do- when (t0 /= T.strip t0)- (Left ("Element name has surrounding whitespace: " ++ show t0))- when (T.null t0)- (Left ("Element name is blank: " ++ show t0))- for_ (HM.keys hm0) $ \k -> do- when (k /= T.strip k)- (Left ("Attribute name has surrounding whitespace: " ++ show k))- when (T.null k)- (Left ("Attribute name is blank: " ++ show k))- Right (Element' t0 hm0 (normalize ns0))---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Parsing--class FromXml a where- -- | Parses an XML fragment body into a value of type @a@.- --- -- If a 'ToXml' instance for @a@ exists, then:- --- -- @- -- 'parseM' 'fromXml' ('toXml' a) == pure ('Right' a)- -- @- fromXml :: ParserT m a---- | Internal parser state.-data ParserState- = STop ![Node]- -- ^ Parsing the top-level nodes.- | SReg !T.Text !(HM.HashMap T.Text T.Text) ![Node]- -- ^ Parsing a particular root element.---- | Construct an initial 'ParserState' to use with 'runParserT' from zero or--- more top-level 'Node's.-initialParserState :: [Node] -> ParserState-initialParserState = STop . normalize-{-# INLINE initialParserState #-}---- | XML parser for a value of type @a@.------ This parser runs on top of some 'Monad' @m@,--- making 'ParserT' a suitable monad transformer.------ You can build a 'ParserT' using 'pElement', 'pAnyElement', 'pName',--- 'pAttr', 'pAttrs', 'pChildren', 'pText', 'pEndOfInput', any of the--- 'Applicative', 'Alternative' or 'Monad' combinators, or you can--- use 'parserT' directly.------ Run a 'ParserT' using 'parse', 'parseM' or 'runParserT'-newtype ParserT (m :: Type -> Type) (a :: Type)- = ParserT (ParserState -> m (ParserState, Either String a))---- | 'parserT' is the most general way or building a 'ParserT'.-parserT- :: (ParserState -> m (ParserState, Either String a))- -- ^ Given a parser's internal state, obtain an @a@ if possible, otherwise- -- return a 'String' describing the parsing failure. A new state with- -- leftovers is returned.- -> ParserT m a-parserT = ParserT-{-# INLINE parserT #-}---- | 'runParserT' is the most general way or running a 'ParserT'.-runParserT- :: ParserT m a- -- ^ Parser to run.- -> ParserState- -- ^ Initial parser state. You can obtain this from- -- 'initialParserState' or from a previous execution of 'runParserT'.- -> m (ParserState, Either String a)- -- ^ Returns the leftover parser state, as well as an @a@ in case parsing was- -- successful, or a 'String' with an error message otherwise.-runParserT (ParserT f) = f-{-# INLINE runParserT #-}---- | Run a 'ParserT' on an XML fragment body.------ Notice that this function doesn't enforce that all input is consumed. If you--- want that behavior, then please use 'pEndOfInput' in the given 'ParserT'.------ As a simpler alternative to 'runParserT', consider using 'parse' if you don't--- need transformer functionality. 'parseM' is implemented on top of the more--- general 'runParserT'.-parseM- :: Applicative m- => ParserT m a- -- ^ Parser to run.- -> [Node]- -- ^ XML fragment body to parse. That is, top-level XML 'Node's.- -> m (Either String a)- -- ^ If parsing fails, a 'String' with an error message is returned.- -- Otherwise, we the parser output @a@ is returned.-parseM p = fmap snd . runParserT p . initialParserState-{-# INLINE parseM #-}---- | Pure version of 'parseM' running on top of 'Identity'.-parse- :: ParserT Identity a- -- ^ Parser to run.- -> [Node]- -- ^ XML fragment body to parse. That is, top-level XML 'Node's.- -> Either String a- -- ^ If parsing fails, a 'String' with an error message is returned.- -- Otherwise, we the parser output @a@ is returned.-parse p = runIdentity . parseM p-{-# INLINE parse #-}--#if MIN_VERSION_base(4,9,0)-instance (Monad m, Semigroup a) => Semigroup (ParserT m a) where- (<>) = liftA2 (<>)- {-# INLINE (<>) #-}-#endif--#if MIN_VERSION_base(4,9,0)-instance (Monad m, Monoid a, Semigroup a) => Monoid (ParserT m a) where-#else-instance (Monad m, Monoid a) => Monoid (ParserT m a) where-#endif- mempty = pure mempty- {-# INLINE mempty #-}-#if MIN_VERSION_base(4,9,0)- mappend = (<>)-#else- mappend = liftA2 mappend-#endif- {-# INLINE mappend #-}--instance Functor m => Functor (ParserT m) where- fmap f = \pa -> ParserT (\s -> fmap (fmap (fmap f)) (runParserT pa s))- {-# INLINE fmap #-}---- | The 'Monad' superclass is necessary because 'ParserT' shortcircuits like--- 'Control.Monad.Trans.Except.ExceptT'.-instance Monad m => Applicative (ParserT m) where- pure = \a -> ParserT (\s -> pure (s, Right a))- {-# INLINE pure #-}- (<*>) = ap- {-# INLINE (<*>) #-}---- | @ma '<|>' mb@ backtracks the internal parser state before running @mb@.-instance Monad m => Alternative (ParserT m) where- empty = pFail "empty"- {-# INLINE empty #-}- pa <|> pb = ParserT (\s0 -> do- (s1, ea) <- runParserT pa s0- case ea of- Right a -> pure (s1, Right a)- Left _ -> runParserT pb s0)- {-# INLINABLE (<|>) #-}--instance Monad m => Selective (ParserT m) where- select pe pf = ParserT (\s0 -> do- (s1, eeab) <- runParserT pe s0- case eeab of- Right (Right b) -> pure (s1, Right b)- Right (Left a) -> runParserT (pf <*> pure a) s1- Left msg -> pure (s1, Left msg))- {-# INLINABLE select #-}--instance Monad m => Monad (ParserT m) where- return = pure- {-# INLINE return #-}- pa >>= kpb = ParserT (\s0 -> do- (s1, ea) <- runParserT pa s0- case ea of- Right a -> runParserT (kpb a) s1- Left msg -> pure (s1, Left msg))- {-# INLINABLE (>>=) #-}-#if !MIN_VERSION_base(4,13,0)- fail = pFail- {-# INLINE fail #-}-#endif--#if MIN_VERSION_base(4,9,0)-instance Monad m => Control.Monad.Fail.MonadFail (ParserT m) where- fail = pFail- {-# INLINE fail #-}-#endif---- | A 'ParserT' that always fails with the given error message.-pFail :: Applicative m => String -> ParserT m a-pFail = \msg -> ParserT (\s -> pure (s, Left msg))-{-# INLINE pFail #-}---- | @'mzero' ma mb@ backtracks the internal parser state before running @mb@.-instance Monad m => MonadPlus (ParserT m) where- mzero = empty- {-# INLINE mzero #-}- mplus = (<|>)- {-# INLINE mplus #-}--instance MonadFix m => MonadFix (ParserT m) where- mfix f =- let die = \msg -> error ("mfix (ParserT): " <> msg)- in ParserT (\s0 ->- mfix (\ ~(_s1, ea) -> runParserT (f (either die id ea)) s0))--instance MonadZip m => MonadZip (ParserT m) where- mzipWith f pa pb = ParserT (\s0 -> do- (s1, ea) <- runParserT pa s0- case ea of- Right a0 ->- mzipWith (\a1 (s2, eb) -> (s2, fmap (f a1) eb))- (pure a0) (runParserT pb s1)- Left msg -> pure (s1, Left msg))- {-# INLINABLE mzipWith #-}--instance MonadTrans ParserT where- lift = \ma -> ParserT (\s -> ma >>= \a -> pure (s, Right a))- {-# INLINE lift #-}--instance MFunctor ParserT where- hoist nat = \p -> ParserT (\s -> nat (runParserT p s))- {-# INLINE hoist #-}--instance MonadIO m => MonadIO (ParserT m) where- liftIO = lift . liftIO- {-# INLINE liftIO #-}--instance MonadReader r m => MonadReader r (ParserT m) where- ask = lift ask- {-# INLINE ask #-}- local f = \p -> ParserT (\s -> local f (runParserT p s))- {-# INLINE local #-}--instance MonadState s m => MonadState s (ParserT m) where- state = lift . state- {-# INLINE state #-}--instance MonadError e m => MonadError e (ParserT m) where- throwError = lift . throwError- {-# INLINABLE throwError #-}- catchError ma h = ParserT (\s ->- catchError (runParserT ma s)- (\e -> runParserT (h e) s))- {-# INLINABLE catchError #-}--instance Ex.MonadThrow m => Ex.MonadThrow (ParserT m) where- throwM = lift . Ex.throwM- {-# INLINABLE throwM #-}--instance Ex.MonadCatch m => Ex.MonadCatch (ParserT m) where- catch ma h = ParserT (\s ->- Ex.catch (runParserT ma s)- (\e -> runParserT (h e) s))- {-# INLINABLE catch #-}--instance Ex.MonadMask m => Ex.MonadMask (ParserT m) where- mask f = ParserT (\s ->- Ex.mask (\u ->- runParserT (f (\p -> ParserT (u . runParserT p))) s))- {-# INLINABLE mask #-}- uninterruptibleMask f = ParserT (\s ->- Ex.uninterruptibleMask (\u ->- runParserT (f (\p -> ParserT (u . runParserT p))) s))- {-# INLINABLE uninterruptibleMask #-}- generalBracket acq rel use = ParserT (\s0 -> do- ((_sb,eb), (sc,ec)) <- Ex.generalBracket- (runParserT acq s0)- (\(s1, ea) ec -> case ea of- Right a -> case ec of- Ex.ExitCaseSuccess (s2, Right b) ->- runParserT (rel a (Ex.ExitCaseSuccess b)) s2- Ex.ExitCaseSuccess (s2, Left msg) ->- -- Result of using mzero or similar on release- pure (s2, Left msg)- Ex.ExitCaseException e ->- runParserT (rel a (Ex.ExitCaseException e)) s1- Ex.ExitCaseAbort ->- runParserT (rel a Ex.ExitCaseAbort) s1- Left msg ->- -- acq failed, nothing to release- pure (s1, Left msg))- (\(s1, ea) -> case ea of- Right a -> runParserT (use a) s1- Left msg ->- -- acq failed, nothing to use- pure (s1, Left msg))- -- We run ec first because its error message, if any, has priority- pure (sc, flip (,) <$> ec <*> eb))---- | This version uses the current state on entering the continuation. See--- 'liftCallCC''. It does not satisfy the uniformity property (see--- 'Control.Monad.Signatures.CallCC').-instance MonadCont m => MonadCont (ParserT m) where- callCC f = ParserT (\s0 ->- callCC (\c -> runParserT (f (\a -> ParserT (\s1 -> c (s1, Right a)))) s0))------------------------------------------------------------------------------------- Some parsers---- | @'pElement' "foo" p@ runs a 'ParserT' @p@ inside a 'Element' node named--- @"foo"@. This parser __fails__ if such element does not exist at the current--- position.------ Leading whitespace is ignored. If you need to preserve that whitespace for--- some reason, capture it using 'pText' before using 'pElement'.------ __Consumes the matched element__ from the parser state.-pElement- :: Monad m- => T.Text -- ^ Element name as strict 'T.Text'.- -> ParserT m a -- ^ 'ParserT' to run /inside/ the matched 'Element'.- -> ParserT m a-pElement t0 p0 = ParserT $ \case- SReg t1 as0 (Element' t as cs : cs0) | t == t0 ->- runParserT p0 (SReg t as cs) >>= \case- (_, Right a) -> pure (SReg t1 as0 cs0, Right a)- (s1, Left msg) -> pure (s1, Left msg)- STop (Element' t as cs : cs0) | t == t0 ->- runParserT p0 (SReg t as cs) >>= \case- (_, Right a) -> pure (STop cs0, Right a)- (s1, Left msg) -> pure (s1, Left msg)- -- skip leading whitespace- SReg t as (Text' x : cs) | TL.all Char.isSpace x ->- runParserT (pElement t0 p0) (SReg t as cs)- STop (Text' x : cs) | TL.all Char.isSpace x ->- runParserT (pElement t0 p0) (STop cs)- s0 -> pure (s0, Left ("Missing element " <> show t0))-{-# INLINABLE pElement #-}---- | @'pAnyElement' p@ runs a 'ParserT' @p@ inside the 'Element' node at the--- current position, if any. Otherwise, if no such element exists, this parser--- __fails__.------ You can recover the name of the matched element using 'pName' inside the--- given 'ParserT'. However, if you already know beforehand the name of the--- element that you want to match, it's better to use 'pElement' rather than--- 'pAnyElement'.------ Leading whitespace is ignored. If you need to preserve that whitespace for--- some reason, capture it using 'pText' before using 'pAnyElement'.------ __Consumes the matched element__ from the parser state.-pAnyElement- :: Monad m- => ParserT m a -- ^ 'ParserT' to run /inside/ any matched 'Element'.- -> ParserT m a-pAnyElement p0 = ParserT $ \case- SReg t0 as0 (Element' t as cs : cs0) ->- runParserT p0 (SReg t as cs) >>= \case- (_, Right a) -> pure (SReg t0 as0 cs0, Right a)- (s1, Left msg) -> pure (s1, Left msg)- STop (Element' t as cs : cs0) ->- runParserT p0 (SReg t as cs) >>= \case- (_, Right a) -> pure (STop cs0, Right a)- (s1, Left msg) -> pure (s1, Left msg)- -- skip leading whitespace- SReg t as (Text' x : cs) | TL.all Char.isSpace x ->- runParserT (pAnyElement p0) (SReg t as cs)- STop (Text' x : cs) | TL.all Char.isSpace x ->- runParserT (pAnyElement p0) (STop cs)- s0 -> pure (s0, Left "Missing element")-{-# INLINABLE pAnyElement #-}---- | Returns the name of the currently selected 'Element'.------ This parser __fails__ if there's no currently selected 'Element' (see--- 'pElement', 'pAnyElement').------ Doesn't modify the parser state.-pName- :: Applicative m- => ParserT m T.Text -- ^ Element name as strict 'T.Text'.-pName = ParserT (\s -> case s of- SReg t _ _ -> pure (s, Right t)- _ -> pure (s, Left "Before selecting an name, you must select an element"))-{-# INLINABLE pName #-}---- | Return the value of the requested attribute, if defined. Returns an--- 'T.empty' 'T.Text' in case the attribute is defined but no value was given to--- it.------ This parser __fails__ if there's no currently selected 'Element' (see--- 'pElement', 'pAnyElement').------ __Consumes the matched attribute__ from the parser state.-pAttr- :: Applicative m- => T.Text- -- ^ Attribute name as strict 'T.Text'.- -> ParserT m T.Text- -- ^ Attribute value as strict 'T.Text', possibly 'T.empty'.-pAttr n = ParserT (\s -> case s of- SReg t as cs -> case HM.lookup n as of- Just x -> pure (SReg t (HM.delete n as) cs, Right x)- Nothing -> pure (s, Left ("Missing attribute " <> show n))- _ -> pure (s, Left "Before selecting an attribute, you must select an element"))-{-# INLINABLE pAttr #-}---- | Returns all of the available element attributes.------ Returns 'T.empty' 'T.Text' as values in case an attribute is defined but no--- value was given to it.------ This parser __fails__ if there's no currently selected 'Element' (see--- 'pElement', 'pAnyElement').------ __Consumes all the attributes__ for this element from the parser state.-pAttrs- :: Applicative m- => ParserT m (HM.HashMap T.Text T.Text)- -- ^ Pairs of attribute names and possibly 'T.empty' values, as strict- -- 'T.Text'.-pAttrs = ParserT (\s -> case s of- SReg t as cs -> pure (SReg t mempty cs, Right as)- _ -> pure (s, Left "Before selecting an attribute, you must select an element"))-{-# INLINABLE pAttrs #-}---- | Returns all of the immediate children of the current element.------ If parsing top-level nodes rather than a particular element (that is, if--- 'pChildren' is /not/ being run inside 'pElement'), then all of the top level--- 'Node's will be returned.------ __Consumes all the returned nodes__ from the parser state.-pChildren- :: Applicative m- => ParserT m [Node] -- ^ 'Node's in their original order.-pChildren = ParserT (\case- STop cs -> pure (STop mempty, Right cs)- SReg t as cs -> pure (SReg t as mempty, Right cs))-{-# INLINABLE pChildren #-}---- | Returns the contents of a 'Text' node.------ Surrounidng whitespace is not removed, as it is considered to be part of the--- text node.------ If there is no text node at the current position, then this parser __fails__.--- This implies that 'pText' /never/ returns an empty 'TL.Text', since there is--- no such thing as a text node without text.------ Please note that consecutive text nodes are always concatenated and returned--- together.------ @--- 'parseT' 'pText' ('text' \"Ha\" <> 'text' \"sk\" <> 'text' \"ell\")--- == 'pure' ('Right' ('text' "Haskell"))--- @------ __Consumes the text__ from the parser state. This implies that if you--- perform two consecutive 'pText' calls, the second will always fail.------ @--- 'parseT' ('pText' >> 'pText') ('text' \"Ha\" <> 'text' \"sk\" <> 'text' \"ell\")--- == 'pure' ('Left' "Missing text node")--- @-pText- :: Applicative m- => ParserT m TL.Text- -- ^ Content of the text node as a lazy 'TL.Text'.-pText = ParserT (\case- -- Note: this works only because we asume 'normalize' has been used.- STop (Text x : ns) -> pure (STop ns, Right x)- SReg t as (Text x : cs) -> pure (SReg t as cs, Right x)- s0 -> pure (s0, Left "Missing text node"))-{-# INLINABLE pText #-}---- | Succeeds if all of the elements, attributes and text nodes have--- been consumed.-pEndOfInput :: Applicative m => ParserT m ()-pEndOfInput = ParserT (\s -> case isEof s of- True -> pure (s, Right ())- False -> pure (s, Left "Not end of input yet"))-{-# INLINABLE pEndOfInput #-}--isEof :: ParserState -> Bool-isEof = \case- SReg _ as cs -> HM.null as && null cs- STop ns -> null ns-{-# INLINE isEof #-}------------------------------------------------------------------------------------- Rendering--class ToXml a where- -- | Renders a value of type @a@ into an XML fragment body.- --- -- If a 'FromXml' instance for @a@ exists, then:- --- -- @- -- 'parseM' 'fromXml' ('toXml' a) == 'pure' ('Right' a)- -- @- toXml :: a -> [Node]---- | Encodes a list of XML 'Node's, representing an XML fragment body, to an--- UTF8-encoded and XML-escaped bytestring.------ This function doesn't render self-closing elements. Instead, all--- elements have a corresponding closing tag.------ Also, it doesn't render CDATA sections. Instead, all text is escaped as--- necessary.-encode :: [Node] -> BB.Builder-encode xs = mconcat (map encodeNode xs)- where- encodeNode :: Node -> BB.Builder- encodeNode = \case- Text x -> encodeXmlUtf8Lazy x- Element t as cs ->- -- This ugly code is so that we make sure we always bind concatenation- -- to the right with as little effort as possible, using (<>).- "<" <> encodeUtf8 t- <> encodeAttrs (">" <> encode cs <> "</" <> encodeUtf8 t <> ">") as- {-# INLINE encodeNode #-}- encodeAttrs :: BB.Builder -> HM.HashMap T.Text T.Text -> BB.Builder- encodeAttrs = HM.foldlWithKey'- (\o k v -> " " <> encodeUtf8 k <> "=\"" <> encodeXmlUtf8 v <> "\"" <> o)- {-# INLINE encodeAttrs #-}---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Node fixpoint---- | Post-order depth-first replacement of 'Node' and all of its children.------ This function works like 'Data.Function.fix', but the given function is--- trying to find a fixpoint for the individual children nodes, not for the root--- node.------ For example, the following function renames every node named @"w"@ to @"y"@,--- and every node named @"y"@ to @"z"@. It accomplishes this by first renaming--- @"w"@ nodes to @"x"@, and then, by using @k@ recursively to further rename--- all @"x"@ nodes (including the ones that were just created) to @"y"@ in a--- post-order depth-first manner. After renaming an @"x"@ node to @"y"@, the--- recursion stops (i.e., @k@ is not used), so our new @"y"@ nodes won't be--- further renamed to @"z"@. However, nodes that were named @"y"@ initially will--- be renamed to @"z"@.------ In our example we only replace one node with another, but a node can be--- replaced with zero or more nodes, depending on the length of the resulting--- list.------ @--- foo :: 'Node' -> ['Node']--- foo = 'dfpos' $ \\k -> \\case--- 'Element' "w" as cs -> 'element' "x" as cs >>= k--- 'Element' "x" as cs -> 'element' "y" as cs--- 'Element' "y" as cs -> 'element' "z" as cs >>= k--- @------ See 'dfpre' for pre-orderd depth-first replacement.------ /WARNING/ If you call @k@ in every branch, then 'dfpos' will never terminate.--- Make sure the recursion stops at some point by simply returning a list of--- nodes instead of calling @k@.-dfpos :: ((Node -> [Node]) -> Node -> [Node]) -> Node -> [Node]-dfpos f = runIdentity . dfposM (\k -> Identity . f (runIdentity . k))---- | Monadic version of 'dfpos'.-dfposM :: Monad m => ((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]-dfposM f = \n0 -> do- c1 <- traverseChildren (dfposM f) (cursorFromNode n0)- c2 <- traverseRightSiblings (dfposM f) c1- fmap (normalize . join)- (traverse (f (dfposM f)) (cursorSiblings c2))----- | Pre-order depth-first replacement of 'Node' and all of its children.------ This is just like 'dfpos' but the search proceeds in a different order.-dfpre :: ((Node -> [Node]) -> Node -> [Node]) -> Node -> [Node]-dfpre f = runIdentity . dfpreM (\k -> Identity . f (runIdentity . k))---- | Monadic version of 'dfpre'.-dfpreM :: Monad m => ((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]-dfpreM f = \n0 -> do- ns <- f (dfpreM f) n0- fmap (normalize . join) $ for ns $ \n -> do- c1 <- traverseChildren (dfpreM f) (cursorFromNode n)- cursorSiblings <$> traverseRightSiblings (dfpreM f) c1----------------------------------------------------------------------------------------------------------------------------------------------------------------------- INTERNAL: Cursor------ Most of this comes from Chris Smith's xmlhtml, BSD3 licensed--- https://hackage.haskell.org/package/xmlhtml---- | Zipper into a 'Node' tree.-data Cursor = Cursor- { _cursorCurrent :: !Node- -- ^ Retrieves the current node of a 'Cursor'.- , _cursorLefts :: !(Seq Node)- -- ^ Nodes to the left (ordered right to left).- , _cursorRights :: !(Seq Node)- -- ^ Nodes to the right (ordered left to right).- , _cursorParents :: !(Seq (Seq Node, T.Text, HM.HashMap T.Text T.Text, Seq Node))- -- ^ Parents' name, attributes, and siblings.- }------------------------------------------------------------------------------------ | The cursor if left where it starts.-traverseChildren :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor-{-# INLINABLE traverseChildren #-}-traverseChildren f c0 = case _cursorCurrent c0 of- Text _ -> pure c0- Element t as cs -> do- n1s <- fmap (normalize . join) (traverse f cs)- pure (c0 {_cursorCurrent = Element' t as n1s})---- | The cursor if left in the rightmost sibling.-traverseRightSiblings :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor-{-# INLINABLE traverseRightSiblings #-}-traverseRightSiblings f c0 = case cursorRemoveRight c0 of- Nothing -> pure c0- Just (n1, c1) -> do- n2s <- fmap normalize (f n1)- traverseRightSiblings f (cursorInsertManyRight n2s c1)---- | Builds a 'Cursor' for navigating a tree. That is, a forest with a single--- root 'Node'.-cursorFromNode :: Node -> Cursor-{-# INLINE cursorFromNode #-}-cursorFromNode n = Cursor n mempty mempty mempty---- | Retrieves a list of the 'Node's at the same level as the current position--- of a cursor, including the current node.-cursorSiblings :: Cursor -> [Node]-{-# INLINE cursorSiblings #-}-cursorSiblings (Cursor cur ls rs _) =- toList (Seq.reverse ls <> (cur Seq.<| rs))---- | Removes the node to the right and return it.-cursorRemoveRight :: Cursor -> Maybe (Node, Cursor)-{-# INLINABLE cursorRemoveRight #-}-cursorRemoveRight = \case- Cursor n ls rs0 ps | not (Seq.null rs0) ->- case Seq.viewl rs0 of- r Seq.:< rs -> Just (r, Cursor n ls rs ps)- _ -> undefined -- unreachable, rs0 is not empty- _ -> Nothing---- | Inserts a list of new 'Node's to the right of the current position.-cursorInsertManyRight :: [Node] -> Cursor -> Cursor-{-# INLINE cursorInsertManyRight #-}-cursorInsertManyRight ns (Cursor nn ls rs ps) =- Cursor nn ls (Seq.fromList ns <> rs) ps---------------------------------------------------------------------------------------------------------------------------------------------------------------------- Miscellaneous--encodeUtf8 :: T.Text -> BB.Builder-{-# INLINE encodeUtf8 #-}-encodeUtf8 = T.encodeUtf8Builder--encodeXmlUtf8 :: T.Text -> BB.Builder-{-# INLINE encodeXmlUtf8 #-}-encodeXmlUtf8 = T.encodeUtf8BuilderEscaped xmlEscaped--encodeXmlUtf8Lazy :: TL.Text -> BB.Builder-{-# INLINE encodeXmlUtf8Lazy #-}-encodeXmlUtf8Lazy = TL.encodeUtf8BuilderEscaped xmlEscaped--xmlEscaped :: BBP.BoundedPrim Word8-{-# INLINE xmlEscaped #-}-xmlEscaped =- BBP.condB (== 38) (fixed5 (38,(97,(109,(112,59))))) $ -- '&' -> "&"- BBP.condB (== 60) (fixed4 (38,(108,(116,59)))) $ -- '<' -> "<"- BBP.condB (== 62) (fixed4 (38,(103,(116,59)))) $ -- '>' -> ">"- BBP.condB (== 34) (fixed5 (38,(35,(51,(52,59))))) $ -- '"' -> """- BBP.liftFixedToBounded BBP.word8- where- {-# INLINE fixed4 #-}- fixed4 :: (Word8, (Word8, (Word8, Word8))) -> BBP.BoundedPrim Word8- fixed4 x = BBP.liftFixedToBounded- (const x BBP.>$< BBP.word8 BBP.>*< BBP.word8- BBP.>*< BBP.word8 BBP.>*< BBP.word8)- {-# INLINE fixed5 #-}- fixed5 :: (Word8, (Word8, (Word8, (Word8, Word8)))) -> BBP.BoundedPrim Word8- fixed5 x = BBP.liftFixedToBounded- (const x BBP.>$< BBP.word8 BBP.>*< BBP.word8- BBP.>*< BBP.word8 BBP.>*< BBP.word8 BBP.>*< BBP.word8)
testsuite/tests/Data/RDF/PropertyTests.hs view
@@ -1,81 +1,80 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-} module Data.RDF.PropertyTests (graphTests) where -import qualified Data.Text.IO as T+import Control.Exception (bracket)+import Control.Monad+import Data.List+import qualified Data.Map as Map import Data.RDF hiding (empty) import Data.RDF.Namespace hiding (rdf)-import qualified Data.Text as T-import Test.QuickCheck-import Data.List-import Data.Semigroup ((<>)) import qualified Data.Set as Set-import qualified Data.Map as Map-import Control.Monad-import Control.Exception (bracket)+import qualified Data.Text as T+import qualified Data.Text.IO as T import GHC.Generics () import System.Directory (removeFile) import System.IO-+import Test.QuickCheck+import Test.QuickCheck.Monadic (assert, monadicIO, run) import Test.Tasty import Test.Tasty.QuickCheck-import Test.QuickCheck.Monadic (assert, monadicIO,run) ---------------------------------------------------- -- property based quick check test cases -- ---------------------------------------------------- -graphTests- :: (Rdf rdf)- => TestName- -> RDF rdf -- ^ empty- -> (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) -- ^ _mkRdf- -> TestTree+graphTests ::+ (Rdf rdf) =>+ TestName ->+ -- | empty+ RDF rdf ->+ -- | _mkRdf+ (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) ->+ TestTree graphTests testGroupName empty _mkRdf = testGroup testGroupName- [ testProperty "empty" (p_empty empty)- , testProperty "mkRdf_triplesOf" (p_mkRdf_triplesOf _mkRdf)- , testProperty "mkRdf_no_dupes" (p_mkRdf_no_dupes _mkRdf)- , testProperty "query_match_none" (p_query_match_none _mkRdf)+ [ testProperty "empty" (p_empty empty),+ testProperty "mkRdf_triplesOf" (p_mkRdf_triplesOf _mkRdf),+ testProperty "mkRdf_no_dupes" (p_mkRdf_no_dupes _mkRdf),+ testProperty "query_match_none" (p_query_match_none _mkRdf), -- see comment above p_query_matched_spo_no_dupes for why this is disabled -- , testProperty "query_matched_spo_no_dupes" (p_query_matched_spo_no_dupes _triplesOf _mkRdf)- , testProperty "query_match_s" (p_query_match_s empty)- , testProperty "query_match_p" (p_query_match_p empty)- , testProperty "query_match_o" (p_query_match_o empty)- , testProperty "query_match_sp" (p_query_match_sp empty)- , testProperty "query_match_so" (p_query_match_so empty)- , testProperty "query_match_po" (p_query_match_po empty)- , testProperty "query_match_spo" (p_query_match_spo empty)- , testProperty "query_unmatched_spo" (p_query_unmatched_spo empty)- , testProperty "select_match_none" (p_select_match_none empty)- , testProperty "select_match_s" (p_select_match_s empty)- , testProperty "select_match_p" (p_select_match_p empty)- , testProperty "select_match_o" (p_select_match_o empty)- , testProperty "select_match_sp" (p_select_match_sp empty)- , testProperty "select_match_so" (p_select_match_so empty)- , testProperty "select_match_po" (p_select_match_po empty)- , testProperty "select_match_spo" (p_select_match_spo empty)- , testProperty "reversed RDF handle write" (p_reverseRdfTest _mkRdf)+ testProperty "query_match_s" (p_query_match_s empty),+ testProperty "query_match_p" (p_query_match_p empty),+ testProperty "query_match_o" (p_query_match_o empty),+ testProperty "query_match_sp" (p_query_match_sp empty),+ testProperty "query_match_so" (p_query_match_so empty),+ testProperty "query_match_po" (p_query_match_po empty),+ testProperty "query_match_spo" (p_query_match_spo empty),+ testProperty "query_unmatched_spo" (p_query_unmatched_spo empty),+ testProperty "select_match_none" (p_select_match_none empty),+ testProperty "select_match_s" (p_select_match_s empty),+ testProperty "select_match_p" (p_select_match_p empty),+ testProperty "select_match_o" (p_select_match_o empty),+ testProperty "select_match_sp" (p_select_match_sp empty),+ testProperty "select_match_so" (p_select_match_so empty),+ testProperty "select_match_po" (p_select_match_po empty),+ testProperty "select_match_spo" (p_select_match_spo empty),+ testProperty "reversed RDF handle write" (p_reverseRdfTest _mkRdf), -- adding and removing triples from a graph.- , testProperty "add_triple" (p_add_triple _mkRdf)- , testProperty "remove_triple" (p_remove_triple _mkRdf)- , testProperty+ testProperty "add_triple" (p_add_triple _mkRdf),+ testProperty "remove_triple" (p_remove_triple _mkRdf),+ testProperty "remove_triple_from_graph"- (p_remove_triple_from_graph _mkRdf)- , testProperty+ (p_remove_triple_from_graph _mkRdf),+ testProperty "remove_triple_from_singleton_graph_query_s"- (p_remove_triple_from_singleton_graph_query_s empty)- , testProperty+ (p_remove_triple_from_singleton_graph_query_s empty),+ testProperty "remove_triple_from_singleton_graph_query_p"- (p_remove_triple_from_singleton_graph_query_p empty)- , testProperty+ (p_remove_triple_from_singleton_graph_query_p empty),+ testProperty "remove_triple_from_singleton_graph_query_o"- (p_remove_triple_from_singleton_graph_query_o empty)- , testProperty+ (p_remove_triple_from_singleton_graph_query_o empty),+ testProperty "p_add_then_remove_triples" (p_add_then_remove_triples empty) ]@@ -84,8 +83,10 @@ { rdfGraph :: (RDF rdf) } -instance (Rdf rdf) =>- Arbitrary (SingletonGraph rdf) where+instance+ (Rdf rdf) =>+ Arbitrary (SingletonGraph rdf)+ where arbitrary = do pref <- arbitraryPrefixMappings baseU' <- arbitraryBaseUrl@@ -93,8 +94,10 @@ t <- liftM3 triple arbitraryS arbitraryP arbitraryO return SingletonGraph {rdfGraph = (mkRdf [t] baseU pref)} -instance (Rdf rdf) =>- Show (SingletonGraph rdf) where+instance+ (Rdf rdf) =>+ Show (SingletonGraph rdf)+ where show singletonGraph = showGraph (rdfGraph singletonGraph) instance Arbitrary BaseUrl where@@ -106,54 +109,54 @@ arbitraryBaseUrl :: Gen BaseUrl arbitraryBaseUrl = oneof $- fmap- (return . BaseUrl . T.pack)- ["http://example.org/", "http://example.com/a", "http://asdf.org/b", "http://asdf.org/c"]+ fmap+ (return . BaseUrl . T.pack)+ ["http://example.org/", "http://example.com/a", "http://asdf.org/b", "http://asdf.org/c"] arbitraryPrefixMappings :: Gen PrefixMappings arbitraryPrefixMappings = oneof- [ return $ PrefixMappings Map.empty- , return $- PrefixMappings $- Map.fromAscList- [ (T.pack "ex", T.pack "ex:")- , (T.pack "eg1", T.pack "http://example.org/1")- , (T.pack "eg2", T.pack "http://example.org/2")- , (T.pack "eg3", T.pack "http://example.org/3")- ]+ [ return $ PrefixMappings Map.empty,+ return $+ PrefixMappings $+ Map.fromAscList+ [ (T.pack "ex", T.pack "ex:"),+ (T.pack "eg1", T.pack "http://example.org/1"),+ (T.pack "eg2", T.pack "http://example.org/2"),+ (T.pack "eg3", T.pack "http://example.org/3")+ ] ] - -- Test stubs, which just require the appropriate RDF impl function -- passed in to determine the implementation to be tested. -- empty RDF should have no triples-p_empty- :: Rdf rdf- => RDF rdf -> Bool+p_empty ::+ (Rdf rdf) =>+ RDF rdf ->+ Bool p_empty empty = null (triplesOf empty) -- triplesOf any RDF should return unique triples used to create it-p_mkRdf_triplesOf- :: Rdf rdf- => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)- -> Triples- -> Maybe BaseUrl- -> PrefixMappings- -> Bool+p_mkRdf_triplesOf ::+ (Rdf rdf) =>+ (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) ->+ Triples ->+ Maybe BaseUrl ->+ PrefixMappings ->+ Bool p_mkRdf_triplesOf _mkRdf ts bUrl pms = uordered (triplesOf (_mkRdf ts bUrl pms)) == uordered ts -- duplicate input triples should not be returned when -- uniqTriplesof is used-p_mkRdf_no_dupes- :: Rdf rdf- => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)- -> Triples- -> Maybe BaseUrl- -> PrefixMappings- -> Bool+p_mkRdf_no_dupes ::+ (Rdf rdf) =>+ (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) ->+ Triples ->+ Maybe BaseUrl ->+ PrefixMappings ->+ Bool p_mkRdf_no_dupes _mkRdf ts bUrl pms = null ts || (sort result == uordered ts) where tsWithDupe = head ts : ts@@ -164,24 +167,24 @@ -- property this test should check? -- -- query with all 3 wildcards should yield all triples in RDF-p_query_match_none- :: Rdf rdf- => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)- -> Triples- -> Maybe BaseUrl- -> PrefixMappings- -> Bool+p_query_match_none ::+ (Rdf rdf) =>+ (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) ->+ Triples ->+ Maybe BaseUrl ->+ PrefixMappings ->+ Bool p_query_match_none _mkRdf ts bUrl pms = uordered ts == uordered result where result = query (_mkRdf ts bUrl pms) Nothing Nothing Nothing -- query with no wildcard and a triple in the RDF should yield -- a singleton list with just the triple.-p_query_match_spo- :: Rdf rdf- => RDF rdf- -> RDF rdf- -> Property+p_query_match_spo ::+ (Rdf rdf) =>+ RDF rdf ->+ RDF rdf ->+ Property p_query_match_spo _unused rdf = classify (null ts) "trivial" $ forAll (tripleFromGen triplesOf rdf) f where@@ -210,20 +213,23 @@ -} -- query with no wildcard and a triple no in the RDF should yield []-p_query_unmatched_spo- :: Rdf rdf- => RDF rdf -> Triple -> Property+p_query_unmatched_spo ::+ (Rdf rdf) =>+ RDF rdf ->+ Triple ->+ Property p_query_unmatched_spo rdf t =- classify (t `elem` ts) "ignored" $ notElem t ts ==> [] == queryT rdf t+ classify (t `elem` ts) "ignored" $ notElem t ts ==> null (queryT rdf t) where ts = triplesOf rdf -- query with fixed subject and wildcards for pred and obj should yield -- a list with all triples having subject, and RDF minus result triples -- should yield all triple with unequal subjects.-p_query_match_s- :: Rdf rdf- => RDF rdf -> Property+p_query_match_s ::+ (Rdf rdf) =>+ RDF rdf ->+ Property p_query_match_s = mk_query_match_fn sameSubj f where f t = (Just (subjectOf t), Nothing, Nothing)@@ -231,43 +237,53 @@ -- query with fixed predicate and wildcards for subj and obj should yield -- a list with all triples having predicate, and a RDF graph minus result triples -- should yield all triple with unequal predicates.-p_query_match_p- :: Rdf rdf- => RDF rdf -> RDF rdf -> Property+p_query_match_p ::+ (Rdf rdf) =>+ RDF rdf ->+ RDF rdf ->+ Property p_query_match_p _unused = mk_query_match_fn samePred f where f t = (Nothing, Just (predicateOf t), Nothing) -- likewise for fixed subject and predicate with object wildcard-p_query_match_o- :: Rdf rdf- => RDF rdf -> RDF rdf -> Property+p_query_match_o ::+ (Rdf rdf) =>+ RDF rdf ->+ RDF rdf ->+ Property p_query_match_o _unused = mk_query_match_fn sameObj f where f t = (Nothing, Nothing, Just (objectOf t)) -- verify likewise for fixed subject and predicate with wildcard object-p_query_match_sp- :: Rdf rdf- => RDF rdf -> RDF rdf -> Property+p_query_match_sp ::+ (Rdf rdf) =>+ RDF rdf ->+ RDF rdf ->+ Property p_query_match_sp _unsed = mk_query_match_fn same f where same t1 t2 = sameSubj t1 t2 && samePred t1 t2 f t = (Just $ subjectOf t, Just $ predicateOf t, Nothing) -- fixed subject and object with wildcard predicate-p_query_match_so- :: Rdf rdf- => RDF rdf -> RDF rdf -> Property+p_query_match_so ::+ (Rdf rdf) =>+ RDF rdf ->+ RDF rdf ->+ Property p_query_match_so _unused = mk_query_match_fn same f where same t1 t2 = sameSubj t1 t2 && sameObj t1 t2 f t = (Just $ subjectOf t, Nothing, Just $ objectOf t) -- fixed predicate and object with wildcard subject-p_query_match_po- :: Rdf rdf- => RDF rdf -> RDF rdf -> Property+p_query_match_po ::+ (Rdf rdf) =>+ RDF rdf ->+ RDF rdf ->+ Property p_query_match_po _unused = mk_query_match_fn same f where same t1 t2 = samePred t1 t2 && sameObj t1 t2@@ -288,12 +304,12 @@ 6) checks that all triples not returned by the query do not match the tripl comparison function. -}-mk_query_match_fn- :: Rdf rdf- => (Triple -> Triple -> Bool)- -> (Triple -> (Maybe Node, Maybe Node, Maybe Node))- -> RDF rdf- -> Property+mk_query_match_fn ::+ (Rdf rdf) =>+ (Triple -> Triple -> Bool) ->+ (Triple -> (Maybe Node, Maybe Node, Maybe Node)) ->+ RDF rdf ->+ Property mk_query_match_fn tripleCompareFn mkPatternFn rdf = forAll (tripleFromGen triplesOf rdf) f where@@ -305,12 +321,13 @@ results = uordered $ queryC rdf (mkPatternFn t) -- `notResults` is the difference of the two sets of triples notResults = ldiff all_ts_sorted results- in all (tripleCompareFn t) results &&- all (not . tripleCompareFn t) notResults+ in all (tripleCompareFn t) results+ && not (any (tripleCompareFn t) notResults) -p_select_match_none- :: Rdf rdf- => RDF rdf -> Bool+p_select_match_none ::+ (Rdf rdf) =>+ RDF rdf ->+ Bool p_select_match_none rdf = sort ts1 == sort ts2 where ts1 = select rdf Nothing Nothing Nothing@@ -319,17 +336,19 @@ -- https://github.com/cordawyn/rdf4h/commit/9dd4729908db8d2f80088706592adac81a0f3016 ts2 = triplesOf rdf -p_select_match_s- :: Rdf rdf- => RDF rdf -> Property+p_select_match_s ::+ (Rdf rdf) =>+ RDF rdf ->+ Property p_select_match_s = p_select_match_fn same mkPattern triplesOf where same = equivNode (==) subjectOf mkPattern t = (Just (\n -> n == subjectOf t), Nothing, Nothing) -p_select_match_p- :: Rdf rdf- => RDF rdf -> Property+p_select_match_p ::+ (Rdf rdf) =>+ RDF rdf ->+ Property p_select_match_p = p_select_match_fn same mkPattern triplesOf where same = equivNode equiv predicateOf@@ -340,77 +359,85 @@ lastChar (UNode uri) = T.last uri lastChar _ = error "GraphTestUtils.p_select_match_p.lastChar" --p_select_match_o :: Rdf rdf => RDF rdf -> Property+p_select_match_o :: (Rdf rdf) => RDF rdf -> Property p_select_match_o = p_select_match_fn same mkPattern triplesOf where same = equivNode (/=) objectOf mkPattern t = (Nothing, Nothing, Just (\n -> n /= objectOf t)) -p_select_match_sp :: Rdf rdf => RDF rdf -> Property+p_select_match_sp :: (Rdf rdf) => RDF rdf -> Property p_select_match_sp = p_select_match_fn same mkPattern triplesOf where same t1 t2 = subjectOf t1 == subjectOf t2 && predicateOf t1 /= predicateOf t2 mkPattern t = (Just (\n -> n == subjectOf t), Just (\n -> n /= predicateOf t), Nothing) -p_select_match_so- :: Rdf rdf- => RDF rdf -> Property+p_select_match_so ::+ (Rdf rdf) =>+ RDF rdf ->+ Property p_select_match_so = p_select_match_fn same mkPattern triplesOf where same t1 t2 = subjectOf t1 /= subjectOf t2 && objectOf t1 == objectOf t2 mkPattern t = (Just (\n -> n /= subjectOf t), Nothing, Just (\n -> n == objectOf t)) -p_select_match_po- :: Rdf rdf- => RDF rdf -> RDF rdf -> Property+p_select_match_po ::+ (Rdf rdf) =>+ RDF rdf ->+ RDF rdf ->+ Property p_select_match_po _unsed = p_select_match_fn same mkPattern triplesOf where same t1 t2 = predicateOf t1 == predicateOf t2 && objectOf t1 == objectOf t2 mkPattern t = (Nothing, Just (\n -> n == predicateOf t), Just (\n -> n == objectOf t)) -p_select_match_spo- :: (Rdf rdf)- => RDF rdf -> RDF rdf -> Property+p_select_match_spo ::+ (Rdf rdf) =>+ RDF rdf ->+ RDF rdf ->+ Property p_select_match_spo _unused = p_select_match_fn same mkPattern triplesOf where same t1 t2 =- subjectOf t1 == subjectOf t2 &&- predicateOf t1 == predicateOf t2 && objectOf t1 /= objectOf t2+ subjectOf t1 == subjectOf t2+ && predicateOf t1 == predicateOf t2+ && objectOf t1 /= objectOf t2 mkPattern t =- ( Just (\n -> n == subjectOf t)- , Just (\n -> n == predicateOf t)- , Just (\n -> n /= objectOf t))+ ( Just (\n -> n == subjectOf t),+ Just (\n -> n == predicateOf t),+ Just (\n -> n /= objectOf t)+ ) --- |adding a triple to a graph.-p_add_triple- :: (Rdf rdf)- => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)- -> Triples- -> Maybe BaseUrl- -> PrefixMappings- -> Triple -- ^ new triple to be added- -> Bool+-- | adding a triple to a graph.+p_add_triple ::+ (Rdf rdf) =>+ (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) ->+ Triples ->+ Maybe BaseUrl ->+ PrefixMappings ->+ -- | new triple to be added+ Triple ->+ Bool p_add_triple _mkRdf ts bUrl pms newTriple = uordered (newTriple : triplesOf oldGr) == uordered (triplesOf newGr) where oldGr = _mkRdf ts bUrl pms newGr = addTriple oldGr newTriple --- |removing a triple that may or may not be in a graph. If it is not,--- this operation is silently ignored.-p_remove_triple- :: (Rdf rdf)- => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)- -> Triples- -> Maybe BaseUrl- -> PrefixMappings- -> Triple -- ^ triple to be removed- -> Bool+-- | removing a triple that may or may not be in a graph. If it is not,+-- this operation is silently ignored.+p_remove_triple ::+ (Rdf rdf) =>+ (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) ->+ Triples ->+ Maybe BaseUrl ->+ PrefixMappings ->+ -- | triple to be removed+ Triple ->+ Bool p_remove_triple _mkRdf ts bUrl pms tripleToBeRemoved = uordered (filter (/= tripleToBeRemoved) oldTriples) == uordered newTriples where@@ -419,18 +446,18 @@ oldTriples = triplesOf oldGr newTriples = triplesOf newGr --- |removing a triple from a graph. The new graph should not contain--- any instances of the triple.-p_remove_triple_from_graph- :: (Rdf rdf)- => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf)- -> Triples- -> Maybe BaseUrl- -> PrefixMappings- -> Property+-- | removing a triple from a graph. The new graph should not contain+-- any instances of the triple.+p_remove_triple_from_graph ::+ (Rdf rdf) =>+ (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF rdf) ->+ Triples ->+ Maybe BaseUrl ->+ PrefixMappings ->+ Property p_remove_triple_from_graph _mkRdf ts bUrl pms = classify (null ts) "p_remove_triple_from_graph tests were trivial" $- forAll (tripleFromGen triplesOf (_mkRdf ts bUrl pms)) f+ forAll (tripleFromGen triplesOf (_mkRdf ts bUrl pms)) f where f :: Maybe Triple -> Bool f Nothing = True@@ -439,69 +466,78 @@ -- TODO: refactor the following 3 functions. --- |removing a triple from a graph that contained only that triple.--- Performing a ((Just s) Nothing Nothing) query should return an--- empty list.-p_remove_triple_from_singleton_graph_query_s- :: (Rdf rdf)- => RDF rdf -> SingletonGraph rdf -> Bool+-- | removing a triple from a graph that contained only that triple.+-- Performing a ((Just s) Nothing Nothing) query should return an+-- empty list.+p_remove_triple_from_singleton_graph_query_s ::+ (Rdf rdf) =>+ RDF rdf ->+ SingletonGraph rdf ->+ Bool p_remove_triple_from_singleton_graph_query_s _unused singletonGraph = null (query newGr (Just s) Nothing Nothing) where tripleInGraph@(Triple s _p _o) = head (triplesOf (rdfGraph singletonGraph)) newGr = removeTriple (rdfGraph singletonGraph) tripleInGraph --- |removing a triple from a graph that contained only that triple.--- Performing a (Nothing (Just p) Nothing) query should return an--- empty list.-p_remove_triple_from_singleton_graph_query_p- :: (Rdf rdf)- => RDF rdf -> SingletonGraph rdf -> Bool+-- | removing a triple from a graph that contained only that triple.+-- Performing a (Nothing (Just p) Nothing) query should return an+-- empty list.+p_remove_triple_from_singleton_graph_query_p ::+ (Rdf rdf) =>+ RDF rdf ->+ SingletonGraph rdf ->+ Bool p_remove_triple_from_singleton_graph_query_p _unused singletonGraph = null (query newGr Nothing (Just p) Nothing) where tripleInGraph@(Triple _s p _o) = head (triplesOf (rdfGraph singletonGraph)) newGr = removeTriple (rdfGraph singletonGraph) tripleInGraph --- |removing a triple from a graph that contained only that triple.--- Performing a (Nothing Nothing (Just o)) query should return an--- empty list.-p_remove_triple_from_singleton_graph_query_o- :: (Rdf rdf)- => RDF rdf -> SingletonGraph rdf -> Bool+-- | removing a triple from a graph that contained only that triple.+-- Performing a (Nothing Nothing (Just o)) query should return an+-- empty list.+p_remove_triple_from_singleton_graph_query_o ::+ (Rdf rdf) =>+ RDF rdf ->+ SingletonGraph rdf ->+ Bool p_remove_triple_from_singleton_graph_query_o _unused singletonGraph = null (query newGr Nothing Nothing (Just o)) where tripleInGraph@(Triple _s _p o) = head (triplesOf (rdfGraph singletonGraph)) newGr = removeTriple (rdfGraph singletonGraph) tripleInGraph -p_add_then_remove_triples- :: (Rdf rdf)- => RDF rdf -- ^ empty- -> Triples -- ^ triples to add then remove- -> Bool+p_add_then_remove_triples ::+ (Rdf rdf) =>+ -- | empty+ RDF rdf ->+ -- | triples to add then remove+ Triples ->+ Bool p_add_then_remove_triples _empty genTriples = let emptyGraph = _empty populatedGraph = foldr (flip addTriple) emptyGraph genTriples emptiedGraph = foldr (flip removeTriple) populatedGraph genTriples- in null (triplesOf emptiedGraph)+ in null (triplesOf emptiedGraph) -equivNode :: (Node -> Node -> Bool)- -> (Triple -> Node)- -> Triple- -> Triple- -> Bool+equivNode ::+ (Node -> Node -> Bool) ->+ (Triple -> Node) ->+ Triple ->+ Triple ->+ Bool equivNode eqFn exFn t1 t2 = exFn t1 `eqFn` exFn t2 -p_select_match_fn- :: Rdf rdf- => (Triple -> Triple -> Bool)- -> (Triple -> (NodeSelector, NodeSelector, NodeSelector))- -> (RDF rdf -> Triples)- -> RDF rdf- -> Property+p_select_match_fn ::+ (Rdf rdf) =>+ (Triple -> Triple -> Bool) ->+ (Triple -> (NodeSelector, NodeSelector, NodeSelector)) ->+ (RDF rdf -> Triples) ->+ RDF rdf ->+ Property p_select_match_fn tripleCompareFn mkPatternFn _triplesOf rdf = forAll (tripleFromGen _triplesOf rdf) f where@@ -512,25 +548,29 @@ all_ts_sorted = uordered all_ts results = uordered $ selectC rdf (mkPatternFn t) notResults = ldiff all_ts_sorted results- in all (tripleCompareFn t) results &&- all (not . tripleCompareFn t) notResults+ in all (tripleCompareFn t) results+ && not (any (tripleCompareFn t) notResults) -- Utility functions and test data ... -- -- a curried version of query that delegates to the actual query after unpacking -- curried maybe node pattern.-queryC- :: Rdf rdf- => RDF rdf -> (Maybe Node, Maybe Node, Maybe Node) -> Triples+queryC ::+ (Rdf rdf) =>+ RDF rdf ->+ (Maybe Node, Maybe Node, Maybe Node) ->+ Triples queryC rdf (s, p, o) = query rdf s p o -selectC- :: Rdf rdf- => RDF rdf -> (NodeSelector, NodeSelector, NodeSelector) -> Triples+selectC ::+ (Rdf rdf) =>+ RDF rdf ->+ (NodeSelector, NodeSelector, NodeSelector) ->+ Triples selectC rdf (s, p, o) = select rdf s p o ldiff :: Triples -> Triples -> Triples-ldiff l1 l2 = Set.toList $(Set.fromList l1) `Set.difference` Set.fromList l2+ldiff l1 l2 = Set.toList $ (Set.fromList l1) `Set.difference` Set.fromList l2 sameSubj :: Triple -> Triple -> Bool sameSubj t1 t2 = subjectOf t1 == subjectOf t2@@ -539,11 +579,11 @@ samePred t1 t2 = predicateOf t1 == predicateOf t2 sameObj :: Triple -> Triple -> Bool-sameObj t1 t2 = objectOf t1 == objectOf t2+sameObj t1 t2 = objectOf t1 == objectOf t2 --- |pick a random triple from an RDF graph if the graph is not empty.-tripleFromGen- :: (RDF rdf -> Triples) -> RDF rdf -> Gen (Maybe Triple)+-- | pick a random triple from an RDF graph if the graph is not empty.+tripleFromGen ::+ (RDF rdf -> Triples) -> RDF rdf -> Gen (Maybe Triple) tripleFromGen _triplesOf rdf = if null ts then return Nothing@@ -551,9 +591,11 @@ where ts = _triplesOf rdf -queryT- :: Rdf rdf- => RDF rdf -> Triple -> Triples+queryT ::+ (Rdf rdf) =>+ RDF rdf ->+ Triple ->+ Triples queryT rdf t = query rdf (Just $ subjectOf t) (Just $ predicateOf t) (Just $ objectOf t) @@ -564,10 +606,15 @@ datatypes = fmap (mkUri xsd . T.pack) ["string", "int", "token"] uris :: [T.Text]-uris = [mkUri ex (n <> T.pack (show (i :: Int)))- | n <- ["foo", "bar", "quz", "zak"], i <- [0 .. 2]]- <> ["ex:" <> n <> T.pack (show (i::Int))- | n <- ["s", "p", "o"], i <- [1..3]]+uris =+ [ mkUri ex (n <> T.pack (show (i :: Int)))+ | n <- ["foo", "bar", "quz", "zak"],+ i <- [0 .. 2]+ ]+ <> [ "ex:" <> n <> T.pack (show (i :: Int))+ | n <- ["s", "p", "o"],+ i <- [1 .. 3]+ ] plainliterals :: [LValue] plainliterals = [plainLL lit lang | lit <- litvalues, lang <- languages]@@ -581,8 +628,8 @@ unodes :: [Node] unodes = fmap UNode uris -bnodes :: [ Node]-bnodes = fmap (BNode . \i -> T.pack ":_genid" <> T.pack (show (i::Int))) [1..5]+bnodes :: [Node]+bnodes = fmap (BNode . \i -> T.pack ":_genid" <> T.pack (show (i :: Int))) [1 .. 5] lnodes :: [Node] lnodes = [LNode lit | lit <- plainliterals <> typedliterals]@@ -625,19 +672,23 @@ -- Reported by Daniel Bergey: -- https://github.com/robstewart57/rdf4h/issues/4 -p_reverseRdfTest- :: Rdf a- => (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF a) -> Property+p_reverseRdfTest ::+ (Rdf a) =>+ (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF a) ->+ Property p_reverseRdfTest _mkRdf = monadicIO $ do- fileContents <- Test.QuickCheck.Monadic.run $ bracket- (openTempFile "." "tmp")- (\(path, h) -> hClose h >> removeFile path)- (\(_, h) -> do- hSetEncoding h utf8- hWriteRdf NTriplesSerializer h rdf- hSeek h AbsoluteSeek 0- T.hGetContents h)+ fileContents <-+ Test.QuickCheck.Monadic.run $+ bracket+ (openTempFile "." "tmp")+ (\(path, h) -> hClose h >> removeFile path)+ ( \(_, h) -> do+ hSetEncoding h utf8+ hWriteRdf NTriplesSerializer h rdf+ hSeek h AbsoluteSeek 0+ T.hGetContents h+ ) assert $ expected == fileContents where rdf = _mkRdf ts (Just $ BaseUrl "file://") (ns_mappings mempty)@@ -648,6 +699,7 @@ (unode "file:///this/is/not/a/palindrome") (LNode . PlainL $ "literal string") ]- expected = "<file:///this/is/not/a/palindrome> \- \<file:///this/is/not/a/palindrome> \- \\"literal string\" .\n"+ expected =+ "<file:///this/is/not/a/palindrome> \+ \<file:///this/is/not/a/palindrome> \+ \\"literal string\" .\n"
testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs view
@@ -13,7 +13,6 @@ import Data.RDF.Graph.TList import Data.RDF.Query import Data.RDF.Types-import Data.Semigroup ((<>)) import Data.String (fromString) import Data.Text (Text) import Test.Tasty@@ -91,7 +90,7 @@ -- Determines if graphs are equivalent, returning Nothing if so or else a diagnostic message. -- First graph is expected graph, second graph is actual.-equivalent :: Rdf a => Either ParseFailure (RDF a) -> Either ParseFailure (RDF a) -> Maybe String+equivalent :: (Rdf a) => Either ParseFailure (RDF a) -> Either ParseFailure (RDF a) -> Maybe String equivalent (Left e) _ = Just $ "Parse failure of the expected graph: " <> show e equivalent _ (Left e) = Just $ "Parse failure of the input graph: " <> show e equivalent (Right gr1) (Right gr2) = checkSize <|> (test $! zip gr1ts gr2ts)@@ -143,7 +142,7 @@ Left (ParseFailure err) -> TU.assertFailure $ idStr <> err Right _ -> return () -assertEquivalent :: Rdf a => String -> IO (Either ParseFailure (RDF a)) -> IO (Either ParseFailure (RDF a)) -> TU.Assertion+assertEquivalent :: (Rdf a) => String -> IO (Either ParseFailure (RDF a)) -> IO (Either ParseFailure (RDF a)) -> TU.Assertion assertEquivalent testname r1 r2 = do gr1 <- r1 gr2 <- r2
testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs view
@@ -1,68 +1,66 @@ {-# LANGUAGE OverloadedStrings #-} module Text.RDF.RDF4H.XmlParser_Test- (- tests- ) where+ ( tests,+ )+where -- todo: QuickCheck tests -import Data.Semigroup ((<>)) -- Testing imports-import Test.Tasty-import Test.Tasty.HUnit as TU -- Import common libraries to facilitate tests import qualified Data.Map as Map-import Data.RDF.Query import Data.RDF.Graph.TList (TList)+import Data.RDF.Query import Data.RDF.Types-import qualified Data.Text.IO as TIO import qualified Data.Text as T (Text, pack, unlines)-import Text.RDF.RDF4H.XmlParser-import Text.RDF.RDF4H.NTriplesParser+import qualified Data.Text.IO as TIO+import Test.Tasty+import Test.Tasty.HUnit as TU import Text.Printf+import Text.RDF.RDF4H.NTriplesParser+import Text.RDF.RDF4H.XmlParser tests :: [TestTree] tests =- [ testCase "simpleStriping1" test_simpleStriping1- , testCase "simpleStriping2" test_simpleStriping2- , testCase "simpleSingleton1" test_simpleSingleton1- , testCase "simpleSingleton2" test_simpleSingleton2- , testCase "vCardPersonal" test_parseXmlRDF_vCardPersonal- , testCase "NML" test_parseXmlRDF_NML- , testCase "NML2" test_parseXmlRDF_NML2- , testCase "NML3" test_parseXmlRDF_NML3- ]- <>- fmap (uncurry checkGoodOtherTest) otherTestFiles+ [ testCase "simpleStriping1" test_simpleStriping1,+ testCase "simpleStriping2" test_simpleStriping2,+ testCase "simpleSingleton1" test_simpleSingleton1,+ testCase "simpleSingleton2" test_simpleSingleton2,+ testCase "vCardPersonal" test_parseXmlRDF_vCardPersonal,+ testCase "NML" test_parseXmlRDF_NML,+ testCase "NML2" test_parseXmlRDF_NML2,+ testCase "NML3" test_parseXmlRDF_NML3+ ]+ <> fmap (uncurry checkGoodOtherTest) otherTestFiles otherTestFiles :: [(String, String)]-otherTestFiles = [ ("data/xml", "example07")- , ("data/xml", "example08")- -- https://gitlab.com/k0001/xmlbf/merge_requests/9- -- , ("data/xml", "example09")- , ("data/xml", "example10")- , ("data/xml", "example11")- , ("data/xml", "example12")- , ("data/xml", "example13")- , ("data/xml", "example14")- , ("data/xml", "example15")- , ("data/xml", "example16")- , ("data/xml", "example17")- , ("data/xml", "example18")- , ("data/xml", "example19")- , ("data/xml", "example20")-- -- https://github.com/robstewart57/rdf4h/issues/48- , ("data/xml", "example22")- ]+otherTestFiles =+ [ ("data/xml", "example07"),+ ("data/xml", "example08"),+ -- https://gitlab.com/k0001/xmlbf/merge_requests/9+ -- , ("data/xml", "example09")+ ("data/xml", "example10"),+ ("data/xml", "example11"),+ ("data/xml", "example12"),+ ("data/xml", "example13"),+ ("data/xml", "example14"),+ ("data/xml", "example15"),+ ("data/xml", "example16"),+ ("data/xml", "example17"),+ ("data/xml", "example18"),+ ("data/xml", "example19"),+ ("data/xml", "example20"),+ -- https://github.com/robstewart57/rdf4h/issues/48+ ("data/xml", "example22")+ ] checkGoodOtherTest :: String -> String -> TestTree checkGoodOtherTest dir fname =- let expGr = loadExpectedGraph1 (printf "%s/%s.out" dir fname :: String)- inGr = loadInputGraph1 dir fname- in doGoodConformanceTest expGr inGr $ printf "xml-%s" fname+ let expGr = loadExpectedGraph1 (printf "%s/%s.out" dir fname :: String)+ inGr = loadInputGraph1 dir fname+ in doGoodConformanceTest expGr inGr $ printf "xml-%s" fname loadExpectedGraph1 :: String -> IO (Either ParseFailure (RDF TList)) loadExpectedGraph1 fname = do@@ -71,305 +69,401 @@ loadInputGraph1 :: String -> String -> IO (Either ParseFailure (RDF TList)) loadInputGraph1 dir fname =- (parseString (XmlParser Nothing (mkDocUrl1 testBaseUri dir fname)) <$>- TIO.readFile (printf "%s/%s.rdf" dir fname :: String))+ ( parseString (XmlParser Nothing (mkDocUrl1 testBaseUri dir fname))+ <$> TIO.readFile (printf "%s/%s.rdf" dir fname :: String)+ ) -doGoodConformanceTest :: IO (Either ParseFailure (RDF TList)) ->- IO (Either ParseFailure (RDF TList)) ->- String -> TestTree+doGoodConformanceTest ::+ IO (Either ParseFailure (RDF TList)) ->+ IO (Either ParseFailure (RDF TList)) ->+ String ->+ TestTree doGoodConformanceTest expGr inGr testname =- let t1 = assertLoadSuccess (printf "expected (%s): " testname) expGr- t2 = assertLoadSuccess (printf " input (%s): " testname) inGr- t3 = assertEquivalent testname expGr inGr- in testGroup (printf "conformance-%s" testname) $ fmap (uncurry testCase) [("loading-expected-graph-data", t1), ("loading-input-graph-data", t2), ("comparing-graphs", t3)]+ let t1 = assertLoadSuccess (printf "expected (%s): " testname) expGr+ t2 = assertLoadSuccess (printf " input (%s): " testname) inGr+ t3 = assertEquivalent testname expGr inGr+ in testGroup (printf "conformance-%s" testname) $ fmap (uncurry testCase) [("loading-expected-graph-data", t1), ("loading-input-graph-data", t2), ("comparing-graphs", t3)] mkTextNode :: T.Text -> Node mkTextNode = lnode . plainL testParse :: T.Text -> RDF TList -> Assertion testParse exRDF ex =- case parsed of- Right result ->- assertBool- ("expected: " <> show ex <> "but got: " <> show result)- (isIsomorphic (result :: RDF TList) (ex :: RDF TList))- Left (ParseFailure err) ->- assertFailure err- where parsed = parseString (XmlParser Nothing Nothing) exRDF+ case parsed of+ Right result ->+ assertBool+ ("expected: " <> show ex <> "but got: " <> show result)+ (isIsomorphic (result :: RDF TList) (ex :: RDF TList))+ Left (ParseFailure err) ->+ assertFailure err+ where+ parsed = parseString (XmlParser Nothing Nothing) exRDF test_simpleStriping1 :: Assertion-test_simpleStriping1 = testParse+test_simpleStriping1 =+ testParse "<rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\- \ xmlns:dc=\"http://purl.org/dc/elements/1.1/\">\- \<rdf:Description rdf:about=\"http://www.w3.org/TR/rdf-syntax-grammar\">\- \<dc:title>RDF/XML Syntax Specification (Revised)</dc:title>\- \</rdf:Description>\+ \ xmlns:dc=\"http://purl.org/dc/elements/1.1/\">\+ \<rdf:Description rdf:about=\"http://www.w3.org/TR/rdf-syntax-grammar\">\+ \<dc:title>RDF/XML Syntax Specification (Revised)</dc:title>\+ \</rdf:Description>\ \</rdf:RDF>"- ( mkRdf [ Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar")- (unode "dc:title")- (mkTextNode "RDF/XML Syntax Specification (Revised)") ]- Nothing- ( PrefixMappings (Map.fromList [ ("dc", "http://purl.org/dc/elements/1.1/")- , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) )+ ( mkRdf+ [ Triple+ (unode "http://www.w3.org/TR/rdf-syntax-grammar")+ (unode "dc:title")+ (mkTextNode "RDF/XML Syntax Specification (Revised)")+ ]+ Nothing+ ( PrefixMappings+ ( Map.fromList+ [ ("dc", "http://purl.org/dc/elements/1.1/"),+ ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#")+ ]+ )+ ) ) test_simpleStriping2 :: Assertion-test_simpleStriping2 = testParse+test_simpleStriping2 =+ testParse "<rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\- \ xmlns:dc=\"http://purl.org/dc/elements/1.1/\">\- \<rdf:Description rdf:about=\"http://www.w3.org/TR/rdf-syntax-grammar\">\- \<dc:title>RDF/XML Syntax Specification (Revised)</dc:title>\- \</rdf:Description>\- \<rdf:Description rdf:about=\"http://example.org/buecher/baum\">\- \<dc:title>Der Baum</dc:title>\- \</rdf:Description>\+ \ xmlns:dc=\"http://purl.org/dc/elements/1.1/\">\+ \<rdf:Description rdf:about=\"http://www.w3.org/TR/rdf-syntax-grammar\">\+ \<dc:title>RDF/XML Syntax Specification (Revised)</dc:title>\+ \</rdf:Description>\+ \<rdf:Description rdf:about=\"http://example.org/buecher/baum\">\+ \<dc:title>Der Baum</dc:title>\+ \</rdf:Description>\ \</rdf:RDF>"- ( mkRdf [ Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar")- (unode "dc:title")- (mkTextNode "RDF/XML Syntax Specification (Revised)")- , Triple (unode "http://example.org/buecher/baum")- (unode "dc:title")- (mkTextNode "Der Baum")- ]- Nothing- ( PrefixMappings (Map.fromList [ ("dc", "http://purl.org/dc/elements/1.1/")- , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) )+ ( mkRdf+ [ Triple+ (unode "http://www.w3.org/TR/rdf-syntax-grammar")+ (unode "dc:title")+ (mkTextNode "RDF/XML Syntax Specification (Revised)"),+ Triple+ (unode "http://example.org/buecher/baum")+ (unode "dc:title")+ (mkTextNode "Der Baum")+ ]+ Nothing+ ( PrefixMappings+ ( Map.fromList+ [ ("dc", "http://purl.org/dc/elements/1.1/"),+ ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#")+ ]+ )+ ) ) test_simpleSingleton1 :: Assertion-test_simpleSingleton1 = testParse+test_simpleSingleton1 =+ testParse "<rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\- \ xmlns:dc=\"http://purl.org/dc/elements/1.1/\">\- \<rdf:Description rdf:about=\"http://www.w3.org/TR/rdf-syntax-grammar\"\- \ dc:title=\"RDF/XML Syntax Specification (Revised)\"/>\+ \ xmlns:dc=\"http://purl.org/dc/elements/1.1/\">\+ \<rdf:Description rdf:about=\"http://www.w3.org/TR/rdf-syntax-grammar\"\+ \ dc:title=\"RDF/XML Syntax Specification (Revised)\"/>\ \</rdf:RDF>"- ( mkRdf [ Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar")- (unode "dc:title")- (mkTextNode "RDF/XML Syntax Specification (Revised)") ]- Nothing- ( PrefixMappings (Map.fromList [ ("dc", "http://purl.org/dc/elements/1.1/")- , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) )+ ( mkRdf+ [ Triple+ (unode "http://www.w3.org/TR/rdf-syntax-grammar")+ (unode "dc:title")+ (mkTextNode "RDF/XML Syntax Specification (Revised)")+ ]+ Nothing+ ( PrefixMappings+ ( Map.fromList+ [ ("dc", "http://purl.org/dc/elements/1.1/"),+ ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#")+ ]+ )+ ) ) test_simpleSingleton2 :: Assertion-test_simpleSingleton2 = testParse+test_simpleSingleton2 =+ testParse "<rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\- \ xmlns:dc=\"http://purl.org/dc/elements/1.1/\">\- \<rdf:Description rdf:about=\"http://www.w3.org/TR/rdf-syntax-grammar\"\- \ dc:title=\"RDF/XML Syntax Specification (Revised)\"\- \ dc:subject=\"RDF\"/>\+ \ xmlns:dc=\"http://purl.org/dc/elements/1.1/\">\+ \<rdf:Description rdf:about=\"http://www.w3.org/TR/rdf-syntax-grammar\"\+ \ dc:title=\"RDF/XML Syntax Specification (Revised)\"\+ \ dc:subject=\"RDF\"/>\ \</rdf:RDF>"- ( mkRdf [ Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar")- (unode "dc:title")- (mkTextNode "RDF/XML Syntax Specification (Revised)")- , Triple (unode "http://www.w3.org/TR/rdf-syntax-grammar")- (unode "dc:subject")- (mkTextNode "RDF") ]- Nothing- ( PrefixMappings (Map.fromList [ ("dc", "http://purl.org/dc/elements/1.1/")- , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) )+ ( mkRdf+ [ Triple+ (unode "http://www.w3.org/TR/rdf-syntax-grammar")+ (unode "dc:title")+ (mkTextNode "RDF/XML Syntax Specification (Revised)"),+ Triple+ (unode "http://www.w3.org/TR/rdf-syntax-grammar")+ (unode "dc:subject")+ (mkTextNode "RDF")+ ]+ Nothing+ ( PrefixMappings+ ( Map.fromList+ [ ("dc", "http://purl.org/dc/elements/1.1/"),+ ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#")+ ]+ )+ ) ) - test_parseXmlRDF_vCardPersonal :: Assertion-test_parseXmlRDF_vCardPersonal = testParse+test_parseXmlRDF_vCardPersonal =+ testParse "<rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\- \ xmlns:v=\"http://www.w3.org/2006/vcard/ns#\">\- \<v:VCard rdf:about=\"http://example.com/me/corky\" >\- \<v:fn>Corky Crystal</v:fn>\- \<v:nickname>Corks</v:nickname>\- \<v:tel>\- \<rdf:Description>\- \<rdf:value>+61 7 5555 5555</rdf:value>\- \<rdf:type rdf:resource=\"http://www.w3.org/2006/vcard/ns#Home\"/>\- \<rdf:type rdf:resource=\"http://www.w3.org/2006/vcard/ns#Voice\"/>\- \</rdf:Description>\- \</v:tel>\- \<v:email rdf:resource=\"mailto:corky@example.com\"/>\- \<v:adr>\- \<rdf:Description>\- \<v:street-address>111 Lake Drive</v:street-address>\- \<v:locality>WonderCity</v:locality>\- \<v:postal-code>5555</v:postal-code>\- \<v:country-name>Australia</v:country-name>\- \<rdf:type rdf:resource=\"http://www.w3.org/2006/vcard/ns#Home\"/>\- \</rdf:Description>\- \</v:adr>\- \</v:VCard>\+ \ xmlns:v=\"http://www.w3.org/2006/vcard/ns#\">\+ \<v:VCard rdf:about=\"http://example.com/me/corky\" >\+ \<v:fn>Corky Crystal</v:fn>\+ \<v:nickname>Corks</v:nickname>\+ \<v:tel>\+ \<rdf:Description>\+ \<rdf:value>+61 7 5555 5555</rdf:value>\+ \<rdf:type rdf:resource=\"http://www.w3.org/2006/vcard/ns#Home\"/>\+ \<rdf:type rdf:resource=\"http://www.w3.org/2006/vcard/ns#Voice\"/>\+ \</rdf:Description>\+ \</v:tel>\+ \<v:email rdf:resource=\"mailto:corky@example.com\"/>\+ \<v:adr>\+ \<rdf:Description>\+ \<v:street-address>111 Lake Drive</v:street-address>\+ \<v:locality>WonderCity</v:locality>\+ \<v:postal-code>5555</v:postal-code>\+ \<v:country-name>Australia</v:country-name>\+ \<rdf:type rdf:resource=\"http://www.w3.org/2006/vcard/ns#Home\"/>\+ \</rdf:Description>\+ \</v:adr>\+ \</v:VCard>\ \</rdf:RDF>"- ( mkRdf [ Triple (unode "http://example.com/me/corky")- (unode "rdf:type")- (unode "v:VCard")- , Triple (unode "http://example.com/me/corky")- (unode "v:fn")- (mkTextNode "Corky Crystal")- , Triple (unode "http://example.com/me/corky")- (unode "v:nickname")- (mkTextNode "Corks")- , Triple (unode "http://example.com/me/corky")- (unode "v:tel")- (BNodeGen 1)- , Triple (BNodeGen 1)- (unode "rdf:value")- (mkTextNode "+61 7 5555 5555")- , Triple (BNodeGen 1)- (unode "rdf:type")- (unode "http://www.w3.org/2006/vcard/ns#Home")- , Triple (BNodeGen 1)- (unode "rdf:type")- (unode "http://www.w3.org/2006/vcard/ns#Voice")- , Triple (unode "http://example.com/me/corky")- (unode "v:email")- (unode "mailto:corky@example.com")- , Triple (unode "http://example.com/me/corky")- (unode "v:adr")- (BNodeGen 2)- , Triple (BNodeGen 2)- (unode "v:street-address")- (mkTextNode "111 Lake Drive")- , Triple (BNodeGen 2)- (unode "v:locality")- (mkTextNode "WonderCity")- , Triple (BNodeGen 2)- (unode "v:postal-code")- (mkTextNode "5555")- , Triple (BNodeGen 2)- (unode "v:country-name")- (mkTextNode "Australia")- , Triple (BNodeGen 2)- (unode "rdf:type")- (unode "http://www.w3.org/2006/vcard/ns#Home")- ]- Nothing- ( PrefixMappings (Map.fromList [ ("v", "http://www.w3.org/2006/vcard/ns#")- , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) )+ ( mkRdf+ [ Triple+ (unode "http://example.com/me/corky")+ (unode "rdf:type")+ (unode "v:VCard"),+ Triple+ (unode "http://example.com/me/corky")+ (unode "v:fn")+ (mkTextNode "Corky Crystal"),+ Triple+ (unode "http://example.com/me/corky")+ (unode "v:nickname")+ (mkTextNode "Corks"),+ Triple+ (unode "http://example.com/me/corky")+ (unode "v:tel")+ (BNodeGen 1),+ Triple+ (BNodeGen 1)+ (unode "rdf:value")+ (mkTextNode "+61 7 5555 5555"),+ Triple+ (BNodeGen 1)+ (unode "rdf:type")+ (unode "http://www.w3.org/2006/vcard/ns#Home"),+ Triple+ (BNodeGen 1)+ (unode "rdf:type")+ (unode "http://www.w3.org/2006/vcard/ns#Voice"),+ Triple+ (unode "http://example.com/me/corky")+ (unode "v:email")+ (unode "mailto:corky@example.com"),+ Triple+ (unode "http://example.com/me/corky")+ (unode "v:adr")+ (BNodeGen 2),+ Triple+ (BNodeGen 2)+ (unode "v:street-address")+ (mkTextNode "111 Lake Drive"),+ Triple+ (BNodeGen 2)+ (unode "v:locality")+ (mkTextNode "WonderCity"),+ Triple+ (BNodeGen 2)+ (unode "v:postal-code")+ (mkTextNode "5555"),+ Triple+ (BNodeGen 2)+ (unode "v:country-name")+ (mkTextNode "Australia"),+ Triple+ (BNodeGen 2)+ (unode "rdf:type")+ (unode "http://www.w3.org/2006/vcard/ns#Home")+ ]+ Nothing+ ( PrefixMappings+ ( Map.fromList+ [ ("v", "http://www.w3.org/2006/vcard/ns#"),+ ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#")+ ]+ )+ ) ) test_parseXmlRDF_NML :: Assertion-test_parseXmlRDF_NML = testParse- (T.unlines- ["<?xml version=\"1.0\" encoding=\"utf-8\"?>"- ,"<rdf:RDF"- ," xmlns:nml=\"http://schemas.ogf.org/nml/2013/05/base#\""- ," xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\""- ,">"- ," <nml:Node rdf:about=\"urn:ogf:network:example.org:2014:foo\">"- ," <nml:hasInboundPort>"- ," <nml:Port rdf:about=\"urn:ogf:network:example.org:2014:foo:A1:in\">"- ," <nml:isSink rdf:resource=\"urn:ogf:network:example.org:2014:link:1\"/>"- ," </nml:Port>"- ," </nml:hasInboundPort>"- ," </nml:Node>"- ,"</rdf:RDF>"- ])- ( mkRdf [ Triple (unode "urn:ogf:network:example.org:2014:foo")- (unode "rdf:type")- (unode "nml:Node")- , Triple (unode "urn:ogf:network:example.org:2014:foo")- (unode "nml:hasInboundPort")- (unode "urn:ogf:network:example.org:2014:foo:A1:in")- , Triple (unode "urn:ogf:network:example.org:2014:foo:A1:in")- (unode "rdf:type")- (unode "nml:Port")- , Triple (unode "urn:ogf:network:example.org:2014:foo:A1:in")- (unode "nml:isSink")- (unode "urn:ogf:network:example.org:2014:link:1")- ]- Nothing- ( PrefixMappings (Map.fromList [ ("nml", "http://schemas.ogf.org/nml/2013/05/base#")- , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) )+test_parseXmlRDF_NML =+ testParse+ ( T.unlines+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>",+ "<rdf:RDF",+ " xmlns:nml=\"http://schemas.ogf.org/nml/2013/05/base#\"",+ " xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"",+ ">",+ " <nml:Node rdf:about=\"urn:ogf:network:example.org:2014:foo\">",+ " <nml:hasInboundPort>",+ " <nml:Port rdf:about=\"urn:ogf:network:example.org:2014:foo:A1:in\">",+ " <nml:isSink rdf:resource=\"urn:ogf:network:example.org:2014:link:1\"/>",+ " </nml:Port>",+ " </nml:hasInboundPort>",+ " </nml:Node>",+ "</rdf:RDF>"+ ] )+ ( mkRdf+ [ Triple+ (unode "urn:ogf:network:example.org:2014:foo")+ (unode "rdf:type")+ (unode "nml:Node"),+ Triple+ (unode "urn:ogf:network:example.org:2014:foo")+ (unode "nml:hasInboundPort")+ (unode "urn:ogf:network:example.org:2014:foo:A1:in"),+ Triple+ (unode "urn:ogf:network:example.org:2014:foo:A1:in")+ (unode "rdf:type")+ (unode "nml:Port"),+ Triple+ (unode "urn:ogf:network:example.org:2014:foo:A1:in")+ (unode "nml:isSink")+ (unode "urn:ogf:network:example.org:2014:link:1")+ ]+ Nothing+ ( PrefixMappings+ ( Map.fromList+ [ ("nml", "http://schemas.ogf.org/nml/2013/05/base#"),+ ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#")+ ]+ )+ )+ ) test_parseXmlRDF_NML2 :: Assertion-test_parseXmlRDF_NML2 = testParse- (T.unlines- ["<?xml version=\"1.0\" encoding=\"utf-8\"?>"- ,"<rdf:RDF"- ," xmlns:nml=\"http://schemas.ogf.org/nml/2013/05/base#\""- ," xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\""- ,">"- ," <nml:Node rdf:about=\"urn:ogf:network:example.org:2014:foo\">"- ," <nml:hasInboundPort rdf:resource=\"urn:ogf:network:example.org:2014:foo:A1:in\"/>"- ," </nml:Node>"- ," <nml:Port rdf:about=\"urn:ogf:network:example.org:2014:foo:A1:in\">"- ," <nml:isSink rdf:resource=\"urn:ogf:network:example.org:2014:link:1\"/>"- ," </nml:Port>"- ,"</rdf:RDF>"- ])- ( mkRdf [ Triple (unode "urn:ogf:network:example.org:2014:foo")- (unode "rdf:type")- (unode "nml:Node")- , Triple (unode "urn:ogf:network:example.org:2014:foo")- (unode "nml:hasInboundPort")- (unode "urn:ogf:network:example.org:2014:foo:A1:in")- , Triple (unode "urn:ogf:network:example.org:2014:foo:A1:in")- (unode "rdf:type")- (unode "nml:Port")- , Triple (unode "urn:ogf:network:example.org:2014:foo:A1:in")- (unode "nml:isSink")- (unode "urn:ogf:network:example.org:2014:link:1")- ]- Nothing- ( PrefixMappings (Map.fromList [ ("nml", "http://schemas.ogf.org/nml/2013/05/base#")- , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) )+test_parseXmlRDF_NML2 =+ testParse+ ( T.unlines+ [ "<?xml version=\"1.0\" encoding=\"utf-8\"?>",+ "<rdf:RDF",+ " xmlns:nml=\"http://schemas.ogf.org/nml/2013/05/base#\"",+ " xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"",+ ">",+ " <nml:Node rdf:about=\"urn:ogf:network:example.org:2014:foo\">",+ " <nml:hasInboundPort rdf:resource=\"urn:ogf:network:example.org:2014:foo:A1:in\"/>",+ " </nml:Node>",+ " <nml:Port rdf:about=\"urn:ogf:network:example.org:2014:foo:A1:in\">",+ " <nml:isSink rdf:resource=\"urn:ogf:network:example.org:2014:link:1\"/>",+ " </nml:Port>",+ "</rdf:RDF>"+ ] )+ ( mkRdf+ [ Triple+ (unode "urn:ogf:network:example.org:2014:foo")+ (unode "rdf:type")+ (unode "nml:Node"),+ Triple+ (unode "urn:ogf:network:example.org:2014:foo")+ (unode "nml:hasInboundPort")+ (unode "urn:ogf:network:example.org:2014:foo:A1:in"),+ Triple+ (unode "urn:ogf:network:example.org:2014:foo:A1:in")+ (unode "rdf:type")+ (unode "nml:Port"),+ Triple+ (unode "urn:ogf:network:example.org:2014:foo:A1:in")+ (unode "nml:isSink")+ (unode "urn:ogf:network:example.org:2014:link:1")+ ]+ Nothing+ ( PrefixMappings+ ( Map.fromList+ [ ("nml", "http://schemas.ogf.org/nml/2013/05/base#"),+ ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#")+ ]+ )+ )+ ) test_parseXmlRDF_NML3 :: Assertion-test_parseXmlRDF_NML3 = testParse+test_parseXmlRDF_NML3 =+ testParse "<?xml version=\"1.0\" encoding=\"utf-8\"?>\- \<rdf:RDF\- \ xmlns:nml=\"http://schemas.ogf.org/nml/2013/05/base#\"\- \ xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\- \>\- \ <nml:Node rdf:about=\"urn:ogf:network:example.org:2014:foo\">\- \ <nml:hasInboundPort rdf:resource=\"urn:ogf:network:example.org:2014:foo:A1:in\"/>\- \ </nml:Node>\- \ <nml:Port rdf:about=\"urn:ogf:network:example.org:2014:foo:A1:in\">\- \ <nml:isSink rdf:resource=\"urn:ogf:network:example.org:2014:link:1\"/>\- \ </nml:Port>\- \</rdf:RDF>"- ( mkRdf [ Triple (unode "urn:ogf:network:example.org:2014:foo")- (unode "rdf:type")- (unode "nml:Node")- , Triple (unode "urn:ogf:network:example.org:2014:foo")- (unode "nml:hasInboundPort")- (unode "urn:ogf:network:example.org:2014:foo:A1:in")- , Triple (unode "urn:ogf:network:example.org:2014:foo:A1:in")- (unode "rdf:type")- (unode "nml:Port")- , Triple (unode "urn:ogf:network:example.org:2014:foo:A1:in")- (unode "nml:isSink")- (unode "urn:ogf:network:example.org:2014:link:1")- ]- Nothing- ( PrefixMappings (Map.fromList [ ("nml", "http://schemas.ogf.org/nml/2013/05/base#")- , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#") ]) )+ \<rdf:RDF\+ \ xmlns:nml=\"http://schemas.ogf.org/nml/2013/05/base#\"\+ \ xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\+ \>\+ \ <nml:Node rdf:about=\"urn:ogf:network:example.org:2014:foo\">\+ \ <nml:hasInboundPort rdf:resource=\"urn:ogf:network:example.org:2014:foo:A1:in\"/>\+ \ </nml:Node>\+ \ <nml:Port rdf:about=\"urn:ogf:network:example.org:2014:foo:A1:in\">\+ \ <nml:isSink rdf:resource=\"urn:ogf:network:example.org:2014:link:1\"/>\+ \ </nml:Port>\+ \</rdf:RDF>"+ ( mkRdf+ [ Triple+ (unode "urn:ogf:network:example.org:2014:foo")+ (unode "rdf:type")+ (unode "nml:Node"),+ Triple+ (unode "urn:ogf:network:example.org:2014:foo")+ (unode "nml:hasInboundPort")+ (unode "urn:ogf:network:example.org:2014:foo:A1:in"),+ Triple+ (unode "urn:ogf:network:example.org:2014:foo:A1:in")+ (unode "rdf:type")+ (unode "nml:Port"),+ Triple+ (unode "urn:ogf:network:example.org:2014:foo:A1:in")+ (unode "nml:isSink")+ (unode "urn:ogf:network:example.org:2014:link:1")+ ]+ Nothing+ ( PrefixMappings+ ( Map.fromList+ [ ("nml", "http://schemas.ogf.org/nml/2013/05/base#"),+ ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#")+ ]+ )+ ) ) -- TODO: refactor out the following functions, since these are copied from TurtleParser_ConformanceTest -assertEquivalent :: Rdf a => String -> IO (Either ParseFailure (RDF a)) -> IO (Either ParseFailure (RDF a)) -> TU.Assertion+assertEquivalent :: (Rdf a) => String -> IO (Either ParseFailure (RDF a)) -> IO (Either ParseFailure (RDF a)) -> TU.Assertion assertEquivalent testname r1 r2 = do gr1 <- r1 gr2 <- r2 case equivalent gr1 gr2 of- Nothing -> return ()+ Nothing -> return () (Just msg) -> fail $ "Graph " <> testname <> " not equivalent to expected:\n" <> msg -- Determines if graphs are equivalent, returning Nothing if so or else a diagnostic message. -- First graph is expected graph, second graph is actual.-equivalent :: Rdf a => Either ParseFailure (RDF a) -> Either ParseFailure (RDF a) -> Maybe String-equivalent (Left _) _ = Nothing-equivalent _ (Left _) = Nothing-equivalent (Right gr1) (Right gr2) = test $! zip gr1ts gr2ts+equivalent :: (Rdf a) => Either ParseFailure (RDF a) -> Either ParseFailure (RDF a) -> Maybe String+equivalent (Left _) _ = Nothing+equivalent _ (Left _) = Nothing+equivalent (Right gr1) (Right gr2) = test $! zip gr1ts gr2ts where gr1ts = uordered $ uniqTriplesOf gr1 -- triplesOf gr1 gr2ts = uordered $ uniqTriplesOf gr2 -- triplesOf gr2- test [] = Nothing- test ((t1,t2):ts) =+ test [] = Nothing+ test ((t1, t2) : ts) = case compareTriple t1 t2 of Nothing -> test ts- err -> err+ err -> err compareTriple t1 t2 = if equalNodes s1 s2 && equalNodes p1 p2 && equalNodes o1 o2 then Nothing@@ -398,13 +492,13 @@ equalNodes (BNodeGen _) (BNode _) = True equalNodes (BNodeGen _) (BNodeGen _) = True equalNodes (BNode _) (BNode _) = True- equalNodes n1 n2 = n1 == n2+ equalNodes n1 n2 = n1 == n2 assertLoadSuccess :: String -> IO (Either ParseFailure (RDF TList)) -> TU.Assertion assertLoadSuccess idStr exprGr = do g <- exprGr case g of- Left (ParseFailure err) -> TU.assertFailure $ idStr <> err+ Left (ParseFailure err) -> TU.assertFailure $ idStr <> err Right _ -> return () -- assertLoadFailure idStr exprGr = do@@ -413,24 +507,24 @@ -- Left _ -> return () -- Right _ -> TU.assertFailure $ "Bad test " <> idStr <> " loaded successfully." -handleLoad :: Either ParseFailure (RDF TList) -> Either ParseFailure (RDF TList)-handleLoad res =- case res of- l@(Left _) -> l- (Right gr) -> Right $ mkRdf (fmap normalize (triplesOf gr)) (baseUrl gr) (prefixMappings gr)+-- handleLoad :: Either ParseFailure (RDF TList) -> Either ParseFailure (RDF TList)+-- handleLoad res =+-- case res of+-- l@(Left _) -> l+-- (Right gr) -> Right $ mkRdf (fmap normalize (triplesOf gr)) (baseUrl gr) (prefixMappings gr) -normalize :: Triple -> Triple-normalize t = let s' = normalizeN $ subjectOf t- p' = normalizeN $ predicateOf t- o' = normalizeN $ objectOf t- in triple s' p' o'-normalizeN :: Node -> Node-normalizeN (BNodeGen i) = BNode (T.pack $ "_:genid" <> show i)-normalizeN n = n+-- normalize :: Triple -> Triple+-- normalize t = let s' = normalizeN $ subjectOf t+-- p' = normalizeN $ predicateOf t+-- o' = normalizeN $ objectOf t+-- in triple s' p' o'+-- normalizeN :: Node -> Node+-- normalizeN (BNodeGen i) = BNode (T.pack $ "_:genid" <> show i)+-- normalizeN n = n -- The Base URI to be used for all conformance tests: testBaseUri :: String-testBaseUri = "http://www.w3.org/2001/sw/DataAccess/df1/tests/"+testBaseUri = "http://www.w3.org/2001/sw/DataAccess/df1/tests/" mkDocUrl1 :: String -> String -> String -> Maybe T.Text mkDocUrl1 baseDocUrl dir fname = Just . T.pack $ printf "%s/%s/%s.rdf" baseDocUrl dir fname
testsuite/tests/W3C/Manifest.hs view
@@ -1,112 +1,120 @@ {-# LANGUAGE OverloadedStrings #-} -module W3C.Manifest (- loadManifest,-- Manifest(..),- TestEntry(..)-) where+module W3C.Manifest+ ( loadManifest,+ Manifest (..),+ TestEntry (..),+ )+where -import Data.Semigroup ((<>))+import qualified Data.List as L (find)+import Data.Maybe (fromJust) import Data.RDF.Graph.TList-import Data.RDF.Query-import Data.RDF.Types import Data.RDF.Namespace (mkUri, rdfs) import qualified Data.RDF.Namespace as NS+import Data.RDF.Query+import Data.RDF.Types+import qualified Data.Text as T import Safe import Text.RDF.RDF4H.TurtleParser -import qualified Data.Text as T-import qualified Data.List as L (find)-import Data.Maybe (fromJust)- -- | Manifest data as represented in W3C test files.-data Manifest =- Manifest {- description :: T.Text,- entries :: [TestEntry]- }+data Manifest = Manifest+ { description :: T.Text,+ entries :: [TestEntry]+ } -- TODO: Fields `name` and `action` are mandatory for all tests, -- `result` is mandatory for positive *Eval tests, -- the rest are optional, so we should use "Maybe" for them.-data TestEntry =- TestTurtleEval {- name :: T.Text,- comment :: T.Text,- approval :: Node,- action :: Node,- result :: Node- } |- TestTurtleNegativeEval {- name :: T.Text,- comment :: T.Text,- approval :: Node,- action :: Node- } |- TestTurtlePositiveSyntax {- name :: T.Text,- comment :: T.Text,- approval :: Node,- action :: Node- } |- TestTurtleNegativeSyntax {- name :: T.Text,- comment :: T.Text,- approval :: Node,- action :: Node- } |- PositiveEntailmentTest {- name :: T.Text,- comment :: T.Text,- approval :: Node,- action :: Node,- result :: Node,- entailmentRegime :: T.Text,- recognizedDatatypes :: [Node],- unrecognizedDatatypes :: [Node]- } |- NegativeEntailmentTest {- name :: T.Text,- comment :: T.Text,- approval :: Node,- action :: Node,- result :: Node,- entailmentRegime :: T.Text,- recognizedDatatypes :: [Node],- unrecognizedDatatypes :: [Node]- } |- TestXMLEval {- name :: T.Text,- comment :: T.Text,- approval :: Node,- action :: Node,- result :: Node- } |- TestXMLNegativeSyntax {- name :: T.Text,- comment :: T.Text,- approval :: Node,- action :: Node- } |- TestNTriplesPositiveSyntax {- name :: T.Text,- comment :: T.Text,- approval :: Node,- action :: Node- } |- TestNTriplesNegativeSyntax {- name :: T.Text,- comment :: T.Text,- approval :: Node,- action :: Node- }- deriving (Show)+data TestEntry+ = TestTurtleEval+ { name :: T.Text,+ comment :: T.Text,+ approval :: Node,+ action :: Node,+ result :: Node+ }+ | TestTurtleNegativeEval+ { name :: T.Text,+ comment :: T.Text,+ approval :: Node,+ action :: Node+ }+ | TestTurtlePositiveSyntax+ { name :: T.Text,+ comment :: T.Text,+ approval :: Node,+ action :: Node+ }+ | TestTurtleNegativeSyntax+ { name :: T.Text,+ comment :: T.Text,+ approval :: Node,+ action :: Node+ }+ | PositiveEntailmentTest+ { name :: T.Text,+ comment :: T.Text,+ approval :: Node,+ action :: Node,+ result :: Node,+ entailmentRegime :: T.Text,+ recognizedDatatypes :: [Node],+ unrecognizedDatatypes :: [Node]+ }+ | NegativeEntailmentTest+ { name :: T.Text,+ comment :: T.Text,+ approval :: Node,+ action :: Node,+ result :: Node,+ entailmentRegime :: T.Text,+ recognizedDatatypes :: [Node],+ unrecognizedDatatypes :: [Node]+ }+ | TestXMLEval+ { name :: T.Text,+ comment :: T.Text,+ approval :: Node,+ action :: Node,+ result :: Node+ }+ | TestXMLNegativeSyntax+ { name :: T.Text,+ comment :: T.Text,+ approval :: Node,+ action :: Node+ }+ | TestNTriplesPositiveSyntax+ { name :: T.Text,+ comment :: T.Text,+ approval :: Node,+ action :: Node+ }+ | TestNTriplesNegativeSyntax+ { name :: T.Text,+ comment :: T.Text,+ approval :: Node,+ action :: Node+ }+ 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,+ rdfsComment,+ rdfsLabel,+ rdftApproval,+ rdfsApproval,+ mfName,+ mfManifest,+ mfAction,+ mfResult,+ mfEntries,+ mfEntailmentRegime,+ mfRecognizedDatatypes,+ mfUnrecognizedDatatypes ::+ Node rdfType = unode $ mkUri NS.rdf "type" rdfsComment = unode $ mkUri rdfs "comment" rdfsLabel = unode $ mkUri rdfs "label"@@ -128,18 +136,21 @@ loadManifest :: T.Text -> T.Text -> IO Manifest loadManifest manifestPath baseIRI = (rdfToManifest . fromEither) <$> parseFile testParser (T.unpack manifestPath)- where testParser = TurtleParser (Just $ BaseUrl baseIRI) Nothing+ where+ testParser = TurtleParser (Just $ BaseUrl baseIRI) Nothing rdfToManifest :: RDF TList -> 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 rdfsLabel) Nothing- <> query rdf (Just manifestNode) (Just mfName) Nothing--- descNode = query rdf (Just manifestNode) (Just mfName) Nothing- tpls = (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+ 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 rdfsLabel) Nothing+ <> query rdf (Just manifestNode) (Just mfName) Nothing+ -- descNode = query rdf (Just manifestNode) (Just mfName) Nothing+ tpls = (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 :: RDF TList -> Node -> TestEntry rdfToTestEntry rdf teSubject = triplesToTestEntry rdf $ query rdf (Just teSubject) Nothing Nothing@@ -160,110 +171,122 @@ n -> error ("Unknown test case: " <> show n) mkTestTurtleEval :: Triples -> TestEntry-mkTestTurtleEval ts = TestTurtleEval {- name = lnodeText $ objectByPredicate mfName ts,- comment = lnodeText $ objectByPredicate rdfsComment ts,- approval = objectByPredicate rdftApproval ts,- action = objectByPredicate mfAction ts,- result = objectByPredicate mfResult ts- }+mkTestTurtleEval ts =+ TestTurtleEval+ { name = lnodeText $ objectByPredicate mfName ts,+ comment = lnodeText $ objectByPredicate rdfsComment ts,+ approval = objectByPredicate rdftApproval ts,+ action = objectByPredicate mfAction ts,+ result = objectByPredicate mfResult ts+ } mkTestTurtleNegativeEval :: Triples -> TestEntry-mkTestTurtleNegativeEval ts = TestTurtleNegativeEval {- name = lnodeText $ objectByPredicate mfName ts,- comment = lnodeText $ objectByPredicate rdfsComment ts,- approval = objectByPredicate rdftApproval ts,- action = objectByPredicate mfAction ts- }+mkTestTurtleNegativeEval ts =+ TestTurtleNegativeEval+ { name = lnodeText $ objectByPredicate mfName ts,+ comment = lnodeText $ objectByPredicate rdfsComment ts,+ approval = objectByPredicate rdftApproval ts,+ action = objectByPredicate mfAction ts+ } mkTestTurtlePositiveSyntax :: Triples -> TestEntry-mkTestTurtlePositiveSyntax ts = TestTurtlePositiveSyntax {- name = lnodeText $ objectByPredicate mfName ts,- comment = lnodeText $ objectByPredicate rdfsComment ts,- approval = objectByPredicate rdftApproval ts,- action = objectByPredicate mfAction ts- }+mkTestTurtlePositiveSyntax ts =+ TestTurtlePositiveSyntax+ { name = lnodeText $ objectByPredicate mfName ts,+ comment = lnodeText $ objectByPredicate rdfsComment ts,+ approval = objectByPredicate rdftApproval ts,+ action = objectByPredicate mfAction ts+ } mkTestTurtleNegativeSyntax :: Triples -> TestEntry-mkTestTurtleNegativeSyntax ts = TestTurtleNegativeSyntax {- name = lnodeText $ objectByPredicate mfName ts,- comment = lnodeText $ objectByPredicate rdfsComment ts,- approval = objectByPredicate rdftApproval ts,- action = objectByPredicate mfAction ts- }+mkTestTurtleNegativeSyntax ts =+ TestTurtleNegativeSyntax+ { name = lnodeText $ objectByPredicate mfName ts,+ comment = lnodeText $ objectByPredicate rdfsComment ts,+ approval = objectByPredicate rdftApproval ts,+ action = objectByPredicate mfAction ts+ } mkPositiveEntailmentTest :: Triples -> RDF TList -> TestEntry-mkPositiveEntailmentTest ts rdf = PositiveEntailmentTest {- name = lnodeText $ objectByPredicate mfName ts,- comment = lnodeText $ objectByPredicate rdfsComment ts,- -- FIXME: incorrect namespace "rdfs:approval" in rdf-mt/manifest.ttl- -- approval = objectByPredicate rdftApproval ts,- approval = objectByPredicate rdfsApproval ts,- action = objectByPredicate mfAction ts,- result = objectByPredicate mfResult ts,- entailmentRegime = lnodeText $ objectByPredicate mfEntailmentRegime ts,- recognizedDatatypes = rDT,- unrecognizedDatatypes = uDT- }- where rDT = rdfCollectionToList rdf rDTCollectionHead- rDTCollectionHead = objectByPredicate mfRecognizedDatatypes ts- uDT = rdfCollectionToList rdf uDTCollectionHead- uDTCollectionHead = objectByPredicate mfUnrecognizedDatatypes ts+mkPositiveEntailmentTest ts rdf =+ PositiveEntailmentTest+ { name = lnodeText $ objectByPredicate mfName ts,+ comment = lnodeText $ objectByPredicate rdfsComment ts,+ -- FIXME: incorrect namespace "rdfs:approval" in rdf-mt/manifest.ttl+ -- approval = objectByPredicate rdftApproval ts,+ approval = objectByPredicate rdfsApproval ts,+ action = objectByPredicate mfAction ts,+ result = objectByPredicate mfResult ts,+ entailmentRegime = lnodeText $ objectByPredicate mfEntailmentRegime ts,+ recognizedDatatypes = rDT,+ unrecognizedDatatypes = uDT+ }+ where+ rDT = rdfCollectionToList rdf rDTCollectionHead+ rDTCollectionHead = objectByPredicate mfRecognizedDatatypes ts+ uDT = rdfCollectionToList rdf uDTCollectionHead+ uDTCollectionHead = objectByPredicate mfUnrecognizedDatatypes ts mkNegativeEntailmentTest :: Triples -> RDF TList -> TestEntry-mkNegativeEntailmentTest ts rdf = NegativeEntailmentTest {- name = lnodeText $ objectByPredicate mfName ts,- comment = lnodeText $ objectByPredicate rdfsComment ts,- -- FIXME: incorrect namespace "rdfs:approval" in rdf-mt/manifest.ttl- -- approval = objectByPredicate rdftApproval ts,- approval = objectByPredicate rdfsApproval ts,- action = objectByPredicate mfAction ts,- result = objectByPredicate mfResult ts,- entailmentRegime = lnodeText $ objectByPredicate mfEntailmentRegime ts,- recognizedDatatypes = rDT,- unrecognizedDatatypes = uDT- }- where rDT = rdfCollectionToList rdf rDTCollectionHead- rDTCollectionHead = objectByPredicate mfRecognizedDatatypes ts- uDT = rdfCollectionToList rdf uDTCollectionHead- uDTCollectionHead = objectByPredicate mfUnrecognizedDatatypes ts+mkNegativeEntailmentTest ts rdf =+ NegativeEntailmentTest+ { name = lnodeText $ objectByPredicate mfName ts,+ comment = lnodeText $ objectByPredicate rdfsComment ts,+ -- FIXME: incorrect namespace "rdfs:approval" in rdf-mt/manifest.ttl+ -- approval = objectByPredicate rdftApproval ts,+ approval = objectByPredicate rdfsApproval ts,+ action = objectByPredicate mfAction ts,+ result = objectByPredicate mfResult ts,+ entailmentRegime = lnodeText $ objectByPredicate mfEntailmentRegime ts,+ recognizedDatatypes = rDT,+ unrecognizedDatatypes = uDT+ }+ where+ rDT = rdfCollectionToList rdf rDTCollectionHead+ rDTCollectionHead = objectByPredicate mfRecognizedDatatypes ts+ uDT = rdfCollectionToList rdf uDTCollectionHead+ uDTCollectionHead = objectByPredicate mfUnrecognizedDatatypes ts mkTestXMLEval :: Triples -> TestEntry-mkTestXMLEval ts = TestXMLEval {- name = lnodeText $ objectByPredicate mfName ts,- comment = lnodeText $ objectByPredicate rdfsComment ts,- -- FIXME: incorrect namespace "rdfs:approval" in rdf-mt/manifest.ttl- -- approval = objectByPredicate rdftApproval ts,- approval = objectByPredicate rdfsApproval ts,- action = objectByPredicate mfAction ts,- result = objectByPredicate mfResult ts- }+mkTestXMLEval ts =+ TestXMLEval+ { name = lnodeText $ objectByPredicate mfName ts,+ comment = lnodeText $ objectByPredicate rdfsComment ts,+ -- FIXME: incorrect namespace "rdfs:approval" in rdf-mt/manifest.ttl+ -- approval = objectByPredicate rdftApproval ts,+ approval = objectByPredicate rdfsApproval ts,+ action = objectByPredicate mfAction ts,+ result = objectByPredicate mfResult ts+ } mkTestXMLNegativeSyntax :: Triples -> TestEntry-mkTestXMLNegativeSyntax ts = TestXMLNegativeSyntax {- name = lnodeText $ objectByPredicate mfName ts,- comment = lnodeText $ objectByPredicate rdfsComment ts,- -- FIXME: incorrect namespace "rdfs:approval" in rdf-mt/manifest.ttl- -- approval = objectByPredicate rdftApproval ts- approval = objectByPredicate rdfsApproval ts,- action = objectByPredicate mfAction ts- }+mkTestXMLNegativeSyntax ts =+ TestXMLNegativeSyntax+ { name = lnodeText $ objectByPredicate mfName ts,+ comment = lnodeText $ objectByPredicate rdfsComment ts,+ -- FIXME: incorrect namespace "rdfs:approval" in rdf-mt/manifest.ttl+ -- approval = objectByPredicate rdftApproval ts+ approval = objectByPredicate rdfsApproval ts,+ action = objectByPredicate mfAction ts+ } mkTestNTriplesPositiveSyntax :: Triples -> TestEntry-mkTestNTriplesPositiveSyntax ts = TestNTriplesPositiveSyntax {- name = lnodeText $ objectByPredicate mfName ts,- comment = lnodeText $ objectByPredicate rdfsComment ts,- approval = objectByPredicate rdftApproval ts,- action = objectByPredicate mfAction ts- }+mkTestNTriplesPositiveSyntax ts =+ TestNTriplesPositiveSyntax+ { name = lnodeText $ objectByPredicate mfName ts,+ comment = lnodeText $ objectByPredicate rdfsComment ts,+ approval = objectByPredicate rdftApproval ts,+ action = objectByPredicate mfAction ts+ } mkTestNTriplesNegativeSyntax :: Triples -> TestEntry-mkTestNTriplesNegativeSyntax ts = TestNTriplesNegativeSyntax {- name = lnodeText $ objectByPredicate mfName ts,- comment = lnodeText $ objectByPredicate rdfsComment ts,- approval = objectByPredicate rdftApproval ts,- action = objectByPredicate mfAction ts- }+mkTestNTriplesNegativeSyntax ts =+ TestNTriplesNegativeSyntax+ { name = lnodeText $ objectByPredicate mfName ts,+ comment = lnodeText $ objectByPredicate rdfsComment ts,+ approval = objectByPredicate rdftApproval ts,+ action = objectByPredicate mfAction ts+ } -- Filter the triples by given predicate and return the object of the first found triple. -- Raises an exception on errors.@@ -275,15 +298,16 @@ subjectNodes :: RDF TList -> [Object] -> [Subject] subjectNodes rdf = (fmap subjectOf) . concatMap queryType- where queryType n = query rdf Nothing (Just rdfType) (Just n)+ where+ queryType n = query rdf Nothing (Just rdfType) (Just n) -- | Text of the literal node. -- Note that it doesn't perform type conversion for TypedL. -- TODO: Looks useful. Move it to RDF4H lib? lnodeText :: Node -> T.Text-lnodeText (LNode(PlainL t)) = t-lnodeText (LNode(PlainLL t _)) = t-lnodeText (LNode(TypedL t _)) = t+lnodeText (LNode (PlainL t)) = t+lnodeText (LNode (PlainLL t _)) = t+lnodeText (LNode (TypedL t _)) = t lnodeText _ = error "Not a literal node" -- | Convert an RDF collection to a List of its objects.@@ -299,12 +323,12 @@ -- | (all triples with <rdf:first> and <rdf:rest> pairs). -- TODO: Looks useful. Move it to RDF4H lib? rdfCollectionToList :: RDF TList -> Node -> [Node]-rdfCollectionToList _ (UNode("http://www.w3.org/1999/02/22-rdf-syntax-ns#nil")) = []+rdfCollectionToList _ (UNode ("http://www.w3.org/1999/02/22-rdf-syntax-ns#nil")) = [] rdfCollectionToList rdf tip = concatMap (tripleToList rdf) $ nextCollectionTriples rdf tip tripleToList :: RDF TList -> 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 _ (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 :: RDF TList -> Node -> Triples
testsuite/tests/W3C/RdfXmlTest.hs view
@@ -1,25 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} module W3C.RdfXmlTest- ( tests- , mfBaseURIXml- ) where+ ( tests,+ mfBaseURIXml,+ )+where -import Data.Semigroup ((<>)) import Data.Maybe (fromJust)+import Data.RDF.Graph.TList+import Data.RDF.Query+import Data.RDF.Types+import qualified Data.Text as T import Test.Tasty import qualified Test.Tasty.HUnit as TU-import qualified Data.Text as T-+import Text.RDF.RDF4H.NTriplesParser+import Text.RDF.RDF4H.XmlParser 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.Graph.TList- tests :: String -> Manifest -> TestTree tests = runManifestTests . mfEntryToTest @@ -32,18 +30,19 @@ mfEntryToTest dir (TestXMLEval nm _ _ act res) = let pathExpected = getFilePath dir res pathAction = getFilePath dir act- parsedRDF = (fromEither <$> parseFile (testParser (nodeURI act)) pathAction) :: IO (RDF TList)+ parsedRDF = (fromEither <$> parseFile (testParser (nodeURI act)) pathAction) :: IO (RDF TList) expectedRDF = (fromEither <$> parseFile NTriplesParser pathExpected) :: IO (RDF TList)- in TU.testCase (T.unpack nm) $ assertIsIsomorphic parsedRDF expectedRDF+ in TU.testCase (T.unpack nm) $ assertIsIsomorphic parsedRDF expectedRDF mfEntryToTest dir (TestXMLNegativeSyntax nm _ _ act) = let pathAction = getFilePath dir act rdf = parseFile (testParser (nodeURI act)) pathAction :: IO (Either ParseFailure (RDF TList))- in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf+ in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf mfEntryToTest _ x = error $ "unknown TestEntry pattern in mfEntryToTest: " <> show x getFilePath :: String -> Node -> String getFilePath dir (UNode iri) = fixFilePath' iri- where fixFilePath' = (dir <>) . T.unpack . fromJust . T.stripPrefix (unBaseUrl mfBaseURIXml)+ where+ fixFilePath' = (dir <>) . T.unpack . fromJust . T.stripPrefix (unBaseUrl mfBaseURIXml) getFilePath _ _ = error "Unexpected node" mfBaseURIXml :: BaseUrl
testsuite/tests/W3C/TurtleTest.hs view
@@ -1,27 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} module W3C.TurtleTest- ( testsParsec- , testsAttoparsec- , mfBaseURITurtle- ) where--import Test.Tasty-import qualified Test.Tasty.HUnit as TU+ ( testsParsec,+ testsAttoparsec,+ mfBaseURITurtle,+ )+where -import Data.Semigroup ((<>)) import Data.Maybe (fromJust)-import qualified Data.Text as T--import W3C.Manifest-import W3C.W3CAssertions--import Data.RDF.Types+import Data.RDF.Graph.TList import Data.RDF.Query-import Text.RDF.RDF4H.TurtleParser+import Data.RDF.Types+import qualified Data.Text as T+import Test.Tasty+import qualified Test.Tasty.HUnit as TU import Text.RDF.RDF4H.NTriplesParser import Text.RDF.RDF4H.ParserUtils-import Data.RDF.Graph.TList+import Text.RDF.RDF4H.TurtleParser+import W3C.Manifest+import W3C.W3CAssertions testsParsec :: String -> Manifest -> TestTree testsParsec = runManifestTests . (`mfEntryToTest` testParserParsec)@@ -33,21 +30,21 @@ mfEntryToTest dir parser (TestTurtleEval nm _ _ act res) = let pathExpected = getFilePath dir res pathAction = getFilePath dir act- parsedRDF = (fromEither <$> parseFile (parser (nodeURI act)) pathAction) :: IO (RDF TList)+ parsedRDF = (fromEither <$> parseFile (parser (nodeURI act)) pathAction) :: IO (RDF TList) expectedRDF = (fromEither <$> parseFile NTriplesParser pathExpected) :: IO (RDF TList)- in TU.testCase (T.unpack nm) $ assertIsIsomorphic parsedRDF expectedRDF+ in TU.testCase (T.unpack nm) $ assertIsIsomorphic parsedRDF expectedRDF mfEntryToTest dir parser (TestTurtleNegativeEval nm _ _ act) = let pathAction = getFilePath dir act rdf = parseFile (parser (nodeURI act)) pathAction :: IO (Either ParseFailure (RDF TList))- in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf+ in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf mfEntryToTest dir parser (TestTurtlePositiveSyntax nm _ _ act) = let pathAction = getFilePath dir act rdf = parseFile (parser (nodeURI act)) pathAction :: IO (Either ParseFailure (RDF TList))- in TU.testCase (T.unpack nm) $ assertIsParsed rdf+ in TU.testCase (T.unpack nm) $ assertIsParsed rdf mfEntryToTest dir parser (TestTurtleNegativeSyntax nm _ _ act) = let pathAction = getFilePath dir act rdf = parseFile (parser (nodeURI act)) pathAction :: IO (Either ParseFailure (RDF TList))- in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf+ in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf mfEntryToTest _ _ x = error $ "unknown TestEntry pattern in mfEntryToTest: " <> show x -- [NOTE] Was previously: http://www.w3.org/2013/TurtleTests/@@ -65,5 +62,6 @@ getFilePath :: String -> Node -> String getFilePath dir (UNode iri) = fixFilePath' iri- where fixFilePath' = (dir <>) . T.unpack . fromJust . T.stripPrefix (unBaseUrl mfBaseURITurtle)+ where+ fixFilePath' = (dir <>) . T.unpack . fromJust . T.stripPrefix (unBaseUrl mfBaseURITurtle) getFilePath _ _ = error "Unexpected node"