{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
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, intersperse, partition)
import Data.Maybe (isJust)
#if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710)
import Data.Monoid (Monoid(..), mconcat)
#endif
import Data.Tuple (swap)
import Data.Word
import Network.URI (URI)
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 :: 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
quoteBString :: String -> B.Builder
quoteBString = quoteB True
quoteText :: T.Text -> B.Builder
quoteText txt =
let
hasNL = isJust $ T.findIndex (== '\n') txt
hasSQ = isJust $ T.findIndex (== '"') txt
has3Q = "\"\"\"" `T.isInfixOf` txt
n = if has3Q || (not hasNL && not hasSQ) then 1 else 3
qch = B.fromString (replicate n '"')
qst = B.fromText $ quoteT (n==1) txt
in mconcat [qch, qst, qch]
showScopedName :: ScopedName -> B.Builder
showScopedName = quoteBString . 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 [ "<"
, quoteBString (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, ": <", quoteBString (show u), "> ."]
pref (_,u) = mconcat ["@prefix : <", quoteBString (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