{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RecordWildCards   #-}
{-# OPTIONS_GHC -fno-warn-orphans -Wno-deprecations #-}

module Database.Bolt.Extras.Graph.Internal.Put
  (
    PutNode (..)
  , PutRelationship (..)
  , GraphPutRequest
  , GraphPutResponse
  , requestPut
  ) where

import           Data.List                                         (foldl')
import           Data.Map.Strict                                   (toList, (!))
import           Data.Text                                         (Text,
                                                                    intercalate,
                                                                    pack)
import           Database.Bolt                                     (Node (..), URelationship (..),
                                                                    Value (..))
import           Database.Bolt.Extras                              (BoltId, ToCypher (..),
                                                                    fromInt)
import           Database.Bolt.Extras.Graph.Internal.AbstractGraph (Graph (..),
                                                                    NodeName,
                                                                    relationName)
import           Database.Bolt.Extras.Graph.Internal.Class         (Extractable (..),
                                                                    Requestable (..),
                                                                    Returnable (..))
import           Database.Bolt.Extras.Utils                        (exact)
import           NeatInterpolation                                 (text)

------------------------------------------------------------------------------------------------
-- REQUEST --
------------------------------------------------------------------------------------------------
--  BOLT FORMAT

-- | 'PutNode' is the wrapper for 'Node' where we can specify if we want to merge or create it.
--
data PutNode
  = BoltId BoltId -- ^ Describe existing node by its 'Database.Bolt.Extras.BoltId'. No new data will be inserted for this node.
  | MergeN Node   -- ^ Merge the 'Node' with existing node in the DB. Corresponds to @MERGE@ Cypher operator.
  | CreateN Node  -- ^ Create an entirely new node. Corresponds to @CREATE@ Cypher operator.
  deriving (Int -> PutNode -> ShowS
[PutNode] -> ShowS
PutNode -> String
(Int -> PutNode -> ShowS)
-> (PutNode -> String) -> ([PutNode] -> ShowS) -> Show PutNode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PutNode] -> ShowS
$cshowList :: [PutNode] -> ShowS
show :: PutNode -> String
$cshow :: PutNode -> String
showsPrec :: Int -> PutNode -> ShowS
$cshowsPrec :: Int -> PutNode -> ShowS
Show)

-- | 'PutRelationship' is the wrapper for 'URelationship' where we can specify
-- if we want to merge or create it.
--
-- Meaning of constructors is the same as for 'PutNode'.
--
data PutRelationship = MergeR URelationship | CreateR URelationship
  deriving (Int -> PutRelationship -> ShowS
[PutRelationship] -> ShowS
PutRelationship -> String
(Int -> PutRelationship -> ShowS)
-> (PutRelationship -> String)
-> ([PutRelationship] -> ShowS)
-> Show PutRelationship
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PutRelationship] -> ShowS
$cshowList :: [PutRelationship] -> ShowS
show :: PutRelationship -> String
$cshow :: PutRelationship -> String
showsPrec :: Int -> PutRelationship -> ShowS
$cshowsPrec :: Int -> PutRelationship -> ShowS
Show)

instance Requestable (NodeName, PutNode) where
  request :: (NodeName, PutNode) -> NodeName
request (NodeName
name, BoltId Int
boltId) = let showBoltId :: NodeName
showBoltId = String -> NodeName
pack (String -> NodeName) -> (Int -> String) -> Int -> NodeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> NodeName) -> Int -> NodeName
forall a b. (a -> b) -> a -> b
$ Int
boltId
                                  in [text|MATCH ($name) WHERE ID($name) = $showBoltId|]
  request (NodeName
name, MergeN Node
node)   = NodeName -> NodeName -> Node -> NodeName
requestNode NodeName
"MERGE"  NodeName
name Node
node
  request (NodeName
name, CreateN Node
node)  = NodeName -> NodeName -> Node -> NodeName
requestNode NodeName
"CREATE" NodeName
name Node
node

requestNode :: Text -> NodeName -> Node -> Text
requestNode :: NodeName -> NodeName -> Node -> NodeName
requestNode NodeName
q NodeName
name Node{Int
[NodeName]
Map NodeName Value
nodeIdentity :: Node -> Int
labels :: Node -> [NodeName]
nodeProps :: Node -> Map NodeName Value
nodeProps :: Map NodeName Value
labels :: [NodeName]
nodeIdentity :: Int
..} = [text|$q ($name $labelsQ {$propsQ})|]
  where
    labelsQ :: NodeName
labelsQ = [NodeName] -> NodeName
forall a. ToCypher a => a -> NodeName
toCypher [NodeName]
labels
    propsQ :: NodeName
propsQ  = [(NodeName, Value)] -> NodeName
forall a. ToCypher a => a -> NodeName
toCypher ([(NodeName, Value)] -> NodeName)
-> (Map NodeName Value -> [(NodeName, Value)])
-> Map NodeName Value
-> NodeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((NodeName, Value) -> Bool)
-> [(NodeName, Value)] -> [(NodeName, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= () -> Value
N ()) (Value -> Bool)
-> ((NodeName, Value) -> Value) -> (NodeName, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeName, Value) -> Value
forall a b. (a, b) -> b
snd) ([(NodeName, Value)] -> [(NodeName, Value)])
-> (Map NodeName Value -> [(NodeName, Value)])
-> Map NodeName Value
-> [(NodeName, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map NodeName Value -> [(NodeName, Value)]
forall k a. Map k a -> [(k, a)]
toList (Map NodeName Value -> NodeName) -> Map NodeName Value -> NodeName
forall a b. (a -> b) -> a -> b
$ Map NodeName Value
nodeProps

instance Requestable ((NodeName, NodeName), PutRelationship) where
  request :: ((NodeName, NodeName), PutRelationship) -> NodeName
request ((NodeName, NodeName)
names, MergeR URelationship
urel)  = NodeName -> (NodeName, NodeName) -> URelationship -> NodeName
requestURelationship NodeName
"MERGE" (NodeName, NodeName)
names URelationship
urel
  request ((NodeName, NodeName)
names, CreateR URelationship
urel) = NodeName -> (NodeName, NodeName) -> URelationship -> NodeName
requestURelationship NodeName
"CREATE" (NodeName, NodeName)
names URelationship
urel

requestURelationship :: Text -> (NodeName, NodeName) -> URelationship -> Text
requestURelationship :: NodeName -> (NodeName, NodeName) -> URelationship -> NodeName
requestURelationship NodeName
q (NodeName
stName, NodeName
enName) URelationship{Int
NodeName
Map NodeName Value
urelIdentity :: URelationship -> Int
urelType :: URelationship -> NodeName
urelProps :: URelationship -> Map NodeName Value
urelProps :: Map NodeName Value
urelType :: NodeName
urelIdentity :: Int
..} =
    [text|$q ($stName)-[$name $labelQ {$propsQ}]->($enName)|]
  where
    name :: NodeName
name   = (NodeName, NodeName) -> NodeName
relationName (NodeName
stName, NodeName
enName)
    labelQ :: NodeName
labelQ = NodeName -> NodeName
forall a. ToCypher a => a -> NodeName
toCypher NodeName
urelType
    propsQ :: NodeName
propsQ = [(NodeName, Value)] -> NodeName
forall a. ToCypher a => a -> NodeName
toCypher ([(NodeName, Value)] -> NodeName)
-> (Map NodeName Value -> [(NodeName, Value)])
-> Map NodeName Value
-> NodeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map NodeName Value -> [(NodeName, Value)]
forall k a. Map k a -> [(k, a)]
toList (Map NodeName Value -> NodeName) -> Map NodeName Value -> NodeName
forall a b. (a -> b) -> a -> b
$ Map NodeName Value
urelProps

-- | Takes all 'PutNode's and 'PutRelationship's
-- and write them to single query to request.
-- Here "WITH" is used, because you cannot perform
-- "match", "merge" or "create" at the same query.
requestPut :: [(NodeName, PutNode)]
           -> [((NodeName, NodeName), PutRelationship)]
           -> (Text, [Text])
requestPut :: [(NodeName, PutNode)]
-> [((NodeName, NodeName), PutRelationship)]
-> (NodeName, [NodeName])
requestPut [(NodeName, PutNode)]
pns [((NodeName, NodeName), PutRelationship)]
prs = ((NodeName, [NodeName]) -> NodeName
forall a b. (a, b) -> a
fst (NodeName, [NodeName])
fullRequest, [])
  where
    foldStepN :: (Text, [NodeName]) -> (NodeName, PutNode) -> (Text, [NodeName])
    foldStepN :: (NodeName, [NodeName])
-> (NodeName, PutNode) -> (NodeName, [NodeName])
foldStepN (NodeName, [NodeName])
accum pn :: (NodeName, PutNode)
pn@(NodeName
name, PutNode
_) = (NodeName, [NodeName])
-> NodeName -> (NodeName, PutNode) -> (NodeName, [NodeName])
forall a.
Requestable a =>
(NodeName, [NodeName]) -> NodeName -> a -> (NodeName, [NodeName])
foldStep (NodeName, [NodeName])
accum NodeName
name (NodeName, PutNode)
pn

    foldStepR :: (Text, [NodeName]) -> ((NodeName, NodeName), PutRelationship) -> (Text, [NodeName])
    foldStepR :: (NodeName, [NodeName])
-> ((NodeName, NodeName), PutRelationship)
-> (NodeName, [NodeName])
foldStepR (NodeName, [NodeName])
accum pr :: ((NodeName, NodeName), PutRelationship)
pr@((NodeName, NodeName)
names, PutRelationship
_) = (NodeName, [NodeName])
-> NodeName
-> ((NodeName, NodeName), PutRelationship)
-> (NodeName, [NodeName])
forall a.
Requestable a =>
(NodeName, [NodeName]) -> NodeName -> a -> (NodeName, [NodeName])
foldStep (NodeName, [NodeName])
accum ((NodeName, NodeName) -> NodeName
relationName (NodeName, NodeName)
names) ((NodeName, NodeName), PutRelationship)
pr

    foldStep :: Requestable a => (Text, [NodeName]) -> NodeName -> a -> (Text, [NodeName])
    foldStep :: (NodeName, [NodeName]) -> NodeName -> a -> (NodeName, [NodeName])
foldStep (NodeName
currentQuery, [NodeName]
names) NodeName
name a
put =
        (NodeName
currentQuery NodeName -> NodeName -> NodeName
forall a. Semigroup a => a -> a -> a
<> a -> NodeName
forall a. Requestable a => a -> NodeName
request a
put NodeName -> NodeName -> NodeName
forall a. Semigroup a => a -> a -> a
<> NodeName
" WITH " NodeName -> NodeName -> NodeName
forall a. Semigroup a => a -> a -> a
<> NodeName -> [NodeName] -> NodeName
intercalate NodeName
", " [NodeName]
updNames NodeName -> NodeName -> NodeName
forall a. Semigroup a => a -> a -> a
<> NodeName
" ", [NodeName]
updNames)
      where
        updNames :: [NodeName]
updNames = NodeName
name NodeName -> [NodeName] -> [NodeName]
forall a. a -> [a] -> [a]
: [NodeName]
names

    requestNodes :: (NodeName, [NodeName])
requestNodes = ((NodeName, [NodeName])
 -> (NodeName, PutNode) -> (NodeName, [NodeName]))
-> (NodeName, [NodeName])
-> [(NodeName, PutNode)]
-> (NodeName, [NodeName])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (NodeName, [NodeName])
-> (NodeName, PutNode) -> (NodeName, [NodeName])
foldStepN (NodeName
"", []) [(NodeName, PutNode)]
pns
    fullRequest :: (NodeName, [NodeName])
fullRequest  = ((NodeName, [NodeName])
 -> ((NodeName, NodeName), PutRelationship)
 -> (NodeName, [NodeName]))
-> (NodeName, [NodeName])
-> [((NodeName, NodeName), PutRelationship)]
-> (NodeName, [NodeName])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (NodeName, [NodeName])
-> ((NodeName, NodeName), PutRelationship)
-> (NodeName, [NodeName])
foldStepR (NodeName, [NodeName])
requestNodes [((NodeName, NodeName), PutRelationship)]
prs

instance Returnable (NodeName, PutNode) where
  -- always return all nodes
  isReturned' :: (NodeName, PutNode) -> Bool
isReturned' (NodeName, PutNode)
_     = Bool
True
  return' :: (NodeName, PutNode) -> NodeName
return' (NodeName
name, PutNode
_) = [text|ID($name) AS $name|]

instance Returnable ((NodeName, NodeName), PutRelationship) where
  -- always return all relations
  isReturned' :: ((NodeName, NodeName), PutRelationship) -> Bool
isReturned' ((NodeName, NodeName), PutRelationship)
_      = Bool
True
  return' :: ((NodeName, NodeName), PutRelationship) -> NodeName
return' ((NodeName, NodeName)
names, PutRelationship
_) = let name :: NodeName
name = (NodeName, NodeName) -> NodeName
relationName (NodeName, NodeName)
names
                       in [text|ID($name) AS $name|]

------------------------------------------------------------------------------------------------

----------------------------------------------------------
-- RESULT --
----------------------------------------------------------

instance Extractable BoltId where
  extract :: NodeName -> [Map NodeName Value] -> BoltActionT m [Int]
extract NodeName
name = (Map NodeName Value -> BoltActionT m Int)
-> [Map NodeName Value] -> BoltActionT m [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Int -> Int) -> BoltActionT m Int -> BoltActionT m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Int
fromInt (BoltActionT m Int -> BoltActionT m Int)
-> (Map NodeName Value -> BoltActionT m Int)
-> Map NodeName Value
-> BoltActionT m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> BoltActionT m Int
forall (m :: * -> *) a. (MonadIO m, RecordValue a) => Value -> m a
exact (Value -> BoltActionT m Int)
-> (Map NodeName Value -> Value)
-> Map NodeName Value
-> BoltActionT m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map NodeName Value -> NodeName -> Value
forall k a. Ord k => Map k a -> k -> a
! NodeName
name))

----------------------------------------------------------
-- GRAPH TYPES --
----------------------------------------------------------

-- | The graph of 'Node's with specified uploading type and 'URelationship's.
--
type GraphPutRequest = Graph NodeName PutNode PutRelationship

-- | The graph of 'Database.Bolt.Extras.BoltId's corresponding to the nodes and relationships
-- which we get after putting 'GraphPutRequest'.
--
type GraphPutResponse = Graph NodeName BoltId BoltId