{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Bolt.Extras.Generic where
import Data.Map.Strict (lookup, singleton)
import Data.Proxy (Proxy (..))
import Data.Text (pack)
import Database.Bolt (IsValue (..), RecordValue (..),
UnpackError (Not), Value (..))
import GHC.Generics (C1, D1, Generic (..), K1 (..), M1 (..),
Meta (..), Rec0, S1, Selector (selName),
U1 (..), type (:*:) (..), type (:+:) (..))
import GHC.TypeLits as GHC (ErrorMessage (Text), KnownSymbol,
TypeError, symbolVal)
import Data.Aeson (Options, constructorTagModifier,
defaultOptions, fieldLabelModifier)
import Data.Either (isRight)
import Prelude hiding (lookup)
import Type.Reflection (Typeable)
newtype BoltGeneric a
= BoltGeneric a
deriving (BoltGeneric a -> BoltGeneric a -> Bool
forall a. Eq a => BoltGeneric a -> BoltGeneric a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BoltGeneric a -> BoltGeneric a -> Bool
$c/= :: forall a. Eq a => BoltGeneric a -> BoltGeneric a -> Bool
== :: BoltGeneric a -> BoltGeneric a -> Bool
$c== :: forall a. Eq a => BoltGeneric a -> BoltGeneric a -> Bool
Eq, Int -> BoltGeneric a -> ShowS
forall a. Show a => Int -> BoltGeneric a -> ShowS
forall a. Show a => [BoltGeneric a] -> ShowS
forall a. Show a => BoltGeneric a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BoltGeneric a] -> ShowS
$cshowList :: forall a. Show a => [BoltGeneric a] -> ShowS
show :: BoltGeneric a -> String
$cshow :: forall a. Show a => BoltGeneric a -> String
showsPrec :: Int -> BoltGeneric a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> BoltGeneric a -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (BoltGeneric a) x -> BoltGeneric a
forall a x. BoltGeneric a -> Rep (BoltGeneric a) x
$cto :: forall a x. Rep (BoltGeneric a) x -> BoltGeneric a
$cfrom :: forall a x. BoltGeneric a -> Rep (BoltGeneric a) x
Generic)
instance (Generic a, GIsValue (Rep a)) => IsValue (BoltGeneric a) where
toValue :: HasCallStack => BoltGeneric a -> Value
toValue (BoltGeneric a
a) =
case forall (rep :: * -> *) a.
GIsValue rep =>
Options -> rep a -> Either String Value
gIsValue Options
defaultOptions (forall a x. Generic a => a -> Rep a x
from a
a) of
Left String
err -> forall a. HasCallStack => String -> a
error String
err
Right Value
res -> Value
res
instance (Typeable a, Generic a, GRecordValue (Rep a)) => RecordValue (BoltGeneric a) where
exactEither :: Value -> Either UnpackError (BoltGeneric a)
exactEither Value
v = forall a. a -> BoltGeneric a
BoltGeneric forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) a.
GRecordValue rep =>
ShowS -> Value -> Either UnpackError (rep a)
gExactEither forall a. a -> a
id Value
v
class GIsValue rep where
gIsValue :: Options -> rep a -> Either String Value
instance GIsValue cs => GIsValue (D1 meta cs) where
gIsValue :: forall a. Options -> D1 meta cs a -> Either String Value
gIsValue Options
op (M1 cs a
cs) = forall (rep :: * -> *) a.
GIsValue rep =>
Options -> rep a -> Either String Value
gIsValue Options
op cs a
cs
instance GIsValue cs => (GIsValue (C1 ('MetaCons s1 s2 'True) cs)) where
gIsValue :: forall a.
Options -> C1 ('MetaCons s1 s2 'True) cs a -> Either String Value
gIsValue Options
op (M1 cs a
cs) = forall (rep :: * -> *) a.
GIsValue rep =>
Options -> rep a -> Either String Value
gIsValue Options
op cs a
cs
instance {-# OVERLAPPING #-} (KnownSymbol name) => GIsValue (C1 ('MetaCons name s2 'False) U1) where
gIsValue :: forall a.
Options
-> C1 ('MetaCons name s2 'False) U1 a -> Either String Value
gIsValue Options
op C1 ('MetaCons name s2 'False) U1 a
_ = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Value
T forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ Options -> ShowS
constructorTagModifier Options
op forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @name forall {k} (t :: k). Proxy t
Proxy
instance TypeError ('GHC.Text "Can't make IsValue for non-record, non-unit constructor ") => GIsValue (C1 ('MetaCons s1 s2 'False) cs) where
gIsValue :: forall a.
Options -> C1 ('MetaCons s1 s2 'False) cs a -> Either String Value
gIsValue Options
_ C1 ('MetaCons s1 s2 'False) cs a
_ = forall a. HasCallStack => String -> a
error String
"not reachable"
instance (Selector s, IsValue a) => GIsValue (S1 s (Rec0 a)) where
gIsValue :: forall a. Options -> S1 s (Rec0 a) a -> Either String Value
gIsValue Options
op m :: S1 s (Rec0 a) a
m@(M1 (K1 a
v)) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Map Text Value -> Value
M forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
singleton (String -> Text
pack String
name) (forall a. (IsValue a, HasCallStack) => a -> Value
toValue a
v)
where
name :: String
name = Options -> ShowS
fieldLabelModifier Options
op (forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName S1 s (Rec0 a) a
m)
instance (GIsValue l, GIsValue r) => GIsValue (l :+: r) where
gIsValue :: forall a. Options -> (:+:) l r a -> Either String Value
gIsValue Options
op (L1 l a
l) = forall (rep :: * -> *) a.
GIsValue rep =>
Options -> rep a -> Either String Value
gIsValue Options
op l a
l
gIsValue Options
op (R1 r a
r) = forall (rep :: * -> *) a.
GIsValue rep =>
Options -> rep a -> Either String Value
gIsValue Options
op r a
r
instance (GIsValue l, GIsValue r) => GIsValue (l :*: r) where
gIsValue :: forall a. Options -> (:*:) l r a -> Either String Value
gIsValue Options
op (l a
l :*: r a
r) = do
Value
lRes <- forall (rep :: * -> *) a.
GIsValue rep =>
Options -> rep a -> Either String Value
gIsValue Options
op l a
l
Value
rRes <- forall (rep :: * -> *) a.
GIsValue rep =>
Options -> rep a -> Either String Value
gIsValue Options
op r a
r
case (Value
lRes, Value
rRes) of
(M Map Text Value
ml, M Map Text Value
mr) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Map Text Value -> Value
M forall a b. (a -> b) -> a -> b
$ Map Text Value
ml forall a. Semigroup a => a -> a -> a
<> Map Text Value
mr
(Value, Value)
_ -> forall a b. a -> Either a b
Left String
"not record product type"
class GRecordValue rep where
gExactEither :: (String -> String) -> Value -> Either UnpackError (rep a)
instance GRecordValue cs => GRecordValue (D1 meta cs) where
gExactEither :: forall a. ShowS -> Value -> Either UnpackError (D1 meta cs a)
gExactEither ShowS
modifier Value
v = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) a.
GRecordValue rep =>
ShowS -> Value -> Either UnpackError (rep a)
gExactEither ShowS
modifier Value
v
instance GRecordValue cs => GRecordValue (C1 ('MetaCons s1 s2 'True) cs) where
gExactEither :: forall a.
ShowS
-> Value -> Either UnpackError (C1 ('MetaCons s1 s2 'True) cs a)
gExactEither ShowS
modifier Value
v = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) a.
GRecordValue rep =>
ShowS -> Value -> Either UnpackError (rep a)
gExactEither ShowS
modifier Value
v
instance {-# OVERLAPPING #-} (KnownSymbol name) => GRecordValue (C1 ('MetaCons name s2 'False) U1) where
gExactEither :: forall a.
ShowS
-> Value -> Either UnpackError (C1 ('MetaCons name s2 'False) U1 a)
gExactEither ShowS
_ (T Text
str) =
if Text
str forall a. Eq a => a -> a -> Bool
== Text
name
then forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall k (p :: k). U1 p
U1
else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> UnpackError
Not forall a b. (a -> b) -> a -> b
$ Text
"expected constructor name: " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" , but got: " forall a. Semigroup a => a -> a -> a
<> Text
str
where
name :: Text
name = String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @name forall {k} (t :: k). Proxy t
Proxy
gExactEither ShowS
_ Value
_ = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> UnpackError
Not Text
"bad value"
instance TypeError ('GHC.Text "Can't make GRecordValue for non-record, non-unit constructor ") => GRecordValue (C1 ('MetaCons s1 s2 'False) cs) where
gExactEither :: forall a.
ShowS
-> Value -> Either UnpackError (C1 ('MetaCons s1 s2 'False) cs a)
gExactEither ShowS
_ = forall a. HasCallStack => String -> a
error String
"not reachable"
instance (KnownSymbol name, GRecordValue a) => GRecordValue (S1 ('MetaSel ('Just name) s1 s2 s3) a) where
gExactEither :: forall a.
ShowS
-> Value
-> Either UnpackError (S1 ('MetaSel ('Just name) s1 s2 s3) a a)
gExactEither ShowS
modifier (M Map Text Value
m) =
case forall k a. Ord k => k -> Map k a -> Maybe a
lookup (String -> Text
pack forall a b. (a -> b) -> a -> b
$ ShowS
modifier String
name) Map Text Value
m of
Just Value
v -> forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) a.
GRecordValue rep =>
ShowS -> Value -> Either UnpackError (rep a)
gExactEither ShowS
modifier Value
v
Maybe Value
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> UnpackError
Not forall a b. (a -> b) -> a -> b
$ Text
"selector with name:" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
name forall a. Semigroup a => a -> a -> a
<> Text
" not in record"
where
name :: String
name = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @name forall {k} (t :: k). Proxy t
Proxy
gExactEither ShowS
_ Value
_ = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> UnpackError
Not Text
"bad structure in selector case"
instance (GRecordValue l, GRecordValue r) => GRecordValue (l :*: r) where
gExactEither :: forall a. ShowS -> Value -> Either UnpackError ((:*:) l r a)
gExactEither ShowS
modifier Value
v = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) a.
GRecordValue rep =>
ShowS -> Value -> Either UnpackError (rep a)
gExactEither ShowS
modifier Value
v forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (rep :: * -> *) a.
GRecordValue rep =>
ShowS -> Value -> Either UnpackError (rep a)
gExactEither ShowS
modifier Value
v
instance (GRecordValue l, GRecordValue r) => GRecordValue (l :+: r) where
gExactEither :: forall a. ShowS -> Value -> Either UnpackError ((:+:) l r a)
gExactEither ShowS
modifier Value
v =
let res :: Either UnpackError ((:+:) l g p)
res = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) a.
GRecordValue rep =>
ShowS -> Value -> Either UnpackError (rep a)
gExactEither @l ShowS
modifier Value
v in
if forall a b. Either a b -> Bool
isRight forall {g :: * -> *} {p}. Either UnpackError ((:+:) l g p)
res then forall {g :: * -> *} {p}. Either UnpackError ((:+:) l g p)
res else forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) a.
GRecordValue rep =>
ShowS -> Value -> Either UnpackError (rep a)
gExactEither @r ShowS
modifier Value
v
instance (RecordValue a) => GRecordValue (K1 i a) where
gExactEither :: forall a. ShowS -> Value -> Either UnpackError (K1 i a a)
gExactEither ShowS
_ Value
v = forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. RecordValue a => Value -> Either UnpackError a
exactEither Value
v