module Swish.RDF.N3Formatter
( NodeGenLookupMap
, formatGraphAsStringNl
, formatGraphAsString
, formatGraphAsShowS
, formatGraphIndent
, formatGraphDiag
)
where
import Swish.RDF.RDFGraph (
RDFGraph, RDFLabel(..),
NamespaceMap, RevNamespaceMap,
emptyNamespaceMap,
FormulaMap, emptyFormulaMap,
getArcs, labels,
setNamespaces, getNamespaces,
getFormulae,
emptyRDFGraph,
res_rdf_first, res_rdf_rest, res_rdf_nil
)
import Swish.RDF.Vocabulary (
isLang, langTag,
rdf_type,
rdf_nil,
owl_sameAs, log_implies
)
import Swish.RDF.GraphClass
( Arc(..) )
import Swish.Utils.LookupMap
( LookupEntryClass(..)
, LookupMap, emptyLookupMap, reverseLookupMap
, listLookupMap
, mapFind, mapFindMaybe, mapAdd, mapDelete, mapMerge
)
import Swish.Utils.Namespace
( ScopedName(..), getScopeURI )
import Data.Char (ord, isDigit)
import Data.List (foldl', delete, groupBy, intercalate, partition, sort)
import Text.Printf (printf)
import Control.Monad (liftM, when)
import Control.Monad.State (State, get, put, runState)
puts :: String -> ShowS
puts = showString
type SubjTree lb = [(lb,PredTree lb)]
type PredTree lb = [(lb,[lb])]
data N3FormatterState = N3FS
{ indent :: String
, lineBreak :: Bool
, graph :: RDFGraph
, subjs :: SubjTree RDFLabel
, props :: PredTree RDFLabel
, objs :: [RDFLabel]
, formAvail :: FormulaMap RDFLabel
, formQueue :: [(RDFLabel,RDFGraph)]
, nodeGenSt :: NodeGenState
, bNodesCheck :: [RDFLabel]
, traceBuf :: [String]
}
type Formatter a = State N3FormatterState a
emptyN3FS :: NodeGenState -> N3FormatterState
emptyN3FS ngs = N3FS
{ indent = "\n"
, lineBreak = False
, graph = emptyRDFGraph
, subjs = []
, props = []
, objs = []
, formAvail = emptyFormulaMap
, formQueue = []
, nodeGenSt = ngs
, bNodesCheck = []
, traceBuf = []
}
type NodeGenLookupMap = LookupMap (RDFLabel,Int)
data NodeGenState = Ngs
{ prefixes :: NamespaceMap
, nodeMap :: NodeGenLookupMap
, nodeGen :: Int
}
emptyNgs :: NodeGenState
emptyNgs = Ngs
{ prefixes = emptyLookupMap
, nodeMap = emptyLookupMap
, nodeGen = 0
}
data LabelContext = SubjContext | PredContext | ObjContext
deriving (Eq, Show)
getIndent :: Formatter String
getIndent = indent `liftM` get
setIndent :: String -> Formatter ()
setIndent ind = do
st <- get
put $ st { indent = ind }
getLineBreak :: Formatter Bool
getLineBreak = lineBreak `liftM` get
setLineBreak :: Bool -> Formatter ()
setLineBreak brk = do
st <- get
put $ st {lineBreak = brk}
getNgs :: Formatter NodeGenState
getNgs = nodeGenSt `liftM` get
setNgs :: NodeGenState -> Formatter ()
setNgs ngs = do
st <- get
put $ st { nodeGenSt = ngs }
getPrefixes :: Formatter NamespaceMap
getPrefixes = prefixes `liftM` getNgs
getSubjs :: Formatter (SubjTree RDFLabel)
getSubjs = subjs `liftM` get
setSubjs :: SubjTree RDFLabel -> Formatter ()
setSubjs sl = do
st <- get
put $ st { subjs = sl }
getProps :: Formatter (PredTree RDFLabel)
getProps = props `liftM` get
setProps :: PredTree RDFLabel -> Formatter ()
setProps ps = do
st <- get
put $ st { props = ps }
getBnodesCheck :: Formatter ([RDFLabel])
getBnodesCheck = bNodesCheck `liftM` get
queueFormula :: RDFLabel -> Formatter ()
queueFormula fn = do
st <- get
let fa = formAvail st
newState fv = st {
formAvail = mapDelete fa fn,
formQueue = (fn,fv) : formQueue st
}
case mapFindMaybe fn fa of
Nothing -> return ()
Just v -> put (newState v) >> return ()
extractFormula :: RDFLabel -> Formatter (Maybe RDFGraph)
extractFormula fn = do
st <- get
let fa = formAvail st
newState = st { formAvail=mapDelete fa fn }
case mapFindMaybe fn fa of
Nothing -> return Nothing
Just fv -> put newState >> return (Just fv)
len1 :: [a] -> Bool
len1 (_:[]) = True
len1 _ = False
getCollection ::
SubjTree RDFLabel
-> RDFLabel
-> Maybe (SubjTree RDFLabel, [RDFLabel], [RDFLabel])
getCollection subjList lbl = go subjList lbl ([],[])
where
go sl l (cs,ss) | l == res_rdf_nil = Just (sl, reverse cs, ss)
| otherwise = do
(pList1, sl') <- removeItem sl l
(pFirst, pList2) <- removeItem pList1 res_rdf_first
(pNext, pList3) <- removeItem pList2 res_rdf_rest
if and [len1 pFirst, len1 pNext, null pList3]
then go sl' (head pNext) (head pFirst : cs, l : ss)
else Nothing
extractList :: LabelContext -> RDFLabel -> Formatter (Maybe [RDFLabel])
extractList lctxt ln = do
osubjs <- getSubjs
oprops <- getProps
let mlst = getCollection osubjs' ln
fprops = filter ((`elem` [res_rdf_first, res_rdf_rest]) . fst) oprops
osubjs' =
case lctxt of
SubjContext -> (ln, fprops) : osubjs
_ -> osubjs
case mlst of
Just (sl,ls,_) -> do
setSubjs sl
when (lctxt == SubjContext) $ setProps $ filter ((`notElem` [res_rdf_first, res_rdf_rest]) . fst) oprops
return (Just ls)
Nothing -> return Nothing
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
formatGraphAsStringNl :: RDFGraph -> String
formatGraphAsStringNl gr = formatGraphAsShowS gr "\n"
formatGraphAsString :: RDFGraph -> String
formatGraphAsString gr = formatGraphAsShowS gr ""
formatGraphAsShowS :: RDFGraph -> ShowS
formatGraphAsShowS = formatGraphIndent "\n" True
formatGraphIndent :: String -> Bool -> RDFGraph -> ShowS
formatGraphIndent ind dopref = fst . formatGraphDiag1 ind dopref emptyLookupMap
formatGraphDiag ::
RDFGraph -> (ShowS,NodeGenLookupMap,Int,[String])
formatGraphDiag gr = (out,nodeMap ngs,nodeGen ngs,traceBuf fgs)
where
(out,fgs) = formatGraphDiag1 "\n" True emptyLookupMap gr
ngs = nodeGenSt fgs
formatGraphDiag1 :: String -> Bool -> NamespaceMap -> RDFGraph -> (ShowS,N3FormatterState)
formatGraphDiag1 ind dopref pref gr =
let fg = formatGraph ind " ." False dopref gr
ngs = emptyNgs {
prefixes=pref,
nodeGen=findMaxBnode gr
}
in runState fg (emptyN3FS ngs)
formatGraph :: String -> String -> Bool -> Bool -> RDFGraph -> Formatter ShowS
formatGraph ind end dobreak dopref gr = do
setIndent ind
setLineBreak dobreak
setGraph gr
fp <- if dopref
then formatPrefixes (getNamespaces gr)
else return $ puts ""
more <- moreSubjects
res <- if more
then do
fr <- formatSubjects
return $ fp . fr . puts end
else return fp
return res
formatPrefixes :: NamespaceMap -> Formatter ShowS
formatPrefixes pmap = do
let mls = map (pref . keyVal) (listLookupMap pmap)
ls <- sequence mls
return $ puts $ concat ls
where
pref (p,u) = nextLine $ "@prefix "++p++": <"++ quote True u ++"> ."
formatSubjects :: Formatter ShowS
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 $ puts (prstr ++ " .") . fr
else return $ puts $ prstr
else do
txt <- nextLine sbstr
return $ puts txt
formatProperties :: RDFLabel -> String -> Formatter String
formatProperties sb sbstr = do
pr <- nextProperty sb
prstr <- formatLabel PredContext pr
obstr <- formatObjects sb pr (sbstr++" "++prstr)
more <- moreProperties
let sbindent = replicate (length sbstr) ' '
if more
then do
fr <- formatProperties sb sbindent
nl <- nextLine $ obstr ++ " ;"
return $ nl ++ fr
else nextLine obstr
formatObjects :: RDFLabel -> RDFLabel -> String -> Formatter String
formatObjects sb pr prstr = do
ob <- nextObject sb pr
obstr <- formatLabel ObjContext ob
more <- moreObjects
if more
then do
let prindent = replicate (length prstr) ' '
fr <- formatObjects sb pr prindent
nl <- nextLine $ prstr ++ " " ++ obstr ++ ","
return $ nl ++ fr
else return $ prstr ++ " " ++ obstr
insertFormula :: RDFGraph -> Formatter String
insertFormula gr = do
ngs0 <- getNgs
ind <- getIndent
let grm = formatGraph (ind++" ") "" True False
(setNamespaces emptyNamespaceMap gr)
(f3str, fgs') = runState grm (emptyN3FS ngs0)
setNgs (nodeGenSt fgs')
f4str <- nextLine " } "
return $ " { " ++ f3str f4str
insertList :: [RDFLabel] -> Formatter String
insertList [] = return $ "()"
insertList xs = do
ls <- mapM (formatLabel ObjContext) xs
return $ "( " ++ intercalate " " ls ++ " )"
insertBnode :: LabelContext -> RDFLabel -> Formatter String
insertBnode SubjContext lbl = do
flag <- moreProperties
txt <- if flag
then liftM (++"\n") $ formatProperties lbl ""
else return ""
return $ "[" ++ 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
_ -> []
nst = ost { subjs = rsubjs,
props = rprops,
objs = []
}
put nst
flag <- moreProperties
txt <- if flag
then liftM (++"\n") $ formatProperties lbl ""
else return ""
nst' <- get
let slist = map fst $ subjs nst'
nsubjs = filter (\(l,_) -> l `elem` slist) osubjs
put $ nst' { subjs = nsubjs,
props = oprops,
objs = oobjs
}
return $ "[" ++ txt ++ "]"
setGraph :: RDFGraph -> Formatter ()
setGraph gr = do
st <- get
let ngs0 = nodeGenSt st
pre' = mapMerge (prefixes ngs0) (getNamespaces gr)
ngs' = ngs0 { prefixes = pre' }
arcs = sortArcs $ getArcs gr
nst = st { graph = gr
, subjs = arcTree arcs
, props = []
, objs = []
, formAvail = getFormulae gr
, nodeGenSt = ngs'
, bNodesCheck = countBnodes arcs
}
put nst
moreSubjects :: Formatter Bool
moreSubjects = (not . null . subjs) `liftM` get
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
moreProperties :: Formatter Bool
moreProperties = (not . null . props) `liftM` get
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
moreObjects :: Formatter Bool
moreObjects = (not . null . objs) `liftM` get
nextObject :: RDFLabel -> RDFLabel -> Formatter RDFLabel
nextObject _ _ = do
st <- get
let ob:obs = objs st
nst = st { objs = obs }
put nst
return ob
nextLine :: String -> Formatter String
nextLine str = do
ind <- getIndent
brk <- getLineBreak
if brk
then return $ ind++str
else do
setLineBreak True
return str
specialTable :: [(ScopedName, String)]
specialTable =
[ (rdf_type, "a")
, (owl_sameAs, "=")
, (log_implies, "=>")
, (rdf_nil, "()")
]
formatLabel :: LabelContext -> RDFLabel -> Formatter String
formatLabel lctxt lab@(Blank (_:_)) = do
mlst <- extractList lctxt lab
case mlst of
Just lst -> insertList lst
Nothing -> do
mfml <- extractFormula lab
case mfml of
Just fml -> insertFormula fml
Nothing -> do
nb1 <- getBnodesCheck
if lctxt /= PredContext && lab `notElem` nb1
then insertBnode lctxt lab
else formatNodeId lab
formatLabel _ lab@(Res sn) =
case lookup sn specialTable of
Just txt -> return $ quote True txt
Nothing -> do
pr <- getPrefixes
let nsuri = getScopeURI sn
local = snLocal sn
premap = reverseLookupMap pr :: RevNamespaceMap
prefix = mapFindMaybe nsuri premap
name = case prefix of
Just p -> quote True (p ++ ":" ++ local)
_ -> "<"++ quote True (nsuri++local) ++">"
queueFormula lab
return name
formatLabel _ (Lit lit mlit) = return $ quoteStr lit ++ formatAnnotation mlit
formatLabel _ lab = return $ show lab
formatAnnotation :: Maybe ScopedName -> String
formatAnnotation Nothing = ""
formatAnnotation (Just a) | isLang a = '@' : langTag a
| otherwise = '^':'^': showScopedName a
quoteStr :: String -> String
quoteStr st =
let qst = quote (n==1) st
n = if '\n' `elem` st || '"' `elem` st then 3 else 1
qch = replicate n '"'
in qch ++ qst ++ qch
quote :: Bool -> String -> String
quote _ [] = ""
quote True ('"': st) = '\\':'"': quote True st
quote True ('\n':st) = '\\':'n': quote True st
quote True ('\t':st) = '\\':'t': quote True st
quote False ('"': st) = '"': quote False st
quote False ('\n':st) = '\n': quote False st
quote False ('\t':st) = '\t': quote False st
quote f ('\r':st) = '\\':'r': quote f st
quote f ('\\':st) = '\\':'\\': quote f st
quote f (c:st) =
let nc = ord c
rst = quote f st
hstr = printf "%08X" nc
ustr = hstr ++ rst
in if nc > 0xffff
then '\\':'U': ustr
else if nc > 0x7e || nc < 0x20
then '\\':'u': drop 4 ustr
else c : rst
formatNodeId :: RDFLabel -> Formatter String
formatNodeId lab@(Blank (lnc:_)) =
if isDigit lnc then mapBlankNode lab else return $ show lab
formatNodeId other = error $ "formatNodeId not expecting a " ++ show other
mapBlankNode :: RDFLabel -> Formatter String
mapBlankNode lab = do
ngs <- getNgs
let cmap = nodeMap ngs
cval = nodeGen ngs
nv <- case mapFind 0 lab cmap of
0 -> do
let nval = succ cval
nmap = mapAdd cmap (lab, nval)
setNgs $ ngs { nodeGen = nval, nodeMap = nmap }
return nval
n -> return n
return $ "_:swish" ++ show nv
showScopedName :: ScopedName -> String
showScopedName = quote True . show
newtype SortedArcs lb = SA [Arc lb]
sortArcs :: (Ord lb) => [Arc lb] -> SortedArcs lb
sortArcs = SA . sort
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 -> Int
findMaxBnode = maximum . map getAutoBnodeIndex . labels
getAutoBnodeIndex :: RDFLabel -> Int
getAutoBnodeIndex (Blank ('_':lns)) = res where
res = case [x | (x,t) <- reads lns, ("","") <- lex t] of
[x] -> x
_ -> 0
getAutoBnodeIndex _ = 0
countBnodes :: SortedArcs RDFLabel -> [RDFLabel]
countBnodes (SA as) = snd (foldl' ctr ([],[]) as)
where
inc b@(b1s,bms) l@(Blank _) | l `elem` bms = b
| l `elem` b1s = (delete l b1s, l:bms)
| otherwise = (l:b1s, bms)
inc b _ = b
incP b@(b1s,bms) l@(Blank _) | l `elem` bms = b
| l `elem` b1s = (delete l b1s, l:bms)
| otherwise = (b1s, l:bms)
incP b _ = b
ctr orig (Arc _ p o) = inc (incP orig p) o