module Swish.RDF.RDFGraph
(
RDFLabel(..), ToRDFLabel(..), FromRDFLabel(..)
, isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral
, isDatatyped, isMemberProp, isUri, isBlank, isQueryVar
, getLiteralText, getScopedName, makeBlank
, quote
, quoteT
, 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
, resRdfRDF
, resRdfDescription
, resRdfID
, resRdfAbout
, resRdfParseType
, resRdfResource
, resRdfLi
, resRdfNodeID
, resRdfDatatype
, resRdf1, resRdf2, resRdfn
, resRdfsResource
, resRdfsClass
, resRdfsLiteral
, resRdfsDatatype
, resRdfXMLLiteral
, resRdfProperty
, resRdfsRange
, resRdfsDomain
, resRdfType
, resRdfsSubClassOf
, resRdfsSubPropertyOf
, resRdfsLabel
, resRdfsComment
, resRdfsContainer
, resRdfBag
, resRdfSeq
, resRdfAlt
, resRdfsContainerMembershipProperty
, resRdfsMember
, resRdfList
, resRdfFirst
, resRdfRest
, resRdfNil
, resRdfStatement
, resRdfSubject
, resRdfPredicate
, resRdfObject
, resRdfsSeeAlso
, resRdfsIsDefinedBy
, resRdfValue
, resOwlSameAs
, resRdfdGeneralRestriction
, resRdfdOnProperties, resRdfdConstraint, resRdfdMaxCardinality
, resLogImplies
, grMatchMap, grEq
, mapnode, maplist
)
where
import Swish.Utils.Namespace
( Namespace, makeNamespace, getNamespaceTuple
, getScopedNameURI
, ScopedName
, getScopeLocal, getScopeNamespace
, getQName
, makeQNameScopedName
, makeURIScopedName
, nullScopedName
)
import Swish.RDF.Vocabulary
import Swish.RDF.GraphClass
( LDGraph(..), Label (..)
, Arc(..), arc, arcSubj, arcPred, arcObj, arcLabels
, Selector )
import Swish.RDF.GraphMatch (graphMatch, LabelMap, ScopedLabel(..))
import Swish.Utils.QName (QName)
import Swish.Utils.MiscHelpers (hash)
import Swish.Utils.ListHelpers (addSetElem)
import Swish.Utils.LookupMap
( LookupMap(..), LookupEntryClass(..)
, listLookupMap
, mapFind, mapFindMaybe, mapReplaceOrAdd, mapAddIfNew
, mapVals, mapKeys )
import qualified Data.Foldable as Foldable
import qualified Data.Traversable as Traversable
import qualified Data.Text as T
import qualified Data.Text.Read as T
import Control.Applicative (Applicative, liftA, (<$>), (<*>))
import Network.URI (URI)
import Data.Monoid (Monoid(..))
import Data.Maybe (mapMaybe)
import Data.Char (ord, isDigit)
import Data.List (intersect, union, findIndices, foldl')
import Data.Ord (comparing)
import Data.String (IsString(..))
import Data.Time (UTCTime, Day, ParseTime, parseTime, formatTime)
import System.Locale (defaultTimeLocale)
import Text.Printf
swap :: (a,b) -> (b,a)
swap (a,b) = (b,a)
data RDFLabel =
Res ScopedName
| Lit T.Text (Maybe ScopedName)
| Blank String
| Var String
| NoNode
instance Eq RDFLabel where
Res q1 == Res q2 = q1 == q2
Blank b1 == Blank b2 = b1 == b2
Var v1 == Var v2 = v1 == v2
Lit s1 Nothing == Lit s2 Nothing = s1 == s2
Lit s1 (Just t1) == Lit s2 (Just t2) = s1 == s2 && (t1 == t2 ||
(isLang t1 && isLang t2 &&
(T.toLower . langTag) t1 == (T.toLower . langTag) t2))
_ == _ = False
instance Show RDFLabel where
show (Res sn) = show sn
show (Lit st Nothing) = quote1Str st
show (Lit st (Just nam))
| isLang nam = quote1Str st ++ "@" ++ T.unpack (langTag nam)
| nam `elem` [xsdBoolean, xsdDouble, xsdDecimal, xsdInteger] = T.unpack st
| otherwise = quote1Str 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_" ++ T.unpack (getScopeLocal 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 . T.pack
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
maybeReadStr :: (Read a) => T.Text -> Maybe a
maybeReadStr txt = case reads (T.unpack txt) of
[(val, "")] -> Just val
_ -> Nothing
maybeRead :: T.Reader a -> T.Text -> Maybe a
maybeRead rdr inTxt =
case rdr inTxt of
Right (val, "") -> Just val
_ -> Nothing
fLabel :: (T.Text -> 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 -> T.Text) -> a -> RDFLabel
tLabel dtype conv = flip Lit (Just dtype) . conv . show
instance ToRDFLabel Char where
toRDFLabel = flip Lit Nothing . T.singleton
instance FromRDFLabel Char where
fromRDFLabel (Lit cs Nothing) | T.compareLength cs 1 == EQ = Just (T.head cs)
| otherwise = Nothing
fromRDFLabel _ = Nothing
instance ToRDFLabel String where
toRDFLabel = flip Lit Nothing . T.pack
instance FromRDFLabel String where
fromRDFLabel (Lit xs Nothing) = Just (T.unpack xs)
fromRDFLabel _ = Nothing
textToBool :: T.Text -> Maybe Bool
textToBool s | s `elem` ["1", "true"] = Just True
| s `elem` ["0", "false"] = Just False
| otherwise = Nothing
instance ToRDFLabel Bool where
toRDFLabel b = Lit (if b then "true" else "false") (Just xsdBoolean)
instance FromRDFLabel Bool where
fromRDFLabel = fLabel textToBool xsdBoolean
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 $ T.pack $ printf "%E" f
where
toL = flip Lit (Just dtype)
textToRealFloat :: (RealFloat a, Read a) => (a -> Maybe a) -> T.Text -> Maybe a
textToRealFloat conv = rconv
where
rconv "NaN" = Just (0.0/0.0)
rconv "INF" = Just (1.0/0.0)
rconv "-INF" = Just ((1.0)/0.0)
rconv ival
| T.null ival = Nothing
| otherwise = case maybeReadStr ival of
Just val -> conv val
_ -> if T.last ival == '.'
then maybeReadStr (T.snoc ival '0') >>= conv
else Nothing
textToFloat :: T.Text -> Maybe Float
textToFloat =
let
conv f | isNaN f || isInfinite f = Nothing
| otherwise = Just f
in textToRealFloat conv
textToDouble :: T.Text -> Maybe Double
textToDouble = textToRealFloat Just
instance ToRDFLabel Float where
toRDFLabel = fromRealFloat xsdFloat
instance FromRDFLabel Float where
fromRDFLabel = fLabel textToFloat xsdFloat
instance ToRDFLabel Double where
toRDFLabel = fromRealFloat xsdDouble
instance FromRDFLabel Double where
fromRDFLabel = fLabel textToDouble xsdDouble
instance ToRDFLabel Int where
toRDFLabel = tLabel xsdInteger T.pack
textToInt :: T.Text -> Maybe Int
textToInt s =
let 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
in maybeRead (T.signed T.decimal) s >>= conv
instance FromRDFLabel Int where
fromRDFLabel = fLabel textToInt xsdInteger
instance ToRDFLabel Integer where
toRDFLabel = tLabel xsdInteger T.pack
instance FromRDFLabel Integer where
fromRDFLabel = fLabel (maybeRead (T.signed T.decimal)) xsdInteger
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 :: T.Text -> Maybe UTCTime
toUTCFormat = toTimeFormat "%FT%T%Q" . T.unpack
toDayFormat :: T.Text -> Maybe Day
toDayFormat = toTimeFormat "%F" . T.unpack
instance ToRDFLabel UTCTime where
toRDFLabel = flip Lit (Just xsdDateTime) . T.pack . fromUTCFormat
instance FromRDFLabel UTCTime where
fromRDFLabel = fLabel toUTCFormat xsdDateTime
instance ToRDFLabel Day where
toRDFLabel = flip Lit (Just xsdDate) . T.pack . fromDayFormat
instance FromRDFLabel Day where
fromRDFLabel = fLabel toDayFormat xsdDate
instance ToRDFLabel ScopedName where
toRDFLabel = Res
instance FromRDFLabel ScopedName where
fromRDFLabel (Res sn) = Just sn
fromRDFLabel _ = Nothing
instance ToRDFLabel QName where
toRDFLabel = Res . makeQNameScopedName Nothing
instance FromRDFLabel QName where
fromRDFLabel (Res sn) = Just $ getQName sn
fromRDFLabel _ = Nothing
instance ToRDFLabel URI where
toRDFLabel = Res . makeURIScopedName
instance FromRDFLabel URI where
fromRDFLabel (Res sn) = Just $ getScopedNameURI sn
fromRDFLabel _ = Nothing
showCanon :: RDFLabel -> String
showCanon (Res sn) = "<"++show (getScopedNameURI sn)++">"
showCanon (Lit st (Just nam))
| isLang nam = quote1Str st ++ "@" ++ T.unpack (langTag nam)
| otherwise = quote1Str st ++ "^^" ++ show (getScopedNameURI nam)
showCanon s = show s
quoteT :: Bool -> T.Text -> T.Text
quoteT f = T.pack . quote f . T.unpack
quote ::
Bool
-> String
-> String
quote _ [] = ""
quote False s@(c:'"':[]) | c == '\\' = s
| otherwise = [c, '\\', '"']
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
quote1Str :: T.Text -> String
quote1Str t = '"' : quote False (T.unpack t) ++ ['"']
resRdfType :: RDFLabel
resRdfType = Res rdfType
resRdfList :: RDFLabel
resRdfList = Res rdfList
resRdfFirst :: RDFLabel
resRdfFirst = Res rdfFirst
resRdfRest :: RDFLabel
resRdfRest = Res rdfRest
resRdfNil :: RDFLabel
resRdfNil = Res rdfNil
resRdfsMember :: RDFLabel
resRdfsMember = Res rdfsMember
resRdfdGeneralRestriction :: RDFLabel
resRdfdGeneralRestriction = Res rdfdGeneralRestriction
resRdfdOnProperties :: RDFLabel
resRdfdOnProperties = Res rdfdOnProperties
resRdfdConstraint :: RDFLabel
resRdfdConstraint = Res rdfdConstraint
resRdfdMaxCardinality :: RDFLabel
resRdfdMaxCardinality = Res rdfdMaxCardinality
resRdfsSeeAlso :: RDFLabel
resRdfsSeeAlso = Res rdfsSeeAlso
resRdfValue :: RDFLabel
resRdfValue = Res rdfValue
resOwlSameAs :: RDFLabel
resOwlSameAs = Res owlSameAs
resLogImplies :: RDFLabel
resLogImplies = Res logImplies
resRdfsLabel :: RDFLabel
resRdfsLabel = Res rdfsLabel
resRdfsComment :: RDFLabel
resRdfsComment = Res rdfsComment
resRdfProperty :: RDFLabel
resRdfProperty = Res rdfProperty
resRdfsSubPropertyOf :: RDFLabel
resRdfsSubPropertyOf = Res rdfsSubPropertyOf
resRdfsSubClassOf :: RDFLabel
resRdfsSubClassOf = Res rdfsSubClassOf
resRdfsClass :: RDFLabel
resRdfsClass = Res rdfsClass
resRdfsLiteral :: RDFLabel
resRdfsLiteral = Res rdfsLiteral
resRdfsDatatype :: RDFLabel
resRdfsDatatype = Res rdfsDatatype
resRdfXMLLiteral :: RDFLabel
resRdfXMLLiteral = Res rdfXMLLiteral
resRdfsRange :: RDFLabel
resRdfsRange = Res rdfsRange
resRdfsDomain :: RDFLabel
resRdfsDomain = Res rdfsDomain
resRdfsContainer :: RDFLabel
resRdfsContainer = Res rdfsContainer
resRdfBag :: RDFLabel
resRdfBag = Res rdfBag
resRdfSeq :: RDFLabel
resRdfSeq = Res rdfSeq
resRdfAlt :: RDFLabel
resRdfAlt = Res rdfAlt
resRdfsContainerMembershipProperty :: RDFLabel
resRdfsContainerMembershipProperty = Res rdfsContainerMembershipProperty
resRdfsIsDefinedBy :: RDFLabel
resRdfsIsDefinedBy = Res rdfsIsDefinedBy
resRdfsResource :: RDFLabel
resRdfsResource = Res rdfsResource
resRdfStatement :: RDFLabel
resRdfStatement = Res rdfStatement
resRdfSubject :: RDFLabel
resRdfSubject = Res rdfSubject
resRdfPredicate :: RDFLabel
resRdfPredicate = Res rdfPredicate
resRdfObject :: RDFLabel
resRdfObject = Res rdfObject
resRdfRDF :: RDFLabel
resRdfRDF = Res rdfRDF
resRdfDescription :: RDFLabel
resRdfDescription = Res rdfDescription
resRdfID :: RDFLabel
resRdfID = Res rdfID
resRdfAbout :: RDFLabel
resRdfAbout = Res rdfAbout
resRdfParseType :: RDFLabel
resRdfParseType = Res rdfParseType
resRdfResource :: RDFLabel
resRdfResource = Res rdfResource
resRdfLi :: RDFLabel
resRdfLi = Res rdfLi
resRdfNodeID :: RDFLabel
resRdfNodeID = Res rdfNodeID
resRdfDatatype :: RDFLabel
resRdfDatatype = Res rdfDatatype
resRdf1 :: RDFLabel
resRdf1 = Res rdf1
resRdf2 :: RDFLabel
resRdf2 = Res rdf2
resRdfn :: Int -> RDFLabel
resRdfn = Res . rdfn
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 rdfXMLLiteral
isDatatyped :: ScopedName -> RDFLabel -> Bool
isDatatyped d (Lit _ (Just n)) = n == d
isDatatyped _ _ = False
isMemberProp :: RDFLabel -> Bool
isMemberProp (Res sn) =
getScopeNamespace sn == namespaceRDF &&
case T.uncons (getScopeLocal sn) of
Just ('_', t) -> T.all isDigit t
_ -> False
isMemberProp _ = False
isBlank :: RDFLabel -> Bool
isBlank (Blank _) = True
isBlank _ = False
isQueryVar :: RDFLabel -> Bool
isQueryVar (Var _) = True
isQueryVar _ = False
getLiteralText :: RDFLabel -> T.Text
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 URI (Maybe T.Text) where
keyVal (RevNamespace ns) = swap $ getNamespaceTuple ns
newEntry (uri,pre) = RevNamespace (makeNamespace 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 = Traversable.traverse (formulaEntryMapA f)
formulaEntryMapA ::
(Applicative f) =>
(lb -> f l2)
-> Formula lb
-> f (Formula l2)
formulaEntryMapA f (Formula k gr) = Formula `liftA` f k <*> Traversable.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 Foldable.Foldable NSGraph where
foldMap = Traversable.foldMapDefault
instance Traversable.Traversable NSGraph where
traverse f (NSGraph ns fml stmts) =
NSGraph ns <$> formulaeMapA f fml <*> (Traversable.traverse $ Traversable.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 = fst . grMatchMap g1
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 :: [RDFTriple] -> RDFGraph
toRDFGraph arcs =
let lbls = concatMap arcLabels arcs
getNS (Res s) = Just s
getNS (Lit _ (Just tn)) | not (isLang tn) = Just tn
| otherwise = Nothing
getNS _ = Nothing
ns = mapMaybe (fmap getScopeNamespace . getNS) lbls
nsmap = foldl' mapAddIfNew emptyNamespaceMap ns
in mempty { namespaces = nsmap, statements = arcs }
emptyRDFGraph :: RDFGraph
emptyRDFGraph = mempty