{-# 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 :: Fold Value a
exact = (Value -> Maybe a) -> Getter Value (Maybe a)
forall s a. (s -> a) -> Getter s a
to Value -> Maybe a
forall a. RecordValue a => Value -> Maybe a
B.exactMaybe ((Maybe a -> f (Maybe a)) -> Value -> f Value)
-> ((a -> f a) -> Maybe a -> f (Maybe a))
-> (a -> f a)
-> Value
-> f Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f a) -> Maybe a -> f (Maybe a)
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 :: Text -> Fold Record a
field Text
key = Text -> Fold Record Value
forall k v. Ord k => k -> Fold (Map k v) v
ix Text
key ((Value -> f Value) -> Record -> f Record)
-> ((a -> f a) -> Value -> f Value)
-> (a -> f a)
-> Record
-> f Record
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f a) -> Value -> f Value
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 :: Text -> Fold Node a
prop Text
key = (Node -> Record) -> Getter Node Record
forall s a. (s -> a) -> Getter s a
to Node -> Record
B.nodeProps ((Record -> f Record) -> Node -> f Node)
-> ((a -> f a) -> Record -> f Record)
-> (a -> f a)
-> Node
-> f Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Fold Record Value
forall k v. Ord k => k -> Fold (Map k v) v
ix Text
key ((Value -> f Value) -> Record -> f Record)
-> ((a -> f a) -> Value -> f Value)
-> (a -> f a)
-> Record
-> f Record
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f a) -> Value -> f Value
forall a. RecordValue a => Fold Value a
exact

-- INTERNAL STUFF

-- | Simplistic implementation of @to@ from @lens@.
to :: (s -> a) -> Getter s a
to :: (s -> a) -> Getter s a
to s -> a
f a -> f a
g = (s -> a) -> f a -> f s
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap s -> a
f (f a -> f s) -> (s -> f a) -> s -> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
g (a -> f a) -> (s -> a) -> s -> f a
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 :: (a -> f a) -> Maybe a -> f (Maybe a)
_Just a -> f a
f Maybe a
s =
  case Maybe a
s of
    Just a
a  -> Maybe a
s Maybe a -> f a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a -> f a
f a
a
    Maybe a
Nothing -> Maybe a -> f (Maybe a)
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 :: k -> Fold (Map k v) v
ix k
k = (Map k v -> Maybe v) -> Getter (Map k v) (Maybe v)
forall s a. (s -> a) -> Getter s a
to (k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k) ((Maybe v -> f (Maybe v)) -> Map k v -> f (Map k v))
-> ((v -> f v) -> Maybe v -> f (Maybe v))
-> (v -> f v)
-> Map k v
-> f (Map k v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> f v) -> Maybe v -> f (Maybe v)
forall a. Fold (Maybe a) a
_Just