diff --git a/bench/MainCriterion.hs b/bench/MainCriterion.hs --- a/bench/MainCriterion.hs +++ b/bench/MainCriterion.hs @@ -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 diff --git a/examples/ESWC.hs b/examples/ESWC.hs --- a/examples/ESWC.hs +++ b/examples/ESWC.hs @@ -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 diff --git a/examples/ParseURLs.hs b/examples/ParseURLs.hs --- a/examples/ParseURLs.hs +++ b/examples/ParseURLs.hs @@ -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 () diff --git a/rdf4h.cabal b/rdf4h.cabal --- a/rdf4h.cabal +++ b/rdf4h.cabal @@ -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 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 diff --git a/src/Data/RDF.hs b/src/Data/RDF.hs --- a/src/Data/RDF.hs +++ b/src/Data/RDF.hs @@ -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 diff --git a/src/Data/RDF/Graph/AdjHashMap.hs b/src/Data/RDF/Graph/AdjHashMap.hs --- a/src/Data/RDF/Graph/AdjHashMap.hs +++ b/src/Data/RDF/Graph/AdjHashMap.hs @@ -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 diff --git a/src/Data/RDF/Graph/AlgebraicGraph.hs b/src/Data/RDF/Graph/AlgebraicGraph.hs new file mode 100644 --- /dev/null +++ b/src/Data/RDF/Graph/AlgebraicGraph.hs @@ -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) diff --git a/src/Data/RDF/Graph/TList.hs b/src/Data/RDF/Graph/TList.hs --- a/src/Data/RDF/Graph/TList.hs +++ b/src/Data/RDF/Graph/TList.hs @@ -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 diff --git a/src/Data/RDF/IRI.hs b/src/Data/RDF/IRI.hs --- a/src/Data/RDF/IRI.hs +++ b/src/Data/RDF/IRI.hs @@ -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 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') diff --git a/src/Data/RDF/Namespace.hs b/src/Data/RDF/Namespace.hs --- a/src/Data/RDF/Namespace.hs +++ b/src/Data/RDF/Namespace.hs @@ -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 diff --git a/src/Data/RDF/Query.hs b/src/Data/RDF/Query.hs --- a/src/Data/RDF/Query.hs +++ b/src/Data/RDF/Query.hs @@ -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) diff --git a/src/Data/RDF/Types.hs b/src/Data/RDF/Types.hs --- a/src/Data/RDF/Types.hs +++ b/src/Data/RDF/Types.hs @@ -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' diff --git a/src/Rdf4hParseMain.hs b/src/Rdf4hParseMain.hs --- a/src/Rdf4hParseMain.hs +++ b/src/Rdf4hParseMain.hs @@ -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)) diff --git a/src/Text/RDF/RDF4H/NTriplesParser.hs b/src/Text/RDF/RDF4H/NTriplesParser.hs --- a/src/Text/RDF/RDF4H/NTriplesParser.hs +++ b/src/Text/RDF/RDF4H/NTriplesParser.hs @@ -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) diff --git a/src/Text/RDF/RDF4H/ParserUtils.hs b/src/Text/RDF/RDF4H/ParserUtils.hs --- a/src/Text/RDF/RDF4H/ParserUtils.hs +++ b/src/Text/RDF/RDF4H/ParserUtils.hs @@ -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" diff --git a/src/Text/RDF/RDF4H/TurtleParser.hs b/src/Text/RDF/RDF4H/TurtleParser.hs --- a/src/Text/RDF/RDF4H/TurtleParser.hs +++ b/src/Text/RDF/RDF4H/TurtleParser.hs @@ -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)] diff --git a/src/Text/RDF/RDF4H/TurtleSerializer.hs b/src/Text/RDF/RDF4H/TurtleSerializer.hs --- a/src/Text/RDF/RDF4H/TurtleSerializer.hs +++ b/src/Text/RDF/RDF4H/TurtleSerializer.hs @@ -1,4 +1,4 @@ --- |An RDF serializer for Turtle +-- |An RDF serializer for 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 = diff --git a/src/Text/RDF/RDF4H/XmlParser.hs b/src/Text/RDF/RDF4H/XmlParser.hs --- a/src/Text/RDF/RDF4H/XmlParser.hs +++ b/src/Text/RDF/RDF4H/XmlParser.hs @@ -1,486 +1,653 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} - --- |An parser for the RDF/XML format --- . - -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 @\@ 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: --- --- --- foo --- --- --- is equivalent to: --- _:a "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 +-- . + +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 }) diff --git a/src/Text/RDF/RDF4H/XmlParser/Identifiers.hs b/src/Text/RDF/RDF4H/XmlParser/Identifiers.hs new file mode 100644 --- /dev/null +++ b/src/Text/RDF/RDF4H/XmlParser/Identifiers.hs @@ -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') diff --git a/src/Text/RDF/RDF4H/XmlParser/Xeno.hs b/src/Text/RDF/RDF4H/XmlParser/Xeno.hs new file mode 100644 --- /dev/null +++ b/src/Text/RDF/RDF4H/XmlParser/Xeno.hs @@ -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 ("" <> dropBomUtf8 bs <> "") of + Left e -> Left ("Malformed XML: " ++ show e) + Right n -> fromXenoNode n >>= \case + Xmlbf.Element "x" _ cs -> Right cs + _ -> Left "Unknown result from fromXenoNode. Please report this as a bug." + +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- Miscellaneous + +decodeUtf8 :: B.ByteString -> Either String T.Text +{-# INLINE decodeUtf8 #-} +decodeUtf8 bs = Bif.first show (T.decodeUtf8' bs) + +decodeUtf8Lazy :: B.ByteString -> Either String TL.Text +{-# INLINE decodeUtf8Lazy #-} +decodeUtf8Lazy bs = fmap TL.fromStrict (decodeUtf8 bs) + +unescapeXmlUtf8 :: B.ByteString -> Either String T.Text +{-# INLINE unescapeXmlUtf8 #-} +unescapeXmlUtf8 bs = fmap TL.toStrict (unescapeXmlUtf8Lazy bs) + +unescapeXmlUtf8Lazy :: B.ByteString -> Either String TL.Text +{-# INLINE unescapeXmlUtf8Lazy #-} +unescapeXmlUtf8Lazy bs = do + t <- decodeUtf8 bs + pure (TB.toLazyText (HTMLEntities.Decoder.htmlEncodedText t)) + +dropBomUtf8 :: B.ByteString -> B.ByteString +{-# INLINE dropBomUtf8 #-} +dropBomUtf8 bs | B.isPrefixOf "\xEF\xBB\xBF" bs = B.drop 3 bs + | otherwise = bs diff --git a/src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs b/src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs new file mode 100644 --- /dev/null +++ b/src/Text/RDF/RDF4H/XmlParser/Xmlbf.hs @@ -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) diff --git a/testsuite/tests/Data/RDF/IRITests.hs b/testsuite/tests/Data/RDF/IRITests.hs --- a/testsuite/tests/Data/RDF/IRITests.hs +++ b/testsuite/tests/Data/RDF/IRITests.hs @@ -1,6 +1,3 @@ ---{-# LANGUAGE DeriveGeneric #-} ---{-# LANGUAGE TypeFamilies #-} ---{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Data.RDF.IRITests diff --git a/testsuite/tests/Data/RDF/PropertyTests.hs b/testsuite/tests/Data/RDF/PropertyTests.hs --- a/testsuite/tests/Data/RDF/PropertyTests.hs +++ b/testsuite/tests/Data/RDF/PropertyTests.hs @@ -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 -- diff --git a/testsuite/tests/Test.hs b/testsuite/tests/Test.hs --- a/testsuite/tests/Test.hs +++ b/testsuite/tests/Test.hs @@ -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 ] ] ) diff --git a/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs b/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs --- a/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs +++ b/testsuite/tests/Text/RDF/RDF4H/TurtleParser_ConformanceTest.hs @@ -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 diff --git a/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs b/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs --- a/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs +++ b/testsuite/tests/Text/RDF/RDF4H/XmlParser_Test.hs @@ -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 "\ - \\ + \\ \Corky Crystal\ \Corks\ \\ @@ -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 diff --git a/testsuite/tests/W3C/Manifest.hs b/testsuite/tests/W3C/Manifest.hs --- a/testsuite/tests/W3C/Manifest.hs +++ b/testsuite/tests/W3C/Manifest.hs @@ -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. diff --git a/testsuite/tests/W3C/NTripleTest.hs b/testsuite/tests/W3C/NTripleTest.hs --- a/testsuite/tests/W3C/NTripleTest.hs +++ b/testsuite/tests/W3C/NTripleTest.hs @@ -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 - diff --git a/testsuite/tests/W3C/RdfXmlTest.hs b/testsuite/tests/W3C/RdfXmlTest.hs --- a/testsuite/tests/W3C/RdfXmlTest.hs +++ b/testsuite/tests/W3C/RdfXmlTest.hs @@ -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) diff --git a/testsuite/tests/W3C/TurtleTest.hs b/testsuite/tests/W3C/TurtleTest.hs --- a/testsuite/tests/W3C/TurtleTest.hs +++ b/testsuite/tests/W3C/TurtleTest.hs @@ -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" diff --git a/testsuite/tests/W3C/W3CAssertions.hs b/testsuite/tests/W3C/W3CAssertions.hs --- a/testsuite/tests/W3C/W3CAssertions.hs +++ b/testsuite/tests/W3C/W3CAssertions.hs @@ -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