diff --git a/rdf4h.cabal b/rdf4h.cabal --- a/rdf4h.cabal +++ b/rdf4h.cabal @@ -1,5 +1,5 @@ name: rdf4h -version: 1.1.0 +version: 1.2.0 synopsis: A library for RDF processing in Haskell description: 'RDF for Haskell' is a library for working with RDF in Haskell. @@ -19,7 +19,7 @@ build-type: Simple category: RDF stability: Experimental -tested-with: GHC==7.6.1 +tested-with: GHC==7.6.3 extra-tmp-files: test flag small_base @@ -54,15 +54,13 @@ , network >= 2.2.0.0 , HTTP >= 4000.0.0 , hxt >= 9.0.0 - , MissingH >= 1.2.0.0 , text other-modules: Data.RDF.Utils , Text.RDF.RDF4H.ParserUtils , Text.RDF.RDF4H.Interact hs-source-dirs: src extensions: BangPatterns RankNTypes MultiParamTypeClasses Arrows FlexibleContexts OverloadedStrings - ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures -funbox-strict-fields -fno-warn-unused-do-bind - + ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields executable rdf4h main-is: Rdf4hParseMain.hs @@ -74,18 +72,16 @@ , network >= 2.2.0.0 , HTTP >= 4000.0.0 , hxt >= 9.0.0 - , MissingH >= 1.2.0.0 , containers , text hs-source-dirs: src extensions: BangPatterns RankNTypes ScopedTypeVariables MultiParamTypeClasses OverloadedStrings - ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures -funbox-strict-fields -fno-warn-unused-do-bind - + ghc-options: -Wall -fno-warn-unused-do-bind -funbox-strict-fields 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 + ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-name-shadowing -funbox-strict-fields extensions: RankNTypes MultiParamTypeClasses Arrows FlexibleContexts OverloadedStrings build-depends: base >= 4 && < 6 , parsec >= 3 @@ -96,11 +92,11 @@ , network >= 2.2.0.0 , QuickCheck >= 1.2.0.0 , HUnit >= 1.2.2.1 - , MissingH >= 1.2.0.0 , bytestring , hxt , containers , text + , knob other-modules: Data.RDF , Data.RDF.Namespace , Data.RDF.MGraph diff --git a/src/Data/RDF/MGraph.hs b/src/Data/RDF/MGraph.hs --- a/src/Data/RDF/MGraph.hs +++ b/src/Data/RDF/MGraph.hs @@ -4,6 +4,7 @@ where +import Prelude hiding (pred) import Data.RDF.Types import Data.RDF.Query import Data.RDF.Namespace @@ -50,21 +51,21 @@ type SPOMap = Map Subject AdjacencyMap baseUrl' :: MGraph -> Maybe BaseUrl -baseUrl' (MGraph (_, baseUrl, _)) = baseUrl +baseUrl' (MGraph (_, baseURL, _)) = baseURL prefixMappings' :: MGraph -> PrefixMappings prefixMappings' (MGraph (_, _, pms)) = pms addPrefixMappings' :: MGraph -> PrefixMappings -> Bool -> MGraph -addPrefixMappings' (MGraph (ts, baseUrl, pms)) pms' replace = +addPrefixMappings' (MGraph (ts, baseURL, pms)) pms' replace = let merge = if replace then flip mergePrefixMappings else mergePrefixMappings - in MGraph (ts, baseUrl, merge pms pms') + 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) +mkRdf' ts baseURL pms = MGraph (mergeTs Map.empty ts, baseURL, pms) mergeTs :: SPOMap -> [Triple] -> SPOMap mergeTs = foldl' mergeT @@ -75,19 +76,17 @@ 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 + (if p `Map.member` adjs then Map.insert s addPredObj m + else Map.insert s addNewPredObjMap m) + else Map.insert s newPredMap 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)) + newPredMap :: Map Predicate (Set Object) + newPredMap = Map.singleton p (Set.singleton o) + addNewPredObjMap :: Map Predicate (Set Object) + addNewPredObjMap = Map.insert p (Set.singleton o) adjs + addPredObj :: Map Predicate (Set Object) + addPredObj = Map.insert p (Set.insert o (get p adjs)) adjs get :: Ord k => k -> Map k v -> v get = Map.findWithDefault undefined diff --git a/src/Data/RDF/Query.hs b/src/Data/RDF/Query.hs --- a/src/Data/RDF/Query.hs +++ b/src/Data/RDF/Query.hs @@ -12,8 +12,9 @@ ) where -import Data.RDF.Types +import Prelude hiding (pred) import Data.List +import Data.RDF.Types -- |Answer the given list of triples in sorted order. sortTriples :: Triples -> Triples @@ -111,8 +112,8 @@ 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 +expandTriples' acc baseURL prefixMaps (t:rest) = expandTriples' (normalize baseURL prefixMaps t : acc) baseURL prefixMaps rest + where normalize baseURL' prefixMaps' = expandPrefixes prefixMaps' . expandBaseUrl baseURL' + expandBaseUrl (Just _) triple' = triple' + expandBaseUrl Nothing triple' = triple' + expandPrefixes _ triple' = triple' diff --git a/src/Data/RDF/TriplesGraph.hs b/src/Data/RDF/TriplesGraph.hs --- a/src/Data/RDF/TriplesGraph.hs +++ b/src/Data/RDF/TriplesGraph.hs @@ -12,10 +12,11 @@ where -import Data.RDF.Types -import Data.RDF.Query -import Data.RDF.Namespace +import Prelude hiding (pred) import qualified Data.Map as Map +import Data.RDF.Namespace +import Data.RDF.Query +import Data.RDF.Types -- |A simple implementation of the 'RDF' type class that represents -- the graph internally as a list of triples. @@ -55,12 +56,12 @@ prefixMappings' (TriplesGraph (_, _, pms)) = pms addPrefixMappings' :: TriplesGraph -> PrefixMappings -> Bool -> TriplesGraph -addPrefixMappings' (TriplesGraph (ts, baseUrl, pms)) pms' replace = +addPrefixMappings' (TriplesGraph (ts, baseURL, pms)) pms' replace = let merge = if replace then flip mergePrefixMappings else mergePrefixMappings - in TriplesGraph (ts, baseUrl, merge pms pms') + in TriplesGraph (ts, baseURL, merge pms pms') baseUrl' :: TriplesGraph -> Maybe BaseUrl -baseUrl' (TriplesGraph (_, baseUrl, _)) = baseUrl +baseUrl' (TriplesGraph (_, baseURL, _)) = baseURL empty' :: TriplesGraph empty' = TriplesGraph ([], Nothing, PrefixMappings Map.empty) @@ -70,7 +71,7 @@ -- 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) +mkRdf' ts baseURL pms = TriplesGraph (ts, baseURL, pms) triplesOf' :: TriplesGraph -> Triples triplesOf' (TriplesGraph (ts, _, _)) = ts diff --git a/src/Data/RDF/Types.hs b/src/Data/RDF/Types.hs --- a/src/Data/RDF/Types.hs +++ b/src/Data/RDF/Types.hs @@ -31,6 +31,7 @@ ) where +import Prelude hiding (pred) import qualified Data.Text as T import System.IO import Text.Printf diff --git a/src/Text/RDF/RDF4H/Interact.hs b/src/Text/RDF/RDF4H/Interact.hs --- a/src/Text/RDF/RDF4H/Interact.hs +++ b/src/Text/RDF/RDF4H/Interact.hs @@ -16,7 +16,7 @@ import qualified Data.Text as T -import Data.RDF.Types +import Data.RDF.Types hiding (baseUrl) import Data.RDF.Utils() import Data.RDF.TriplesGraph() import Data.RDF.MGraph() diff --git a/src/Text/RDF/RDF4H/NTriplesParser.hs b/src/Text/RDF/RDF4H/NTriplesParser.hs --- a/src/Text/RDF/RDF4H/NTriplesParser.hs +++ b/src/Text/RDF/RDF4H/NTriplesParser.hs @@ -5,6 +5,7 @@ NTriplesParser(NTriplesParser), ParseFailure ) where +import Prelude hiding (init,pred) import Data.RDF.Types import Text.RDF.RDF4H.ParserUtils import Data.Char(isLetter, isDigit, isLower) @@ -187,6 +188,7 @@ <|> liftM T.pack (many (satisfy (\ c -> is_nonquote_char c && c /= '\\'))) +b_tab, b_ret, b_nl, b_slash, b_quote :: T.Text b_tab = T.singleton '\t' b_ret = T.singleton '\r' b_nl = T.singleton '\n' diff --git a/src/Text/RDF/RDF4H/NTriplesSerializer.hs b/src/Text/RDF/RDF4H/NTriplesSerializer.hs --- a/src/Text/RDF/RDF4H/NTriplesSerializer.hs +++ b/src/Text/RDF/RDF4H/NTriplesSerializer.hs @@ -5,15 +5,13 @@ NTriplesSerializer(NTriplesSerializer) ) where +import Control.Monad (void) import Data.RDF.Types import Data.RDF.Utils import qualified Data.Text as T -import Data.Text.Encoding -import qualified Data.ByteString as B -import Control.Monad (void) +import qualified Data.Text.IO as T import System.IO - data NTriplesSerializer = NTriplesSerializer instance RdfSerializer NTriplesSerializer where @@ -44,7 +42,7 @@ _writeNode h node = case node of (UNode bs) -> hPutChar h '<' >> - hPutStrRev h bs >> + T.hPutStr h bs >> hPutChar h '>' (BNode gId) -> hPutStrRev h gId (BNodeGen i)-> putStr "_:genid" >> hPutStr h (show i) @@ -56,10 +54,10 @@ (PlainL lit) -> _writeLiteralString h lit (PlainLL lit lang) -> _writeLiteralString h lit >> hPutStr h "@" >> - B.hPutStr h (encodeUtf8 lang) + T.hPutStr h lang (TypedL lit dtype) -> _writeLiteralString h lit >> hPutStr h "^^<" >> - hPutStrRev h dtype >> + T.hPutStr h dtype >> hPutStr h ">" -- TODO: this is REALLY slow. diff --git a/src/Text/RDF/RDF4H/ParserUtils.hs b/src/Text/RDF/RDF4H/ParserUtils.hs --- a/src/Text/RDF/RDF4H/ParserUtils.hs +++ b/src/Text/RDF/RDF4H/ParserUtils.hs @@ -7,8 +7,6 @@ import Network.URI import Network.HTTP import Data.Char(intToDigit) --- import Data.ByteString.Lazy.Char8(ByteString) --- import qualified Data.ByteString as B import Data.Text.Encoding (decodeUtf8) import qualified Data.ByteString.Char8 as B import qualified Data.Text as T @@ -34,10 +32,10 @@ where showRspCode (a, b, c) = map intToDigit [a, b, c] httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp - p url = - simpleHTTP (request url) >>= \resp -> + p url' = + simpleHTTP (request url') >>= \resp -> case resp of - (Left e) -> return (errResult $ "couldn't retrieve from URL: " ++ show url ++ " [" ++ show e ++ "]") + (Left e) -> return (errResult $ "couldn't retrieve from URL: " ++ show url' ++ " [" ++ show e ++ "]") (Right res) -> case rspCode res of (2, 0, 0) -> return $ parseFunc (decodeUtf8 (rspBody res)) _ -> return (errResult $ "couldn't retrieve from URL: " ++ httpError res) diff --git a/src/Text/RDF/RDF4H/TurtleParser.hs b/src/Text/RDF/RDF4H/TurtleParser.hs --- a/src/Text/RDF/RDF4H/TurtleParser.hs +++ b/src/Text/RDF/RDF4H/TurtleParser.hs @@ -215,7 +215,7 @@ liftM (`mkLNode` xsdBooleanUri) t_boolean where mkLNode :: T.Text -> T.Text -> Node - mkLNode bsType bs = LNode (typedL bsType bs) + mkLNode bsType bs' = LNode (typedL bsType bs') str_literal :: GenParser ParseState Node str_literal = @@ -293,9 +293,9 @@ t_language :: GenParser ParseState T.Text t_language = - do init <- many1 lower; + do initial <- many1 lower; rest <- many (do {char '-'; cs <- many1 (lower <|> digit); return ( s2t ('-':cs))}) - return $! ( s2t init `T.append` T.concat rest) + return $! ( s2t initial `T.append` T.concat rest) identifier :: GenParser ParseState Char -> GenParser ParseState Char -> GenParser ParseState T.Text identifier initial rest = initial >>= \i -> many rest >>= \r -> return ( s2t (i:r)) @@ -425,7 +425,7 @@ else bUrl) `T.append` urlFrag) where - isHash bs = T.length bs == 1 && T.head bs == '#' + isHash bs' = T.length bs' == 1 && T.head bs' == '#' {-# INLINE isAbsoluteUri #-} isAbsoluteUri :: T.Text -> Bool @@ -572,7 +572,7 @@ -- Returns either a @ParseFailure@ or a new RDF containing the parsed triples. parseFile' :: forall rdf. (RDF rdf) => Maybe BaseUrl -> Maybe T.Text -> String -> IO (Either ParseFailure rdf) parseFile' bUrl docUrl fpath = - TIO.readFile fpath >>= \bs -> return $ handleResult bUrl (runParser t_turtleDoc initialState (maybe "" t2s docUrl) bs) + TIO.readFile fpath >>= \bs' -> return $ handleResult bUrl (runParser t_turtleDoc initialState (maybe "" t2s 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 diff --git a/src/Text/RDF/RDF4H/TurtleSerializer.hs b/src/Text/RDF/RDF4H/TurtleSerializer.hs --- a/src/Text/RDF/RDF4H/TurtleSerializer.hs +++ b/src/Text/RDF/RDF4H/TurtleSerializer.hs @@ -9,10 +9,11 @@ import Data.RDF.Types import Data.RDF.Query -import Data.RDF.Namespace +import Data.RDF.Namespace hiding (rdf) import Data.RDF.Utils import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.IO as T import qualified Data.ByteString.Char8 as B import Data.Map(Map) import qualified Data.Map as Map @@ -95,7 +96,7 @@ 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') >> + mapM_ (\t' -> hPutStr h ";\n\t" >> writePredGroup h dUrl pms t') (tail ts') >> hPutStrLn h " ." where ts' = groupBy equalPredicates ts @@ -110,7 +111,7 @@ -- 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 + mapM_ (\t' -> hPutStr h ", " >> writeNode h docUrl (objectOf t') pms) ts writeNode :: Handle -> Maybe T.Text -> Node -> Map T.Text T.Text -> IO () writeNode h mdUrl node prefixes = @@ -155,7 +156,7 @@ (PlainL lit) -> writeLiteralString h lit (PlainLL lit lang) -> writeLiteralString h lit >> hPutStr h "@" >> - B.hPutStr h (encodeUtf8 lang) + T.hPutStr h lang (TypedL lit dtype) -> writeLiteralString h lit >> hPutStr h "^^" >> writeUNodeUri h (T.reverse dtype) pms diff --git a/src/Text/RDF/RDF4H/XmlParser.hs b/src/Text/RDF/RDF4H/XmlParser.hs --- a/src/Text/RDF/RDF4H/XmlParser.hs +++ b/src/Text/RDF/RDF4H/XmlParser.hs @@ -1,3 +1,5 @@ +{-# Language Arrows #-} + -- |An parser for the RDF/XML format -- . @@ -5,13 +7,14 @@ parseXmlRDF, getRDF ) where -import Data.RDF.Types -import Data.RDF.Utils -import qualified Data.Map as Map -import Control.Arrow -import Text.XML.HXT.Core -import qualified Data.Text as T -import Data.String.Utils +import Control.Arrow (Arrow,(>>>),(<<<),(&&&),(***),arr,returnA) +import Control.Arrow.ArrowState (ArrowState,nextState) +import Data.List (isPrefixOf) +import qualified Data.Map as Map (fromList) +import Data.RDF.Types (RDF,Node(BNodeGen),BaseUrl(..),Triple(..),Triples,Subject,Predicate,Object,PrefixMappings(..),ParseFailure(ParseFailure),mkRdf,lnode,plainL,plainLL,typedL,unode,bnode) +import Data.RDF.Utils (s2t,t2s) +import qualified Data.Text as T (Text) +import Text.XML.HXT.Core (ArrowXml,XmlTree,IfThen((:->)),(>.),(>>.),first,neg,(<+>),expandURI,getName,getAttrValue,getAttrValue0,getAttrl,hasAttrValue,hasAttr,constA,choiceA,getChildren,ifA,arr2A,second,hasName,isElem,xshow,listA,isA,isText,getText,this,unlistA,orElse,sattr,mkelem,xread,runSLA) -- TODO: Create instance: -- RdfParse XmlParser @@ -62,7 +65,7 @@ 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) -> (s2t (drop 6 n), s2t m)) . filter (startswith "xmlns:" . fst) + toPrefixMap = PrefixMappings . Map.fromList . map (\(n, m) -> (s2t (drop 6 n), s2t m)) . filter (isPrefixOf "xmlns:" . fst) -- |Read the initial state from an rdf element parseDescription' :: forall a. (ArrowXml a, ArrowState GParseState a) => a (BaseUrl, XmlTree) Triple @@ -138,7 +141,7 @@ ] where parseObjectDescription = proc desc -> do o <- mkNode s -< desc - t0 <- arr (\(sub, (p, o)) -> Triple sub p o) -< (stateSubject s, (p, o)) + 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 @@ -178,7 +181,7 @@ -- |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 ( (s2t t)) v)) +getTypedTriple state = nameToUNode &&& (attrExpandURI state "rdf:datatype" &&& xshow getChildren >>> arr (\(t, v) -> mkTypedLiteralNode (s2t t) v)) >>> arr (attachSubject (stateSubject state)) getResourceTriple :: forall a. (ArrowXml a, ArrowState GParseState a) @@ -200,7 +203,10 @@ , this :-> mkBlankNode ] -rdfXmlLiteral = (s2t) "http://www.w3.org/1999/02/22-rdf-syntax-ns#XMLLiteral" +rdfXmlLiteral :: T.Text +rdfFirst,rdfRest,rdfNil,rdfType,rdfStatement,rdfSubject,rdfPredicate,rdfObject :: Node + +rdfXmlLiteral = s2t "http://www.w3.org/1999/02/22-rdf-syntax-ns#XMLLiteral" rdfFirst = (unode . s2t) "rdf:first" rdfRest = (unode . s2t) "rdf:rest" rdfNil = (unode . s2t) "rdf:nil"