{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Bolt.Extras.Generic where
import Data.Proxy (Proxy (..))
import Data.Text (pack, unpack)
import Database.Bolt (Value (..))
import GHC.Generics (C1, D1, Generic (..), M1 (..), Meta (..), U1 (..), type (:+:) (..))
import GHC.TypeLits (KnownSymbol, symbolVal)
import Control.Applicative ((<|>))
import Database.Bolt.Extras.Internal.Types (FromValue (..), ToValue (..))
import Type.Reflection (Typeable, typeRep)
newtype BoltEnum a
= BoltEnum a
deriving (BoltEnum a -> BoltEnum a -> Bool
(BoltEnum a -> BoltEnum a -> Bool)
-> (BoltEnum a -> BoltEnum a -> Bool) -> Eq (BoltEnum a)
forall a. Eq a => BoltEnum a -> BoltEnum a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BoltEnum a -> BoltEnum a -> Bool
$c/= :: forall a. Eq a => BoltEnum a -> BoltEnum a -> Bool
== :: BoltEnum a -> BoltEnum a -> Bool
$c== :: forall a. Eq a => BoltEnum a -> BoltEnum a -> Bool
Eq, Int -> BoltEnum a -> ShowS
[BoltEnum a] -> ShowS
BoltEnum a -> String
(Int -> BoltEnum a -> ShowS)
-> (BoltEnum a -> String)
-> ([BoltEnum a] -> ShowS)
-> Show (BoltEnum a)
forall a. Show a => Int -> BoltEnum a -> ShowS
forall a. Show a => [BoltEnum a] -> ShowS
forall a. Show a => BoltEnum a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BoltEnum a] -> ShowS
$cshowList :: forall a. Show a => [BoltEnum a] -> ShowS
show :: BoltEnum a -> String
$cshow :: forall a. Show a => BoltEnum a -> String
showsPrec :: Int -> BoltEnum a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> BoltEnum a -> ShowS
Show, (forall x. BoltEnum a -> Rep (BoltEnum a) x)
-> (forall x. Rep (BoltEnum a) x -> BoltEnum a)
-> Generic (BoltEnum a)
forall x. Rep (BoltEnum a) x -> BoltEnum a
forall x. BoltEnum a -> Rep (BoltEnum a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (BoltEnum a) x -> BoltEnum a
forall a x. BoltEnum a -> Rep (BoltEnum a) x
$cto :: forall a x. Rep (BoltEnum a) x -> BoltEnum a
$cfrom :: forall a x. BoltEnum a -> Rep (BoltEnum a) x
Generic)
instance (Generic a, GToValue (Rep a)) => ToValue (BoltEnum a) where
toValue :: BoltEnum a -> Value
toValue (BoltEnum a
a) = Text -> Value
T (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Rep a Any -> String
forall (rep :: * -> *) a. GToValue rep => rep a -> String
gToValue (Rep a Any -> String) -> Rep a Any -> String
forall a b. (a -> b) -> a -> b
$ a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
a
instance (Typeable a, Generic a, GFromValue (Rep a)) => FromValue (BoltEnum a) where
fromValue :: Value -> BoltEnum a
fromValue (T Text
str) =
case String -> Maybe (Rep a Any)
forall (rep :: * -> *) a. GFromValue rep => String -> Maybe (rep a)
gFromValue (String -> Maybe (Rep a Any)) -> String -> Maybe (Rep a Any)
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
str of
Maybe (Rep a Any)
Nothing -> String -> BoltEnum a
forall a. HasCallStack => String -> a
error (String -> BoltEnum a) -> String -> BoltEnum a
forall a b. (a -> b) -> a -> b
$ String
"Could not unpack unknown value " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
str String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep a -> String
forall a. Show a => a -> String
show (Typeable a => TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep @a)
Just Rep a Any
rep -> a -> BoltEnum a
forall a. a -> BoltEnum a
BoltEnum (a -> BoltEnum a) -> a -> BoltEnum a
forall a b. (a -> b) -> a -> b
$ Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to Rep a Any
rep
fromValue Value
v = String -> BoltEnum a
forall a. HasCallStack => String -> a
error (String -> BoltEnum a) -> String -> BoltEnum a
forall a b. (a -> b) -> a -> b
$ String
"Could not unpack " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
v String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" as " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep a -> String
forall a. Show a => a -> String
show (Typeable a => TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep @a)
class GToValue rep where
gToValue :: rep a -> String
instance GToValue cs => GToValue (D1 meta cs) where
gToValue :: D1 meta cs a -> String
gToValue (M1 cs a
cs) = cs a -> String
forall (rep :: * -> *) a. GToValue rep => rep a -> String
gToValue cs a
cs
instance KnownSymbol name => GToValue (C1 ('MetaCons name fixity rec) U1) where
gToValue :: C1 ('MetaCons name fixity rec) U1 a -> String
gToValue C1 ('MetaCons name fixity rec) U1 a
_ = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @name Proxy name
forall k (t :: k). Proxy t
Proxy
instance (GToValue l, GToValue r) => GToValue (l :+: r) where
gToValue :: (:+:) l r a -> String
gToValue (L1 l a
l) = l a -> String
forall (rep :: * -> *) a. GToValue rep => rep a -> String
gToValue l a
l
gToValue (R1 r a
r) = r a -> String
forall (rep :: * -> *) a. GToValue rep => rep a -> String
gToValue r a
r
class GFromValue rep where
gFromValue :: String -> Maybe (rep a)
instance GFromValue cs => GFromValue (D1 meta cs) where
gFromValue :: String -> Maybe (D1 meta cs a)
gFromValue = (cs a -> D1 meta cs a) -> Maybe (cs a) -> Maybe (D1 meta cs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap cs a -> D1 meta cs a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Maybe (cs a) -> Maybe (D1 meta cs a))
-> (String -> Maybe (cs a)) -> String -> Maybe (D1 meta cs a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. GFromValue cs => String -> Maybe (cs a)
forall (rep :: * -> *) a. GFromValue rep => String -> Maybe (rep a)
gFromValue @cs
instance KnownSymbol name => GFromValue (C1 ('MetaCons name fixity rec) U1) where
gFromValue :: String -> Maybe (C1 ('MetaCons name fixity rec) U1 a)
gFromValue String
str =
if String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @name Proxy name
forall k (t :: k). Proxy t
Proxy
then C1 ('MetaCons name fixity rec) U1 a
-> Maybe (C1 ('MetaCons name fixity rec) U1 a)
forall a. a -> Maybe a
Just (C1 ('MetaCons name fixity rec) U1 a
-> Maybe (C1 ('MetaCons name fixity rec) U1 a))
-> C1 ('MetaCons name fixity rec) U1 a
-> Maybe (C1 ('MetaCons name fixity rec) U1 a)
forall a b. (a -> b) -> a -> b
$ U1 a -> C1 ('MetaCons name fixity rec) U1 a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 U1 a
forall k (p :: k). U1 p
U1
else Maybe (C1 ('MetaCons name fixity rec) U1 a)
forall a. Maybe a
Nothing
instance (GFromValue l, GFromValue r) => GFromValue (l :+: r) where
gFromValue :: String -> Maybe ((:+:) l r a)
gFromValue String
str = l a -> (:+:) l r a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (l a -> (:+:) l r a) -> Maybe (l a) -> Maybe ((:+:) l r a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe (l a)
forall (rep :: * -> *) a. GFromValue rep => String -> Maybe (rep a)
gFromValue @l String
str Maybe ((:+:) l r a) -> Maybe ((:+:) l r a) -> Maybe ((:+:) l r a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> r a -> (:+:) l r a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (r a -> (:+:) l r a) -> Maybe (r a) -> Maybe ((:+:) l r a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe (r a)
forall (rep :: * -> *) a. GFromValue rep => String -> Maybe (rep a)
gFromValue @r String
str