{-# LANGUAGE RankNTypes #-}

module Database.Bolt.Lens
  ( exact
  , field
  , prop
  )
where

import           Data.Functor.Contravariant (Contravariant (..))
import           Data.Map.Strict            (Map)
import qualified Data.Map.Strict            as M
import           Data.Text                  (Text)
import qualified Database.Bolt              as B

-- | @Getter@ from @lens@ package.
type Getter s a = forall f. (Functor f, Contravariant f) => (a -> f a) -> (s -> f s)

-- | @Fold@ from @lens@ package.
type Fold s a = forall f. (Applicative f, Contravariant f) => (a -> f a) -> (s -> f s)

-- | This 'Fold' extracts value of required type from 'B.Value'. If 'B.Value' contains wrong
-- type, 'exact' is an empty 'Fold'.
exact :: B.RecordValue a => Fold B.Value a
exact :: forall a. RecordValue a => Fold Value a
exact = forall s a. (s -> a) -> Getter s a
to forall a. RecordValue a => Value -> Maybe a
B.exactMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fold (Maybe a) a
_Just

-- | Extract field by given key from 'B.Record'. If there is no such key or the type is wrong,
-- this is an empty 'Fold'.
field :: B.RecordValue a => Text -> Fold B.Record a
field :: forall a. RecordValue a => Text -> Fold Record a
field Text
key = forall k v. Ord k => k -> Fold (Map k v) v
ix Text
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RecordValue a => Fold Value a
exact

-- | Extract any property from 'B.Node'. If there is no such property or the type is wrong,
-- this is an emtpy 'Fold'.
prop :: B.RecordValue a => Text -> Fold B.Node a
prop :: forall a. RecordValue a => Text -> Fold Node a
prop Text
key = forall s a. (s -> a) -> Getter s a
to Node -> Record
B.nodeProps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => k -> Fold (Map k v) v
ix Text
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RecordValue a => Fold Value a
exact

-- INTERNAL STUFF

-- | Simplistic implementation of @to@ from @lens@.
to :: (s -> a) -> Getter s a
to :: forall s a. (s -> a) -> Getter s a
to s -> a
f a -> f a
g = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap s -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> a
f

-- | Simplistic implementation of @_Just@ prism. We use this prism only in one direction,
-- so @Fold@ suffices.
_Just :: Fold (Maybe a) a
_Just :: forall a. Fold (Maybe a) a
_Just a -> f a
f Maybe a
s =
  case Maybe a
s of
    Just a
a  -> Maybe a
s forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a -> f a
f a
a
    Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
s

-- | Simplistic implementation of @ix@. We don't need a full lens here, so this is just a 'Fold'.
ix :: Ord k => k -> Fold (Map k v) v
ix :: forall k v. Ord k => k -> Fold (Map k v) v
ix k
k = forall s a. (s -> a) -> Getter s a
to (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fold (Maybe a) a
_Just