module Database.Persist.Redis.Update
    ( cmdUpdate
    ) where

import Control.Exception (throw)
import Data.Either()
import Data.Functor.Identity
import Data.Functor.Constant

import Database.Persist
import Database.Persist.Redis.Exception

type ASetter s t a b = (a -> Identity b) -> s -> Identity t

set :: ASetter s t a b -> b -> s -> t
set :: forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter s t a b
l b
b = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> (s -> Identity t) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter s t a b
l (\a
_ -> b -> Identity b
forall a. a -> Identity a
Identity b
b)

type Getting r s t a b = (a -> Constant r b) -> s -> Constant r t

view :: s -> Getting a s t a b -> a
view :: forall s a t b. s -> Getting a s t a b -> a
view s
s Getting a s t a b
l = Constant a t -> a
forall {k} a (b :: k). Constant a b -> a
getConstant (Getting a s t a b
l a -> Constant a b
forall {k} a (b :: k). a -> Constant a b
Constant s
s)

cmdUpdate :: PersistEntity val => Entity val -> [Update val] -> Entity val
cmdUpdate :: forall val.
PersistEntity val =>
Entity val -> [Update val] -> Entity val
cmdUpdate = (Update val -> Entity val -> Entity val)
-> Entity val -> [Update val] -> Entity val
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Update val -> Entity val -> Entity val
forall val.
PersistEntity val =>
Update val -> Entity val -> Entity val
updateOneField

updateOneField :: PersistEntity val => Update val -> Entity val -> Entity val
updateOneField :: forall val.
PersistEntity val =>
Update val -> Entity val -> Entity val
updateOneField (BackendUpdate BackendSpecificUpdate (PersistEntityBackend val) val
_) Entity val
_ =  RedisException -> Entity val
forall a e. Exception e => e -> a
throw (RedisException -> Entity val) -> RedisException -> Entity val
forall a b. (a -> b) -> a -> b
$ String -> RedisException
NotSupportedOperation String
"Backend specific update"
updateOneField (Update EntityField val typ
field typ
v PersistUpdate
Assign) Entity val
oldValue  = ASetter (Entity val) (Entity val) typ typ
-> typ -> Entity val -> Entity val
forall s t a b. ASetter s t a b -> b -> s -> t
set (EntityField val typ
-> forall (f :: * -> *).
   Functor f =>
   (typ -> f typ) -> Entity val -> f (Entity val)
forall record field.
PersistEntity record =>
EntityField record field
-> forall (f :: * -> *).
   Functor f =>
   (field -> f field) -> Entity record -> f (Entity record)
forall field.
EntityField val field
-> forall (f :: * -> *).
   Functor f =>
   (field -> f field) -> Entity val -> f (Entity val)
fieldLens EntityField val typ
field) typ
v Entity val
oldValue
updateOneField (Update EntityField val typ
_ typ
_ (BackendSpecificUpdate Text
_)) Entity val
_ =
    RedisException -> Entity val
forall a e. Exception e => e -> a
throw (RedisException -> Entity val) -> RedisException -> Entity val
forall a b. (a -> b) -> a -> b
$ String -> RedisException
NotSupportedOperation String
"Backend specific update withing update operation"

updateOneField (Update EntityField val typ
field typ
v PersistUpdate
up) Entity val
oldValue  = ASetter (Entity val) (Entity val) typ typ
-> typ -> Entity val -> Entity val
forall s t a b. ASetter s t a b -> b -> s -> t
set (EntityField val typ
-> forall (f :: * -> *).
   Functor f =>
   (typ -> f typ) -> Entity val -> f (Entity val)
forall record field.
PersistEntity record =>
EntityField record field
-> forall (f :: * -> *).
   Functor f =>
   (field -> f field) -> Entity record -> f (Entity record)
forall field.
EntityField val field
-> forall (f :: * -> *).
   Functor f =>
   (field -> f field) -> Entity val -> f (Entity val)
fieldLens EntityField val typ
field) typ
newValue Entity val
oldValue
    where
        lens :: (typ -> Constant typ typ)
-> Entity val -> Constant typ (Entity val)
lens = EntityField val typ
-> forall (f :: * -> *).
   Functor f =>
   (typ -> f typ) -> Entity val -> f (Entity val)
forall record field.
PersistEntity record =>
EntityField record field
-> forall (f :: * -> *).
   Functor f =>
   (field -> f field) -> Entity record -> f (Entity record)
forall field.
EntityField val field
-> forall (f :: * -> *).
   Functor f =>
   (field -> f field) -> Entity val -> f (Entity val)
fieldLens EntityField val typ
field
        pv :: PersistValue
pv    = typ -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue typ
v
        oldV :: PersistValue
oldV = typ -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (typ -> PersistValue) -> typ -> PersistValue
forall a b. (a -> b) -> a -> b
$ Entity val
-> ((typ -> Constant typ typ)
    -> Entity val -> Constant typ (Entity val))
-> typ
forall s a t b. s -> Getting a s t a b -> a
view Entity val
oldValue (typ -> Constant typ typ)
-> Entity val -> Constant typ (Entity val)
lens
        eitherNewValue :: Either Text typ
eitherNewValue = PersistValue -> Either Text typ
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue (PersistValue -> Either Text typ)
-> PersistValue -> Either Text typ
forall a b. (a -> b) -> a -> b
$ PersistUpdate -> PersistValue -> PersistValue -> PersistValue
apply PersistUpdate
up PersistValue
oldV PersistValue
pv
        newValue :: typ
newValue = (Text -> typ) -> (typ -> typ) -> Either Text typ -> typ
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
_ -> RedisException -> typ
forall a e. Exception e => e -> a
throw RedisException
IncorrectBehavior) typ -> typ
forall a. a -> a
id Either Text typ
eitherNewValue


apply :: PersistUpdate -> PersistValue -> PersistValue -> PersistValue

apply :: PersistUpdate -> PersistValue -> PersistValue -> PersistValue
apply PersistUpdate
Assign PersistValue
_ PersistValue
_ = RedisException -> PersistValue
forall a e. Exception e => e -> a
throw RedisException
IncorrectBehavior

apply PersistUpdate
Add (PersistInt64 Int64
x) (PersistInt64 Int64
y) = Int64 -> PersistValue
PersistInt64 (Int64
x Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
y)
apply PersistUpdate
Add (PersistDouble Double
x) (PersistDouble Double
y) = Double -> PersistValue
PersistDouble (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
y)
apply PersistUpdate
Add (PersistRational Rational
x) (PersistRational Rational
y) = Rational -> PersistValue
PersistRational (Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
y)
apply PersistUpdate
Add PersistValue
_ PersistValue
_ = RedisException -> PersistValue
forall a e. Exception e => e -> a
throw (RedisException -> PersistValue) -> RedisException -> PersistValue
forall a b. (a -> b) -> a -> b
$ String -> RedisException
IncorrectUpdate String
"Unable to apply addition to this field"

apply PersistUpdate
Subtract (PersistInt64 Int64
x) (PersistInt64 Int64
y) = Int64 -> PersistValue
PersistInt64 (Int64
x Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
y)
apply PersistUpdate
Subtract (PersistDouble Double
x) (PersistDouble Double
y) = Double -> PersistValue
PersistDouble (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y)
apply PersistUpdate
Subtract (PersistRational Rational
x) (PersistRational Rational
y) = Rational -> PersistValue
PersistRational (Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
y)
apply PersistUpdate
Subtract PersistValue
_ PersistValue
_ = RedisException -> PersistValue
forall a e. Exception e => e -> a
throw (RedisException -> PersistValue) -> RedisException -> PersistValue
forall a b. (a -> b) -> a -> b
$ String -> RedisException
IncorrectUpdate String
"Unable to apply subtraction to this field"

apply PersistUpdate
Multiply (PersistInt64 Int64
x) (PersistInt64 Int64
y) = Int64 -> PersistValue
PersistInt64 (Int64
x Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
y)
apply PersistUpdate
Multiply (PersistDouble Double
x) (PersistDouble Double
y) = Double -> PersistValue
PersistDouble (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y)
apply PersistUpdate
Multiply (PersistRational Rational
x) (PersistRational Rational
y) = Rational -> PersistValue
PersistRational (Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
y)
apply PersistUpdate
Multiply PersistValue
_ PersistValue
_ = RedisException -> PersistValue
forall a e. Exception e => e -> a
throw (RedisException -> PersistValue) -> RedisException -> PersistValue
forall a b. (a -> b) -> a -> b
$ String -> RedisException
IncorrectUpdate String
"Unable to apply subtraction to this field"

apply PersistUpdate
Divide (PersistInt64 Int64
x) (PersistInt64 Int64
y) = Int64 -> PersistValue
PersistInt64 (Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
div Int64
x Int64
y)
apply PersistUpdate
Divide (PersistDouble Double
x) (PersistDouble Double
y) = Double -> PersistValue
PersistDouble (Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
y)
apply PersistUpdate
Divide (PersistRational Rational
x) (PersistRational Rational
y) = Rational -> PersistValue
PersistRational (Rational
x Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
y)
apply PersistUpdate
Divide PersistValue
_ PersistValue
_ = RedisException -> PersistValue
forall a e. Exception e => e -> a
throw (RedisException -> PersistValue) -> RedisException -> PersistValue
forall a b. (a -> b) -> a -> b
$ String -> RedisException
IncorrectUpdate String
"Unable to apply subtraction to this field"

apply (BackendSpecificUpdate Text
_) PersistValue
_ PersistValue
_ = RedisException -> PersistValue
forall a e. Exception e => e -> a
throw RedisException
IncorrectBehavior