diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,27 @@ +Copyright (c) Calvin Smith + +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. + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/rdf4h.cabal b/rdf4h.cabal new file mode 100644 --- /dev/null +++ b/rdf4h.cabal @@ -0,0 +1,112 @@ +name: rdf4h +version: 0.9.1 +synopsis: A library for RDF processing in Haskell +description: + 'RDF for Haskell' is a library for working with RDF in Haskell. + At present it includes parsers and serializers for RDF in the N-Triples + and Turtle, and parsing support for RDF/XML. It provides abilities such as querying + for triples containing a particular subject, predicate, or object, or + selecting triples that satisfy an arbitrary predicate function. + +author: Calvin Smith +copyright: (c) Calvin Smith +maintainer: Rob Stewart +homepage: https://github.com/robstewart57/rdf4h +bug-reports: https://github.com/robstewart57/rdf4h/issues +license: BSD3 +license-file: LICENSE.txt +cabal-version: >= 1.8 +build-type: Simple +category: RDF +stability: Experimental +tested-with: GHC==7.4.1 +extra-tmp-files: test + +flag small_base + description: Choose the new smaller, split-up base package. + default: False + +flag tests + description: Build the tests + default: False + +flag hpc + description: Use HPC for tests + default: True + +library + exposed-modules: Data.RDF + , Data.RDF.Namespace + , Data.RDF.MGraph + , Data.RDF.TriplesGraph + , Text.RDF.RDF4H.NTriplesParser + , Text.RDF.RDF4H.NTriplesSerializer + , Text.RDF.RDF4H.TurtleParser + , Text.RDF.RDF4H.TurtleSerializer + , Text.RDF.RDF4H.XmlParser + if flag(small_base) + build-depends: base >= 3, bytestring, directory, containers + else + build-depends: base < 3 + build-depends: parsec >= 3 && < 3.2 + , network >= 2.2.0.0 && < 2.4 + , HTTP >= 4000.0.0 && < 4000.3 + , hxt >= 9.0.0 && < 9.2 + , MissingH >= 1.0.0 && < 1.2 + other-modules: Data.RDF.Utils + , Text.RDF.RDF4H.ParserUtils + , Text.RDF.RDF4H.Interact + hs-source-dirs: src + extensions: BangPatterns RankNTypes MultiParamTypeClasses Arrows FlexibleContexts + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures -funbox-strict-fields -fno-warn-unused-do-bind + + +executable rdf4h + main-is: Rdf4hParseMain.hs + if flag(small_base) + build-depends: base >= 3, bytestring + else + build-depends: base >= 4 && < 6 + build-depends: parsec >= 3 + , network >= 2.2.0.0 && < 2.4 + , HTTP >= 4000.0.0 && < 4000.3 + , hxt >= 9.0.0 && < 9.2 + , MissingH >= 1.0.0 && < 1.2 + , containers + hs-source-dirs: src + extensions: BangPatterns RankNTypes ScopedTypeVariables MultiParamTypeClasses + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures -funbox-strict-fields -fno-warn-unused-do-bind + + +test-suite test-rdf4h + type: exitcode-stdio-1.0 + main-is: Test.hs + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures -funbox-strict-fields -fno-warn-unused-do-bind + extensions: RankNTypes MultiParamTypeClasses Arrows FlexibleContexts + build-depends: base >= 4 && < 6 + , parsec >= 3 + , test-framework >= 0.2.3 && < 0.7 + , test-framework-quickcheck2 >= 0.2.12.2 + , test-framework-hunit >= 0.2.7 + , HTTP >= 4000.0.0 && < 4000.3 + , network >= 2.2.0.0 && < 2.4 + , QuickCheck >= 1.2.0.0 && < 2.5 + , HUnit >= 1.2.2.1 && < 1.3 + , MissingH >= 1.0.0 && < 1.2 + , bytestring + , hxt + , containers + other-modules: Data.RDF + , Data.RDF.Namespace + , Data.RDF.MGraph + , Data.RDF.TriplesGraph + , Text.RDF.RDF4H.NTriplesParser + , Text.RDF.RDF4H.NTriplesSerializer + , Text.RDF.RDF4H.TurtleParser + , Text.RDF.RDF4H.TurtleSerializer + , Text.RDF.RDF4H.XmlParser + hs-source-dirs: src, testsuite/tests + +source-repository head + type: git + location: git://github.com/robstewart57/rdf4h.git diff --git a/src/Data/RDF.hs b/src/Data/RDF.hs new file mode 100644 --- /dev/null +++ b/src/Data/RDF.hs @@ -0,0 +1,546 @@ +-- |The Core module provides the fundamental types, +-- type classes, and functions of the library. +-- + +-- TODO: update writeT to writeTriple, etc. + +module Data.RDF ( + -- * Parsing RDF + RdfParser(parseString, parseFile, parseURL), + -- * Serializing RDF + RdfSerializer(hWriteRdf, writeRdf, hWriteH, writeH, hWriteTs, writeTs, hWriteT, writeT, hWriteN, writeN), + -- * RDF type + RDF(empty, mkRdf, triplesOf, select, query, baseUrl, prefixMappings, addPrefixMappings), + -- * RDF triples, nodes, and literals + Triple(Triple), triple, Triples, sortTriples, + Node(UNode, BNode, BNodeGen, LNode), + LValue(PlainL, PlainLL, TypedL), + + -- * Supporting types and functions + BaseUrl(BaseUrl), + PrefixMappings(PrefixMappings), toPMList, PrefixMapping(PrefixMapping), + NodeSelector, isUNode, isBNode, isLNode, + equalSubjects, equalPredicates, equalObjects, + isIsomorphic, + subjectOf, predicateOf, objectOf, isEmpty, + rdfContainsNode,tripleContainsNode, + listSubjectsWithPredicate,listObjectsOfPredicate, + Subject, Predicate, Object, + ParseFailure(ParseFailure), + FastString(uniq,value),mkFastString, + s2b,b2s,unode,bnode,lnode,plainL,plainLL,typedL, + View, view, + fromEither, maybeHead, removeDupes +) +where + +import Data.RDF.Namespace +import Data.RDF.Utils +import Data.ByteString.Lazy.Char8(ByteString) +import qualified Data.ByteString.Lazy.Char8 as B +import Data.List +import System.IO +import Text.Printf + +-- |A type class for ADTs that expose views to clients. +class View a b where + view :: a -> b + +-- |An alias for 'Node', defined for convenience and readability purposes. +type Subject = Node + +-- |An alias for 'Node', defined for convenience and readability purposes. +type Predicate = Node + +-- |An alias for 'Node', defined for convenience and readability purposes. +type Object = Node + +-- |An RDF value is a set of (unique) RDF triples, together with the +-- operations defined upon them. +-- +-- For information about the efficiency of the functions, see the +-- documentation for the particular RDF instance. +-- +-- For more information about the concept of an RDF graph, see +-- the following: . +class RDF rdf where + + -- |Return the base URL of this RDF, if any. + baseUrl :: rdf -> Maybe BaseUrl + + -- |Return the prefix mappings defined for this RDF, if any. + prefixMappings :: rdf -> PrefixMappings + + -- |Return an RDF with the specified prefix mappings merged with + -- the existing mappings. If the Bool arg is True, then a new mapping + -- for an existing prefix will replace the old mapping; otherwise, + -- the new mapping is ignored. + addPrefixMappings :: rdf -> PrefixMappings -> Bool -> rdf + + -- |Return an empty RDF. + empty :: rdf + + -- |Return a RDF containing all the given triples. Handling of duplicates + -- in the input depend on the particular RDF implementation. + mkRdf :: Triples -> Maybe BaseUrl -> PrefixMappings -> rdf + + -- |Return all triples in the RDF, as a list. + triplesOf :: rdf -> Triples + + -- |Select the triples in the RDF that match the given selectors. + -- + -- The three NodeSelector parameters are optional functions that match + -- the respective subject, predicate, and object of a triple. The triples + -- returned are those in the given graph for which the first selector + -- returns true when called on the subject, the second selector returns + -- true when called on the predicate, and the third selector returns true + -- when called on the ojbect. A 'Nothing' parameter is equivalent to a + -- function that always returns true for the appropriate node; but + -- implementations may be able to much more efficiently answer a select + -- that involves a 'Nothing' parameter rather than an @(id True)@ parameter. + -- + -- The following call illustrates the use of select, and would result in + -- the selection of all and only the triples that have a blank node + -- as subject and a literal node as object: + -- + -- > select gr (Just isBNode) Nothing (Just isLNode) + -- + -- Note: this function may be very slow; see the documentation for the + -- particular RDF implementation for more information. + select :: rdf -> NodeSelector -> NodeSelector -> NodeSelector -> Triples + + -- |Return the triples in the RDF that match the given pattern, where + -- the pattern (3 Maybe Node parameters) is interpreted as a triple pattern. + -- + -- The @Maybe Node@ params are interpreted as the subject, predicate, and + -- object of a triple, respectively. @Just n@ is true iff the triple has + -- a node equal to @n@ in the appropriate location; @Nothing@ is always + -- true, regardless of the node in the appropriate location. + -- + -- For example, @ query rdf (Just n1) Nothing (Just n2) @ would return all + -- and only the triples that have @n1@ as subject and @n2@ as object, + -- regardless of the predicate of the triple. + query :: rdf -> Maybe Node -> Maybe Node -> Maybe Node -> Triples + +-- |An RdfParser is a parser that knows how to parse 1 format of RDF and +-- can parse an RDF document of that type from a string, a file, or a URL. +-- Required configuration options will vary from instance to instance. +class RdfParser p where + + -- |Parse RDF from the given bytestring, yielding a failure with error message or + -- the resultant RDF. + parseString :: forall rdf. (RDF rdf) => p -> ByteString -> Either ParseFailure rdf + + -- |Parse RDF from the local file with the given path, yielding a failure with error + -- message or the resultant RDF in the IO monad. + parseFile :: forall rdf. (RDF rdf) => p -> String -> IO (Either ParseFailure rdf) + + -- |Parse RDF from the remote file with the given HTTP URL (https is not supported), + -- yielding a failure with error message or the resultant graph in the IO monad. + parseURL :: forall rdf. (RDF rdf) => p -> String -> IO (Either ParseFailure rdf) + +-- |An RdfSerializer is a serializer of RDF to some particular output format, such as +-- NTriples or Turtle. +class RdfSerializer s where + -- |Write the RDF to a file handle using whatever configuration is specified by + -- the first argument. + hWriteRdf :: forall rdf. (RDF rdf) => s -> Handle -> rdf -> IO () + + -- |Write the RDF to stdout; equivalent to @'hWriteRdf' stdout@. + writeRdf :: forall rdf. (RDF rdf) => s -> rdf -> IO () + + -- |Write to the file handle whatever header information is required based on + -- the output format. For example, if serializing to Turtle, this method would + -- write the necessary \@prefix declarations and possibly a \@baseUrl declaration, + -- whereas for NTriples, there is no header section at all, so this would be a no-op. + hWriteH :: forall rdf. (RDF rdf) => s -> Handle -> rdf -> IO () + + -- |Write header information to stdout; equivalent to @'hWriteRdf' stdout@. + writeH :: forall rdf. (RDF rdf) => s -> rdf -> IO () + + -- |Write some triples to a file handle using whatever configuration is specified + -- by the first argument. + -- + -- WARNING: if the serialization format has header-level information + -- that should be output (e.g., \@prefix declarations for Turtle), then you should + -- use 'hWriteG' instead of this method unless you're sure this is safe to use, since + -- otherwise the resultant document will be missing the header information and + -- will not be valid. + hWriteTs :: s -> Handle -> Triples -> IO () + + -- |Write some triples to stdout; equivalent to @'hWriteTs' stdout@. + writeTs :: s -> Triples -> IO () + + -- |Write a single triple to the file handle using whatever configuration is + -- specified by the first argument. The same WARNING applies as to 'hWriteTs'. + hWriteT :: s -> Handle -> Triple -> IO () + + -- |Write a single triple to stdout; equivalent to @'hWriteT' stdout@. + writeT :: s -> Triple -> IO () + + -- |Write a single node to the file handle using whatever configuration is + -- specified by the first argument. The same WARNING applies as to 'hWriteTs'. + hWriteN :: s -> Handle -> Node -> IO () + + -- |Write a single node to sdout; equivalent to @'hWriteN' stdout@. + writeN :: s -> Node -> IO () + +-- |An RDF node, which may be either a URIRef node ('UNode'), a blank +-- node ('BNode'), or a literal node ('LNode'). +data Node = + + -- |An RDF URI reference. See + -- for more + -- information. + UNode !FastString + + -- |An RDF blank node. See + -- for more + -- information. + | BNode !FastString + + -- |An RDF blank node with an auto-generated identifier, as used in + -- Turtle. + | BNodeGen !Int + + -- |An RDF literal. See + -- for more + -- information. + | LNode !LValue + +-- ============================== +-- Constructor functions for Node + +-- |Return a URIRef node for the given bytetring URI. +{-# INLINE unode #-} +unode :: ByteString -> Node +unode = UNode . mkFastString + +-- |Return a blank node using the given string identifier. +{-# INLINE bnode #-} +bnode :: ByteString -> Node +bnode = BNode . mkFastString + +-- |Return a literal node using the given LValue. +{-# INLINE lnode #-} +lnode :: LValue -> Node +lnode = LNode + +-- Constructor functions for Node +-- ============================== + + +-- |A list of triples. This is defined for convenience and readability. +type Triples = [Triple] + +-- |An RDF triple is a statement consisting of a subject, predicate, +-- and object, respectively. +-- +-- See for +-- more information. +data Triple = Triple !Node !Node !Node + +-- |A smart constructor function for 'Triple' that verifies the node arguments +-- are of the correct type and creates the new 'Triple' if so or calls 'error'. +-- /subj/ must be a 'UNode' or 'BNode', and /pred/ must be a 'UNode'. +triple :: Subject -> Predicate -> Object -> Triple +triple subj pred obj + | isLNode subj = error $ "subject must be UNode or BNode: " ++ show subj + | isLNode pred = error $ "predicate must be UNode, not LNode: " ++ show pred + | isBNode pred = error $ "predicate must be UNode, not BNode: " ++ show pred + | otherwise = Triple subj pred obj + +-- |The actual value of an RDF literal, represented as the 'LValue' +-- parameter of an 'LNode'. +data LValue = + -- Constructors are not exported, because we need to have more + -- control over the format of the literal bytestring that we store. + + -- |A plain (untyped) literal value in an unspecified language. + PlainL !ByteString + + -- |A plain (untyped) literal value with a language specifier. + | PlainLL !ByteString !ByteString + + -- |A typed literal value consisting of the literal value and + -- the URI of the datatype of the value, respectively. + | TypedL !ByteString !FastString + +-- ================================ +-- Constructor functions for LValue + +-- |Return a PlainL LValue for the given string value. +{-# INLINE plainL #-} +plainL :: ByteString -> LValue +plainL = PlainL + +-- |Return a PlainLL LValue for the given string value and language, +-- respectively. +{-# INLINE plainLL #-} +plainLL :: ByteString -> ByteString -> LValue +plainLL = PlainLL + +-- |Return a TypedL LValue for the given string value and datatype URI, +-- respectively. +{-# INLINE typedL #-} +typedL :: ByteString -> FastString -> LValue +typedL val dtype = TypedL (canonicalize dtype val) dtype + +-- Constructor functions for LValue +-- ================================ + + +-- |The base URL of an RDF. +newtype BaseUrl = BaseUrl ByteString + deriving (Eq, Ord, Show) + +-- |A 'NodeSelector' is either a function that returns 'True' +-- or 'False' for a node, or Nothing, which indicates that all +-- nodes would return 'True'. +-- +-- The selector is said to select, or match, the nodes for +-- which it returns 'True'. +-- +-- When used in conjunction with the 'select' method of 'Graph', three +-- node selectors are used to match a triple. +type NodeSelector = Maybe (Node -> Bool) + +-- |Represents a failure in parsing an N-Triples document, including +-- an error message with information about the cause for the failure. +newtype ParseFailure = ParseFailure String + deriving (Eq, Show) + +-- |A node is equal to another node if they are both the same type +-- of node and if the field values are equal. +instance Eq Node where + (UNode fs1) == (UNode fs2) = uniq fs1 == uniq fs2 + (BNode fs1) == (BNode fs2) = uniq fs1 == uniq fs2 + (BNodeGen i1) == (BNodeGen i2) = i1 == i2 + (LNode l1) == (LNode l2) = l1 == l2 + _ == _ = False + +-- |Node ordering is defined first by type, with Unode < BNode < BNodeGen +-- < LNode PlainL < LNode PlainLL < LNode TypedL, and secondly by +-- the natural ordering of the node value. +-- +-- E.g., a '(UNode _)' is LT any other type of node, and a +-- '(LNode (TypedL _ _))' is GT any other type of node, and the ordering +-- of '(BNodeGen 44)' and '(BNodeGen 3)' is that of the values, or +-- 'compare 44 3', GT. +instance Ord Node where + compare = compareNode + +compareNode :: Node -> Node -> Ordering +compareNode (UNode fs1) (UNode fs2) = compareFS fs1 fs2 +compareNode (UNode _) _ = LT +compareNode (BNode fs1) (BNode fs2) = compareFS fs1 fs2 +compareNode (BNode _) (UNode _) = GT +compareNode (BNode _) _ = LT +compareNode (BNodeGen i1) (BNodeGen i2) = compare i1 i2 +compareNode (BNodeGen _) (LNode _) = LT +compareNode (BNodeGen _) _ = GT +compareNode (LNode (PlainL bs1)) (LNode (PlainL bs2)) = compare bs1 bs2 +compareNode (LNode (PlainL _)) (LNode _) = LT +compareNode (LNode (PlainLL bs1 bs1')) (LNode (PlainLL bs2 bs2')) = + case compare bs1' bs2' of + EQ -> compare bs1 bs2 + LT -> LT + GT -> GT +compareNode (LNode (PlainLL _ _)) (LNode (PlainL _)) = GT +compareNode (LNode (PlainLL _ _)) (LNode _) = LT +compareNode (LNode (TypedL bs1 fs1)) (LNode (TypedL bs2 fs2)) = + case compare fs1 fs2 of + EQ -> compare bs1 bs2 + LT -> LT + GT -> GT +compareNode (LNode (TypedL _ _)) (LNode _) = GT +compareNode (LNode _) _ = GT + +-- |Two triples are equal iff their respective subjects, predicates, and objects +-- are equal. +instance Eq Triple where + (Triple s1 p1 o1) == (Triple s2 p2 o2) = s1 == s2 && p1 == p2 && o1 == o2 + +-- |The ordering of triples is based on that of the subject, predicate, and object +-- of the triple, in that order. +instance Ord Triple where + (Triple s1 p1 o1) `compare` (Triple s2 p2 o2) = + case compareNode s1 s2 of + EQ -> case compareNode p1 p2 of + EQ -> compareNode o1 o2 + LT -> LT + GT -> GT + GT -> GT + LT -> LT + +-- |Two 'LValue' values are equal iff they are of the same type and all fields are +-- equal. +instance Eq LValue where + (PlainL bs1) == (PlainL bs2) = bs1 == bs2 + (PlainLL bs1 bs1') == (PlainLL bs2 bs2') = bs1' == bs2' && bs1 == bs2 + (TypedL bs1 fs1) == (TypedL bs2 fs2) = equalFS fs1 fs2 && bs1 == bs2 + _ == _ = False + +-- |Ordering of 'LValue' values is as follows: (PlainL _) < (PlainLL _ _) +-- < (TypedL _ _), and values of the same type are ordered by field values, +-- with '(PlainLL literalValue language)' being ordered by language first and +-- literal value second, and '(TypedL literalValue datatypeUri)' being ordered +-- by datatype first and literal value second. +instance Ord LValue where + compare = compareLValue + +{-# INLINE compareLValue #-} +compareLValue :: LValue -> LValue -> Ordering +compareLValue (PlainL bs1) (PlainL bs2) = compare bs1 bs2 +compareLValue (PlainL _) _ = LT +compareLValue _ (PlainL _) = GT +compareLValue (PlainLL bs1 bs1') (PlainLL bs2 bs2') = + case compare bs1' bs2' of + EQ -> compare bs1 bs2 + GT -> GT + LT -> LT +compareLValue (PlainLL _ _) _ = LT +compareLValue _ (PlainLL _ _) = GT +compareLValue (TypedL l1 t1) (TypedL l2 t2) = + case compareFS t1 t2 of + EQ -> compare l1 l2 + GT -> GT + LT -> LT + +-- String representations of the various data types; generally NTriples-like. + +instance Show Triple where + show (Triple s p o) = + printf "Triple(%s,%s,%s)" (show s) (show p) (show o) + +instance Show Node where + show (UNode uri) = "UNode(" ++ show uri ++ ")" + show (BNode i) = "BNode(" ++ show i ++ ")" + show (BNodeGen genId) = "BNodeGen(" ++ show genId ++ ")" + show (LNode lvalue) = "LNode(" ++ show lvalue ++ ")" + +instance Show LValue where + show (PlainL lit) = "PlainL(" ++ B.unpack lit ++ ")" + show (PlainLL lit lang) = "PlainLL(" ++ B.unpack lit ++ ", " ++ B.unpack lang ++ ")" + show (TypedL lit dtype) = "TypedL(" ++ B.unpack lit ++ "," ++ show dtype ++ ")" + +-- |Answer the given list of triples in sorted order. +sortTriples :: Triples -> Triples +sortTriples = sort + +-- |Answer the subject node of the triple. +{-# INLINE subjectOf #-} +subjectOf :: Triple -> Node +subjectOf (Triple s _ _) = s + +-- |Answer the predicate node of the triple. +{-# INLINE predicateOf #-} +predicateOf :: Triple -> Node +predicateOf (Triple _ p _) = p + +-- |Answer the object node of the triple. +{-# INLINE objectOf #-} +objectOf :: Triple -> Node +objectOf (Triple _ _ o) = o + +-- |Answer if rdf contains node. +rdfContainsNode :: forall rdf. (RDF rdf) => rdf -> Node -> Bool +rdfContainsNode rdf node = + let ts = triplesOf rdf + xs = map (tripleContainsNode node) ts + in elem True xs + +-- |Answer if triple contains node. +tripleContainsNode :: Node -> Triple -> Bool +{-# INLINE tripleContainsNode #-} +tripleContainsNode node t = + subjectOf t == node || predicateOf t == node || objectOf t == node + +-- |Answer if given node is a URI Ref node. +{-# INLINE isUNode #-} +isUNode :: Node -> Bool +isUNode (UNode _) = True +isUNode _ = False + +-- |Answer if given node is a blank node. +{-# INLINE isBNode #-} +isBNode :: Node -> Bool +isBNode (BNode _) = True +isBNode (BNodeGen _) = True +isBNode _ = False + +-- |Answer if given node is a literal node. +{-# INLINE isLNode #-} +isLNode :: Node -> Bool +isLNode (LNode _) = True +isLNode _ = False + +-- |Determine whether two triples have equal subjects. +equalSubjects :: Triple -> Triple -> Bool +equalSubjects (Triple s1 _ _) (Triple s2 _ _) = s1 == s2 + +-- |Determine whether two triples have equal predicates. +equalPredicates :: Triple -> Triple -> Bool +equalPredicates (Triple _ p1 _) (Triple _ p2 _) = p1 == p2 + +-- |Determine whether two triples have equal objects. +equalObjects :: Triple -> Triple -> Bool +equalObjects (Triple _ _ o1) (Triple _ _ o2) = o1 == o2 + +-- |Determines whether the 'RDF' contains zero triples. +isEmpty :: RDF rdf => rdf -> Bool +isEmpty rdf = + let ts = triplesOf rdf + in null ts + +-- |Lists of all subjects of triples with the given predicate. +listSubjectsWithPredicate :: RDF rdf => rdf -> Predicate -> [Subject] +listSubjectsWithPredicate rdf pred = + listNodesWithPredicate rdf pred subjectOf + +-- |Lists of all objects of triples with the given predicate. +listObjectsOfPredicate :: RDF rdf => rdf -> Predicate -> [Object] +listObjectsOfPredicate rdf pred = + listNodesWithPredicate rdf pred objectOf + +listNodesWithPredicate :: RDF rdf => rdf -> Predicate -> (Triple -> Node) -> [Node] +listNodesWithPredicate rdf pred f = + let ts = triplesOf rdf + xs = filter (\t -> predicateOf t == pred) ts + in map f xs + + +-- |Convert a parse result into an RDF if it was successful +-- and error and terminate if not. +fromEither :: RDF rdf => Either ParseFailure rdf -> rdf +fromEither res = + case res of + (Left err) -> error (show err) + (Right rdf) -> rdf + +-- |Remove duplicate triples, returning unique triples. This +-- function may return the triples in a different order than +-- given. +removeDupes :: Triples -> Triples +removeDupes = map head . group . sort + +-- |This determines if two RDF representations are equal regardless of blank +-- nodc names, triple order and prefixes. In math terms, this is the \simeq +-- latex operator, or ~= +isIsomorphic :: forall rdf1 rdf2. (RDF rdf1, RDF rdf2) => rdf1 -> rdf2 -> Bool +isIsomorphic g1 g2 = normalize g1 == normalize g2 + where normalize :: forall rdf. (RDF rdf) => rdf -> Triples + normalize = sort . nub . expandTriples + +-- |Expand the triples in a graph with the prefix map and base URL for that +-- graph. +expandTriples :: (RDF rdf) => rdf -> Triples +expandTriples rdf = expandTriples' [] (baseUrl rdf) (prefixMappings rdf) (triplesOf rdf) + +expandTriples' :: Triples -> Maybe BaseUrl -> PrefixMappings -> Triples -> Triples +expandTriples' acc _ _ [] = acc +expandTriples' acc baseUrl prefixMappings (t:rest) = expandTriples' (normalize baseUrl prefixMappings t : acc) baseUrl prefixMappings rest + where normalize baseUrl prefixMappings = expandPrefixes prefixMappings . expandBaseUrl baseUrl + expandBaseUrl (Just _) triple = triple + expandBaseUrl Nothing triple = triple + expandPrefixes _ triple = triple diff --git a/src/Data/RDF/MGraph.hs b/src/Data/RDF/MGraph.hs new file mode 100644 --- /dev/null +++ b/src/Data/RDF/MGraph.hs @@ -0,0 +1,155 @@ +-- |A simple graph implementation backed by 'Data.Map'. + +module Data.RDF.MGraph(MGraph, empty, mkRdf, triplesOf, select, query) + +where + +import Data.RDF +import Data.RDF.Namespace +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Set(Set) +import qualified Data.Set as Set +import Data.List + +-- |A map-based graph implementation. +-- +-- Worst-case time complexity of the graph functions, with respect +-- to the number of triples, are: +-- +-- * 'empty' : O(1) +-- +-- * 'mkRdf' : O(n) +-- +-- * 'triplesOf': O(n) +-- +-- * 'select' : O(n) +-- +-- * 'query' : O(log n) +newtype MGraph = MGraph (SPOMap, Maybe BaseUrl, PrefixMappings) + +instance RDF MGraph where + baseUrl = baseUrl' + prefixMappings = prefixMappings' + addPrefixMappings = addPrefixMappings' + empty = empty' + mkRdf = mkRdf' + triplesOf = triplesOf' + select = select' + query = query' + +-- some convenience type alias for readability + +-- An adjacency map for a subject, mapping from a predicate node to +-- to the adjacent nodes via that predicate. +type AdjacencyMap = Map Predicate Adjacencies + +-- +type Adjacencies = Set Object +type SPOMap = Map Subject AdjacencyMap + +baseUrl' :: MGraph -> Maybe BaseUrl +baseUrl' (MGraph (_, baseUrl, _)) = baseUrl + +prefixMappings' :: MGraph -> PrefixMappings +prefixMappings' (MGraph (_, _, pms)) = pms + +addPrefixMappings' :: MGraph -> PrefixMappings -> Bool -> MGraph +addPrefixMappings' (MGraph (ts, baseUrl, pms)) pms' replace = + let merge = if replace then flip mergePrefixMappings else mergePrefixMappings + in MGraph (ts, baseUrl, merge pms pms') + +empty' :: MGraph +empty' = MGraph (Map.empty, Nothing, PrefixMappings Map.empty) + +mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> MGraph +mkRdf' ts baseUrl pms = MGraph (mergeTs Map.empty ts, baseUrl, pms) + +mergeTs :: SPOMap -> [Triple] -> SPOMap +mergeTs = foldl' mergeT + where + mergeT :: SPOMap -> Triple -> SPOMap + mergeT m t = mergeT' m (subjectOf t) (predicateOf t) (objectOf t) + +mergeT' :: SPOMap -> Subject -> Predicate -> Object -> SPOMap +mergeT' m s p o = + if s `Map.member` m then + (if p `Map.member` adjs then Map.insert s (addPredObj p o adjs) m + else Map.insert s (addNewPredObjMap p o adjs) m) + else Map.insert s (newPredMap p o) m + where + adjs = get s m + newPredMap :: Predicate -> Object -> Map Predicate (Set Object) + newPredMap p o = Map.singleton p (Set.singleton o) + addNewPredObjMap :: Predicate -> Object -> Map Predicate (Set Object) -> + Map Predicate (Set Object) + addNewPredObjMap p o = Map.insert p (Set.singleton o) + addPredObj :: Predicate -> Object -> Map Predicate (Set Object) -> + Map Predicate (Set Object) + addPredObj p o = Map.insert p (Set.insert o (get p adjs)) + get :: Ord k => k -> Map k v -> v + get = Map.findWithDefault undefined + +-- 3 following functions support triplesOf +triplesOf' :: MGraph -> Triples +triplesOf' (MGraph (spoMap, _, _)) = concatMap (uncurry tripsSubj) subjPredMaps + where subjPredMaps = Map.toList spoMap + +tripsSubj :: Subject -> AdjacencyMap -> Triples +tripsSubj s adjMap = concatMap (uncurry (tfsp s)) (Map.toList adjMap) + where tfsp = tripsForSubjPred + +tripsForSubjPred :: Subject -> Predicate -> Adjacencies -> Triples +tripsForSubjPred s p adjs = map (Triple s p) (Set.elems adjs) + +-- supports select +select' :: MGraph -> NodeSelector -> NodeSelector -> NodeSelector -> Triples +select' (MGraph (spoMap,_,_)) subjFn predFn objFn = + map (\(s,p,o) -> Triple s p o) $ Set.toList $ sel1 subjFn predFn objFn spoMap + +sel1 :: NodeSelector -> NodeSelector -> NodeSelector -> SPOMap -> Set (Node, Node, Node) +sel1 (Just subjFn) p o spoMap = + Set.unions $ map (sel2 p o) $ filter (\(x,_) -> subjFn x) $ Map.toList spoMap +sel1 Nothing p o spoMap = Set.unions $ map (sel2 p o) $ Map.toList spoMap + +sel2 :: NodeSelector -> NodeSelector -> (Node, Map Node (Set Node)) -> Set (Node, Node, Node) +sel2 (Just predFn) mobjFn (s, ps) = + Set.map (\(p,o) -> (s,p,o)) $ + foldl' Set.union Set.empty $ + map (sel3 mobjFn) poMapS :: Set (Node, Node, Node) + where + poMapS :: [(Node, Set Node)] + poMapS = filter (\(k,_) -> predFn k) $ Map.toList ps +sel2 Nothing mobjFn (s, ps) = + Set.map (\(p,o) -> (s,p,o)) $ + foldl' Set.union Set.empty $ + map (sel3 mobjFn) poMaps + where + poMaps = Map.toList ps + +sel3 :: NodeSelector -> (Node, Set Node) -> Set (Node, Node) +sel3 (Just objFn) (p, os) = Set.map (\o -> (p, o)) $ Set.filter objFn os +sel3 Nothing (p, os) = Set.map (\o -> (p, o)) os + +-- support query +query' :: MGraph -> Maybe Node -> Maybe Predicate -> Maybe Node -> Triples +query' (MGraph (spoMap,_ , _)) subj pred obj = map f $ Set.toList $ q1 subj pred obj spoMap + where f (s, p, o) = Triple s p o + +q1 :: Maybe Node -> Maybe Node -> Maybe Node -> SPOMap -> Set (Node, Node, Node) +q1 (Just s) p o spoMap = q2 p o (s, Map.findWithDefault Map.empty s spoMap) +q1 Nothing p o spoMap = Set.unions $ map (q2 p o) $ Map.toList spoMap + +q2 :: Maybe Node -> Maybe Node -> (Node, Map Node (Set Node)) -> Set (Node, Node, Node) +q2 (Just p) o (s, pmap) = + if p `Map.member` pmap then + Set.map (\ (p', o') -> (s, p', o')) $ + q3 o (p, Map.findWithDefault undefined p pmap) + else Set.empty +q2 Nothing o (s, pmap) = Set.map (\(x,y) -> (s,x,y)) $ Set.unions $ map (q3 o) opmaps + where opmaps ::[(Node, Set Node)] + opmaps = Map.toList pmap + +q3 :: Maybe Node -> (Node, Set Node) -> Set (Node, Node) +q3 (Just o) (p, os) = if o `Set.member` os then Set.singleton (p, o) else Set.empty +q3 Nothing (p, os) = Set.map (\o -> (p, o)) os diff --git a/src/Data/RDF/Namespace.hs b/src/Data/RDF/Namespace.hs new file mode 100644 --- /dev/null +++ b/src/Data/RDF/Namespace.hs @@ -0,0 +1,141 @@ +-- |Defines types and utility functions related to namespaces, and +-- some predefined values for commonly used namespaces, such as +-- rdf, xsd, dublin core, etc. + +module Data.RDF.Namespace( + -- * Namespace types and functions + Namespace(..), mkPlainNS, mkPrefixedNS, mkPrefixedNS', + PrefixMapping(PrefixMapping), PrefixMappings(PrefixMappings), toPMList, + mergePrefixMappings, + mkUri, + prefixOf, uriOf, + -- * Predefined namespace values + rdf, rdfs, dc, dct, owl, xsd, skos, foaf, ex, ex2, standard_ns_mappings +) +where + +import Data.RDF.Utils +import Text.Printf +import Data.Map(Map) +import qualified Data.Map as Map +import qualified Data.List as List +import Data.ByteString.Lazy.Char8(ByteString) +import qualified Data.ByteString.Lazy.Char8 as B + +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 $ Map.fromList $ + map (\(PrefixedNS pre uri) -> (pre, uri)) standard_namespaces + +-- |The RDF namespace. +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#" + +-- |The Dublic Core namespace. +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/" + +-- |The OWL namespace. +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#" + +-- |The SKOS namespace. +skos :: Namespace +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/" + +-- |Example namespace #1. +ex :: Namespace +ex = mkPrefixedNS' "ex" "http://www.example.org/" + +-- |Example namespace #2. +ex2 :: Namespace +ex2 = mkPrefixedNS' "ex2" "http://www2.example.org/" + +-- |An alias for a map from prefix to namespace URI. +newtype PrefixMappings = PrefixMappings (Map ByteString ByteString) + deriving (Eq, Ord) +instance Show PrefixMappings where + -- This is really inefficient, but it's not used much so not what + -- worth optimizing yet. + show (PrefixMappings pmap) = printf "PrefixMappings [%s]" mappingsStr + where showPM = show . PrefixMapping + mappingsStr = List.intercalate ", " (map showPM (Map.toList pmap)) + +-- |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 + +-- |View the prefix mappings as a list of key-value pairs. The PM in +-- in the name is to reduce name clashes if used without qualifying. +toPMList :: PrefixMappings -> [(ByteString, ByteString)] +toPMList (PrefixMappings m) = Map.toList m + +-- |A mapping of a prefix to the URI for that prefix. +newtype PrefixMapping = PrefixMapping (ByteString, ByteString) + deriving (Eq, Ord) +instance Show PrefixMapping where + show (PrefixMapping (prefix, uri)) = printf "PrefixMapping (%s, %s)" (b2s prefix) (b2s uri) + +-- |Make a URI consisting of the given namespace and the given localname. +mkUri :: Namespace -> ByteString -> ByteString +mkUri ns local = uriOf ns `B.append` local + +-- |Represents a namespace as either a prefix and uri, respectively, +-- or just a uri. +data Namespace = PrefixedNS ByteString ByteString -- prefix and ns uri + | PlainNS ByteString -- ns uri alone + +-- |Make a namespace for the given URI reference. +mkPlainNS :: ByteString -> Namespace +mkPlainNS = PlainNS + +-- |Make a namespace having the given prefix for the given URI reference, +-- respectively. +mkPrefixedNS :: ByteString -> ByteString -> Namespace +mkPrefixedNS = PrefixedNS + +-- |Make a namespace having the given prefix for the given URI reference, +-- respectively, using strings which will be converted to bytestrings +-- automatically. +mkPrefixedNS' :: String -> String -> Namespace +mkPrefixedNS' s1 s2 = mkPrefixedNS (B.pack s1) (B.pack s2) + +instance Eq Namespace where + (PrefixedNS _ u1) == (PrefixedNS _ u2) = u1 == u2 + (PlainNS u1) == (PlainNS u2) = u1 == u2 + (PrefixedNS _ u1) == (PlainNS u2) = u1 == u2 + (PlainNS u1) == (PrefixedNS _ u2) = u1 == u2 + +instance Show Namespace where + show (PlainNS uri) = B.unpack uri + show (PrefixedNS prefix uri) = printf "(PrefixNS %s %s)" (B.unpack prefix) (B.unpack uri) + +-- |Determine the URI of the given namespace. +uriOf :: Namespace -> ByteString +uriOf (PlainNS uri) = uri +uriOf (PrefixedNS _ uri) = uri + +-- |Determine the prefix of the given namespace, if it has one. +prefixOf :: Namespace -> Maybe ByteString +prefixOf (PlainNS _) = Nothing +prefixOf (PrefixedNS p _) = Just p diff --git a/src/Data/RDF/TriplesGraph.hs b/src/Data/RDF/TriplesGraph.hs new file mode 100644 --- /dev/null +++ b/src/Data/RDF/TriplesGraph.hs @@ -0,0 +1,96 @@ +-- |"TriplesGraph" contains a list-backed graph implementation suitable +-- for smallish graphs or for temporary graphs that will not be queried. +-- It maintains the triples in the order that they are given in, and is +-- especially useful for holding N-Triples, where it is often desirable +-- to preserve the order of the triples when they were originally parsed. +-- Duplicate triples are not filtered. If you might have duplicate triples, +-- use @MGraph@ instead, which is also more efficient. However, the query +-- functions of this graph (select, query) remove duplicates from their +-- result triples (but triplesOf does not) since it is usually cheap +-- to do so. +module Data.RDF.TriplesGraph(TriplesGraph, empty, mkRdf, triplesOf, select, query) + +where + +import Data.RDF +import Data.RDF.Namespace +import qualified Data.Map as Map + +-- |A simple implementation of the 'RDF' type class that represents +-- the graph internally as a list of triples. +-- +-- Note that this type of RDF is fine for interactive +-- experimentation and querying of smallish (<10,000 triples) graphs, +-- but there are better options for larger graphs or graphs that you +-- will do many queries against (e.g., @MGraph@ is faster for queries). +-- +-- The time complexity of the functions (where n == num_triples) are: +-- +-- * 'empty' : O(1) +-- +-- * 'mkRdf' : O(n) +-- +-- * 'triplesOf': O(1) +-- +-- * 'select' : O(n) +-- +-- * 'query' : O(n) +newtype TriplesGraph = TriplesGraph (Triples, Maybe BaseUrl, PrefixMappings) + +instance RDF TriplesGraph where + baseUrl = baseUrl' + prefixMappings = prefixMappings' + addPrefixMappings = addPrefixMappings' + empty = empty' + mkRdf = mkRdf' + triplesOf = triplesOf' + select = select' + query = query' + +prefixMappings' :: TriplesGraph -> PrefixMappings +prefixMappings' (TriplesGraph (_, _, pms)) = pms + +addPrefixMappings' :: TriplesGraph -> PrefixMappings -> Bool -> TriplesGraph +addPrefixMappings' (TriplesGraph (ts, baseUrl, pms)) pms' replace = + let merge = if replace then flip mergePrefixMappings else mergePrefixMappings + in TriplesGraph (ts, baseUrl, merge pms pms') + +baseUrl' :: TriplesGraph -> Maybe BaseUrl +baseUrl' (TriplesGraph (_, baseUrl, _)) = baseUrl + +empty' :: TriplesGraph +empty' = TriplesGraph ([], Nothing, PrefixMappings Map.empty) + +-- We no longer remove duplicates here, as it is very time consuming and is often not +-- necessary (raptor does not seem to remove dupes either). Instead, we remove dupes +-- from the results of the select' and query' functions, since it is cheap to do +-- there in most cases, but not when triplesOf' is called. +mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> TriplesGraph +mkRdf' ts baseUrl pms = TriplesGraph (ts, baseUrl, pms) + +triplesOf' :: TriplesGraph -> Triples +triplesOf' (TriplesGraph (ts, _, _)) = ts + +select' :: TriplesGraph -> NodeSelector -> NodeSelector -> NodeSelector -> Triples +select' (TriplesGraph (ts, _, _)) s p o = removeDupes $ filter (matchSelect s p o) ts + +query' :: TriplesGraph -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples +query' (TriplesGraph (ts, _, _)) s p o = removeDupes $ filter (matchPattern s p o) ts + +matchSelect :: NodeSelector -> NodeSelector -> NodeSelector -> Triple -> Bool +matchSelect s p o t = + match s (subjectOf t) && match p (predicateOf t) && match o (objectOf t) + where + match Nothing _ = True + match (Just fn) n = fn n + +matchPattern :: Maybe Subject -> Maybe Predicate -> Maybe Object -> Triple -> Bool +matchPattern subj pred obj t = smatch t && pmatch t && omatch t + where + smatch trp = matchNode subj (subjectOf trp) + pmatch trp = matchNode pred (predicateOf trp) + omatch trp = matchNode obj (objectOf trp) + +matchNode :: Maybe Node -> Node -> Bool +matchNode Nothing _ = True +matchNode (Just n1) n2 = n1 == n2 diff --git a/src/Data/RDF/Utils.hs b/src/Data/RDF/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/RDF/Utils.hs @@ -0,0 +1,161 @@ +{-# OPTIONS_GHC -fno-cse #-} +module Data.RDF.Utils ( + FastString(uniq, value), + mkFastString, equalFS, compareFS, + s2b, b2s, hPutStrRev, hPutStrLnRev, + canonicalize, maybeHead +) where + +import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Lazy.Char8(ByteString) +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Map(Map) +import qualified Data.Map as Map +import System.IO +import Data.IORef +import System.IO.Unsafe(unsafePerformIO) + +bs_newline :: ByteString +bs_newline = B.pack "\n" + +-- |A safe version of head that returns 'Nothing' for an empty list or 'Just (head lst)' for +-- a non-empty list. +maybeHead :: [a] -> Maybe a +maybeHead lst | null lst = Nothing + | otherwise = Just (head lst) + +-- |'FastString' is a bytestring-based string type that provides constant-time equality +-- testing. +-- +-- A 'FastString' value consists of a unique identifier and a (strict) 'ByteString' value. +-- The unique identifier is used for constant-time equality testing, and all other operations +-- are provided by the 'ByteString' value itself. +-- +-- 'FastString' values are created by the 'mkFastString' function, which maintains a table +-- of all created values, and reuses old values whenever possible. The 'ByteString' is +-- maintained internally in reverse order of the string passed to 'mkFastString'; this +-- is to provide faster comparison testing for unequal values, since it is very common in +-- RDF to have URIs that are equal apart from the last few characters (localname). +data FastString = FS { + uniq :: !Int, + value :: !ByteString +} + +instance Show FastString where + show = B.unpack . B.reverse . value + +-- |Two 'FastString' values are equal iff they have the same unique identifer. +instance Eq FastString where + (==) = equalFS + +{-# INLINE equalFS #-} +equalFS :: FastString -> FastString -> Bool +equalFS fs1 fs2 = uniq fs1 == uniq fs2 + + +-- |Two 'FastString' values are equal if they have the same unique identifier, +-- and are otherwise ordered using the natural ordering of 'ByteString' in the +-- internal (reversed) representation. +instance Ord FastString where + compare = compareFS + +{-# INLINE compareFS #-} +compareFS :: FastString -> FastString -> Ordering +compareFS fs1 fs2 = + if uniq fs1 == uniq fs2 then EQ else + compare (value fs1) (value fs2) + +-- |A convenience function for converting from a bytestring to a string. +{-# INLINE b2s #-} +b2s :: ByteString -> String +b2s = B.unpack + +-- |A convenience function for converting from a string to a bytestring. +{-# INLINE s2b #-} +s2b :: String -> ByteString +s2b = B.pack + +-- |Write to the handle the reversed value of the bytestring, with no newline. +{-# INLINE hPutStrRev #-} +hPutStrRev :: Handle -> ByteString -> IO () +hPutStrRev h bs = BL.hPutStr h (B.reverse bs) + +-- |Write to the handle the reversed value of the bytestring, followed by +-- a newline. +{-# INLINE hPutStrLnRev #-} +hPutStrLnRev :: Handle -> ByteString -> IO () +hPutStrLnRev h bs = BL.hPutStr h (B.reverse bs) >> BL.hPutStr h bs_newline + +-- |Return a 'FastString' value for the given 'ByteString', reusing a 'FastString' +-- if one has been created for equal bytestrings, or creating a new one if necessary. +-- The 'FastString' values created maintain the invariant that two values have the +-- same unique identifier (accessible via 'uniq') iff their respective bytestring +-- values are equal. +-- +-- The unique identifier is only for the given session, and equal 'ByteString' values +-- will generally not be assigned the same identifier under different processes and +-- different executions. +{-# NOINLINE mkFastString #-} +mkFastString :: ByteString -> FastString +mkFastString bs = + unsafePerformIO $ + do m <- readIORef fsMap + let mFs = Map.lookup bs m + case mFs of + Just fs -> return fs + Nothing -> newFastString bs >>= \fs -> + writeIORef fsMap (Map.insert bs fs m) >> + return fs + +-- |Canonicalize the given 'ByteString' value using the 'FastString' +-- as the datatype URI. +{-# NOINLINE canonicalize #-} +canonicalize :: FastString -> ByteString -> ByteString +canonicalize typeFs litValue = + case Map.lookup typeFs canonicalizerTable of + Nothing -> litValue + Just fn -> fn litValue + +{-# INLINE newFastString #-} +newFastString :: ByteString -> IO FastString +newFastString str = + do curr <- readIORef fsCounter + modifyIORef fsCounter (+1) + return $! FS curr (B.reverse str) + +{-# NOINLINE fsCounter #-} +fsCounter :: IORef Int +fsCounter = unsafePerformIO $ newIORef 0 + +{-# NOINLINE fsMap #-} +fsMap :: IORef (Map ByteString FastString) +fsMap = unsafePerformIO $ newIORef Map.empty + +-- A table of mappings from a FastString URI (reversed as +-- they are) to a function that canonicalizes a ByteString +-- assumed to be of that type. +{-# NOINLINE canonicalizerTable #-} +canonicalizerTable :: Map FastString (ByteString -> ByteString) +canonicalizerTable = + Map.fromList [(integerUri, _integerStr), (doubleUri, _doubleStr), + (decimalUri, _decimalStr)] + where + integerUri = mkFsUri "http://www.w3.org/2001/XMLSchema#integer" + decimalUri = mkFsUri "http://www.w3.org/2001/XMLSchema#decimal" + doubleUri = mkFsUri "http://www.w3.org/2001/XMLSchema#double" + mkFsUri :: String -> FastString + mkFsUri uri = mkFastString . s2b $! uri + +_integerStr, _decimalStr, _doubleStr :: ByteString -> ByteString +_integerStr = B.dropWhile (== '0') + +-- exponent: [eE] ('-' | '+')? [0-9]+ +-- ('-' | '+') ? ( [0-9]+ '.' [0-9]* exponent | '.' ([0-9])+ exponent | ([0-9])+ exponent ) +_doubleStr s = B.pack $ show (read $ B.unpack s :: Double) + +-- ('-' | '+')? ( [0-9]+ '.' [0-9]* | '.' ([0-9])+ | ([0-9])+ ) +_decimalStr s = -- haskell double parser doesn't handle '1.'.., + case B.last s of -- so we add a zero if that's the case and then parse + '.' -> f (s `B.snoc` '0') + _ -> f s + where f s' = B.pack $ show (read $ B.unpack s' :: Double) diff --git a/src/Rdf4hParseMain.hs b/src/Rdf4hParseMain.hs new file mode 100644 --- /dev/null +++ b/src/Rdf4hParseMain.hs @@ -0,0 +1,191 @@ +module Main where + +import Data.RDF +import Data.RDF.TriplesGraph + +import Text.RDF.RDF4H.NTriplesParser +import Text.RDF.RDF4H.NTriplesSerializer +import Text.RDF.RDF4H.TurtleParser +import Text.RDF.RDF4H.TurtleSerializer + +import Data.ByteString.Lazy.Char8(ByteString) +import qualified Data.ByteString.Lazy.Char8 as B + +import System.Environment +import System.IO +import System.Exit +import System.Console.GetOpt + +import Control.Monad + +import Data.List +import qualified Data.Map as Map +import Data.Char(isLetter) +import Text.Printf(hPrintf) + +-- TODO: cleanup and refactor main and elsewhere in this module + +main :: IO () +main = + do (opts, args) <- getArgs >>= compilerOpts + when (Help `elem` opts) + (putStrLn (usageInfo header options) >> exitSuccess) + when (Version `elem` opts) (putStrLn version >> exitSuccess) + when (null args) + (ioError + (userError + ("\n\n" ++ "INPUT-URI required\n\n" ++ usageInfo header options))) + let debug = Debug `elem` opts + inputUri = head args + inputFormat = getWithDefault (InputFormat "turtle") opts + outputFormat = getWithDefault (OutputFormat "ntriples") opts + inputBaseUri = getInputBaseUri inputUri args opts + outputBaseUri = getWithDefault (OutputBaseUri inputBaseUri) opts + unless (outputFormat == "ntriples" || outputFormat == "turtle") + (hPrintf stderr + ("'" ++ + outputFormat ++ + "' is not a valid output format. Supported output formats are: ntriples, turtle\n") + >> exitWith (ExitFailure 1)) + when debug + (hPrintf stderr " INPUT-URI: %s\n\n" inputUri >> + hPrintf stderr " INPUT-FORMAT: %s\n" inputFormat + >> hPrintf stderr " INPUT-BASE-URI: %s\n\n" inputBaseUri + >> hPrintf stderr " OUTPUT-FORMAT: %s\n" outputFormat + >> hPrintf stderr "OUTPUT-BASE-URI: %s\n\n" outputBaseUri) + let mInputUri + = if inputBaseUri == "-" then Nothing else + Just (BaseUrl $ s2b inputBaseUri) + docUri = Just $ s2b inputUri + emptyPms = PrefixMappings Map.empty + case (inputFormat, isUri $ s2b inputUri) of + ("turtle", True) -> parseURL (TurtleParser mInputUri docUri) + inputUri + >>= + \ (res :: Either ParseFailure TriplesGraph) -> + write outputFormat docUri emptyPms res + ("turtle", False) -> (if inputUri /= "-" then + parseFile (TurtleParser mInputUri docUri) inputUri else + liftM (parseString (TurtleParser mInputUri docUri)) B.getContents) + >>= + \ (res :: Either ParseFailure TriplesGraph) -> + write outputFormat docUri emptyPms res + ("ntriples", True) -> parseURL NTriplesParser inputUri >>= + \ (res :: Either ParseFailure TriplesGraph) -> + write outputFormat Nothing emptyPms res + ("ntriples", False) -> (if inputUri /= "-" then + parseFile NTriplesParser inputUri else + liftM (parseString NTriplesParser) B.getContents) + >>= + \ (res :: Either ParseFailure TriplesGraph) -> + write outputFormat Nothing emptyPms res + (str, _) -> putStrLn ("Invalid format: " ++ str) >> exitFailure + +write :: forall rdf. (RDF rdf) => String -> Maybe ByteString -> PrefixMappings -> Either ParseFailure rdf -> IO () +write format docUri pms res = + case res of + (Left (ParseFailure msg)) -> putStrLn msg >> exitWith (ExitFailure 1) + (Right rdf) -> doWriteRdf rdf + where doWriteRdf rdf = case format of + "turtle" -> writeRdf (TurtleSerializer docUri pms) rdf + "ntriples" -> writeRdf NTriplesSerializer rdf + 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 +-- the second item in the list) or in the flags as an explicitly +-- selected flag. If the user submitted both a 2nd commandline arg +-- after the INPUT-URI and used the -I/--input-base-uri arg, then +-- the -I/--input-base-uri value is used and the 2nd commandline +-- arg is silently discarded. +getInputBaseUri :: String -> [String] -> [Flag] -> String +getInputBaseUri inputUri args flags = + if null $ tail args then + getWithDefault (InputBaseUri inputUri) flags else + getWithDefault (InputBaseUri (head $ tail args)) flags + +-- Determine if the bytestring represents a URI, which is currently +-- decided solely by checking for a colon in the string. +isUri :: ByteString -> Bool +isUri str = not (B.null post) && B.all isLetter pre + where (pre, post) = B.break (== ':') str + +-- Extract from the list of flags a flag of the same type as the first +-- flag argument, returning its string value; if there is no such flag, +-- return the string value of the first argument. +getWithDefault :: Flag -> [Flag] -> String +getWithDefault def args = + case find (== def) args of + Nothing -> strValue def + Just val -> strValue val + +-- Convert the flag to a string, which is only valid for flags that have +-- a string argument. +strValue :: Flag -> String +strValue (InputFormat s) = s +strValue (InputBaseUri s) = s +strValue (OutputFormat s) = s +strValue (OutputBaseUri s) = s +strValue flag = error $ "No string value for flag: " ++ show flag + +-- The commandline arguments we accept. None are required. +data Flag + = Help | Debug | Version + | InputFormat String | InputBaseUri String + | OutputFormat String | OutputBaseUri String + deriving (Show) + +-- Two flags are equal if they are of the same type, regardless of value: a +-- strange definition, but we never care about values when finding or comparing +-- them. +instance Eq Flag where + Help == Help = True + Debug == Debug = True + Version == Version = True + InputFormat _ == InputFormat _ = True + InputBaseUri _ == InputBaseUri _ = True + OutputFormat _ == OutputFormat _ = True + OutputBaseUri _ == OutputBaseUri _ = True + _ == _ = False + +-- The top part of the usage output. +header :: String +header = + "\nrdf4h_parse: an RDF parser and serializer\n\n" ++ + "\nUsage: rdf4h_parse [OPTION...] INPUT-URI [INPUT-BASE-URI]\n\n" ++ + " INPUT-URI a filename, URI or '-' for standard input (stdin).\n" ++ + " INPUT-BASE-URI the input/parser base URI or '-' for none.\n" ++ + " Default is INPUT-URI\n" ++ + " Equivalent to -I INPUT-BASE-URI, --input-base-uri INPUT-BASE-URI\n\n" + +-- The current version of the executable, which for the moment is the same as +-- the version for the library as a whole, as given in rdf4h.cabal. +-- TODO: should get this from cabal file rather than duplicating i here. +version :: String +version = "0.9.1" + +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 "v" ["version"] (NoArg Version) "Show version number\n\n" + + , Option "i" ["input"] (ReqArg InputFormat "FORMAT") $ "Set input format/parser to one of:\n" ++ + " turtle Turtle (default)\n" ++ + " ntriples N-Triples" + , Option "I" ["input-base-uri"] (ReqArg InputBaseUri "URI") $ "Set the input/parser base URI. '-' for none.\n" ++ + " Default is INPUT-BASE-URI argument value.\n\n" + + , Option "o" ["output"] (ReqArg OutputFormat "FORMAT") $ "Set output format/serializer to one of:\n" ++ + " ntriples N-Triples (default)\n" ++ + " turtle Turtle" + , Option "O" ["output-base-uri"] (ReqArg OutputBaseUri "URI") $ "Set the output format/serializer base URI. '-' for none.\n" ++ + " Default is input/parser base URI." + ] + +compilerOpts :: [String] -> IO ([Flag], [String]) +compilerOpts argv = + case getOpt Permute options argv of + (o,n,[] ) -> return (o,n) + (_,_,errs) -> ioError (userError ("\n\n" ++ concat errs ++ usageInfo header options)) + diff --git a/src/Text/RDF/RDF4H/Interact.hs b/src/Text/RDF/RDF4H/Interact.hs new file mode 100644 --- /dev/null +++ b/src/Text/RDF/RDF4H/Interact.hs @@ -0,0 +1,89 @@ +-- |This module re-exports most of the other modules of this library and also +-- defines some convenience methods for interactive experimentation, such as +-- simplified functions for parsing and serializing RDF, etc. +-- +-- All the load functions can be used with any 'RDF' implementation, so you +-- must declare a type in order to help the type system disambiguate the +-- @RDF rdf@ constraint in those function's types. +-- +-- Many of the simplified functions in this module call 'error' when there is +-- a failure. This is so that you don't have to deal with 'Maybe' or 'Either' +-- return values while interacting. These functions are thus only intended +-- to be used when interactively exploring via ghci, and should not otherwise +-- be used. + +module Text.RDF.RDF4H.Interact where + +import Data.ByteString.Lazy.Char8(ByteString) +import qualified Data.ByteString.Lazy.Char8 as B + +import Data.RDF +import Data.RDF.Utils() +import Data.RDF.TriplesGraph() +import Data.RDF.MGraph() + +import Text.RDF.RDF4H.NTriplesParser +import Text.RDF.RDF4H.TurtleParser +import Text.RDF.RDF4H.NTriplesSerializer() +import Text.RDF.RDF4H.TurtleSerializer() + +-- |Load a Turtle file from the filesystem using the optional base URL +-- (used to resolve relative URI fragments) and optional document URI +-- (used to resolve <> in the document). +-- +-- This function calls 'error' with an error message if unable to load the file. +loadTurtleFile :: forall rdf. (RDF rdf) => Maybe String -> Maybe String -> String -> IO rdf +loadTurtleFile baseUrl docUri = _load parseFile (mkTurtleParser baseUrl docUri) + +-- |Load a Turtle file from a URL just like 'loadTurtleFile' does from the local +-- filesystem. See that function for explanation of args, etc. +loadTurtleURL :: forall rdf. (RDF rdf) => Maybe String -> Maybe String -> String -> IO rdf +loadTurtleURL baseUrl docUri = _load parseURL (mkTurtleParser baseUrl docUri) + +-- |Parse a Turtle document from the given 'ByteString' using the given @baseUrl@ and +-- @docUri@, which have the same semantics as in the loadTurtle* functions. +parseTurtleString :: forall rdf. (RDF rdf) => Maybe String -> Maybe String -> ByteString -> rdf +parseTurtleString baseUrl docUri = _parse parseString (mkTurtleParser baseUrl docUri) + +mkTurtleParser :: Maybe String -> Maybe String -> TurtleParser +mkTurtleParser b d = TurtleParser ((BaseUrl . B.pack) `fmap` b) (B.pack `fmap` d) + +-- |Load an NTriples file from the filesystem. +-- +-- This function calls 'error' with an error message if unable to load the file. +loadNTriplesFile :: forall rdf. (RDF rdf) => String -> IO rdf +loadNTriplesFile = _load parseFile NTriplesParser + +-- |Load an NTriples file from a URL just like 'loadNTriplesFile' does from the local +-- filesystem. See that function for more info. +loadNTriplesURL :: forall rdf. (RDF rdf) => String -> IO rdf +loadNTriplesURL = _load parseURL NTriplesParser + +-- |Parse an NTriples document from the given 'ByteString', as 'loadNTriplesFile' does +-- from a file. +parseNTriplesString :: forall rdf. (RDF rdf) => ByteString -> rdf +parseNTriplesString = _parse parseString NTriplesParser + +-- |Print a list of triples to stdout; useful for debugging and interactive use. +printTriples :: Triples -> IO () +printTriples = mapM_ print + +-- Load an RDF using the given parseFunc, parser, and the location (filesystem path +-- or HTTP URL), calling error with the 'ParseFailure' message if unable to load +-- or parse for any reason. +_load :: forall p rdf. (RdfParser p, RDF rdf) => + (p -> String -> IO (Either ParseFailure rdf)) -> + p -> String -> IO rdf +_load parseFunc parser location = parseFunc parser location >>= _handle + +-- Use the given parseFunc and parser to parse the given 'ByteString', calling error +-- with the 'ParseFailure' message if unable to load or parse for any reason. +_parse :: forall p rdf. (RdfParser p, RDF rdf) => + (p -> ByteString -> Either ParseFailure rdf) -> + p -> ByteString -> rdf +_parse parseFunc parser rdfBs = either (error . show) id $ parseFunc parser rdfBs + +-- Handle the result of an IO parse by returning the graph if parse was successful +-- and calling 'error' with the 'ParseFailure' error message if unsuccessful. +_handle :: forall rdf. (RDF rdf) => Either ParseFailure rdf -> IO rdf +_handle = either (error . show) return diff --git a/src/Text/RDF/RDF4H/NTriplesParser.hs b/src/Text/RDF/RDF4H/NTriplesParser.hs new file mode 100644 --- /dev/null +++ b/src/Text/RDF/RDF4H/NTriplesParser.hs @@ -0,0 +1,232 @@ +-- |A parser for RDF in N-Triples format +-- . + +module Text.RDF.RDF4H.NTriplesParser( + NTriplesParser(NTriplesParser), ParseFailure +) + +where + +-- TODO: switch to OverloadedStrings and use ByteString literals (?). + +import Data.RDF +import Text.RDF.RDF4H.ParserUtils +import Data.Char(isLetter, isDigit, isLower) +import qualified Data.Map as Map +import Text.Parsec +import Text.Parsec.ByteString.Lazy +import Data.ByteString.Lazy.Char8(ByteString) +import qualified Data.ByteString.Lazy.Char8 as B +import Control.Monad (liftM,void) + +-- |NTriplesParser is an 'RdfParser' implementation for parsing RDF in the +-- NTriples format. It requires no configuration options. To use this parser, +-- pass an 'NTriplesParser' value as the first argument to any of the +-- 'parseString', 'parseFile', or 'parseURL' methods of the 'RdfParser' type +-- class. +data NTriplesParser = NTriplesParser + +-- |'NTriplesParser' is an instance of 'RdfParser'. +instance RdfParser NTriplesParser where + parseString _ = parseString' + parseFile _ = parseFile' + parseURL _ = parseURL' + +-- We define or redefine all here using same names as the spec, but with an +-- 'nt_' prefix in order to avoid name clashes (e.g., ntripleDoc becomes +-- nt_ntripleDoc). + +-- |nt_ntripleDoc is simply zero or more lines. +nt_ntripleDoc :: GenParser ByteString () [Maybe Triple] +nt_ntripleDoc = manyTill nt_line eof + +nt_line :: GenParser ByteString () (Maybe Triple) +nt_line = + skipMany nt_space >> + (nt_comment <|> nt_triple <|> nt_empty) >>= + \res -> nt_eoln >> return res + +-- A comment consists of an initial # character, followed by any number of +-- characters except cr or lf. The spec is redundant in specifying that +-- comment is hash followed by "character - (cr | lf)", since character +-- is already defined as the range #x0020-#x007E, so cr #x000D and +-- lf #x000A are both already excluded. This returns Nothing as we are +-- ignoring comments for now. +nt_comment :: GenParser ByteString () (Maybe Triple) +nt_comment = char '#' >> skipMany nt_character >> return Nothing + +-- A triple consists of whitespace-delimited subject, predicate, and object, +-- followed by optional whitespace and a period, and possibly more +-- whitespace. +nt_triple :: GenParser ByteString () (Maybe Triple) +nt_triple = + do + subj <- nt_subject + skipMany1 nt_space + pred <- nt_predicate + skipMany1 nt_space + obj <- nt_object + skipMany nt_space + char '.' + many nt_space + return $ Just (Triple subj pred obj) + +-- A literal is either a language literal (with optional language +-- specified) or a datatype literal (with required datatype +-- specified). The literal value is always enclosed in double +-- quotes. A language literal may have '@' after the closing quote, +-- followed by a language specifier. A datatype literal follows +-- the closing quote with ^^ followed by the URI of the datatype. +nt_literal :: GenParser ByteString () LValue +nt_literal = + do lit_str <- between_chars '"' '"' inner_literal + liftM (plainLL lit_str) (char '@' >> nt_language) <|> + liftM (typedL lit_str . mkFastString) (count 2 (char '^') >> nt_uriref) <|> + return (plainL lit_str) + where inner_literal = liftM B.concat (manyTill inner_string (lookAhead $ char '"')) + +-- A language specifier of a language literal is any number of lowercase +-- letters followed by any number of blocks consisting of a hyphen followed +-- by one or more lowercase letters or digits. +nt_language :: GenParser ByteString () ByteString +nt_language = + do str <- liftM B.pack (many (satisfy (\ c -> c == '-' || isLower c))) + if B.null str || B.last str == '-' || B.head str == '-' + then fail ("Invalid language string: '" ++ B.unpack str ++ "'") + else return str + +-- nt_empty is a line that isn't a comment or a triple. They appear in the +-- parsed output as Nothing, whereas a real triple appears as (Just triple). +nt_empty :: GenParser ByteString () (Maybe Triple) +nt_empty = skipMany nt_space >> return Nothing + +-- A subject is either a URI reference for a resource or a node id for a +-- blank node. +nt_subject :: GenParser ByteString () Node +nt_subject = + liftM unode nt_uriref <|> + liftM bnode nt_nodeID + +-- A predicate may only be a URI reference to a resource. +nt_predicate :: GenParser ByteString () Node +nt_predicate = liftM unode nt_uriref + +-- An object may be either a resource (represented by a URI reference), +-- a blank node (represented by a node id), or an object literal. +nt_object :: GenParser ByteString () Node +nt_object = + liftM unode nt_uriref <|> + liftM bnode nt_nodeID <|> + liftM LNode nt_literal + +-- A URI reference is one or more nrab_character inside angle brackets. +nt_uriref :: GenParser ByteString () ByteString +nt_uriref = between_chars '<' '>' (liftM B.pack (many (satisfy ( /= '>')))) + +-- A node id is "_:" followed by a name. +nt_nodeID :: GenParser ByteString () ByteString +nt_nodeID = char '_' >> char ':' >> nt_name >>= \n -> + return ('_' `B.cons'` (':' `B.cons'` n)) + +-- A name is a letter followed by any number of alpha-numeric characters. +nt_name :: GenParser ByteString () ByteString +nt_name = + do init <- letter + rest <- many (satisfy isLetterOrDigit) + return $ B.pack (init:rest) + +isLetterOrDigit :: Char -> Bool +isLetterOrDigit c = isLetter c || isDigit c + +-- An nt_character is any character except a double quote character. +nt_character :: GenParser ByteString () Char +nt_character = satisfy is_nonquote_char + +-- A character is any Unicode value from ASCII space to decimal 126 (tilde). +is_character :: Char -> Bool +is_character c = c >= '\x0020' && c <= '\x007E' + +-- A non-quote character is a character that isn't the double-quote character. +is_nonquote_char :: Char -> Bool +is_nonquote_char c = is_character c && c/= '"' + +-- End-of-line consists of either lf or crlf. +-- We also test for eof and consider that to match as well. +nt_eoln :: GenParser ByteString () () +nt_eoln = eof <|> void (nt_cr >> nt_lf) <|> void nt_lf + +-- Whitespace is either a space or tab character. We must avoid using the +-- built-in space combinator here, because it includes newline. +nt_space :: GenParser ByteString () Char +nt_space = char ' ' <|> nt_tab + +-- Carriage return is \r. +nt_cr :: GenParser ByteString () Char +nt_cr = char '\r' + +-- Line feed is \n. +nt_lf :: GenParser ByteString () Char +nt_lf = char '\n' + +-- Tab is \t. +nt_tab :: GenParser ByteString () Char +nt_tab = char '\t' + +-- An inner_string is a fragment of a string (this is used inside double +-- quotes), and consists of the non-quote characters allowed and the +-- standard escapes for a backslash (\\), a tab (\t), a carriage return (\r), +-- a newline (\n), a double-quote (\"), a 4-digit Unicode escape (\uxxxx +-- where x is a hexadecimal digit), and an 8-digit Unicode escape +-- (\Uxxxxxxxx where x is a hexadecimaldigit). +inner_string :: GenParser ByteString () ByteString +inner_string = + try (char '\\' >> + ((char 't' >> return b_tab) <|> + (char 'r' >> return b_ret) <|> + (char 'n' >> return b_nl) <|> + (char '\\' >> return b_slash) <|> + (char '"' >> return b_quote) <|> + (char 'u' >> count 4 hexDigit >>= \cs -> return $ B.pack ('\\':'u':cs)) <|> + (char 'U' >> count 8 hexDigit >>= \cs -> return $ B.pack ('\\':'U':cs)))) + <|> liftM B.pack + (many (satisfy (\ c -> is_nonquote_char c && c /= '\\'))) + +b_tab = B.singleton '\t' +b_ret = B.singleton '\r' +b_nl = B.singleton '\n' +b_slash = B.singleton '\\' +b_quote = B.singleton '"' + +between_chars :: Char -> Char -> GenParser ByteString () ByteString -> GenParser ByteString () ByteString +between_chars start end parser = char start >> parser >>= \res -> char end >> return res + +parseString' :: forall rdf. (RDF rdf) => ByteString -> Either ParseFailure rdf +parseString' bs = handleParse mkRdf (runParser nt_ntripleDoc () "" bs) + +parseURL' :: forall rdf. (RDF rdf) => String -> IO (Either ParseFailure rdf) +parseURL' = _parseURL parseString' + +parseFile' :: forall rdf. (RDF rdf) => String -> IO (Either ParseFailure rdf) +parseFile' path = liftM (handleParse mkRdf . runParser nt_ntripleDoc () path) + (B.readFile path) + +handleParse :: forall rdf. (RDF rdf) => (Triples -> Maybe BaseUrl -> PrefixMappings -> rdf) -> + Either ParseError [Maybe Triple] -> + Either ParseFailure rdf +handleParse _mkRdf result +-- | B.length rem /= 0 = (Left $ ParseFailure $ "Invalid Document. Unparseable end of document: " ++ B.unpack rem) + | otherwise = + case result of + Left err -> Left $ ParseFailure $ "Parse failure: \n" ++ show err + Right ts -> Right $ _mkRdf (conv ts) Nothing (PrefixMappings Map.empty) + where + conv [] = [] + conv (Nothing:ts) = conv ts + conv (Just t:ts) = t : conv ts + +_test :: GenParser ByteString () a -> String -> IO a +_test p str = + case result of + (Left err) -> putStr "ParseError: '" >> putStr (show err) >> putStr "\n" >> error "" + (Right a) -> return a + where result = runParser p () "" (B.pack str) diff --git a/src/Text/RDF/RDF4H/NTriplesSerializer.hs b/src/Text/RDF/RDF4H/NTriplesSerializer.hs new file mode 100644 --- /dev/null +++ b/src/Text/RDF/RDF4H/NTriplesSerializer.hs @@ -0,0 +1,89 @@ +-- |A serializer for RDF as N-Triples +-- . + +module Text.RDF.RDF4H.NTriplesSerializer( + NTriplesSerializer(NTriplesSerializer) +) where + +import Data.RDF +import Data.RDF.Utils +import Data.ByteString.Lazy.Char8(ByteString) +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.ByteString.Lazy as BL +import Control.Monad (void) +import System.IO + + +data NTriplesSerializer = NTriplesSerializer + +instance RdfSerializer NTriplesSerializer where + hWriteRdf _ = _writeRdf + writeRdf _ = _writeRdf stdout + hWriteH _ _ _ = return () + writeH _ _ = return () + hWriteTs _ = _writeTriples + writeTs _ = _writeTriples stdout + hWriteT _ = _writeTriple + writeT _ = _writeTriple stdout + hWriteN _ = _writeNode + writeN _ = _writeNode stdout + +_writeRdf :: RDF rdf => Handle -> rdf -> IO () +_writeRdf h = _writeTriples h . triplesOf + +_writeTriples :: Handle -> Triples -> IO () +_writeTriples h = mapM_ (_writeTriple h) + +_writeTriple :: Handle -> Triple -> IO () +_writeTriple h (Triple s p o) = + _writeNode h s >> hPutChar h ' ' >> + _writeNode h p >> hPutChar h ' ' >> + _writeNode h o >> hPutStrLn h " ." + +_writeNode :: Handle -> Node -> IO () +_writeNode h node = + case node of + (UNode fs) -> hPutChar h '<' >> + hPutStrRev h (value fs) >> + hPutChar h '>' + (BNode gId) -> hPutStrRev h (value gId) + (BNodeGen i)-> putStr "_:genid" >> hPutStr h (show i) + (LNode n) -> _writeLValue h n + +_writeLValue :: Handle -> LValue -> IO () +_writeLValue h lv = + case lv of + (PlainL lit) -> _writeLiteralString h lit + (PlainLL lit lang) -> _writeLiteralString h lit >> + hPutStr h "@" >> + BL.hPutStr h lang + (TypedL lit dtype) -> _writeLiteralString h lit >> + hPutStr h "^^<" >> + hPutStrRev h (value dtype) >> + hPutStr h ">" + +-- TODO: this is REALLY slow. +_writeLiteralString:: Handle -> ByteString -> IO () +_writeLiteralString h bs = + do hPutChar h '"' + B.foldl' writeChar (return ()) bs + hPutChar h '"' + where + -- the seq is necessary in writeChar to ensure all chars + -- are written. without it, only the last is written. + writeChar :: IO () -> Char -> IO () + writeChar b c = b >>= \b' -> b' `seq` + case c of + '\n' -> void (hPutChar h '\\' >> hPutChar h 'n') + '\t' -> void (hPutChar h '\\' >> hPutChar h 't') + '\r' -> void (hPutChar h '\\' >> hPutChar h 'r') + '"' -> void (hPutChar h '\\' >> hPutChar h '"') + '\\' -> void (hPutChar h '\\' >> hPutChar h '\\') + _ -> void (hPutChar h c) + +_bs1, _bs2 :: ByteString +_bs1 = B.pack "\nthis \ris a \\U00015678long\t\nliteral\\uABCD\n" +_bs2 = B.pack "\nan \\U00015678 escape\n" + +_w :: IO () +_w = _writeLiteralString stdout _bs1 diff --git a/src/Text/RDF/RDF4H/ParserUtils.hs b/src/Text/RDF/RDF4H/ParserUtils.hs new file mode 100644 --- /dev/null +++ b/src/Text/RDF/RDF4H/ParserUtils.hs @@ -0,0 +1,46 @@ +module Text.RDF.RDF4H.ParserUtils( + _parseURL, justTriples +) where + +import Data.RDF + +import Network.URI +import Network.HTTP +import Data.Char(intToDigit) +import Data.ByteString.Lazy.Char8(ByteString) +import qualified Data.ByteString.Lazy.Char8 as B +import Data.Maybe (fromMaybe) + +-- A convenience function for terminating a parse with a parse failure, using +-- the given error message as the message for the failure. +errResult :: RDF rdf => String -> Either ParseFailure rdf +errResult msg = Left (ParseFailure msg) + +-- Keep the (Just t) triples (eliminating the Nothing comments), and unbox the +-- triples, leaving a list of triples. +justTriples :: [Maybe Triple] -> [Triple] +justTriples = map (fromMaybe (error "ParserUtils.justTriples")) . + filter (/= Nothing) + +_parseURL :: RDF rdf => (ByteString -> Either ParseFailure rdf) -> String -> IO (Either ParseFailure rdf) +_parseURL parseFunc url = + maybe + (return (Left (ParseFailure $ "Unable to parse URL: " ++ url))) + p + (parseURI url) + where + showRspCode (a, b, c) = map intToDigit [a, b, c] + httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp + p url = + simpleHTTP (request url) >>= \resp -> + case resp of + (Left e) -> return (errResult $ "couldn't retrieve from URL: " ++ show url ++ " [" ++ show e ++ "]") + (Right res) -> case rspCode res of + (2, 0, 0) -> return $ parseFunc (rspBody res) + _ -> return (errResult $ "couldn't retrieve from URL: " ++ httpError res) + +request :: URI -> HTTPRequest ByteString +request uri = Request { rqURI = uri, + rqMethod = GET, + rqHeaders = [Header HdrConnection "close"], + rqBody = B.empty } diff --git a/src/Text/RDF/RDF4H/TurtleParser.hs b/src/Text/RDF/RDF4H/TurtleParser.hs new file mode 100644 --- /dev/null +++ b/src/Text/RDF/RDF4H/TurtleParser.hs @@ -0,0 +1,597 @@ +-- |An 'RdfParser' implementation for the Turtle format +-- . + +module Text.RDF.RDF4H.TurtleParser( + TurtleParser(TurtleParser) +) + +where + +import Data.RDF +import Data.RDF.Namespace +import Text.RDF.RDF4H.ParserUtils +import Text.Parsec +import Text.Parsec.ByteString.Lazy +import qualified Data.Map as Map +import Data.ByteString.Lazy.Char8(ByteString) +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.ByteString.Lazy as BL +import Data.Sequence(Seq, (|>)) +import qualified Data.Sequence as Seq +import qualified Data.Foldable as F +import Data.Char (isDigit) +import Control.Monad +import Data.Maybe (fromMaybe) +import Debug.Trace(trace) + +-- To avoid compiler warnings when not being used. +_trace = trace + +-- |An 'RdfParser' implementation for parsing RDF in the +-- Turtle format. It takes optional arguments representing the base URL to use +-- for resolving relative URLs in the document (may be overridden in the document +-- itself using the \@base directive), and the URL to use for the document itself +-- for resolving references to <> in the document. +-- To use this parser, pass a 'TurtleParser' value as the first argument to any of +-- the 'parseString', 'parseFile', or 'parseURL' methods of the 'RdfParser' type +-- class. +data TurtleParser = TurtleParser (Maybe BaseUrl) (Maybe ByteString) + +-- |'TurtleParser' is an instance of 'RdfParser'. +instance RdfParser TurtleParser where + parseString (TurtleParser bUrl dUrl) = parseString' bUrl dUrl + parseFile (TurtleParser bUrl dUrl) = parseFile' bUrl dUrl + parseURL (TurtleParser bUrl dUrl) = parseURL' bUrl dUrl + +type ParseState = + (Maybe BaseUrl, -- the current BaseUrl, may be Nothing initially, but not after it is once set + Maybe ByteString, -- the docUrl, which never changes and is used to resolve <> in the document. + Int, -- the id counter, containing the value of the next id to be used + PrefixMappings, -- the mappings from prefix to URI that are encountered while parsing + [Subject], -- stack of current subject nodes, if we have parsed a subject but not finished the triple + [Predicate], -- stack of current predicate nodes, if we've parsed a predicate but not finished the triple + [Bool], -- a stack of values to indicate that we're processing a (possibly nested) collection; top True indicates just started (on first element) + Seq Triple) -- the triples encountered while parsing; always added to on the right side + +t_turtleDoc :: GenParser ByteString ParseState (Seq Triple, PrefixMappings) +t_turtleDoc = + many t_statement >> (eof "eof") >> getState >>= \(_, _, _, pms, _, _, _, ts) -> return (ts, pms) + +t_statement :: GenParser ByteString ParseState () +t_statement = d <|> t <|> void (many1 t_ws "blankline-whitespace") + where + d = void + (try t_directive >> (many t_ws "directive-whitespace1") >> + (char '.' "end-of-directive-period") >> + (many t_ws "directive-whitespace2")) + t = void + (t_triples >> (many t_ws "triple-whitespace1") >> + (char '.' "end-of-triple-period") >> + (many t_ws "triple-whitespace2")) + +t_triples :: GenParser ByteString ParseState () +t_triples = t_subject >> (many1 t_ws "subject-predicate-whitespace") >> t_predicateObjectList >> resetSubjectPredicate + +t_directive :: GenParser ByteString ParseState () +t_directive = t_prefixID <|> t_base + +t_resource :: GenParser ByteString ParseState ByteString +t_resource = try t_uriref <|> t_qname + +t_prefixID :: GenParser ByteString ParseState () +t_prefixID = + do try (string "@prefix" "@prefix-directive") + pre <- (many1 t_ws "whitespace-after-@prefix") >> option B.empty t_prefixName + char ':' >> (many1 t_ws "whitespace-after-@prefix-colon") + uriFrag <- t_uriref + (bUrl, dUrl, _, PrefixMappings pms, _, _, _, _) <- getState + updatePMs $ Just (PrefixMappings $ Map.insert pre (absolutizeUrl bUrl dUrl uriFrag) pms) + return () + +t_base :: GenParser ByteString ParseState () +t_base = + do try (string "@base" "@base-directive") + many1 t_ws "whitespace-after-@base" + urlFrag <- t_uriref + bUrl <- currBaseUrl + dUrl <- currDocUrl + updateBaseUrl (Just $ Just $ newBaseUrl bUrl (absolutizeUrl bUrl dUrl urlFrag)) + +t_verb :: GenParser ByteString ParseState () +t_verb = (try t_predicate <|> (char 'a' >> return rdfTypeNode)) >>= pushPred + +t_predicate :: GenParser ByteString ParseState Node +t_predicate = liftM (UNode . mkFastString) (t_resource "resource") + +t_nodeID :: GenParser ByteString ParseState ByteString +t_nodeID = do { try (string "_:"); cs <- t_name; return $! s2b "_:" `B.append` cs } + +t_qname :: GenParser ByteString ParseState ByteString +t_qname = + do pre <- option B.empty (try t_prefixName) + char ':' + name <- option B.empty t_name + (bUrl, _, _, pms, _, _, _, _) <- getState + return $ resolveQName bUrl pre pms `B.append` name + +t_subject :: GenParser ByteString ParseState () +t_subject = + simpleBNode <|> + resource <|> + nodeId <|> + between (char '[') (char ']') poList + where + resource = liftM (UNode . mkFastString) (t_resource "subject resource") >>= pushSubj + nodeId = liftM (BNode . mkFastString) (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 ws+ objectList ( ws* ';' ws* verb ws+ objectList )* (ws* ';')? +t_predicateObjectList :: GenParser ByteString ParseState () +t_predicateObjectList = + do t_verb "verb" -- pushes pred onto pred stack + many1 t_ws "polist-whitespace-after-verb" + t_objectList "polist-objectList" + many (try (many t_ws >> char ';') >> many t_ws >> t_verb >> many1 t_ws >> t_objectList >> popPred) + popPred -- pop off the predicate pushed by 1st t_verb + return () + +t_objectList :: GenParser ByteString ParseState () +t_objectList = -- t_object actually adds the triples + void + ((t_object "object") >> + many (try (many t_ws >> char ',' >> many t_ws >> t_object))) + +t_object :: GenParser ByteString ParseState () +t_object = + do inColl <- isInColl -- whether this object is in a collection + onFirstItem <- onCollFirstItem -- whether we're on the first item of the collection + let processObject = (t_literal >>= addTripleForObject) <|> + (liftM (UNode . mkFastString) t_resource >>= addTripleForObject) <|> + blank_as_obj <|> t_collection + case (inColl, onFirstItem) of + (False, _) -> processObject + (True, True) -> liftM BNodeGen nextIdCounter >>= \bSubj -> addTripleForObject bSubj >> + pushSubj bSubj >> pushPred rdfFirstNode >> processObject >> collFirstItemProcessed + (True, False) -> liftM BNodeGen nextIdCounter >>= \bSubj -> pushPred rdfRestNode >> + addTripleForObject bSubj >> popPred >> popSubj >> + pushSubj bSubj >> processObject + +-- collection: '(' ws* itemList? ws* ')' +-- itemList: object (ws+ object)* +t_collection:: GenParser ByteString ParseState () +t_collection = + -- ( object1 object2 ) is short for: + -- [ rdf:first object1; rdf:rest [ rdf:first object2; rdf:rest rdf:nil ] ] + -- ( ) is short for the resource: rdf:nil + between (char '(') (char ')') $ + do beginColl + many t_ws + emptyColl <- option True (try t_object >> many t_ws >> return False) + if emptyColl then void (addTripleForObject rdfNilNode) else + void + (many (many t_ws >> try t_object >> many t_ws) >> popPred >> + pushPred rdfRestNode >> + addTripleForObject rdfNilNode >> + popPred) + finishColl + return () + +blank_as_obj :: GenParser ByteString ParseState () +blank_as_obj = + -- if a node id, like _:a1, then create a BNode and add the triple + (liftM (BNode . mkFastString) t_nodeID >>= addTripleForObject) <|> + -- if a simple blank like [], do likewise + (genBlank >>= addTripleForObject) <|> + -- if a blank containing a predicateObjectList, like [ :b :c; :b :d ] + poList + where + genBlank = liftM BNodeGen (try (string "[]") >> nextIdCounter) + poList = between (char '[') (char ']') $ + liftM BNodeGen nextIdCounter >>= \bSubj -> -- generate new bnode + void + (addTripleForObject bSubj >> -- add triple with bnode as object + many t_ws >> pushSubj bSubj >> -- push bnode as new subject + t_predicateObjectList >> popSubj >> many t_ws) -- process polist, which uses bnode as subj, then pop bnode + + +rdfTypeNode, rdfNilNode, rdfFirstNode, rdfRestNode :: Node +rdfTypeNode = UNode $ mkFastString $ mkUri rdf $ s2b "type" +rdfNilNode = UNode $ mkFastString $ mkUri rdf $ s2b "nil" +rdfFirstNode = UNode $ mkFastString $ mkUri rdf $ s2b "first" +rdfRestNode = UNode $ mkFastString $ mkUri rdf $ s2b "rest" + +xsdIntUri, xsdDoubleUri, xsdDecimalUri, xsdBooleanUri :: FastString +xsdIntUri = mkFastString $! mkUri xsd $! s2b "integer" +xsdDoubleUri = mkFastString $! mkUri xsd $! s2b "double" +xsdDecimalUri = mkFastString $! mkUri xsd $! s2b "decimal" +xsdBooleanUri = mkFastString $! mkUri xsd $! s2b "boolean" + +t_literal :: GenParser ByteString ParseState Node +t_literal = + try str_literal <|> + liftM (`mkLNode` xsdIntUri) (try t_integer) <|> + liftM (`mkLNode` xsdDoubleUri) (try t_double) <|> + liftM (`mkLNode` xsdDecimalUri) (try t_decimal) <|> + liftM (`mkLNode` xsdBooleanUri) t_boolean + where + mkLNode :: ByteString -> FastString -> Node + mkLNode bs fs = LNode (typedL bs fs) + +str_literal :: GenParser ByteString ParseState Node +str_literal = + do str <- t_quotedString "quotedString" + liftM (LNode . typedL str . mkFastString) + (try (count 2 (char '^')) >> t_resource) <|> + liftM (lnode . plainLL str) (char '@' >> t_language) <|> + return (lnode $ plainL str) + +t_quotedString :: GenParser ByteString ParseState ByteString +t_quotedString = t_longString <|> t_string + +-- a non-long string: any number of scharacters (echaracter without ") inside doublequotes. +t_string :: GenParser ByteString ParseState ByteString +t_string = liftM B.concat (between (char '"') (char '"') (many t_scharacter)) + +t_longString :: GenParser ByteString ParseState ByteString +t_longString = + do + try tripleQuote + strVal <- liftM B.concat (many longString_char) + tripleQuote + return strVal + where + tripleQuote = count 3 (char '"') + +t_integer :: GenParser ByteString ParseState ByteString +t_integer = + do sign <- sign_parser "+-" + ds <- many1 digit "digit" + notFollowedBy (char '.') + -- integer must be in canonical format, with no leading plus sign or leading zero + return $! (s2b sign `B.append` s2b ds) + +t_double :: GenParser ByteString ParseState ByteString +t_double = + do sign <- sign_parser "+-" + rest <- try (do { ds <- many1 digit "digit"; char '.'; ds' <- many digit "digit"; e <- t_exponent "exponent"; return (s2b ds `B.snoc` '.' `B.append` s2b ds' `B.append` e) }) <|> + try (do { char '.'; ds <- many1 digit "digit"; e <- t_exponent "exponent"; return ('.' `B.cons` s2b ds `B.append` e) }) <|> + try (do { ds <- many1 digit "digit"; e <- t_exponent "exponent"; return (s2b ds `B.append` e) }) + return $! s2b sign `B.append` rest + +sign_parser :: GenParser ByteString ParseState String +sign_parser = option "" (oneOf "-+" >>= (\c -> return [c])) + +t_decimal :: GenParser ByteString ParseState ByteString +t_decimal = + do sign <- sign_parser + rest <- try (do ds <- many digit "digit"; char '.'; ds' <- option "" (many digit); return (ds ++ ('.':ds'))) + <|> try (do { char '.'; ds <- many1 digit "digit"; return ('.':ds) }) + <|> many1 digit "digit" + return $ s2b sign `B.append` s2b rest + +t_exponent :: GenParser ByteString ParseState ByteString +t_exponent = do e <- oneOf "eE" + s <- option "" (oneOf "-+" >>= \c -> return [c]) + ds <- many1 digit; + return $! (e `B.cons` (s2b s `B.append` s2b ds)) + +t_boolean :: GenParser ByteString ParseState ByteString +t_boolean = + try (liftM s2b (string "true") <|> + liftM s2b (string "true")) + +t_comment :: GenParser ByteString ParseState () +t_comment = + void (char '#' >> many (satisfy (\ c -> c /= '\n' && c /= '\r'))) + +t_ws :: GenParser ByteString ParseState () +t_ws = + (void (try (char '\t' <|> char '\n' <|> char '\r' <|> char ' ')) + <|> try t_comment) + "whitespace-or-comment" + + +t_language :: GenParser ByteString ParseState ByteString +t_language = + do init <- many1 lower; + rest <- many (do {char '-'; cs <- many1 (lower <|> digit); return (s2b ('-':cs))}) + return $! (s2b init `B.append` B.concat rest) + +identifier :: GenParser ByteString ParseState Char -> GenParser ByteString ParseState Char -> GenParser ByteString ParseState ByteString +identifier initial rest = initial >>= \i -> many rest >>= \r -> return (s2b (i:r)) + +t_prefixName :: GenParser ByteString ParseState ByteString +t_prefixName = identifier t_nameStartCharMinusUnderscore t_nameChar + +t_name :: GenParser ByteString ParseState ByteString +t_name = identifier t_nameStartChar t_nameChar + +t_uriref :: GenParser ByteString ParseState ByteString +t_uriref = between (char '<') (char '>') t_relativeURI + +t_relativeURI :: GenParser ByteString ParseState ByteString +t_relativeURI = + do frag <- liftM (B.pack . concat) (many t_ucharacter) + bUrl <- currBaseUrl + dUrl <- currDocUrl + return $ absolutizeUrl bUrl dUrl frag + +-- We make this String rather than ByteString because we want +-- t_relativeURI (the only place it's used) to have chars so that +-- when it creates a ByteString it can all be in one chunk. +t_ucharacter :: GenParser ByteString ParseState String +t_ucharacter = + try (liftM B.unpack unicode_escape) <|> + try (string "\\>") <|> + liftM B.unpack (non_ctrl_char_except ">") + +t_nameChar :: GenParser ByteString ParseState Char +t_nameChar = t_nameStartChar <|> char '-' <|> char '\x00B7' <|> satisfy f + where + f = flip in_range [('0', '9'), ('\x0300', '\x036F'), ('\x203F', '\x2040')] + +longString_char :: GenParser ByteString ParseState ByteString +longString_char = + specialChar <|> -- \r|\n|\t as single char + try escapedChar <|> -- an backslash-escaped tab, newline, linefeed, backslash or doublequote + try twoDoubleQuote <|> -- two doublequotes not followed by a doublequote + try oneDoubleQuote <|> -- a single doublequote + safeNonCtrlChar <|> -- anything but a single backslash or doublequote + try unicode_escape -- a unicode escape sequence (\uxxxx or \Uxxxxxxxx) + where + specialChar = oneOf "\t\n\r" >>= bs1 + escapedChar = + do char '\\' + (char 't' >> bs1 '\t') <|> (char 'n' >> bs1 '\n') <|> (char 'r' >> bs1 '\r') <|> + (char '\\' >> bs1 '\\') <|> (char '"' >> bs1 '"') + twoDoubleQuote = string "\"\"" >> notFollowedBy (char '"') >> bs "\"\"" + oneDoubleQuote = char '"' >> notFollowedBy (char '"') >> bs1 '"' + safeNonCtrlChar = non_ctrl_char_except "\\\"" + +bs1 :: Char -> GenParser ByteString ParseState ByteString +bs1 = return . B.singleton + +bs :: String -> GenParser ByteString ParseState ByteString +bs = return . B.pack + +t_nameStartChar :: GenParser ByteString ParseState Char +t_nameStartChar = char '_' <|> t_nameStartCharMinusUnderscore + +t_nameStartCharMinusUnderscore :: GenParser ByteString ParseState Char +t_nameStartCharMinusUnderscore = try $ satisfy $ flip in_range blocks + where + blocks = [('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')] + +t_hex :: GenParser ByteString ParseState Char +t_hex = satisfy (\c -> isDigit c || (c >= 'A' && c <= 'F')) "hexadecimal digit" + +-- characters used in (non-long) strings; any echaracters except ", or an escaped \" +-- echaracter - #x22 ) | '\"' +t_scharacter :: GenParser ByteString ParseState ByteString +t_scharacter = + (try (string "\\\"") >> return (B.singleton '"')) + <|> try (do {char '\\'; + (char 't' >> return (B.singleton '\t')) <|> + (char 'n' >> return (B.singleton '\n')) <|> + (char 'r' >> return (B.singleton '\r'))}) -- echaracter part 1 + <|> unicode_escape + <|> (non_ctrl_char_except "\\\"" >>= \s -> return $! s) -- echaracter part 2 minus " + +unicode_escape :: GenParser ByteString ParseState ByteString +unicode_escape = + (char '\\' >> return (B.singleton '\\')) >> + ((char '\\' >> return (s2b "\\\\")) <|> + (char 'u' >> count 4 t_hex >>= \cs -> return $! s2b "\\u" `B.append` s2b cs) <|> + (char 'U' >> count 8 t_hex >>= \cs -> return $! s2b "\\U" `B.append` s2b cs)) + +non_ctrl_char_except :: String -> GenParser ByteString ParseState ByteString +non_ctrl_char_except cs = + liftM B.singleton + (satisfy (\ c -> c <= '\1114111' && (c >= ' ' && c `notElem` cs))) + +{-# INLINE in_range #-} +in_range :: Char -> [(Char, Char)] -> Bool +in_range c = any (\(c1, c2) -> c >= c1 && c <= c2) + +-- Resolve a prefix using the given prefix mappings and base URL. If the prefix is +-- empty, then the base URL will be used if there is a base URL and if the map +-- does not contain an entry for the empty prefix. +resolveQName :: Maybe BaseUrl -> ByteString -> PrefixMappings -> ByteString +resolveQName mbaseUrl prefix (PrefixMappings pms') = + case (mbaseUrl, B.null prefix) of + (Just (BaseUrl base), True) -> Map.findWithDefault base BL.empty pms' + (Nothing, True) -> err1 + (_, _ ) -> Map.findWithDefault err2 prefix pms' + where + err1 = error "Cannot resolve empty QName prefix to a Base URL." + err2 = error ("Cannot resolve QName prefix: " ++ B.unpack prefix) + +-- Resolve a URL fragment found on the right side of a prefix mapping by converting it to an absolute URL if possible. +absolutizeUrl :: Maybe BaseUrl -> Maybe ByteString -> ByteString -> ByteString +absolutizeUrl mbUrl mdUrl urlFrag = + if isAbsoluteUri urlFrag then urlFrag else + (case (mbUrl, mdUrl) of + (Nothing, Nothing) -> urlFrag + (Just (BaseUrl bUrl), Nothing) -> bUrl `B.append` urlFrag + (Nothing, Just dUrl) -> if isHash urlFrag then + dUrl `B.append` urlFrag else urlFrag + (Just (BaseUrl bUrl), Just dUrl) -> (if isHash urlFrag then dUrl + else bUrl) + `B.append` urlFrag) + where + isHash bs = B.length bs == 1 && B.head bs == '#' + +{-# INLINE isAbsoluteUri #-} +isAbsoluteUri :: ByteString -> Bool +isAbsoluteUri = B.elem ':' + +newBaseUrl :: Maybe BaseUrl -> ByteString -> BaseUrl +newBaseUrl Nothing url = BaseUrl url +newBaseUrl (Just (BaseUrl bUrl)) url = BaseUrl $! mkAbsoluteUrl bUrl url + +{-# INLINE mkAbsoluteUrl #-} +-- Make an absolute URL by returning as is if already an absolute URL and otherwise +-- appending the URL to the given base URL. +mkAbsoluteUrl :: ByteString -> ByteString -> ByteString +mkAbsoluteUrl base url = + if isAbsoluteUri url then url else base `B.append` url + +currBaseUrl :: GenParser ByteString ParseState (Maybe BaseUrl) +currBaseUrl = getState >>= \(bUrl, _, _, _, _, _, _, _) -> return bUrl + +currDocUrl :: GenParser ByteString ParseState (Maybe ByteString) +currDocUrl = getState >>= \(_, dUrl, _, _, _, _, _, _) -> return dUrl + +pushSubj :: Subject -> GenParser ByteString ParseState () +pushSubj s = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, ts) -> + setState (bUrl, dUrl, i, pms, s:ss, ps, cs, ts) + +popSubj :: GenParser ByteString ParseState Subject +popSubj = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, ts) -> + setState (bUrl, dUrl, i, pms, tail ss, ps, cs, ts) >> + when (null ss) (error "Cannot pop subject off empty stack.") >> + return (head ss) + +pushPred :: Predicate -> GenParser ByteString ParseState () +pushPred p = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, ts) -> + setState (bUrl, dUrl, i, pms, ss, p:ps, cs, ts) + +popPred :: GenParser ByteString ParseState Predicate +popPred = getState >>= \(bUrl, dUrl, i, pms, ss, ps, cs, ts) -> + setState (bUrl, dUrl, i, pms, ss, tail ps, cs, ts) >> + when (null ps) (error "Cannot pop predicate off empty stack.") >> + -- _trace (show ps) (return ()) >> + return (head ps) + +isInColl :: GenParser ByteString ParseState Bool +isInColl = getState >>= \(_, _, _, _, _, _, cs, _) -> return . not . null $ cs + +updateBaseUrl :: Maybe (Maybe BaseUrl) -> GenParser ByteString ParseState () +updateBaseUrl val = _modifyState val no no no no no + +-- combines get_current and increment into a single function +nextIdCounter :: GenParser ByteString ParseState Int +nextIdCounter = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, ts) -> + setState (bUrl, dUrl, i+1, pms, s, p, cs, ts) >> return i + +updatePMs :: Maybe PrefixMappings -> GenParser ByteString ParseState () +updatePMs val = _modifyState no no val no no no + +-- Register that we have begun processing a collection +beginColl :: GenParser ByteString ParseState () +beginColl = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, ts) -> + setState (bUrl, dUrl, i, pms, s, p, True:cs, ts) + +onCollFirstItem :: GenParser ByteString ParseState Bool +onCollFirstItem = getState >>= \(_, _, _, _, _, _, cs, _) -> return (not (null cs) && head cs) + +collFirstItemProcessed :: GenParser ByteString ParseState () +collFirstItemProcessed = getState >>= \(bUrl, dUrl, i, pms, s, p, _:cs, ts) -> + setState (bUrl, dUrl, i, pms, s, p, False:cs, ts) + +-- Register that a collection is finished being processed; the bool value +-- in the monad is *not* the value that was popped from the stack, but whether +-- we are still processing a parent collection or have finished processing +-- all collections and are no longer in a collection at all. +finishColl :: GenParser ByteString ParseState Bool +finishColl = getState >>= \(bUrl, dUrl, i, pms, s, p, cs, ts) -> + let cs' = drop 1 cs + in setState (bUrl, dUrl, i, pms, s, p, cs', ts) >> return (not $ null cs') + +-- Alias for Nothing for use with _modifyState calls, which can get very long with +-- many Nothing values. +no :: Maybe a +no = Nothing + +-- Update the subject and predicate values of the ParseState to Nothing. +resetSubjectPredicate :: GenParser ByteString ParseState () +resetSubjectPredicate = + getState >>= \(bUrl, dUrl, n, pms, _, _, cs, ts) -> + setState (bUrl, dUrl, n, pms, [], [], cs, ts) + +-- Modifies the current parser state by updating any state values among the parameters +-- that have non-Nothing values. +_modifyState :: Maybe (Maybe BaseUrl) -> Maybe (Int -> Int) -> Maybe PrefixMappings -> + Maybe Subject -> Maybe Predicate -> Maybe (Seq Triple) -> + GenParser ByteString ParseState () +_modifyState mb_bUrl mb_n mb_pms mb_subj mb_pred mb_trps = + do (_bUrl, _dUrl, _n, _pms, _s, _p, _cs, _ts) <- getState + setState (fromMaybe _bUrl mb_bUrl, + _dUrl, + maybe _n (const _n) mb_n, + fromMaybe _pms mb_pms, + maybe _s (: _s) mb_subj, + maybe _p (: _p) mb_pred, + _cs, + fromMaybe _ts mb_trps) + +addTripleForObject :: Object -> GenParser ByteString ParseState () +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 + when (null ps) $ + error $ "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@ +-- as the base URI, and using the given document URL as the URI of the Turtle document itself. +-- +-- The @BaseUrl@ is used as the base URI within the document for resolving any relative URI references. +-- It may be changed within the document using the @\@base@ directive. At any given point, the current +-- base URI is the most recent @\@base@ directive, or if none, the @BaseUrl@ given to @parseURL@, or +-- if none given, the document URL given to @parseURL@. For example, if the @BaseUrl@ were +-- @http:\/\/example.org\/@ and a relative URI of @\@ were encountered (with no preceding @\@base@ +-- directive), then the relative URI would expand to @http:\/\/example.org\/b@. +-- +-- The 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. +--p +-- Returns either a @ParseFailure@ or a new RDF containing the parsed triples. +parseURL' :: forall rdf. (RDF rdf) => + Maybe BaseUrl -- ^ The optional base URI of the document. + -> Maybe ByteString -- ^ The document URI (i.e., the URI of the document itself); if Nothing, use location URI. + -> String -- ^ The location URI from which to retrieve the Turtle document. + -> IO (Either ParseFailure rdf) + -- ^ The parse result, which is either a @ParseFailure@ or the RDF + -- corresponding to the Turtle document. +parseURL' bUrl docUrl = _parseURL (parseString' bUrl docUrl) + +-- |Parse the given file as a Turtle document. The arguments and return type have the same semantics +-- as 'parseURL', except that the last @String@ argument corresponds to a filesystem location rather +-- than a location URI. +-- +-- Returns either a @ParseFailure@ or a new RDF containing the parsed triples. +parseFile' :: forall rdf. (RDF rdf) => Maybe BaseUrl -> Maybe ByteString -> String -> IO (Either ParseFailure rdf) +parseFile' bUrl docUrl fpath = + B.readFile fpath >>= \bs -> return $ handleResult bUrl (runParser t_turtleDoc initialState (maybe "" B.unpack docUrl) bs) + where initialState = (bUrl, docUrl, 1, PrefixMappings Map.empty, [], [], [], Seq.empty) + +-- |Parse the given string as a Turtle document. The arguments and return type have the same semantics +-- as , except that the last @String@ argument corresponds to the Turtle document itself as +-- a a string rather than a location URI. +parseString' :: forall rdf. (RDF rdf) => Maybe BaseUrl -> Maybe ByteString -> ByteString -> Either ParseFailure rdf +parseString' bUrl docUrl ttlStr = handleResult bUrl (runParser t_turtleDoc initialState "" ttlStr) + where initialState = (bUrl, docUrl, 1, PrefixMappings Map.empty, [], [], [], Seq.empty) + +handleResult :: RDF rdf => Maybe BaseUrl -> Either ParseError (Seq Triple, PrefixMappings) -> Either ParseFailure rdf +handleResult bUrl result = + case result of + (Left err) -> Left (ParseFailure $ show err) + (Right (ts, pms)) -> Right $! mkRdf (F.toList ts) bUrl pms + +_testParseState :: ParseState +_testParseState = (Nothing, Nothing, 1, PrefixMappings Map.empty, [], [], [], Seq.empty) diff --git a/src/Text/RDF/RDF4H/TurtleSerializer.hs b/src/Text/RDF/RDF4H/TurtleSerializer.hs new file mode 100644 --- /dev/null +++ b/src/Text/RDF/RDF4H/TurtleSerializer.hs @@ -0,0 +1,185 @@ +-- |An RDF serializer for Turtle +-- . + +module Text.RDF.RDF4H.TurtleSerializer( + TurtleSerializer(TurtleSerializer) +) + +where + +import Data.RDF +import Data.RDF.Namespace +import Data.RDF.Utils + +import Data.ByteString.Lazy.Char8(ByteString) +import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.ByteString.Lazy as BL +import Data.Map(Map) +import qualified Data.Map as Map +import Data.List +import Control.Monad +import System.IO +import Debug.Trace(trace) + +-- Defined so that there are no compiler warnings when trace is not used. +_debug = trace + +data TurtleSerializer = TurtleSerializer (Maybe ByteString) PrefixMappings + +instance RdfSerializer TurtleSerializer where + hWriteRdf (TurtleSerializer docUrl pms) h rdf = _writeRdf h docUrl (addPrefixMappings rdf pms False) + writeRdf s = hWriteRdf s stdout + hWriteH (TurtleSerializer _ pms) h rdf = writeHeader h (baseUrl rdf) (mergePrefixMappings (prefixMappings rdf) pms) + writeH s = hWriteRdf s stdout + -- TODO: should use mdUrl to render <> where appropriate + hWriteTs (TurtleSerializer docUrl pms) h = writeTriples h docUrl pms + writeTs s = hWriteTs s stdout + hWriteT (TurtleSerializer docUrl pms) h = writeTriple h docUrl pms + writeT s = hWriteT s stdout + hWriteN (TurtleSerializer docUrl (PrefixMappings pms)) h n = writeNode h docUrl n pms + writeN s = hWriteN s stdout + +-- TODO: writeRdf currently merges standard namespace prefix mappings with +-- the ones that the RDF already contains, so that if the RDF has none +-- (e.g., was parsed from ntriples RDF) the output still uses prefix for +-- common mappings like rdf, owl, and the like. This behavior should be +-- configurable somehow, so that if the user really doesn't want any extra +-- prefix declarations added, that is possible. + +_writeRdf :: RDF rdf => Handle -> Maybe ByteString -> rdf -> IO () +_writeRdf h mdUrl rdf = + writeHeader h bUrl pms' >> writeTriples h mdUrl pms' ts >> hPutChar h '\n' + where + bUrl = baseUrl rdf + -- a merged set of prefix mappings using those from the standard_ns_mappings + -- that are not defined already (union is left-biased). + pms' = PrefixMappings $ Map.union (asMap $ prefixMappings rdf) (asMap standard_ns_mappings) + asMap (PrefixMappings x) = x + ts = triplesOf rdf + +writeHeader :: Handle -> Maybe BaseUrl -> PrefixMappings -> IO () +writeHeader h bUrl pms = writeBase h bUrl >> writePrefixes h pms + +writeBase :: Handle -> Maybe BaseUrl -> IO () +writeBase _ Nothing = + return () +writeBase h (Just (BaseUrl bUrl)) = + hPutStr h "@base " >> hPutChar h '<' >> BL.hPutStr h bUrl >> hPutStr h "> ." >> hPutChar h '\n' + +writePrefixes :: Handle -> PrefixMappings -> IO () +writePrefixes h pms = mapM_ (writePrefix h) (toPMList pms) >> hPutChar h '\n' + +writePrefix :: Handle -> (ByteString, ByteString) -> IO () +writePrefix h (pre, uri) = + hPutStr h "@prefix " >> BL.hPutStr h pre >> hPutStr h ": " >> + hPutChar h '<' >> BL.hPutStr h uri >> hPutStr h "> ." >> hPutChar h '\n' + +-- We don't really use the map as a map yet, but we reverse the map anyway so that +-- it maps from uri to prefix rather than the usual prefix to uri, since we never need +-- to look anything up by prefix, where as we do use the uri for determining which +-- prefix to use. +writeTriples :: Handle -> Maybe ByteString -> PrefixMappings -> Triples -> IO () +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 + +writeTriple :: Handle -> Maybe ByteString -> PrefixMappings -> Triple -> IO () +writeTriple h mdUrl (PrefixMappings pms) t = + w subjectOf >> space >> w predicateOf >> space >> w objectOf + where + w :: (Triple -> Node) -> IO () + w f = writeNode h mdUrl (f t) pms + space = hPutChar h ' ' + +-- Write a group of triples that all have the same subject, with the subject only +-- being output once, and comma or semi-colon used as appropriate. +writeSubjGroup :: Handle -> Maybe ByteString -> Map ByteString ByteString -> Triples -> IO () +writeSubjGroup _ _ _ [] = return () +writeSubjGroup h dUrl pms ts@(t:_) = + writeNode h dUrl (subjectOf t) pms >> hPutChar h ' ' >> + writePredGroup h dUrl pms (head ts') >> + mapM_ (\t -> hPutStr h ";\n\t" >> writePredGroup h dUrl pms t) (tail ts') >> + hPutStrLn h " ." + where + ts' = groupBy equalPredicates ts + +-- Write a group of triples that all have the same subject and the same predicate, +-- assuming the subject has already been output and only the predicate and objects +-- need to be written. +writePredGroup :: Handle -> Maybe ByteString -> Map ByteString ByteString -> 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), + -- so we pass the docUrl through to writeNode in all cases. + writeNode h docUrl (predicateOf t) pms >> hPutChar h ' ' >> + writeNode h docUrl (objectOf t) pms >> + mapM_ (\t -> hPutStr h ", " >> writeNode h docUrl (objectOf t) pms) ts + +writeNode :: Handle -> Maybe ByteString -> Node -> Map ByteString ByteString -> IO () +writeNode h mdUrl node prefixes = + case node of + (UNode fs) -> let currUri = B.reverse $ value fs + in case mdUrl of + Nothing -> writeUNodeUri h currUri prefixes + Just url -> if url == currUri then hPutStr h "<>" else writeUNodeUri h currUri prefixes + (BNode gId) -> hPutStrRev h (value gId) + (BNodeGen i)-> putStr "_:genid" >> hPutStr h (show i) + (LNode n) -> writeLValue h n prefixes + +writeUNodeUri :: Handle -> ByteString -> Map ByteString ByteString -> IO () +writeUNodeUri h uri prefixes = + case mapping of + Nothing -> hPutChar h '<' >> BL.hPutStr h uri >> hPutChar h '>' + (Just (pre, localName)) -> BL.hPutStr h pre >> hPutChar h ':' >> BL.hPutStr h localName + where + mapping = findMapping prefixes uri + +-- Print prefix mappings to stdout for debugging. +_debugPMs :: Map ByteString ByteString -> IO () +_debugPMs pms = mapM_ (\(k, v) -> B.putStr k >> putStr "__" >> B.putStrLn v) (Map.toList pms) + +-- Expects a map from uri to prefix, and returns the (prefix, uri_expansion) +-- from the mappings such that uri_expansion is a prefix of uri, or Nothing if +-- 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 ByteString ByteString -> ByteString -> Maybe (ByteString, ByteString) +findMapping pms uri = + case mapping of + Nothing -> Nothing + Just (u, p) -> Just (p, B.drop (B.length u) uri) -- empty localName is permitted + where + mapping = find (\(k, _) -> B.isPrefixOf k uri) (Map.toList pms) + +--_testPms = Map.fromList [(s2b "http://example.com/ex#", s2b "eg")] + +writeLValue :: Handle -> LValue -> Map ByteString ByteString -> IO () +writeLValue h lv pms = + case lv of + (PlainL lit) -> writeLiteralString h lit + (PlainLL lit lang) -> writeLiteralString h lit >> + hPutStr h "@" >> + BL.hPutStr h lang + (TypedL lit dtype) -> writeLiteralString h lit >> + hPutStr h "^^" >> + writeUNodeUri h (B.reverse $ value dtype) pms + +writeLiteralString:: Handle -> ByteString -> IO () +writeLiteralString h bs = + do hPutChar h '"' + B.foldl' writeChar (return True) bs + hPutChar h '"' + where + writeChar :: IO Bool -> Char -> IO Bool + writeChar b c = + case c of + '\n' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h 'n') >> return True + '\t' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h 't') >> return True + '\r' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h 'r') >> return True + '"' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h '"') >> return True + '\\' -> b >>= \b' -> when b' (hPutChar h '\\' >> hPutChar h '\\') >> return True + _ -> b >>= \b' -> when b' (hPutChar h c) >> return True + +--subj1 = unode $ s2b "http://example.com/subj" +--pred1 = unode $ s2b "http://example.com/pred" +--obj1 = typedL (s2b "hello, world") (mkFastString $ makeUri xsd $ s2b "") diff --git a/src/Text/RDF/RDF4H/XmlParser.hs b/src/Text/RDF/RDF4H/XmlParser.hs new file mode 100644 --- /dev/null +++ b/src/Text/RDF/RDF4H/XmlParser.hs @@ -0,0 +1,242 @@ +-- |An parser for the RDF/XML format +-- . + +module Text.RDF.RDF4H.XmlParser( + parseXmlRDF, getRDF +) where + +import Data.RDF +import qualified Data.Map as Map +import Control.Arrow +import Text.XML.HXT.Core +import Data.ByteString.Lazy.Char8(ByteString) +import Data.String.Utils + +-- TODO: Create instance: +-- RdfParse XmlParser + +-- |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) + +-- |Parse a xml ByteString to an RDF representation +parseXmlRDF :: forall rdf. (RDF rdf) + => Maybe BaseUrl -- ^ The base URL for the RDF if required + -> Maybe ByteString -- ^ DocUrl: The request URL for the RDF if available + -> ByteString -- ^ The contents to parse + -> Either ParseFailure rdf -- ^ 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 (xread >>> addMetaData bUrl dUrl >>> getRDF) initState (b2s 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 ByteString -> 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" (b2s dUrl) ] + mkSource Nothing = [] + mkBase (Just (BaseUrl bUrl)) = [ sattr "transfer-URI" (b2s 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 +getRDF = proc xml -> do + rdf <- hasName "rdf:RDF" <<< isElem <<< getChildren -< xml + bUrl <- arr (BaseUrl . s2b) <<< ((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) -> (s2b (drop 6 n), s2b m)) . filter (startswith "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 -< (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")) >>> 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 . s2b) + replaceLiElems acc n (Triple s p o : rest) | p == (unode . s2b) "rdf:li" = + replaceLiElems (Triple s ((unode . s2b) ("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 . s2b) 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, ArrowState GParseState a) => LParseState -> a XmlTree Triple +parsePredicatesFromAttr state = getAttrl + >>> (getName >>> neg isMetaAttr >>> mkUNode) &&& (getChildren >>> getText >>> arr (lnode . plainL . s2b)) + >>> arr (attachSubject (stateSubject state)) + +-- | Arrow to determine if special processing is required for an attribute +isMetaAttr :: forall a. (ArrowXml a, ArrowState GParseState a) => a String String +isMetaAttr = isA (== "rdf:about") + <+> isA (== "rdf:nodeID") + <+> isA (== "rdf:ID") + <+> isA (== "xml:lang") + <+> isA (== "rdf:parseType") + +-- |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 + >>> choiceA + [ second (hasAttrValue "rdf:parseType" (== "Literal")) :-> arr2A parseAsLiteralTriple + , second (hasAttrValue "rdf:parseType" (== "Resource")) :-> (defaultA <+> (mkBlankNode &&& arr id >>> arr2A parseAsResource)) + , 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") :-> arr2A getNodeIdTriple + , second (hasAttr "rdf:ID") :-> (arr2A mkRelativeNode &&& defaultA >>> arr2A reifyTriple >>> unlistA) + , second hasPredicateAttr :-> (defaultA <+> (mkBlankNode &&& arr id >>> arr2A parsePredicateAttr)) + , this :-> defaultA + ] + where defaultA = proc (state, predXml) -> do + p <- arr(unode . s2b) <<< getName -< predXml + t <- arr2A (arr2A . parseObjectsFromChildren) <<< second (second getChildren) -< (state, (p, predXml)) + returnA -< t + parsePredicateAttr n = (second getName >>> arr (\(s, p) -> Triple (stateSubject s) ((unode . s2b) p) n)) + <+> (first (arr (\s -> s { stateSubject = n })) >>> arr2A parsePredicatesFromAttr) + hasPredicateAttr = getAttrl >>> neg (getName >>> isMetaAttr) + +parseObjectsFromChildren :: forall a. (ArrowXml a, ArrowState GParseState a) + => LParseState -> Predicate -> a XmlTree Triple +parseObjectsFromChildren s p = choiceA + [ isText :-> (getText >>> arr (Triple (stateSubject s) p . mkLiteralNode s)) + , isElem :-> (hasName "rdf:Description" >>> parseObjectDescription) + ] + where parseObjectDescription = proc desc -> do + 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, ArrowState GParseState 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, ArrowState GParseState 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 . s2b) base } ) ) &&& arr id + +-- |Read a Triple with an rdf:parseType of Literal +parseAsLiteralTriple :: forall a. (ArrowXml a, ArrowState GParseState a) => LParseState -> a XmlTree Triple +parseAsLiteralTriple state = (nameToUNode &&& (xshow getChildren >>> arr (mkTypedLiteralNode rdfXmlLiteral))) + >>> arr (attachSubject (stateSubject state)) + +mkCollectionTriples :: forall a. (ArrowXml a, ArrowState GParseState 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, ArrowState GParseState a) => LParseState -> a XmlTree Triple +getTypedTriple state = nameToUNode &&& (attrExpandURI state "rdf:datatype" &&& xshow getChildren >>> arr (\(t, v) -> mkTypedLiteralNode (mkFastString (s2b t)) v)) + >>> arr (attachSubject (stateSubject state)) + +getResourceTriple :: forall a. (ArrowXml a, ArrowState GParseState a) + => LParseState -> a XmlTree Triple +getResourceTriple state = nameToUNode &&& (attrExpandURI state "rdf:resource" >>> mkUNode) + >>> arr (attachSubject (stateSubject state)) + +getNodeIdTriple :: forall a. (ArrowXml a, ArrowState GParseState a) + => LParseState -> a XmlTree Triple +getNodeIdTriple state = nameToUNode &&& (getAttrValue "rdf:nodeID" >>> arr (bnode . s2b)) + >>> 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 . s2b)) + , hasAttr "rdf:ID" :-> mkRelativeNode state + , this :-> mkBlankNode + ] + +rdfXmlLiteral = (mkFastString . s2b) "http://www.w3.org/1999/02/22-rdf-syntax-ns#XMLLiteral" +rdfFirst = (unode . s2b) "rdf:first" +rdfRest = (unode . s2b) "rdf:rest" +rdfNil = (unode . s2b) "rdf:nil" +rdfType = (unode . s2b) "rdf:type" +rdfStatement = (unode . s2b) "rdf:Statement" +rdfSubject = (unode . s2b) "rdf:subject" +rdfPredicate = (unode . s2b) "rdf:predicate" +rdfObject = (unode . s2b) "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 >>> expandURI + where baseUrl = constA (case stateBaseUrl state of BaseUrl b -> b2s b) + +-- |Make a UNode from an absolute string +mkUNode :: forall a. (Arrow a) => a String Node +mkUNode = arr (unode . s2b) + +-- |Make a UNode from a rdf:ID element, expanding relative URIs +mkRelativeNode :: forall a. (ArrowXml a, ArrowState GParseState a) => LParseState -> a XmlTree Node +mkRelativeNode s = (getAttrValue "rdf:ID" >>> arr (\x -> '#':x)) &&& baseUrl + >>> expandURI >>> arr (unode . s2b) + where baseUrl = constA (case stateBaseUrl s of BaseUrl b -> b2s b) + +-- |Make a literal node with the given type and content +mkTypedLiteralNode :: FastString -> String -> Node +mkTypedLiteralNode t content = lnode (typedL (s2b content) t) + +-- |Use the given state to create a literal node +mkLiteralNode :: LParseState -> String -> Node +mkLiteralNode (LParseState _ (Just lang) _) content = lnode (plainLL (s2b content) (s2b lang)) +mkLiteralNode (LParseState _ Nothing _) content = (lnode . plainL . s2b) 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) + diff --git a/testsuite/tests/Test.hs b/testsuite/tests/Test.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/Test.hs @@ -0,0 +1,17 @@ +module Main where + +import Test.Framework (defaultMain) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Text.RDF.RDF4H.TurtleParser_ConformanceTest as TurtleParser +import qualified Data.RDF.TriplesGraph_Test as TriplesGraph +import qualified Data.RDF.MGraph_Test as MGraph +import qualified Text.RDF.RDF4H.XmlParser_Test as XmlParser + +main :: IO () +main = defaultMain ( TriplesGraph.tests + ++ MGraph.tests + -- ++ TurtleParser.test -- TODO: Implement TurtleParses `tests' + ++ XmlParser.tests + ) +