rdf4h 3.1.1 → 4.0.0
raw patch · 31 files changed
+2388/−873 lines, 31 filesdep +algebraic-graphsdep +exceptionsdep +html-entitiesdep −HTTPdep −hxtdep ~unordered-containers
Dependencies added: algebraic-graphs, exceptions, html-entities, mmorph, selective, xeno
Dependencies removed: HTTP, hxt
Dependency ranges changed: unordered-containers
Files
- bench/MainCriterion.hs +54/−41
- examples/ESWC.hs +3/−3
- examples/ParseURLs.hs +1/−1
- rdf4h.cabal +34/−16
- src/Data/RDF.hs +4/−0
- src/Data/RDF/Graph/AdjHashMap.hs +6/−7
- src/Data/RDF/Graph/AlgebraicGraph.hs +113/−0
- src/Data/RDF/Graph/TList.hs +4/−4
- src/Data/RDF/IRI.hs +28/−21
- src/Data/RDF/Namespace.hs +36/−38
- src/Data/RDF/Query.hs +4/−2
- src/Data/RDF/Types.hs +21/−20
- src/Rdf4hParseMain.hs +20/−19
- src/Text/RDF/RDF4H/NTriplesParser.hs +12/−12
- src/Text/RDF/RDF4H/ParserUtils.hs +84/−10
- src/Text/RDF/RDF4H/TurtleParser.hs +26/−30
- src/Text/RDF/RDF4H/TurtleSerializer.hs +9/−8
- src/Text/RDF/RDF4H/XmlParser.hs +653/−486
- src/Text/RDF/RDF4H/XmlParser/Identifiers.hs +108/−0
- src/Text/RDF/RDF4H/XmlParser/Xeno.hs +91/−0
- src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs +938/−0
- testsuite/tests/Data/RDF/IRITests.hs +0/−3
- testsuite/tests/Data/RDF/PropertyTests.hs +24/−23
- testsuite/tests/Test.hs +16/−12
- testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs +10/−45
- testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs +19/−19
- testsuite/tests/W3C/Manifest.hs +8/−7
- testsuite/tests/W3C/NTripleTest.hs +2/−2
- testsuite/tests/W3C/RdfXmlTest.hs +21/−14
- testsuite/tests/W3C/TurtleTest.hs +33/−25
- testsuite/tests/W3C/W3CAssertions.hs +6/−5
bench/MainCriterion.hs view
@@ -4,6 +4,7 @@ module Main where import Prelude hiding (readFile)+import Data.Semigroup (Semigroup(..)) import Criterion import Criterion.Types import Criterion.Main@@ -18,21 +19,15 @@ -- $ gzip -d bills.099.actions.rdf.gz parseXmlRDF :: Rdf a => T.Text -> RDF a-parseXmlRDF s =- let (Right rdf) = parseString (XmlParser Nothing Nothing) s- in rdf+parseXmlRDF = either (error . show) id . parseString (XmlParser Nothing Nothing) {-# INLINE parseXmlRDF #-} parseNtRDF :: Rdf a => T.Text -> RDF a-parseNtRDF s =- let (Right rdf) = parseString NTriplesParser s- in rdf+parseNtRDF = either (error . show) id . parseString NTriplesParser {-# INLINE parseNtRDF #-} parseTtlRDF :: Rdf a => T.Text -> RDF a-parseTtlRDF s =- let (Right rdf) = parseString (TurtleParser Nothing Nothing) s- in rdf+parseTtlRDF = either (error . show) id . parseString (TurtleParser Nothing Nothing) {-# INLINE parseTtlRDF #-} queryGr :: Rdf a => (Maybe Node,Maybe Node,Maybe Node,RDF a) -> [Triple]@@ -48,15 +43,19 @@ main = defaultMainWith (defaultConfig {resamples = 100}) [ env+ -- [FIXME] Do not rely on system's defaults to read files. (do fawltyContentTurtle <- readFile "data/ttl/fawlty1.ttl" fawltyContentNTriples <- readFile "data/nt/all-fawlty-towers.nt"- rdf1' <- parseFile (XmlParser Nothing Nothing) xmlFile- rdf2' <- parseFile (XmlParser Nothing Nothing) xmlFile- let rdf1 = either (error . show) id rdf1' :: RDF TList+ xmlContent <- readFile xmlFile+ let rdf1' = parseString (XmlParser Nothing Nothing) xmlContent+ rdf2' = parseString (XmlParser Nothing Nothing) xmlContent+ rdf3' =parseString (XmlParser Nothing Nothing) xmlContent+ rdf1 = either (error . show) id rdf1' :: RDF TList rdf2 = either (error . show) id rdf2' :: RDF AdjHashMap+ rdf3 = either (error . show) id rdf3' :: RDF AlgebraicGraph triples = triplesOf rdf1- return (rdf1, rdf2, triples, fawltyContentNTriples, fawltyContentTurtle)) $- \ ~(triplesList, adjMap, triples, fawltyContentNTriples, fawltyContentTurtle) ->+ return (rdf1, rdf2, rdf3, triples, fawltyContentNTriples, fawltyContentTurtle, xmlContent)) $+ \ ~(triplesList, adjMap, algGraph, triples, fawltyContentNTriples, fawltyContentTurtle, xmlContent) -> bgroup "rdf4h" [ bgroup@@ -81,42 +80,56 @@ let res = parseString (TurtleParserCustom Nothing Nothing Attoparsec) t :: Either ParseFailure (RDF TList) in either (error . show) id res ) fawltyContentTurtle+ , bench "xml-xmlbf" $+ nf (\t ->+ let res = parseString (XmlParser Nothing Nothing) t :: Either ParseFailure (RDF TList)+ in either (error . show) id res+ ) xmlContent+ -- , bench "xml-xht" $+ -- nf (\t ->+ -- let res = parseString (XmlParserHXT Nothing Nothing) t :: Either ParseFailure (RDF TList)+ -- in either (error . show) id res+ -- ) xmlContent ] , bgroup "query"- (queryBench "TList" triplesList ++- queryBench "AdjHashMap" adjMap- -- queryBench "SP" mapSP ++ queryBench "HashSP" hashMapSP+ (queryBench "TList" triplesList <>+ queryBench "AdjHashMap" adjMap <>+ queryBench "AlgebraicGraph" algGraph+ -- queryBench "SP" mapSP <> queryBench "HashSP" hashMapSP ) , bgroup "select"- (selectBench "TList" triplesList ++- selectBench "AdjHashMap" adjMap- -- selectBench "SP" mapSP ++ selectBench "HashSP" hashMapSP+ (selectBench "TList" triplesList <>+ selectBench "AdjHashMap" adjMap <>+ selectBench "AlgebraicGraph" algGraph+ -- selectBench "SP" mapSP <> selectBench "HashSP" hashMapSP ) , bgroup "add-remove-triples"- (addRemoveTriples "TList" triples (empty :: RDF TList) triplesList- ++ addRemoveTriples "AdjHashMap" triples (empty :: RDF AdjHashMap) adjMap+ (addRemoveTriples "TList" triples (empty :: RDF TList) triplesList <>+ addRemoveTriples "AdjHashMap" triples (empty :: RDF AdjHashMap) adjMap <>+ addRemoveTriples "AlgebraicGraph" triples (empty :: RDF AlgebraicGraph) algGraph ) , bgroup "count_triples" [ bench "TList" (nf (length . triplesOf) triplesList) , bench "AdjHashMap" (nf (length . triplesOf) adjMap)+ , bench "AlgebraicGraph" (nf (length . triplesOf) algGraph) ] ] ] selectBench :: Rdf a => String -> RDF a -> [Benchmark] selectBench label gr =- [ bench (label ++ " SPO") $ nf selectGr (subjSelect,predSelect,objSelect,gr)- , bench (label ++ " SP") $ nf selectGr (subjSelect,predSelect,selectNothing,gr)- , bench (label ++ " S") $ nf selectGr (subjSelect,selectNothing,selectNothing,gr)- , bench (label ++ " PO") $ nf selectGr (selectNothing,predSelect,objSelect,gr)- , bench (label ++ " SO") $ nf selectGr (subjSelect,selectNothing,objSelect,gr)- , bench (label ++ " P") $ nf selectGr (selectNothing,predSelect,selectNothing,gr)- , bench (label ++ " O") $ nf selectGr (selectNothing,selectNothing,objSelect,gr)+ [ bench (label <> " SPO") $ nf selectGr (subjSelect,predSelect,objSelect,gr)+ , bench (label <> " SP") $ nf selectGr (subjSelect,predSelect,selectNothing,gr)+ , bench (label <> " S") $ nf selectGr (subjSelect,selectNothing,selectNothing,gr)+ , bench (label <> " PO") $ nf selectGr (selectNothing,predSelect,objSelect,gr)+ , bench (label <> " SO") $ nf selectGr (subjSelect,selectNothing,objSelect,gr)+ , bench (label <> " P") $ nf selectGr (selectNothing,predSelect,selectNothing,gr)+ , bench (label <> " O") $ nf selectGr (selectNothing,selectNothing,objSelect,gr) ] subjSelect, predSelect, objSelect, selectNothing :: Maybe (Node -> Bool)@@ -133,25 +146,25 @@ queryBench :: Rdf a => String -> RDF a -> [Benchmark] queryBench label gr =- [ bench (label ++ " SPO") $ nf queryGr (subjQuery,predQuery,objQuery,gr)- , bench (label ++ " SP") $ nf queryGr (subjQuery,predQuery,queryNothing,gr)- , bench (label ++ " S") $ nf queryGr (subjQuery,queryNothing,queryNothing,gr)- , bench (label ++ " PO") $ nf queryGr (queryNothing,predQuery,objQuery,gr)- , bench (label ++ " SO") $ nf queryGr (subjQuery,queryNothing,objQuery,gr)- , bench (label ++ " P") $ nf queryGr (queryNothing,predQuery,queryNothing,gr)- , bench (label ++ " O") $ nf queryGr (queryNothing,queryNothing,objQuery,gr)+ [ bench (label <> " SPO") $ nf queryGr (subjQuery,predQuery,objQuery,gr)+ , bench (label <> " SP") $ nf queryGr (subjQuery,predQuery,queryNothing,gr)+ , bench (label <> " S") $ nf queryGr (subjQuery,queryNothing,queryNothing,gr)+ , bench (label <> " PO") $ nf queryGr (queryNothing,predQuery,objQuery,gr)+ , bench (label <> " SO") $ nf queryGr (subjQuery,queryNothing,objQuery,gr)+ , bench (label <> " P") $ nf queryGr (queryNothing,predQuery,queryNothing,gr)+ , bench (label <> " O") $ nf queryGr (queryNothing,queryNothing,objQuery,gr) ] -addRemoveTriples :: (NFData a,NFData (RDF a), Rdf a) => String -> Triples -> RDF a -> RDF a -> [Benchmark]+addRemoveTriples :: (NFData (RDF a), Rdf a) => String -> Triples -> RDF a -> RDF a -> [Benchmark] addRemoveTriples lbl triples emptyGr populatedGr =- [ bench (lbl ++ "-add-triples") $ nf addTriples (triples,emptyGr)- , bench (lbl ++ "-remove-triples") $ nf removeTriples (triples,populatedGr)+ [ bench (lbl <> "-add-triples") $ nf addTriples (triples,emptyGr)+ , bench (lbl <> "-remove-triples") $ nf removeTriples (triples,populatedGr) ] addTriples :: Rdf a => (Triples,RDF a) -> RDF a addTriples (triples,emptyGr) =- foldr (\t g -> addTriple g t) emptyGr triples+ foldr (flip addTriple) emptyGr triples removeTriples :: Rdf a => (Triples,RDF a) -> RDF a removeTriples (triples,populatedGr) =- foldr (\t g -> removeTriple g t) populatedGr triples+ foldr (flip removeTriple) populatedGr triples
examples/ESWC.hs view
@@ -13,8 +13,8 @@ eswcCommitteeMembers :: RDF TList -> [T.Text] eswcCommitteeMembers graph = let triples = query graph (Just (unode eswcCommitteeURI)) (Just (unode heldByProp)) Nothing- memberURIs = map objectOf triples- in map+ memberURIs = fmap objectOf triples+ in fmap (\memberURI -> let (LNode (PlainL (firstName::T.Text))) = objectOf $ head $ query graph (Just memberURI) (Just (unode "foaf:firstName")) Nothing@@ -22,7 +22,7 @@ objectOf $ head $ query graph (Just memberURI) (Just (unode "foaf:lastName")) Nothing in (T.append firstName (T.append (T.pack " ") lastName))) memberURIs- + main :: IO () main = do result <- parseURL
examples/ParseURLs.hs view
@@ -11,7 +11,7 @@ timBernersLee = do Right (rdf::RDF TList) <- parseURL (XmlParser Nothing Nothing) "http://www.w3.org/People/Berners-Lee/card.rdf" let ts = query rdf (Just (UNode "http://www.w3.org/2011/Talks/0331-hyderabad-tbl/data#talk")) (Just (UNode "dct:title")) Nothing- let talks = map (\(Triple _ _ (LNode (PlainL s))) -> s) ts+ let talks = fmap (\(Triple _ _ (LNode (PlainL s))) -> s) ts print talks main :: IO ()
rdf4h.cabal view
@@ -1,5 +1,5 @@ name: rdf4h-version: 3.1.1+version: 4.0.0 synopsis: A library for RDF processing in Haskell description: 'RDF for Haskell' is a library for working with RDF in Haskell.@@ -9,7 +9,7 @@ selecting triples that satisfy an arbitrary predicate function. author: Rob Stewart, Pierre Le Marre, Slava Kravchenko, Calvin Smith-copyright: (c) Rob Stewart, Pierre Le Marre, Slava Kravchenko, Calvin Smith+copyright: (c) Rob Stewart, Pierre Le Marre, Slava Kravchenko, Calvin Smith, Renzo Carbonara maintainer: Rob Stewart <robstewart57@gmail.com> homepage: https://github.com/robstewart57/rdf4h bug-reports: https://github.com/robstewart57/rdf4h/issues@@ -19,24 +19,31 @@ build-type: Simple category: RDF stability: Experimental-tested-with: GHC==7.10.2, GHC==8.0.2+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.8.2, GHC==8.4.3, GHC==8.6.5 extra-tmp-files: test extra-source-files: examples/ParseURLs.hs , examples/ESWC.hs +source-repository head+ type: git+ location: https://github.com/robstewart57/rdf4h.git+ library+ hs-source-dirs: src exposed-modules: Data.RDF , Data.RDF.IRI , Data.RDF.Namespace , Data.RDF.Types , Data.RDF.Query , Data.RDF.Graph.AdjHashMap+ , Data.RDF.Graph.AlgebraicGraph , Data.RDF.Graph.TList , Text.RDF.RDF4H.TurtleParser , Text.RDF.RDF4H.TurtleSerializer , Text.RDF.RDF4H.NTriplesParser , Text.RDF.RDF4H.NTriplesSerializer , Text.RDF.RDF4H.XmlParser+ , Text.RDF.RDF4H.XmlParser.Identifiers , Text.RDF.RDF4H.ParserUtils build-depends: attoparsec , base >= 4.8.0.0@@ -44,10 +51,11 @@ , filepath , containers , parsec >= 3- , HTTP >= 4000.0.0- , hxt >= 9.3.1.2+ -- , HTTP >= 4000.0.0+ -- , hxt >= 9.3.1.2 , text >= 1.2.1.0- , unordered-containers+ , algebraic-graphs >= 0.3 && < 0.5+ , unordered-containers >= 0.2.10.0 , hashable , deepseq , binary@@ -55,15 +63,23 @@ , parsers , mtl , network-uri >= 2.6+ -- , xmlbf >= 0.6+ -- , xmlbf-xeno , lifted-base , http-conduit+ , mmorph+ , exceptions+ , selective+ , html-entities+ , xeno+ 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) build-depends: semigroups == 0.18.* - hs-source-dirs: src- ghc-options: -Wall -funbox-strict-fields+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints executable rdf4h main-is: src/Rdf4hParseMain.hs@@ -75,11 +91,12 @@ if impl(ghc < 7.6) build-depends: ghc-prim - ghc-options: -Wall -funbox-strict-fields+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints test-suite test-rdf4h type: exitcode-stdio-1.0 main-is: Test.hs+ hs-source-dirs: testsuite/tests other-modules: Data.RDF.PropertyTests Data.RDF.GraphImplTests Data.RDF.IRITests@@ -87,9 +104,9 @@ Text.RDF.RDF4H.XmlParser_Test W3C.Manifest W3C.NTripleTest+ W3C.TurtleTest W3C.RdfXmlTest W3C.W3CAssertions- ghc-options: -Wall -fno-warn-orphans -funbox-strict-fields build-depends: base >= 4.8.0.0 && < 6 , rdf4h , tasty@@ -105,9 +122,10 @@ if impl(ghc < 7.6) build-depends: ghc-prim+ if !impl(ghc >= 8.0)+ build-depends: semigroups == 0.18.* - other-modules: W3C.TurtleTest- hs-source-dirs: testsuite/tests+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints benchmark rdf4h-bench type: exitcode-stdio-1.0@@ -118,8 +136,8 @@ criterion, rdf4h, text >= 1.2.1.0- ghc-options: -Wall -source-repository head- type: git- location: https://github.com/robstewart57/rdf4h.git+ if !impl(ghc >= 8.0)+ build-depends: semigroups == 0.18.*++ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
src/Data/RDF.hs view
@@ -15,6 +15,7 @@ -- * RDF type class instances module Data.RDF.Graph.TList, module Data.RDF.Graph.AdjHashMap,+ module Data.RDF.Graph.AlgebraicGraph, -- module Data.RDF.Graph.HashMapSP, -- module Data.RDF.Graph.MapSP, @@ -24,11 +25,13 @@ module Text.RDF.RDF4H.TurtleSerializer, module Text.RDF.RDF4H.TurtleParser, module Text.RDF.RDF4H.XmlParser,+ --module Text.RDF.RDF4H.XmlParserHXT, ) where import Data.RDF.Namespace import Data.RDF.Graph.TList import Data.RDF.Graph.AdjHashMap+import Data.RDF.Graph.AlgebraicGraph -- import Data.RDF.Graph.HashMapSP -- import Data.RDF.Graph.MapSP import Text.RDF.RDF4H.NTriplesSerializer@@ -36,6 +39,7 @@ import Text.RDF.RDF4H.NTriplesParser import Text.RDF.RDF4H.TurtleParser import Text.RDF.RDF4H.XmlParser+--import Text.RDF.RDF4H.XmlParserHXT import Data.RDF.IRI import Data.RDF.Types import Data.RDF.Query
src/Data/RDF/Graph/AdjHashMap.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -13,11 +12,11 @@ module Data.RDF.Graph.AdjHashMap (AdjHashMap) where import Prelude hiding (pred)+import Data.Semigroup ((<>)) import Data.List import Data.Binary (Binary) import Data.RDF.Types import Data.RDF.Query-import Data.RDF.Namespace import Data.Hashable () import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap@@ -103,16 +102,16 @@ -- show (AdjHashMap ((spoMap, _), _, _)) = -- let ts = concatMap (uncurry tripsSubj) subjPredMaps -- where subjPredMaps = HashMap.toList spoMap--- in concatMap (\t -> show t ++ "\n") ts+-- in concatMap (\t -> show t <> "\n") ts -showGraph' :: RDF AdjHashMap -> [Char]+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+ in concatMap (\t -> show t <> "\n") ts -- instance Show (RDF AdjHashMap) where--- show gr = concatMap (\t -> show t ++ "\n") (triplesOf gr)+-- show gr = concatMap (\t -> show t <> "\n") (triplesOf gr) -- some convenience type alias for readability @@ -132,7 +131,7 @@ addPrefixMappings' :: RDF AdjHashMap -> PrefixMappings -> Bool -> RDF AdjHashMap addPrefixMappings' (AdjHashMap (ts, baseURL, pms)) pms' replace =- let merge = if replace then flip mergePrefixMappings else mergePrefixMappings+ let merge = if replace then flip (<>) else (<>) in AdjHashMap (ts, baseURL, merge pms pms') empty' :: RDF AdjHashMap
+ src/Data/RDF/Graph/AlgebraicGraph.hs view
@@ -0,0 +1,113 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} -- [TODO] Remove when the missing NFData instance is added to Alga.+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyDataDecls #-}+++module Data.RDF.Graph.AlgebraicGraph+ ( AlgebraicGraph+ ) where+++import Data.Semigroup (Semigroup(..))+import Control.DeepSeq (NFData(..))+import Data.Binary+import Data.RDF.Namespace+import Data.RDF.Query+import Data.RDF.Types (RDF, Rdf(..), BaseUrl, Triples, Triple(..), Node, Subject, Predicate, Object, NodeSelector)+import qualified Algebra.Graph.Labelled as G+import Data.HashSet (HashSet)+import qualified Data.HashSet as HS+import GHC.Generics+++data AlgebraicGraph deriving (Generic)++instance Binary AlgebraicGraph+instance NFData AlgebraicGraph++data instance RDF AlgebraicGraph = AlgebraicGraph+ { _graph :: G.Graph (HashSet Node) Node+ , _baseUrl :: Maybe BaseUrl+ , _prefixMappings :: PrefixMappings+ } deriving (Generic, NFData)++-- [TODO] Remove this orphan instance when the missing NFData instance is added to Alga.+instance (NFData e, NFData a) => NFData (G.Graph e a) where+ rnf G.Empty = ()+ rnf (G.Vertex x ) = rnf x+ rnf (G.Connect e x y) = e `seq` rnf x `seq` rnf y++instance Rdf AlgebraicGraph where+ baseUrl = _baseUrl+ prefixMappings = _prefixMappings+ addPrefixMappings = addPrefixMappings'+ empty = empty'+ mkRdf = mkRdf'+ addTriple = addTriple'+ removeTriple = removeTriple'+ triplesOf = triplesOf'+ uniqTriplesOf = triplesOf'+ select = select'+ query = query'+ showGraph = showGraph'++toEdge :: Triple -> (HashSet Predicate, Subject, Object)+toEdge (Triple s p o) = (HS.singleton p, s, o)++toTriples :: (HashSet Predicate, Subject, Object) -> Triples+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)++addPrefixMappings' :: RDF AlgebraicGraph -> PrefixMappings -> Bool -> RDF AlgebraicGraph+addPrefixMappings' (AlgebraicGraph g baseURL pms) pms' replace =+ let merge = if replace then flip (<>) else (<>)+ in AlgebraicGraph g baseURL (merge pms pms')++empty' :: RDF AlgebraicGraph+empty' = AlgebraicGraph G.empty mempty (PrefixMappings mempty)++mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> RDF AlgebraicGraph+mkRdf' ts baseURL pms =+ let g = G.edges . fmap toEdge $ ts+ in AlgebraicGraph g baseURL pms++addTriple' :: RDF AlgebraicGraph -> Triple -> RDF AlgebraicGraph+addTriple' (AlgebraicGraph g baseURL pms) (Triple s p o) =+ let g' = G.edge (HS.singleton p) s o+ in AlgebraicGraph (G.overlay g g') baseURL pms++removeTriple' :: RDF AlgebraicGraph -> Triple -> RDF AlgebraicGraph+removeTriple' (AlgebraicGraph g baseURL pms) (Triple s p o) =+ let ps = G.edgeLabel s o g+ g'+ | HS.null ps = g+ | elem p ps = G.replaceEdge (HS.delete p ps) s o g+ | otherwise = g+ in AlgebraicGraph g' baseURL pms++triplesOf' :: RDF AlgebraicGraph -> Triples+triplesOf' (AlgebraicGraph g _ _) = mconcat $ toTriples <$> G.edgeList g++select' :: RDF AlgebraicGraph -> NodeSelector -> NodeSelector -> NodeSelector -> Triples+select' r Nothing Nothing Nothing = triplesOf r+select' (AlgebraicGraph g _ _) s p o = let (res, _, _) = G.foldg e v c g in res+ where+ e = (mempty, mempty, mempty)+ v x = (mempty, s ?? x, o ?? x)+ (??) f x' = let xs = HS.singleton x' in maybe xs (`HS.filter` xs) f+ c ps (ts1, ss1, os1) (ts2, ss2, os2) = (ts3, ss3, os3)+ where+ ss3 = ss1 <> ss2+ os3 = os1 <> os2+ ts3+ | HS.null ps' = ts1 <> ts2+ | otherwise = ts1 <> ts2 <> [Triple s' p' o' | s' <- HS.toList ss3, p' <- HS.toList ps', o' <- HS.toList os3]+ ps' = maybe ps (`HS.filter` ps) p++query' :: RDF AlgebraicGraph -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples+query' r Nothing Nothing Nothing = triplesOf r+query' r s p o = select r ((==) <$> s) ((==) <$> p) ((==) <$> o)
src/Data/RDF/Graph/TList.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} @@ -20,6 +19,7 @@ module Data.RDF.Graph.TList (TList) where import Prelude+import Data.Semigroup ((<>)) import Control.DeepSeq (NFData) import Data.Binary import Data.RDF.Namespace@@ -70,15 +70,15 @@ query = query' showGraph = showGraph' -showGraph' :: RDF TList -> [Char]-showGraph' gr = concatMap (\t -> show t ++ "\n") (expandTriples gr)+showGraph' :: RDF TList -> String+showGraph' gr = concatMap (\t -> show t <> "\n") (expandTriples gr) prefixMappings' :: RDF TList -> PrefixMappings prefixMappings' (TListC(_, _, pms)) = pms addPrefixMappings' :: RDF TList -> PrefixMappings -> Bool -> RDF TList addPrefixMappings' (TListC(ts, baseURL, pms)) pms' replace =- let merge = if replace then flip mergePrefixMappings else mergePrefixMappings+ let merge = if replace then flip (<>) else (<>) in TListC(ts, baseURL, merge pms pms') baseUrl' :: RDF TList -> Maybe BaseUrl
src/Data/RDF/IRI.hs view
@@ -16,15 +16,16 @@ , serializeIRI , parseIRI, parseRelIRI , validateIRI, resolveIRI+ , removeIRIFragment ) where import Data.Semigroup (Semigroup(..))-import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (maybe, isJust) import Data.Functor import Data.List (intersperse) import Control.Applicative import Control.Monad (guard)-import Control.Arrow ((***), (&&&), (>>>))+import Control.Arrow (first, (&&&), (>>>)) import Data.Char (isAlpha, isDigit, isAlphaNum, toUpper, toLower) import Data.Text (Text) import qualified Data.Text as T@@ -92,21 +93,24 @@ | MissingColon -- ^ Schemas must be followed by a colon deriving (Show, Eq) +removeIRIFragment :: IRIRef -> IRIRef+removeIRIFragment (IRIRef s a p q _) = IRIRef s a p q Nothing+ -- [TODO] use Builder serializeIRI :: IRIRef -> Text serializeIRI (IRIRef s a p q f) = mconcat- [ fromMaybe mempty (scheme <$> s)- , fromMaybe mempty (authority <$> a)+ [ maybe mempty scheme s+ , maybe mempty authority a , path p- , fromMaybe mempty (query <$> q)- , fromMaybe mempty (fragment <$> f)]+ , maybe mempty query q+ , maybe mempty fragment f ] where scheme (Scheme s') = s' <> ":" authority (Authority u (Host h) p') = mconcat [ "//"- , fromMaybe mempty (userInfo <$> u)+ , maybe mempty userInfo u , h- , fromMaybe mempty (port <$> p') ]+ , maybe mempty port p' ] userInfo (UserInfo u) = u <> "@" port (Port p') = (":" <>) . T.pack . show $ p' path (Path p') = p'@@ -123,12 +127,15 @@ parseRelIRI = P.parseOnly $ irelativeRefParser <* (P.endOfInput <?> "Unexpected characters at the end") validateIRI :: Text -> Either String Text-validateIRI t = const t <$> parseIRI t+validateIRI t = t <$ parseIRI t -- | IRI parsing and resolution according to algorithm 5.2 from RFC3986 -- See: http://www.ietf.org/rfc/rfc3986.txt--- [FIXME] Currently, this is a correct but naive implemenation.-resolveIRI :: Text -> Text -> Either String Text+-- [FIXME] Currently, this is a correct but naive implementation.+resolveIRI+ :: Text -- ^ Base URI+ -> Text -- ^ URI to resolve+ -> Either String Text resolveIRI baseIri iri = serializeIRI <$> resolvedIRI where resolvedIRI = either (const resolvedRelativeIRI) resolveAbsoluteIRI (parseIRI iri)@@ -169,8 +176,8 @@ scheme <- Just <$> schemeParser _ <- P.string ":" <?> "Missing colon after scheme" (authority, path) <- ihierPartParser- query <- P.option Nothing (Just <$> iqueryParser)- fragment <- P.option Nothing (Just <$> ifragmentParser)+ query <- optional iqueryParser+ fragment <- optional ifragmentParser return (IRIRef scheme authority path query fragment) -- ihier-part = "//" iauthority ipath-abempty@@ -194,8 +201,8 @@ irelativeRefParser :: Parser IRIRef irelativeRefParser = do (authority, path) <- irelativePartParser- query <- P.option Nothing (Just <$> iqueryParser)- fragment <- P.option Nothing (Just <$> ifragmentParser)+ query <- optional iqueryParser+ fragment <- optional ifragmentParser return (IRIRef Nothing authority path query fragment) -- irelative-part = "//" iauthority ipath-abempty@@ -212,9 +219,9 @@ -- iauthority = [ iuserinfo "@" ] ihost [ ":" port ] iauthorityParser :: Parser Authority iauthorityParser =- Authority <$> P.option Nothing (Just <$> (iuserInfoParser <* P.string "@"))+ Authority <$> optional (iuserInfoParser <* P.string "@") <*> ihostParser- <*> P.option Nothing (Just <$> (P.string ":" *> portParser))+ <*> optional (P.string ":" *> portParser) <?> "Authority" -- iuserinfo = *( iunreserved / pct-encoded / sub-delims / ":" )@@ -270,7 +277,7 @@ -- ipath-empty = 0<ipchar> ipathEmptyParser :: Parser (Maybe Authority, Path)-ipathEmptyParser = const (Nothing, mempty) <$> ipathEmptyParser'+ipathEmptyParser = (Nothing, mempty) <$ ipathEmptyParser' ipathEmptyParser' :: Parser Text ipathEmptyParser' = P.string mempty <?> "Empty path"@@ -406,7 +413,7 @@ h16 = parseBetween 1 4 (P.takeWhile isHexaDigit) ipNotElided (leading, lengthL) = guard (lengthL == 7 && isDecOctet (last leading)) *> partialIpV4 <|>- guard (lengthL == 8) *> pure mempty+ (guard (lengthL == 8) $> mempty) ipElided (_, lengthL) = do guard $ lengthL <= 8 elision <- P.string "::"@@ -476,10 +483,10 @@ iauthWithPathParser :: Parser (Maybe Authority, Path) iauthWithPathParser = do void (P.string "//")- curry (Just *** id) <$> iauthorityParser <*> ipathAbEmptyParser+ curry (first Just) <$> iauthorityParser <*> ipathAbEmptyParser isHexaDigit :: Char -> Bool-isHexaDigit c = (c >= '0' && c <= '9') ||+isHexaDigit c = (isDigit c) || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F')
src/Data/RDF/Namespace.hs view
@@ -6,75 +6,73 @@ -- * Namespace types and functions Namespace(..), mkPlainNS, mkPrefixedNS, mkPrefixedNS', PrefixMapping(PrefixMapping), PrefixMappings(PrefixMappings), toPMList,- mergePrefixMappings, mkUri, prefixOf, uriOf, -- * Predefined namespace values- rdf, rdfs, dc, dct, owl, xsd, skos, foaf, ex, ex2,+ rdf, rdfs, dc, dct, owl, xml, xsd, skos, foaf, ex, ex2, standard_ns_mappings, ns_mappings ) where import qualified Data.Text as T import Data.RDF.Types import qualified Data.Map as Map+import Data.Semigroup ((<>)) standard_namespaces :: [Namespace] standard_namespaces = [rdf, rdfs, dc, dct, owl, xsd, skos, foaf, ex, ex2] -- |The set of common predefined namespaces as a 'PrefixMappings' value.-standard_ns_mappings :: PrefixMappings+standard_ns_mappings :: PrefixMappings standard_ns_mappings = ns_mappings standard_namespaces -- |Takes a list of 'Namespace's and returns 'PrefixMappings'. ns_mappings :: [Namespace] -> PrefixMappings-ns_mappings ns = PrefixMappings $ Map.fromList $ - map (\(PrefixedNS pre uri) -> (pre, uri)) ns+ns_mappings ns = PrefixMappings $ Map.fromList $+ fmap (\(PrefixedNS pre uri) -> (pre, uri)) ns -- |The RDF namespace.-rdf :: Namespace-rdf = mkPrefixedNS' "rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"+rdf :: Namespace+rdf = mkPrefixedNS' "rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#" -- |The RDF Schema namespace. rdfs :: Namespace-rdfs = mkPrefixedNS' "rdfs" "http://www.w3.org/2000/01/rdf-schema#"+rdfs = mkPrefixedNS' "rdfs" "http://www.w3.org/2000/01/rdf-schema#" -- |The Dublin Core namespace.-dc :: Namespace-dc = mkPrefixedNS' "dc" "http://purl.org/dc/elements/1.1/"+dc :: Namespace+dc = mkPrefixedNS' "dc" "http://purl.org/dc/elements/1.1/" -- |The Dublin Core terms namespace.-dct :: Namespace-dct = mkPrefixedNS' "dct" "http://purl.org/dc/terms/"+dct :: Namespace+dct = mkPrefixedNS' "dct" "http://purl.org/dc/terms/" -- |The OWL namespace.-owl :: Namespace-owl = mkPrefixedNS' "owl" "http://www.w3.org/2002/07/owl#"+owl :: Namespace+owl = mkPrefixedNS' "owl" "http://www.w3.org/2002/07/owl#" -- |The XML Schema namespace.-xsd :: Namespace-xsd = mkPrefixedNS' "xsd" "http://www.w3.org/2001/XMLSchema#"+xml :: Namespace+xml = mkPrefixedNS' "xml" "http://www.w3.org/XML/1998/namespace" +-- |The XML Schema namespace.+xsd :: Namespace+xsd = mkPrefixedNS' "xsd" "http://www.w3.org/2001/XMLSchema#"+ -- |The SKOS namespace. skos :: Namespace-skos = mkPrefixedNS' "skos" "http://www.w3.org/2004/02/skos/core#"+skos = mkPrefixedNS' "skos" "http://www.w3.org/2004/02/skos/core#" -- |The friend of a friend namespace. foaf :: Namespace-foaf = mkPrefixedNS' "foaf" "http://xmlns.com/foaf/0.1/"+foaf = mkPrefixedNS' "foaf" "http://xmlns.com/foaf/0.1/" -- |Example namespace #1.-ex :: Namespace-ex = mkPrefixedNS' "ex" "http://www.example.org/"+ex :: Namespace+ex = mkPrefixedNS' "ex" "http://www.example.org/" -- |Example namespace #2.-ex2 :: Namespace-ex2 = mkPrefixedNS' "ex2" "http://www2.example.org/"----- |Perform a left-biased merge of the two sets of prefix mappings.-mergePrefixMappings :: PrefixMappings -> PrefixMappings -> PrefixMappings-mergePrefixMappings (PrefixMappings p1s) (PrefixMappings p2s) = - PrefixMappings $ Map.union p1s p2s+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.@@ -87,13 +85,13 @@ -- |Make a namespace for the given URI reference.-mkPlainNS :: T.Text -> Namespace-mkPlainNS = PlainNS+mkPlainNS :: T.Text -> Namespace+mkPlainNS = PlainNS -- |Make a namespace having the given prefix for the given URI reference, -- respectively.-mkPrefixedNS :: T.Text -> T.Text -> Namespace-mkPrefixedNS = PrefixedNS+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@@ -102,11 +100,11 @@ mkPrefixedNS' s1 s2 = mkPrefixedNS (T.pack s1) (T.pack s2) -- |Determine the URI of the given namespace.-uriOf :: Namespace -> T.Text-uriOf (PlainNS uri) = uri-uriOf (PrefixedNS _ uri) = uri+uriOf :: Namespace -> T.Text+uriOf (PlainNS uri) = uri+uriOf (PrefixedNS _ uri) = uri -- |Determine the prefix of the given namespace, if it has one.-prefixOf :: Namespace -> Maybe T.Text-prefixOf (PlainNS _) = Nothing-prefixOf (PrefixedNS p _) = Just p+prefixOf :: Namespace -> Maybe T.Text+prefixOf (PlainNS _) = Nothing+prefixOf (PrefixedNS p _) = Just p
src/Data/RDF/Query.hs view
@@ -20,6 +20,8 @@ import Prelude hiding (pred) import Data.List+import Data.Maybe (fromMaybe)+import Data.Semigroup ((<>)) import Data.RDF.Types import qualified Data.RDF.Namespace as NS import Data.Text (Text)@@ -132,7 +134,7 @@ where triples = expandTriples g triplesHashMap :: HashMap (Subject,Predicate) [Object]- triplesHashMap = HashMap.fromListWith (++) [((s,p), [o]) | Triple s p o <- triples]+ triplesHashMap = HashMap.fromListWith (<>) [((s,p), [o]) | Triple s p o <- triples] triplesGrouped :: [((Subject,Predicate),[Object])] triplesGrouped = HashMap.toList triplesHashMap (dataGraph,_,_) = (graphFromEdges . fmap (\((s,p),os) -> (s,p,os))) triplesGrouped@@ -156,7 +158,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 = maybe iri id $ foldl' f Nothing (NS.toPMList pms)+expandURI pms iri = fromMaybe iri $ foldl' f Nothing (NS.toPMList pms) where f :: Maybe Text -> (Text, Text) -> Maybe Text f x (p, u) = x <|> (T.append u <$> T.stripPrefix (T.append p ":") iri)
src/Data/RDF/Types.hs view
@@ -40,7 +40,7 @@ PrefixMappings(PrefixMappings),PrefixMapping(PrefixMapping), -- * Supporting types- BaseUrl(BaseUrl), NodeSelector, ParseFailure(ParseFailure)+ BaseUrl(..), NodeSelector, ParseFailure(ParseFailure) ) where @@ -188,10 +188,10 @@ -- |Same as 'uriValidate', but on 'String' rather than 'Text' uriValidateString :: String -> Maybe String-uriValidateString = liftA T.unpack . uriValidate . fromString+uriValidateString = fmap T.unpack . uriValidate . fromString isRdfURI :: Text -> Either ParseError Text-isRdfURI t = parse (iriFragment <* eof) ("Invalid URI: " ++ T.unpack t) t+isRdfURI t = parse (iriFragment <* eof) ("Invalid URI: " <> T.unpack t) t -- IRIREF from NTriples spec (without <> enclosing) -- [8] IRIREF ::= '<' ([^#x00-#x20<>"{}|^`\] | UCHAR)* '>'@@ -274,9 +274,9 @@ -- /subj/ must be a 'UNode' or 'BNode', and /pred/ must be a 'UNode'. triple :: Subject -> Predicate -> Object -> Triple triple s p o- | isLNode s = error $ "subject must be UNode or BNode: " ++ show s- | isLNode p = error $ "predicate must be UNode, not LNode: " ++ show p- | isBNode p = error $ "predicate must be UNode, not BNode: " ++ show p+ | isLNode s = error $ "subject must be UNode or BNode: " <> show s+ | isLNode p = error $ "predicate must be UNode, not LNode: " <> show p+ | isBNode p = error $ "predicate must be UNode, not BNode: " <> show p | otherwise = Triple s p o -- |Answer if given node is a URI Ref node.@@ -462,11 +462,14 @@ -- |The base URL of an RDF.-newtype BaseUrl = BaseUrl Text+newtype BaseUrl = BaseUrl { unBaseUrl :: Text } deriving (Eq, Ord, Show, NFData, Semigroup, Generic) instance Binary BaseUrl +instance Monoid BaseUrl where+ mempty = BaseUrl T.empty+ -- |A 'NodeSelector' is either a function that returns 'True' -- or 'False' for a node, or Nothing, which indicates that all -- nodes would return 'True'.@@ -569,8 +572,8 @@ show (PrefixedNS prefix uri) = printf "(PrefixNS %s %s)" (T.unpack prefix) (T.unpack uri) -- |An alias for a map from prefix to namespace URI.-newtype PrefixMappings = PrefixMappings (Map Text Text)- deriving (Eq, Ord,NFData, Generic)+newtype PrefixMappings = PrefixMappings (Map Text Text)+ deriving (Eq, Ord, NFData, Semigroup, Monoid, Generic) instance Binary PrefixMappings @@ -579,7 +582,7 @@ -- worth optimizing yet. show (PrefixMappings pmap) = printf "PrefixMappings [%s]" mappingsStr where showPM = show . PrefixMapping- mappingsStr = List.intercalate ", " (map showPM (Map.toList pmap))+ mappingsStr = List.intercalate ", " (fmap showPM (Map.toList pmap)) -- |A mapping of a prefix to the URI for that prefix. newtype PrefixMapping = PrefixMapping (Text, Text)@@ -592,7 +595,7 @@ -- | Resolve a prefix using the given prefix mappings. resolveQName :: Text -> PrefixMappings -> Maybe Text-resolveQName prefix (PrefixMappings pms') = Map.lookup prefix pms'+resolveQName prefix (PrefixMappings pms) = Map.lookup prefix pms {-# INLINE mkAbsoluteUrl #-} {-# DEPRECATED mkAbsoluteUrl "Use resolveIRI instead, because mkAbsoluteUrl is a partial function" #-}@@ -624,12 +627,10 @@ doubleUri = "http://www.w3.org/2001/XMLSchema#double" _integerStr, _decimalStr, _doubleStr :: Text -> Text-_integerStr t =- if T.length t == 1- then t- else if T.head t == '0'- then _integerStr (T.tail t)- else t+_integerStr t+ | T.length t == 1 = t+ | T.head t == '0' = _integerStr (T.tail t)+ | otherwise = t -- exponent: [eE] ('-' | '+')? [0-9]+ -- ('-' | '+') ? ( [0-9]+ '.' [0-9]* exponent | '.' ([0-9])+ exponent | ([0-9])+ exponent )@@ -649,12 +650,12 @@ | otherwise = Nothing where textToFilePath = pure . fromString <=< stringToFilePath . T.unpack- stringToFilePath = fixPrefix <=< pure . Network.uriPath <=< Network.parseURI+ stringToFilePath = fixPrefix <=< pure . unEscapeString . Network.uriPath <=< Network.parseURI fixPrefix "" = Nothing fixPrefix p@(p':p'') | p' == FP.pathSeparator = Just (FP.normalise p) -- Posix path | p' == '/' = Just (FP.normalise p'') -- Windows classic Path- | otherwise = Just ("\\\\" ++ FP.normalise p) -- Windows UNC Path+ | otherwise = Just ("\\\\" <> FP.normalise p) -- Windows UNC Path fileSchemeToFilePath _ = Nothing -- | Converts a file path to a URI with "file:" scheme@@ -663,7 +664,7 @@ | FP.isRelative p = Nothing | otherwise = Just . fromString . as_uri . FP.normalise $ p where- as_uri = ("file://" ++) . escapeURIString isAllowedInURI . as_posix . fix_prefix+ as_uri = ("file://" <>) . escapeURIString isAllowedInURI . as_posix . fix_prefix fix_prefix p' = case (FP.takeDrive p') of "/" -> p' '\\':'\\':_ -> drop 2 p'
src/Rdf4hParseMain.hs view
@@ -7,6 +7,7 @@ import Data.RDF +import Data.Semigroup ((<>)) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -32,7 +33,7 @@ when (null args) (ioError (userError- ("\n\n" ++ "INPUT-URI required\n\n" ++ usageInfo header options)))+ ("\n\n" <> "INPUT-URI required\n\n" <> usageInfo header options))) let debug = Debug `elem` opts inputUri = head args inputFormat = getWithDefault (InputFormat "turtle") opts@@ -41,8 +42,8 @@ outputBaseUri = getWithDefault (OutputBaseUri inputBaseUri) opts unless (outputFormat == "ntriples" || outputFormat == "turtle") (hPrintf stderr- ("'" ++- outputFormat +++ ("'" <>+ outputFormat <> "' is not a valid output format. Supported output formats are: ntriples, turtle\n") >> exitWith (ExitFailure 1)) when debug@@ -88,7 +89,7 @@ >>= \ (res :: Either ParseFailure (RDF TList)) -> write outputFormat docUri emptyPms res- (str, _) -> putStrLn ("Invalid format: " ++ str) >> exitFailure+ (str, _) -> putStrLn ("Invalid format: " <> str) >> exitFailure write :: (Rdf a) => String -> Maybe T.Text -> PrefixMappings -> Either ParseFailure (RDF a) -> IO () write format docUri pms res = case res of@@ -98,7 +99,7 @@ doWriteRdf rdf = case format of "turtle" -> writeRdf (TurtleSerializer docUri pms) rdf "ntriples" -> writeRdf NTriplesSerializer rdf- unknown -> error $ "Unknown output format: " ++ unknown+ unknown -> error $ "Unknown output format: " <> unknown -- Get the input base URI from the argument list or flags, using the -- first string arg as the default if not found in string args (as@@ -135,7 +136,7 @@ strValue (InputBaseUri s) = s strValue (OutputFormat s) = s strValue (OutputBaseUri s) = s-strValue flag = error $ "No string value for flag: " ++ show flag+strValue flag = error $ "No string value for flag: " <> show flag -- The commandline arguments we accept. None are required. data Flag@@ -160,28 +161,28 @@ -- The top part of the usage output. header :: String header =- "\nrdf4h_parse: an RDF parser and serializer\n\n" ++- "\nUsage: rdf4h_parse [OPTION...] INPUT-URI [INPUT-BASE-URI]\n\n" ++- " INPUT-URI a filename, URI or '-' for standard input (stdin).\n" ++- " INPUT-BASE-URI the input/parser base URI or '-' for none.\n" ++- " Default is INPUT-URI\n" +++ "\nrdf4h_parse: an RDF parser and serializer\n\n" <>+ "\nUsage: rdf4h_parse [OPTION...] INPUT-URI [INPUT-BASE-URI]\n\n" <>+ " INPUT-URI a filename, URI or '-' for standard input (stdin).\n" <>+ " INPUT-BASE-URI the input/parser base URI or '-' for none.\n" <>+ " Default is INPUT-URI\n" <> " Equivalent to -I INPUT-BASE-URI, --input-base-uri INPUT-BASE-URI\n\n" options :: [OptDescr Flag] options = [ Option "h" ["help"] (NoArg Help) "Display this help, then exit" , Option "d" ["debug"] (NoArg Debug) "Print debug info (like INPUT-BASE-URI used, etc.)"- , Option "i" ["input"] (ReqArg InputFormat "FORMAT") $ "Set input format/parser to one of:\n" ++- " turtle Turtle (default)\n" ++- " ntriples N-Triples\n" +++ , Option "i" ["input"] (ReqArg InputFormat "FORMAT") $ "Set input format/parser to one of:\n" <>+ " turtle Turtle (default)\n" <>+ " ntriples N-Triples\n" <> " xml RDF/XML"- , Option "I" ["input-base-uri"] (ReqArg InputBaseUri "URI") $ "Set the input/parser base URI. '-' for none.\n" +++ , Option "I" ["input-base-uri"] (ReqArg InputBaseUri "URI") $ "Set the input/parser base URI. '-' for none.\n" <> " Default is INPUT-BASE-URI argument value.\n\n" - , Option "o" ["output"] (ReqArg OutputFormat "FORMAT") $ "Set output format/serializer to one of:\n" ++- " ntriples N-Triples (default)\n" +++ , Option "o" ["output"] (ReqArg OutputFormat "FORMAT") $ "Set output format/serializer to one of:\n" <>+ " ntriples N-Triples (default)\n" <> " turtle Turtle"- , Option "O" ["output-base-uri"] (ReqArg OutputBaseUri "URI") $ "Set the output format/serializer base URI. '-' for none.\n" +++ , Option "O" ["output-base-uri"] (ReqArg OutputBaseUri "URI") $ "Set the output format/serializer base URI. '-' for none.\n" <> " Default is input/parser base URI." ] @@ -189,4 +190,4 @@ compilerOpts argv = case getOpt Permute options argv of (o,n,[] ) -> return (o,n)- (_,_,errs) -> ioError (userError ("\n\n" ++ concat errs ++ usageInfo header options))+ (_,_,errs) -> ioError (userError ("\n\n" <> concat errs <> usageInfo header options))
src/Text/RDF/RDF4H/NTriplesParser.hs view
@@ -13,7 +13,7 @@ import Prelude hiding (readFile) import Data.Semigroup ((<>))-import Data.Char (isDigit, isLetter, isAlphaNum)+import Data.Char (isDigit, isLetter, isAlphaNum, isAsciiUpper, isAsciiLower) import Control.Applicative import Control.Monad (void) @@ -39,7 +39,7 @@ -- class. data NTriplesParser = NTriplesParser -data NTriplesParserCustom = NTriplesParserCustom Parser+newtype NTriplesParserCustom = NTriplesParserCustom Parser -- |'NTriplesParser' is an instance of 'RdfParser' using parsec based parsers. instance RdfParser NTriplesParser where@@ -109,13 +109,13 @@ nt_langtag = do ss <- char '@' *> some (satisfy isLetter) rest <- concat <$> many (char '-' *> some (satisfy isAlphaNum) >>= \lang_str -> pure ('-':lang_str))- pure (T.pack (ss ++ rest))+ pure (T.pack (ss <> rest)) -- [8] IRIREF nt_iriref :: (CharParsing m, Monad m) => m T.Text nt_iriref = between (char '<') (char '>') $ do raw_iri <- iriFragment- either (const empty) pure (validateIRI raw_iri) <?> "Only absolute IRIs allowed in NTriples format, which this isn't: " ++ show raw_iri+ either (const empty) pure (validateIRI raw_iri) <?> "Only absolute IRIs allowed in NTriples format, which this isn't: " <> show raw_iri -- [153s] ECHAR nt_echar :: (CharParsing m, Monad m) => m Char@@ -165,8 +165,8 @@ -- [157s] PN_CHARS_BASE ::= [A-Z] | [a-z] | [#x00C0-#x00D6] | [#x00D8-#x00F6] | [#x00F8-#x02FF] | [#x0370-#x037D] | [#x037F-#x1FFF] | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF] | [#x3001-#xD7FF] | [#xF900-#xFDCF] | [#xFDF0-#xFFFD] | [#x10000-#xEFFFF] nt_pn_chars_base :: CharParsing m => m Char nt_pn_chars_base = try $ satisfy isBaseChar- where isBaseChar c = (c >= 'A' && c <= 'Z')- || (c >= 'a' && c <= 'z')+ where isBaseChar c = (isAsciiUpper c)+ || (isAsciiLower c) || (c >= '\x00C0' && c <= '\x00D6') || (c >= '\x00D8' && c <= '\x00F6') || (c >= '\x00F8' && c <= '\x02FF')@@ -225,7 +225,7 @@ T.hGetContents h parseURLParsec :: (Rdf a) => String -> IO (Either ParseFailure (RDF a))-parseURLParsec = _parseURL parseStringParsec+parseURLParsec = parseFromURL parseStringParsec handleParsec :: (Triples -> Maybe BaseUrl -> PrefixMappings -> RDF a) -> Either ParseError [Triple] -> Either ParseFailure (RDF a)@@ -242,7 +242,7 @@ parseFileAttoparsec path = handleAttoparsec <$> readFile path parseURLAttoparsec :: (Rdf a) => String -> IO (Either ParseFailure (RDF a))-parseURLAttoparsec = _parseURL handleAttoparsec+parseURLAttoparsec = parseFromURL handleAttoparsec parseStringAttoparsec :: (Rdf a) => T.Text -> Either ParseFailure (RDF a) parseStringAttoparsec = handleAttoparsec@@ -251,11 +251,11 @@ handleAttoparsec bs = handleResult $ parse nt_ntripleDoc (T.encodeUtf8 bs) where handleResult res = case res of- Fail _i _contexts err -> Left $ ParseFailure $ "Parse failure: \n" ++ show err+ Fail _i _contexts err -> Left $ ParseFailure $ "Parse failure: \n" <> show err -- error $- -- "\nnot consumed: " ++ show i- -- ++ "\ncontexts: " ++ show contexts- -- ++ "\nerror: " ++ show err+ -- "\nnot consumed: " <> show i+ -- <> "\ncontexts: " <> show contexts+ -- <> "\nerror: " <> show err Partial f -> handleResult (f (T.encodeUtf8 mempty)) Done _ ts -> Right $ mkRdf ts Nothing (PrefixMappings mempty)
src/Text/RDF/RDF4H/ParserUtils.hs view
@@ -1,18 +1,46 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Text.RDF.RDF4H.ParserUtils(- _parseURL,- Parser(..)-) where+module Text.RDF.RDF4H.ParserUtils+ ( Parser(..)+ , parseFromURL+ -- RDF+ , rdfTypeNode, rdfNilNode, rdfFirstNode, rdfRestNode+ , rdfSubjectNode, rdfPredicateNode, rdfObjectNode, rdfStatementNode+ , rdfTag, rdfID, rdfAbout, rdfParseType, rdfResource, rdfNodeID, rdfDatatype+ , rdfType, rdfLi, rdfListIndex+ , rdfDescription, rdfXmlLiteral+ , rdfAboutEach, rdfAboutEachPrefix, rdfBagID+ -- XML+ , xmlLang+ -- XSD+ , xsdIntUri, xsdDoubleUri, xsdDecimalUri, xsdBooleanUri+ -- for GHC 8.0 compatibility+#if MIN_VERSION_base(4,10,0)+#else+ , fromRight+#endif+ ) where import Data.RDF.Types+import Data.RDF.Namespace import Control.Exception.Lifted import Network.HTTP.Conduit import Data.Text.Encoding (decodeUtf8)+import Data.Semigroup ((<>)) import qualified Data.ByteString.Lazy as BS+import Data.Text (Text) import qualified Data.Text as T +#if MIN_VERSION_base(4,10,0)+#else+fromRight :: b -> Either a b -> b+fromRight _ (Right b) = b+fromRight b _ = b+#endif+ data Parser = Parsec | Attoparsec -- | A convenience function for terminating a parse with a parse failure, using@@ -20,19 +48,65 @@ errResult :: String -> Either ParseFailure (RDF rdfImpl) errResult msg = Left (ParseFailure msg) -_parseURL :: (T.Text -> Either ParseFailure (RDF rdfImpl)) -> String -> IO (Either ParseFailure (RDF rdfImpl))-_parseURL parseFunc url = do+parseFromURL :: (Rdf rdfImpl) => (T.Text -> Either ParseFailure (RDF rdfImpl)) -> String -> IO (Either ParseFailure (RDF rdfImpl))+parseFromURL parseFunc url = do result <- Control.Exception.Lifted.try $ simpleHttp url case result of- Left (ex::HttpException) ->- case ex of+ Left (err :: HttpException) ->+ case err of (HttpExceptionRequest _req content) -> case content of- ConnectionTimeout -> do+ ConnectionTimeout -> return $ errResult "Connection timed out"- _ -> return $ errResult ("HttpExceptionRequest content: " ++ show content)+ _ -> return $ errResult ("HttpExceptionRequest content: " <> show content) (InvalidUrlException{}) -> return $ errResult "Invalid URL exception" Right bs -> do let s = decodeUtf8 $ BS.toStrict bs return (parseFunc s)++rdfTypeNode, rdfNilNode, rdfFirstNode, rdfRestNode :: Node+rdfTypeNode = UNode $ mkUri rdf "type"+rdfNilNode = UNode $ mkUri rdf "nil"+rdfFirstNode = UNode $ mkUri rdf "first"+rdfRestNode = UNode $ mkUri rdf "rest"++rdfSubjectNode, rdfPredicateNode, rdfObjectNode, rdfStatementNode :: Node+rdfSubjectNode = UNode $ mkUri rdf "subject"+rdfPredicateNode = UNode $ mkUri rdf "predicate"+rdfObjectNode = UNode $ mkUri rdf "object"+rdfStatementNode = UNode $ mkUri rdf "Statement"++-- Core terms+rdfTag, rdfID, rdfAbout, rdfParseType, rdfResource, rdfNodeID, rdfDatatype :: Text+rdfTag = mkUri rdf "RDF"+rdfID = mkUri rdf "ID"+rdfAbout = mkUri rdf "about"+rdfParseType = mkUri rdf "parseType"+rdfResource = mkUri rdf "resource"+rdfNodeID = mkUri rdf "nodeID"+rdfDatatype = mkUri rdf "datatype"++rdfType, rdfLi, rdfListIndex :: Text+rdfType = mkUri rdf "type"+rdfLi = mkUri rdf "li"+rdfListIndex = mkUri rdf "_"++rdfXmlLiteral, rdfDescription :: Text+rdfXmlLiteral = mkUri rdf "XMLLiteral"+rdfDescription = mkUri rdf "Description"++-- Old terms+rdfAboutEach, rdfAboutEachPrefix, rdfBagID :: Text+rdfAboutEach = mkUri rdf "aboutEach"+rdfAboutEachPrefix = mkUri rdf "aboutEachPrefix"+rdfBagID = mkUri rdf "bagID"++xmlLang :: Text+xmlLang = mkUri xml "lang"++xsdIntUri, xsdDoubleUri, xsdDecimalUri, xsdBooleanUri :: Text+xsdIntUri = mkUri xsd "integer"+xsdDoubleUri = mkUri xsd "double"+xsdDecimalUri = mkUri xsd "decimal"+xsdBooleanUri = mkUri xsd "boolean"
src/Text/RDF/RDF4H/TurtleParser.hs view
@@ -8,6 +8,7 @@ module Text.RDF.RDF4H.TurtleParser ( TurtleParser(TurtleParser) , TurtleParserCustom(TurtleParserCustom)+ , parseTurtleDebug ) where import Prelude hiding (readFile)@@ -16,20 +17,23 @@ import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe+import Data.Either+import Data.Semigroup ((<>)) import Data.RDF.Types import Data.RDF.IRI-import Data.RDF.Namespace+import Data.RDF.Graph.TList import Text.RDF.RDF4H.ParserUtils import Text.RDF.RDF4H.NTriplesParser import Text.Parsec (runParser, ParseError) import qualified Data.Text as T import Data.Sequence (Seq, (|>))+import Data.Functor (($>)) import qualified Data.Foldable as F import Control.Monad import Text.Parser.Char import Text.Parser.Combinators import Text.Parser.LookAhead-import Control.Applicative+import Control.Applicative hiding (empty) import Control.Monad.State.Class import Control.Monad.State.Strict @@ -73,6 +77,10 @@ , Seq Triple -- the triples encountered while parsing; always added to on the right side , Map String Integer ) -- map blank node names to generated id. ++parseTurtleDebug :: String -> IO (RDF TList)+parseTurtleDebug f = fromRight empty <$> parseFile (TurtleParserCustom (Just . BaseUrl $ "http://base-url.com/") (Just "http://doc-url.com/") Attoparsec) f+ -- grammar rule: [1] turtleDoc t_turtleDoc :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m (Seq Triple, PrefixMappings) t_turtleDoc =@@ -176,7 +184,7 @@ updateBaseUrl (Just $ Just newBaseIri) t_verb :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m ()-t_verb = try t_predicate <|> (char 'a' *> pure rdfTypeNode) >>= setPredicate+t_verb = try t_predicate <|> (char 'a' $> rdfTypeNode) >>= setPredicate -- grammar rule: [11] predicate ::= iri t_predicate :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m Node@@ -189,7 +197,7 @@ (_, _, _, pms, _, _, _, _) <- get case resolveQName pre pms of Just n -> pure n- Nothing -> unexpected ("Cannot resolve QName prefix: " ++ T.unpack pre)+ Nothing -> unexpected ("Cannot resolve QName prefix: " <> T.unpack pre) -- grammar rules: [168s] PN_LOCAL -- [168s] PN_LOCAL ::= (PN_CHARS_U | ':' | [0-9] | PLX) ((PN_CHARS | '.' | ':' | PLX)* (PN_CHARS | ':' | PLX))?@@ -199,9 +207,9 @@ xs <- option "" $ try $ do let recsve = (t_pn_chars_str <|> string ":" <|> t_plx) <|> (t_pn_chars_str <|> string ":" <|> t_plx <|> try (string "." <* lookAhead (try recsve))) <|>- (t_pn_chars_str <|> string ":" <|> t_plx <|> try (string "." *> notFollowedBy t_ws *> pure "."))+ (t_pn_chars_str <|> string ":" <|> t_plx <|> try (string "." *> notFollowedBy t_ws $> ".")) concat <$> many recsve- pure (T.pack (x ++ xs))+ pure (T.pack (x <> xs)) where satisfy_str = pure <$> satisfy isDigit t_pn_chars_str = pure <$> t_pn_chars@@ -235,7 +243,7 @@ -- [137s] BlankNode ::= BLANK_NODE_LABEL | ANON t_blankNode :: (CharParsing m, MonadState ParseState m) => m Node t_blankNode = do- genID <- try t_blank_node_label <|> (t_anon *> pure mempty)+ genID <- try t_blank_node_label <|> (t_anon $> mempty) mp <- currGenIdLookup maybe (newBN genID) getExistingBN (Map.lookup genID mp) where@@ -297,7 +305,7 @@ void (many t_ws) return root where- empty_list = lookAhead (char ')') *> return rdfNilNode+ empty_list = lookAhead (char ')') $> rdfNilNode non_empty_list = do ns <- sepEndBy1 element (some t_ws) addTripleForObject rdfNilNode@@ -313,18 +321,6 @@ return bn getSubject = get >>= \(_, _, _, _, s, _, _, _) -> pure s -rdfTypeNode, rdfNilNode, rdfFirstNode, rdfRestNode :: Node-rdfTypeNode = UNode $ mkUri rdf "type"-rdfNilNode = UNode $ mkUri rdf "nil"-rdfFirstNode = UNode $ mkUri rdf "first"-rdfRestNode = UNode $ mkUri rdf "rest"--xsdIntUri, xsdDoubleUri, xsdDecimalUri, xsdBooleanUri :: T.Text-xsdIntUri = mkUri xsd "integer"-xsdDoubleUri = mkUri xsd "double"-xsdDecimalUri = mkUri xsd "decimal"-xsdBooleanUri = mkUri xsd "boolean"- t_literal :: (MonadState ParseState m, CharParsing m, LookAheadParsing m) => m Node t_literal = LNode <$> try t_rdf_literal <|>@@ -507,7 +503,7 @@ -- combines get_current and increment into a single function nextIdCounter :: MonadState ParseState m => m Integer nextIdCounter = get >>= \(bUrl, dUrl, i, pms, s, p, ts, genMap) ->- put (bUrl, dUrl, i+1, pms, s, p, ts, genMap) *> pure i+ put (bUrl, dUrl, i+1, pms, s, p, ts, genMap) $> i nextBlankNode :: MonadState ParseState m => m Node nextBlankNode = BNodeGen . fromIntegral <$> nextIdCounter@@ -570,8 +566,8 @@ t <- getTriple s p put (bUrl, dUrl, i, pms, s, p, ts |> t, genMap) where- getTriple Nothing _ = unexpected $ "No Subject with which to create triple for: " ++ show obj- getTriple _ Nothing = unexpected $ "No Predicate with which to create triple for: " ++ show obj+ getTriple Nothing _ = unexpected $ "No Subject with which to create triple for: " <> show obj+ getTriple _ Nothing = unexpected $ "No Predicate with which to create triple for: " <> show obj getTriple (Just s') (Just p') = pure $ Triple s' p' obj @@ -603,7 +599,7 @@ -> IO (Either ParseFailure (RDF a)) -- ^ The parse result, which is either a @ParseFailure@ or the RDF -- corresponding to the Turtle document.-parseURLParsec bUrl docUrl = _parseURL (parseStringParsec bUrl docUrl)+parseURLParsec bUrl docUrl = parseFromURL (parseStringParsec bUrl docUrl) -- |Parse the given file as a Turtle document. The arguments and return type have the same semantics -- as 'parseURL', except that the last @String@ argument corresponds to a filesystem location rather@@ -631,7 +627,7 @@ where handleResult' res = case res of Fail _ _ err -> -- error err- Left $ ParseFailure $ "Parse failure: \n" ++ show err+ Left $ ParseFailure $ "Parse failure: \n" <> show err Partial f -> handleResult' (f mempty) Done _ (ts,pms) -> Right $! mkRdf (F.toList ts) bUrl pms @@ -645,17 +641,17 @@ -> IO (Either ParseFailure (RDF a)) -- ^ The parse result, which is either a @ParseFailure@ or the RDF -- corresponding to the Turtle document.-parseURLAttoparsec bUrl docUrl = _parseURL (parseStringAttoparsec bUrl docUrl)+parseURLAttoparsec bUrl docUrl = parseFromURL (parseStringAttoparsec bUrl docUrl) --------------------------------- initialState :: Maybe BaseUrl -> Maybe T.Text -> ParseState-initialState bUrl docUrl = (bUrl, docUrl, 1, PrefixMappings mempty, Nothing, Nothing, mempty, mempty)+initialState bUrl docUrl = (BaseUrl <$> docUrl <|> bUrl, docUrl, 1, PrefixMappings mempty, Nothing, Nothing, mempty, mempty) handleResult :: Rdf a => Maybe BaseUrl -> Either ParseError (Seq Triple, PrefixMappings) -> Either ParseFailure (RDF a) handleResult bUrl result = case result of- (Left err) -> Left (ParseFailure $ "Parse failure: \n" ++ show err)+ (Left err) -> Left (ParseFailure $ "Parse failure: \n" <> show err) (Right (ts, pms)) -> Right $! mkRdf (F.toList ts) bUrl pms @@ -668,7 +664,7 @@ -- Match the string 's', accepting either lowercase or uppercase form of each character caseInsensitiveString :: (CharParsing m, Monad m) => String -> m String-caseInsensitiveString s = try (mapM caseInsensitiveChar s) <?> "\"" ++ s ++ "\""+caseInsensitiveString s = try (mapM caseInsensitiveChar s) <?> "\"" <> s <> "\"" tryIriResolution :: (CharParsing m, Monad m) => Maybe BaseUrl -> Maybe T.Text -> T.Text -> m T.Text tryIriResolution mbUrl mdUrl iriFrag = tryIriResolution' mbUrl mdUrl@@ -676,4 +672,4 @@ tryIriResolution' (Just (BaseUrl bIri)) _ = either err pure (resolveIRI bIri iriFrag) tryIriResolution' _ (Just dIri) = either err pure (resolveIRI dIri iriFrag) tryIriResolution' _ _ = either err pure (resolveIRI mempty iriFrag)- err m = unexpected $ "Cannot resolve IRI: " ++ m ++ " " ++ show (mbUrl, mdUrl, iriFrag)+ err m = unexpected $ mconcat ["Cannot resolve IRI: ", m, " ", show (mbUrl, mdUrl, iriFrag)]
src/Text/RDF/RDF4H/TurtleSerializer.hs view
@@ -1,4 +1,4 @@--- |An RDF serializer for Turtle +-- |An RDF serializer for Turtle -- <http://www.w3.org/TeamSubmission/turtle/>. module Text.RDF.RDF4H.TurtleSerializer(@@ -10,6 +10,7 @@ import Data.RDF.Types import Data.RDF.Query import Data.RDF.Namespace hiding (rdf)+import Data.Semigroup ((<>)) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Map(Map)@@ -23,7 +24,7 @@ instance RdfSerializer TurtleSerializer where hWriteRdf (TurtleSerializer docUrl pms) h rdf = _writeRdf h docUrl (addPrefixMappings rdf pms False) writeRdf s = hWriteRdf s stdout- hWriteH (TurtleSerializer _ pms) h rdf = writeHeader h (baseUrl rdf) (mergePrefixMappings (prefixMappings rdf) pms)+ hWriteH (TurtleSerializer _ pms) h rdf = writeHeader h (baseUrl rdf) (prefixMappings rdf <> pms) writeH s = hWriteRdf s stdout -- TODO: should use mdUrl to render <> where appropriate hWriteTs (TurtleSerializer docUrl pms) h = writeTriples h docUrl pms@@ -31,7 +32,7 @@ hWriteT (TurtleSerializer docUrl pms) h = writeTriple h docUrl pms writeT s = hWriteT s stdout hWriteN (TurtleSerializer docUrl (PrefixMappings pms)) h n = writeNode h docUrl n pms- writeN s = hWriteN s stdout + writeN s = hWriteN s stdout -- TODO: writeRdf currently merges standard namespace prefix mappings with -- the ones that the RDF already contains, so that if the RDF has none@@ -72,10 +73,10 @@ writeTriples h mdUrl (PrefixMappings pms) ts = mapM_ (writeSubjGroup h mdUrl revPms) (groupBy equalSubjects ts) where- revPms = Map.fromList $ map (\(k,v) -> (v,k)) $ Map.toList pms+ revPms = Map.fromList $ (\(k,v) -> (v,k)) <$> Map.toList pms writeTriple :: Handle -> Maybe T.Text -> PrefixMappings -> Triple -> IO ()-writeTriple h mdUrl (PrefixMappings pms) t = +writeTriple h mdUrl (PrefixMappings pms) t = w subjectOf >> space >> w predicateOf >> space >> w objectOf where w :: (Triple -> Node) -> IO ()@@ -100,9 +101,9 @@ writePredGroup :: Handle -> Maybe T.Text -> Map T.Text T.Text -> Triples -> IO () writePredGroup _ _ _ [] = return () writePredGroup h docUrl pms (t:ts) =- -- The doesn't rule out <> in either the predicate or object (as well as subject), + -- 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 @@ -131,7 +132,7 @@ -- Expects a map from uri to prefix, and returns the (prefix, uri_expansion) -- from the mappings such that uri_expansion is a prefix of uri, or Nothing if--- there is no such mapping. This function does a linear-time search over the +-- there is no such mapping. This function does a linear-time search over the -- map, but the prefix mappings should always be very small, so it's okay for now. findMapping :: Map T.Text T.Text -> T.Text -> Maybe (T.Text, T.Text) findMapping pms uri =
src/Text/RDF/RDF4H/XmlParser.hs view
@@ -1,486 +1,653 @@-{-# LANGUAGE Arrows #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}---- |An parser for the RDF/XML format--- <http://www.w3.org/TR/REC-rdf-syntax/>.--module Text.RDF.RDF4H.XmlParser(- XmlParser(XmlParser)-) where---import Control.Arrow ((>>>),(<<<),(&&&),(***),arr,returnA)-import Control.Arrow.ArrowList (arrL)-import Control.Arrow.ArrowState (ArrowState,nextState)-import Control.Exception-import Data.Char-import Data.List (isPrefixOf)-import qualified Data.Map as Map (fromList)-import Data.Maybe-import Data.Typeable-import Text.RDF.RDF4H.ParserUtils-import Data.RDF.IRI-import Data.RDF.Types (Rdf,RDF,RdfParser(..),Node(BNodeGen),BaseUrl(..),Triple(..),Triples,Subject,Predicate,Object,PrefixMappings(..),ParseFailure(ParseFailure),mkRdf,lnode,plainL,plainLL,typedL,unode,bnode,unodeValidate)-import Data.Text (Text)-import qualified Data.Text as T -- (Text,pack,unpack)-import qualified Data.Text.IO as TIO-import Text.XML.HXT.Core (ArrowXml,ArrowIf,XmlTree,IfThen((:->)),(>.),(>>.),first,neg,(<+>),expandURI,getName,getAttrValue,getAttrValue0,getAttrl,hasAttrValue,hasAttr,constA,choiceA,getChildren,ifA,arr2A,second,hasName,isElem,isWhiteSpace,xshow,listA,isA,isText,getText,this,unlistA,orElse,sattr,mkelem,xreadDoc,runSLA)---- TODO: write QuickCheck tests for XmlParser instance for RdfParser.---- Useful HXT intro: http://adit.io/posts/2012-04-14-working_with_HTML_in_haskell.html---- note on generating stack tracing with ghci------ use 'traceStack'------ then start ghci with------ stack ghci --ghc-options "-fexternal-interpreter" --ghc-options "-prof"------ then run the function you with to create a stack trace for.---- |'XmlParser' is an instance of 'RdfParser'.------ The 'BaseUrl' is used as the base URI within the document for--- resolving any relative URI references. It may be changed within--- the document using the @\@base@ directive. At any given point, the--- current base URI is the most recent @\@base@ directive, or if none,--- the @BaseUrl@ given to @parseURL@, or if none given, the document--- URL given to @parseURL@. For example, if the @BaseUrl@ were--- @http:\/\/example.org\/@ and a relative URI of @\<b>@ were--- encountered (with no preceding @\@base@ directive), then the--- relative URI would expand to @http:\/\/example.org\/b@.------ The @Maybe Text@ argument is the document URL is for the purpose of--- resolving references to 'this document' within the document, and--- may be different than the actual location URL from which the--- document is retrieved. Any reference to @\<>@ within the document--- is expanded to the value given here. Additionally, if no 'BaseUrl'--- is given and no @\@base@ directive has appeared before a relative--- URI occurs, this value is used as the base URI against which the--- relative URI is resolved.------ An example of using this RDF/XML parser is:------ @--- Right (rdf::RDF TList) <- parseURL (XmlParser Nothing Nothing) "http://www.w3.org/People/Berners-Lee/card.rdf"--- @--data XmlParser = XmlParser (Maybe BaseUrl) (Maybe Text)--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----- |Global state for the parser-data GParseState = GParseState { stateGenId :: Int- }- deriving(Show)---- |Local state for the parser (dependant on the parent xml elements)-data LParseState = LParseState { stateBaseUrl :: BaseUrl- , stateLang :: Maybe String- , stateSubject :: Subject- }- deriving(Show)--data ParserException = ParserException String- deriving (Show,Typeable)-instance Exception ParserException---- |Parse the given file as a XML document. The arguments and return type have the same semantics--- as 'parseURL', except that the last String argument corresponds to a filesystem location rather--- than a location URI.------ Returns either a @ParseFailure@ or a new RDF containing the parsed triples.-parseFile' :: (Rdf a) => Maybe BaseUrl -> Maybe Text -> String -> IO (Either ParseFailure (RDF a))-parseFile' bUrl dUrl fpath =- TIO.readFile fpath >>= return . parseXmlRDF bUrl dUrl---- |Parse the document at the given location URL as an XML document, using an optional @BaseUrl@--- as the base URI, and using the given document URL as the URI of the XML document itself.------ Returns either a @ParseFailure@ or a new RDF containing the parsed triples.-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- -- corresponding to the XML document.-parseURL' bUrl docUrl = _parseURL (parseXmlRDF bUrl docUrl)----- |Parse a xml Text to an RDF representation-parseXmlRDF :: (Rdf a)- => Maybe BaseUrl -- ^ The base URL for the RDF if required- -> Maybe Text -- ^ DocUrl: The request URL for the RDF if available- -> Text -- ^ The contents to parse- -> Either ParseFailure (RDF a) -- ^ The RDF representation of the triples or ParseFailure-parseXmlRDF bUrl dUrl xmlStr = case runParseArrow of- (_,r:_) -> Right r- _ -> Left (ParseFailure "XML parsing failed")- where runParseArrow = runSLA (xreadDoc >>> isElem >>> addMetaData bUrl dUrl >>> getRDF) initState (T.unpack xmlStr)- initState = GParseState { stateGenId = 0 }---- |Add a root tag to a given XmlTree to appear as if it was read from a readDocument function-addMetaData :: (ArrowXml a) => Maybe BaseUrl -> Maybe Text -> a XmlTree XmlTree-addMetaData bUrlM dUrlM = mkelem "/"- ( [ sattr "transfer-Message" "OK"- , sattr "transfer-MimeType" "text/rdf"- ] ++ mkSource dUrlM ++ mkBase bUrlM- )- [ arr id ]- where mkSource (Just dUrl) = [ sattr "source" (T.unpack dUrl) ]- mkSource Nothing = []- mkBase (Just (BaseUrl bUrl)) = [ sattr "transfer-URI" (T.unpack bUrl) ]- mkBase Nothing = []---- |Arrow that translates HXT XmlTree to an RDF representation-getRDF :: forall rdf a. (Rdf rdf, ArrowXml a, ArrowState GParseState a) => a XmlTree (RDF rdf)-getRDF = proc xml -> do--- rdf <- hasName "rdf:RDF" `orElse` hasName "RDF" <<< isElem <<< getChildren -< xml- rdf <- isElem <<< getChildren -< xml- bUrl <- arr (BaseUrl . T.pack) <<< ((getAttrValue0 "xml:base" <<< isElem <<< getChildren) `orElse` getAttrValue "transfer-URI") -< xml- prefixMap <- arr toPrefixMap <<< toAttrMap -< rdf- triples <- parseDescription' >. id -< (bUrl,rdf)- returnA -< mkRdf triples (Just bUrl) prefixMap- where toAttrMap = (getAttrl >>> (getName &&& (getChildren >>> getText))) >. id- toPrefixMap = PrefixMappings . Map.fromList . map (\(n, m) -> (T.pack (drop 6 n), T.pack m)) . filter (isPrefixOf "xmlns:" . fst)---- |Read the initial state from an rdf element-parseDescription' :: forall a. (ArrowXml a, ArrowState GParseState a) => a (BaseUrl, XmlTree) Triple-parseDescription' = proc (bUrl, rdf) -> do- desc <- isElem <<< getChildren -< rdf- state <- arr (\(s, o) -> s { stateSubject = o }) <<< arr fst &&& arr2A mkNode <<< updateState -< (LParseState bUrl Nothing undefined, desc)- triple <- parseDescription -< (state, desc)- returnA -< triple---- |Read an rdf:Description tag to its corresponding Triples-parseDescription :: forall a. (ArrowXml a, ArrowState GParseState a) => a (LParseState, XmlTree) Triple-parseDescription = updateState- >>> (arr2A parsePredicatesFromAttr- <+> (second (getChildren >>> isElem) >>> parsePredicatesFromChildren)- <+> (second (neg (hasName "rdf:Description") >>> neg (hasName "Description")) >>> arr2A readTypeTriple))- >>. replaceLiElems [] (1 :: Int)- where readTypeTriple :: (ArrowXml a) => LParseState -> a XmlTree Triple- readTypeTriple state = getName >>> arr (Triple (stateSubject state) rdfType . unode . T.pack)- replaceLiElems acc n (Triple s p o : rest) | p == (unode . T.pack) "rdf:li" =- replaceLiElems (Triple s ((unode . T.pack) ("rdf:_" ++ show n)) o : acc) (n + 1) rest- replaceLiElems acc n (Triple s p o : rest) = replaceLiElems (Triple s p o : acc) n rest- replaceLiElems acc _ [] = acc---- |Parse the current predicate element as a rdf:Description element (used when rdf:parseType = "Resource")-parseAsResource :: forall a. (ArrowXml a, ArrowState GParseState a) => Node -> a (LParseState, XmlTree) Triple-parseAsResource n =- updateState- >>> (arr2A parsePredicatesFromAttr- <+> (second getName >>> arr (\(s, p) -> Triple (stateSubject s) ((unode . T.pack) p) n))- <+> (arr (\s -> s { stateSubject = n }) *** (getChildren >>> isElem) >>> parsePredicatesFromChildren))---- |Read the attributes of an rdf:Description element. These correspond to the Predicate Object pairs of the Triple-parsePredicatesFromAttr :: forall a. (ArrowXml a) => LParseState -> a XmlTree Triple-parsePredicatesFromAttr state =- getAttrl- >>> (getName >>> neg isMetaAttr >>> mkUNode) &&& (getChildren >>> getText >>> arr (mkLiteralNode state))- >>> arr (attachSubject (stateSubject state))---- | Arrow to determine if special processing is required for an attribute-isMetaAttr :: forall a. (ArrowXml a) => a String String-isMetaAttr = isA (== "rdf:about")- <+> isA (== "rdf:nodeID")- <+> isA (== "rdf:ID")- <+> isA (== "xml:lang")- <+> isA (== "rdf:parseType")- <+> isA (== "xml:base")---- See: Issue http://www.w3.org/2000/03/rdf-tracking/#rdfms-rdf-names-use--- section: Illegal or unusual use of names from the RDF namespace------ test cases:--- rdf-tests/rdf-xml/rdfms-rdf-names-use/test-017.rdf to--- rdf-tests/rdf-xml/rdfms-rdf-names-use/test-032.rdf--- rdf:Seq, rdf:Bag, rdf:Alt, rdf:Statement, rdf:Property, rdf:List--- rdf:subject, rdf:predicate, rdf:object, rdf:type, rdf:value,--- rdf:first, rdf:rest, rdf:_1, rdf:li------ but in fact the wording at the above URL says:------ "The WG reaffirmed its decision not to restrict names in the RDF--- namespaces which are not syntactic. The WG decided that an RDF--- processor SHOULD emit a warning when encountering names in the RDF--- namespace which are not defined, but should otherwise behave--- normally."------ And that specifically:------ <rdf:Description> --- <rdf:foo>foo</rdf:foo>--- </rdf:Description>------ is equivalent to:--- _:a <rdf:foo> "foo" .------ And hence the use of `hasNamePrefix "rdf"`-isValidPropElemName :: (ArrowXml a) => a XmlTree XmlTree-isValidPropElemName =- hasName "rdf:Description"- <+> hasName "rdf:RDF"- <+> hasName "rdf:ID"- <+> hasName "rdf:about"- <+> hasName "rdf:bagID"- <+> hasName "rdf:parseType"- <+> hasName "rdf:resource"- <+> hasName "rdf:nodeID"- <+> hasName "rdf:aboutEach"- <+> hasName "rdf:aboutEachPrefix"-- -- isValidPropElemName = hasNamePrefix "rdf"- -- hasName "rdf:Seq"- -- <+> hasName "rdf:Bag"- -- <+> hasName "rdf:Alt"- -- <+> hasName "rdf:Statement"- -- <+> hasName "rdf:Property"- -- <+> hasName "rdf:List"- -- <+> hasName "rdf:subject"- -- <+> hasName "rdf:predicate"- -- <+> hasName "rdf:object"- -- <+> hasName "rdf:type"- -- <+> hasName "rdf:value"- -- <+> hasName "rdf:first"- -- <+> hasName "rdf:rest"- -- <+> hasName "rdf:_1"- -- <+> hasName "rdf:li"----- |Read a children of an rdf:Description element. These correspond to the Predicate portion of the Triple-parsePredicatesFromChildren :: forall a. (ArrowXml a, ArrowState GParseState a)- => a (LParseState, XmlTree) Triple-parsePredicatesFromChildren = updateState- >>> validPropElementName- >>> choiceA- [ second (hasAttrValue "rdf:parseType" (== "Literal")) :-> arr2A parseAsLiteralTriple- , second (hasAttrValue "rdf:parseType" (== "Resource")) :-> (mkBlankNode &&& arr id >>> arr2A parseAsResource)- , second (hasAttrValue "rdf:parseType" (== "Collection")) :-> (listA (defaultA >>> arr id &&& mkBlankNode) >>> mkCollectionTriples >>> unlistA)- , second (hasAttr "rdf:datatype") :-> arr2A getTypedTriple- -- for the following case, see rdfms-syntax-incomplete-error006- -- , second (hasAttr "rdf:nodeID") :-> (neg (second (hasAttr "rdf:resource")) >>> arr2A getResourceTriple)- , second (hasAttr "rdf:nodeID") :-> arr2A getNodeIdTriple- , second (hasAttr "rdf:ID") :-> (arr2A mkRelativeNode &&& defaultA >>> arr2A reifyTriple >>> unlistA)- , second (hasAttr "rdf:resource") :-> arr2A validPropElemNames- , second isValidPropElemName :-> arr2A validPropElemNames- , second hasPredicateAttr :-> (defaultA <+> (mkBlankNode &&& arr id >>> arr2A parsePredicateAttr))- , this :-> defaultA- ]- - -- See: Issue http://www.w3.org/2000/03/rdf-tracking/#rdfms-rdf-names-use- -- section: Illegal or unusual use of names from the RDF namespace- --- -- Avoid making blank nodes for some property names.- where validPropElemNames state = proc (predXml) -> do- p <- arr (unode . T.pack) <<< getName -< predXml- o <- getAttrValue0 "rdf:resource" -< predXml- returnA -< Triple (stateSubject state) p (unode (T.pack o))-- defaultA =- proc (state, predXml) -> do- p <- arr (unode . T.pack) <<< getName -< predXml- t <- arr2A (arr2A . parseObjectsFromChildren) <<< second (second getChildren) -< (state, (p, predXml))- returnA -< t- -- parsePredicateAttr :: Node -> a (LParseState,XmlTree) Triple- parsePredicateAttr n = (second getName >>> arr (\(s, p) -> Triple (stateSubject s) ((unode . T.pack) p) n))- <+> (first (arr (\s -> s { stateSubject = n })) >>> arr2A parsePredicatesFromAttr)- hasPredicateAttr = getAttrl >>> neg (getName >>> isMetaAttr)---- See https://www.w3.org/2000/03/rdf-tracking/--- Section "Issue rdfms-rdf-names-use: Illegal or unusual use of names from the RDF namespace"-validPropElementName :: (ArrowXml a) => a (LParseState,XmlTree) (LParseState,XmlTree)-validPropElementName = proc (state,predXml) -> do- neg (hasName "rdf:Description") -< predXml- neg (hasName "rdf:RDF") -< predXml- neg (hasName "rdf:ID") -< predXml- neg (hasName "rdf:about") -< predXml- neg (hasName "rdf:bagID") -< predXml- neg (hasName "rdf:parseType") -< predXml- neg (hasName "rdf:resource") -< predXml- neg (hasName "rdf:nodeID") -< predXml- neg (hasName "rdf:aboutEach") -< predXml- neg (hasName "rdf:aboutEachPrefix") -< predXml- returnA -< (state,predXml)--parseObjectsFromChildren :: forall a. (ArrowIf a, ArrowXml a, ArrowState GParseState a)- => LParseState -> Predicate -> a XmlTree Triple-parseObjectsFromChildren s p =- choiceA - [ isText :-> (neg( isWhiteSpace) >>> getText >>> arr (Triple (stateSubject s) p . mkLiteralNode s))- , isElem :-> (parseObjectDescription)- ]- where parseObjectDescription =- proc desc -> do- -- _ <- (second (neg (hasAttr "rdf:nodeID")) &&& (second (neg (hasName "rdf:resource")))) -< (p,desc)- o <- mkNode s -< desc- t0 <- arr (\(sub, (p', o)) -> Triple sub p' o) -< (stateSubject s, (p, o))- t <- arr fst <+> (parseDescription <<< arr snd) -< (t0, (s { stateSubject = o }, desc))- returnA -< t--attachSubject :: Subject -> (Predicate, Object) -> Triple-attachSubject s (p, o) = Triple s p o--reifyTriple :: forall a. (ArrowXml a) => Subject -> a Triple Triples-reifyTriple node = arr (\(Triple s p o) -> [ Triple s p o- , Triple node rdfType rdfStatement- , Triple node rdfSubject s- , Triple node rdfPredicate p- , Triple node rdfObject o- ])---- |Updates the local state at a given node-updateState :: forall a. (ArrowXml a)- => a (LParseState, XmlTree) (LParseState, XmlTree)-updateState = ifA (second (hasAttr "xml:lang")) (arr2A readLang) (arr id)- >>> ifA (second (hasAttr "xml:base")) (arr2A readBase) (arr id)- where readLang state = (getAttrValue0 "xml:lang" >>> arr (\lang -> state { stateLang = Just lang } ) ) &&& arr id- readBase state = (getAttrValue0 "xml:base" >>> arr (\base -> state { stateBaseUrl = (BaseUrl . T.pack) base } ) ) &&& arr id---- |Read a Triple with an rdf:parseType of Literal-parseAsLiteralTriple :: forall a. (ArrowXml a) => LParseState -> a XmlTree Triple-parseAsLiteralTriple state = (nameToUNode &&& (xshow getChildren >>> arr (mkTypedLiteralNode rdfXmlLiteral)))- >>> arr (attachSubject (stateSubject state))--mkCollectionTriples :: forall a. (ArrowXml a) => a [(Triple, Node)] Triples-mkCollectionTriples = arr (mkCollectionTriples' [])- where mkCollectionTriples' [] ((Triple s1 p1 o1, n1):rest) =- mkCollectionTriples' [Triple s1 p1 n1] ((Triple s1 p1 o1, n1):rest)- mkCollectionTriples' acc ((Triple _ _ o1, n1):(t2, n2):rest) =- mkCollectionTriples' (Triple n1 rdfFirst o1 : Triple n1 rdfRest n2 : acc) ((t2, n2):rest)- mkCollectionTriples' acc [(Triple _ _ o1, n1)] =- Triple n1 rdfFirst o1 : Triple n1 rdfRest rdfNil : acc- mkCollectionTriples' _ [] = []---- |Read a Triple and it's type when rdf:datatype is available-getTypedTriple :: forall a. (ArrowXml a) => LParseState -> a XmlTree Triple-getTypedTriple state = nameToUNode &&& (attrExpandURI state "rdf:datatype" &&& xshow getChildren >>> arr (\(t, v) -> mkTypedLiteralNode (T.pack t) v))- >>> arr (attachSubject (stateSubject state))---- getResourceTriple :: forall a. (ArrowXml a)--- => LParseState -> a XmlTree Triple--- getResourceTriple state = nameToUNode &&& (attrExpandURI state "rdf:resource" >>> mkUNode)--- >>> arr (attachSubject (stateSubject state))--getNodeIdTriple :: forall a. (ArrowXml a)- => LParseState -> a XmlTree Triple-getNodeIdTriple state = nameToUNode &&& (getAttrValue "rdf:nodeID" >>> (arrL (maybeToList . xmlName)) >>> arr (bnode . T.pack))- >>> arr (attachSubject (stateSubject state))---- |Read a Node from the "rdf:about" property or generate a blank node-mkNode :: forall a. (ArrowXml a, ArrowState GParseState a) => LParseState -> a XmlTree Node-mkNode state = choiceA [ hasAttr "rdf:about" :-> (attrExpandURI state "rdf:about" >>> mkUNode)- , hasAttr "rdf:resource" :-> (attrExpandURI state "rdf:resource" >>> mkUNode)- -- , hasAttr "rdf:nodeID" :-> (getAttrValue "rdf:nodeID" >>> arr (bnode . T.pack))- --- -- rdfms-syntax-incomplete/error001.rdf says:- -- "The value of rdf:nodeID must match the XML Name production"- , hasAttr "rdf:nodeID" :-> (getAttrValue "rdf:nodeID" >>> (arrL (maybeToList . xmlName)) >>> arr (bnode . T.pack))- , hasAttr "rdf:ID" :-> mkRelativeNode state- , this :-> (validNodeElementName >>> mkBlankNode)- ]---- See https://www.w3.org/2000/03/rdf-tracking/--- Section "Issue rdfms-rdf-names-use: Illegal or unusual use of names from the RDF namespace"-validNodeElementName :: (ArrowXml a) => a XmlTree XmlTree-validNodeElementName = neg (hasName "rdf:RDF")- >>> neg (hasName "rdf:ID")- >>> neg (hasName "rdf:about")- >>> neg (hasName "rdf:bagID")- >>> neg (hasName "rdf:parseType")- >>> neg (hasName "rdf:resource")- >>> neg (hasName "rdf:nodeID")- >>> neg (hasName "rdf:li")- >>> neg (hasName "rdf:aboutEach")- >>> neg (hasName "rdf:aboutEachPrefix")--rdfXmlLiteral :: Text-rdfFirst,rdfRest,rdfNil,rdfType,rdfStatement,rdfSubject,rdfPredicate,rdfObject :: Node--rdfXmlLiteral = T.pack "http://www.w3.org/1999/02/22-rdf-syntax-ns#XMLLiteral"-rdfFirst = (unode . T.pack) "rdf:first"-rdfRest = (unode . T.pack) "rdf:rest"-rdfNil = (unode . T.pack) "rdf:nil"-rdfType = (unode . T.pack) "rdf:type"-rdfStatement = (unode . T.pack) "rdf:Statement"-rdfSubject = (unode . T.pack) "rdf:subject"-rdfPredicate = (unode . T.pack) "rdf:predicate"-rdfObject = (unode . T.pack) "rdf:object"--nameToUNode :: forall a. (ArrowXml a) => a XmlTree Node-nameToUNode = getName >>> mkUNode--attrExpandURI :: forall a. (ArrowXml a) => LParseState -> String -> a XmlTree String-attrExpandURI state attr = getAttrValue attr &&& baseUrl >>> my_expandURI- where baseUrl = constA (case stateBaseUrl state of BaseUrl b -> T.unpack b)--my_expandURI :: ArrowXml a => a (String, String) String-my_expandURI- = arrL (maybeToList . uncurry resolveIRIString)- where- resolveIRIString uri base =- case resolveIRI (T.pack base) (T.pack uri) of- Left _err -> Nothing- Right x -> Just (T.unpack x)---- |Make a UNode from an absolute string-mkUNode :: forall a. (ArrowIf a) => a String Node-mkUNode = choiceA [ (arr (isJust . unodeValidate . T.pack)) :-> (arr (unode . T.pack))- , arr (\_ -> True) :-> arr (\uri -> throw (ParserException ("Invalid URI: " ++ uri)))- ]---- |Make a UNode from a rdf:ID element, expanding relative URIs-mkRelativeNode :: forall a. (ArrowXml a) => LParseState -> a XmlTree Node-mkRelativeNode s = (getAttrValue "rdf:ID" >>> (arrL (maybeToList . xmlName)) >>> arr (\x -> '#':x)) &&& baseUrl- >>> expandURI >>> arr (unode . T.pack)- where baseUrl = constA (case stateBaseUrl s of BaseUrl b -> T.unpack b)---- The value of rdf:ID must match the XML Name production------ https://docstore.mik.ua/orelly/xml/xmlnut/ch02_04.htm--- http://www.informit.com/articles/article.aspx?p=27865&seqNum=4------ see rdf-tests test rdfms-rdf-id-error004-xmlName :: String -> Maybe String-xmlName str = go [] str- where- go accum [] = Just accum- go accum [s] =- if isValid s- then go (accum++[s]) []- else Nothing- go accum (s:ss) =- if isValid s- then go (accum++[s]) ss- else Nothing- isValid c = isAlphaNum c- || '_' == c- -- || '-' == c- || '.' == c- || ':' == c---- |Make a literal node with the given type and content-mkTypedLiteralNode :: Text -> String -> Node-mkTypedLiteralNode t content = lnode (typedL (T.pack content) t)---- |Use the given state to create a literal node-mkLiteralNode :: LParseState -> String -> Node-mkLiteralNode (LParseState _ (Just lang) _) content = lnode (plainLL (T.pack content) (T.pack lang))-mkLiteralNode (LParseState _ Nothing _) content = (lnode . plainL . T.pack) content---- |Generate an RDF blank node with incrementing IDs from the arrow state-mkBlankNode :: forall a b. (ArrowState GParseState a) => a b Node-mkBlankNode = nextState (\gState -> gState { stateGenId = stateGenId gState + 1 })- >>> arr (BNodeGen . stateGenId)+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}++-- |An parser for the RDF/XML format+-- <http://www.w3.org/TR/REC-rdf-syntax/>.++module Text.RDF.RDF4H.XmlParser+ ( XmlParser(..)+ , parseXmlDebug+ ) where++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 Data.Semigroup ((<>))+import Data.Set (Set)+import qualified Data.Set as S+import qualified Data.Map as Map+import Data.Maybe+import Data.Either+import Data.Bifunctor+import Data.HashSet (HashSet)+import qualified Data.HashSet as HS+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+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++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++-- |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.++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+ -- corresponding to the XML document.+parseURL' bUrl docUrl = parseFromURL (parseXmlRDF bUrl docUrl)++-- |The parser monad.+type Parser = ParserT (ExceptT String (State ParseState))++-- |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)++-- |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+parseXmlRDF bUrl dUrl = parseRdf . parseXml+ where+ bUrl' = BaseUrl <$> dUrl <|> bUrl+ parseXml = Xeno.fromRawXml . T.encodeUtf8+ parseRdf = first ParseFailure . join . second parseRdf'+ 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)+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)+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+pRdf = pAnyElement $ do+ attrs <- pRDFAttrs+ uri <- pName >>= pQName+ guard (uri == rdfTag)+ 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.+--+-- Throws an error if the namespace is not defined.+pQName :: Text -> Parser Text+pQName qn = do+ pm <- currentPrefixMappings+ let qn' = resolveQName pm qn >>= validateIRI+ either throwError pure qn'++-- |Process the attributes of an XML element.+--+-- To be called __once__ per XML element.+pRDFAttrs :: Parser (HashMap Text Text)+pRDFAttrs = do+ -- Language (xml:lang)+ liftA2 (<|>) pLang currentLang >>= setLang+ -- Base URI (xml:base)+ liftA2 (<|>) pBase currentBaseUri >>= setBaseUri+ bUri <- currentBaseUri+ -- Process the rest of the attributes+ attrs <- pAttrs+ -- Get the namespace definitions (xmlns:)+ pm <- updatePrefixMappings (PrefixMappings $ HM.foldlWithKey' mkNameSpace mempty attrs)+ -- Filter and resolve RDF attributes+ let as = HM.foldlWithKey' (mkRdfAttribute pm bUri) mempty attrs+ setNodeAttrs as+ pure as+ where+ -- |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 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+ -- 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 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+ 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'++-- |Return the value of the requested RDF attribute using its URI.+--+-- Fails if the attribute is not defined.+pRDFAttr :: Text -> Parser Text+pRDFAttr a = do+ as <- currentNodeAttrs+ maybe+ (fail . mconcat $ ["Attribute \"", T.unpack a, "\" not found."])+ pure+ (HM.lookup a as)++-- See: https://www.w3.org/TR/rdf-syntax-grammar/#nodeElementList+pNodeElementList :: Parser 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+ 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 = pAnyElement $ do+ -- Process attributes+ void pRDFAttrs+ -- Process URI, subject and @rdf:type@.+ (s, mt) <- pSubject+ ts1 <- pPropertyAttrs s+ -- Process propertyEltList+ ts2 <- keepState pPropertyEltList+ setSubject (Just s)+ let ts = ts1 <> ts2+ 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)+pSubject = do+ -- Create the subject+ -- [TODO] check the attributes that only one of the following may work+ s <- pUnodeId <|> pBnode <|> pUnode <|> pBnodeGen+ setSubject (Just s)+ -- Resolve URI+ uri <- pName >>= pQName+ -- Check that the URI is allowed+ unless (checkNodeUri uri) (throwError $ "URI not allowed: " <> T.unpack uri)+ -- Optional rdf:type triple+ mtype <- optional (pType1 s uri)+ pure (s, mtype)+ where+ checkNodeUri uri = isNotCoreSyntaxTerm uri && uri /= rdfLi && isNotOldTerm uri+ pUnodeId = (pIdAttr >>= mkUNodeID) <* removeNodeAttr rdfID+ pBnode = (BNode <$> pNodeIdAttr) <* removeNodeAttr rdfNodeID+ pUnode = (unode <$> pAboutAttr) <* removeNodeAttr rdfAbout+ -- Default subject: a new blank node+ pBnodeGen = newBNode+ pType1 n uri =+ if uri /= rdfDescription+ then pure $ Triple n rdfTypeNode (unode uri)+ else empty++-- See: https://www.w3.org/TR/rdf-syntax-grammar/#propertyAttr+pPropertyAttrs :: Node -> Parser Triples+pPropertyAttrs s = do+ attrs <- currentNodeAttrs+ HM.elems <$> HM.traverseWithKey f attrs+ where+ f attr value+ | not (isPropertyAttrURI attr) = throwError $ "URI not allowed for attribute: " <> T.unpack attr+ | 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))++pLang :: Parser (Maybe Text)+pLang = optional (pAttr "xml:lang")++-- [TODO] resolve base uri in context+pBase :: Parser (Maybe BaseUrl)+pBase = optional $ do+ uri <- pAttr "xml:base"+ -- Parse and remove fragment+ 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))++-- See: https://www.w3.org/TR/rdf-syntax-grammar/#propertyElt+pPropertyElt :: Parser Triples+pPropertyElt = pAnyElement $ do+ -- Process attributes+ void pRDFAttrs+ -- Process the predicate from the URI+ uri <- pName >>= pQName >>= listExpansion+ unless (isPropertyAttrURI uri) (throwError $ "URI not allowed for propertyElt: " <> T.unpack uri)+ let p = unode uri+ -- Process 'propertyElt'+ pParseTypeLiteralPropertyElt p+ <|> pParseTypeResourcePropertyElt p+ <|> pParseTypeCollectionPropertyElt p+ <|> pParseTypeOtherPropertyElt p+ <|> pResourcePropertyElt p+ <|> pLiteralPropertyElt p+ <|> pEmptyPropertyElt p+ where+ listExpansion u+ | u == rdfLi = nextCollectionIndex+ | otherwise = pure u++-- See: https://www.w3.org/TR/rdf-syntax-grammar/#resourcePropertyElt+pResourcePropertyElt :: Node -> Parser Triples+pResourcePropertyElt p = do+ pWs+ -- [NOTE] We need to restore part of the state after exploring the element' children.+ (ts1, o) <- keepState $ liftA2 (,) pNodeElement currentSubject+ pWs+ mi <- optional pIdAttr <* removeNodeAttr rdfID+ -- No other attribute is allowed.+ checkAllowedAttributes []+ -- Generated triple+ s <- currentSubject+ 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++-- See: https://www.w3.org/TR/rdf-syntax-grammar/#literalPropertyElt+pLiteralPropertyElt :: Node -> Parser Triples+pLiteralPropertyElt p = do+ l <- pText+ -- No children+ pChildren >>= guard . null+ mi <- optional pIdAttr <* removeNodeAttr rdfID+ checkAllowedAttributes [rdfDatatype]+ dt <- optional pDatatypeAttr+ s <- currentSubject+ lang <- currentLang+ -- Generated triple+ let l' = TL.toStrict l+ 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++-- See: https://www.w3.org/TR/rdf-syntax-grammar/#parseTypeLiteralPropertyElt+pParseTypeLiteralPropertyElt :: Node -> Parser Triples+pParseTypeLiteralPropertyElt p = do+ pt <- pRDFAttr rdfParseType+ guard (pt == "Literal")+ mi <- optional pIdAttr <* removeNodeAttr rdfID+ checkAllowedAttributes [rdfParseType]+ l <- pXMLLiteral+ -- Generated triple+ s <- currentSubject+ let o = lnode (typedL l rdfXmlLiteral)+ mt = (\s' -> Triple s' p o) <$> s+ -- Reify the triple+ ts <- maybe (pure mempty) (uncurry reifyTriple) (liftA2 (,) mi mt)+ pure $ maybe ts (:ts) mt++-- See: https://www.w3.org/TR/rdf-syntax-grammar/#parseTypeResourcePropertyElt+pParseTypeResourcePropertyElt :: Node -> Parser Triples+pParseTypeResourcePropertyElt p = do+ pt <- pRDFAttr rdfParseType+ guard (pt == "Resource")+ mi <- optional pIdAttr <* removeNodeAttr rdfID+ checkAllowedAttributes [rdfParseType]+ -- Generated triple+ s <- currentSubject+ o <- newBNode+ let mt = (\s' -> Triple s' p o) <$> s+ -- Reify the triple+ ts1 <- maybe (pure mempty) (uncurry reifyTriple) (liftA2 (,) mi mt)+ setSubject (Just o)+ -- Explore children+ ts2 <- keepCollectionIndex pPropertyEltList+ --setSubject s+ pure $ maybe (ts1 <> ts2) ((<> ts2) . (:ts1)) mt++-- See: https://www.w3.org/TR/rdf-syntax-grammar/#parseTypeCollectionPropertyElt+pParseTypeCollectionPropertyElt :: Node -> Parser Triples+pParseTypeCollectionPropertyElt p = do+ pt <- pRDFAttr rdfParseType+ guard (pt == "Collection")+ mi <- optional pIdAttr <* removeNodeAttr rdfID+ checkAllowedAttributes [rdfParseType]+ s <- currentSubject+ case s of+ Nothing -> pure mempty+ Just s' -> do+ r <- optional pNodeElement+ case r of+ Nothing ->+ -- Empty collection+ let t = Triple s' p rdfNilNode+ in ([t] <>) <$> maybe (pure mempty) (`reifyTriple` t) mi+ Just ts1 -> do+ -- Non empty collection+ s'' <- currentSubject+ n <- newBNode+ -- Triples corresping to the first item+ let t = Triple s' p n+ ts2 = maybe mempty (\s''' -> [t, Triple n rdfFirstNode s''']) s''+ -- Process next item+ ts3 <- go n+ -- Reify triple+ ts4 <- maybe (pure mempty) (`reifyTriple` t) mi+ pure $ mconcat [ts1, ts2, ts3, ts4]+ where+ go s = do+ -- Generate the triples of the current item.+ r <- optional pNodeElement+ case r of+ -- End of the collection+ Nothing -> pure [Triple s rdfRestNode rdfNilNode]+ -- Add the item to the collection and process the next item+ Just ts1 -> do+ s' <- currentSubject+ n <- newBNode+ let ts2 = maybe mempty (\s'' -> [Triple s rdfRestNode n, Triple n rdfFirstNode s'']) s'+ -- Next item+ ts3 <- go n+ pure $ mconcat [ts1, ts2, ts3]++-- See: https://www.w3.org/TR/rdf-syntax-grammar/#parseTypeOtherPropertyElt+pParseTypeOtherPropertyElt :: Node -> Parser Triples+pParseTypeOtherPropertyElt _p = do+ pt <- pRDFAttr rdfParseType+ guard (pt /= "Resource" && pt /= "Literal" && pt /= "Collection")+ checkAllowedAttributes [rdfParseType]+ _mi <- optional pIdAttr <* removeNodeAttr rdfID+ -- [FIXME] Implement 'parseTypeOtherPropertyElt'+ throwError "Not implemented: rdf:parseType = other"++-- See: https://www.w3.org/TR/rdf-syntax-grammar/#emptyPropertyElt+pEmptyPropertyElt :: Node -> Parser Triples+pEmptyPropertyElt p = do+ s <- currentSubject+ case s of+ Nothing -> pure mempty+ Just s' -> do+ mi <- optional pIdAttr <* removeNodeAttr rdfID+ o <- pResourceAttr' <|> pNodeIdAttr' <|> newBNode+ let t = Triple s' p o+ -- Reify triple+ ts1 <- maybe (pure mempty) (`reifyTriple` t) mi+ ts2 <- pPropertyAttrs o+ pure (t:ts1 <> ts2)+ where+ pResourceAttr' = unode <$> pResourceAttr <* removeNodeAttr rdfResource+ pNodeIdAttr' = BNode <$> pNodeIdAttr <* removeNodeAttr rdfNodeID++checkAllowedAttributes :: HashSet Text -> Parser ()+checkAllowedAttributes as = do+ attrs <- currentNodeAttrs+ let diff = HS.difference (HM.keysSet attrs) as+ unless (null diff) (throwError $ "Attributes not allowed: " <> show diff)++-- See: https://www.w3.org/TR/rdf11-concepts/#dfn-rdf-xmlliteral,+-- https://www.w3.org/TR/rdf-syntax-grammar/#literal+pXMLLiteral :: Parser Text+pXMLLiteral =+ T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . encode <$> pChildren++pIdAttr :: Parser Text+pIdAttr = do+ i <- pRDFAttr rdfID+ i' <- either throwError pure (checkRdfId i)+ -- Check the uniqueness of the ID in the context of the current base URI.+ checkIdIsUnique i'+ pure i'++checkIdIsUnique :: Text -> Parser ()+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 = do+ i <- pRDFAttr rdfNodeID+ either throwError pure (checkRdfId i)++pAboutAttr :: Parser Text+pAboutAttr = pRDFAttr rdfAbout >>= checkIRI "rdf:about"++pResourceAttr :: Parser Text+pResourceAttr = pRDFAttr rdfResource >>= checkIRI "rdf:resource"++pDatatypeAttr :: Parser Text+pDatatypeAttr = pRDFAttr rdfDatatype >>= checkIRI "rdf:datatype"++reifyTriple :: Text -> Triple -> Parser 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 ]++--------------------------------------------------------------------------------+-- URI checks++checkIRI :: String -> Text -> Parser Text+checkIRI msg iri = do+ bUri <- maybe mempty unBaseUrl <$> currentBaseUri+ case uriValidate iri of+ 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++-- 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++-- https://www.w3.org/TR/rdf-syntax-grammar/#oldTerms+isNotOldTerm :: Text -> Bool+isNotOldTerm uri = uri /= rdfAboutEach+ && uri /= rdfAboutEachPrefix+ && uri /= rdfBagID++--------------------------------------------------------------------------------+-- Parser's state utils++-- |Create a new unique blank node+newBNode :: Parser Node+newBNode = do+ 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+keepState p = do+ st <- get+ let bUri = stateBaseUri st+ is = stateIdSet st+ p <* do+ st' <- get+ let i = stateGenId st'+ bUri' = stateBaseUri st'+ 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' })++currentIdSet :: Parser (Set Text)+currentIdSet = stateIdSet <$> get++updateIdSet :: Text -> Parser ()+updateIdSet i = do+ is <- currentIdSet+ modify (\st -> st { stateIdSet = S.insert i is })++currentNodeAttrs :: Parser (HashMap Text Text)+currentNodeAttrs = stateNodeAttrs <$> get++setNodeAttrs :: HashMap Text Text -> Parser ()+setNodeAttrs as = modify (\st -> st { stateNodeAttrs = as })++removeNodeAttr :: Text -> Parser ()+removeNodeAttr a = HM.delete a <$> currentNodeAttrs >>= setNodeAttrs++currentPrefixMappings :: Parser PrefixMappings+currentPrefixMappings = statePrefixMapping <$> get++updatePrefixMappings :: PrefixMappings -> Parser PrefixMappings+updatePrefixMappings pm = do+ pm' <- (<> pm) <$> currentPrefixMappings+ modify (\st -> st { statePrefixMapping = pm' })+ pure pm'++currentCollectionIndex :: Parser Int+currentCollectionIndex = stateCollectionIndex <$> get++setCollectionIndex :: Int -> Parser ()+setCollectionIndex i = modify (\st -> st { stateCollectionIndex = i })++keepCollectionIndex :: Parser a -> Parser 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 = do+ modify $ \st -> st { stateCollectionIndex = stateCollectionIndex st + 1 }+ (rdfListIndex <>) . T.pack . show . stateCollectionIndex <$> get++resetCollectionIndex :: Parser ()+resetCollectionIndex = modify $ \st -> st { stateCollectionIndex = 0 }++currentBaseUri :: Parser (Maybe BaseUrl)+currentBaseUri = stateBaseUri <$> get++setBaseUri :: (Maybe BaseUrl) -> Parser ()+setBaseUri u = modify (\st -> st { stateBaseUri = u })++mkUNodeID :: Text -> Parser Node+mkUNodeID t = mkUnode <$> currentBaseUri+ where+ mkUnode = unode . \case+ Nothing -> t+ Just (BaseUrl u) -> mconcat [u, "#", t]++currentSubject :: Parser (Maybe Subject)+currentSubject = stateSubject <$> get++setSubject :: (Maybe Subject) -> Parser ()+setSubject s = modify (\st -> st { stateSubject = s })++currentLang :: Parser (Maybe Text)+currentLang = stateLang <$> get++setLang :: (Maybe Text) -> Parser ()+setLang lang = modify (\st -> st { stateLang = lang })
+ src/Text/RDF/RDF4H/XmlParser/Identifiers.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Text.RDF.RDF4H.XmlParser.Identifiers+ ( -- rdf:ID validation+ checkRdfId+ -- Qualified names+ , resolveQName, resolveQName'+ , parseQName+ ) where+++import Data.Functor ((<$))+import Control.Applicative (liftA2, Alternative(..))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Map as Map+import Data.Attoparsec.Text (Parser, (<?>))+import qualified Data.Attoparsec.Text as P+import Data.Semigroup ((<>))++import Data.RDF.Namespace++--------------------------------------------------------------------------------+-- 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+checkRdfId t = t <$ parseId t++parseId :: Text -> Either String Text+parseId = P.parseOnly $ pNCName <* (P.endOfInput <?> "Unexpected characters at the end")++--------------------------------------------------------------------------------+-- Qualified names++-- |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+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+resolveQName' (PrefixMappings pm) (Nothing, name) =+ case Map.lookup mempty pm of+ 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"]+ Just iri -> Right $ iri <> name++-- |Parse a qualified name.+--+-- 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")++-- https://www.w3.org/TR/xml-names/#ns-qualnames+-- https://www.w3.org/TR/xml-names/#NT-QName+pQName :: Parser (Maybe Text, Text)+pQName = pPrefixedName <|> pUnprefixedNamed+ where pUnprefixedNamed = (empty,) <$> pLocalPart++-- https://www.w3.org/TR/xml-names/#NT-PrefixedName+pPrefixedName :: Parser (Maybe Text, Text)+pPrefixedName = do+ prefix <- pLocalPart <* P.char ':'+ localPart <- pLocalPart+ pure (Just prefix, localPart)++-- https://www.w3.org/TR/xml-names/#NT-LocalPart+pLocalPart :: Parser Text+pLocalPart = pNCName++-- http://www.w3.org/TR/REC-xml-names/#NT-NCName+pNCName :: Parser Text+pNCName = liftA2 T.cons pNameStartChar pNameRest+ 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')
+ src/Text/RDF/RDF4H/XmlParser/Xeno.hs view
@@ -0,0 +1,91 @@+{-# 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+import Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+import qualified Data.Text.Encoding as T+import Data.Traversable (for)+import qualified HTMLEntities.Decoder+import qualified Xeno.DOM as Xeno+import qualified Text.RDF.RDF4H.XmlParser.Xmlbf as Xmlbf++--------------------------------------------------------------------------------+-- Xeno support++-- | Convert a 'Xeno.Node' from "Xeno.DOM" into an 'Element' from "Xmlbf".+fromXenoNode+ :: Xeno.Node -- ^ A 'Xeno.Node' from "Xeno.DOM".+ -> Either String Xmlbf.Node -- ^ A 'Xmlbf.Node' from "Xmlbf".+fromXenoNode x = do+ n <- decodeUtf8 (Xeno.name x)+ as <- for (Xeno.attributes x) $ \(k,v) -> do+ (,) <$> decodeUtf8 k <*> unescapeXmlUtf8 v+ cs <- for (Xeno.contents x) $ \case+ Xeno.Element n1 -> fromXenoNode n1+ Xeno.Text bs -> Xmlbf.text' =<< unescapeXmlUtf8Lazy bs+ Xeno.CData bs -> Xmlbf.text' =<< decodeUtf8Lazy bs+ Xmlbf.element' n (HM.fromList as) cs++-- | Parses a given UTF8-encoded raw XML fragment into @a@, using the @xeno@+-- Haskell library, so all of @xeno@'s parsing quirks apply.+--+-- You can provide the output of this function as input to "Xmlbf"'s+-- 'Xmlbf.parse'.+--+-- The given XML can contain more zero or more text or element nodes.+--+-- Surrounding whitespace is not stripped.+fromRawXml+ :: B.ByteString -- ^ Raw XML fragment.+ -> Either String [Xmlbf.Node] -- ^ 'Xmlbf.Node's from "Xmlbf"+fromRawXml = \bs -> case Xeno.parse ("<x>" <> dropBomUtf8 bs <> "</x>") of+ Left e -> Left ("Malformed XML: " ++ show e)+ Right n -> fromXenoNode n >>= \case+ Xmlbf.Element "x" _ cs -> Right cs+ _ -> Left "Unknown result from fromXenoNode. Please report this as a bug."++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- Miscellaneous++decodeUtf8 :: B.ByteString -> Either String T.Text+{-# INLINE decodeUtf8 #-}+decodeUtf8 bs = Bif.first show (T.decodeUtf8' bs)++decodeUtf8Lazy :: B.ByteString -> Either String TL.Text+{-# INLINE decodeUtf8Lazy #-}+decodeUtf8Lazy bs = fmap TL.fromStrict (decodeUtf8 bs)++unescapeXmlUtf8 :: B.ByteString -> Either String T.Text+{-# INLINE unescapeXmlUtf8 #-}+unescapeXmlUtf8 bs = fmap TL.toStrict (unescapeXmlUtf8Lazy bs)++unescapeXmlUtf8Lazy :: B.ByteString -> Either String TL.Text+{-# INLINE unescapeXmlUtf8Lazy #-}+unescapeXmlUtf8Lazy bs = do+ t <- decodeUtf8 bs+ pure (TB.toLazyText (HTMLEntities.Decoder.htmlEncodedText t))++dropBomUtf8 :: B.ByteString -> B.ByteString+{-# INLINE dropBomUtf8 #-}+dropBomUtf8 bs | B.isPrefixOf "\xEF\xBB\xBF" bs = B.drop 3 bs+ | otherwise = bs
+ src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs view
@@ -0,0 +1,938 @@+{-# 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)+import Data.Semigroup+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+{-# COMPLETE Element #-} -- TODO this leads to silly pattern matching warnings++-- | Destruct a text 'Node'.+pattern Text :: TL.Text -> Node+pattern Text t <- Text' t+{-# COMPLETE Text #-} -- TODO this leads to silly pattern matching warnings++-- | 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++instance (Monad m, Monoid a) => Monoid (ParserT m a) where+ 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 (>>=) #-}+ fail = pFail+ {-# INLINE fail #-}++#if MIN_VERSION_base(4,9,0)+instance Monad m => Control.Monad.Fail.MonadFail (ParserT m) where+ fail = pFail+ {-# INLINE fail #-}+#endif++-- | A 'ParserT' that always fails with the given error message.+pFail :: Applicative m => String -> ParserT m a+pFail = \msg -> ParserT (\s -> pure (s, Left msg))+{-# INLINE pFail #-}++-- | @'mzero' ma mb@ backtracks the internal parser state before running @mb@.+instance Monad m => MonadPlus (ParserT m) where+ mzero = empty+ {-# INLINE mzero #-}+ mplus = (<|>)+ {-# INLINE mplus #-}++instance MonadFix m => MonadFix (ParserT m) where+ mfix f =+ let die = \msg -> error ("mfix (ParserT): " <> msg)+ in ParserT (\s0 ->+ mfix (\ ~(_s1, ea) -> runParserT (f (either die id ea)) s0))++instance MonadZip m => MonadZip (ParserT m) where+ mzipWith f pa pb = ParserT (\s0 -> do+ (s1, ea) <- runParserT pa s0+ case ea of+ Right a0 ->+ mzipWith (\a1 (s2, eb) -> (s2, fmap (f a1) eb))+ (pure a0) (runParserT pb s1)+ Left msg -> pure (s1, Left msg))+ {-# INLINABLE mzipWith #-}++instance MonadTrans ParserT where+ lift = \ma -> ParserT (\s -> ma >>= \a -> pure (s, Right a))+ {-# INLINE lift #-}++instance MFunctor ParserT where+ hoist nat = \p -> ParserT (\s -> nat (runParserT p s))+ {-# INLINE hoist #-}++instance MonadIO m => MonadIO (ParserT m) where+ liftIO = lift . liftIO+ {-# INLINE liftIO #-}++instance MonadReader r m => MonadReader r (ParserT m) where+ ask = lift ask+ {-# INLINE ask #-}+ local f = \p -> ParserT (\s -> local f (runParserT p s))+ {-# INLINE local #-}++instance MonadState s m => MonadState s (ParserT m) where+ state = lift . state+ {-# INLINE state #-}++instance MonadError e m => MonadError e (ParserT m) where+ throwError = lift . throwError+ {-# INLINABLE throwError #-}+ catchError ma h = ParserT (\s ->+ catchError (runParserT ma s)+ (\e -> runParserT (h e) s))+ {-# INLINABLE catchError #-}++instance Ex.MonadThrow m => Ex.MonadThrow (ParserT m) where+ throwM = lift . Ex.throwM+ {-# INLINABLE throwM #-}++instance Ex.MonadCatch m => Ex.MonadCatch (ParserT m) where+ catch ma h = ParserT (\s ->+ Ex.catch (runParserT ma s)+ (\e -> runParserT (h e) s))+ {-# INLINABLE catch #-}++instance Ex.MonadMask m => Ex.MonadMask (ParserT m) where+ mask f = ParserT (\s ->+ Ex.mask (\u ->+ runParserT (f (\p -> ParserT (u . runParserT p))) s))+ {-# INLINABLE mask #-}+ uninterruptibleMask f = ParserT (\s ->+ Ex.uninterruptibleMask (\u ->+ runParserT (f (\p -> ParserT (u . runParserT p))) s))+ {-# INLINABLE uninterruptibleMask #-}+ generalBracket acq rel use = ParserT (\s0 -> do+ ((_sb,eb), (sc,ec)) <- Ex.generalBracket+ (runParserT acq s0)+ (\(s1, ea) ec -> case ea of+ Right a -> case ec of+ Ex.ExitCaseSuccess (s2, Right b) ->+ runParserT (rel a (Ex.ExitCaseSuccess b)) s2+ Ex.ExitCaseSuccess (s2, Left msg) ->+ -- Result of using mzero or similar on release+ pure (s2, Left msg)+ Ex.ExitCaseException e ->+ runParserT (rel a (Ex.ExitCaseException e)) s1+ Ex.ExitCaseAbort ->+ runParserT (rel a Ex.ExitCaseAbort) s1+ Left msg ->+ -- acq failed, nothing to release+ pure (s1, Left msg))+ (\(s1, ea) -> case ea of+ Right a -> runParserT (use a) s1+ Left msg ->+ -- acq failed, nothing to use+ pure (s1, Left msg))+ -- We run ec first because its error message, if any, has priority+ pure (sc, flip (,) <$> ec <*> eb))++-- | This version uses the current state on entering the continuation. See+-- 'liftCallCC''. It does not satisfy the uniformity property (see+-- 'Control.Monad.Signatures.CallCC').+instance MonadCont m => MonadCont (ParserT m) where+ callCC f = ParserT (\s0 ->+ callCC (\c -> runParserT (f (\a -> ParserT (\s1 -> c (s1, Right a)))) s0))++--------------------------------------------------------------------------------+-- Some parsers++-- | @'pElement' "foo" p@ runs a 'ParserT' @p@ inside a 'Element' node named+-- @"foo"@. This parser __fails__ if such element does not exist at the current+-- position.+--+-- Leading whitespace is ignored. If you need to preserve that whitespace for+-- some reason, capture it using 'pText' before using 'pElement'.+--+-- __Consumes the matched element__ from the parser state.+pElement+ :: Monad m+ => T.Text -- ^ Element name as strict 'T.Text'.+ -> ParserT m a -- ^ 'ParserT' to run /inside/ the matched 'Element'.+ -> ParserT m a+pElement t0 p0 = ParserT $ \case+ SReg t1 as0 (Element' t as cs : cs0) | t == t0 ->+ runParserT p0 (SReg t as cs) >>= \case+ (_, Right a) -> pure (SReg t1 as0 cs0, Right a)+ (s1, Left msg) -> pure (s1, Left msg)+ STop (Element' t as cs : cs0) | t == t0 ->+ runParserT p0 (SReg t as cs) >>= \case+ (_, Right a) -> pure (STop cs0, Right a)+ (s1, Left msg) -> pure (s1, Left msg)+ -- skip leading whitespace+ SReg t as (Text' x : cs) | TL.all Char.isSpace x ->+ runParserT (pElement t0 p0) (SReg t as cs)+ STop (Text' x : cs) | TL.all Char.isSpace x ->+ runParserT (pElement t0 p0) (STop cs)+ s0 -> pure (s0, Left ("Missing element " <> show t0))+{-# INLINABLE pElement #-}++-- | @'pAnyElement' p@ runs a 'ParserT' @p@ inside the 'Element' node at the+-- current position, if any. Otherwise, if no such element exists, this parser+-- __fails__.+--+-- You can recover the name of the matched element using 'pName' inside the+-- given 'ParserT'. However, if you already know beforehand the name of the+-- element that you want to match, it's better to use 'pElement' rather than+-- 'pAnyElement'.+--+-- Leading whitespace is ignored. If you need to preserve that whitespace for+-- some reason, capture it using 'pText' before using 'pAnyElement'.+--+-- __Consumes the matched element__ from the parser state.+pAnyElement+ :: Monad m+ => ParserT m a -- ^ 'ParserT' to run /inside/ any matched 'Element'.+ -> ParserT m a+pAnyElement p0 = ParserT $ \case+ SReg t0 as0 (Element' t as cs : cs0) ->+ runParserT p0 (SReg t as cs) >>= \case+ (_, Right a) -> pure (SReg t0 as0 cs0, Right a)+ (s1, Left msg) -> pure (s1, Left msg)+ STop (Element' t as cs : cs0) ->+ runParserT p0 (SReg t as cs) >>= \case+ (_, Right a) -> pure (STop cs0, Right a)+ (s1, Left msg) -> pure (s1, Left msg)+ -- skip leading whitespace+ SReg t as (Text' x : cs) | TL.all Char.isSpace x ->+ runParserT (pAnyElement p0) (SReg t as cs)+ STop (Text' x : cs) | TL.all Char.isSpace x ->+ runParserT (pAnyElement p0) (STop cs)+ s0 -> pure (s0, Left "Missing element")+{-# INLINABLE pAnyElement #-}++-- | Returns the name of the currently selected 'Element'.+--+-- This parser __fails__ if there's no currently selected 'Element' (see+-- 'pElement', 'pAnyElement').+--+-- Doesn't modify the parser state.+pName+ :: Applicative m+ => ParserT m T.Text -- ^ Element name as strict 'T.Text'.+pName = ParserT (\s -> case s of+ SReg t _ _ -> pure (s, Right t)+ _ -> pure (s, Left "Before selecting an name, you must select an element"))+{-# INLINABLE pName #-}++-- | Return the value of the requested attribute, if defined. Returns an+-- 'T.empty' 'T.Text' in case the attribute is defined but no value was given to+-- it.+--+-- This parser __fails__ if there's no currently selected 'Element' (see+-- 'pElement', 'pAnyElement').+--+-- __Consumes the matched attribute__ from the parser state.+pAttr+ :: Applicative m+ => T.Text+ -- ^ Attribute name as strict 'T.Text'.+ -> ParserT m T.Text+ -- ^ Attribute value as strict 'T.Text', possibly 'T.empty'.+pAttr n = ParserT (\s -> case s of+ SReg t as cs -> case HM.lookup n as of+ Just x -> pure (SReg t (HM.delete n as) cs, Right x)+ Nothing -> pure (s, Left ("Missing attribute " <> show n))+ _ -> pure (s, Left "Before selecting an attribute, you must select an element"))+{-# INLINABLE pAttr #-}++-- | Returns all of the available element attributes.+--+-- Returns 'T.empty' 'T.Text' as values in case an attribute is defined but no+-- value was given to it.+--+-- This parser __fails__ if there's no currently selected 'Element' (see+-- 'pElement', 'pAnyElement').+--+-- __Consumes all the attributes__ for this element from the parser state.+pAttrs+ :: Applicative m+ => ParserT m (HM.HashMap T.Text T.Text)+ -- ^ Pairs of attribute names and possibly 'T.empty' values, as strict+ -- 'T.Text'.+pAttrs = ParserT (\s -> case s of+ SReg t as cs -> pure (SReg t mempty cs, Right as)+ _ -> pure (s, Left "Before selecting an attribute, you must select an element"))+{-# INLINABLE pAttrs #-}++-- | Returns all of the immediate children of the current element.+--+-- If parsing top-level nodes rather than a particular element (that is, if+-- 'pChildren' is /not/ being run inside 'pElement'), then all of the top level+-- 'Node's will be returned.+--+-- __Consumes all the returned nodes__ from the parser state.+pChildren+ :: Applicative m+ => ParserT m [Node] -- ^ 'Node's in their original order.+pChildren = ParserT (\case+ STop cs -> pure (STop mempty, Right cs)+ SReg t as cs -> pure (SReg t as mempty, Right cs))+{-# INLINABLE pChildren #-}++-- | Returns the contents of a 'Text' node.+--+-- Surrounidng whitespace is not removed, as it is considered to be part of the+-- text node.+--+-- If there is no text node at the current position, then this parser __fails__.+-- This implies that 'pText' /never/ returns an empty 'TL.Text', since there is+-- no such thing as a text node without text.+--+-- Please note that consecutive text nodes are always concatenated and returned+-- together.+--+-- @+-- 'parseT' 'pText' ('text' \"Ha\" <> 'text' \"sk\" <> 'text' \"ell\")+-- == 'pure' ('Right' ('text' "Haskell"))+-- @+--+-- __Consumes the text__ from the parser state. This implies that if you+-- perform two consecutive 'pText' calls, the second will always fail.+--+-- @+-- 'parseT' ('pText' >> 'pText') ('text' \"Ha\" <> 'text' \"sk\" <> 'text' \"ell\")+-- == 'pure' ('Left' "Missing text node")+-- @+pText+ :: Applicative m+ => ParserT m TL.Text+ -- ^ Content of the text node as a lazy 'TL.Text'.+pText = ParserT (\case+ -- Note: this works only because we asume 'normalize' has been used.+ STop (Text x : ns) -> pure (STop ns, Right x)+ SReg t as (Text x : cs) -> pure (SReg t as cs, Right x)+ s0 -> pure (s0, Left "Missing text node"))+{-# INLINABLE pText #-}++-- | Succeeds if all of the elements, attributes and text nodes have+-- been consumed.+pEndOfInput :: Applicative m => ParserT m ()+pEndOfInput = ParserT (\s -> case isEof s of+ True -> pure (s, Right ())+ False -> pure (s, Left "Not end of input yet"))+{-# INLINABLE pEndOfInput #-}++isEof :: ParserState -> Bool+isEof = \case+ SReg _ as cs -> HM.null as && null cs+ STop ns -> null ns+{-# INLINE isEof #-}++--------------------------------------------------------------------------------+-- Rendering++class ToXml a where+ -- | Renders a value of type @a@ into an XML fragment body.+ --+ -- If a 'FromXml' instance for @a@ exists, then:+ --+ -- @+ -- 'parseM' 'fromXml' ('toXml' a) == 'pure' ('Right' a)+ -- @+ toXml :: a -> [Node]++-- | Encodes a list of XML 'Node's, representing an XML fragment body, to an+-- UTF8-encoded and XML-escaped bytestring.+--+-- This function doesn't render self-closing elements. Instead, all+-- elements have a corresponding closing tag.+--+-- Also, it doesn't render CDATA sections. Instead, all text is escaped as+-- necessary.+encode :: [Node] -> BB.Builder+encode xs = mconcat (map encodeNode xs)+ where+ encodeNode :: Node -> BB.Builder+ encodeNode = \case+ Text x -> encodeXmlUtf8Lazy x+ Element t as cs ->+ -- This ugly code is so that we make sure we always bind concatenation+ -- to the right with as little effort as possible, using (<>).+ "<" <> encodeUtf8 t+ <> encodeAttrs (">" <> encode cs <> "</" <> encodeUtf8 t <> ">") as+ {-# INLINE encodeNode #-}+ encodeAttrs :: BB.Builder -> HM.HashMap T.Text T.Text -> BB.Builder+ encodeAttrs = HM.foldlWithKey'+ (\o k v -> " " <> encodeUtf8 k <> "=\"" <> encodeXmlUtf8 v <> "\"" <> o)+ {-# INLINE encodeAttrs #-}++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- Node fixpoint++-- | Post-order depth-first replacement of 'Node' and all of its children.+--+-- This function works like 'Data.Function.fix', but the given function is+-- trying to find a fixpoint for the individual children nodes, not for the root+-- node.+--+-- For example, the following function renames every node named @"w"@ to @"y"@,+-- and every node named @"y"@ to @"z"@. It accomplishes this by first renaming+-- @"w"@ nodes to @"x"@, and then, by using @k@ recursively to further rename+-- all @"x"@ nodes (including the ones that were just created) to @"y"@ in a+-- post-order depth-first manner. After renaming an @"x"@ node to @"y"@, the+-- recursion stops (i.e., @k@ is not used), so our new @"y"@ nodes won't be+-- further renamed to @"z"@. However, nodes that were named @"y"@ initially will+-- be renamed to @"z"@.+--+-- In our example we only replace one node with another, but a node can be+-- replaced with zero or more nodes, depending on the length of the resulting+-- list.+--+-- @+-- foo :: 'Node' -> ['Node']+-- foo = 'dfpos' $ \\k -> \\case+-- 'Element' "w" as cs -> 'element' "x" as cs >>= k+-- 'Element' "x" as cs -> 'element' "y" as cs+-- 'Element' "y" as cs -> 'element' "z" as cs >>= k+-- @+--+-- See 'dfpre' for pre-orderd depth-first replacement.+--+-- /WARNING/ If you call @k@ in every branch, then 'dfpos' will never terminate.+-- Make sure the recursion stops at some point by simply returning a list of+-- nodes instead of calling @k@.+dfpos :: ((Node -> [Node]) -> Node -> [Node]) -> Node -> [Node]+dfpos f = runIdentity . dfposM (\k -> Identity . f (runIdentity . k))++-- | Monadic version of 'dfpos'.+dfposM :: Monad m => ((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]+dfposM f = \n0 -> do+ c1 <- traverseChildren (dfposM f) (cursorFromNode n0)+ c2 <- traverseRightSiblings (dfposM f) c1+ fmap (normalize . join)+ (traverse (f (dfposM f)) (cursorSiblings c2))+++-- | Pre-order depth-first replacement of 'Node' and all of its children.+--+-- This is just like 'dfpos' but the search proceeds in a different order.+dfpre :: ((Node -> [Node]) -> Node -> [Node]) -> Node -> [Node]+dfpre f = runIdentity . dfpreM (\k -> Identity . f (runIdentity . k))++-- | Monadic version of 'dfpre'.+dfpreM :: Monad m => ((Node -> m [Node]) -> Node -> m [Node]) -> Node -> m [Node]+dfpreM f = \n0 -> do+ ns <- f (dfpreM f) n0+ fmap (normalize . join) $ for ns $ \n -> do+ c1 <- traverseChildren (dfpreM f) (cursorFromNode n)+ cursorSiblings <$> traverseRightSiblings (dfpreM f) c1+++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- INTERNAL: Cursor+--+-- Most of this comes from Chris Smith's xmlhtml, BSD3 licensed+-- https://hackage.haskell.org/package/xmlhtml++-- | Zipper into a 'Node' tree.+data Cursor = Cursor+ { _cursorCurrent :: !Node+ -- ^ Retrieves the current node of a 'Cursor'.+ , _cursorLefts :: !(Seq Node)+ -- ^ Nodes to the left (ordered right to left).+ , _cursorRights :: !(Seq Node)+ -- ^ Nodes to the right (ordered left to right).+ , _cursorParents :: !(Seq (Seq Node, T.Text, HM.HashMap T.Text T.Text, Seq Node))+ -- ^ Parents' name, attributes, and siblings.+ }++------------------------------------------------------------------------------++-- | The cursor if left where it starts.+traverseChildren :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor+{-# INLINABLE traverseChildren #-}+traverseChildren f c0 = case _cursorCurrent c0 of+ Text _ -> pure c0+ Element t as cs -> do+ n1s <- fmap (normalize . join) (traverse f cs)+ pure (c0 {_cursorCurrent = Element' t as n1s})++-- | The cursor if left in the rightmost sibling.+traverseRightSiblings :: Monad m => (Node -> m [Node]) -> Cursor -> m Cursor+{-# INLINABLE traverseRightSiblings #-}+traverseRightSiblings f c0 = case cursorRemoveRight c0 of+ Nothing -> pure c0+ Just (n1, c1) -> do+ n2s <- fmap normalize (f n1)+ traverseRightSiblings f (cursorInsertManyRight n2s c1)++-- | Builds a 'Cursor' for navigating a tree. That is, a forest with a single+-- root 'Node'.+cursorFromNode :: Node -> Cursor+{-# INLINE cursorFromNode #-}+cursorFromNode n = Cursor n mempty mempty mempty++-- | Retrieves a list of the 'Node's at the same level as the current position+-- of a cursor, including the current node.+cursorSiblings :: Cursor -> [Node]+{-# INLINE cursorSiblings #-}+cursorSiblings (Cursor cur ls rs _) =+ toList (Seq.reverse ls <> (cur Seq.<| rs))++-- | Removes the node to the right and return it.+cursorRemoveRight :: Cursor -> Maybe (Node, Cursor)+{-# INLINABLE cursorRemoveRight #-}+cursorRemoveRight = \case+ Cursor n ls rs0 ps | not (Seq.null rs0) ->+ case Seq.viewl rs0 of+ r Seq.:< rs -> Just (r, Cursor n ls rs ps)+ _ -> undefined -- unreachable, rs0 is not empty+ _ -> Nothing++-- | Inserts a list of new 'Node's to the right of the current position.+cursorInsertManyRight :: [Node] -> Cursor -> Cursor+{-# INLINE cursorInsertManyRight #-}+cursorInsertManyRight ns (Cursor nn ls rs ps) =+ Cursor nn ls (Seq.fromList ns <> rs) ps++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- Miscellaneous++encodeUtf8 :: T.Text -> BB.Builder+{-# INLINE encodeUtf8 #-}+encodeUtf8 = T.encodeUtf8Builder++encodeXmlUtf8 :: T.Text -> BB.Builder+{-# INLINE encodeXmlUtf8 #-}+encodeXmlUtf8 = T.encodeUtf8BuilderEscaped xmlEscaped++encodeXmlUtf8Lazy :: TL.Text -> BB.Builder+{-# INLINE encodeXmlUtf8Lazy #-}+encodeXmlUtf8Lazy = TL.encodeUtf8BuilderEscaped xmlEscaped++xmlEscaped :: BBP.BoundedPrim Word8+{-# INLINE xmlEscaped #-}+xmlEscaped =+ BBP.condB (== 38) (fixed5 (38,(97,(109,(112,59))))) $ -- '&' -> "&"+ BBP.condB (== 60) (fixed4 (38,(108,(116,59)))) $ -- '<' -> "<"+ BBP.condB (== 62) (fixed4 (38,(103,(116,59)))) $ -- '>' -> ">"+ BBP.condB (== 34) (fixed5 (38,(35,(51,(52,59))))) $ -- '"' -> """+ BBP.liftFixedToBounded BBP.word8+ where+ {-# INLINE fixed4 #-}+ fixed4 :: (Word8, (Word8, (Word8, Word8))) -> BBP.BoundedPrim Word8+ fixed4 x = BBP.liftFixedToBounded+ (const x BBP.>$< BBP.word8 BBP.>*< BBP.word8+ BBP.>*< BBP.word8 BBP.>*< BBP.word8)+ {-# INLINE fixed5 #-}+ fixed5 :: (Word8, (Word8, (Word8, (Word8, Word8)))) -> BBP.BoundedPrim Word8+ fixed5 x = BBP.liftFixedToBounded+ (const x BBP.>$< BBP.word8 BBP.>*< BBP.word8+ BBP.>*< BBP.word8 BBP.>*< BBP.word8 BBP.>*< BBP.word8)
testsuite/tests/Data/RDF/IRITests.hs view
@@ -1,6 +1,3 @@---{-# LANGUAGE DeriveGeneric #-}---{-# LANGUAGE TypeFamilies #-}---{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Data.RDF.IRITests
testsuite/tests/Data/RDF/PropertyTests.hs view
@@ -11,6 +11,7 @@ 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@@ -105,7 +106,7 @@ arbitraryBaseUrl :: Gen BaseUrl arbitraryBaseUrl = oneof $- map+ fmap (return . BaseUrl . T.pack) ["http://example.org/", "http://example.com/a", "http://asdf.org/b", "http://asdf.org/c"] @@ -131,7 +132,7 @@ p_empty :: Rdf rdf => RDF rdf -> Bool-p_empty empty = triplesOf empty == []+p_empty empty = null (triplesOf empty) -- triplesOf any RDF should return unique triples used to create it p_mkRdf_triplesOf@@ -445,7 +446,7 @@ :: (Rdf rdf) => RDF rdf -> SingletonGraph rdf -> Bool p_remove_triple_from_singleton_graph_query_s _unused singletonGraph =- query newGr (Just s) Nothing Nothing == []+ null (query newGr (Just s) Nothing Nothing) where tripleInGraph@(Triple s _p _o) = head (triplesOf (rdfGraph singletonGraph)) newGr = removeTriple (rdfGraph singletonGraph) tripleInGraph@@ -457,7 +458,7 @@ :: (Rdf rdf) => RDF rdf -> SingletonGraph rdf -> Bool p_remove_triple_from_singleton_graph_query_p _unused singletonGraph =- query newGr Nothing (Just p) Nothing == []+ null (query newGr Nothing (Just p) Nothing) where tripleInGraph@(Triple _s p _o) = head (triplesOf (rdfGraph singletonGraph)) newGr = removeTriple (rdfGraph singletonGraph) tripleInGraph@@ -469,7 +470,7 @@ :: (Rdf rdf) => RDF rdf -> SingletonGraph rdf -> Bool p_remove_triple_from_singleton_graph_query_o _unused singletonGraph =- query newGr Nothing Nothing (Just o) == []+ null (query newGr Nothing Nothing (Just o)) where tripleInGraph@(Triple _s _p o) = head (triplesOf (rdfGraph singletonGraph)) newGr = removeTriple (rdfGraph singletonGraph) tripleInGraph@@ -482,10 +483,10 @@ p_add_then_remove_triples _empty genTriples = let emptyGraph = _empty populatedGraph =- foldr (\t gr -> addTriple gr t) emptyGraph genTriples+ foldr (flip addTriple) emptyGraph genTriples emptiedGraph =- foldr (\t gr -> removeTriple gr t) populatedGraph genTriples- in triplesOf emptiedGraph == []+ foldr (flip removeTriple) populatedGraph genTriples+ in null (triplesOf emptiedGraph) equivNode :: (Node -> Node -> Bool) -> (Triple -> Node)@@ -546,7 +547,7 @@ tripleFromGen _triplesOf rdf = if null ts then return Nothing- else oneof $ map (return . Just) ts+ else oneof $ fmap (return . Just) ts where ts = _triplesOf rdf @@ -560,12 +561,13 @@ languages = [T.pack "fr", T.pack "en"] datatypes :: [T.Text]-datatypes = map (mkUri xsd . T.pack) ["string", "int", "token"]+datatypes = fmap (mkUri xsd . T.pack) ["string", "int", "token"] uris :: [T.Text]-uris =- map (mkUri ex) [T.pack n `T.append` T.pack (show (i::Int)) | n <- ["foo", "bar", "quz", "zak"], i <- [0..2]]- ++ [T.pack "ex:" `T.append` T.pack n `T.append` 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]@@ -574,16 +576,16 @@ typedliterals = [typedL lit dtype | lit <- litvalues, dtype <- datatypes] litvalues :: [T.Text]-litvalues = map T.pack ["hello", "world", "peace", "earth", "", "haskell"]+litvalues = fmap T.pack ["hello", "world", "peace", "earth", "", "haskell"] unodes :: [Node]-unodes = map UNode uris+unodes = fmap UNode uris bnodes :: [ Node]-bnodes = map (BNode . \i -> T.pack ":_genid" `T.append` T.pack (show (i::Int))) [1..5]+bnodes = fmap (BNode . \i -> T.pack ":_genid" <> T.pack (show (i::Int))) [1..5] lnodes :: [Node]-lnodes = [LNode lit | lit <- plainliterals ++ typedliterals]+lnodes = [LNode lit | lit <- plainliterals <> typedliterals] -- maximum number of triples maxN :: Int@@ -601,11 +603,10 @@ arbitrary = do s <- arbitraryS p <- arbitraryP- o <- arbitraryO- return (triple s p o)+ triple s p <$> arbitraryO instance Arbitrary Node where- arbitrary = oneof $ map return unodes+ arbitrary = oneof $ fmap return unodes arbitraryTs :: Gen Triples arbitraryTs = do@@ -613,9 +614,9 @@ sequence [arbitrary | _ <- [1 .. n]] arbitraryS, arbitraryP, arbitraryO :: Gen Node-arbitraryS = oneof $ map return $ unodes ++ bnodes-arbitraryP = oneof $ map return unodes-arbitraryO = oneof $ map return $ unodes ++ bnodes ++ lnodes+arbitraryS = oneof $ fmap return $ unodes <> bnodes+arbitraryP = oneof $ fmap return unodes+arbitraryO = oneof $ fmap return $ unodes <> bnodes <> lnodes ---------------------------------------------------- -- Unit test cases --
testsuite/tests/Test.hs view
@@ -25,13 +25,13 @@ suiteFilesDirNTriples = "rdf-tests/ntriples/" mfPathTurtle,mfPathXml,mfPathNTriples :: T.Text-mfPathTurtle = T.concat [suiteFilesDirTurtle, "manifest.ttl"]-mfPathXml = T.concat [suiteFilesDirXml, "manifest.ttl"]-mfPathNTriples = T.concat [suiteFilesDirNTriples, "manifest.ttl"]+mfPathTurtle = mconcat [suiteFilesDirTurtle, "manifest.ttl"]+mfPathXml = mconcat [suiteFilesDirXml, "manifest.ttl"]+mfPathNTriples = mconcat [suiteFilesDirNTriples, "manifest.ttl"] mfBaseURITurtle,mfBaseURIXml,mfBaseURINTriples :: BaseUrl-mfBaseURITurtle = BaseUrl "http://www.w3.org/2013/TurtleTests/"-mfBaseURIXml = BaseUrl "http://www.w3.org/2013/RDFXMLTests/"+mfBaseURITurtle = W3CTurtleTest.mfBaseURITurtle+mfBaseURIXml = W3CRdfXmlTest.mfBaseURIXml mfBaseURINTriples = BaseUrl "http://www.w3.org/2013/N-TriplesTests/" main :: IO ()@@ -41,9 +41,8 @@ dir <- getCurrentDirectory let fileSchemeUri suitesDir = fromJust . filePathToUri $ (dir </> T.unpack suitesDir)- turtleManifest <-- loadManifest mfPathTurtle (fileSchemeUri suiteFilesDirTurtle)- xmlManifest <- loadManifest mfPathXml (fileSchemeUri suiteFilesDirXml)+ turtleManifest <- loadManifest mfPathTurtle (unBaseUrl mfBaseURITurtle)+ xmlManifest <- loadManifest mfPathXml (unBaseUrl mfBaseURIXml) nTriplesManifest <- loadManifest mfPathNTriples (fileSchemeUri suiteFilesDirNTriples) -- run tests@@ -61,7 +60,12 @@ (graphTests "AdjHashMap" (empty :: RDF AdjHashMap)- (mkRdf :: Triples -> Maybe BaseUrl -> PrefixMappings -> RDF AdjHashMap))]+ (mkRdf :: Triples -> Maybe BaseUrl -> PrefixMappings -> RDF AdjHashMap))+ ,+ (graphTests+ "AlgebraicGraph"+ (empty :: RDF AlgebraicGraph)+ (mkRdf :: Triples -> Maybe BaseUrl -> PrefixMappings -> RDF AlgebraicGraph))] , testGroup "graph-impl-unit-tests"@@ -95,15 +99,15 @@ "parser-w3c-tests-turtle" [ testGroup "parser-w3c-tests-turtle-parsec"- [W3CTurtleTest.testsParsec turtleManifest]+ [W3CTurtleTest.testsParsec (dir </> T.unpack suiteFilesDirTurtle) turtleManifest] , testGroup "parser-w3c-tests-turtle-attoparsec"- [W3CTurtleTest.testsAttoparsec turtleManifest]+ [W3CTurtleTest.testsAttoparsec (dir </> T.unpack suiteFilesDirTurtle) turtleManifest] ] , testGroup "parser-w3c-tests-xml"- [ W3CRdfXmlTest.tests xmlManifest+ [ W3CRdfXmlTest.tests (dir </> T.unpack suiteFilesDirXml) xmlManifest ] ] )
testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs view
@@ -4,6 +4,7 @@ ( tests ) where +import Data.Semigroup ((<>)) -- Testing imports import Test.Tasty import Test.Tasty.HUnit as TU@@ -44,20 +45,8 @@ mtestBaseUri :: Maybe BaseUrl mtestBaseUri = Just . BaseUrl $ testBaseUri -fpath :: String -> Int -> String -> String-fpath name i ext = printf "data/ttl/conformance/%s-%02d.%s" name i ext :: String- tests :: [TestTree]-tests = ts1 ++ ts2 ++ ts3- where ts1 = fmap checkGoodConformanceTest [0..29]- ts2 = fmap checkBadConformanceTest [0..15]- ts3 = fmap (uncurry checkGoodOtherTest) otherTestFiles--checkGoodConformanceTest :: Int -> TestTree-checkGoodConformanceTest i =- let expGr = loadExpectedGraph "test" i- inGr = loadInputGraph "test" i- in doGoodConformanceTest expGr inGr (printf "test-%d" i :: String)+tests = fmap (uncurry checkGoodOtherTest) otherTestFiles checkGoodOtherTest :: String -> String -> TestTree checkGoodOtherTest dir fname =@@ -72,31 +61,26 @@ 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) $ map (uncurry testCase) [("loading-expected-graph-data", t1), ("loading-input-graph-data", t2), ("comparing-graphs", t3)]--checkBadConformanceTest :: Int -> TestTree-checkBadConformanceTest i =- let t = assertLoadFailure (show i) (loadInputGraph "bad" i)- in testCase (printf "loading-test-%d-negative" i) t+ in testGroup (printf "conformance-%s" testname) $ fmap (uncurry testCase) [("loading-expected-graph-data", t1), ("loading-input-graph-data", t2), ("comparing-graphs", t3)] -- Determines if graphs are equivalent, returning Nothing if so or else a diagnostic message. -- First graph is expected graph, second graph is actual. equivalent :: Rdf a => Either ParseFailure (RDF a) -> Either ParseFailure (RDF a) -> Maybe String-equivalent (Left e) _ = Just $ "Parse failure of the expected graph: " ++ show e-equivalent _ (Left e) = Just $ "Parse failure of the input graph: " ++ show e+equivalent (Left e) _ = Just $ "Parse failure of the expected graph: " <> show e+equivalent _ (Left e) = Just $ "Parse failure of the input graph: " <> show e equivalent (Right gr1) (Right gr2) = checkSize <|> (test $! zip gr1ts gr2ts) where gr1ts = uordered $ triplesOf gr1 gr2ts = uordered $ triplesOf gr2 length1 = length gr1ts length2 = length gr2ts- checkSize = if (length1 == length2) then Nothing else (Just $ "Size different. Expected: " ++ (show length1) ++ ", got: " ++ (show length2))+ checkSize = if (length1 == length2) then Nothing else (Just $ "Size different. Expected: " <> (show length1) <> ", got: " <> (show length2)) test [] = Nothing test ((t1,t2):ts) = maybe (test ts) pure (compareTriple t1 t2) compareTriple t1@(Triple s1 p1 o1) t2@(Triple s2 p2 o2) = if equalNodes s1 s2 && equalNodes p1 p2 && equalNodes o1 o2 then Nothing- else Just ("Expected:\n " ++ show t1 ++ "\nFound:\n " ++ show t2 ++ "\n")+ else Just ("Expected:\n " <> show t1 <> "\nFound:\n " <> show t2 <> "\n") -- I'm not sure it's right to compare blank nodes with generated -- blank nodes. This is because parsing an already generated blank@@ -117,48 +101,29 @@ equalNodes (BNode _) (BNode _) = True equalNodes n1 n2 = n1 == n2 --- Returns a graph for a good ttl test that is intended to pass, and normalizes--- triples into a format so that they can be compared with the expected output triples.-loadInputGraph :: String -> Int -> IO (Either ParseFailure (RDF TList))-loadInputGraph name n = parseFile parserConfig path- where path = fpath name n "ttl"- parserConfig = TurtleParser mtestBaseUri (mkDocUrl testBaseUri name n)- loadInputGraph1 :: String -> String -> IO (Either ParseFailure (RDF TList)) loadInputGraph1 dir fname = parseFile parserConfig path where path = printf "%s/%s.ttl" dir fname :: String parserConfig = TurtleParser mtestBaseUri (mkDocUrl1 testBaseUri fname) -loadExpectedGraph :: String -> Int -> IO (Either ParseFailure (RDF TList))-loadExpectedGraph name n = loadExpectedGraph1 (fpath name n "out")- loadExpectedGraph1 :: String -> IO (Either ParseFailure (RDF TList)) loadExpectedGraph1 fname = parseFile (TurtleParser mtestBaseUri (mkDocUrl1 testBaseUri fname)) fname -assertLoadSuccess, assertLoadFailure :: String -> IO (Either ParseFailure (RDF TList)) -> TU.Assertion+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- g <- exprGr- case g of- Left _ -> return ()- Right _ -> TU.assertFailure $ "Bad test " ++ idStr ++ " loaded successfully."- 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 ()- (Just msg) -> fail $ "Graph " ++ testname ++ " not equivalent to expected:\n" ++ msg--mkDocUrl :: Text -> String -> Int -> Maybe Text-mkDocUrl baseDocUrl fname testNum = Just . fromString $ printf "%s%s-%02d.ttl" baseDocUrl fname testNum+ (Just msg) -> fail $ "Graph " <> testname <> " not equivalent to expected:\n" <> msg mkDocUrl1 :: Text -> String -> Maybe Text mkDocUrl1 baseDocUrl fname = Just . fromString $ printf "%s%s.ttl" baseDocUrl fname
testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs view
@@ -7,9 +7,9 @@ -- todo: QuickCheck tests +import Data.Semigroup ((<>)) -- Testing imports import Test.Tasty-import Test.Tasty.HUnit import Test.Tasty.HUnit as TU -- Import common libraries to facilitate tests@@ -34,13 +34,13 @@ , testCase "NML2" test_parseXmlRDF_NML2 , testCase "NML3" test_parseXmlRDF_NML3 ]- ++- map (uncurry checkGoodOtherTest) otherTestFiles+ <>+ fmap (uncurry checkGoodOtherTest) otherTestFiles otherTestFiles :: [(String, String)] otherTestFiles = [ ("data/xml", "example07") , ("data/xml", "example08")- , ("data/xml", "example09")+ -- , ("data/xml", "example09") , ("data/xml", "example10") , ("data/xml", "example11") , ("data/xml", "example12")@@ -70,8 +70,8 @@ loadInputGraph1 :: String -> String -> IO (Either ParseFailure (RDF TList)) loadInputGraph1 dir fname =- TIO.readFile (printf "%s/%s.rdf" dir fname :: String) >>=- return . parseString (XmlParser Nothing (mkDocUrl1 testBaseUri fname)) >>= return . handleLoad+ (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)) ->@@ -80,7 +80,7 @@ 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) $ map (uncurry testCase) [("loading-expected-graph-data", t1), ("loading-input-graph-data", t2), ("comparing-graphs", t3)]+ 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@@ -90,7 +90,7 @@ case parsed of Right result -> assertBool- ("expected: " ++ show ex ++ "but got: " ++ show result)+ ("expected: " <> show ex <> "but got: " <> show result) (isIsomorphic (result :: RDF TList) (ex :: RDF TList)) Left (ParseFailure err) -> assertFailure err@@ -174,7 +174,7 @@ test_parseXmlRDF_vCardPersonal = testParse "<rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\ \ xmlns:v=\"http://www.w3.org/2006/vcard/ns#\">\- \<v:VCard rdf:about = \"http://example.com/me/corky\" >\+ \<v:VCard rdf:about=\"http://example.com/me/corky\" >\ \<v:fn>Corky Crystal</v:fn>\ \<v:nickname>Corks</v:nickname>\ \<v:tel>\@@ -353,7 +353,7 @@ gr2 <- r2 case equivalent gr1 gr2 of Nothing -> return ()- (Just msg) -> fail $ "Graph " ++ testname ++ " not equivalent to expected:\n" ++ msg+ (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.@@ -372,13 +372,13 @@ compareTriple t1 t2 = if equalNodes s1 s2 && equalNodes p1 p2 && equalNodes o1 o2 then Nothing- else Just ("Expected:\n " ++ show t1 ++ "\nFound:\n " ++ show t2 ++ "\n")+ else Just ("Expected:\n " <> show t1 <> "\nFound:\n " <> show t2 <> "\n") where (s1, p1, o1) = f t1 (s2, p2, o2) = f t2 f t = (subjectOf t, predicateOf t, objectOf t)- -- equalNodes (BNode fs1) (BNodeGen i) = T.reverse fs1 == T.pack ("_:genid" ++ show i)- -- equalNodes (BNode fs1) (BNodeGen i) = fs1 == T.pack ("_:genid" ++ show i)+ -- equalNodes (BNode fs1) (BNodeGen i) = T.reverse fs1 == T.pack ("_:genid" <> show i)+ -- equalNodes (BNode fs1) (BNodeGen i) = fs1 == T.pack ("_:genid" <> show i) -- I'm not sure it's right to compare blank nodes with generated -- blank nodes. This is because parsing an already generated blank@@ -403,20 +403,20 @@ 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 -- g <- exprGr -- case g of -- Left _ -> return ()--- Right _ -> TU.assertFailure $ "Bad test " ++ idStr ++ " loaded successfully."+-- 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 (map normalize (triplesOf gr)) (baseUrl gr) (prefixMappings gr)+ (Right gr) -> Right $ mkRdf (fmap normalize (triplesOf gr)) (baseUrl gr) (prefixMappings gr) normalize :: Triple -> Triple normalize t = let s' = normalizeN $ subjectOf t@@ -424,12 +424,12 @@ o' = normalizeN $ objectOf t in triple s' p' o' normalizeN :: Node -> Node-normalizeN (BNodeGen i) = BNode (T.pack $ "_:genid" ++ show i)+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/" -mkDocUrl1 :: String -> String -> Maybe T.Text-mkDocUrl1 baseDocUrl fname = Just $ T.pack $ printf "%s%s.rdf" baseDocUrl fname+mkDocUrl1 :: String -> String -> String -> Maybe T.Text+mkDocUrl1 baseDocUrl dir fname = Just . T.pack $ printf "%s/%s/%s.rdf" baseDocUrl dir fname
testsuite/tests/W3C/Manifest.hs view
@@ -7,6 +7,7 @@ TestEntry(..) ) where +import Data.Semigroup ((<>)) import Data.RDF.Graph.TList import Data.RDF.Query import Data.RDF.Types@@ -125,18 +126,18 @@ -- | Load the manifest from the given file; -- apply the given namespace as the base IRI of the manifest. loadManifest :: T.Text -> T.Text -> IO Manifest-loadManifest manifestPath baseIRI = do- parseFile testParser (T.unpack manifestPath) >>= return . rdfToManifest . fromEither+loadManifest manifestPath baseIRI =+ (rdfToManifest . fromEither) <$> parseFile testParser (T.unpack manifestPath) 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+ 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+ <> query rdf (Just manifestNode) (Just mfName) Nothing -- descNode = query rdf (Just manifestNode) (Just mfName) Nothing- tpls = map (rdfToTestEntry rdf) $ rdfCollectionToList rdf collectionHead+ 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 @@ -156,7 +157,7 @@ (UNode "http://www.w3.org/ns/rdftest#TestXMLNegativeSyntax") -> mkTestXMLNegativeSyntax ts (UNode "http://www.w3.org/ns/rdftest#TestNTriplesPositiveSyntax") -> mkTestNTriplesPositiveSyntax ts (UNode "http://www.w3.org/ns/rdftest#TestNTriplesNegativeSyntax") -> mkTestNTriplesNegativeSyntax ts- n -> error ("Unknown test case: " ++ show n)+ n -> error ("Unknown test case: " <> show n) mkTestTurtleEval :: Triples -> TestEntry mkTestTurtleEval ts = TestTurtleEval {@@ -273,7 +274,7 @@ manifestSubjectNodes rdf = subjectNodes rdf [mfManifest] subjectNodes :: RDF TList -> [Object] -> [Subject]-subjectNodes rdf = (map subjectOf) . concatMap queryType+subjectNodes rdf = (fmap subjectOf) . concatMap queryType where queryType n = query rdf Nothing (Just rdfType) (Just n) -- | Text of the literal node.
testsuite/tests/W3C/NTripleTest.hs view
@@ -3,6 +3,7 @@ , testsAttoparsec ) where +import Data.Semigroup ((<>)) import Data.Maybe (fromJust) import Test.Tasty import qualified Test.Tasty.HUnit as TU@@ -36,11 +37,10 @@ let act = (UNode . fromJust . fileSchemeToFilePath) act' rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure (RDF TList)) in TU.testCase (T.unpack nm) $ assertIsNotParsed rdf-mfEntryToTest _ x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x+mfEntryToTest _ x = error $ "unknown TestEntry pattern in mfEntryToTest: " <> show x testParserParsec :: NTriplesParserCustom testParserParsec = NTriplesParserCustom Parsec testParserAttoparsec :: NTriplesParserCustom testParserAttoparsec = NTriplesParserCustom Attoparsec-
testsuite/tests/W3C/RdfXmlTest.hs view
@@ -2,8 +2,10 @@ module W3C.RdfXmlTest ( tests+ , mfBaseURIXml ) where +import Data.Semigroup ((<>)) import Data.Maybe (fromJust) import Test.Tasty import qualified Test.Tasty.HUnit as TU@@ -18,29 +20,34 @@ import Text.RDF.RDF4H.NTriplesParser import Data.RDF.Graph.TList -tests :: Manifest -> TestTree-tests = runManifestTests mfEntryToTest+tests :: String -> Manifest -> TestTree+tests = runManifestTests . mfEntryToTest -- Functions to map manifest test entries to unit tests. -- They are defined here to avoid cluttering W3C.Manifest -- with functions that may not be needed to those who -- just want to parse Manifest files. -- TODO: They should probably be moved to W3C.Manifest after all.-mfEntryToTest :: TestEntry -> TestTree-mfEntryToTest (TestXMLEval nm _ _ act' res') =- let act = (UNode . fromJust . fileSchemeToFilePath) act'- res = (UNode . fromJust . fileSchemeToFilePath) res'- parsedRDF = parseFile testParser (nodeURI act) >>= return . fromEither :: IO (RDF TList)- expectedRDF = parseFile NTriplesParser (nodeURI res) >>= return . fromEither :: IO (RDF TList)+mfEntryToTest :: String -> TestEntry -> TestTree+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)+ expectedRDF = (fromEither <$> parseFile NTriplesParser pathExpected) :: IO (RDF TList) in TU.testCase (T.unpack nm) $ assertIsIsomorphic parsedRDF expectedRDF-mfEntryToTest (TestXMLNegativeSyntax nm _ _ act') =- let act = (UNode . fromJust . fileSchemeToFilePath) act'- rdf = parseFile testParser (nodeURI act) :: IO (Either ParseFailure (RDF TList))+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-mfEntryToTest x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x+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)+getFilePath _ _ = error "Unexpected node"+ mfBaseURIXml :: BaseUrl mfBaseURIXml = BaseUrl "http://www.w3.org/2013/RDFXMLTests/" -testParser :: XmlParser-testParser = XmlParser (Just mfBaseURIXml) Nothing+testParser :: String -> XmlParser+testParser dUri = XmlParser (Just mfBaseURIXml) (Just . T.pack $ dUri)
testsuite/tests/W3C/TurtleTest.hs view
@@ -3,11 +3,13 @@ module W3C.TurtleTest ( testsParsec , testsAttoparsec+ , mfBaseURITurtle ) where import Test.Tasty import qualified Test.Tasty.HUnit as TU +import Data.Semigroup ((<>)) import Data.Maybe (fromJust) import qualified Data.Text as T @@ -21,41 +23,47 @@ import Text.RDF.RDF4H.ParserUtils import Data.RDF.Graph.TList -testsParsec :: Manifest -> TestTree-testsParsec = runManifestTests (mfEntryToTest testParserParsec)+testsParsec :: String -> Manifest -> TestTree+testsParsec = runManifestTests . (`mfEntryToTest` testParserParsec) -testsAttoparsec :: Manifest -> TestTree-testsAttoparsec = runManifestTests (mfEntryToTest testParserAttoparsec)+testsAttoparsec :: String -> Manifest -> TestTree+testsAttoparsec = runManifestTests . (`mfEntryToTest` testParserAttoparsec) -mfEntryToTest :: TurtleParserCustom -> TestEntry -> TestTree-mfEntryToTest parser (TestTurtleEval nm _ _ act' res') =- let act = (UNode . fromJust . fileSchemeToFilePath) act'- res = (UNode . fromJust . fileSchemeToFilePath) res'- parsedRDF = parseFile parser (nodeURI act) >>= return . fromEither :: IO (RDF TList)- expectedRDF = parseFile NTriplesParser (nodeURI res) >>= return . fromEither :: IO (RDF TList)+mfEntryToTest :: String -> (String -> TurtleParserCustom) -> TestEntry -> TestTree+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)+ expectedRDF = (fromEither <$> parseFile NTriplesParser pathExpected) :: IO (RDF TList) in TU.testCase (T.unpack nm) $ assertIsIsomorphic parsedRDF expectedRDF-mfEntryToTest parser (TestTurtleNegativeEval nm _ _ act') =- let act = (UNode . fromJust . fileSchemeToFilePath) act'- rdf = parseFile parser (nodeURI act) :: IO (Either ParseFailure (RDF TList))+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-mfEntryToTest parser (TestTurtlePositiveSyntax nm _ _ act') =- let act = (UNode . fromJust . fileSchemeToFilePath) act'- rdf = parseFile parser (nodeURI act) :: IO (Either ParseFailure (RDF TList))+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-mfEntryToTest parser (TestTurtleNegativeSyntax nm _ _ act') =- let act = (UNode . fromJust . fileSchemeToFilePath) act'- rdf = parseFile parser (nodeURI act) :: IO (Either ParseFailure (RDF TList))+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-mfEntryToTest _ x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x+mfEntryToTest _ _ x = error $ "unknown TestEntry pattern in mfEntryToTest: " <> show x +-- [NOTE] Was previously: http://www.w3.org/2013/TurtleTests/ mfBaseURITurtle :: BaseUrl-mfBaseURITurtle = BaseUrl "http://www.w3.org/2013/TurtleTests/"+mfBaseURITurtle = BaseUrl "http://w3c.github.io/rdf-tests/turtle/" -- testParser :: TurtleParser -- testParser = TurtleParser (Just mfBaseURITurtle) Nothing -testParserParsec :: TurtleParserCustom-testParserParsec = TurtleParserCustom (Just mfBaseURITurtle) Nothing Parsec+testParserParsec :: String -> TurtleParserCustom+testParserParsec dUrl = TurtleParserCustom (Just mfBaseURITurtle) (Just . T.pack $ dUrl) Parsec -testParserAttoparsec :: TurtleParserCustom-testParserAttoparsec = TurtleParserCustom (Just mfBaseURITurtle) Nothing Attoparsec+testParserAttoparsec :: String -> TurtleParserCustom+testParserAttoparsec dUrl = TurtleParserCustom (Just mfBaseURITurtle) (Just . T.pack $ dUrl) Attoparsec++getFilePath :: String -> Node -> String+getFilePath dir (UNode iri) = fixFilePath' iri+ where fixFilePath' = (dir <>) . T.unpack . fromJust . T.stripPrefix (unBaseUrl mfBaseURITurtle)+getFilePath _ _ = error "Unexpected node"
testsuite/tests/W3C/W3CAssertions.hs view
@@ -6,6 +6,7 @@ , nodeURI ) where +import Data.Semigroup ((<>)) import qualified Data.Text as T import Data.RDF import qualified Test.HUnit as TU@@ -14,13 +15,13 @@ runManifestTests :: (TestEntry -> TestTree) -> Manifest -> TestTree runManifestTests mfEntryToTest manifest =- testGroup (T.unpack $ description manifest) $ map mfEntryToTest $ entries manifest+ testGroup (T.unpack $ description manifest) $ mfEntryToTest <$> entries manifest assertIsIsomorphic :: IO (RDF TList) -> IO (RDF TList) -> IO () assertIsIsomorphic r1 r2 = do gr1 <- r1 gr2 <- r2- TU.assertBool ("not isomorphic: " ++ show gr1 ++ " compared with " ++ show gr2) (isSame gr1 gr2) -- (isGraphIsomorphic gr1 gr2)+ TU.assertBool ("not isomorphic: " <> show gr1 <> " compared with " <> show gr2) (isSame gr1 gr2) -- (isGraphIsomorphic gr1 gr2) where noBlankNodes g = (all noBlanks . expandTriples) g noBlanks (Triple s p o) = not (blankNode s)@@ -41,12 +42,12 @@ assertIsParsed :: IO (Either ParseFailure (RDF TList)) -> TU.Assertion assertIsParsed r1 = do gr1 <- r1- TU.assertBool ("unable to parse, reason:\n" ++ show gr1) (isParsed gr1)+ TU.assertBool ("unable to parse, reason:\n" <> show gr1) (isParsed gr1) assertIsNotParsed :: IO (Either ParseFailure (RDF TList)) -> TU.Assertion assertIsNotParsed r1 = do gr1 <- r1- TU.assertBool ("parsed unexpectantly:\n" ++ show gr1) (not (isParsed gr1))+ TU.assertBool ("parsed unexpectantly:\n" <> show gr1) (not (isParsed gr1)) isParsed :: Either a b -> Bool isParsed (Left _) = False@@ -54,4 +55,4 @@ nodeURI :: Node -> String nodeURI (UNode u) = T.unpack u-nodeURI node = error $ "W3CAssertions: unexpected node in `nodeURI`: " ++ show node+nodeURI node = error $ "W3CAssertions: unexpected node in `nodeURI`: " <> show node