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)
_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
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
_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
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'
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 ' '
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
writePredGroup :: Handle -> Maybe ByteString -> Map ByteString ByteString -> Triples -> IO ()
writePredGroup _ _ _ [] = return ()
writePredGroup h docUrl pms (t:ts) =
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
_debugPMs :: Map ByteString ByteString -> IO ()
_debugPMs pms = mapM_ (\(k, v) -> B.putStr k >> putStr "__" >> B.putStrLn v) (Map.toList pms)
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)
where
mapping = find (\(k, _) -> B.isPrefixOf k uri) (Map.toList pms)
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