diff --git a/LICENSE.txt b/LICENSE.txt --- a/LICENSE.txt +++ b/LICENSE.txt @@ -1,28 +1,32 @@ Copyright 2007-2012 Calvin Smith. -Copyright 2012-2014 Rob Stewart +Copyright 2012-2015 Rob Stewart . All rights reserved. Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. +modification, are permitted provided that the following conditions are +met: -THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alan Zimmerman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/bench/MainCriterion.hs b/bench/MainCriterion.hs --- a/bench/MainCriterion.hs +++ b/bench/MainCriterion.hs @@ -5,7 +5,7 @@ import Criterion import Criterion.Main import Data.RDF -import qualified Data.Text.Lazy as T +import qualified Data.Text as T -- The `bills.102.rdf` XML file is needed to run this benchmark suite -- diff --git a/rdf4h.cabal b/rdf4h.cabal --- a/rdf4h.cabal +++ b/rdf4h.cabal @@ -1,5 +1,5 @@ name: rdf4h -version: 1.3.3 +version: 1.3.4 synopsis: A library for RDF processing in Haskell description: 'RDF for Haskell' is a library for working with RDF in Haskell. @@ -109,6 +109,8 @@ , containers , text >= 1.2.1.0 , knob + , directory + , safe if impl(ghc < 7.6) build-depends: ghc-prim 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 @@ -14,7 +14,7 @@ standard_ns_mappings, ns_mappings ) where -import qualified Data.Text.Lazy as T +import qualified Data.Text as T import Data.RDF.Types import qualified Data.Map as Map 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,7 +20,7 @@ import Data.List import Data.RDF.Types import qualified Data.RDF.Namespace as NS (toPMList, uriOf, rdf) -import qualified Data.Text.Lazy as T +import qualified Data.Text as T import Data.Maybe (catMaybes) 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 @@ -9,13 +9,13 @@ -- * Constructor functions plainL,plainLL,typedL, - unode,bnode,lnode,triple, + unode,bnode,lnode,triple,unodeValidate, -- * Node query function isUNode,isLNode,isBNode, -- * Miscellaneous - resolveQName, absolutizeUrl, isAbsoluteUri, mkAbsoluteUrl, + resolveQName, absolutizeUrl, isAbsoluteUri, mkAbsoluteUrl,fileSchemeToFilePath, -- * RDF Type RDF(baseUrl,prefixMappings,addPrefixMappings,empty,mkRdf,triplesOf,uniqTriplesOf,select,query), @@ -36,7 +36,7 @@ ) where import Prelude hiding (pred) -import qualified Data.Text.Lazy as T +import qualified Data.Text as T import System.IO import Text.Printf import Data.Binary @@ -45,10 +45,9 @@ import Data.Hashable(Hashable) import qualified Data.List as List import qualified Data.Map as Map -import qualified Network.URI as Network (isURI) +import qualified Network.URI as Network (isURI,uriPath,parseURI) import Control.DeepSeq (NFData,rnf) -import GHC.Generics () - +import Text.Parsec ------------------- -- LValue and constructor functions @@ -138,11 +137,76 @@ -- |An alias for 'Node', defined for convenience and readability purposes. type Object = Node --- |Return a URIRef node for the given bytetring URI. +-- |Return a URIRef node for the given URI. {-# INLINE unode #-} unode :: T.Text -> Node unode = UNode +-- For background on 'unodeValidate', see: +-- http://stackoverflow.com/questions/33250184/unescaping-unicode-literals-found-in-haskell-strings + +-- |Validate a URI and return it in a @Just UNode@ if it is +-- valid, otherwise @Nothing@ is returned. Performs the following: +-- +-- 1. unescape unicode RDF literals +-- 2. checks validity of this unescaped URI using 'isURI' from 'Network.URI' +-- 3. if the unescaped URI is valid then 'Node' constructed with 'UNode' +unodeValidate :: T.Text -> Maybe Node +unodeValidate t = if Network.isURI uri + then Just (UNode (T.pack uri)) + else Nothing + where + Right uri = parse unicodeEscParser "" (T.unpack t) + unicodeEscParser :: Stream s m Char => ParsecT s u m String + unicodeEscParser = do + ss <- many ( + try (do { _ <- char '\\' + ; _ <- char 'u' + ; pos1 <- digit + ; pos2 <- digit + ; pos3 <- digit + ; pos4 <- digit + ; pos5 <- digit + ; pos6 <- digit + ; pos7 <- digit + ; pos8 <- digit + ; let str = ['\\','x',pos1,pos2,pos3,pos4,pos5,pos6,pos7,pos8] + ; return (read ("\"" ++ str ++ "\"") :: String)}) + <|> + try (do { _ <- char '\\' + ; _ <- char 'U' + ; pos1 <- digit + ; pos2 <- digit + ; pos3 <- digit + ; pos4 <- digit + ; pos5 <- digit + ; pos6 <- digit + ; pos7 <- digit + ; pos8 <- digit + ; let str = ['\\','x',pos1,pos2,pos3,pos4,pos5,pos6,pos7,pos8] + ; return (read ("\"" ++ str ++ "\"") :: String)}) + <|> + try (do { _ <- char '\\' + ; _ <- char 'u' + ; pos1 <- digit + ; pos2 <- digit + ; pos3 <- digit + ; pos4 <- digit + ; let str = ['\\','x',pos1,pos2,pos3,pos4] + ; return (read ("\"" ++ str ++ "\"") :: String)}) + <|> + try (do { _ <- char '\\' + ; _ <- char 'U' + ; pos1 <- digit + ; pos2 <- digit + ; pos3 <- digit + ; pos4 <- digit + ; let str = ['\\','x',pos1,pos2,pos3,pos4] + ; return (read ("\"" ++ str ++ "\"") :: String)}) + <|> + (anyChar >>= \c -> return [c])) + return (concat ss :: String) + -- |Return a blank node using the given string identifier. {-# INLINE bnode #-} bnode :: T.Text -> Node @@ -635,3 +699,12 @@ '.' -> f (s `T.snoc` '0') _ -> f s where f s' = T.pack $ show (read $ T.unpack s' :: Double) + +-- | Removes "file://" schema from URIs in 'UNode' nodes +fileSchemeToFilePath :: Node -> Maybe T.Text +fileSchemeToFilePath (UNode fileScheme) = + if T.pack "file://" `T.isPrefixOf` fileScheme + then fmap (T.pack . Network.uriPath) (Network.parseURI (T.unpack fileScheme)) + else Nothing +fileSchemeToFilePath _ = Nothing + diff --git a/src/Rdf4hParseMain.hs b/src/Rdf4hParseMain.hs --- a/src/Rdf4hParseMain.hs +++ b/src/Rdf4hParseMain.hs @@ -12,8 +12,8 @@ import Text.RDF.RDF4H.TurtleParser import Text.RDF.RDF4H.TurtleSerializer -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as TIO +import qualified Data.Text as T +import qualified Data.Text.IO as TIO import System.Environment import System.IO diff --git a/src/Text/RDF/RDF4H/Interact.hs b/src/Text/RDF/RDF4H/Interact.hs --- a/src/Text/RDF/RDF4H/Interact.hs +++ b/src/Text/RDF/RDF4H/Interact.hs @@ -14,7 +14,7 @@ module Text.RDF.RDF4H.Interact where -import qualified Data.Text.Lazy as T +import qualified Data.Text as T import Data.RDF.Types hiding (baseUrl) import Data.RDF.TriplesGraph() 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 @@ -11,9 +11,9 @@ import Data.Char(isLetter, isDigit, isLower) import qualified Data.Map as Map import Text.Parsec -import Text.Parsec.Text.Lazy -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as TIO +import Text.Parsec.Text +import qualified Data.Text as T +import qualified Data.Text.IO as TIO import Control.Monad (liftM,void) -- |NTriplesParser is an 'RdfParser' implementation for parsing RDF in the diff --git a/src/Text/RDF/RDF4H/NTriplesSerializer.hs b/src/Text/RDF/RDF4H/NTriplesSerializer.hs --- a/src/Text/RDF/RDF4H/NTriplesSerializer.hs +++ b/src/Text/RDF/RDF4H/NTriplesSerializer.hs @@ -8,8 +8,8 @@ import Control.Monad (void) import Data.RDF.Types import Data.RDF.Query (expandTriples) -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as T +import qualified Data.Text as T +import qualified Data.Text.IO as T import System.IO data NTriplesSerializer = NTriplesSerializer 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 @@ -7,9 +7,9 @@ import Network.URI import Network.HTTP import Data.Char (intToDigit) -import Data.Text.Lazy.Encoding (decodeUtf8) -import qualified Data.ByteString.Lazy.Char8 as B -import qualified Data.Text.Lazy as T +import Data.Text.Encoding (decodeUtf8) +import qualified Data.ByteString.Char8 as B +import qualified Data.Text as T -- import qualified Data.Map as Map import Data.Maybe (fromMaybe) 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,14 +8,15 @@ where import Data.Char (toLower,toUpper) +import Data.Maybe import Data.RDF.Types import Data.RDF.Namespace import Text.RDF.RDF4H.ParserUtils import Text.Parsec -import Text.Parsec.Text.Lazy +import Text.Parsec.Text import qualified Data.Map as Map -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as TIO +import qualified Data.Text as T +import qualified Data.Text.IO as TIO import Data.Sequence(Seq, (|>)) import qualified Data.Sequence as Seq import qualified Data.Foldable as F @@ -189,7 +190,7 @@ (bUrl, _, _, pms, _, _, _, _) <- getState case resolveQName bUrl pre pms of Just n -> return $ n `T.append` name - Nothing -> error ("Cannot resolve QName prefix: " ++ T.unpack pre) + Nothing -> unexpected ("Cannot resolve QName prefix: " ++ T.unpack pre) -- grammar rule: [10] subject t_subject :: GenParser ParseState () @@ -199,21 +200,21 @@ nodeId <|> between (char '[') (char ']') poList where - iri = liftM UNode (try t_iri "subject resource") >>= pushSubj + iri = liftM unode (try t_iri "subject resource") >>= pushSubj nodeId = liftM BNode (try t_nodeID "subject nodeID") >>= pushSubj simpleBNode = try (string "[]") >> nextIdCounter >>= pushSubj . BNodeGen poList = void (nextIdCounter >>= pushSubj . BNodeGen >> many t_ws >> t_predicateObjectList >> many t_ws) - + -- verb objectList (';' (verb objectList)?)* -- -- verb ws+ objectList ( ws* ';' ws* verb ws+ objectList )* (ws* ';')? -- grammar rule: [7] predicateObjectlist t_predicateObjectList :: GenParser ParseState () t_predicateObjectList = - do sepEndBy1 (try (t_verb >> many1 t_ws >> t_objectList >> popPred)) (try (many t_ws >> char ';' >> many t_ws)) + do sepEndBy1 (try (t_verb >> many1 t_ws >> t_objectList >> popPred)) (try (many t_ws >> char ';' >> optional (char ';') >> many t_ws)) return () -- grammar rule: [8] objectlist @@ -293,8 +294,8 @@ t_literal :: GenParser ParseState Node t_literal = try str_literal <|> - liftM (`mkLNode` xsdIntUri) (try t_integer) <|> liftM (`mkLNode` xsdDoubleUri) (try t_double) <|> + liftM (`mkLNode` xsdIntUri) (try t_integer) <|> liftM (`mkLNode` xsdDecimalUri) (try t_decimal) <|> liftM (`mkLNode` xsdBooleanUri) t_boolean where @@ -416,7 +417,9 @@ do frag <- liftM (T.pack . concat) (many t_ucharacter) bUrl <- currBaseUrl dUrl <- currDocUrl - return $ absolutizeUrl bUrl dUrl frag + case unodeValidate (absolutizeUrl bUrl dUrl frag) of + Nothing -> unexpected ("Invalid URI in Turtle parser: " ++ show (absolutizeUrl bUrl dUrl frag)) + Just (UNode t) -> return t -- We make this String rather than T.Text because we want -- t_relativeURI (the only place it's used) to have chars so that @@ -614,9 +617,9 @@ addTripleForObject obj = do (bUrl, dUrl, i, pms, ss, ps, cs, ts) <- getState when (null ss) $ - error $ "No Subject with which to create triple for: " ++ show obj + unexpected $ "No Subject with which to create triple for: " ++ show obj when (null ps) $ - error $ "No Predicate with which to create triple for: " ++ show obj + unexpected $ "No Predicate with which to create triple for: " ++ show obj setState (bUrl, dUrl, i, pms, ss, ps, cs, ts |> Triple (head ss) (head ps) obj) -- |Parse the document at the given location URL as a Turtle document, using an optional @BaseUrl@ 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 @@ -10,8 +10,8 @@ import Data.RDF.Types import Data.RDF.Query import Data.RDF.Namespace hiding (rdf) -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as T +import qualified Data.Text as T +import qualified Data.Text.IO as T import Data.Map(Map) import qualified Data.Map as Map import Data.List 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,6 +1,6 @@ -{-# Language Arrows,OverloadedStrings #-} +{-# Language Arrows,OverloadedStrings,DoAndIfThenElse #-} --- |An parser for the RDF/XML format +-- |An parser for the RDF/XML format -- . module Text.RDF.RDF4H.XmlParser( @@ -9,21 +9,24 @@ import Control.Arrow (Arrow,(>>>),(<<<),(&&&),(***),arr,returnA) import Control.Arrow.ArrowState (ArrowState,nextState) +import Control.Exception 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.Types (RDF,RdfParser(..),Node(BNodeGen),BaseUrl(..),Triple(..),Triples,Subject,Predicate,Object,PrefixMappings(..),ParseFailure(ParseFailure),mkRdf,lnode,plainL,plainLL,typedL,unode,bnode) -import qualified Data.Text.Lazy as T (Text,pack,unpack) -import qualified Data.Text.Lazy.IO as TIO -import Text.XML.HXT.Core (ArrowXml,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) - +import Data.RDF.Types (RDF,RdfParser(..),Node(BNodeGen),BaseUrl(..),Triple(..),Triples,Subject,Predicate,Object,PrefixMappings(..),ParseFailure(ParseFailure),mkRdf,lnode,plainL,plainLL,typedL,unode,bnode,unodeValidate) +import qualified Data.Text as T (Text,pack,unpack) +import qualified Data.Text.IO as TIO +import Text.XML.HXT.Core (ArrowXml,ArrowIf,ArrowChoice,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,fatal,canonicalizeAllNodes) + -- TODO: write QuickCheck tests for XmlParser instance for RdfParser. data XmlParser = XmlParser (Maybe BaseUrl) (Maybe T.Text) -- |'XmlParser' is an instance of 'RdfParser'. instance RdfParser XmlParser where - parseString (XmlParser bUrl dUrl) = parseXmlRDF bUrl dUrl + parseString (XmlParser bUrl dUrl) = parseXmlRDF bUrl dUrl parseFile (XmlParser bUrl dUrl) = parseFile' bUrl dUrl parseURL (XmlParser bUrl dUrl) = parseURL' bUrl dUrl @@ -40,6 +43,10 @@ } 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. @@ -54,19 +61,19 @@ -- -- 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 +-- 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@ +-- @http:\/\/example.org\/@ and a relative URI of @\@ were encountered (with no preceding @\@base@ -- directive), then the relative URI would expand to @http:\/\/example.org\/b@. -- -- The document URL is for the purpose of resolving references to 'this document' within the document, -- and may be different than the actual location URL from which the document is retrieved. Any reference --- to @\<>@ within the document is expanded to the value given here. Additionally, if no @BaseUrl@ is +-- 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. --p -- Returns either a @ParseFailure@ or a new RDF containing the parsed triples. -parseURL' :: forall rdf. (RDF rdf) => +parseURL' :: forall rdf. (RDF rdf) => Maybe BaseUrl -- ^ The optional base URI of the document. -> Maybe T.Text -- ^ The document URI (i.e., the URI of the document itself); if Nothing, use location URI. -> String -- ^ The location URI from which to retrieve the XML document. @@ -104,7 +111,8 @@ -- |Arrow that translates HXT XmlTree to an RDF representation getRDF :: forall rdf a. (RDF rdf, ArrowXml a, ArrowState GParseState a) => a XmlTree rdf getRDF = proc xml -> do - rdf <- hasName "rdf:RDF" <<< isElem <<< getChildren -< xml +-- 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) @@ -125,7 +133,7 @@ parseDescription = updateState >>> (arr2A parsePredicatesFromAttr <+> (second (getChildren >>> isElem) >>> parsePredicatesFromChildren) - <+> (second (neg (hasName "rdf:Description")) >>> arr2A readTypeTriple)) + <+> (second (neg (hasName "rdf:Description") >>> neg (hasName "Description")) >>> arr2A readTypeTriple)) >>. replaceLiElems [] (1 :: Int) where readTypeTriple :: forall a. (ArrowXml a, ArrowState GParseState a) => LParseState -> a XmlTree Triple readTypeTriple state = getName >>> arr (Triple (stateSubject state) rdfType . unode . T.pack) @@ -144,7 +152,7 @@ -- |Read the attributes of an rdf:Description element. These correspond to the Predicate Object pairs of the Triple parsePredicatesFromAttr :: forall a. (ArrowXml a, ArrowState GParseState a) => LParseState -> a XmlTree Triple parsePredicatesFromAttr state = getAttrl - >>> (getName >>> neg isMetaAttr >>> mkUNode) &&& (getChildren >>> getText >>> arr (lnode . plainL . T.pack)) + >>> (getName >>> neg isMetaAttr >>> mkUNode) &&& (getChildren >>> getText >>> arr (mkLiteralNode state)) >>> arr (attachSubject (stateSubject state)) -- | Arrow to determine if special processing is required for an attribute @@ -166,6 +174,7 @@ , second (hasAttrValue "rdf:parseType" (== "Collection")) :-> (listA (defaultA >>> arr id &&& mkBlankNode) >>> mkCollectionTriples >>> unlistA) , second (hasAttr "rdf:datatype") :-> arr2A getTypedTriple , second (hasAttr "rdf:resource") :-> arr2A getResourceTriple +-- , second (hasAttr "rdf:nodeID") >>> hasAttr "rdf:ID" :-> ERROR. , second (hasAttr "rdf:nodeID") :-> arr2A getNodeIdTriple , second (hasAttr "rdf:ID") :-> (arr2A mkRelativeNode &&& defaultA >>> arr2A reifyTriple >>> unlistA) , second hasPredicateAttr :-> (defaultA <+> (mkBlankNode &&& arr id >>> arr2A parsePredicateAttr)) @@ -270,8 +279,10 @@ where baseUrl = constA (case stateBaseUrl state of BaseUrl b -> T.unpack b) -- |Make a UNode from an absolute string -mkUNode :: forall a. (Arrow a) => a String Node -mkUNode = arr (unode . T.pack) +mkUNode :: forall a. (Arrow a, ArrowIf a) => a String Node +mkUNode = choiceA [ (arr (isJust . unodeValidate . T.pack)) :-> (arr (fromJust . unodeValidate . 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, ArrowState GParseState a) => LParseState -> a XmlTree Node @@ -292,4 +303,3 @@ mkBlankNode :: forall a b. (ArrowState GParseState a) => a b Node mkBlankNode = nextState (\gState -> gState { stateGenId = stateGenId gState + 1 }) >>> arr (BNodeGen . stateGenId) - 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,7 +3,10 @@ import Test.Framework.Providers.API import Test.Framework.Providers.HUnit import qualified Test.HUnit as TU -import qualified Data.Text.Lazy as T +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Network.URI (parseURI,uriPath) +import System.Directory (getCurrentDirectory) import W3C.Manifest @@ -13,6 +16,7 @@ import Text.RDF.RDF4H.NTriplesParser import Data.RDF.TriplesGraph +suiteFilesDir :: T.Text suiteFilesDir = "data/w3c/turtle/TurtleTests/" mfPath = T.concat [suiteFilesDir, "manifest.ttl"] @@ -23,26 +27,34 @@ allTurtleTests :: IO Test allTurtleTests = do - m <- loadManifest mfPath suiteFilesDir + dir <- getCurrentDirectory + let fileSchemeURI = T.pack ("file://" ++ dir ++ "/" ++ T.unpack suiteFilesDir) + m <- loadManifest mfPath fileSchemeURI return $ testGroup (T.unpack $ description m) $ map (buildTest . mfEntryToTest) $ entries m + -- 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 -> IO Test -mfEntryToTest (TestTurtleEval nm _ _ act res) = do +mfEntryToTest (TestTurtleEval nm _ _ act' res') = do + let act = (UNode . fromJust . fileSchemeToFilePath) act' + let res = (UNode . fromJust . fileSchemeToFilePath) res' parsedRDF <- parseFile testParser (nodeURI act) >>= return . fromEither :: IO TriplesGraph expectedRDF <- parseFile NTriplesParser (nodeURI res) >>= return . fromEither :: IO TriplesGraph return $ testCase (T.unpack nm) $ TU.assert $ isIsomorphic parsedRDF expectedRDF -mfEntryToTest (TestTurtleNegativeEval nm _ _ act) = do +mfEntryToTest (TestTurtleNegativeEval nm _ _ act') = do + let act = (UNode . fromJust . fileSchemeToFilePath) act' rdf <- parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesGraph) return $ testCase (T.unpack nm) $ TU.assert $ isNotParsed rdf -mfEntryToTest (TestTurtlePositiveSyntax nm _ _ act) = do +mfEntryToTest (TestTurtlePositiveSyntax nm _ _ act') = do + let act = (UNode . fromJust . fileSchemeToFilePath) act' rdf <- parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesGraph) return $ testCase (T.unpack nm) $ TU.assert $ isParsed rdf -mfEntryToTest (TestTurtleNegativeSyntax nm _ _ act) = do +mfEntryToTest (TestTurtleNegativeSyntax nm _ _ act') = do + let act = (UNode . fromJust . fileSchemeToFilePath) act' rdf <- parseFile testParser (nodeURI act) :: IO (Either ParseFailure TriplesGraph) return $ testCase (T.unpack nm) $ TU.assert $ isNotParsed rdf mfEntryToTest x = error $ "unknown TestEntry pattern in mfEntryToTest: " ++ show x