diff --git a/bench/MainCriterion.hs b/bench/MainCriterion.hs --- a/bench/MainCriterion.hs +++ b/bench/MainCriterion.hs @@ -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 diff --git a/examples/BuildRDFGraph.hs b/examples/BuildRDFGraph.hs new file mode 100644 --- /dev/null +++ b/examples/BuildRDFGraph.hs @@ -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) diff --git a/rdf4h.cabal b/rdf4h.cabal --- a/rdf4h.cabal +++ b/rdf4h.cabal @@ -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 diff --git a/src/Data/RDF/Graph/AdjHashMap.hs b/src/Data/RDF/Graph/AdjHashMap.hs --- a/src/Data/RDF/Graph/AdjHashMap.hs +++ b/src/Data/RDF/Graph/AdjHashMap.hs @@ -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 diff --git a/src/Data/RDF/Graph/AlgebraicGraph.hs b/src/Data/RDF/Graph/AlgebraicGraph.hs --- a/src/Data/RDF/Graph/AlgebraicGraph.hs +++ b/src/Data/RDF/Graph/AlgebraicGraph.hs @@ -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 diff --git a/src/Data/RDF/Graph/TList.hs b/src/Data/RDF/Graph/TList.hs --- a/src/Data/RDF/Graph/TList.hs +++ b/src/Data/RDF/Graph/TList.hs @@ -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 diff --git a/src/Data/RDF/IRI.hs b/src/Data/RDF/IRI.hs --- a/src/Data/RDF/IRI.hs +++ b/src/Data/RDF/IRI.hs @@ -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 diff --git a/src/Data/RDF/Namespace.hs b/src/Data/RDF/Namespace.hs --- a/src/Data/RDF/Namespace.hs +++ b/src/Data/RDF/Namespace.hs @@ -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 diff --git a/src/Data/RDF/Query.hs b/src/Data/RDF/Query.hs --- a/src/Data/RDF/Query.hs +++ b/src/Data/RDF/Query.hs @@ -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 diff --git a/src/Data/RDF/Types.hs b/src/Data/RDF/Types.hs --- a/src/Data/RDF/Types.hs +++ b/src/Data/RDF/Types.hs @@ -1,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 diff --git a/src/Rdf4hParseMain.hs b/src/Rdf4hParseMain.hs --- a/src/Rdf4hParseMain.hs +++ b/src/Rdf4hParseMain.hs @@ -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)) diff --git a/src/Text/RDF/RDF4H/NTriplesParser.hs b/src/Text/RDF/RDF4H/NTriplesParser.hs --- a/src/Text/RDF/RDF4H/NTriplesParser.hs +++ b/src/Text/RDF/RDF4H/NTriplesParser.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- |A parser for RDF in N-Triples format -- . @@ -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) diff --git a/src/Text/RDF/RDF4H/ParserUtils.hs b/src/Text/RDF/RDF4H/ParserUtils.hs --- a/src/Text/RDF/RDF4H/ParserUtils.hs +++ b/src/Text/RDF/RDF4H/ParserUtils.hs @@ -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 diff --git a/src/Text/RDF/RDF4H/TurtleParser.hs b/src/Text/RDF/RDF4H/TurtleParser.hs --- a/src/Text/RDF/RDF4H/TurtleParser.hs +++ b/src/Text/RDF/RDF4H/TurtleParser.hs @@ -1,104 +1,115 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DoAndIfThenElse #-} --- |An 'RdfParser' implementation for the Turtle format --- . - +-- | An 'RdfParser' implementation for the Turtle format +-- . 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 @\@ 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 @\@ 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 , 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 , 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)] diff --git a/src/Text/RDF/RDF4H/TurtleSerializer.hs b/src/Text/RDF/RDF4H/TurtleSerializer.hs --- a/src/Text/RDF/RDF4H/TurtleSerializer.hs +++ b/src/Text/RDF/RDF4H/TurtleSerializer.hs @@ -1,38 +1,46 @@ --- |An RDF serializer for Turtle --- . - -module Text.RDF.RDF4H.TurtleSerializer( - TurtleSerializer(TurtleSerializer) -) +{-# LANGUAGE CPP #-} +-- | An RDF serializer for 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 diff --git a/src/Text/RDF/RDF4H/XmlParser.hs b/src/Text/RDF/RDF4H/XmlParser.hs --- a/src/Text/RDF/RDF4H/XmlParser.hs +++ b/src/Text/RDF/RDF4H/XmlParser.hs @@ -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 diff --git a/src/Text/RDF/RDF4H/XmlParser/Identifiers.hs b/src/Text/RDF/RDF4H/XmlParser/Identifiers.hs --- a/src/Text/RDF/RDF4H/XmlParser/Identifiers.hs +++ b/src/Text/RDF/RDF4H/XmlParser/Identifiers.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/src/Text/RDF/RDF4H/XmlParser/Xeno.hs b/src/Text/RDF/RDF4H/XmlParser/Xeno.hs --- a/src/Text/RDF/RDF4H/XmlParser/Xeno.hs +++ b/src/Text/RDF/RDF4H/XmlParser/Xeno.hs @@ -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 diff --git a/src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs b/src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs --- a/src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs +++ b/src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs @@ -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 diff --git a/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs b/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs --- a/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs +++ b/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs @@ -1,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 diff --git a/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs b/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs --- a/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs +++ b/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs @@ -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")