module Swish.RDF.RDFGraph
( RDFLabel(..)
, isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral
, isDatatyped, isMemberProp, isUri, isBlank, isQueryVar
, getLiteralText, getScopedName, makeBlank
, RDFTriple
, NSGraph(..), RDFGraph
, NamespaceMap, RevNamespaceMap, RevNamespace
, emptyNamespaceMap
, LookupFormula(..), Formula, FormulaMap, emptyFormulaMap
, addArc, merge
, allLabels, allNodes, remapLabels, remapLabelList
, newNode, newNodes
, setNamespaces, getNamespaces
, setFormulae, getFormulae, setFormula, getFormula
, toRDFGraph, emptyRDFGraph
, LDGraph(..), Label (..), Arc(..)
, arc, arcSubj, arcPred, arcObj, Selector
, res_rdf_type, res_rdf_first, res_rdf_rest, res_rdf_nil
, res_rdfs_member
, res_rdfd_GeneralRestriction
, res_rdfd_onProperties, res_rdfd_constraint, res_rdfd_maxCardinality
, res_owl_sameAs, res_log_implies
, grMatchMap, grEq
, mapnode, maplist
)
where
import Swish.Utils.Namespace
( Namespace(..)
, getScopedNameURI
, ScopedName(..)
, nullScopedName
)
import Swish.RDF.Vocabulary
( namespaceRDF
, langTag, isLang
, rdf_type
, rdf_first, rdf_rest, rdf_nil, rdf_XMLLiteral
, rdfs_member
, rdfd_GeneralRestriction
, rdfd_onProperties, rdfd_constraint, rdfd_maxCardinality
, owl_sameAs, log_implies
)
import Swish.RDF.GraphClass
( LDGraph(..), Label (..)
, Arc(..), arc, arcSubj, arcPred, arcObj
, Selector )
import Swish.RDF.GraphMatch
( graphMatch, LabelMap, ScopedLabel(..) )
import Swish.Utils.MiscHelpers
( hash, quote )
import Swish.Utils.ListHelpers
( addSetElem )
import Swish.Utils.LookupMap
( LookupMap(..), LookupEntryClass(..)
, listLookupMap
, mapFind, mapFindMaybe, mapReplaceOrAdd, mapVals, mapKeys )
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import Control.Applicative (Applicative, liftA, (<$>), (<*>))
import Data.Char
( isDigit )
import Data.List
( intersect, union, findIndices )
import Data.Ord (comparing)
data RDFLabel =
Res ScopedName
| Lit String (Maybe ScopedName)
| Blank String
| Var String
| NoNode
instance Eq RDFLabel where
(==) = labelEq
instance Show RDFLabel where
show (Res sn) = show sn
show (Lit st Nothing) = quote st
show (Lit st (Just nam))
| isLang nam = quote st ++ "@" ++ langTag nam
| otherwise = quote st ++ "^^" ++ show nam
show (Blank ln) = "_:"++ln
show (Var ln) = '?' : ln
show NoNode = "<NoNode>"
instance Ord RDFLabel where
compare (Res sn1) (Res sn2) = compare sn1 sn2
compare (Blank ln1) (Blank ln2) = compare ln1 ln2
compare (Res _) (Blank _) = LT
compare (Blank _) (Res _) = GT
compare l1 l2 = comparing show l1 l2
instance Label RDFLabel where
labelIsVar (Blank _) = True
labelIsVar (Var _) = True
labelIsVar _ = False
getLocal (Blank loc) = loc
getLocal (Var loc) = '?':loc
getLocal (Res sn) = "Res_"++snLocal sn
getLocal (NoNode) = "None"
getLocal _ = "Lit_"
makeLabel ('?':loc) = Var loc
makeLabel loc = Blank loc
labelHash seed lb = hash seed (showCanon lb)
showCanon :: RDFLabel -> String
showCanon (Res sn) = "<"++getScopedNameURI sn++">"
showCanon (Lit st (Just nam))
| isLang nam = quote st ++ "@" ++ langTag nam
| otherwise = quote st ++ "^^" ++ getScopedNameURI nam
showCanon s = show s
labelEq :: RDFLabel -> RDFLabel -> Bool
labelEq (Res q1) (Res q2) = q1 == q2
labelEq (Blank s1) (Blank s2) = s1 == s2
labelEq (Var v1) (Var v2) = v1 == v2
labelEq (Lit s1 t1) (Lit s2 t2) = s1 == s2 && t1 == t2
labelEq _ _ = False
res_rdf_type, res_rdf_first, res_rdf_rest, res_rdf_nil,
res_rdfs_member, res_rdfd_GeneralRestriction,
res_rdfd_onProperties, res_rdfd_constraint,
res_rdfd_maxCardinality, res_owl_sameAs, res_log_implies
:: RDFLabel
res_rdf_type = Res rdf_type
res_rdf_first = Res rdf_first
res_rdf_rest = Res rdf_rest
res_rdf_nil = Res rdf_nil
res_rdfs_member = Res rdfs_member
res_rdfd_GeneralRestriction = Res rdfd_GeneralRestriction
res_rdfd_onProperties = Res rdfd_onProperties
res_rdfd_constraint = Res rdfd_constraint
res_rdfd_maxCardinality = Res rdfd_maxCardinality
res_owl_sameAs = Res owl_sameAs
res_log_implies = Res log_implies
isUri :: RDFLabel -> Bool
isUri (Res _) = True
isUri _ = False
isLiteral :: RDFLabel -> Bool
isLiteral (Lit _ _) = True
isLiteral _ = False
isUntypedLiteral :: RDFLabel -> Bool
isUntypedLiteral (Lit _ Nothing ) = True
isUntypedLiteral (Lit _ (Just tn)) = isLang tn
isUntypedLiteral _ = False
isTypedLiteral :: RDFLabel -> Bool
isTypedLiteral (Lit _ (Just tn)) = not (isLang tn)
isTypedLiteral _ = False
isXMLLiteral :: RDFLabel -> Bool
isXMLLiteral = isDatatyped rdf_XMLLiteral
isDatatyped :: ScopedName -> RDFLabel -> Bool
isDatatyped d (Lit _ (Just n)) = n == d
isDatatyped _ _ = False
isMemberProp :: RDFLabel -> Bool
isMemberProp (Res sn) = snScope sn == namespaceRDF &&
head loc == '_' &&
all isDigit (tail loc)
where
loc = snLocal sn
isMemberProp _ = False
isBlank :: RDFLabel -> Bool
isBlank (Blank _) = True
isBlank _ = False
isQueryVar :: RDFLabel -> Bool
isQueryVar (Var _) = True
isQueryVar _ = False
getLiteralText :: RDFLabel -> String
getLiteralText (Lit s _) = s
getLiteralText _ = ""
getScopedName :: RDFLabel -> ScopedName
getScopedName (Res sn) = sn
getScopedName _ = nullScopedName
makeBlank :: RDFLabel -> RDFLabel
makeBlank (Var loc) = Blank loc
makeBlank lb = lb
type RDFTriple = Arc RDFLabel
type NamespaceMap = LookupMap Namespace
data RevNamespace = RevNamespace Namespace
instance LookupEntryClass RevNamespace String String where
keyVal (RevNamespace (Namespace pre uri)) = (uri,pre)
newEntry (uri,pre) = RevNamespace (Namespace pre uri)
type RevNamespaceMap = LookupMap RevNamespace
emptyNamespaceMap :: NamespaceMap
emptyNamespaceMap = LookupMap []
data LookupFormula lb gr = Formula
{ formLabel :: lb
, formGraph :: gr
}
instance ( Eq lb, Eq gr ) => Eq (LookupFormula lb gr) where
f1 == f2 = formLabel f1 == formLabel f2 &&
formGraph f1 == formGraph f2
instance (Label lb)
=> LookupEntryClass (LookupFormula lb (NSGraph lb)) lb (NSGraph lb)
where
keyVal fe = (formLabel fe, formGraph fe)
newEntry (k,v) = Formula { formLabel=k, formGraph=v }
instance (Label lb) => Show (LookupFormula lb (NSGraph lb))
where
show (Formula l g) = show l ++ " :- { " ++ showArcs " " g ++ " }"
type Formula lb = LookupFormula lb (NSGraph lb)
type FormulaMap lb = LookupMap (LookupFormula lb (NSGraph lb))
emptyFormulaMap :: FormulaMap RDFLabel
emptyFormulaMap = LookupMap []
formulaeMap :: (lb -> l2) -> FormulaMap lb -> FormulaMap l2
formulaeMap f = fmap (formulaEntryMap f)
formulaEntryMap ::
(lb -> l2)
-> Formula lb
-> Formula l2
formulaEntryMap f (Formula k gr) = Formula (f k) (fmap f gr)
formulaeMapA :: Applicative f => (lb -> f l2) ->
FormulaMap lb -> f (FormulaMap l2)
formulaeMapA f = T.traverse (formulaEntryMapA f)
formulaEntryMapA ::
(Applicative f) =>
(lb -> f l2)
-> Formula lb
-> f (Formula l2)
formulaEntryMapA f (Formula k gr) = Formula `liftA` f k <*> T.traverse f gr
data NSGraph lb = NSGraph
{ namespaces :: NamespaceMap
, formulae :: FormulaMap lb
, statements :: [Arc lb]
}
getNamespaces :: NSGraph lb -> NamespaceMap
getNamespaces = namespaces
setNamespaces :: NamespaceMap -> NSGraph lb -> NSGraph lb
setNamespaces ns g = g { namespaces=ns }
getFormulae :: NSGraph lb -> FormulaMap lb
getFormulae = formulae
setFormulae :: FormulaMap lb -> NSGraph lb -> NSGraph lb
setFormulae fs g = g { formulae=fs }
getFormula :: (Label lb) => NSGraph lb -> lb -> Maybe (NSGraph lb)
getFormula g l = mapFindMaybe l (formulae g)
setFormula :: (Label lb) => Formula lb -> NSGraph lb -> NSGraph lb
setFormula f g = g { formulae=mapReplaceOrAdd f (formulae g) }
instance (Label lb) => LDGraph NSGraph lb where
getArcs = statements
setArcs as g = g { statements=as }
containedIn = error "containedIn for LDGraph NSGraph lb is undefined!"
addArc :: (Label lb) => Arc lb -> NSGraph lb -> NSGraph lb
addArc ar gr = gr { statements=addSetElem ar (statements gr) }
instance Functor NSGraph where
fmap f (NSGraph ns fml stmts) =
NSGraph ns (formulaeMap f fml) ((map $ fmap f) stmts)
instance F.Foldable NSGraph where
foldMap = T.foldMapDefault
instance T.Traversable NSGraph where
traverse f (NSGraph ns fml stmts) =
NSGraph ns <$> formulaeMapA f fml <*> (T.traverse $ T.traverse f) stmts
instance (Label lb) => Eq (NSGraph lb) where
(==) = grEq
instance (Label lb) => Show (NSGraph lb) where
show = grShow ""
showList = grShowList ""
grShowList :: (Label lb) => String -> [NSGraph lb] -> String -> String
grShowList _ [] = showString "[no graphs]"
grShowList p (g:gs) = showChar '[' . showString (grShow pp g) . showl gs
where
showl [] = showChar ']'
showl (h:hs) = showString (",\n "++p++grShow pp h) . showl hs
pp = ' ':p
grShow :: (Label lb) => String -> NSGraph lb -> String
grShow p g =
"Graph, formulae: " ++ showForm ++ "\n" ++
p ++ "arcs: " ++ showArcs p g
where
showForm = foldr ((++) . (pp ++) . show) "" fml
fml = listLookupMap (getFormulae g)
pp = "\n " ++ p
showArcs :: (Label lb) => String -> NSGraph lb -> String
showArcs p g = foldr ((++) . (pp ++) . show) "" (getArcs g)
where
pp = "\n " ++ p
grEq :: (Label lb) => NSGraph lb -> NSGraph lb -> Bool
grEq g1 g2 = fst ( grMatchMap g1 g2 )
grMatchMap :: (Label lb) =>
NSGraph lb -> NSGraph lb -> (Bool, LabelMap (ScopedLabel lb))
grMatchMap g1 g2 =
graphMatch matchable (getArcs g1) (getArcs g2)
where
matchable l1 l2 = mapFormula g1 l1 == mapFormula g2 l2
mapFormula g l = mapFindMaybe l (getFormulae g)
toNSGraph :: (Eq lb, Show lb) => [Arc lb] -> NSGraph lb
toNSGraph arcs =
NSGraph
{ statements = arcs
, namespaces = emptyNamespaceMap
, formulae = LookupMap []
}
merge :: (Label lb) => NSGraph lb -> NSGraph lb -> NSGraph lb
merge gr1 gr2 =
let
bn1 = allLabels labelIsVar gr1
bn2 = allLabels labelIsVar gr2
dupbn = intersect bn1 bn2
allbn = union bn1 bn2
in
add gr1 (remapLabels dupbn allbn id gr2)
allLabels :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb]
allLabels p gr = filter p (unionNodes p (formulaNodes p gr) (labels gr) )
allNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb]
allNodes p = unionNodes p [] . nodes
formulaNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb]
formulaNodes p gr = foldl (unionNodes p) fkeys (map (allLabels p) fvals)
where
fm = formulae gr
fvals = mapVals fm
fkeys = filter p $ mapKeys fm
unionNodes :: (Label lb) => (lb -> Bool) -> [lb] -> [lb] -> [lb]
unionNodes p ls1 ls2 = ls1 `union` filter p ls2
remapLabels ::
(Label lb)
=> [lb]
-> [lb]
-> (lb -> lb)
-> NSGraph lb
-> NSGraph lb
remapLabels dupbn allbn cnvbn = fmap (mapnode dupbn allbn cnvbn)
remapLabelList ::
(Label lb)
=> [lb]
-> [lb]
-> [(lb,lb)]
remapLabelList remap avoid = maplist remap avoid id []
mapnode ::
(Label lb) => [lb] -> [lb] -> (lb -> lb) -> lb -> lb
mapnode dupbn allbn cnvbn nv =
mapFind nv nv (LookupMap (maplist dupbn allbn cnvbn []))
maplist ::
(Label lb)
=> [lb]
-> [lb]
-> (lb -> lb)
-> [(lb,lb)]
-> [(lb,lb)]
maplist [] _ _ mapbn = mapbn
maplist (dn:dupbn) allbn cnvbn mapbn = maplist dupbn allbn' cnvbn mapbn'
where
dnmap = newNode (cnvbn dn) allbn
mapbn' = (dn,dnmap):mapbn
allbn' = dnmap:allbn
newNode :: (Label lb) => lb -> [lb] -> lb
newNode dn existnodes =
head $ newNodes dn existnodes
newNodes :: (Label lb) => lb -> [lb] -> [lb]
newNodes dn existnodes =
filter (not . (`elem` existnodes)) $ trynodes (noderootindex dn)
noderootindex :: (Label lb) => lb -> (String,Int)
noderootindex dn = (nh,nx) where
(nh,nt) = splitnodeid $ getLocal dn
nx = if null nt then 0 else read nt
splitnodeid :: String -> (String,String)
splitnodeid dn = splitAt (tx+1) dn where
tx = last $ (1):findIndices (not . isDigit) dn
trynodes :: (Label lb) => (String,Int) -> [lb]
trynodes (nr,nx) = [ makeLabel (nr++show n) | n <- iterate (+1) nx ]
type RDFGraph = NSGraph RDFLabel
toRDFGraph :: [Arc RDFLabel] -> RDFGraph
toRDFGraph = toNSGraph
emptyRDFGraph :: RDFGraph
emptyRDFGraph = toRDFGraph []