module Swish.RDF.Formatter.Internal
( NodeGenLookupMap
, SLens(..)
, SubjTree
, PredTree
, LabelContext(..)
, NodeGenState(..)
, changeState
, hasMore
, emptyNgs
, getBNodeLabel
, findMaxBnode
, splitOnLabel
, getCollection
, processArcs
, findPrefix
, quoteB
, quoteText
, showScopedName
, formatScopedName
, formatPrefixLines
, formatPlainLit
, formatLangLit
, formatTypedLit
, insertList
, nextLine_
, mapBlankNode_
, formatPrefixes_
, formatGraph_
, formatSubjects_
, formatProperties_
, formatObjects_
, insertBnode_
, extractList_
)
where
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
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
, getNamespaces
, resRdfFirst, resRdfRest, resRdfNil
, quote
, quoteT
)
import Swish.RDF.Vocabulary (LanguageTag, fromLangTag, xsdBoolean, xsdDecimal, xsdInteger, xsdDouble)
import Control.Monad (liftM)
import Control.Monad.State (State, get, gets, modify, put)
import Data.List (foldl', groupBy, isInfixOf, intersperse, partition)
import Data.Monoid (Monoid(..), mconcat)
import Data.Word
import Network.URI (URI)
import Network.URI.Ord ()
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 701)
import Data.Tuple (swap)
#else
swap :: (a,b) -> (b,a)
swap (a,b) = (b,a)
#endif
findPrefix :: URI -> M.Map a URI -> Maybe a
findPrefix u = M.lookup u . M.fromList . map swap . M.assocs
data SLens a b = SLens (a -> b) (a -> b -> a)
slens :: SLens a b -> a -> b -> a
slens (SLens _ s) = s
glens :: SLens a b -> a -> b
glens (SLens g _) = g
type NodeGenLookupMap = M.Map RDFLabel Word32
type SubjTree lb = [(lb,PredTree lb)]
type PredTree lb = [(lb,[lb])]
data LabelContext = SubjContext | PredContext | ObjContext
deriving (Eq, Show)
data NodeGenState = Ngs
{ nodeMap :: NodeGenLookupMap
, nodeGen :: Word32
}
emptyNgs :: NodeGenState
emptyNgs = Ngs M.empty 0
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)
changeState ::
(a -> (b, a)) -> State a b
changeState f = do
st <- get
let (rval, nst) = f st
put nst
return rval
hasMore :: (a -> [b]) -> State a Bool
hasMore lens = (not . null . lens) `liftM` get
removeItem :: (Eq a) => [(a,b)] -> a -> Maybe (b, [(a,b)])
removeItem os x =
let (as, bs) = break (\a -> fst a == x) os
in case bs of
((_,b):bbs) -> Just (b, as ++ bbs)
[] -> Nothing
getCollection ::
SubjTree RDFLabel
-> RDFLabel
-> Maybe (SubjTree RDFLabel, [RDFLabel], [RDFLabel])
getCollection subjList lbl = go subjList lbl ([],[])
where
go sl l (cs,ss) | l == resRdfNil = Just (sl, reverse cs, ss)
| otherwise = do
(pList1, sl') <- removeItem sl l
([pFirst], pList2) <- removeItem pList1 resRdfFirst
([pNext], []) <- removeItem pList2 resRdfRest
go sl' pNext (pFirst : cs, l : ss)
processArcs :: RDFGraph -> (SubjTree RDFLabel, [RDFLabel])
processArcs gr =
let arcs = sortArcs $ getArcs gr
in (arcTree arcs, countBnodes arcs)
newtype SortedArcs lb = SA [Arc lb]
sortArcs :: (Ord lb) => ArcSet lb -> SortedArcs lb
sortArcs = SA . S.toAscList
arcTree :: (Eq lb) => SortedArcs lb -> SubjTree lb
arcTree (SA as) = commonFstEq (commonFstEq id) $ map spopair as
where
spopair (Arc s p o) = (s,(p,o))
commonFstEq :: (Eq a) => ( [b] -> c ) -> [(a,b)] -> [(a,c)]
commonFstEq f ps =
[ (fst $ head sps,f $ map snd sps) | sps <- groupBy fstEq ps ]
where
fstEq (f1,_) (f2,_) = f1 == f2
findMaxBnode :: RDFGraph -> Word32
findMaxBnode = S.findMax . S.map getAutoBnodeIndex . labels
getAutoBnodeIndex :: RDFLabel -> Word32
getAutoBnodeIndex (Blank ('_':lns)) = res where
res = case [x | (x,t) <- reads lns, ("","") <- lex t] of
[x] -> x
_ -> 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)
countBnodes :: SortedArcs RDFLabel -> [RDFLabel]
countBnodes (SA as) =
let
upd _ _ = True
procPO oMap (Arc _ p o) =
addNode False o $ addNode True p oMap
procS oMap s = addNode False s oMap
isBlank (Blank _) = True
isBlank _ = False
subjects = S.filter isBlank $ S.fromList $ map arcSubj as
addNode f l@(Blank _) m = M.insertWith upd l f m
addNode _ _ m = m
map1 = foldl' procPO M.empty as
map2 = S.foldl' procS map1 subjects
in M.keys $ M.filter id map2
quoteB :: Bool -> String -> B.Builder
quoteB f v = B.fromString $ quote f v
quoteText :: T.Text -> B.Builder
quoteText txt =
let st = T.unpack txt
hasNL = '\n' `elem` st
hasSQ = '"' `elem` st
has3Q = "\"\"\"" `isInfixOf` st
n = if has3Q || (not hasNL && not hasSQ) then 1 else 3
qch = B.fromString (replicate n '"')
qst = quoteB (n==1) st
in mconcat [qch, qst, qch]
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)]
formatTypedLit :: Bool -> T.Text -> ScopedName -> B.Builder
formatTypedLit n3flag lit dtype
| dtype == xsdDouble = B.fromText $ if n3flag then T.toLower lit else lit
| dtype `elem` [xsdBoolean, xsdDecimal, xsdInteger] = B.fromText lit
| otherwise = mconcat [quoteText lit, "^^", showScopedName dtype]
insertList ::
(RDFLabel -> State a B.Builder)
-> [RDFLabel]
-> State a B.Builder
insertList _ [] = return "()"
insertList f xs = do
ls <- mapM f xs
return $ mconcat ("( " : intersperse " " ls) `mappend` " )"
nextLine_ ::
(a -> B.Builder)
-> SLens a Bool
-> 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
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)
-> NamespaceMap
-> State a B.Builder
formatPrefixes_ nextLine pmap =
mconcat `liftM` mapM nextLine (formatPrefixLines pmap)
formatGraph_ ::
(B.Builder -> State a ())
-> (Bool -> State a ())
-> (RDFGraph -> a -> a)
-> (NamespaceMap -> State a B.Builder)
-> (a -> SubjTree RDFLabel)
-> State a B.Builder
-> B.Builder
-> B.Builder
-> Bool
-> Bool
-> RDFGraph
-> 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
-> (LabelContext -> RDFLabel -> State a B.Builder)
-> (a -> PredTree RDFLabel)
-> (RDFLabel -> B.Builder -> State a B.Builder)
-> (a -> SubjTree RDFLabel)
-> (B.Builder -> State a B.Builder)
-> 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
hackIndent :: B.Builder
hackIndent = " "
formatProperties_ ::
(RDFLabel -> State a RDFLabel)
-> (LabelContext -> RDFLabel -> State a B.Builder)
-> (RDFLabel -> RDFLabel -> B.Builder -> State a B.Builder)
-> (a -> PredTree RDFLabel)
-> (B.Builder -> State a B.Builder)
-> RDFLabel
-> B.Builder
-> 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
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)
-> (LabelContext -> RDFLabel -> State a B.Builder)
-> (a -> [RDFLabel])
-> (B.Builder -> State a B.Builder)
-> RDFLabel
-> RDFLabel
-> B.Builder
-> 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
fr <- formatObjects_ nextObject formatLabel objs nextLine sb pr prindent
nl <- nextLine $ mconcat [prstr, " ", obstr, ","]
return $ nl `mappend` fr
else return $ mconcat [prstr, " ", obstr]
insertBnode_ ::
(a -> SubjTree RDFLabel)
-> (a -> PredTree RDFLabel)
-> (a -> [RDFLabel])
-> (a -> SubjTree RDFLabel -> PredTree RDFLabel -> [RDFLabel] -> a)
-> (RDFLabel -> B.Builder -> State a B.Builder)
-> 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 ""
nst <- get
let slist = map fst $ subjs nst
nsubjs = filter (\(l,_) -> l `elem` slist) osubjs
put $ updateState nst nsubjs (props ost) (objs ost)
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
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)
-> (a -> PredTree RDFLabel)
-> (SubjTree RDFLabel -> State a ())
-> (PredTree RDFLabel -> State a ())
-> 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