rdf4h 4.0.0 → 4.0.1
raw patch · 21 files changed
+901/−590 lines, 21 filesdep ~algebraic-graphsdep ~http-conduit
Dependency ranges changed: algebraic-graphs, http-conduit
Files
- bench/MainCriterion.hs +7/−1
- examples/BuildRDFGraph.hs +24/−0
- rdf4h.cabal +16/−10
- src/Data/RDF/Graph/AdjHashMap.hs +8/−1
- src/Data/RDF/Graph/AlgebraicGraph.hs +46/−42
- src/Data/RDF/Graph/TList.hs +8/−1
- src/Data/RDF/IRI.hs +13/−1
- src/Data/RDF/Namespace.hs +16/−3
- src/Data/RDF/Query.hs +135/−83
- src/Data/RDF/Types.hs +8/−1
- src/Rdf4hParseMain.hs +144/−121
- src/Text/RDF/RDF4H/NTriplesParser.hs +8/−0
- src/Text/RDF/RDF4H/ParserUtils.hs +7/−1
- src/Text/RDF/RDF4H/TurtleParser.hs +254/−199
- src/Text/RDF/RDF4H/TurtleSerializer.hs +86/−70
- src/Text/RDF/RDF4H/XmlParser.hs +13/−4
- src/Text/RDF/RDF4H/XmlParser/Identifiers.hs +10/−1
- src/Text/RDF/RDF4H/XmlParser/Xeno.hs +4/−0
- src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs +22/−6
- testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs +71/−45
- testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs +1/−0
bench/MainCriterion.hs view
@@ -4,7 +4,13 @@ module Main where import Prelude hiding (readFile)-import Data.Semigroup (Semigroup(..))+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#else+#endif+#else+#endif import Criterion import Criterion.Types import Criterion.Main
+ examples/BuildRDFGraph.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where+import Data.RDF++main :: IO ()+main = do+ -- create an empty RDF graph to be backed by a list based+ -- implementation of the graph+ let myEmptyGraph = empty :: RDF TList+ -- add a triple to the empty graph+ triple1 = triple+ (unode "http://www.example.com/rob")+ (unode "http://xmlns.com/foaf/0.1/interest")+ (unode "http://dbpedia.org/resource/Scotch_whisky")+ graph1 = addTriple myEmptyGraph triple1+ -- add another triple to the graph+ triple2 = triple+ (unode "http://www.example.com/rob")+ (unode "http://xmlns.com/foaf/0.1/interest")+ (unode "http://dbpedia.org/resource/Haskell_(programming_language)")+ graph2 = addTriple graph1 triple2+ -- remove one of my interests+ graph3 = removeTriple graph2 triple1+ putStrLn (showGraph graph3)
rdf4h.cabal view
@@ -1,12 +1,13 @@ name: rdf4h-version: 4.0.0+version: 4.0.1 synopsis: A library for RDF processing in Haskell description: 'RDF for Haskell' is a library for working with RDF in Haskell.- At present it includes parsers and serializers for RDF in the N-Triples- and Turtle, and parsing support for RDF/XML. It provides abilities such as querying- for triples containing a particular subject, predicate, or object, or- selecting triples that satisfy an arbitrary predicate function.+ It includes RDF parsers and serializers for N-Triples+ and Turtle, and an RDF parser for RDF/XML. It provides the ability to query+ for triples containing a particular subject, predicate, or object, or+ selecting triples that satisfy an arbitrary predicate function. It+ also supports IRI parsing and resolution. author: Rob Stewart, Pierre Le Marre, Slava Kravchenko, Calvin Smith copyright: (c) Rob Stewart, Pierre Le Marre, Slava Kravchenko, Calvin Smith, Renzo Carbonara@@ -15,20 +16,22 @@ bug-reports: https://github.com/robstewart57/rdf4h/issues license: BSD3 license-file: LICENSE.txt-cabal-version: >= 1.8+cabal-version: >= 1.10 build-type: Simple category: RDF-stability: Experimental-tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.8.2, GHC==8.4.3, GHC==8.6.5+stability: stable+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.3, GHC==8.6.5, GHC==8.8.3 extra-tmp-files: test extra-source-files: examples/ParseURLs.hs , examples/ESWC.hs+ , examples/BuildRDFGraph.hs source-repository head type: git location: https://github.com/robstewart57/rdf4h.git library+ default-language: Haskell2010 hs-source-dirs: src exposed-modules: Data.RDF , Data.RDF.IRI@@ -54,7 +57,7 @@ -- , HTTP >= 4000.0.0 -- , hxt >= 9.3.1.2 , text >= 1.2.1.0- , algebraic-graphs >= 0.3 && < 0.5+ , algebraic-graphs >= 0.5 , unordered-containers >= 0.2.10.0 , hashable , deepseq@@ -66,7 +69,7 @@ -- , xmlbf >= 0.6 -- , xmlbf-xeno , lifted-base- , http-conduit+ , http-conduit >= 2.2.0 , mmorph , exceptions , selective@@ -82,6 +85,7 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints executable rdf4h+ default-language: Haskell2010 main-is: src/Rdf4hParseMain.hs build-depends: base >= 4.8.0.0 && < 6 , rdf4h@@ -94,6 +98,7 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints test-suite test-rdf4h+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Test.hs hs-source-dirs: testsuite/tests@@ -128,6 +133,7 @@ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints benchmark rdf4h-bench+ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: MainCriterion.hs
src/Data/RDF/Graph/AdjHashMap.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-}@@ -12,7 +13,13 @@ module Data.RDF.Graph.AdjHashMap (AdjHashMap) where import Prelude hiding (pred)-import Data.Semigroup ((<>))+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#else+#endif+#else+#endif import Data.List import Data.Binary (Binary) import Data.RDF.Types
src/Data/RDF/Graph/AlgebraicGraph.hs view
@@ -1,57 +1,61 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} -- [TODO] Remove when the missing NFData instance is added to Alga.-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} +-- [TODO] Remove when the missing NFData instance is added to Alga. module Data.RDF.Graph.AlgebraicGraph- ( AlgebraicGraph- ) where-+ ( AlgebraicGraph,+ )+where -import Data.Semigroup (Semigroup(..))-import Control.DeepSeq (NFData(..))-import Data.Binary-import Data.RDF.Namespace-import Data.RDF.Query-import Data.RDF.Types (RDF, Rdf(..), BaseUrl, Triples, Triple(..), Node, Subject, Predicate, Object, NodeSelector) import qualified Algebra.Graph.Labelled as G+import Control.DeepSeq (NFData (..))+import Data.Binary import Data.HashSet (HashSet) import qualified Data.HashSet as HS+import Data.RDF.Namespace+import Data.RDF.Query+import Data.RDF.Types (BaseUrl, Node, NodeSelector, Object, Predicate, RDF, Rdf (..), Subject, Triple (..), Triples)+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#else+#endif+#else+#endif import GHC.Generics - data AlgebraicGraph deriving (Generic) instance Binary AlgebraicGraph-instance NFData AlgebraicGraph -data instance RDF AlgebraicGraph = AlgebraicGraph- { _graph :: G.Graph (HashSet Node) Node- , _baseUrl :: Maybe BaseUrl- , _prefixMappings :: PrefixMappings- } deriving (Generic, NFData)+instance NFData AlgebraicGraph --- [TODO] Remove this orphan instance when the missing NFData instance is added to Alga.-instance (NFData e, NFData a) => NFData (G.Graph e a) where- rnf G.Empty = ()- rnf (G.Vertex x ) = rnf x- rnf (G.Connect e x y) = e `seq` rnf x `seq` rnf y+data instance RDF AlgebraicGraph+ = AlgebraicGraph+ { _graph :: G.Graph (HashSet Node) Node,+ _baseUrl :: Maybe BaseUrl,+ _prefixMappings :: PrefixMappings+ }+ deriving (Generic, NFData) instance Rdf AlgebraicGraph where- baseUrl = _baseUrl- prefixMappings = _prefixMappings+ baseUrl = _baseUrl+ prefixMappings = _prefixMappings addPrefixMappings = addPrefixMappings'- empty = empty'- mkRdf = mkRdf'- addTriple = addTriple'- removeTriple = removeTriple'- triplesOf = triplesOf'- uniqTriplesOf = triplesOf'- select = select'- query = query'- showGraph = showGraph'+ empty = empty'+ mkRdf = mkRdf'+ addTriple = addTriple'+ removeTriple = removeTriple'+ triplesOf = triplesOf'+ uniqTriplesOf = triplesOf'+ select = select'+ query = query'+ showGraph = showGraph' toEdge :: Triple -> (HashSet Predicate, Subject, Object) toEdge (Triple s p o) = (HS.singleton p, s, o)@@ -65,7 +69,7 @@ addPrefixMappings' :: RDF AlgebraicGraph -> PrefixMappings -> Bool -> RDF AlgebraicGraph addPrefixMappings' (AlgebraicGraph g baseURL pms) pms' replace = let merge = if replace then flip (<>) else (<>)- in AlgebraicGraph g baseURL (merge pms pms')+ in AlgebraicGraph g baseURL (merge pms pms') empty' :: RDF AlgebraicGraph empty' = AlgebraicGraph G.empty mempty (PrefixMappings mempty)@@ -73,21 +77,21 @@ mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> RDF AlgebraicGraph mkRdf' ts baseURL pms = let g = G.edges . fmap toEdge $ ts- in AlgebraicGraph g baseURL pms+ in AlgebraicGraph g baseURL pms addTriple' :: RDF AlgebraicGraph -> Triple -> RDF AlgebraicGraph addTriple' (AlgebraicGraph g baseURL pms) (Triple s p o) = let g' = G.edge (HS.singleton p) s o- in AlgebraicGraph (G.overlay g g') baseURL pms+ in AlgebraicGraph (G.overlay g g') baseURL pms removeTriple' :: RDF AlgebraicGraph -> Triple -> RDF AlgebraicGraph removeTriple' (AlgebraicGraph g baseURL pms) (Triple s p o) = let ps = G.edgeLabel s o g g' | HS.null ps = g- | elem p ps = G.replaceEdge (HS.delete p ps) s o g- | otherwise = g- in AlgebraicGraph g' baseURL pms+ | elem p ps = G.replaceEdge (HS.delete p ps) s o g+ | otherwise = g+ in AlgebraicGraph g' baseURL pms triplesOf' :: RDF AlgebraicGraph -> Triples triplesOf' (AlgebraicGraph g _ _) = mconcat $ toTriples <$> G.edgeList g@@ -96,7 +100,7 @@ select' r Nothing Nothing Nothing = triplesOf r select' (AlgebraicGraph g _ _) s p o = let (res, _, _) = G.foldg e v c g in res where- e = (mempty, mempty, mempty)+ e = (mempty, mempty, mempty) v x = (mempty, s ?? x, o ?? x) (??) f x' = let xs = HS.singleton x' in maybe xs (`HS.filter` xs) f c ps (ts1, ss1, os1) (ts2, ss2, os2) = (ts3, ss3, os3)@@ -105,7 +109,7 @@ os3 = os1 <> os2 ts3 | HS.null ps' = ts1 <> ts2- | otherwise = ts1 <> ts2 <> [Triple s' p' o' | s' <- HS.toList ss3, p' <- HS.toList ps', o' <- HS.toList os3]+ | otherwise = ts1 <> ts2 <> [Triple s' p' o' | s' <- HS.toList ss3, p' <- HS.toList ps', o' <- HS.toList os3] ps' = maybe ps (`HS.filter` ps) p query' :: RDF AlgebraicGraph -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples
src/Data/RDF/Graph/TList.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}@@ -19,7 +20,13 @@ module Data.RDF.Graph.TList (TList) where import Prelude-import Data.Semigroup ((<>))+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#else+#endif+#else+#endif import Control.DeepSeq (NFData) import Data.Binary import Data.RDF.Namespace
src/Data/RDF/IRI.hs view
@@ -19,8 +19,20 @@ , removeIRIFragment ) where -import Data.Semigroup (Semigroup(..))+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#else+#endif+#else+#endif++#if MIN_VERSION_base(4,13,0)+import Data.Maybe (isJust)+#else import Data.Maybe (maybe, isJust)+#endif+ import Data.Functor import Data.List (intersperse) import Control.Applicative
src/Data/RDF/Namespace.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- |Defines types and utility functions related to namespaces, and -- some predefined values for commonly used namespaces, such as -- rdf, xsd, dublin core, etc.@@ -13,10 +15,18 @@ 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.Semigroup ((<>))+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0)+ -- lts 10 says not needed+-- import Data.Semigroup+#else+#endif+#else+#endif standard_namespaces :: [Namespace] standard_namespaces = [rdf, rdfs, dc, dct, owl, xsd, skos, foaf, ex, ex2]@@ -27,8 +37,11 @@ -- |Takes a list of 'Namespace's and returns 'PrefixMappings'. ns_mappings :: [Namespace] -> PrefixMappings-ns_mappings ns = PrefixMappings $ Map.fromList $- fmap (\(PrefixedNS pre uri) -> (pre, uri)) ns+ns_mappings ns = PrefixMappings $ Map.fromList $ catMaybes $+ fmap (\n -> case n of+ (PrefixedNS pre uri) -> Just (pre, uri)+ PlainNS _ -> Nothing+ ) ns -- |The RDF namespace. rdf :: Namespace
src/Data/RDF/Query.hs view
@@ -1,129 +1,156 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module Data.RDF.Query (-- -- * Query functions- equalSubjects, equalPredicates, equalObjects,- subjectOf, predicateOf, objectOf, isEmpty,- rdfContainsNode, tripleContainsNode,- subjectsWithPredicate, objectsOfPredicate, uordered,+module Data.RDF.Query+ ( -- * Query functions+ equalSubjects,+ equalPredicates,+ equalObjects,+ subjectOf,+ predicateOf,+ objectOf,+ isEmpty,+ rdfContainsNode,+ tripleContainsNode,+ subjectsWithPredicate,+ objectsOfPredicate,+ uordered, - -- * RDF graph functions- isIsomorphic, isGraphIsomorphic, expandTriples, fromEither,+ -- * RDF graph functions+ isIsomorphic,+ isGraphIsomorphic,+ expandTriples,+ fromEither, - -- * expansion functions- expandTriple, expandNode, expandURI,+ -- * expansion functions+ expandTriple,+ expandNode,+ expandURI, - -- * absolutizing functions- absolutizeTriple, absolutizeNode-) where+ -- * absolutizing functions+ absolutizeTriple,+ absolutizeNode,+ absolutizeNodeUnsafe,+ QueryException(..)+ )+where -import Prelude hiding (pred)+import Control.Applicative ((<|>))+import Control.Exception+import Data.Graph (Graph, graphFromEdges)+import qualified Data.Graph.Automorphism as Automorphism+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap) import Data.List import Data.Maybe (fromMaybe)-import Data.Semigroup ((<>))-import Data.RDF.Types+import Data.RDF.IRI import qualified Data.RDF.Namespace as NS-import Data.Text (Text)+import Data.RDF.Types+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#else+#endif+#else+#endif+import Data.Text (Text) import qualified Data.Text as T-import Data.Graph (Graph,graphFromEdges)-import qualified Data.Graph.Automorphism as Automorphism-import qualified Data.HashMap.Strict as HashMap-import Data.HashMap.Strict (HashMap)-import Control.Applicative ((<|>))+import Prelude hiding (pred) --- |Answer the subject node of the triple.+-- | Answer the subject node of the triple. {-# INLINE subjectOf #-} subjectOf :: Triple -> Node subjectOf (Triple s _ _) = s --- |Answer the predicate node of the triple.+-- | Answer the predicate node of the triple. {-# INLINE predicateOf #-} predicateOf :: Triple -> Node predicateOf (Triple _ p _) = p --- |Answer the object node of the triple.+-- | Answer the object node of the triple. {-# INLINE objectOf #-} objectOf :: Triple -> Node-objectOf (Triple _ _ o) = o+objectOf (Triple _ _ o) = o --- |Answer if rdf contains node.+-- | Answer if rdf contains node. rdfContainsNode :: (Rdf a) => RDF a -> Node -> Bool rdfContainsNode rdf node = any (tripleContainsNode node) (triplesOf rdf) --- |Answer if triple contains node.--- Note that it doesn't perform namespace expansion!+-- | Answer if triple contains node.+-- Note that it doesn't perform namespace expansion! tripleContainsNode :: Node -> Triple -> Bool {-# INLINE tripleContainsNode #-} tripleContainsNode node (Triple s p o) = s == node || p == node || o == node --- |Determine whether two triples have equal subjects.--- Note that it doesn't perform namespace expansion!+-- | Determine whether two triples have equal subjects.+-- Note that it doesn't perform namespace expansion! equalSubjects :: Triple -> Triple -> Bool equalSubjects (Triple s1 _ _) (Triple s2 _ _) = s1 == s2 --- |Determine whether two triples have equal predicates.--- Note that it doesn't perform namespace expansion!+-- | Determine whether two triples have equal predicates.+-- Note that it doesn't perform namespace expansion! equalPredicates :: Triple -> Triple -> Bool equalPredicates (Triple _ p1 _) (Triple _ p2 _) = p1 == p2 --- |Determine whether two triples have equal objects.--- Note that it doesn't perform namespace expansion!+-- | Determine whether two triples have equal objects.+-- Note that it doesn't perform namespace expansion! equalObjects :: Triple -> Triple -> Bool equalObjects (Triple _ _ o1) (Triple _ _ o2) = o1 == o2 --- |Determines whether the 'RDF' contains zero triples.+-- | Determines whether the 'RDF' contains zero triples. isEmpty :: Rdf a => RDF a -> Bool isEmpty = null . triplesOf --- |Lists of all subjects of triples with the given predicate.+-- | Lists of all subjects of triples with the given predicate. 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.+-- | Lists of all objects of triples with the given predicate. 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--- and error and terminate if not.-fromEither :: Rdf a => Either ParseFailure (RDF a) -> RDF a-fromEither (Left err) = error (show err)+-- | Convert a parse result into an RDF if it was successful+-- and error and terminate if not.+fromEither :: Either ParseFailure (RDF a) -> RDF a+fromEither (Left err) = error (show err) fromEither (Right rdf) = rdf --- |Convert a list of triples into a sorted list of unique triples.+-- | Convert a list of triples into a sorted list of unique triples. uordered :: Triples -> Triples uordered = sort . nub -- graphFromEdges :: Ord key => [(node, key, [key])] -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex) --- |This determines if two RDF representations are equal regardless of blank--- node names, triple order and prefixes. In math terms, this is the \simeq--- latex operator, or ~=+-- | This determines if two RDF representations are equal regardless+-- of blank node names, triple order and prefixes. In math terms,+-- this is the \simeq latex operator, or ~= . Unsafe because it+-- assumes IRI resolution will succeed, may throw an+-- 'IRIResolutionException` exception. isIsomorphic :: (Rdf a, Rdf b) => RDF a -> RDF b -> Bool isIsomorphic g1 g2 = and $ zipWith compareTripleUnlessBlank (normalize g1) (normalize g2) where compareNodeUnlessBlank :: Node -> Node -> Bool- compareNodeUnlessBlank (BNode _) (BNode _) = True- compareNodeUnlessBlank (UNode n1) (UNode n2) = n1 == n2+ compareNodeUnlessBlank (BNode _) (BNode _) = True+ compareNodeUnlessBlank (UNode n1) (UNode n2) = n1 == n2 compareNodeUnlessBlank (BNodeGen i1) (BNodeGen i2) = i1 == i2- compareNodeUnlessBlank (LNode l1) (LNode l2) = l1 == l2- compareNodeUnlessBlank (BNodeGen _) (BNode _) = True- compareNodeUnlessBlank (BNode _) (BNodeGen _) = True- compareNodeUnlessBlank _ _ = False-+ compareNodeUnlessBlank (LNode l1) (LNode l2) = l1 == l2+ compareNodeUnlessBlank (BNodeGen _) (BNode _) = True+ compareNodeUnlessBlank (BNode _) (BNodeGen _) = True+ compareNodeUnlessBlank _ _ = False compareTripleUnlessBlank :: Triple -> Triple -> Bool compareTripleUnlessBlank (Triple s1 p1 o1) (Triple s2 p2 o2) =- compareNodeUnlessBlank s1 s2 &&- compareNodeUnlessBlank p1 p2 &&- compareNodeUnlessBlank o1 o2-+ compareNodeUnlessBlank s1 s2+ && compareNodeUnlessBlank p1 p2+ && compareNodeUnlessBlank o1 o2 normalize :: (Rdf a) => RDF a -> Triples normalize = sort . nub . expandTriples --- | Compares the structure of two graphs and returns 'True' if--- their graph structures are identical. This does not consider the nature of--- each node in the graph, i.e. the URI text of 'UNode' nodes, the generated--- index of a blank node, or the values in literal nodes.+-- | Compares the structure of two graphs and returns 'True' if their+-- graph structures are identical. This does not consider the nature+-- of each node in the graph, i.e. the URI text of 'UNode' nodes,+-- the generated index of a blank node, or the values in literal+-- nodes. Unsafe because it assumes IRI resolution will succeed, may+-- throw an 'IRIResolutionException` exception. isGraphIsomorphic :: (Rdf a, Rdf b) => RDF a -> RDF b -> Bool isGraphIsomorphic g1 g2 = Automorphism.isIsomorphic g1' g2' where@@ -133,40 +160,65 @@ rdfGraphToDataGraph g = dataGraph where triples = expandTriples g- triplesHashMap :: HashMap (Subject,Predicate) [Object]- triplesHashMap = HashMap.fromListWith (<>) [((s,p), [o]) | Triple s p o <- triples]- triplesGrouped :: [((Subject,Predicate),[Object])]+ triplesHashMap :: HashMap (Subject, Predicate) [Object]+ triplesHashMap = HashMap.fromListWith (<>) [((s, p), [o]) | Triple s p o <- triples]+ triplesGrouped :: [((Subject, Predicate), [Object])] triplesGrouped = HashMap.toList triplesHashMap- (dataGraph,_,_) = (graphFromEdges . fmap (\((s,p),os) -> (s,p,os))) triplesGrouped+ (dataGraph, _, _) = (graphFromEdges . fmap (\((s, p), os) -> (s, p, os))) triplesGrouped --- |Expand the triples in a graph with the prefix map and base URL for that graph.+-- | Expand the triples in a graph with the prefix map and base URL+-- for that graph. Unsafe because it assumes IRI resolution will+-- succeed, may throw an 'IRIResolutionException` exception. expandTriples :: (Rdf a) => RDF a -> Triples expandTriples rdf = normalize <$> triplesOf rdf- where normalize = absolutizeTriple (baseUrl rdf) . expandTriple (prefixMappings rdf)+ where+ normalize = absolutizeTriple (baseUrl rdf) . expandTriple (prefixMappings rdf) --- |Expand the triple with the prefix map.+-- | Expand the triple with the prefix map. expandTriple :: PrefixMappings -> Triple -> Triple expandTriple pms (Triple s p o) = triple (expandNode pms s) (expandNode pms p) (expandNode pms o) --- |Expand the node with the prefix map.--- Only UNodes are expanded, other kinds of nodes are returned as-is.+-- | Expand the node with the prefix map.+-- Only UNodes are expanded, other kinds of nodes are returned as-is. expandNode :: PrefixMappings -> Node -> Node expandNode pms (UNode u) = unode $ expandURI pms u-expandNode _ n = n+expandNode _ n = n --- |Expand the URI with the prefix map.--- Also expands "a" to "http://www.w3.org/1999/02/22-rdf-syntax-ns#type".+-- | Expand the URI with the prefix map.+-- 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 _ "a" = NS.mkUri NS.rdf "type" expandURI pms iri = fromMaybe iri $ 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)+ where+ f :: Maybe Text -> (Text, Text) -> Maybe Text+ f x (p, u) = x <|> (T.append u <$> T.stripPrefix (T.append p ":") iri) --- |Prefixes relative URIs in the triple with BaseUrl.+-- | Prefixes relative URIs in the triple with BaseUrl. Unsafe because+-- it assumes IRI resolution will succeed, may throw an+-- 'IRIResolutionException` exception. absolutizeTriple :: Maybe BaseUrl -> Triple -> Triple-absolutizeTriple base (Triple s p o) = triple (absolutizeNode base s) (absolutizeNode base p) (absolutizeNode base o)+absolutizeTriple base (Triple s p o) = triple (absolutizeNodeUnsafe base s) (absolutizeNodeUnsafe base p) (absolutizeNodeUnsafe base o) --- |Prepends BaseUrl to UNodes with relative URIs.-absolutizeNode :: Maybe BaseUrl -> Node -> Node-absolutizeNode (Just (BaseUrl b)) (UNode u) = unode $ mkAbsoluteUrl b u-absolutizeNode _ n = n+-- | Prepends BaseUrl to UNodes with relative URIs.+absolutizeNode :: Maybe BaseUrl -> Node -> Either String Node+absolutizeNode (Just (BaseUrl b)) (UNode u) =+ case resolveIRI b u of+ Left iriErr -> Left iriErr+ Right t -> Right (unode t)+absolutizeNode _ n = Right n++data QueryException+ = IRIResolutionException String+ deriving (Show)++instance Exception QueryException++-- | Prepends BaseUrl to UNodes with relative URIs. Unsafe because it+-- assumes IRI resolution will succeed, may throw an+-- 'IRIResolutionException` exception.+absolutizeNodeUnsafe :: Maybe BaseUrl -> Node -> Node+absolutizeNodeUnsafe (Just (BaseUrl b)) (UNode u) =+ case resolveIRI b u of+ Left iriErr -> throw (IRIResolutionException iriErr)+ Right t -> unode t+absolutizeNodeUnsafe _ n = n
src/Data/RDF/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-}@@ -53,7 +54,13 @@ import Data.Char (chr, ord) import Data.Either (isRight) import Data.String (IsString(..))-import Data.Semigroup (Semigroup(..))+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#else+#endif+#else+#endif import Data.Map (Map) import Data.RDF.IRI import Control.Applicative
src/Rdf4hParseMain.hs view
@@ -1,105 +1,122 @@-{-# LANGUAGE OverloadedStrings,- RankNTypes,- ScopedTypeVariables,- MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Main where -import Data.RDF+-- import Data.Semigroup ((<>)) +import Control.Monad+import Data.Char (isLetter)+import Data.List+import qualified Data.Map as Map+import Data.RDF+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0) import Data.Semigroup ((<>))+#else+#endif+#else+#endif import qualified Data.Text as T import qualified Data.Text.IO as TIO-+import System.Console.GetOpt import System.Environment-import System.IO import System.Exit-import System.Console.GetOpt--import Control.Monad--import Data.List-import qualified Data.Map as Map-import Data.Char (isLetter)+import System.IO import Text.Printf (hPrintf) -- TODO: cleanup and refactor main and elsewhere in this module main :: IO () main =- do (opts, args) <- getArgs >>= compilerOpts- when (Help `elem` opts)+ do+ (opts, args) <- getArgs >>= compilerOpts+ when+ (Help `elem` opts) (putStrLn (usageInfo header options) >> exitSuccess)- when (null args)- (ioError- (userError- ("\n\n" <> "INPUT-URI required\n\n" <> usageInfo header options)))- let debug = Debug `elem` opts- inputUri = head args- inputFormat = getWithDefault (InputFormat "turtle") opts- outputFormat = getWithDefault (OutputFormat "ntriples") opts- inputBaseUri = getInputBaseUri inputUri args opts- outputBaseUri = getWithDefault (OutputBaseUri inputBaseUri) opts- unless (outputFormat == "ntriples" || outputFormat == "turtle")- (hPrintf stderr- ("'" <>- outputFormat <>- "' is not a valid output format. Supported output formats are: ntriples, turtle\n")- >> exitWith (ExitFailure 1))- when debug- (hPrintf stderr " INPUT-URI: %s\n\n" inputUri >>- hPrintf stderr " INPUT-FORMAT: %s\n" inputFormat+ when+ (null args)+ ( ioError+ ( userError+ ("\n\n" <> "INPUT-URI required\n\n" <> usageInfo header options)+ )+ )+ let debug = Debug `elem` opts+ inputUri = head args+ inputFormat = getWithDefault (InputFormat "turtle") opts+ outputFormat = getWithDefault (OutputFormat "ntriples") opts+ inputBaseUri = getInputBaseUri inputUri args opts+ outputBaseUri = getWithDefault (OutputBaseUri inputBaseUri) opts+ unless+ (outputFormat == "ntriples" || outputFormat == "turtle")+ ( hPrintf+ stderr+ ( "'"+ <> outputFormat+ <> "' is not a valid output format. Supported output formats are: ntriples, turtle\n"+ )+ >> exitWith (ExitFailure 1)+ )+ when+ debug+ ( hPrintf stderr " INPUT-URI: %s\n\n" inputUri+ >> hPrintf stderr " INPUT-FORMAT: %s\n" inputFormat >> hPrintf stderr " INPUT-BASE-URI: %s\n\n" inputBaseUri >> hPrintf stderr " OUTPUT-FORMAT: %s\n" outputFormat- >> hPrintf stderr "OUTPUT-BASE-URI: %s\n\n" outputBaseUri)- let mInputUri- = if inputBaseUri == "-" then Nothing else- Just (BaseUrl (T.pack inputBaseUri))- docUri = Just $ T.pack inputUri- emptyPms = PrefixMappings Map.empty- case (inputFormat, isUri $ T.pack inputUri) of- ("turtle", True) -> parseURL (TurtleParser mInputUri docUri)- inputUri- >>=- \ (res :: Either ParseFailure (RDF TList)) ->- write outputFormat docUri emptyPms res- ("turtle", False) -> (if inputUri /= "-" then- parseFile (TurtleParser mInputUri docUri) inputUri else- parseString (TurtleParser mInputUri docUri) <$> TIO.getContents)- >>=- \ (res :: Either ParseFailure (RDF TList)) ->- write outputFormat docUri emptyPms res- ("ntriples", True) -> parseURL NTriplesParser inputUri >>=- \ (res :: Either ParseFailure (RDF TList)) ->- write outputFormat Nothing emptyPms res- ("ntriples", False) -> (if inputUri /= "-" then- parseFile NTriplesParser inputUri else- parseString NTriplesParser <$> TIO.getContents)- >>=- \ (res :: Either ParseFailure (RDF TList)) ->- write outputFormat Nothing emptyPms res- ("xml", True) -> parseURL (XmlParser mInputUri docUri)- inputUri- >>=- \ (res :: Either ParseFailure (RDF TList)) ->- write outputFormat docUri emptyPms res- ("xml", False) -> (if inputUri /= "-" then- parseFile (XmlParser mInputUri docUri) inputUri else- parseString (XmlParser mInputUri docUri) <$> TIO.getContents)- >>=- \ (res :: Either ParseFailure (RDF TList)) ->- write outputFormat docUri emptyPms res- (str, _) -> putStrLn ("Invalid format: " <> str) >> exitFailure+ >> hPrintf stderr "OUTPUT-BASE-URI: %s\n\n" outputBaseUri+ )+ let mInputUri =+ if inputBaseUri == "-"+ then Nothing+ else Just (BaseUrl (T.pack inputBaseUri))+ docUri = Just $ T.pack inputUri+ emptyPms = PrefixMappings Map.empty+ case (inputFormat, isUri $ T.pack inputUri) of+ ("turtle", True) -> parseURL+ (TurtleParser mInputUri docUri)+ inputUri+ >>= \(res :: Either ParseFailure (RDF TList)) ->+ write outputFormat docUri emptyPms res+ ("turtle", False) -> ( if inputUri /= "-"+ then parseFile (TurtleParser mInputUri docUri) inputUri+ else parseString (TurtleParser mInputUri docUri) <$> TIO.getContents+ )+ >>= \(res :: Either ParseFailure (RDF TList)) ->+ write outputFormat docUri emptyPms res+ ("ntriples", True) -> parseURL NTriplesParser inputUri+ >>= \(res :: Either ParseFailure (RDF TList)) ->+ write outputFormat Nothing emptyPms res+ ("ntriples", False) -> ( if inputUri /= "-"+ then parseFile NTriplesParser inputUri+ else parseString NTriplesParser <$> TIO.getContents+ )+ >>= \(res :: Either ParseFailure (RDF TList)) ->+ write outputFormat Nothing emptyPms res+ ("xml", True) -> parseURL+ (XmlParser mInputUri docUri)+ inputUri+ >>= \(res :: Either ParseFailure (RDF TList)) ->+ write outputFormat docUri emptyPms res+ ("xml", False) -> ( if inputUri /= "-"+ then parseFile (XmlParser mInputUri docUri) inputUri+ else parseString (XmlParser mInputUri docUri) <$> TIO.getContents+ )+ >>= \(res :: Either ParseFailure (RDF TList)) ->+ write outputFormat docUri emptyPms res+ (str, _) -> putStrLn ("Invalid format: " <> str) >> exitFailure write :: (Rdf a) => String -> Maybe T.Text -> PrefixMappings -> Either ParseFailure (RDF a) -> IO () write format docUri pms res = case res of (Left (ParseFailure msg)) -> putStrLn msg >> exitWith (ExitFailure 1)- (Right rdf) -> doWriteRdf rdf+ (Right rdf) -> doWriteRdf rdf where doWriteRdf rdf = case format of- "turtle" -> writeRdf (TurtleSerializer docUri pms) rdf+ "turtle" -> writeRdf (TurtleSerializer docUri pms) rdf "ntriples" -> writeRdf NTriplesSerializer rdf- unknown -> error $ "Unknown output format: " <> unknown+ unknown -> error $ "Unknown output format: " <> unknown -- Get the input base URI from the argument list or flags, using the -- first string arg as the default if not found in string args (as@@ -110,15 +127,16 @@ -- arg is silently discarded. getInputBaseUri :: String -> [String] -> [Flag] -> String getInputBaseUri inputUri args flags =- if null $ tail args then- getWithDefault (InputBaseUri inputUri) flags else- getWithDefault (InputBaseUri (head $ tail args)) flags+ if null $ tail args+ then getWithDefault (InputBaseUri inputUri) flags+ else getWithDefault (InputBaseUri (head $ tail args)) flags -- Determine if the bytestring represents a URI, which is currently -- decided solely by checking for a colon in the string. isUri :: T.Text -> Bool isUri str = not (T.null post) && T.all isLetter pre- where (pre, post) = T.break (== ':') str+ where+ (pre, post) = T.break (== ':') str -- Extract from the list of flags a flag of the same type as the first -- flag argument, returning its string value; if there is no such flag,@@ -126,68 +144,73 @@ getWithDefault :: Flag -> [Flag] -> String getWithDefault def args = case find (== def) args of- Nothing -> strValue def+ Nothing -> strValue def Just val -> strValue val -- Convert the flag to a string, which is only valid for flags that have -- a string argument. strValue :: Flag -> String-strValue (InputFormat s) = s-strValue (InputBaseUri s) = s-strValue (OutputFormat s) = s+strValue (InputFormat s) = s+strValue (InputBaseUri s) = s+strValue (OutputFormat s) = s strValue (OutputBaseUri s) = s-strValue flag = error $ "No string value for flag: " <> show flag+strValue flag = error $ "No string value for flag: " <> show flag -- The commandline arguments we accept. None are required. data Flag- = Help | Debug- | InputFormat String | InputBaseUri String- | OutputFormat String | OutputBaseUri String- deriving (Show)+ = Help+ | Debug+ | InputFormat String+ | InputBaseUri String+ | OutputFormat String+ | OutputBaseUri String+ deriving (Show) -- Two flags are equal if they are of the same type, regardless of value: a -- strange definition, but we never care about values when finding or comparing -- them. instance Eq Flag where- Help == Help = True- Debug == Debug = True- InputFormat _ == InputFormat _ = True- InputBaseUri _ == InputBaseUri _ = True- OutputFormat _ == OutputFormat _ = True+ Help == Help = True+ Debug == Debug = True+ InputFormat _ == InputFormat _ = True+ InputBaseUri _ == InputBaseUri _ = True+ OutputFormat _ == OutputFormat _ = True OutputBaseUri _ == OutputBaseUri _ = True- _ == _ = False-+ _ == _ = False -- The top part of the usage output. header :: String header =- "\nrdf4h_parse: an RDF parser and serializer\n\n" <>- "\nUsage: rdf4h_parse [OPTION...] INPUT-URI [INPUT-BASE-URI]\n\n" <>- " INPUT-URI a filename, URI or '-' for standard input (stdin).\n" <>- " INPUT-BASE-URI the input/parser base URI or '-' for none.\n" <>- " Default is INPUT-URI\n" <>- " Equivalent to -I INPUT-BASE-URI, --input-base-uri INPUT-BASE-URI\n\n"+ "\nrdf4h_parse: an RDF parser and serializer\n\n"+ <> "\nUsage: rdf4h_parse [OPTION...] INPUT-URI [INPUT-BASE-URI]\n\n"+ <> " INPUT-URI a filename, URI or '-' for standard input (stdin).\n"+ <> " INPUT-BASE-URI the input/parser base URI or '-' for none.\n"+ <> " Default is INPUT-URI\n"+ <> " Equivalent to -I INPUT-BASE-URI, --input-base-uri INPUT-BASE-URI\n\n" options :: [OptDescr Flag] options =- [ Option "h" ["help"] (NoArg Help) "Display this help, then exit"- , Option "d" ["debug"] (NoArg Debug) "Print debug info (like INPUT-BASE-URI used, etc.)"- , Option "i" ["input"] (ReqArg InputFormat "FORMAT") $ "Set input format/parser to one of:\n" <>- " turtle Turtle (default)\n" <>- " ntriples N-Triples\n" <>- " xml RDF/XML"- , Option "I" ["input-base-uri"] (ReqArg InputBaseUri "URI") $ "Set the input/parser base URI. '-' for none.\n" <>- " Default is INPUT-BASE-URI argument value.\n\n"-- , Option "o" ["output"] (ReqArg OutputFormat "FORMAT") $ "Set output format/serializer to one of:\n" <>- " ntriples N-Triples (default)\n" <>- " turtle Turtle"- , Option "O" ["output-base-uri"] (ReqArg OutputBaseUri "URI") $ "Set the output format/serializer base URI. '-' for none.\n" <>- " Default is input/parser base URI."- ]+ [ Option "h" ["help"] (NoArg Help) "Display this help, then exit",+ Option "d" ["debug"] (NoArg Debug) "Print debug info (like INPUT-BASE-URI used, etc.)",+ Option "i" ["input"] (ReqArg InputFormat "FORMAT") $+ "Set input format/parser to one of:\n"+ <> " turtle Turtle (default)\n"+ <> " ntriples N-Triples\n"+ <> " xml RDF/XML",+ Option "I" ["input-base-uri"] (ReqArg InputBaseUri "URI") $+ "Set the input/parser base URI. '-' for none.\n"+ <> " Default is INPUT-BASE-URI argument value.\n\n",+ Option "o" ["output"] (ReqArg OutputFormat "FORMAT") $+ "Set output format/serializer to one of:\n"+ <> " ntriples N-Triples (default)\n"+ <> " turtle Turtle",+ Option "O" ["output-base-uri"] (ReqArg OutputBaseUri "URI") $+ "Set the output format/serializer base URI. '-' for none.\n"+ <> " Default is input/parser base URI."+ ] compilerOpts :: [String] -> IO ([Flag], [String]) compilerOpts argv =- case getOpt Permute options argv of- (o,n,[] ) -> return (o,n)- (_,_,errs) -> ioError (userError ("\n\n" <> concat errs <> usageInfo header options))+ case getOpt Permute options argv of+ (o, n, []) -> return (o, n)+ (_, _, errs) -> ioError (userError ("\n\n" <> concat errs <> usageInfo header options))
src/Text/RDF/RDF4H/NTriplesParser.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- |A parser for RDF in N-Triples format -- <http://www.w3.org/TR/rdf-testcases/#ntriples>. @@ -12,7 +14,13 @@ ) where import Prelude hiding (readFile)+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0) import Data.Semigroup ((<>))+#else+#endif+#else+#endif import Data.Char (isDigit, isLetter, isAlphaNum, isAsciiUpper, isAsciiLower) import Control.Applicative import Control.Monad (void)
src/Text/RDF/RDF4H/ParserUtils.hs view
@@ -29,7 +29,13 @@ import Control.Exception.Lifted import Network.HTTP.Conduit import Data.Text.Encoding (decodeUtf8)+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0) import Data.Semigroup ((<>))+#else+#endif+#else+#endif import qualified Data.ByteString.Lazy as BS import Data.Text (Text) import qualified Data.Text as T@@ -48,7 +54,7 @@ errResult :: String -> Either ParseFailure (RDF rdfImpl) errResult msg = Left (ParseFailure msg) -parseFromURL :: (Rdf rdfImpl) => (T.Text -> Either ParseFailure (RDF rdfImpl)) -> String -> IO (Either ParseFailure (RDF rdfImpl))+parseFromURL :: (T.Text -> Either ParseFailure (RDF rdfImpl)) -> String -> IO (Either ParseFailure (RDF rdfImpl)) parseFromURL parseFunc url = do result <- Control.Exception.Lifted.try $ simpleHttp url case result of
src/Text/RDF/RDF4H/TurtleParser.hs view
@@ -1,104 +1,115 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DoAndIfThenElse #-} --- |An 'RdfParser' implementation for the Turtle format--- <http://www.w3.org/TeamSubmission/turtle/>.-+-- | An 'RdfParser' implementation for the Turtle format+-- <http://www.w3.org/TeamSubmission/turtle/>. module Text.RDF.RDF4H.TurtleParser- ( TurtleParser(TurtleParser)- , TurtleParserCustom(TurtleParserCustom)- , parseTurtleDebug- ) where+ ( TurtleParser (TurtleParser),+ TurtleParserCustom (TurtleParserCustom),+ parseTurtleDebug,+ )+where -import Prelude hiding (readFile)-import Data.Attoparsec.Text (parse,IResult(..))-import Data.Char (toLower, toUpper, isDigit, isHexDigit)+import Control.Applicative hiding (empty)+import Control.Monad+import Control.Monad.State.Class+import Control.Monad.State.Strict+import Data.Attoparsec.Text (IResult (..), parse)+import Data.Char (isDigit, isHexDigit, toLower, toUpper)+import Data.Either+import qualified Data.Foldable as F+import Data.Functor (($>)) import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe-import Data.Either-import Data.Semigroup ((<>))-import Data.RDF.Types-import Data.RDF.IRI import Data.RDF.Graph.TList-import Text.RDF.RDF4H.ParserUtils-import Text.RDF.RDF4H.NTriplesParser-import Text.Parsec (runParser, ParseError)-import qualified Data.Text as T+import Data.RDF.IRI+import Data.RDF.Types+#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 Data.Functor (($>))-import qualified Data.Foldable as F-import Control.Monad+import qualified Data.Text as T+import Text.Parsec (ParseError, runParser) import Text.Parser.Char import Text.Parser.Combinators import Text.Parser.LookAhead-import Control.Applicative hiding (empty)-import Control.Monad.State.Class-import Control.Monad.State.Strict+import Text.RDF.RDF4H.NTriplesParser+import Text.RDF.RDF4H.ParserUtils+import Prelude hiding (readFile) --- |An 'RdfParser' implementation for parsing RDF in the--- Turtle format. It is an implementation of W3C Turtle grammar rules at--- http://www.w3.org/TR/turtle/#sec-grammar-grammar .--- It takes optional arguments representing the base URL to use--- for resolving relative URLs in the document (may be overridden in the document--- itself using the \@base directive), and the URL to use for the document itself--- for resolving references to <> in the document.--- To use this parser, pass a 'TurtleParser' value as the first argument to any of--- the 'parseString', 'parseFile', or 'parseURL' methods of the 'RdfParser' type--- class.+-- | An 'RdfParser' implementation for parsing RDF in the+-- Turtle format. It is an implementation of W3C Turtle grammar rules at+-- http://www.w3.org/TR/turtle/#sec-grammar-grammar .+-- It takes optional arguments representing the base URL to use+-- for resolving relative URLs in the document (may be overridden in the document+-- itself using the \@base directive), and the URL to use for the document itself+-- for resolving references to <> in the document.+-- To use this parser, pass a 'TurtleParser' value as the first argument to any of+-- the 'parseString', 'parseFile', or 'parseURL' methods of the 'RdfParser' type+-- class. data TurtleParser = TurtleParser (Maybe BaseUrl) (Maybe T.Text) data TurtleParserCustom = TurtleParserCustom (Maybe BaseUrl) (Maybe T.Text) Parser --- |'TurtleParser' is an instance of 'RdfParser' using a parsec based parser.+-- | 'TurtleParser' is an instance of 'RdfParser' using a parsec based parser. instance RdfParser TurtleParser where- parseString (TurtleParser bUrl dUrl) = parseStringParsec bUrl dUrl- parseFile (TurtleParser bUrl dUrl) = parseFileParsec bUrl dUrl- parseURL (TurtleParser bUrl dUrl) = parseURLParsec bUrl dUrl+ parseString (TurtleParser bUrl dUrl) = parseStringParsec bUrl dUrl+ parseFile (TurtleParser bUrl dUrl) = parseFileParsec bUrl dUrl+ parseURL (TurtleParser bUrl dUrl) = parseURLParsec bUrl dUrl --- |'TurtleParser' is an instance of 'RdfParser' using either a--- parsec or an attoparsec based parser.+-- | 'TurtleParser' is an instance of 'RdfParser' using either a+-- parsec or an attoparsec based parser. instance RdfParser TurtleParserCustom where- parseString (TurtleParserCustom bUrl dUrl Parsec) = parseStringParsec bUrl dUrl- parseString (TurtleParserCustom bUrl dUrl Attoparsec) = parseStringAttoparsec bUrl dUrl- parseFile (TurtleParserCustom bUrl dUrl Parsec) = parseFileParsec bUrl dUrl- parseFile (TurtleParserCustom bUrl dUrl Attoparsec) = parseFileAttoparsec bUrl dUrl- parseURL (TurtleParserCustom bUrl dUrl Parsec) = parseURLParsec bUrl dUrl- parseURL (TurtleParserCustom bUrl dUrl Attoparsec) = parseURLAttoparsec bUrl dUrl+ parseString (TurtleParserCustom bUrl dUrl Parsec) = parseStringParsec bUrl dUrl+ parseString (TurtleParserCustom bUrl dUrl Attoparsec) = parseStringAttoparsec bUrl dUrl+ parseFile (TurtleParserCustom bUrl dUrl Parsec) = parseFileParsec bUrl dUrl+ parseFile (TurtleParserCustom bUrl dUrl Attoparsec) = parseFileAttoparsec bUrl dUrl+ parseURL (TurtleParserCustom bUrl dUrl Parsec) = parseURLParsec bUrl dUrl+ parseURL (TurtleParserCustom bUrl dUrl Attoparsec) = parseURLAttoparsec bUrl dUrl type ParseState =- ( Maybe BaseUrl -- the current BaseUrl, may be Nothing initially, but not after it is once set- , Maybe T.Text -- the docUrl, which never changes and is used to resolve <> in the document.- , Integer -- the id counter, containing the value of the next id to be used- , PrefixMappings -- the mappings from prefix to URI that are encountered while parsing- , Maybe Subject -- current subject node, if we have parsed a subject but not finished the triple- , Maybe Predicate -- current predicate node, if we have parsed a predicate but not finished the triple- , Seq Triple -- the triples encountered while parsing; always added to on the right side- , Map String Integer ) -- map blank node names to generated id.-+ ( Maybe BaseUrl, -- the current BaseUrl, may be Nothing initially, but not after it is once set+ Maybe T.Text, -- the docUrl, which never changes and is used to resolve <> in the document.+ Integer, -- the id counter, containing the value of the next id to be used+ PrefixMappings, -- the mappings from prefix to URI that are encountered while parsing+ Maybe Subject, -- current subject node, if we have parsed a subject but not finished the triple+ Maybe Predicate, -- current predicate node, if we have parsed a predicate but not finished the triple+ Seq Triple, -- the triples encountered while parsing; always added to on the right side+ Map String Integer -- map blank node names to generated id.+ ) parseTurtleDebug :: String -> IO (RDF TList) parseTurtleDebug f = fromRight empty <$> parseFile (TurtleParserCustom (Just . BaseUrl $ "http://base-url.com/") (Just "http://doc-url.com/") Attoparsec) f -- grammar rule: [1] turtleDoc-t_turtleDoc :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m (Seq Triple, PrefixMappings)+t_turtleDoc :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m (Seq Triple, Maybe BaseUrl, PrefixMappings) t_turtleDoc =- many t_statement *> (eof <?> "eof") *> gets (\(_, _, _, pms, _, _, ts,_) -> (ts, pms))+ many t_statement *> (eof <?> "eof") *> gets (\(mb_bUrl, _, _, pms, _, _, ts, _) -> (ts, mb_bUrl, pms)) -- grammar rule: [2] statement -- [2] statement ::= directive | triples '.' t_statement :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m () t_statement = directive <|> triples <|> void (some t_ws <?> "blankline-whitespace") where- directive = void- (try t_directive- *> (many t_ws <?> "directive-whitespace2"))- triples = void- (try t_triples- *> (many t_ws <?> "triple-whitespace1")- *> (char '.' <?> "end-of-triple-period")- *> (many t_ws <?> "triple-whitespace2"))+ directive =+ void+ ( try t_directive+ *> (many t_ws <?> "directive-whitespace2")+ )+ triples =+ void+ ( try t_triples+ *> (many t_ws <?> "triple-whitespace1")+ *> (char '.' <?> "end-of-triple-period")+ *> (many t_ws <?> "triple-whitespace2")+ ) -- grammar rule: [6] triples -- subject predicateObjectList | blankNodePropertyList predicateObjectList?@@ -106,16 +117,17 @@ t_triples = try subjectWithPOL <|> blankNodePropertyListWithPOL where subjectWithPOL = t_subject *> many t_ws *> t_predicateObjectList *> resetSubjectPredicate- blankNodePropertyListWithPOL = t_blankNodePropertyList >>= \bn- -> many t_ws- *> setSubjectPredicate (Just bn) Nothing- *> optional t_predicateObjectList- *> resetSubjectPredicate+ blankNodePropertyListWithPOL = t_blankNodePropertyList >>= \bn ->+ many t_ws+ *> setSubjectPredicate (Just bn) Nothing+ *> optional t_predicateObjectList+ *> resetSubjectPredicate -- [14] blankNodePropertyList ::= '[' predicateObjectList ']' t_blankNodePropertyList :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m Node-t_blankNodePropertyList = withConstantSubjectPredicate $- between (char '[') (char ']') $ do+t_blankNodePropertyList = withConstantSubjectPredicate+ $ between (char '[') (char ']')+ $ do bn <- nextBlankNode setSubjectPredicate (Just bn) Nothing void (many t_ws *> t_predicateObjectList *> many t_ws)@@ -127,7 +139,7 @@ -- grammar rule: [135s] iri ::= IRIREF | PrefixedName t_iri :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m T.Text-t_iri = try t_iriref <|> t_prefixedName+t_iri = try t_iriref <|> t_prefixedName -- grammar rule: [136s] PrefixedName ::= PNAME_LN | PNAME_NS t_prefixedName :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m T.Text@@ -196,7 +208,7 @@ pre <- option mempty (try t_pn_prefix) <* char ':' (_, _, _, pms, _, _, _, _) <- get case resolveQName pre pms of- Just n -> pure n+ Just n -> pure n Nothing -> unexpected ("Cannot resolve QName prefix: " <> T.unpack pre) -- grammar rules: [168s] PN_LOCAL@@ -205,21 +217,23 @@ t_pn_local = do x <- t_pn_chars_u_str <|> string ":" <|> satisfy_str <|> t_plx xs <- option "" $ try $ do- let recsve = (t_pn_chars_str <|> string ":" <|> t_plx) <|>- (t_pn_chars_str <|> string ":" <|> t_plx <|> try (string "." <* lookAhead (try recsve))) <|>- (t_pn_chars_str <|> string ":" <|> t_plx <|> try (string "." *> notFollowedBy t_ws $> "."))+ let recsve =+ (t_pn_chars_str <|> string ":" <|> t_plx)+ <|> (t_pn_chars_str <|> string ":" <|> t_plx <|> try (string "." <* lookAhead (try recsve)))+ <|> (t_pn_chars_str <|> string ":" <|> t_plx <|> try (string "." *> notFollowedBy t_ws $> ".")) concat <$> many recsve pure (T.pack (x <> xs)) where- satisfy_str = pure <$> satisfy isDigit- t_pn_chars_str = pure <$> t_pn_chars+ satisfy_str = pure <$> satisfy isDigit+ t_pn_chars_str = pure <$> t_pn_chars t_pn_chars_u_str = pure <$> t_pn_chars_u -- PERCENT | PN_LOCAL_ESC -- grammar rules: [169s] PLX t_plx :: (CharParsing m, Monad m) => m String t_plx = t_percent <|> t_pn_local_esc_str- where t_pn_local_esc_str = pure <$> t_pn_local_esc+ where+ t_pn_local_esc_str = pure <$> t_pn_local_esc -- '%' HEX HEX -- grammar rules: [170s] PERCENT@@ -238,7 +252,8 @@ -- [10] subject ::= iri | BlankNode | collection t_subject :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m () t_subject = iri <|> t_blankNode <|> t_collection >>= setSubject- where iri = unode <$> (try t_iri <?> "subject resource")+ where+ iri = unode <$> (try t_iri <?> "subject resource") -- [137s] BlankNode ::= BLANK_NODE_LABEL | ANON t_blankNode :: (CharParsing m, MonadState ParseState m) => m Node@@ -259,15 +274,16 @@ t_blank_node_label = do void (string "_:") firstChar <- t_pn_chars_u <|> satisfy isDigit- try $ (firstChar:) <$> otherChars+ try $ (firstChar :) <$> otherChars where otherChars = option "" $ do xs <- many (t_pn_chars <|> char '.') if null xs- then pure xs- else if last xs == '.'- then unexpected "'.' at the end of a blank node label"- else pure xs+ then pure xs+ else+ if last xs == '.'+ then unexpected "'.' at the end of a blank node label"+ else pure xs -- [162s] ANON ::= '[' WS* ']' t_anon :: CharParsing m => m ()@@ -276,8 +292,9 @@ -- [7] predicateObjectList ::= verb objectList (';' (verb objectList)?)* t_predicateObjectList :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m () t_predicateObjectList = void $ sepEndBy1 (try verbObjectList) (try separator)- where verbObjectList = t_verb *> some t_ws *> t_objectList- separator = some (many t_ws *> char ';' *> many t_ws)+ where+ verbObjectList = t_verb *> some t_ws *> t_objectList+ separator = some (many t_ws *> char ';' *> many t_ws) -- grammar rule: [8] objectlist -- [8] objectList ::= object (',' object)*@@ -289,17 +306,19 @@ -- grammar rule: [12] object -- [12] object ::= iri | BlankNode | collection | blankNodePropertyList | literal t_object :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m Node-t_object = try (UNode <$> t_iri)- <|> try t_blankNode- <|> try t_collection- <|> try t_blankNodePropertyList- <|> t_literal+t_object =+ try (UNode <$> t_iri)+ <|> try t_blankNode+ <|> try t_collection+ <|> try t_blankNodePropertyList+ <|> t_literal -- grammar rule: [15] collection -- [15] collection ::= '(' object* ')' t_collection :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m Node-t_collection = withConstantSubjectPredicate $- between (char '(') (char ')') $ do+t_collection = withConstantSubjectPredicate+ $ between (char '(') (char ')')+ $ do void (many t_ws) root <- try empty_list <|> non_empty_list void (many t_ws)@@ -323,11 +342,11 @@ t_literal :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m Node t_literal =- LNode <$> try t_rdf_literal <|>- (`mkLNode` xsdDoubleUri) <$> try t_double <|>- (`mkLNode` xsdDecimalUri) <$> try t_decimal <|>- (`mkLNode` xsdIntUri) <$> try t_integer <|>- (`mkLNode` xsdBooleanUri) <$> t_boolean+ LNode <$> try t_rdf_literal+ <|> (`mkLNode` xsdDoubleUri) <$> try t_double+ <|> (`mkLNode` xsdDecimalUri) <$> try t_decimal+ <|> (`mkLNode` xsdIntUri) <$> try t_integer+ <|> (`mkLNode` xsdBooleanUri) <$> t_boolean where mkLNode :: T.Text -> T.Text -> Node mkLNode bsType bs' = LNode (typedL bsType bs')@@ -345,10 +364,11 @@ -- [17] String -- STRING_LITERAL_QUOTE | STRING_LITERAL_SINGLE_QUOTE | STRING_LITERAL_LONG_SINGLE_QUOTE | STRING_LITERAL_LONG_QUOTE t_string :: (CharParsing m, Monad m) => m T.Text-t_string = try t_string_literal_long_double_quote- <|> try t_string_literal_long_single_quote- <|> try t_string_literal_double_quote- <|> t_string_literal_single_quote+t_string =+ try t_string_literal_long_double_quote+ <|> try t_string_literal_long_single_quote+ <|> try t_string_literal_double_quote+ <|> t_string_literal_single_quote -- [22] STRING_LITERAL_QUOTE -- '"' ([^#x22#x5C#xA#xD] | ECHAR | UCHAR)* '"'@@ -366,7 +386,7 @@ t_string_literal_long_single_quote = between (string "'''") (string "'''") $ do ss <- many $ try $ do s1 <- T.pack <$> option "" (try (string "''") <|> string "'")- s2 <- T.singleton <$> (noneOf ['\'','\\'] <|> t_echar <|> t_uchar)+ s2 <- T.singleton <$> (noneOf ['\'', '\\'] <|> t_echar <|> t_uchar) pure (s1 `T.append` s2) pure (T.concat ss) @@ -376,7 +396,7 @@ t_string_literal_long_double_quote = between (string "\"\"\"") (string "\"\"\"") $ do ss <- many $ try $ do s1 <- T.pack <$> option "" (try (string "\"\"") <|> string "\"")- s2 <- T.singleton <$> (noneOf ['"','\\'] <|> t_echar <|> t_uchar)+ s2 <- T.singleton <$> (noneOf ['"', '\\'] <|> t_echar <|> t_uchar) pure (s1 `T.append` s2) pure (T.concat ss) @@ -397,23 +417,32 @@ t_integer = try $ do sign <- sign_parser <?> "+-" ds <- some (satisfy isDigit <?> "digit")- pure $! ( T.pack sign `T.append` T.pack ds)+ pure $! (T.pack sign `T.append` T.pack ds) -- grammar rule: [21] DOUBLE -- [21] DOUBLE ::= [+-]? ([0-9]+ '.' [0-9]* EXPONENT | '.' [0-9]+ EXPONENT | [0-9]+ EXPONENT) t_double :: (CharParsing m, Monad m) => m T.Text t_double = do sign <- sign_parser <?> "+-"- rest <- try (do { ds <- (some (satisfy isDigit) <?> "digit") <* char '.';- ds' <- many (satisfy isDigit) <?> "digit";- e <- t_exponent <?> "exponent";- pure ( T.pack ds `T.snoc` '.' `T.append` T.pack ds' `T.append` e) }) <|>- try (do { ds <- char '.' *> some (satisfy isDigit) <?> "digit";- e <- t_exponent <?> "exponent";- pure ('.' `T.cons` T.pack ds `T.append` e) }) <|>- (do { ds <- some (satisfy isDigit) <?> "digit";- e <- t_exponent <?> "exponent";- pure ( T.pack ds `T.append` e) })+ rest <-+ try+ ( do+ ds <- (some (satisfy isDigit) <?> "digit") <* char '.'+ ds' <- many (satisfy isDigit) <?> "digit"+ e <- t_exponent <?> "exponent"+ pure (T.pack ds `T.snoc` '.' `T.append` T.pack ds' `T.append` e)+ )+ <|> try+ ( do+ ds <- char '.' *> some (satisfy isDigit) <?> "digit"+ e <- t_exponent <?> "exponent"+ pure ('.' `T.cons` T.pack ds `T.append` e)+ )+ <|> ( do+ ds <- some (satisfy isDigit) <?> "digit"+ e <- t_exponent <?> "exponent"+ pure (T.pack ds `T.append` e)+ ) pure $! T.pack sign `T.append` rest sign_parser :: CharParsing m => m String@@ -425,14 +454,15 @@ sign <- sign_parser dig1 <- many (satisfy isDigit) <* char '.' dig2 <- some (satisfy isDigit)- pure (T.pack sign `T.append` T.pack dig1 `T.append` T.pack "." `T.append` T.pack dig2)+ pure (T.pack sign `T.append` T.pack dig1 `T.append` T.pack "." `T.append` T.pack dig2) -- [154s] EXPONENT ::= [eE] [+-]? [0-9]+ t_exponent :: (CharParsing m, Monad m) => m T.Text-t_exponent = do e <- oneOf "eE"- s <- option "" (pure <$> oneOf "-+")- ds <- some digit- pure $! (e `T.cons` ( T.pack s `T.append` T.pack ds))+t_exponent = do+ e <- oneOf "eE"+ s <- option "" (pure <$> oneOf "-+")+ ds <- some digit+ pure $! (e `T.cons` (T.pack s `T.append` T.pack ds)) -- [133s] BooleanLiteral ::= 'true' | 'false' t_boolean :: CharParsing m => m T.Text@@ -440,19 +470,21 @@ t_comment :: CharParsing m => m () t_comment = void (char '#' *> many (noneOf "\n\r"))+ --[TODO] t_comment = nt_comment -- [161s] WS ::= #x20 | #x9 | #xD | #xA t_ws :: CharParsing m => m ()-t_ws = (void (try (oneOf "\t\n\r "))) <|> try t_comment- <?> "whitespace-or-comment"+t_ws =+ (void (try (oneOf "\t\n\r "))) <|> try t_comment+ <?> "whitespace-or-comment" -- [167s] PN_PREFIX ::= PN_CHARS_BASE ((PN_CHARS | '.')* PN_CHARS)? t_pn_prefix :: (CharParsing m, MonadState ParseState m) => m T.Text t_pn_prefix = do i <- try t_pn_chars_base r <- option "" (many (try t_pn_chars <|> char '.')) -- TODO: ensure t_pn_chars is last char- pure (T.pack (i:r))+ pure (T.pack (i : r)) -- [18] IRIREF ::= '<' ([^#x00-#x20<>"{}|^`\] | UCHAR)* '>' t_iriref :: (CharParsing m, MonadState ParseState m) => m T.Text@@ -473,7 +505,8 @@ -- [166s] PN_CHARS ::= PN_CHARS_U | '-' | [0-9] | #x00B7 | [#x0300-#x036F] | [#x203F-#x2040] t_pn_chars :: CharParsing m => m Char t_pn_chars = t_pn_chars_u <|> char '-' <|> char '\x00B7' <|> satisfy f- where f = flip in_range [('0', '9'), ('\x0300', '\x036F'), ('\x203F', '\x2040')]+ where+ f = flip in_range [('0', '9'), ('\x0300', '\x036F'), ('\x203F', '\x2040')] -- grammar rules: [171s] HEX t_hex :: CharParsing m => m Char@@ -484,18 +517,18 @@ in_range c = any (\(c1, c2) -> c >= c1 && c <= c2) currGenIdLookup :: MonadState ParseState m => m (Map String Integer)-currGenIdLookup = gets $ \(_, _, _, _, _, _, _,genMap) -> genMap+currGenIdLookup = gets $ \(_, _, _, _, _, _, _, genMap) -> genMap addGenIdLookup :: MonadState ParseState m => String -> Integer -> m () addGenIdLookup genId counter = modify $ \(bUrl, dUrl, i, pms, s, p, ts, genMap) ->- (bUrl, dUrl, i, pms, s, p, ts, Map.insert genId counter genMap)+ (bUrl, dUrl, i, pms, s, p, ts, Map.insert genId counter genMap) currBaseUrl :: MonadState ParseState m => m (Maybe BaseUrl)-currBaseUrl = gets $ \(bUrl, _, _, _, _, _, _,_) -> bUrl+currBaseUrl = gets $ \(bUrl, _, _, _, _, _, _, _) -> bUrl currDocUrl :: MonadState ParseState m => m (Maybe T.Text)-currDocUrl = gets $ \(_, dUrl, _, _, _, _, _,_) -> dUrl+currDocUrl = gets $ \(_, dUrl, _, _, _, _, _, _) -> dUrl updateBaseUrl :: MonadState ParseState m => Maybe (Maybe BaseUrl) -> m () updateBaseUrl val = _modifyState val no no no no no@@ -503,7 +536,7 @@ -- combines get_current and increment into a single function nextIdCounter :: MonadState ParseState m => m Integer nextIdCounter = get >>= \(bUrl, dUrl, i, pms, s, p, ts, genMap) ->- put (bUrl, dUrl, i+1, pms, s, p, ts, genMap) $> i+ put (bUrl, dUrl, i + 1, pms, s, p, ts, genMap) $> i nextBlankNode :: MonadState ParseState m => m Node nextBlankNode = BNodeGen . fromIntegral <$> nextIdCounter@@ -528,17 +561,17 @@ setSubjectPredicate :: MonadState ParseState m => Maybe Subject -> Maybe Predicate -> m () setSubjectPredicate s p = modify $ \(bUrl, dUrl, n, pms, _, _, ts, genMap) ->- (bUrl, dUrl, n, pms, s, p, ts, genMap)+ (bUrl, dUrl, n, pms, s, p, ts, genMap) setSubject :: MonadState ParseState m => Subject -> m () setSubject s = modify $ \(bUrl, dUrl, n, pms, _, p, ts, genMap) ->- (bUrl, dUrl, n, pms, Just s, p, ts, genMap)+ (bUrl, dUrl, n, pms, Just s, p, ts, genMap) setPredicate :: MonadState ParseState m => Predicate -> m () setPredicate p = modify $ \(bUrl, dUrl, n, pms, s, _, ts, genMap) ->- (bUrl, dUrl, n, pms, s, Just p, ts, genMap)+ (bUrl, dUrl, n, pms, s, Just p, ts, genMap) -- Update the subject and predicate values of the ParseState to Nothing. resetSubjectPredicate :: MonadState ParseState m => m ()@@ -546,19 +579,27 @@ -- Modifies the current parser state by updating any state values among the parameters -- that have non-Nothing values.-_modifyState :: MonadState ParseState m =>- Maybe (Maybe BaseUrl) -> Maybe (Integer -> Integer) -> Maybe PrefixMappings ->- Maybe (Maybe Subject) -> Maybe (Maybe Predicate) -> Maybe (Seq Triple) ->- m ()+_modifyState ::+ MonadState ParseState m =>+ Maybe (Maybe BaseUrl) ->+ Maybe (Integer -> Integer) ->+ Maybe PrefixMappings ->+ Maybe (Maybe Subject) ->+ Maybe (Maybe Predicate) ->+ Maybe (Seq Triple) ->+ m () _modifyState mb_bUrl mb_n mb_pms mb_subj mb_pred mb_trps = do (_bUrl, _dUrl, _n, _pms, _s, _p, _ts, genMap) <- get- put ( fromMaybe _bUrl mb_bUrl- , _dUrl- , maybe _n (const _n) mb_n- , fromMaybe _pms mb_pms- , maybe _s (const _s) mb_subj- , maybe _p (const _p) mb_pred- , fromMaybe _ts mb_trps, genMap )+ put+ ( fromMaybe _bUrl mb_bUrl,+ _dUrl,+ maybe _n (const _n) mb_n,+ fromMaybe _pms mb_pms,+ maybe _s (const _s) mb_subj,+ maybe _p (const _p) mb_pred,+ fromMaybe _ts mb_trps,+ genMap+ ) addTripleForObject :: (CharParsing m, MonadState ParseState m) => Object -> m () addTripleForObject obj = do@@ -566,59 +607,60 @@ t <- getTriple s p put (bUrl, dUrl, i, pms, s, p, ts |> t, genMap) where- getTriple Nothing _ = unexpected $ "No Subject with which to create triple for: " <> show obj- getTriple _ Nothing = unexpected $ "No Predicate with which to create triple for: " <> show obj+ getTriple Nothing _ = unexpected $ "No Subject with which to create triple for: " <> show obj+ getTriple _ Nothing = unexpected $ "No Predicate with which to create triple for: " <> show obj getTriple (Just s') (Just p') = pure $ Triple s' p' obj -- --------------------------------- -- parsec based parsers --- |Parse the document at the given location URL as a Turtle document, using an optional @BaseUrl@--- as the base URI, and using the given document URL as the URI of the Turtle document itself.+-- | Parse the document at the given location URL as a Turtle document, using an optional @BaseUrl@+-- as the base URI, and using the given document URL as the URI of the Turtle document itself. ----- The @BaseUrl@ is used as the base URI within the document for resolving any relative URI references.--- It may be changed within the document using the @\@base@ directive. At any given point, the current--- base URI is the most recent @\@base@ directive, or if none, the @BaseUrl@ given to @parseURL@, or--- if none given, the document URL given to @parseURL@. For example, if the @BaseUrl@ were--- @http:\/\/example.org\/@ and a relative URI of @\<b>@ were encountered (with no preceding @\@base@--- directive), then the relative URI would expand to @http:\/\/example.org\/b@.+-- The @BaseUrl@ is used as the base URI within the document for resolving any relative URI references.+-- It may be changed within the document using the @\@base@ directive. At any given point, the current+-- base URI is the most recent @\@base@ directive, or if none, the @BaseUrl@ given to @parseURL@, or+-- if none given, the document URL given to @parseURL@. For example, if the @BaseUrl@ were+-- @http:\/\/example.org\/@ and a relative URI of @\<b>@ were encountered (with no preceding @\@base@+-- directive), then the relative URI would expand to @http:\/\/example.org\/b@. ----- The document URL is for the purpose of resolving references to 'this document' within the document,--- and may be different than the actual location URL from which the document is retrieved. Any reference--- to @\<>@ within the document is expanded to the value given here. Additionally, if no @BaseUrl@ is--- given and no @\@base@ directive has appeared before a relative URI occurs, this value is used as the--- base URI against which the relative URI is resolved.+-- The document URL is for the purpose of resolving references to 'this document' within the document,+-- and may be different than the actual location URL from which the document is retrieved. Any reference+-- to @\<>@ within the document is expanded to the value given here. Additionally, if no @BaseUrl@ is+-- given and no @\@base@ directive has appeared before a relative URI occurs, this value is used as the+-- base URI against which the relative URI is resolved. ----- Returns either a @ParseFailure@ or a new RDF containing the parsed triples.-parseURLParsec :: (Rdf a) =>- Maybe BaseUrl -- ^ The optional base URI of the document.- -> Maybe T.Text -- ^ The document URI (i.e., the URI of the document itself); if Nothing, use location URI.- -> String -- ^ The location URI from which to retrieve the Turtle document.- -> IO (Either ParseFailure (RDF a))- -- ^ The parse result, which is either a @ParseFailure@ or the RDF- -- corresponding to the Turtle document.+-- Returns either a @ParseFailure@ or a new RDF containing the parsed triples.+parseURLParsec ::+ (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 T.Text ->+ -- | The location URI from which to retrieve the Turtle document.+ String ->+ -- | The parse result, which is either a @ParseFailure@ or the RDF+ -- corresponding to the Turtle document.+ IO (Either ParseFailure (RDF a)) parseURLParsec bUrl docUrl = parseFromURL (parseStringParsec bUrl docUrl) --- |Parse the given file as a Turtle document. The arguments and return type have the same semantics--- as 'parseURL', except that the last @String@ argument corresponds to a filesystem location rather--- than a location URI.+-- | Parse the given file as a Turtle document. The arguments and return type have the same semantics+-- as 'parseURL', except that the last @String@ argument corresponds to a filesystem location rather+-- than a location URI. ----- Note: it does not relies on OS specificities (encoding, newline convention).+-- Note: it does not relies on OS specificities (encoding, newline convention). ----- Returns either a @ParseFailure@ or a new RDF containing the parsed triples.+-- Returns either a @ParseFailure@ or a new RDF containing the parsed triples. parseFileParsec :: (Rdf a) => Maybe BaseUrl -> Maybe T.Text -> String -> IO (Either ParseFailure (RDF a)) parseFileParsec bUrl docUrl fpath = readFile fpath >>= \c -> pure $ handleResult bUrl (runParser (evalStateT t_turtleDoc (initialState bUrl docUrl)) () (maybe "" T.unpack docUrl) c) --- |Parse the given string as a Turtle document. The arguments and return type have the same semantics--- as <parseURL>, except that the last @String@ argument corresponds to the Turtle document itself as--- a string rather than a location URI.+-- | Parse the given string as a Turtle document. The arguments and return type have the same semantics+-- as <parseURL>, except that the last @String@ argument corresponds to the Turtle document itself as+-- a string rather than a location URI. parseStringParsec :: (Rdf a) => Maybe BaseUrl -> Maybe T.Text -> T.Text -> Either ParseFailure (RDF a) parseStringParsec bUrl docUrl ttlStr = handleResult bUrl (runParser (evalStateT t_turtleDoc (initialState bUrl docUrl)) () "" ttlStr) - --------------------------------- -- attoparsec based parsers @@ -626,21 +668,30 @@ parseStringAttoparsec bUrl docUrl t = handleResult' $ parse (evalStateT t_turtleDoc (initialState bUrl docUrl)) t where handleResult' res = case res of- Fail _ _ err -> -- error err- Left $ ParseFailure $ "Parse failure: \n" <> show err- Partial f -> handleResult' (f mempty)- Done _ (ts,pms) -> Right $! mkRdf (F.toList ts) bUrl pms+ Fail _ _ err ->+ Left $ ParseFailure $ "Parse failure: \n" <> show err+ Partial f -> handleResult' (f mempty)+ Done _ (ts, mb_bUrl, pms) ->+ let chosenBaseUrl =+ if isJust mb_bUrl+ then mb_bUrl+ else bUrl+ in Right $! mkRdf (F.toList ts) chosenBaseUrl pms parseFileAttoparsec :: (Rdf a) => Maybe BaseUrl -> Maybe T.Text -> String -> IO (Either ParseFailure (RDF a)) parseFileAttoparsec bUrl docUrl path = parseStringAttoparsec bUrl docUrl <$> readFile path -parseURLAttoparsec :: (Rdf a) =>- Maybe BaseUrl -- ^ The optional base URI of the document.- -> Maybe T.Text -- ^ The document URI (i.e., the URI of the document itself); if Nothing, use location URI.- -> String -- ^ The location URI from which to retrieve the Turtle document.- -> IO (Either ParseFailure (RDF a))- -- ^ The parse result, which is either a @ParseFailure@ or the RDF- -- corresponding to the Turtle document.+parseURLAttoparsec ::+ (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 T.Text ->+ -- | The location URI from which to retrieve the Turtle document.+ String ->+ -- | The parse result, which is either a @ParseFailure@ or the RDF+ -- corresponding to the Turtle document.+ IO (Either ParseFailure (RDF a)) parseURLAttoparsec bUrl docUrl = parseFromURL (parseStringAttoparsec bUrl docUrl) ---------------------------------@@ -648,12 +699,16 @@ initialState :: Maybe BaseUrl -> Maybe T.Text -> ParseState initialState bUrl docUrl = (BaseUrl <$> docUrl <|> bUrl, docUrl, 1, PrefixMappings mempty, Nothing, Nothing, mempty, mempty) --handleResult :: Rdf a => Maybe BaseUrl -> Either ParseError (Seq Triple, PrefixMappings) -> Either ParseFailure (RDF a)+handleResult :: Rdf a => Maybe BaseUrl -> Either ParseError (Seq Triple, Maybe BaseUrl, PrefixMappings) -> Either ParseFailure (RDF a) handleResult bUrl result = case result of- (Left err) -> Left (ParseFailure $ "Parse failure: \n" <> show err)- (Right (ts, pms)) -> Right $! mkRdf (F.toList ts) bUrl pms-+ (Left err) -> Left (ParseFailure $ "Parse failure: \n" <> show err)+ (Right (ts, mb_bUrl, pms)) ->+ -- the base URL may have been overwritten by a @base statement.+ let chosenBaseUrl =+ if isJust mb_bUrl+ then mb_bUrl+ else bUrl+ in Right $! mkRdf (F.toList ts) chosenBaseUrl pms -------------- -- auxiliary parsing functions@@ -666,10 +721,10 @@ caseInsensitiveString :: (CharParsing m, Monad m) => String -> m String caseInsensitiveString s = try (mapM caseInsensitiveChar s) <?> "\"" <> s <> "\"" -tryIriResolution :: (CharParsing m, Monad m) => Maybe BaseUrl -> Maybe T.Text -> T.Text -> m T.Text+tryIriResolution :: (CharParsing m) => Maybe BaseUrl -> Maybe T.Text -> T.Text -> m T.Text tryIriResolution mbUrl mdUrl iriFrag = tryIriResolution' mbUrl mdUrl where tryIriResolution' (Just (BaseUrl bIri)) _ = either err pure (resolveIRI bIri iriFrag)- tryIriResolution' _ (Just dIri) = either err pure (resolveIRI dIri iriFrag)- tryIriResolution' _ _ = either err pure (resolveIRI mempty iriFrag)+ tryIriResolution' _ (Just dIri) = either err pure (resolveIRI dIri iriFrag)+ tryIriResolution' _ _ = either err pure (resolveIRI mempty iriFrag) err m = unexpected $ mconcat ["Cannot resolve IRI: ", m, " ", show (mbUrl, mdUrl, iriFrag)]
src/Text/RDF/RDF4H/TurtleSerializer.hs view
@@ -1,38 +1,46 @@--- |An RDF serializer for Turtle--- <http://www.w3.org/TeamSubmission/turtle/>.--module Text.RDF.RDF4H.TurtleSerializer(- TurtleSerializer(TurtleSerializer)-)+{-# LANGUAGE CPP #-} +-- | An RDF serializer for Turtle+-- <http://www.w3.org/TeamSubmission/turtle/>.+module Text.RDF.RDF4H.TurtleSerializer+ ( TurtleSerializer (TurtleSerializer),+ ) where -import Data.RDF.Types-import Data.RDF.Query-import Data.RDF.Namespace hiding (rdf)+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0) import Data.Semigroup ((<>))+#else+#endif+#else+#endif++import Control.Monad+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.RDF.Namespace hiding (rdf)+import Data.RDF.Query+import Data.RDF.Types import qualified Data.Text as T import qualified Data.Text.IO as T-import Data.Map(Map)-import qualified Data.Map as Map-import Data.List-import Control.Monad import System.IO data TurtleSerializer = TurtleSerializer (Maybe T.Text) PrefixMappings instance RdfSerializer TurtleSerializer where- hWriteRdf (TurtleSerializer docUrl pms) h rdf = _writeRdf h docUrl (addPrefixMappings rdf pms False)- writeRdf s = hWriteRdf s stdout- hWriteH (TurtleSerializer _ pms) h rdf = writeHeader h (baseUrl rdf) (prefixMappings rdf <> pms)- writeH s = hWriteRdf s stdout+ hWriteRdf (TurtleSerializer docUrl pms) h rdf = _writeRdf h docUrl (addPrefixMappings rdf pms False)+ writeRdf s = hWriteRdf s stdout+ hWriteH (TurtleSerializer _ pms) h rdf = writeHeader h (baseUrl rdf) (prefixMappings rdf <> pms)+ writeH s = hWriteRdf s stdout+ -- TODO: should use mdUrl to render <> where appropriate hWriteTs (TurtleSerializer docUrl pms) h = writeTriples h docUrl pms- writeTs s = hWriteTs s stdout- hWriteT (TurtleSerializer docUrl pms) h = writeTriple h docUrl pms- writeT s = hWriteT s stdout- hWriteN (TurtleSerializer docUrl (PrefixMappings pms)) h n = writeNode h docUrl n pms- writeN s = hWriteN s stdout+ writeTs s = hWriteTs s stdout+ hWriteT (TurtleSerializer docUrl pms) h = writeTriple h docUrl pms+ writeT s = hWriteT s stdout+ hWriteN (TurtleSerializer docUrl (PrefixMappings pms)) h n = writeNode h docUrl n pms+ writeN s = hWriteN s stdout -- TODO: writeRdf currently merges standard namespace prefix mappings with -- the ones that the RDF already contains, so that if the RDF has none@@ -45,18 +53,18 @@ _writeRdf h mdUrl rdf = writeHeader h bUrl pms' >> writeTriples h mdUrl pms' ts >> hPutChar h '\n' where- bUrl = baseUrl rdf+ 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 $ Map.union (asMap $ prefixMappings rdf) (asMap standard_ns_mappings)+ pms' = PrefixMappings $ (asMap $ prefixMappings rdf) asMap (PrefixMappings x) = x- ts = triplesOf rdf+ ts = triplesOf rdf writeHeader :: Handle -> Maybe BaseUrl -> PrefixMappings -> IO () writeHeader h bUrl pms = writeBase h bUrl >> writePrefixes h pms writeBase :: Handle -> Maybe BaseUrl -> IO ()-writeBase _ Nothing =+writeBase _ Nothing = return () writeBase h (Just (BaseUrl bUrl)) = hPutStr h "@base " >> hPutChar h '<' >> T.hPutStr h bUrl >> hPutStr h "> ." >> hPutChar h '\n'@@ -66,14 +74,17 @@ writePrefix :: Handle -> (T.Text, T.Text) -> IO () writePrefix h (pre, uri) =- hPutStr h "@prefix " >> T.hPutStr h pre >> hPutStr h ": " >>- hPutChar h '<' >> T.hPutStr h uri >> hPutStr h "> ." >> hPutChar h '\n'+ hPutStr h "@prefix " >> T.hPutStr h pre >> hPutStr h ": "+ >> hPutChar h '<'+ >> T.hPutStr h uri+ >> hPutStr h "> ."+ >> hPutChar h '\n' writeTriples :: Handle -> Maybe T.Text -> PrefixMappings -> Triples -> IO () writeTriples h mdUrl (PrefixMappings pms) ts = mapM_ (writeSubjGroup h mdUrl revPms) (groupBy equalSubjects ts) where- revPms = Map.fromList $ (\(k,v) -> (v,k)) <$> Map.toList pms+ revPms = Map.fromList $ (\(k, v) -> (v, k)) <$> Map.toList pms writeTriple :: Handle -> Maybe T.Text -> PrefixMappings -> Triple -> IO () writeTriple h mdUrl (PrefixMappings pms) t =@@ -86,12 +97,12 @@ -- Write a group of triples that all have the same subject, with the subject only -- being output once, and comma or semi-colon used as appropriate. writeSubjGroup :: Handle -> Maybe T.Text -> Map T.Text T.Text -> Triples -> IO ()-writeSubjGroup _ _ _ [] = return ()-writeSubjGroup h dUrl pms ts@(t:_) =- 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 " ."+writeSubjGroup _ _ _ [] = return ()+writeSubjGroup h dUrl pms ts@(t : _) =+ 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 " ." where ts' = groupBy equalPredicates ts @@ -99,36 +110,37 @@ -- assuming the subject has already been output and only the predicate and objects -- need to be written. writePredGroup :: Handle -> Maybe T.Text -> Map T.Text T.Text -> Triples -> IO ()-writePredGroup _ _ _ [] = return ()-writePredGroup h docUrl pms (t:ts) =+writePredGroup _ _ _ [] = return ()+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 (objectOf t) pms >>- mapM_ (\t' -> hPutStr h ", " >> writeNode h docUrl (objectOf t') pms) ts+ 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 writeNode :: Handle -> Maybe T.Text -> Node -> Map T.Text T.Text -> IO () writeNode h mdUrl node prefixes = case node of- (UNode bs) -> let currUri = bs- in case mdUrl of- Nothing -> writeUNodeUri h currUri prefixes- Just url -> if url == currUri then hPutStr h "<>" else writeUNodeUri h currUri prefixes+ (UNode bs) ->+ let currUri = bs+ in case mdUrl of+ Nothing -> writeUNodeUri h currUri prefixes+ Just url -> if url == currUri then hPutStr h "<>" else writeUNodeUri h currUri prefixes (BNode gId) -> T.hPutStr h gId- (BNodeGen i)-> putStr "_:genid" >> hPutStr h (show i)- (LNode n) -> writeLValue h n prefixes+ (BNodeGen i) -> putStr "_:genid" >> hPutStr h (show i)+ (LNode n) -> writeLValue h n prefixes writeUNodeUri :: Handle -> T.Text -> Map T.Text T.Text -> IO () writeUNodeUri h uri prefixes = case mapping of- Nothing -> hPutChar h '<' >> T.hPutStr h uri >> hPutChar h '>'+ Nothing -> hPutChar h '<' >> T.hPutStr h uri >> hPutChar h '>' (Just (pre, localName)) -> T.hPutStr h pre >> hPutChar h ':' >> T.hPutStr h localName where- mapping = findMapping prefixes uri+ mapping = findMapping prefixes uri -- Print prefix mappings to stdout for debugging.-_debugPMs :: Map T.Text T.Text -> IO ()-_debugPMs pms = mapM_ (\(k, v) -> T.putStr k >> putStr "__" >> T.putStrLn v) (Map.toList pms)+_debugPMs :: Map T.Text T.Text -> IO ()+_debugPMs pms = mapM_ (\(k, v) -> T.putStr k >> putStr "__" >> T.putStrLn v) (Map.toList pms) -- Expects a map from uri to prefix, and returns the (prefix, uri_expansion) -- from the mappings such that uri_expansion is a prefix of uri, or Nothing if@@ -137,35 +149,39 @@ findMapping :: Map T.Text T.Text -> T.Text -> Maybe (T.Text, T.Text) findMapping pms uri = case mapping of- Nothing -> Nothing+ Nothing -> Nothing Just (u, p) -> Just (p, T.drop (T.length u) uri) -- empty localName is permitted where- mapping = find (\(k, _) -> T.isPrefixOf k uri) (Map.toList pms)+ mapping = find (\(k, _) -> T.isPrefixOf k uri) (Map.toList pms) writeLValue :: Handle -> LValue -> Map T.Text T.Text -> IO () writeLValue h lv pms = case lv of- (PlainL lit) -> writeLiteralString h lit- (PlainLL lit lang) -> writeLiteralString h lit >>- hPutStr h "@" >>- T.hPutStr h lang- (TypedL lit dtype) -> writeLiteralString h lit >>- hPutStr h "^^" >>- writeUNodeUri h dtype pms- -- writeUNodeUri h (T.reverse dtype) pms+ (PlainL lit) -> writeLiteralString h lit+ (PlainLL lit lang) ->+ writeLiteralString h lit+ >> hPutStr h "@"+ >> T.hPutStr h lang+ (TypedL lit dtype) ->+ writeLiteralString h lit+ >> hPutStr h "^^"+ >> writeUNodeUri h dtype pms -writeLiteralString:: Handle -> T.Text -> IO ()+-- writeUNodeUri h (T.reverse dtype) pms++writeLiteralString :: Handle -> T.Text -> IO () writeLiteralString h bs =- do hPutChar h '"'- void (T.foldl' writeChar (return True) bs)- hPutChar h '"'+ do+ hPutChar h '"'+ void (T.foldl' writeChar (return True) bs)+ hPutChar h '"' where writeChar :: IO Bool -> Char -> IO Bool writeChar b c = case c of- '\n' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h 'n') >> return True- '\t' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h 't') >> return True- '\r' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h 'r') >> return True- '"' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h '"') >> return True- '\\' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h '\\') >> return True- _ -> b >>= \b' -> when b' (hPutChar h c) >> return True+ '\n' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h 'n') >> return True+ '\t' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h 't') >> return True+ '\r' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h 'r') >> return True+ '"' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h '"') >> return True+ '\\' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h '\\') >> return True+ _ -> b >>= \b' -> when b' (hPutChar h c) >> return True
src/Text/RDF/RDF4H/XmlParser.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}@@ -27,12 +28,21 @@ import Control.Monad import Control.Monad.Except import Control.Monad.State.Strict-import Data.Semigroup ((<>))+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#else+#endif+#else+#endif import Data.Set (Set) import qualified Data.Set as S import qualified Data.Map as Map import Data.Maybe+#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@@ -480,9 +490,8 @@ checkAllowedAttributes :: HashSet Text -> Parser () checkAllowedAttributes as = do attrs <- currentNodeAttrs- let diff = HS.difference (HM.keysSet attrs) as- unless (null diff) (throwError $ "Attributes not allowed: " <> show diff)-+ 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
src/Text/RDF/RDF4H/XmlParser/Identifiers.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} @@ -10,15 +11,23 @@ ) 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 qualified Data.Attoparsec.Text as P+#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0) import Data.Semigroup ((<>))-+#else+#endif+#else+#endif import Data.RDF.Namespace --------------------------------------------------------------------------------
src/Text/RDF/RDF4H/XmlParser/Xeno.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -18,7 +19,10 @@ 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
src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs view
@@ -134,7 +134,13 @@ 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@@ -172,13 +178,17 @@ -- | 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)@@ -378,14 +388,18 @@ {-# 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+#if MIN_VERSION_base(4,9,0)+ mappend = (<>)+#else mappend = liftA2 mappend--- #endif+#endif {-# INLINE mappend #-} instance Functor m => Functor (ParserT m) where@@ -429,8 +443,10 @@ 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
testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs view
@@ -1,42 +1,45 @@ {-# LANGUAGE OverloadedStrings #-} module Text.RDF.RDF4H.TurtleParser_ConformanceTest- ( tests- ) where+ ( tests,+ )+where -import Data.Semigroup ((<>)) -- Testing imports-import Test.Tasty-import Test.Tasty.HUnit as TU -- Import common libraries to facilitate tests-import Data.RDF.Query++import Control.Applicative ((<|>)) 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+import Test.Tasty.HUnit as TU import Text.Printf import Text.RDF.RDF4H.TurtleParser-import Control.Applicative ((<|>)) -- tests :: TestTree -- tests = testGroup "TurtleParser" allCTests -- A list of other tests to run, each entry of which is (directory, fname_without_ext). otherTestFiles :: [(String, String)]-otherTestFiles = [ ("data/ttl", "example1")- , ("data/ttl", "example2")- , ("data/ttl", "example3")- , ("data/ttl", "example5")- , ("data/ttl", "example6")- , ("data/ttl", "example7")- , ("data/ttl", "example8")- , ("data/ttl", "example9")- , ("data/ttl", "example10")- , ("data/ttl", "example11")- , ("data/ttl", "example12")- , ("data/ttl", "fawlty1") ]-+otherTestFiles =+ [ ("data/ttl", "example1"),+ ("data/ttl", "example2"),+ ("data/ttl", "example3"),+ ("data/ttl", "example5"),+ ("data/ttl", "example6"),+ ("data/ttl", "example7"),+ ("data/ttl", "example8"),+ ("data/ttl", "example9"),+ ("data/ttl", "example10"),+ ("data/ttl", "example11"),+ ("data/ttl", "example12"),+ ("data/ttl", "fawlty1")+ ] -- The Base URI to be used for all conformance tests: testBaseUri :: Text@@ -46,28 +49,51 @@ mtestBaseUri = Just . BaseUrl $ testBaseUri tests :: [TestTree]-tests = fmap (uncurry checkGoodOtherTest) otherTestFiles+tests =+ baseUrlTests+ : fmap (uncurry checkGoodOtherTest) otherTestFiles +baseUrlTests :: TestTree+baseUrlTests =+ let t1 = assertBaseUrlSuccess (parseFile (TurtleParser Nothing Nothing) "data/ttl/example13.ttl") "http://example.org" "baseUrl-test1"+ in testGroup "baseUrl-tests" $+ fmap (uncurry testCase) [("baseUrl-test1", t1)]++assertBaseUrlSuccess :: IO (Either ParseFailure (RDF TList)) -> Text -> String -> TU.Assertion+assertBaseUrlSuccess exprGr expectedBUrl testLabel = do+ g <- exprGr+ case g of+ Left (ParseFailure err) -> TU.assertFailure err+ Right g' ->+ case baseUrl g' of+ Just (BaseUrl bUrl) ->+ if bUrl == expectedBUrl+ then return ()+ else TU.assertFailure $ "wrong base URL: " <> testLabel+ Nothing -> TU.assertFailure $ "no base URL: " <> testLabel+ 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 "turtle-%s" fname+ let expGr = loadExpectedGraph1 (printf "%s/%s.out" dir fname :: String)+ inGr = loadInputGraph1 dir fname+ in doGoodConformanceTest expGr inGr $ printf "turtle-%s" fname -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)] -- 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 e) _ = Just $ "Parse failure of the expected graph: " <> show e-equivalent _ (Left e) = Just $ "Parse failure of the input graph: " <> show e+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) where gr1ts = uordered $ triplesOf gr1@@ -75,13 +101,12 @@ length1 = length gr1ts length2 = length gr2ts checkSize = if (length1 == length2) then Nothing else (Just $ "Size different. Expected: " <> (show length1) <> ", got: " <> (show length2))- test [] = Nothing- test ((t1,t2):ts) = maybe (test ts) pure (compareTriple t1 t2)+ test [] = Nothing+ test ((t1, t2) : ts) = maybe (test ts) pure (compareTriple t1 t2) compareTriple t1@(Triple s1 p1 o1) t2@(Triple s2 p2 o2) = if equalNodes s1 s2 && equalNodes p1 p2 && equalNodes o1 o2 then Nothing else Just ("Expected:\n " <> show t1 <> "\nFound:\n " <> show t2 <> "\n")- -- I'm not sure it's right to compare blank nodes with generated -- blank nodes. This is because parsing an already generated blank -- node is parsed as a blank node. Moreover, a parser is free to@@ -95,16 +120,17 @@ -- -- which just so happens to be what Apache Jena just created when -- [] was parsed.- equalNodes (BNode _) (BNodeGen _) = True- equalNodes (BNodeGen _) (BNode _) = True+ equalNodes (BNode _) (BNodeGen _) = True+ equalNodes (BNodeGen _) (BNode _) = True equalNodes (BNodeGen _) (BNodeGen _) = True- equalNodes (BNode _) (BNode _) = True- equalNodes n1 n2 = n1 == n2+ equalNodes (BNode _) (BNode _) = True+ equalNodes n1 n2 = n1 == n2 loadInputGraph1 :: String -> String -> IO (Either ParseFailure (RDF TList)) loadInputGraph1 dir fname = parseFile parserConfig path- where path = printf "%s/%s.ttl" dir fname :: String- parserConfig = TurtleParser mtestBaseUri (mkDocUrl1 testBaseUri fname)+ where+ path = printf "%s/%s.ttl" dir fname :: String+ parserConfig = TurtleParser mtestBaseUri (mkDocUrl1 testBaseUri fname) loadExpectedGraph1 :: String -> IO (Either ParseFailure (RDF TList)) loadExpectedGraph1 fname =@@ -114,7 +140,7 @@ 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 () assertEquivalent :: Rdf a => String -> IO (Either ParseFailure (RDF a)) -> IO (Either ParseFailure (RDF a)) -> TU.Assertion@@ -122,8 +148,8 @@ gr1 <- r1 gr2 <- r2 case equivalent gr1 gr2 of- Nothing -> return ()+ Nothing -> return () (Just msg) -> fail $ "Graph " <> testname <> " not equivalent to expected:\n" <> msg mkDocUrl1 :: Text -> String -> Maybe Text-mkDocUrl1 baseDocUrl fname = Just . fromString $ printf "%s%s.ttl" baseDocUrl fname+mkDocUrl1 baseDocUrl fname = Just . fromString $ printf "%s%s.ttl" baseDocUrl fname
testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs view
@@ -40,6 +40,7 @@ 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")