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

-- Intended usage is with @DerivingVia@:
--
-- >>> :{
-- data Color = Red | Green | Blue
--   deriving (Eq, Show, Generic)
--   deriving (IsValue, RecordValue) via BoltGeneric Color
-- data MyRec = MyRec
--   { field1 :: Int
--   , field2 :: [Text]
--   , field3 :: Double
--   , field4 :: Color
--   }
--   deriving (Eq, Show, Generic)
--   deriving (IsValue, RecordValue) via BoltGeneric MyRec
-- data MyHardRec = MyHard
--   { field1h :: Int
--   , field2h :: [Text]
--   , field3h :: MyRec
--   }
--   deriving (Eq, Show, Generic)
--   deriving (IsValue, RecordValue) via BoltGeneric MyHardRec
-- data FailTest = FailTest Int Int
--   deriving (Eq, Show, Generic)
--   deriving (IsValue, RecordValue) via BoltGeneric FailTest
-- :}
--
-- >>> Bolt.toValue Red
-- T "Red"
-- >>> Bolt.toValue Blue
-- T "Blue"
-- >>> let myRec = MyRec 1 [pack "hello"] 3.14 Red
-- >>> Bolt.toValue myRec
-- M (fromList [("field1",I 1),("field2",L [T "hello"]),("field3",F 3.14),("field4",T "Red")])
-- >>> let myHardRec = MyHard 2 [pack "Hello!"] myRec
-- >>> Bolt.toValue myHardRec
-- M (fromList [("field1h",I 2),("field2h",L [T "Hello!"]),("field3h",M (fromList [("field1",I 1),("field2",L [T "hello"]),("field3",F 3.14),("field4",T "Red")]))])
-- >>> (exactEither . Bolt.toValue) myHardRec == Right myHardRec
-- True
-- >>> Bolt.toValue $ FailTest 1 2
-- ...
-- ... Can't make IsValue for non-record, non-unit constructor
-- ...
--

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

{- $setup
>>> :set -XDerivingStrategies -XDerivingVia
>>> :load Database.Bolt.Extras Database.Bolt.Extras.Generic
>>> import GHC.Generics
>>> import Database.Bolt.Extras.Generic
>>> import Data.Text (Text, pack)
>>> import Database.Bolt as Bolt (Value (..), IsValue(toValue), RecordValue(exactEither))
-}