{-# 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)

-- | Wrapper to encode enum-like types as strings in the DB.
--
-- Intended usage is with @DerivingVia@:
--
-- >>> :{
-- data Color = Red | Green | Blue
--   deriving (Show, Generic)
--   deriving (ToValue, FromValue) via BoltEnum Color
-- :}
--
-- >>> toValue Red
-- T "Red"
-- >>> fromValue (T "Blue") :: Color
-- Blue
-- >>> fromValue (T "Brown") :: Color
-- *** Exception: Could not unpack unknown value Brown of Color
-- ...
-- ...
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

{- $setup
>>> :set -XDerivingStrategies -XDerivingVia
>>> :load Database.Bolt.Extras Database.Bolt.Extras.Generic
>>> import GHC.Generics
>>> import Database.Bolt.Extras.Generic
>>> import Database.Bolt (Value (..))
-}