swish 0.8.0.0 → 0.8.0.2
raw patch · 7 files changed
+686/−798 lines, 7 filesdep ~directorydep ~hashable
Dependency ranges changed: directory, hashable
Files
- README +47/−6
- src/Swish/RDF/Formatter/Internal.hs +427/−12
- src/Swish/RDF/Formatter/N3.hs +90/−355
- src/Swish/RDF/Formatter/NTriples.hs +13/−61
- src/Swish/RDF/Formatter/Turtle.hs +86/−359
- src/Swish/RDF/Graph.hs +4/−2
- swish.cabal +19/−3
README view
@@ -1,9 +1,50 @@-This is an update to Swish [1,2] so that it builds with a recent-Haskell platform. -For more information on this release see [3].+# Introduction - [1] http://www.ninebynine.org/Software/Swish-0.2.0.html- [2] http://www.ninebynine.org/RDFNotes/Swish/Intro.html- [2] https://bitbucket.org/doug_burke/swish/wiki/Home+Swish - which stands for Semantic Web Inference Scripting in Haskell -+was written by Graham Klyne as a framework, written in the purely+functional programming language Haskell, for performing deductions in+RDF data using a variety of techniques. Swish wass conceived as a+toolkit for experimenting with RDF inference, and for implementing+stand-alone RDF file processors (usable in similar style to CWM, but+with a view to being extensible in declarative style through added+Haskell function and data value declarations). One of the aims was to+explore Haskell as "a scripting language for the Semantic Web"+(http://www.ninebynine.org/RDFNotes/Swish/Intro.html). +It was updated from version 0.2.1 by Vasili I Galchin so that it would+build with recent version of GHC+(http://hackage.haskell.org/package/swish-0.2.1).++Since then it has been updated to take advantage of recent+developments in the Haskell ecosystem, add support for the NTriples+and Turtle serialisation formats, and a number of convenience+functions. Development is done at+https://bitbucket.org/doug_burke/swish/.++# Aim++Current development is based on my own needs, which are more about+using this as a RDF library for I/O with limited querying rather than+for inferencing or use as a flexible graph-processing library+(e.g. for extensions to non-RDF models).++# Haskell and the Semantic Web ++Other Haskell packages for RDF support include++ * rdf4h http://hackage.haskell.org/package/rdf4h+ * hsparql http://hackage.haskell.org/package/hsparql+ * hasparql-client http://hackage.haskell.org/package/hasparql-client++# Installation++Install a recent version of the Haskell platform (http://hackage.haskell.org/platform/)+and then try++ % cabal update+ % cabal install swish++This will install a command-line tool `Swish` along with the modules+in the `Swish` namespace; documentation can be found at+http://hackage.haskell.org/package/swish .
src/Swish/RDF/Formatter/Internal.hs view
@@ -20,23 +20,60 @@ module Swish.RDF.Formatter.Internal ( NodeGenLookupMap+ , SLens(..) , SubjTree , PredTree , LabelContext(..) , NodeGenState(..)+ , changeState+ , hasMore , emptyNgs + , getBNodeLabel , findMaxBnode+ , splitOnLabel , getCollection , processArcs , findPrefix+ -- N3-like formatting+ , quoteB+ , quoteText+ , showScopedName+ , formatScopedName+ , formatPrefixLines+ , formatPlainLit+ , formatLangLit+ , formatTypedLit+ , insertList+ , nextLine_+ , mapBlankNode_+ , formatPrefixes_+ , formatGraph_+ , formatSubjects_+ , formatProperties_+ , formatObjects_+ , insertBnode_+ , extractList_ ) where import Swish.GraphClass (Arc(..), ArcSet)+import Swish.Namespace (ScopedName, getScopeLocal, getScopeURI)+import Swish.QName (getLName)+ import Swish.RDF.Graph (RDFGraph, RDFLabel(..), NamespaceMap)-import Swish.RDF.Graph (labels, getArcs, resRdfFirst, resRdfRest, resRdfNil)+import Swish.RDF.Graph (labels, getArcs+ , getNamespaces+ , resRdfFirst, resRdfRest, resRdfNil+ , quote+ , quoteT+ )+import Swish.RDF.Vocabulary (LanguageTag, fromLangTag, xsdBoolean, xsdDecimal, xsdInteger, xsdDouble) -import Data.List (delete, foldl', groupBy)+import Control.Monad (liftM)+import Control.Monad.State (State, get, gets, modify, put)++import Data.List (delete, foldl', groupBy, intersperse, partition)+import Data.Monoid (Monoid(..), mconcat) import Data.Word import Network.URI (URI)@@ -44,6 +81,8 @@ import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as B #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 701) import Data.Tuple (swap)@@ -55,34 +94,97 @@ findPrefix :: URI -> M.Map a URI -> Maybe a findPrefix u = M.lookup u . M.fromList . map swap . M.assocs +{- ++Playing around with ideas to reduce the amount of duplicated code+without (for instance) deciding on one of the many lens packages+available. It does not seem worth further re-factoring until we+have another formatter using a turtle-like syntax (e.g. TriG+http://www4.wiwiss.fu-berlin.de/bizer/trig/).++-}++data SLens a b = SLens (a -> b) (a -> b -> a)++-- | Extract the setter.+slens :: SLens a b -> a -> b -> a+slens (SLens _ s) = s++-- | Extract the getter.+glens :: SLens a b -> a -> b+glens (SLens g _) = g+ -- | Node name generation state information that carries through -- and is updated by nested formulae. type NodeGenLookupMap = M.Map RDFLabel Word32 +{-+TODO: look at using Swish.Graphpartition instead.+-} type SubjTree lb = [(lb,PredTree lb)] type PredTree lb = [(lb,[lb])] --- simple context for label creation--- (may be a temporary solution to the problem--- of label creation)+-- | The context for label creation. -- data LabelContext = SubjContext | PredContext | ObjContext deriving (Eq, Show) +-- | A generator for BNode labels. data NodeGenState = Ngs- { prefixes :: NamespaceMap- , nodeMap :: NodeGenLookupMap+ { nodeMap :: NodeGenLookupMap , nodeGen :: Word32 } +-- | Create an empty node generator. emptyNgs :: NodeGenState-emptyNgs = Ngs- { prefixes = M.empty- , nodeMap = M.empty- , nodeGen = 0- }+emptyNgs = Ngs M.empty 0 {-|+Get the label text for the blank node, creating a new one+if it has not been seen before.++The label text is currently _:swish<number> where number is+1 or higher. This format may be changed in the future.+-}+getBNodeLabel :: RDFLabel -> NodeGenState -> (B.Builder, Maybe NodeGenState)+getBNodeLabel lab ngs = + let cmap = nodeMap ngs+ cval = nodeGen ngs++ (lnum, mngs) = + case M.findWithDefault 0 lab cmap of+ 0 -> let nval = succ cval+ nmap = M.insert lab nval cmap+ in (nval, Just (ngs { nodeGen = nval, nodeMap = nmap }))++ n -> (n, Nothing)++ in ("_:swish" `mappend` B.fromString (show lnum), mngs)+++{-|+Process the state, returning a value extracted from it+after updating the state.+-}++changeState ::+ (a -> (b, a)) -> State a b+changeState f = do+ st <- get+ let (rval, nst) = f st+ put nst+ return rval++{-|+Apply the function to the state and return True+if the result is not empty.+-}++hasMore :: (a -> [b]) -> State a Bool+hasMore lens = (not . null . lens) `liftM` get+++{-| Removes the first occurrence of the item from the association list, returning it's contents and the rest of the list, if it exists.@@ -191,6 +293,16 @@ _ -> 0 getAutoBnodeIndex _ = 0 +splitOnLabel :: + (Eq a) => a -> SubjTree a -> (SubjTree a, PredTree a)+splitOnLabel lbl osubjs = + let (bsubj, rsubjs) = partition ((== lbl) . fst) osubjs+ rprops = case bsubj of+ [(_, rs)] -> rs+ _ -> []+ in (rsubjs, rprops)+ + {- Find all blank nodes that occur - any number of times as a subject@@ -227,6 +339,309 @@ ctr orig (Arc _ p o) = inc (incP orig p) o +-- N3-like output++-- temporary conversion+quoteB :: Bool -> String -> B.Builder+quoteB f v = B.fromString $ quote f v++{-|+Convert text into a format for display in Turtle. The idea+is to use one double quote unless three are needed, and to+handle adding necessary @\\@ characters, or conversion+for Unicode characters.+-}+quoteText :: T.Text -> B.Builder+quoteText txt = + let st = T.unpack txt -- TODO: fix+ qst = quoteB (n==1) st+ n = if '\n' `elem` st || '"' `elem` st then 3 else 1+ qch = B.fromString (replicate n '"')+ in mconcat [qch, qst, qch]++-- TODO: need to be a bit more clever with this than we did in NTriples+-- not sure the following counts as clever enough ...+-- +showScopedName :: ScopedName -> B.Builder+showScopedName = quoteB True . show++formatScopedName :: ScopedName -> M.Map (Maybe T.Text) URI -> B.Builder+formatScopedName sn prmap =+ let nsuri = getScopeURI sn+ local = getLName $ getScopeLocal sn+ in case findPrefix nsuri prmap of+ Just (Just p) -> B.fromText $ quoteT True $ mconcat [p, ":", local]+ _ -> mconcat [ "<"+ , quoteB True (show nsuri ++ T.unpack local)+ , ">"+ ]++formatPlainLit :: T.Text -> B.Builder+formatPlainLit = quoteText++formatLangLit :: T.Text -> LanguageTag -> B.Builder+formatLangLit lit lcode = mconcat [quoteText lit, "@", B.fromText (fromLangTag lcode)]++-- The canonical notation for xsd:double in XSD, with an upper-case E,+-- does not match the syntax used in N3, so we need to convert here. +-- Rather than converting back to a Double and then displaying that +-- we just convert E to e for now. +-- +formatTypedLit :: T.Text -> ScopedName -> B.Builder+formatTypedLit lit dtype+ | dtype == xsdDouble = B.fromText $ T.toLower lit+ | dtype `elem` [xsdBoolean, xsdDecimal, xsdInteger] = B.fromText lit+ | otherwise = mconcat [quoteText lit, "^^", showScopedName dtype]+ + +{-+Add a list inline. We are given the labels that constitute+the list, in order, so just need to display them surrounded+by ().+-}+insertList ::+ (RDFLabel -> State a B.Builder)+ -> [RDFLabel]+ -> State a B.Builder+insertList _ [] = return "()" -- QUS: can this happen in a valid graph?+insertList f xs = do+ ls <- mapM f xs+ return $ mconcat ("( " : intersperse " " ls) `mappend` " )" ++nextLine_ ::+ (a -> B.Builder) -- ^ indentation+ -> SLens a Bool -- ^ line break lens+ -> B.Builder -> State a B.Builder+nextLine_ indent _lineBreak str = do+ ind <- gets indent+ brk <- gets $ glens _lineBreak+ if brk+ then return $ ind `mappend` str+ else do+ -- After first line, always insert line break+ modify $ \st -> slens _lineBreak st True+ return str++mapBlankNode_ :: SLens a NodeGenState -> RDFLabel -> State a B.Builder+mapBlankNode_ _nodeGen lab = do+ ngs <- gets $ glens _nodeGen+ let (lval, mngs) = getBNodeLabel lab ngs+ case mngs of+ Just ngs' -> modify $ \st -> slens _nodeGen st ngs'+ _ -> return ()+ return lval++formatPrefixLines :: NamespaceMap -> [B.Builder]+formatPrefixLines = map pref . M.assocs+ where+ pref (Just p,u) = mconcat ["@prefix ", B.fromText p, ": <", quoteB True (show u), "> ."]+ pref (_,u) = mconcat ["@prefix : <", quoteB True (show u), "> ."]++formatPrefixes_ ::+ (B.Builder -> State a B.Builder) -- ^ Create a new line+ -> NamespaceMap+ -> State a B.Builder+formatPrefixes_ nextLine pmap = + mconcat `liftM` mapM nextLine (formatPrefixLines pmap)++formatGraph_ :: + (B.Builder -> State a ()) -- set indent+ -> (Bool -> State a ()) -- set line-break flag+ -> (RDFGraph -> a -> a) -- create a new state from the graph+ -> (NamespaceMap -> State a B.Builder) -- format prefixes+ -> (a -> SubjTree RDFLabel) -- get the subjects+ -> State a B.Builder -- format the subjects+ -> B.Builder -- indentation string+ -> B.Builder -- text to be placed after final statement+ -> Bool -- True if a line break is to be inserted at the start+ -> Bool -- True if prefix strings are to be generated+ -> RDFGraph -- graph to convert+ -> State a B.Builder+formatGraph_ setIndent setLineBreak newState formatPrefixes subjs formatSubjects ind end dobreak dopref gr = do+ setIndent ind+ setLineBreak dobreak+ modify (newState gr)+ + fp <- if dopref+ then formatPrefixes (getNamespaces gr)+ else return mempty+ more <- hasMore subjs+ if more+ then do+ fr <- formatSubjects+ return $ mconcat [fp, fr, end]+ else return fp++formatSubjects_ ::+ State a RDFLabel -- ^ next subject+ -> (LabelContext -> RDFLabel -> State a B.Builder) -- ^ convert label into text+ -> (a -> PredTree RDFLabel) -- ^ extract properties+ -> (RDFLabel -> B.Builder -> State a B.Builder) -- ^ format properties+ -> (a -> SubjTree RDFLabel) -- ^ extract subjects+ -> (B.Builder -> State a B.Builder) -- ^ next line+ -> State a B.Builder+formatSubjects_ nextSubject formatLabel props formatProperties subjs nextLine = do+ sb <- nextSubject+ sbstr <- formatLabel SubjContext sb+ + flagP <- hasMore props+ if flagP+ then do+ prstr <- formatProperties sb sbstr+ flagS <- hasMore subjs+ if flagS+ then do+ fr <- formatSubjects_ nextSubject formatLabel props formatProperties subjs nextLine+ return $ mconcat [prstr, " .", fr]+ else return prstr+ + else do+ txt <- nextLine sbstr+ + flagS <- hasMore subjs+ if flagS+ then do+ fr <- formatSubjects_ nextSubject formatLabel props formatProperties subjs nextLine+ return $ mconcat [txt, " .", fr]+ else return txt+++{-+TODO: now we are throwing a Builder around it is awkward to+get the length of the text to calculate the indentation++So++ a) change the indentation scheme+ b) pass around text instead of builder++mkIndent :: L.Text -> L.Text+mkIndent inVal = L.replicate (L.length inVal) " "+-}++hackIndent :: B.Builder+hackIndent = " "++formatProperties_ :: + (RDFLabel -> State a RDFLabel) -- ^ next property for the given subject+ -> (LabelContext -> RDFLabel -> State a B.Builder) -- ^ convert label into text+ -> (RDFLabel -> RDFLabel -> B.Builder -> State a B.Builder) -- ^ format objects+ -> (a -> PredTree RDFLabel) -- ^ extract properties+ -> (B.Builder -> State a B.Builder) -- ^ next line+ -> RDFLabel -- ^ property being processed+ -> B.Builder -- ^ current output+ -> State a B.Builder+formatProperties_ nextProperty formatLabel formatObjects props nextLine sb sbstr = do+ pr <- nextProperty sb+ prstr <- formatLabel PredContext pr+ obstr <- formatObjects sb pr $ mconcat [sbstr, " ", prstr]+ more <- hasMore props+ let sbindent = hackIndent -- mkIndent sbstr+ if more+ then do+ fr <- formatProperties_ nextProperty formatLabel formatObjects props nextLine sb sbindent+ nl <- nextLine $ obstr `mappend` " ;"+ return $ nl `mappend` fr+ else nextLine obstr++formatObjects_ :: + (RDFLabel -> RDFLabel -> State a RDFLabel) -- ^ get the next object for the (subject,property) pair+ -> (LabelContext -> RDFLabel -> State a B.Builder) -- ^ format a label+ -> (a -> [RDFLabel]) -- ^ extract objects+ -> (B.Builder -> State a B.Builder) -- ^ insert a new line+ -> RDFLabel -- ^ subject+ -> RDFLabel -- ^ property+ -> B.Builder -- ^ current text+ -> State a B.Builder+formatObjects_ nextObject formatLabel objs nextLine sb pr prstr = do+ ob <- nextObject sb pr+ obstr <- formatLabel ObjContext ob+ more <- hasMore objs+ if more+ then do+ let prindent = hackIndent -- mkIndent prstr+ fr <- formatObjects_ nextObject formatLabel objs nextLine sb pr prindent+ nl <- nextLine $ mconcat [prstr, " ", obstr, ","]+ return $ nl `mappend` fr+ else return $ mconcat [prstr, " ", obstr]++{-+Processing a Bnode when not a subject.+-}+insertBnode_ ::+ (a -> SubjTree RDFLabel) -- ^ extract subjects+ -> (a -> PredTree RDFLabel) -- ^ extract properties+ -> (a -> [RDFLabel]) -- ^ extract objects+ -> (a -> SubjTree RDFLabel -> PredTree RDFLabel -> [RDFLabel] -> a) -- ^ update state to new settings+ -> (RDFLabel -> B.Builder -> State a B.Builder) -- ^ format properties+ -> RDFLabel+ -> State a B.Builder+insertBnode_ subjs props objs updateState formatProperties lbl = do+ ost <- get+ let osubjs = subjs ost+ (rsubjs, rprops) = splitOnLabel lbl osubjs+ put $ updateState ost rsubjs rprops []+ flag <- hasMore props+ txt <- if flag+ then (`mappend` "\n") `liftM` formatProperties lbl ""+ else return ""++ -- restore the original data (where appropriate)+ nst <- get+ let slist = map fst $ subjs nst+ nsubjs = filter (\(l,_) -> l `elem` slist) osubjs++ put $ updateState nst nsubjs (props ost) (objs ost)++ -- TODO: handle indentation?+ return $ mconcat ["[", txt, "]"]+++maybeExtractList :: + SubjTree RDFLabel+ -> PredTree RDFLabel+ -> LabelContext+ -> RDFLabel+ -> Maybe ([RDFLabel], SubjTree RDFLabel, PredTree RDFLabel)+maybeExtractList osubjs oprops lctxt ln =+ let mlst = getCollection osubjs' ln++ -- we only want to send in rdf:first/rdf:rest here+ fprops = filter ((`elem` [resRdfFirst, resRdfRest]) . fst) oprops++ osubjs' =+ case lctxt of+ SubjContext -> (ln, fprops) : osubjs+ _ -> osubjs ++ in case mlst of+ Just (sl, ls, _) -> + let oprops' = if lctxt == SubjContext+ then filter ((`notElem` [resRdfFirst, resRdfRest]) . fst) oprops+ else oprops+ in Just (ls, sl, oprops')++ _ -> Nothing++extractList_ :: + (a -> SubjTree RDFLabel) -- ^ extract subjects+ -> (a -> PredTree RDFLabel) -- ^ extract properties+ -> (SubjTree RDFLabel -> State a ()) -- ^ set subjects+ -> (PredTree RDFLabel -> State a ()) -- ^ set properties+ -> LabelContext + -> RDFLabel + -> State a (Maybe [RDFLabel])+extractList_ subjs props setSubjs setProps lctxt ln = do+ osubjs <- gets subjs+ oprops <- gets props+ case maybeExtractList osubjs oprops lctxt ln of+ Just (ls, osubjs', oprops') -> do+ setSubjs osubjs'+ setProps oprops'+ return (Just ls)++ _ -> return Nothing+ -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,
src/Swish/RDF/Formatter/N3.hs view
@@ -61,15 +61,32 @@ where import Swish.RDF.Formatter.Internal (NodeGenLookupMap, SubjTree, PredTree+ , SLens(..) , LabelContext(..)- , NodeGenState(..), emptyNgs+ , NodeGenState(..)+ , changeState+ , hasMore+ , emptyNgs , findMaxBnode- , getCollection , processArcs- , findPrefix) + , quoteB+ , formatScopedName+ , formatPlainLit+ , formatLangLit+ , formatTypedLit+ , insertList+ , nextLine_+ , mapBlankNode_+ , formatPrefixes_+ , formatGraph_+ , formatSubjects_+ , formatProperties_+ , formatObjects_+ , insertBnode_+ , extractList_+ ) -import Swish.Namespace (ScopedName, getScopeLocal, getScopeURI)-import Swish.QName (getLName)+import Swish.Namespace (ScopedName) import Swish.RDF.Graph ( RDFGraph, RDFLabel(..),@@ -79,24 +96,18 @@ setNamespaces, getNamespaces, getFormulae, emptyRDFGraph- , quote- , quoteT- , resRdfFirst, resRdfRest ) import Swish.RDF.Vocabulary (- fromLangTag, rdfType, rdfNil, owlSameAs, logImplies- , xsdBoolean, xsdDecimal, xsdInteger, xsdDouble ) -import Control.Monad (liftM, when, void)-import Control.Monad.State (State, modify, get, put, runState)+import Control.Monad (liftM, void)+import Control.Monad.State (State, modify, get, gets, put, runState) import Data.Char (isDigit)-import Data.List (partition, intersperse) import Data.Monoid (Monoid(..)) import Data.Word (Word32) @@ -109,10 +120,6 @@ import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B --- temporary conversion-quoteB :: Bool -> String -> B.Builder-quoteB f v = B.fromString $ quote f v- ---------------------------------------------------------------------- -- Graph formatting state monad ----------------------------------------------------------------------@@ -132,15 +139,27 @@ , objs :: [RDFLabel] -- for last property selected , formAvail :: FormulaMap RDFLabel , formQueue :: [(RDFLabel,RDFGraph)]+ , prefixes :: NamespaceMap , nodeGenSt :: NodeGenState , bNodesCheck :: [RDFLabel] -- these bNodes are not to be converted to '[..]' format , traceBuf :: [String] }- ++type SL a = SLens N3FormatterState a++_lineBreak :: SL Bool+_lineBreak = SLens lineBreak $ \a b -> a { lineBreak = b }++_nodeGen :: SL NodeGenState+_nodeGen = SLens nodeGenSt $ \a b -> a { nodeGenSt = b }+ type Formatter a = State N3FormatterState a -emptyN3FS :: NodeGenState -> N3FormatterState-emptyN3FS ngs = N3FS+updateState :: N3FormatterState -> SubjTree RDFLabel -> PredTree RDFLabel -> [RDFLabel] -> N3FormatterState+updateState ost nsubjs nprops nobjs = ost { subjs = nsubjs, props = nprops, objs = nobjs }++emptyN3FS :: NamespaceMap -> NodeGenState -> N3FormatterState+emptyN3FS pmap ngs = N3FS { indent = "\n" , lineBreak = False , graph = emptyRDFGraph@@ -149,41 +168,21 @@ , objs = [] , formAvail = emptyFormulaMap , formQueue = []+ , prefixes = pmap , nodeGenSt = ngs , bNodesCheck = [] , traceBuf = [] } -getIndent :: Formatter B.Builder-getIndent = indent `liftM` get- setIndent :: B.Builder -> Formatter () setIndent ind = modify $ \st -> st { indent = ind } -getLineBreak :: Formatter Bool-getLineBreak = lineBreak `liftM` get- setLineBreak :: Bool -> Formatter () setLineBreak brk = modify $ \st -> st { lineBreak = brk } -getNgs :: Formatter NodeGenState-getNgs = nodeGenSt `liftM` get--setNgs :: NodeGenState -> Formatter ()-setNgs ngs = modify $ \st -> st { nodeGenSt = ngs }--getPrefixes :: Formatter NamespaceMap-getPrefixes = prefixes `liftM` getNgs--getSubjs :: Formatter (SubjTree RDFLabel)-getSubjs = subjs `liftM` get- setSubjs :: SubjTree RDFLabel -> Formatter () setSubjs sl = modify $ \st -> st { subjs = sl } -getProps :: Formatter (PredTree RDFLabel)-getProps = props `liftM` get- setProps :: PredTree RDFLabel -> Formatter () setProps ps = modify $ \st -> st { props = ps } @@ -197,9 +196,6 @@ put $ st { objs = os } -} -getBnodesCheck :: Formatter [RDFLabel]-getBnodesCheck = bNodesCheck `liftM` get- {- addTrace :: String -> Formatter () addTrace tr = do@@ -253,29 +249,7 @@ -} extractList :: LabelContext -> RDFLabel -> Formatter (Maybe [RDFLabel])-extractList lctxt ln = do- osubjs <- getSubjs- oprops <- getProps- let mlst = getCollection osubjs' ln-- -- we only want to send in rdf:first/rdf:rest here- fprops = filter ((`elem` [resRdfFirst, resRdfRest]) . fst) oprops-- osubjs' =- case lctxt of- SubjContext -> (ln, fprops) : osubjs- _ -> osubjs -- -- tr = "extractList " ++ show ln ++ " (" ++ show lctxt ++ ")\n -> osubjs= " ++ show osubjs ++ "\n -> opreds= " ++ show oprops ++ "\n -> mlst= " ++ show mlst ++ "\n"- -- addTrace tr- case mlst of- -- sl is guaranteed to be free of (ln,fprops) here if lctxt is SubjContext- Just (sl,ls,_) -> do- setSubjs sl- when (lctxt == SubjContext) $ setProps $ filter ((`notElem` [resRdfFirst, resRdfRest]) . fst) oprops- return (Just ls)-- Nothing -> return Nothing+extractList = extractList_ subjs props setSubjs setProps ---------------------------------------------------------------------- -- Define a top-level formatter function:@@ -311,12 +285,9 @@ -> (B.Builder, NodeGenLookupMap, Word32, [String]) formatGraphDiag indnt flag gr = let fg = formatGraph indnt " .\n" False flag gr- ngs = emptyNgs {- prefixes = M.empty,- nodeGen = findMaxBnode gr- }+ ngs = emptyNgs { nodeGen = findMaxBnode gr } - (out, fgs) = runState fg (emptyN3FS ngs)+ (out, fgs) = runState fg (emptyN3FS emptyNamespaceMap ngs) ogs = nodeGenSt fgs in (out, nodeMap ogs, nodeGen ogs, traceBuf fgs)@@ -332,136 +303,42 @@ -> Bool -- True if prefix strings are to be generated -> RDFGraph -- graph to convert -> Formatter B.Builder-formatGraph ind end dobreak dopref gr = do- setIndent ind- setLineBreak dobreak- setGraph gr- - fp <- if dopref- then formatPrefixes (getNamespaces gr)- else return mempty- more <- moreSubjects- if more- then do- fr <- formatSubjects- return $ mconcat [fp, fr, end]- else return fp+formatGraph = formatGraph_ setIndent setLineBreak newState formatPrefixes subjs formatSubjects formatPrefixes :: NamespaceMap -> Formatter B.Builder-formatPrefixes pmap = do- let mls = map pref $ M.assocs pmap- ls <- sequence mls- return $ mconcat ls- where- pref (Just p,u) = nextLine $ mconcat ["@prefix ", B.fromText p, ": <", quoteB True (show u), "> ."]- pref (_,u) = nextLine $ mconcat ["@prefix : <", quoteB True (show u), "> ."]--{--NOTE:-I expect there to be confusion below where I need to-convert from Text to Builder--}+formatPrefixes = formatPrefixes_ nextLine formatSubjects :: Formatter B.Builder-formatSubjects = do- sb <- nextSubject- sbstr <- formatLabel SubjContext sb- - flagP <- moreProperties- if flagP- then do- prstr <- formatProperties sb sbstr- flagS <- moreSubjects- if flagS- then do- fr <- formatSubjects- return $ mconcat [prstr, " .", fr]- else return prstr- - else do- txt <- nextLine sbstr- - flagS <- moreSubjects- if flagS- then do- fr <- formatSubjects- return $ mconcat [txt, " .", fr]- else return txt--{--TODO: now we are throwing a Builder around it is awkward to-get the length of the text to calculate the indentation--So-- a) change the indentation scheme- b) pass around text instead of builder--mkIndent :: L.Text -> L.Text-mkIndent inVal = L.replicate (L.length inVal) " "--}--hackIndent :: B.Builder-hackIndent = " "+formatSubjects = formatSubjects_ nextSubject formatLabel props formatProperties subjs nextLine formatProperties :: RDFLabel -> B.Builder -> Formatter B.Builder-formatProperties sb sbstr = do- pr <- nextProperty sb- prstr <- formatLabel PredContext pr- obstr <- formatObjects sb pr $ mconcat [sbstr, " ", prstr]- more <- moreProperties- let sbindent = hackIndent -- mkIndent sbstr- if more- then do- fr <- formatProperties sb sbindent- nl <- nextLine $ obstr `mappend` " ;"- return $ nl `mappend` fr- else nextLine obstr+formatProperties = formatProperties_ nextProperty formatLabel formatObjects props nextLine formatObjects :: RDFLabel -> RDFLabel -> B.Builder -> Formatter B.Builder-formatObjects sb pr prstr = do- ob <- nextObject sb pr- obstr <- formatLabel ObjContext ob- more <- moreObjects- if more- then do- let prindent = hackIndent -- mkIndent prstr- fr <- formatObjects sb pr prindent- nl <- nextLine $ mconcat [prstr, " ", obstr, ","]- return $ nl `mappend` fr- else return $ mconcat [prstr, " ", obstr]+formatObjects = formatObjects_ nextObject formatLabel objs nextLine insertFormula :: RDFGraph -> Formatter B.Builder insertFormula gr = do- ngs0 <- getNgs- ind <- getIndent+ pmap0 <- gets prefixes+ ngs0 <- gets nodeGenSt+ ind <- gets indent let grm = formatGraph (ind `mappend` " ") "" True False (setNamespaces emptyNamespaceMap gr) - (f3str, fgs') = runState grm (emptyN3FS ngs0)+ (f3str, fgs') = runState grm (emptyN3FS pmap0 ngs0) - setNgs (nodeGenSt fgs')+ modify $ \st -> st { nodeGenSt = nodeGenSt fgs'+ , prefixes = prefixes fgs' } f4str <- nextLine " } " return $ mconcat [" { ",f3str, f4str] {--Add a list inline. We are given the labels that constitute-the list, in order, so just need to display them surrounded-by ().--}-insertList :: [RDFLabel] -> Formatter B.Builder-insertList [] = return "()" -- not convinced this can happen-insertList xs = do- ls <- mapM (formatLabel ObjContext) xs- return $ mconcat ("( " : intersperse " " ls) `mappend` " )"- -{- Add a blank node inline. -} insertBnode :: LabelContext -> RDFLabel -> Formatter B.Builder insertBnode SubjContext lbl = do- flag <- moreProperties+ flag <- hasMore props txt <- if flag then (`mappend` "\n") `liftM` formatProperties lbl "" else return ""@@ -469,59 +346,15 @@ -- TODO: handle indentation? return $ mconcat ["[", txt, "]"] -insertBnode _ lbl = do- ost <- get- let osubjs = subjs ost- oprops = props ost- oobjs = objs ost-- (bsubj, rsubjs) = partition ((== lbl) . fst) osubjs-- rprops = case bsubj of- [(_,rs)] -> rs- _ -> []-- -- we essentially want to create a new subgraph- -- for this node but it's not as simple as that since- -- we could have something like- -- :a :b [ :foo [ :bar "xx" ] ]- -- so we still need to carry around the whole graph- --- nst = ost { subjs = rsubjs,- props = rprops,- objs = []- }-- put nst- flag <- moreProperties- txt <- if flag- then (`mappend` "\n") `liftM` formatProperties lbl ""- else return ""-- -- TODO: how do we restore the original set up?- -- I can't believe the following is sufficient- --- nst' <- get- let slist = map fst $ subjs nst'- nsubjs = filter (\(l,_) -> l `elem` slist) osubjs-- put $ nst' { subjs = nsubjs,- props = oprops, - objs = oobjs- }+insertBnode _ lbl = insertBnode_ subjs props objs updateState formatProperties lbl - -- TODO: handle indentation?- return $ mconcat ["[", txt, "]"]- ---------------------------------------------------------------------- -- Formatting helpers ---------------------------------------------------------------------- newState :: RDFGraph -> N3FormatterState -> N3FormatterState newState gr st = - let ngs0 = nodeGenSt st- pre' = prefixes ngs0 `M.union` getNamespaces gr- ngs' = ngs0 { prefixes = pre' }+ let pre' = prefixes st `M.union` getNamespaces gr (arcSubjs, bNodes) = processArcs gr in st { graph = gr@@ -529,70 +362,38 @@ , props = [] , objs = [] , formAvail = getFormulae gr- , nodeGenSt = ngs'+ , prefixes = pre' , bNodesCheck = bNodes } -setGraph :: RDFGraph -> Formatter ()-setGraph = modify . newState--hasMore :: (N3FormatterState -> [b]) -> Formatter Bool-hasMore lens = (not . null . lens) `liftM` get--moreSubjects :: Formatter Bool-moreSubjects = hasMore subjs--moreProperties :: Formatter Bool-moreProperties = hasMore props--moreObjects :: Formatter Bool-moreObjects = hasMore objs- nextSubject :: Formatter RDFLabel-nextSubject = do- st <- get-- let sb:sbs = subjs st- nst = st { subjs = sbs- , props = snd sb- , objs = []- }-- put nst- return $ fst sb+nextSubject = + changeState $ \st -> + let (a,b):sbs = subjs st+ nst = st { subjs = sbs+ , props = b+ , objs = []+ }+ in (a, nst) nextProperty :: RDFLabel -> Formatter RDFLabel-nextProperty _ = do- st <- get-- let pr:prs = props st- nst = st { props = prs- , objs = snd pr- }-- put nst- return $ fst pr-+nextProperty _ =+ changeState $ \st ->+ let (a,b):prs = props st+ nst = st { props = prs+ , objs = b+ }+ in (a, nst)+ nextObject :: RDFLabel -> RDFLabel -> Formatter RDFLabel-nextObject _ _ = do- st <- get-- let ob:obs = objs st- nst = st { objs = obs }-- put nst- return ob+nextObject _ _ =+ changeState $ \st ->+ let ob:obs = objs st+ nst = st { objs = obs }+ in (ob, nst) nextLine :: B.Builder -> Formatter B.Builder-nextLine str = do- ind <- getIndent- brk <- getLineBreak- if brk- then return $ ind `mappend` str- else do- -- After first line, always insert line break- setLineBreak True- return str+nextLine = nextLine_ indent _lineBreak -- Format a label -- Most labels are simply displayed as provided, but there are a@@ -633,17 +434,19 @@ {- The "[..]" conversion is done last, after "()" and "{}" checks.++TODO: look at the (_:_) check on the blank string; why is this needed? -} formatLabel lctxt lab@(Blank (_:_)) = do mlst <- extractList lctxt lab case mlst of- Just lst -> insertList lst+ Just lst -> insertList (formatLabel ObjContext) lst Nothing -> do mfml <- extractFormula lab case mfml of Just fml -> insertFormula fml Nothing -> do- nb1 <- getBnodesCheck+ nb1 <- gets bNodesCheck if lctxt /= PredContext && lab `notElem` nb1 then insertBnode lctxt lab else formatNodeId lab@@ -652,91 +455,23 @@ case lookup sn specialTable of Just txt -> return $ quoteB True txt -- TODO: do we need to quote? Nothing -> do- pr <- getPrefixes- let nsuri = getScopeURI sn- local = getLName $ getScopeLocal sn- prefix = findPrefix nsuri pr- - name = case prefix of- Just (Just p) -> B.fromText $ quoteT True $ mconcat [p, ":", local] -- TODO: what are quoting rules for QNames- _ -> mconcat ["<", quoteB True (show nsuri ++ T.unpack local), ">"]- - {-- name = case prefix of- Just p -> quoteB True (p ++ ":" ++ local) -- TODO: what are quoting rules for QNames- _ -> mconcat ["<", quoteB True (nsuri++local), ">"]- -}- + pr <- gets prefixes queueFormula lab- return name+ return $ formatScopedName sn pr --- The canonical notation for xsd:double in XSD, with an upper-case E,--- does not match the syntax used in N3, so we need to convert here. --- Rather than converting back to a Double and then displaying that --- we just convert E to e for now. ----formatLabel _ (TypedLit lit dtype)- | dtype == xsdDouble = return $ B.fromText $ T.toLower lit- | dtype `elem` [xsdBoolean, xsdDecimal, xsdInteger] = return $ B.fromText lit- | otherwise = return $ quoteText lit `mappend` "^^" `mappend` showScopedName dtype-formatLabel _ (LangLit lit lcode) =- return $ quoteText lit `mappend` "@" `mappend` B.fromText (fromLangTag lcode)-formatLabel _ (Lit lit) = return $ quoteText lit+formatLabel _ (Lit lit) = return $ formatPlainLit lit+formatLabel _ (LangLit lit lcode) = return $ formatLangLit lit lcode+formatLabel _ (TypedLit lit dtype) = return $ formatTypedLit lit dtype formatLabel _ lab = return $ B.fromString $ show lab -{--We have to decide whether to use " or """ to quote-the string.--There is also no need to restrict the string to the-ASCII character set; this could be an option but we-can also leave Unicode as is (or at least convert to UTF-8).--If we use """ to surround the string then we protect the-last character if it is a " (assuming it isn't protected).--}--quoteText :: T.Text -> B.Builder-quoteText txt = - let st = T.unpack txt -- TODO: fix- qst = quoteB (n==1) st- n = if '\n' `elem` st || '"' `elem` st then 3 else 1- qch = B.fromString (replicate n '"')- in mconcat [qch, qst, qch]- formatNodeId :: RDFLabel -> Formatter B.Builder formatNodeId lab@(Blank (lnc:_)) = if isDigit lnc then mapBlankNode lab else return $ B.fromString $ show lab formatNodeId other = error $ "formatNodeId not expecting a " ++ show other -- to shut up -Wall mapBlankNode :: RDFLabel -> Formatter B.Builder-mapBlankNode lab = do- ngs <- getNgs- let cmap = nodeMap ngs- cval = nodeGen ngs- nv <- case M.findWithDefault 0 lab cmap of- 0 -> do - let nval = succ cval- nmap = M.insert lab nval cmap- setNgs $ ngs { nodeGen = nval, nodeMap = nmap }- return nval- - n -> return n- - -- TODO: is this what we want?- return $ "_:swish" `mappend` B.fromString (show nv)---- TODO: need to be a bit more clever with this than we did in NTriples--- not sure the following counts as clever enough ...--- -showScopedName :: ScopedName -> B.Builder-{--showScopedName (ScopedName n l) = - let uri = nsURI n ++ l- in quote uri--}-showScopedName = quoteB True . show+mapBlankNode = mapBlankNode_ _nodeGen -------------------------------------------------------------------------------- --
src/Swish/RDF/Formatter/NTriples.hs view
@@ -29,7 +29,11 @@ ) where -import Swish.RDF.Formatter.Internal (NodeGenLookupMap)+import Swish.RDF.Formatter.Internal ( NodeGenState(..)+ , SLens (..)+ , emptyNgs+ , mapBlankNode_+ ) import Swish.GraphClass (Arc(..)) import Swish.Namespace (ScopedName, getQName)@@ -44,13 +48,11 @@ import Data.Char (ord, intToDigit, toUpper) import Data.Monoid-import Data.Word (Word32) -- it strikes me that using Lazy Text here is likely to be -- wrong; however I have done no profiling to back this -- assumption up! -import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy as L@@ -62,18 +64,10 @@ -- -- This is a lot simpler than other formatters. -data NTFormatterState = NTFS { - ntfsNodeMap :: NodeGenLookupMap,- ntfsNodeGen :: Word32- } deriving Show--emptyNTFS :: NTFormatterState-emptyNTFS = NTFS {- ntfsNodeMap = M.empty,- ntfsNodeGen = 0- }+type Formatter a = State NodeGenState a -type Formatter a = State NTFormatterState a+_nodeGen :: SLens NodeGenState NodeGenState+_nodeGen = SLens id $ flip const -- | Convert a RDF graph to NTriples format. formatGraphAsText :: RDFGraph -> T.Text@@ -85,7 +79,7 @@ -- | Convert a RDF graph to NTriples format. formatGraphAsBuilder :: RDFGraph -> B.Builder-formatGraphAsBuilder gr = fst $ runState (formatGraph gr) emptyNTFS+formatGraphAsBuilder gr = fst $ runState (formatGraph gr) emptyNgs ---------------------------------------------------------------------- -- Formatting as a monad-based computation@@ -108,69 +102,27 @@ pl <- formatLabel p ol <- formatLabel o return $ mconcat [sl, space, pl, space, ol, nl]- -- return $ sl `mappend` $ space `mappend` $ pl `mappend` $ space `mappend` $ ol `mappend` nl -{--If we have a blank node then can-- - use the label it contains- - generate a new one on output--For now we create new labels whatever the input was since this-simplifies things, but it may be changed.--formatLabel :: RDFLabel -> Formatter String-formatLabel lab@(Blank (lnc:_)) = - if isDigit lnc then mapBlankNode lab else return $ show lab-formatLabel lab = return $ show lab--}--squote, at, carets :: B.Builder-squote = "\""-at = "@"-carets = "^^"- formatLabel :: RDFLabel -> Formatter B.Builder formatLabel lab@(Blank _) = mapBlankNode lab formatLabel (Res sn) = return $ showScopedName sn formatLabel (Lit lit) = return $ quoteText lit-formatLabel (LangLit lit lang) = return $ mconcat [quoteText lit, at, B.fromText (fromLangTag lang)]-formatLabel (TypedLit lit dt) = return $ mconcat [quoteText lit, carets, showScopedName dt]+formatLabel (LangLit lit lang) = return $ mconcat [quoteText lit, "@", B.fromText (fromLangTag lang)]+formatLabel (TypedLit lit dt) = return $ mconcat [quoteText lit, "^^", showScopedName dt] -- do not expect to get the following, but include -- just in case rather than failing formatLabel lab = return $ B.fromString $ show lab mapBlankNode :: RDFLabel -> Formatter B.Builder-mapBlankNode lab = do- st <- get- let cmap = ntfsNodeMap st- cval = ntfsNodeGen st-- nv <- case M.findWithDefault 0 lab cmap of- 0 -> do- let nval = succ cval- nmap = M.insert lab nval cmap-- put $ st { ntfsNodeMap = nmap, ntfsNodeGen = nval }- return nval-- n -> return n-- return $ "_:swish" `mappend` B.fromString (show nv)+mapBlankNode = mapBlankNode_ _nodeGen -- TODO: can we use Network.URI to protect the URI? showScopedName :: ScopedName -> B.Builder-{--showScopedName (ScopedName n l) = - let uri = T.pack (show (nsURI n)) `mappend` l- in mconcat ["<", B.fromText (quote uri), ">"]--}--- showScopedName s = mconcat ["<", B.fromText (quote (T.pack (show (getQName s)))), ">"] showScopedName s = B.fromText (quote (T.pack (show (getQName s)))) -- looks like qname already adds the <> around this quoteText :: T.Text -> B.Builder-quoteText st = mconcat [squote, B.fromText (quote st), squote]+quoteText st = mconcat ["\"", B.fromText (quote st), "\""] {- QUS: should we be operating on Text like this?
src/Swish/RDF/Formatter/Turtle.hs view
@@ -40,44 +40,48 @@ , formatGraphAsBuilder , formatGraphIndent , formatGraphDiag- - -- -- * Auxillary routines- -- , quoteText ) where import Swish.RDF.Formatter.Internal (NodeGenLookupMap, SubjTree, PredTree+ , SLens(..) , LabelContext(..)- , NodeGenState(..), emptyNgs+ , NodeGenState(..)+ , changeState+ , hasMore+ , emptyNgs , findMaxBnode- , getCollection , processArcs- , findPrefix)--import Swish.Namespace (ScopedName, getScopeLocal, getScopeURI)-import Swish.QName (getLName)+ , formatScopedName+ , formatPlainLit+ , formatLangLit+ , formatTypedLit+ , insertList+ , nextLine_+ , mapBlankNode_+ , formatPrefixes_+ , formatGraph_+ , formatSubjects_+ , formatProperties_+ , formatObjects_+ , insertBnode_+ , extractList_+ ) import Swish.RDF.Graph ( RDFGraph, RDFLabel(..) , NamespaceMap+ , emptyNamespaceMap , getNamespaces , emptyRDFGraph- , quote- , quoteT- , resRdfFirst, resRdfRest ) -import Swish.RDF.Vocabulary ( fromLangTag - , rdfType- , rdfNil- , xsdBoolean, xsdDecimal, xsdInteger, xsdDouble - )+import Swish.RDF.Vocabulary (rdfType, rdfNil) -import Control.Monad (liftM, when)-import Control.Monad.State (State, modify, get, put, runState)+import Control.Monad (liftM)+import Control.Monad.State (State, modify, gets, runState) import Data.Char (isDigit)-import Data.List (partition, intersperse) import Data.Monoid (Monoid(..)) import Data.Word (Word32) @@ -90,10 +94,6 @@ import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B --- temporary conversion-quoteB :: Bool -> String -> B.Builder-quoteB f v = B.fromString $ quote f v- ---------------------------------------------------------------------- -- Graph formatting state monad ----------------------------------------------------------------------@@ -113,13 +113,30 @@ , objs :: [RDFLabel] -- for last property selected -- , formAvail :: FormulaMap RDFLabel -- , formQueue :: [(RDFLabel,RDFGraph)]+ , prefixes :: NamespaceMap , nodeGenSt :: NodeGenState , bNodesCheck :: [RDFLabel] -- these bNodes are not to be converted to '[..]' format , traceBuf :: [String] }- ++type SL a = SLens TurtleFormatterState a++_lineBreak :: SL Bool+_lineBreak = SLens lineBreak $ \a b -> a { lineBreak = b }++_nodeGen :: SL NodeGenState+_nodeGen = SLens nodeGenSt $ \a b -> a { nodeGenSt = b }+ type Formatter a = State TurtleFormatterState a +updateState ::+ TurtleFormatterState+ -> SubjTree RDFLabel+ -> PredTree RDFLabel+ -> [RDFLabel]+ -> TurtleFormatterState+updateState ost nsubjs nprops nobjs = ost { subjs = nsubjs, props = nprops, objs = nobjs }+ emptyTFS :: NodeGenState -> TurtleFormatterState emptyTFS ngs = TFS { indent = "\n"@@ -128,97 +145,33 @@ , subjs = [] , props = [] , objs = []- -- , formAvail = emptyFormulaMap- -- , formQueue = []+ , prefixes = emptyNamespaceMap , nodeGenSt = ngs , bNodesCheck = [] , traceBuf = [] } -getIndent :: Formatter B.Builder-getIndent = indent `liftM` get- setIndent :: B.Builder -> Formatter () setIndent ind = modify $ \st -> st { indent = ind } -getLineBreak :: Formatter Bool-getLineBreak = lineBreak `liftM` get- setLineBreak :: Bool -> Formatter () setLineBreak brk = modify $ \st -> st { lineBreak = brk } -getNgs :: Formatter NodeGenState-getNgs = nodeGenSt `liftM` get--setNgs :: NodeGenState -> Formatter ()-setNgs ngs = modify $ \st -> st { nodeGenSt = ngs }--getPrefixes :: Formatter NamespaceMap-getPrefixes = prefixes `liftM` getNgs--getSubjs :: Formatter (SubjTree RDFLabel)-getSubjs = subjs `liftM` get- setSubjs :: SubjTree RDFLabel -> Formatter () setSubjs sl = modify $ \st -> st { subjs = sl } -getProps :: Formatter (PredTree RDFLabel)-getProps = props `liftM` get- setProps :: PredTree RDFLabel -> Formatter () setProps ps = modify $ \st -> st { props = ps } {--getObjs :: Formatter ([RDFLabel])-getObjs = objs `liftM` get--setObjs :: [RDFLabel] -> Formatter ()-setObjs os = do- st <- get- put $ st { objs = os }--}--getBnodesCheck :: Formatter [RDFLabel]-getBnodesCheck = bNodesCheck `liftM` get--{--addTrace :: String -> Formatter ()-addTrace tr = do- st <- get- put $ st { traceBuf = tr : traceBuf st }--}- -{- TODO: Should we change the preds/objs entries as well? -} extractList :: LabelContext -> RDFLabel -> Formatter (Maybe [RDFLabel])-extractList lctxt ln = do- osubjs <- getSubjs- oprops <- getProps- let mlst = getCollection osubjs' ln-- -- we only want to send in rdf:first/rdf:rest here- fprops = filter ((`elem` [resRdfFirst, resRdfRest]) . fst) oprops-- osubjs' =- case lctxt of- SubjContext -> (ln, fprops) : osubjs- _ -> osubjs -- -- tr = "extractList " ++ show ln ++ " (" ++ show lctxt ++ ")\n -> osubjs= " ++ show osubjs ++ "\n -> opreds= " ++ show oprops ++ "\n -> mlst= " ++ show mlst ++ "\n"- -- addTrace tr- case mlst of- -- sl is guaranteed to be free of (ln,fprops) here if lctxt is SubjContext- Just (sl,ls,_) -> do- setSubjs sl- when (lctxt == SubjContext) $ setProps $ filter ((`notElem` [resRdfFirst, resRdfRest]) . fst) oprops- return (Just ls)+extractList = extractList_ subjs props setSubjs setProps - Nothing -> return Nothing- ---------------------------------------------------------------------- -- Define a top-level formatter function: ----------------------------------------------------------------------@@ -253,10 +206,7 @@ -> (B.Builder, NodeGenLookupMap, Word32, [String]) formatGraphDiag indnt flag gr = let fg = formatGraph indnt " .\n" False flag gr- ngs = emptyNgs {- prefixes = M.empty,- nodeGen = findMaxBnode gr- }+ ngs = emptyNgs { nodeGen = findMaxBnode gr } (out, fgs) = runState fg (emptyTFS ngs) ogs = nodeGenSt fgs@@ -274,253 +224,81 @@ -> Bool -- True if prefix strings are to be generated -> RDFGraph -- graph to convert -> Formatter B.Builder-formatGraph ind end dobreak dopref gr = do- setIndent ind- setLineBreak dobreak- setGraph gr- - fp <- if dopref- then formatPrefixes (getNamespaces gr)- else return mempty- more <- moreSubjects- if more- then do- fr <- formatSubjects- return $ mconcat [fp, fr, end]- else return fp+formatGraph = formatGraph_ setIndent setLineBreak newState formatPrefixes subjs formatSubjects formatPrefixes :: NamespaceMap -> Formatter B.Builder-formatPrefixes pmap = do- let mls = map pref $ M.assocs pmap- ls <- sequence mls- return $ mconcat ls- where- pref (Just p,u) = nextLine $ mconcat ["@prefix ", B.fromText p, ": <", quoteB True (show u), "> ."]- pref (_,u) = nextLine $ mconcat ["@prefix : <", quoteB True (show u), "> ."]--{--NOTE:-I expect there to be confusion below where I need to-convert from Text to Builder--}+formatPrefixes = formatPrefixes_ nextLine formatSubjects :: Formatter B.Builder-formatSubjects = do- sb <- nextSubject- sbstr <- formatLabel SubjContext sb- - flagP <- moreProperties- if flagP- then do- prstr <- formatProperties sb sbstr- flagS <- moreSubjects- if flagS- then do- fr <- formatSubjects- return $ mconcat [prstr, " .", fr]- else return prstr- - else do- txt <- nextLine sbstr- - flagS <- moreSubjects- if flagS- then do- fr <- formatSubjects- return $ mconcat [txt, " .", fr]- else return txt--{--TODO: now we are throwing a Builder around it is awkward to-get the length of the text to calculate the indentation--So-- a) change the indentation scheme- b) pass around text instead of builder--mkIndent :: L.Text -> L.Text-mkIndent inVal = L.replicate (L.length inVal) " "--}--hackIndent :: B.Builder-hackIndent = " "+formatSubjects = formatSubjects_ nextSubject formatLabel props formatProperties subjs nextLine formatProperties :: RDFLabel -> B.Builder -> Formatter B.Builder-formatProperties sb sbstr = do- pr <- nextProperty sb- prstr <- formatLabel PredContext pr- obstr <- formatObjects sb pr $ mconcat [sbstr, " ", prstr]- more <- moreProperties- let sbindent = hackIndent -- mkIndent sbstr- if more- then do- fr <- formatProperties sb sbindent- nl <- nextLine $ obstr `mappend` " ;"- return $ nl `mappend` fr- else nextLine obstr+formatProperties = formatProperties_ nextProperty formatLabel formatObjects props nextLine formatObjects :: RDFLabel -> RDFLabel -> B.Builder -> Formatter B.Builder-formatObjects sb pr prstr = do- ob <- nextObject sb pr- obstr <- formatLabel ObjContext ob- more <- moreObjects- if more- then do- let prindent = hackIndent -- mkIndent prstr- fr <- formatObjects sb pr prindent- nl <- nextLine $ mconcat [prstr, " ", obstr, ","]- return $ nl `mappend` fr- else return $ mconcat [prstr, " ", obstr]+formatObjects = formatObjects_ nextObject formatLabel objs nextLine {--Add a list inline. We are given the labels that constitute-the list, in order, so just need to display them surrounded-by ().--}-insertList :: [RDFLabel] -> Formatter B.Builder-insertList [] = return "()" -- not convinced this can happen-insertList xs = do- ls <- mapM (formatLabel ObjContext) xs- return $ mconcat ("( " : intersperse " " ls) `mappend` " )"- -{- Add a blank node inline. -} insertBnode :: LabelContext -> RDFLabel -> Formatter B.Builder insertBnode SubjContext lbl = do -- a safety check- flag <- moreProperties+ flag <- hasMore props if flag then do txt <- (`mappend` "\n") `liftM` formatProperties lbl "" return $ mconcat ["[] ", txt] else error $ "Internal error: expected properties with label: " ++ show lbl -insertBnode _ lbl = do- ost <- get- let osubjs = subjs ost- oprops = props ost- oobjs = objs ost-- (bsubj, rsubjs) = partition ((== lbl) . fst) osubjs-- rprops = case bsubj of- [(_,rs)] -> rs- _ -> []-- -- we essentially want to create a new subgraph- -- for this node but it's not as simple as that since- -- we could have something like- -- :a :b [ :foo [ :bar "xx" ] ]- -- so we still need to carry around the whole graph- --- nst = ost { subjs = rsubjs,- props = rprops,- objs = []- }-- put nst- flag <- moreProperties- txt <- if flag- then (`mappend` "\n") `liftM` formatProperties lbl ""- else return ""-- -- TODO: how do we restore the original set up?- -- I can't believe the following is sufficient- --- nst' <- get- let slist = map fst $ subjs nst'- nsubjs = filter (\(l,_) -> l `elem` slist) osubjs-- put $ nst' { subjs = nsubjs,- props = oprops, - objs = oobjs- }+insertBnode _ lbl = insertBnode_ subjs props objs updateState formatProperties lbl - -- TODO: handle indentation?- return $ mconcat ["[", txt, "]"]- ---------------------------------------------------------------------- -- Formatting helpers ---------------------------------------------------------------------- newState :: RDFGraph -> TurtleFormatterState -> TurtleFormatterState newState gr st = - let ngs0 = nodeGenSt st- pre' = prefixes ngs0 `M.union` getNamespaces gr- ngs' = ngs0 { prefixes = pre' }+ let pre' = prefixes st `M.union` getNamespaces gr (arcSubjs, bNodes) = processArcs gr in st { graph = gr , subjs = arcSubjs , props = [] , objs = []- , nodeGenSt = ngs'+ , prefixes = pre' , bNodesCheck = bNodes } -setGraph :: RDFGraph -> Formatter ()-setGraph = modify . newState--hasMore :: (TurtleFormatterState -> [b]) -> Formatter Bool-hasMore lens = (not . null . lens) `liftM` get--moreSubjects :: Formatter Bool-moreSubjects = hasMore subjs--moreProperties :: Formatter Bool-moreProperties = hasMore props--moreObjects :: Formatter Bool-moreObjects = hasMore objs- nextSubject :: Formatter RDFLabel-nextSubject = do- st <- get-- let sb:sbs = subjs st- nst = st { subjs = sbs- , props = snd sb- , objs = []- }-- put nst- return $ fst sb+nextSubject = + changeState $ \st -> + let (a,b):sbs = subjs st+ nst = st { subjs = sbs+ , props = b+ , objs = []+ }+ in (a, nst) nextProperty :: RDFLabel -> Formatter RDFLabel-nextProperty _ = do- st <- get-- let pr:prs = props st- nst = st { props = prs- , objs = snd pr- }-- put nst- return $ fst pr-+nextProperty _ =+ changeState $ \st ->+ let (a,b):prs = props st+ nst = st { props = prs+ , objs = b+ }+ in (a, nst)+ nextObject :: RDFLabel -> RDFLabel -> Formatter RDFLabel-nextObject _ _ = do- st <- get-- let ob:obs = objs st- nst = st { objs = obs }-- put nst- return ob+nextObject _ _ =+ changeState $ \st ->+ let ob:obs = objs st+ nst = st { objs = obs }+ in (ob, nst) nextLine :: B.Builder -> Formatter B.Builder-nextLine str = do- ind <- getIndent- brk <- getLineBreak- if brk- then return $ ind `mappend` str- else do- -- After first line, always insert line break- setLineBreak True- return str+nextLine = nextLine_ indent _lineBreak -- Format a label -- Most labels are simply displayed as provided, but there are a@@ -550,16 +328,18 @@ {- The "[..]" conversion is done last, after "()" and "{}" checks.++TODO: look at the (_:_) check on the blank string; why is this needed? -} formatLabel lctxt lab@(Blank (_:_)) = do mlst <- extractList lctxt lab case mlst of- Just lst -> insertList lst+ Just lst -> insertList (formatLabel ObjContext) lst Nothing -> do -- NOTE: unlike N3 we do not properly handle "formula"/named graphs -- also we only expand out bnodes into [...] format when it's a object. -- although we need to handle [] for the subject.- nb1 <- getBnodesCheck+ nb1 <- gets bNodesCheck if lctxt /= PredContext && lab `notElem` nb1 then insertBnode lctxt lab else formatNodeId lab@@ -569,75 +349,22 @@ | ctxt == PredContext && sn == rdfType = return "a" | ctxt == ObjContext && sn == rdfNil = return "()" | otherwise = do- pr <- getPrefixes- let nsuri = getScopeURI sn- local = getLName $ getScopeLocal sn- name = case findPrefix nsuri pr of- Just (Just p) -> B.fromText $ quoteT True $ mconcat [p, ":", local] -- TODO: what are quoting rules for QNames- _ -> mconcat ["<", quoteB True (show nsuri ++ T.unpack local), ">"]- - return name+ pr <- gets prefixes+ return $ formatScopedName sn pr --- The canonical notation for xsd:double in XSD, with an upper-case E,--- does not match the syntax used in N3, so we need to convert here. --- Rather than converting back to a Double and then displaying that --- we just convert E to e for now. --- -formatLabel _ (Lit lit) = return $ quoteText lit-formatLabel _ (LangLit lit lcode) = return $ quoteText lit `mappend` "@" `mappend` B.fromText (fromLangTag lcode)-formatLabel _ (TypedLit lit dtype)- | dtype == xsdDouble = return $ B.fromText $ T.toLower lit- | dtype `elem` [xsdBoolean, xsdDecimal, xsdInteger] = return $ B.fromText lit- | otherwise = return $ quoteText lit `mappend` "^^" `mappend` showScopedName dtype+formatLabel _ (Lit lit) = return $ formatPlainLit lit+formatLabel _ (LangLit lit lcode) = return $ formatLangLit lit lcode+formatLabel _ (TypedLit lit dtype) = return $ formatTypedLit lit dtype formatLabel _ lab = return $ B.fromString $ show lab -{-|-Convert text into a format for display in Turtle. The idea-is to use one double quote unless three are needed, and to-handle adding necessary @\\@ characters, or conversion-for Unicode characters.--}-quoteText :: T.Text -> B.Builder-quoteText txt = - let st = T.unpack txt -- TODO: fix- qst = quoteB (n==1) st- n = if '\n' `elem` st || '"' `elem` st then 3 else 1- qch = B.fromString (replicate n '"')- in mconcat [qch, qst, qch]- formatNodeId :: RDFLabel -> Formatter B.Builder formatNodeId lab@(Blank (lnc:_)) = if isDigit lnc then mapBlankNode lab else return $ B.fromString $ show lab formatNodeId other = error $ "formatNodeId not expecting a " ++ show other -- to shut up -Wall mapBlankNode :: RDFLabel -> Formatter B.Builder-mapBlankNode lab = do- ngs <- getNgs- let cmap = nodeMap ngs- cval = nodeGen ngs- nv <- case M.findWithDefault 0 lab cmap of- 0 -> do - let nval = succ cval- nmap = M.insert lab nval cmap- setNgs $ ngs { nodeGen = nval, nodeMap = nmap }- return nval- - n -> return n- - -- TODO: is this what we want?- return $ "_:swish" `mappend` B.fromString (show nv)---- TODO: need to be a bit more clever with this than we did in NTriples--- not sure the following counts as clever enough ...--- -showScopedName :: ScopedName -> B.Builder-{--showScopedName (ScopedName n l) = - let uri = nsURI n ++ l- in quote uri--}-showScopedName = quoteB True . show+mapBlankNode = mapBlankNode_ _nodeGen -------------------------------------------------------------------------------- --
src/Swish/RDF/Graph.hs view
@@ -1153,19 +1153,21 @@ instance (Label lb) => Monoid (NSGraph lb) where mempty = emptyGraph mappend = merge++-- fmapNSGraph :: (Ord lb1, Ord lb2) => (lb1 -> lb2) -> NSGraph lb1 -> NSGraph lb2 -- | 'fmap' for 'NSGraph' instances.--- fmapNSGraph :: (Ord lb1, Ord lb2) => (lb1 -> lb2) -> NSGraph lb1 -> NSGraph lb2 fmapNSGraph :: (Ord lb) => (lb -> lb) -> NSGraph lb -> NSGraph lb fmapNSGraph f (NSGraph ns fml stmts) = NSGraph ns (fmapFormulaMap f fml) ((S.map $ fmap f) stmts) --- | 'Data.Traversable.traverse' for 'NSGraph' instances. {- traverseNSGraph :: (Applicative f, Ord a, Ord b) => (a -> f b) -> NSGraph a -> f (NSGraph b) -}++-- | 'Data.Traversable.traverse' for 'NSGraph' instances. traverseNSGraph :: (Applicative f, Ord a) => (a -> f a) -> NSGraph a -> f (NSGraph a)
swish.cabal view
@@ -1,5 +1,5 @@ Name: swish-Version: 0.8.0.0+Version: 0.8.0.2 Stability: experimental License: LGPL License-file: LICENSE @@ -44,6 +44,17 @@ . * Complete, ready-to-run, command-line and script-driven programs. .+ Changes in version @0.8.0.2@:+ .+ * Restrict @hashable@ since tests fail with @1.1.2.5@+ (this is a hack).+ .+ * Updated @directory@ constraint to include @1.2@ on ghc 7.6.+ .+ Changes in version @0.8.0.1@:+ .+ * Internal changes to Turtle/N3 formatting. No user-visible changes.+ . Changes in version @0.8.0.0@: . * The @LDGraph@ class now uses @Set (Arc lb)@, rather than @[Arc lb]@,@@ -101,9 +112,9 @@ base >=3 && < 5, binary == 0.5.*, containers >= 0.4 && < 0.6,- directory >= 1.0 && < 1.2, filepath >= 1.1 && < 1.4,- hashable == 1.1.*,+ -- hashable == 1.1.*,+ hashable >= 1.1 && < 1.1.2.4, mtl >= 2 && < 3, network >= 2.2 && < 2.4, old-locale == 1.0.*, @@ -116,6 +127,11 @@ Build-Depends: intern == 0.8 if impl(ghc >= 7.4.0) Build-Depends: intern >= 0.8 && < 1.0++ if impl(ghc < 7.6.0)+ Build-Depends: directory >= 1.0 && < 1.2+ if impl(ghc >= 7.6.0)+ Build-Depends: directory >= 1.0 && < 1.3 Hs-Source-Dirs: src/ Other-Modules: Swish.RDF.Formatter.Internal