{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.RDF.Graph.AdjHashMap (AdjHashMap) where
import Prelude hiding (pred)
import Control.DeepSeq (NFData)
import Data.RDF.Types
import Data.RDF.Query
import Data.RDF.Namespace
import qualified Data.Map as Map
import Data.Hashable()
import Data.HashMap.Strict(HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet(HashSet)
import qualified Data.HashSet as Set
import Data.List
import GHC.Generics
import Data.Binary (Binary)
data AdjHashMap deriving (Generic)
instance Binary AdjHashMap
instance NFData AdjHashMap
data instance RDF AdjHashMap = AdjHashMap (TMaps, Maybe BaseUrl, PrefixMappings)
deriving (NFData,Generic)
instance Rdf AdjHashMap where
baseUrl = baseUrl'
prefixMappings = prefixMappings'
addPrefixMappings = addPrefixMappings'
empty = empty'
mkRdf = mkRdf'
triplesOf = triplesOf'
uniqTriplesOf = uniqTriplesOf'
select = select'
query = query'
showGraph = showGraph'
addTriple = addTriple'
removeTriple = removeTriple'
showGraph' :: RDF AdjHashMap -> [Char]
showGraph' ((AdjHashMap ((spoMap, _), _, _))) =
let ts = concatMap (uncurry tripsSubj) subjPredMaps
where subjPredMaps = HashMap.toList spoMap
in concatMap (\t -> show t ++ "\n") ts
type AdjacencyMap = HashMap Predicate (HashSet Node)
type Adjacencies = HashSet Node
type TMap = HashMap Node AdjacencyMap
type TMaps = (TMap, TMap)
baseUrl' :: RDF AdjHashMap -> Maybe BaseUrl
baseUrl' (AdjHashMap (_, baseURL, _)) = baseURL
prefixMappings' :: RDF AdjHashMap -> PrefixMappings
prefixMappings' (AdjHashMap (_, _, pms)) = pms
addPrefixMappings' :: RDF AdjHashMap -> PrefixMappings -> Bool -> RDF AdjHashMap
addPrefixMappings' (AdjHashMap (ts, baseURL, pms)) pms' replace =
let merge = if replace then flip mergePrefixMappings else mergePrefixMappings
in AdjHashMap (ts, baseURL, merge pms pms')
empty' :: RDF AdjHashMap
empty' = AdjHashMap ((HashMap.empty, HashMap.empty), Nothing, PrefixMappings Map.empty)
mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> RDF AdjHashMap
mkRdf' ts baseURL pms = AdjHashMap (mergeTs (HashMap.empty, HashMap.empty) ts, baseURL, pms)
addTriple' :: RDF AdjHashMap -> Triple -> RDF AdjHashMap
addTriple' (AdjHashMap (tmaps, baseURL, pms)) t =
let newTMaps = mergeTs tmaps [t]
in AdjHashMap (newTMaps, baseURL, pms)
removeTriple' :: RDF AdjHashMap -> Triple -> RDF AdjHashMap
removeTriple' (AdjHashMap ((spoMap, opsMap), baseURL, pms)) (Triple s p o) =
(AdjHashMap (new_tmaps, baseURL, pms))
where
new_tmaps = (newSpoMap, newOpsMap)
newSpoMap =
case HashMap.lookup s spoMap of
Nothing -> spoMap
Just poAdjMap ->
case HashMap.lookup p poAdjMap of
Nothing -> spoMap
Just oHashSet ->
if not (Set.member o oHashSet)
then spoMap
else let newPoAdjMap =
HashMap.adjust
(\oHashSet' -> Set.delete o oHashSet')
p
poAdjMap
in HashMap.adjust (\_poAdjMap' -> newPoAdjMap) s spoMap
newOpsMap =
case HashMap.lookup o opsMap of
Nothing -> opsMap
Just poAdjMap ->
case HashMap.lookup p poAdjMap of
Nothing -> opsMap
Just sHashSet ->
if not (Set.member s sHashSet)
then opsMap
else let newPoAdjMap =
HashMap.adjust
(\sHashSet' -> Set.delete s sHashSet')
p
poAdjMap
in HashMap.adjust (\_poAdjMap' -> newPoAdjMap) o opsMap
mergeTs :: TMaps -> [Triple] -> TMaps
mergeTs = foldl' mergeT
where
mergeT :: TMaps -> Triple -> TMaps
mergeT m t = mergeT' m (subjectOf t) (predicateOf t) (objectOf t)
mergeT' :: TMaps -> Subject -> Predicate -> Object -> TMaps
mergeT' (spo, ops) s p o = (mergeT'' spo s p o, mergeT'' ops o p s)
mergeT'' :: TMap -> Subject -> Predicate -> Object -> TMap
mergeT'' m s p o =
if s `HashMap.member` m then
(if p `HashMap.member` adjs then HashMap.insert s addPredObj m
else HashMap.insert s addNewPredObjMap m)
else HashMap.insert s newPredMap m
where
adjs = HashMap.lookupDefault HashMap.empty s m
newPredMap :: HashMap Predicate (HashSet Object)
newPredMap = HashMap.singleton p (Set.singleton o)
addNewPredObjMap :: HashMap Predicate (HashSet Object)
addNewPredObjMap = HashMap.insert p (Set.singleton o) adjs
addPredObj :: HashMap Predicate (HashSet Object)
addPredObj = HashMap.insert p (Set.insert o (get p adjs)) adjs
get = HashMap.lookupDefault Set.empty
triplesOf' :: RDF AdjHashMap -> Triples
triplesOf' (AdjHashMap ((spoMap, _), _, _)) = concatMap (uncurry tripsSubj) subjPredMaps
where subjPredMaps = HashMap.toList spoMap
uniqTriplesOf' :: RDF AdjHashMap -> Triples
uniqTriplesOf' = nub . expandTriples
tripsSubj :: Subject -> AdjacencyMap -> Triples
tripsSubj s adjMap = concatMap (uncurry (tfsp s)) (HashMap.toList adjMap)
where tfsp = tripsForSubjPred
tripsForSubjPred :: Subject -> Predicate -> Adjacencies -> Triples
tripsForSubjPred s p adjs = map (Triple s p) (Set.toList adjs)
select' :: RDF AdjHashMap -> NodeSelector -> NodeSelector -> NodeSelector -> Triples
select' (AdjHashMap ((spoMap,_),_,_)) subjFn predFn objFn =
map (\(s,p,o) -> Triple s p o) $ Set.toList $ sel1 subjFn predFn objFn spoMap
sel1 :: NodeSelector -> NodeSelector -> NodeSelector -> TMap -> HashSet (Node, Node, Node)
sel1 (Just subjFn) p o spoMap =
Set.unions $ map (sel2 p o) $ filter (\(x,_) -> subjFn x) $ HashMap.toList spoMap
sel1 Nothing p o spoMap = Set.unions $ map (sel2 p o) $ HashMap.toList spoMap
sel2 :: NodeSelector -> NodeSelector -> (Node, HashMap Node (HashSet Node)) -> HashSet (Node, Node, Node)
sel2 (Just predFn) mobjFn (s, ps) =
Set.map (\(p,o) -> (s,p,o)) $
foldl' Set.union Set.empty $
map (sel3 mobjFn) poMapS :: HashSet (Node, Node, Node)
where
poMapS :: [(Node, HashSet Node)]
poMapS = filter (\(k,_) -> predFn k) $ HashMap.toList ps
sel2 Nothing mobjFn (s, ps) =
Set.map (\(p,o) -> (s,p,o)) $
foldl' Set.union Set.empty $
map (sel3 mobjFn) poMaps
where
poMaps = HashMap.toList ps
sel3 :: NodeSelector -> (Node, HashSet Node) -> HashSet (Node, Node)
sel3 (Just objFn) (p, os) = Set.map (\o -> (p, o)) $ Set.filter objFn os
sel3 Nothing (p, os) = Set.map (\o -> (p, o)) os
query' :: RDF AdjHashMap -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples
query' (AdjHashMap (m,_ , _)) subj pred obj = map (\(s, p, o) -> Triple s p o) $ Set.toList (q1 subj pred obj m)
q1 :: Maybe Node -> Maybe Node -> Maybe Node -> TMaps -> HashSet (Node, Node, Node)
q1 (Just s) p o (spoMap, _ ) = q2 p o (s, HashMap.lookupDefault HashMap.empty s spoMap)
q1 s p (Just o) (_ , opsMap) = Set.map (\(o',p',s') -> (s',p',o')) $ q2 p s (o, HashMap.lookupDefault HashMap.empty o opsMap)
q1 Nothing (Just p) Nothing (spoMap,_) =
let (filtered::HashMap Node (HashMap Node (HashSet Node)))
= HashMap.filter (\poAdjMap -> HashMap.member p poAdjMap) spoMap
subjXS = HashMap.toList filtered :: [(Node,AdjacencyMap)]
ys = concatMap (\(s,poMap) ->
let objs = map snd (HashMap.toList poMap :: [(Predicate,HashSet Node)])
in concatMap (\objHash -> map (\o -> (s,p,o)) (Set.toList objHash)) objs
) subjXS
in Set.fromList ys
q1 Nothing p o (spoMap, _ ) =
let hashSets = map (q2 p o) (HashMap.toList spoMap) :: [HashSet (Node,Node,Node)]
in Set.unions hashSets
q2
:: Maybe Node
-> Maybe Node
-> (Node, HashMap Node (HashSet Node))
-> HashSet (Node, Node, Node)
q2 (Just p) o (s, pmap) =
let objAdjHashMapetMaybe = HashMap.lookup p pmap :: Maybe (HashSet Node)
in case objAdjHashMapetMaybe of
Nothing -> Set.empty
Just objAdjHashMapet ->
let poAdjHashMapet = q3 o (p,objAdjHashMapet)
in Set.map (\(p', o') -> (s, p', o')) poAdjHashMapet
q2 Nothing o (s, pmap) =
Set.map (\(x, y) -> (s, x, y)) $ Set.unions $ map (q3 o) opmaps
where
opmaps :: [(Node, HashSet Node)]
opmaps = HashMap.toList pmap
q3 :: Maybe Node
-> (Node, HashSet Node)
-> HashSet (Node, Node)
q3 (Just o) (p, os) =
if o `Set.member` os
then Set.singleton (p, o)
else Set.empty
q3 Nothing (p, os) = Set.map (\o -> (p, o)) os