{-# OPTIONS_GHC -fno-warn-orphans #-} -- [TODO] Remove when the missing NFData instance is added to Alga.
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDecls #-}


module Data.RDF.Graph.AlgebraicGraph
  ( AlgebraicGraph
  ) where


import Data.Semigroup (Semigroup(..))
import Control.DeepSeq (NFData(..))
import Data.Binary
import Data.RDF.Namespace
import Data.RDF.Query
import Data.RDF.Types (RDF, Rdf(..), BaseUrl, Triples, Triple(..), Node, Subject, Predicate, Object, NodeSelector)
import qualified Algebra.Graph.Labelled as G
import Data.HashSet (HashSet)
import qualified Data.HashSet as HS
import GHC.Generics


data AlgebraicGraph deriving (Generic)

instance Binary AlgebraicGraph
instance NFData AlgebraicGraph

data instance RDF AlgebraicGraph = AlgebraicGraph
  { _graph :: G.Graph (HashSet Node) Node
  , _baseUrl :: Maybe BaseUrl
  , _prefixMappings :: PrefixMappings
  } deriving (Generic, NFData)

-- [TODO] Remove this orphan instance when the missing NFData instance is added to Alga.
instance (NFData e, NFData a) => NFData (G.Graph e a) where
    rnf G.Empty           = ()
    rnf (G.Vertex  x    ) = rnf x
    rnf (G.Connect e x y) = e `seq` rnf x `seq` rnf y

instance Rdf AlgebraicGraph where
  baseUrl           = _baseUrl
  prefixMappings    = _prefixMappings
  addPrefixMappings = addPrefixMappings'
  empty             = empty'
  mkRdf             = mkRdf'
  addTriple         = addTriple'
  removeTriple      = removeTriple'
  triplesOf         = triplesOf'
  uniqTriplesOf     = triplesOf'
  select            = select'
  query             = query'
  showGraph         = showGraph'

toEdge :: Triple -> (HashSet Predicate, Subject, Object)
toEdge (Triple s p o) = (HS.singleton p, s, o)

toTriples :: (HashSet Predicate, Subject, Object) -> Triples
toTriples (ps, s, o) = [Triple s p o | p <- HS.toList ps]

showGraph' :: RDF AlgebraicGraph -> String
showGraph' r = concatMap (\t -> show t ++ "\n") (expandTriples r)

addPrefixMappings' :: RDF AlgebraicGraph -> PrefixMappings -> Bool -> RDF AlgebraicGraph
addPrefixMappings' (AlgebraicGraph g baseURL pms) pms' replace =
  let merge = if replace then flip (<>) else (<>)
  in  AlgebraicGraph g baseURL (merge pms pms')

empty' :: RDF AlgebraicGraph
empty' = AlgebraicGraph G.empty mempty (PrefixMappings mempty)

mkRdf' :: Triples -> Maybe BaseUrl -> PrefixMappings -> RDF AlgebraicGraph
mkRdf' ts baseURL pms =
  let g = G.edges . fmap toEdge $ ts
  in AlgebraicGraph g baseURL pms

addTriple' :: RDF AlgebraicGraph -> Triple -> RDF AlgebraicGraph
addTriple' (AlgebraicGraph g baseURL pms) (Triple s p o) =
  let g' = G.edge (HS.singleton p) s o
  in AlgebraicGraph (G.overlay g g') baseURL pms

removeTriple' :: RDF AlgebraicGraph -> Triple -> RDF AlgebraicGraph
removeTriple' (AlgebraicGraph g baseURL pms) (Triple s p o) =
  let ps = G.edgeLabel s o g
      g'
        | HS.null ps = g
        | elem p ps  = G.replaceEdge (HS.delete p ps) s o g
        | otherwise  = g
  in AlgebraicGraph g' baseURL pms

triplesOf' :: RDF AlgebraicGraph -> Triples
triplesOf' (AlgebraicGraph g _ _) = mconcat $ toTriples <$> G.edgeList g

select' :: RDF AlgebraicGraph -> NodeSelector -> NodeSelector -> NodeSelector -> Triples
select' r Nothing Nothing Nothing = triplesOf r
select' (AlgebraicGraph g _ _) s p o = let (res, _, _) = G.foldg e v c g in res
  where
    e   = (mempty, mempty, mempty)
    v x = (mempty, s ?? x, o ?? x)
    (??) f x' = let xs = HS.singleton x' in maybe xs (`HS.filter` xs) f
    c ps (ts1, ss1, os1) (ts2, ss2, os2) = (ts3, ss3, os3)
      where
        ss3 = ss1 <> ss2
        os3 = os1 <> os2
        ts3
          | HS.null ps' = ts1 <> ts2
          | otherwise   = ts1 <> ts2 <> [Triple s' p' o' | s' <- HS.toList ss3, p' <- HS.toList ps', o' <- HS.toList os3]
        ps' = maybe ps (`HS.filter` ps) p

query' :: RDF AlgebraicGraph -> Maybe Subject -> Maybe Predicate -> Maybe Object -> Triples
query' r Nothing Nothing Nothing = triplesOf r
query' r s p o = select r ((==) <$> s) ((==) <$> p) ((==) <$> o)