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