module Swish.RDF.RDFGraph
(
RDFLabel(..), ToRDFLabel(..), FromRDFLabel(..)
, isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral
, isDatatyped, isMemberProp, isUri, isBlank, isQueryVar
, getLiteralText, getScopedName, makeBlank
, RDFTriple
, toRDFTriple, fromRDFTriple
, NSGraph(..)
, RDFGraph
, toRDFGraph, emptyRDFGraph
, NamespaceMap, RevNamespaceMap, RevNamespace
, emptyNamespaceMap
, LookupFormula(..), Formula, FormulaMap, emptyFormulaMap
, addArc, merge
, allLabels, allNodes, remapLabels, remapLabelList
, newNode, newNodes
, setNamespaces, getNamespaces
, setFormulae, getFormulae, setFormula, getFormula
, 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(..)
, getQName
, makeQNameScopedName
, makeUriScopedName
, 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
, xsd_boolean, xsd_float, xsd_double, xsd_integer
, xsd_dateTime, xsd_date
)
import Swish.RDF.GraphClass
( LDGraph(..), Label (..)
, Arc(..), arc, arcSubj, arcPred, arcObj
, Selector )
import Swish.RDF.GraphMatch (graphMatch, LabelMap, ScopedLabel(..))
import Swish.Utils.QName (QName)
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 Network.URI (URI, parseURI, uriToString)
import Data.Monoid (Monoid(..))
import Data.Char (isDigit)
import Data.List (intersect, union, findIndices)
import Data.Ord (comparing)
import Data.String (IsString(..))
import Data.Time (UTCTime, Day, ParseTime, parseTime, formatTime)
import System.Locale (defaultTimeLocale)
import Text.Printf
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)
instance IsString RDFLabel where
fromString = flip Lit Nothing
class ToRDFLabel a where
toRDFLabel :: a -> RDFLabel
class FromRDFLabel a where
fromRDFLabel :: RDFLabel -> Maybe a
instance ToRDFLabel RDFLabel where
toRDFLabel = id
instance FromRDFLabel RDFLabel where
fromRDFLabel = Just . id
maybeRead :: (Read a) => String -> Maybe a
maybeRead inStr =
case reads inStr of
[(val, "")] -> Just val
_ -> Nothing
fLabel :: (String -> Maybe a) -> ScopedName -> RDFLabel -> Maybe a
fLabel conv dtype (Lit xs (Just dt)) | dt == dtype = conv xs
| otherwise = Nothing
fLabel _ _ _ = Nothing
tLabel :: (Show a) => ScopedName -> (String -> String) -> a -> RDFLabel
tLabel dtype conv = flip Lit (Just dtype) . conv . show
instance ToRDFLabel Char where
toRDFLabel = flip Lit Nothing . (:[])
instance FromRDFLabel Char where
fromRDFLabel (Lit [c] Nothing) = Just c
fromRDFLabel _ = Nothing
instance ToRDFLabel String where
toRDFLabel = flip Lit Nothing
instance FromRDFLabel String where
fromRDFLabel (Lit xs Nothing) = Just xs
fromRDFLabel _ = Nothing
instance ToRDFLabel Bool where
toRDFLabel b = Lit (if b then "true" else "false") (Just xsd_boolean)
instance FromRDFLabel Bool where
fromRDFLabel = fLabel conv xsd_boolean
where
conv s | s `elem` ["1", "true"] = Just True
| s `elem` ["0", "false"] = Just False
| otherwise = Nothing
fromRealFloat :: (RealFloat a, PrintfArg a) => ScopedName -> a -> RDFLabel
fromRealFloat dtype f | isNaN f = toL "NaN"
| isInfinite f = toL $ if f > 0.0 then "INF" else "-INF"
| otherwise = toL $ printf "%E" f
where
toL = flip Lit (Just dtype)
toRealFloat :: (RealFloat a, Read a) => (a -> Maybe a) -> ScopedName -> RDFLabel -> Maybe a
toRealFloat conv = fLabel rconv
where
rconv "NaN" = Just (0.0/0.0)
rconv "INF" = Just (1.0/0.0)
rconv "-INF" = Just ((1.0)/0.0)
rconv istr
| null istr = Nothing
| last istr == '.' = maybeRead (istr ++ "0") >>= conv
| otherwise = maybeRead istr >>= conv
instance ToRDFLabel Float where
toRDFLabel = fromRealFloat xsd_float
instance FromRDFLabel Float where
fromRDFLabel = toRealFloat conv xsd_float
where
conv f | isNaN f || isInfinite f = Nothing
| otherwise = Just f
instance ToRDFLabel Double where
toRDFLabel = fromRealFloat xsd_double
instance FromRDFLabel Double where
fromRDFLabel = toRealFloat Just xsd_double
instance ToRDFLabel Int where
toRDFLabel = tLabel xsd_integer id
instance FromRDFLabel Int where
fromRDFLabel = fLabel (\istr -> maybeRead istr >>= conv) xsd_integer
where
conv :: Integer -> Maybe Int
conv i =
let lb = fromIntegral (minBound :: Int)
ub = fromIntegral (maxBound :: Int)
in if (i >= lb) && (i <= ub) then Just (fromIntegral i) else Nothing
instance ToRDFLabel Integer where
toRDFLabel = tLabel xsd_integer id
instance FromRDFLabel Integer where
fromRDFLabel = fLabel maybeRead xsd_integer
fromUTCFormat :: UTCTime -> String
fromUTCFormat = formatTime defaultTimeLocale "%FT%T%QZ"
fromDayFormat :: Day -> String
fromDayFormat = formatTime defaultTimeLocale "%FZ"
toTimeFormat :: (ParseTime a) => String -> String -> Maybe a
toTimeFormat fmt inVal =
let fmtHHMM = fmt ++ "%z"
fmtZ = fmt ++ "Z"
pt f = parseTime defaultTimeLocale f inVal
in case pt fmtHHMM of
o@(Just _) -> o
_ -> case pt fmtZ of
o@(Just _) -> o
_ -> pt fmt
toUTCFormat :: String -> Maybe UTCTime
toUTCFormat = toTimeFormat "%FT%T%Q"
toDayFormat :: String -> Maybe Day
toDayFormat = toTimeFormat "%F"
instance ToRDFLabel UTCTime where
toRDFLabel = flip Lit (Just xsd_dateTime) . fromUTCFormat
instance FromRDFLabel UTCTime where
fromRDFLabel = fLabel toUTCFormat xsd_dateTime
instance ToRDFLabel Day where
toRDFLabel = flip Lit (Just xsd_date) . fromDayFormat
instance FromRDFLabel Day where
fromRDFLabel = fLabel toDayFormat xsd_date
instance ToRDFLabel ScopedName where
toRDFLabel = Res
instance FromRDFLabel ScopedName where
fromRDFLabel (Res sn) = Just sn
fromRDFLabel _ = Nothing
instance ToRDFLabel QName where
toRDFLabel = Res . makeQNameScopedName
instance FromRDFLabel QName where
fromRDFLabel (Res sn) = Just $ getQName sn
fromRDFLabel _ = Nothing
instance ToRDFLabel URI where
toRDFLabel u = Res $ makeUriScopedName $ uriToString id u ""
instance FromRDFLabel URI where
fromRDFLabel (Res sn) = parseURI $ getScopedNameURI sn
fromRDFLabel _ = Nothing
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
toRDFTriple ::
(ToRDFLabel s, ToRDFLabel p, ToRDFLabel o)
=> s
-> p
-> o
-> RDFTriple
toRDFTriple s p o =
Arc (toRDFLabel s) (toRDFLabel p) (toRDFLabel o)
fromRDFTriple ::
(FromRDFLabel s, FromRDFLabel p, FromRDFLabel o)
=> RDFTriple
-> Maybe (s, p, o)
fromRDFTriple (Arc s p o) =
(,,) <$> fromRDFLabel s <*> fromRDFLabel p <*> fromRDFLabel o
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) => Monoid (NSGraph lb) where
mempty = NSGraph emptyNamespaceMap (LookupMap []) []
mappend = merge
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)
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 arcs = emptyRDFGraph { statements = arcs }
emptyRDFGraph :: RDFGraph
emptyRDFGraph = mempty