module Prairie.Update where
import Data.Aeson (ToJSON(..), FromJSON(..), object, withObject, (.:), (.=))
import Control.Lens (set)
import Data.Typeable (Typeable, (:~:)(..), eqT)
import Prairie.Class
data Update rec where
SetField :: Field rec a -> a -> Update rec
instance (forall a. Eq (Field rec a), FieldDict Typeable rec, FieldDict Eq rec) => Eq (Update rec) where
SetField Field rec a
f0 (a
a0 :: a0) == :: Update rec -> Update rec -> Bool
== SetField Field rec a
f1 (a
a1 :: a1) =
Field rec a -> (Typeable a => Bool) -> Bool
forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict @Typeable Field rec a
f0 ((Typeable a => Bool) -> Bool) -> (Typeable a => Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
Field rec a -> (Typeable a => Bool) -> Bool
forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict @Typeable Field rec a
f1 ((Typeable a => Bool) -> Bool) -> (Typeable a => Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
case (Typeable a, Typeable a) => Maybe (a :~: a)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a0 @a1 of
Maybe (a :~: a)
Nothing ->
Bool
False
Just a :~: a
Refl ->
Field rec a -> (Eq a => Bool) -> Bool
forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict @Eq Field rec a
f0 ((Eq a => Bool) -> Bool) -> (Eq a => Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
Field rec a
f0 Field rec a -> Field rec a -> Bool
forall a. Eq a => a -> a -> Bool
== Field rec a
Field rec a
f1 Bool -> Bool -> Bool
&& a
a0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a
a1
instance (forall a. Show (Field rec a), FieldDict Show rec) => Show (Update rec) where
showsPrec :: Int -> Update rec -> ShowS
showsPrec Int
d (SetField Field rec a
field a
a) =
Field rec a -> (Show a => ShowS) -> ShowS
forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict @Show Field rec a
field ((Show a => ShowS) -> ShowS) -> (Show a => ShowS) -> ShowS
forall a b. (a -> b) -> a -> b
$
Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
(ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Update "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Field rec a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Field rec a
field
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
a
instance (FieldDict ToJSON rec, forall a. ToJSON (Field rec a)) => ToJSON (Update rec) where
toJSON :: Update rec -> Value
toJSON (SetField Field rec a
field a
newVal) =
Field rec a -> (ToJSON a => Value) -> Value
forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict @ToJSON Field rec a
field ((ToJSON a => Value) -> Value) -> (ToJSON a => Value) -> Value
forall a b. (a -> b) -> a -> b
$
[Pair] -> Value
object [ Text
"field" Text -> Field rec a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Field rec a
field, Text
"value" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
newVal ]
instance (FieldDict FromJSON rec, FieldDict Typeable rec, FromJSON (SomeField rec)) => FromJSON (Update rec) where
parseJSON :: Value -> Parser (Update rec)
parseJSON = String
-> (Object -> Parser (Update rec)) -> Value -> Parser (Update rec)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Update" ((Object -> Parser (Update rec)) -> Value -> Parser (Update rec))
-> (Object -> Parser (Update rec)) -> Value -> Parser (Update rec)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
SomeField rec
field <- Object
o Object -> Text -> Parser (SomeField rec)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"field"
case SomeField rec
field of
SomeField Field rec a
field ->
Field rec a
-> (FromJSON a => Parser (Update rec)) -> Parser (Update rec)
forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict @FromJSON Field rec a
field ((FromJSON a => Parser (Update rec)) -> Parser (Update rec))
-> (FromJSON a => Parser (Update rec)) -> Parser (Update rec)
forall a b. (a -> b) -> a -> b
$
Field rec a -> a -> Update rec
forall rec a. Field rec a -> a -> Update rec
SetField Field rec a
field (a -> Update rec) -> Parser a -> Parser (Update rec)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"value"
updateSingleField :: Record rec => Update rec -> rec -> rec
updateSingleField :: Update rec -> rec -> rec
updateSingleField (SetField Field rec a
field a
newValue) rec
rec =
ASetter rec rec a a -> a -> rec -> rec
forall s t a b. ASetter s t a b -> b -> s -> t
set (Field rec a -> Lens' rec a
forall rec ty. Record rec => Field rec ty -> Lens' rec ty
recordFieldLens Field rec a
field) a
newValue rec
rec
updateRecord :: Record rec => [Update rec] -> rec -> rec
updateRecord :: [Update rec] -> rec -> rec
updateRecord [Update rec]
upds rec
rec = (Update rec -> rec -> rec) -> rec -> [Update rec] -> rec
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Update rec -> rec -> rec
forall rec. Record rec => Update rec -> rec -> rec
updateSingleField rec
rec [Update rec]
upds