{-# OPTIONS_GHC -fno-warn-orphans #-}

module Database.Bolt.Extras.Utils
  (
    dummyId
  , union
  , currentLoc
  , exactValues
  , exactValuesM
  , exact
  ) where

import           Control.Monad.IO.Class (MonadIO (..))
import           Data.List              (nub)
import           Data.Map.Strict        as M ((!), (!?))
import qualified Data.Map.Strict        as M (union)
import           Data.Text              (Text)
import           Database.Bolt          as B (BoltActionT, Node (..), Record,
                                              RecordValue (..), Value (..))
import           Language.Haskell.TH    (Exp (..), Lit (..), Loc (..), Q,
                                         location)
import           Text.Printf            (printf)


-- | 'dummyId' is used to load 'Node' and 'URelationship' into database,
-- because id from database is not known for such moment.
--
dummyId :: Int
dummyId :: Int
dummyId = -Int
1

-- | 'Node's can be merged. 'union' is useful when you have to store in one node
-- several labels and props from different classes.
--
union :: Node -> Node -> Node
(Node Int
_ [Text]
labels1 Map Text Value
props1) union :: Node -> Node -> Node
`union` (Node Int
_ [Text]
labels2 Map Text Value
props2) = Int -> [Text] -> Map Text Value -> Node
Node Int
dummyId
                                                               ([Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text]
labels1 [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
labels2)
                                                               (Map Text Value
props1 Map Text Value -> Map Text Value -> Map Text Value
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Text Value
props2)

-- | 'currentLoc' shows module name and line where this expression is used.
--
currentLoc :: Q Exp
currentLoc :: Q Exp
currentLoc = do
  Loc
loc <- Q Loc
location
  Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ String -> String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%s:%d: " (Loc -> String
loc_module Loc
loc) ((Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Int, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> (Int, Int)
loc_start Loc
loc)

-- | Unpack a value, using 'fail' in 'IO` to report errors.
{-# DEPRECATED exact "This function exists for compatibility, consider using pure exactEither or exactMaybe instead." #-}
exact :: (MonadIO m, RecordValue a) => Value -> m a
exact :: Value -> m a
exact = (UnpackError -> m a) -> (a -> m a) -> Either UnpackError a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (UnpackError -> IO a) -> UnpackError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO a) -> (UnpackError -> String) -> UnpackError -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnpackError -> String
forall a. Show a => a -> String
show) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either UnpackError a -> m a)
-> (Value -> Either UnpackError a) -> Value -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either UnpackError a
forall a. RecordValue a => Value -> Either UnpackError a
exactEither

-- | Extract values
--
exactValues :: (MonadIO m, RecordValue a) => Text -> [Record] -> m [a]
exactValues :: Text -> [Map Text Value] -> m [a]
exactValues Text
var = (Map Text Value -> m a) -> [Map Text Value] -> m [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Value -> m a
forall (m :: * -> *) a. (MonadIO m, RecordValue a) => Value -> m a
exact (Value -> m a)
-> (Map Text Value -> Value) -> Map Text Value -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Text Value -> Text -> Value
forall k a. Ord k => Map k a -> k -> a
! Text
var))

-- | Extract values (maybe)
exactValuesM :: (MonadIO m, RecordValue a) => Text -> [Record] -> BoltActionT m [Maybe a]
exactValuesM :: Text -> [Map Text Value] -> BoltActionT m [Maybe a]
exactValuesM Text
var = (Map Text Value -> BoltActionT m (Maybe a))
-> [Map Text Value] -> BoltActionT m [Maybe a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe Value -> BoltActionT m (Maybe a)
forall (m :: * -> *) a.
(MonadIO m, RecordValue a) =>
Maybe Value -> BoltActionT m (Maybe a)
safeExact (Maybe Value -> BoltActionT m (Maybe a))
-> (Map Text Value -> Maybe Value)
-> Map Text Value
-> BoltActionT m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Text Value -> Text -> Maybe Value
forall k a. Ord k => Map k a -> k -> Maybe a
!? Text
var))
  where
    safeExact :: (MonadIO m, RecordValue a) => Maybe B.Value -> BoltActionT m (Maybe a)
    safeExact :: Maybe Value -> BoltActionT m (Maybe a)
safeExact Maybe Value
Nothing       = Maybe a -> BoltActionT m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    safeExact (Just (N ())) = Maybe a -> BoltActionT m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    safeExact (Just Value
x )     = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> BoltActionT m a -> BoltActionT m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> BoltActionT m a
forall (m :: * -> *) a. (MonadIO m, RecordValue a) => Value -> m a
exact Value
x