{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language GADTs #-}
{-# language KindSignatures #-}
{-# language MultiParamTypeClasses #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
module Mu.Adapter.Persistent (
WithEntityNestedId(..)
, WithEntityPlainId(..)
, runDb
) where
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Resource.Internal
import Data.Functor.Identity
import Data.Int
import Database.Persist.Sql
import GHC.Generics
import GHC.TypeLits
import Mu.Schema
import Mu.Schema.Class
import Mu.Schema.Interpretation
newtype WithEntityNestedId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a
= WithEntityNestedId { WithEntityNestedId ty fmap a -> a
unWithEntityNestedId :: a }
newtype WithEntityPlainId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a
= WithEntityPlainId { WithEntityPlainId ty fmap a -> a
unWithEntityPlainId :: a }
instance ( Generic t, Applicative w
, (sch :/: sty) ~ 'DRecord name (idArg ': args)
, idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64)
, Rep t ~ D1 dInfo (C1 cInfo f)
, GToSchemaRecord Identity sch fmap args f
, ToBackendKey (PersistEntityBackend t) t
, PersistEntityBackend t ~ SqlBackend )
=> ToSchema w sch sty (WithEntityPlainId sty fmap (Entity t)) where
toSchema :: WithEntityPlainId sty fmap (Entity t) -> Term w sch (sch :/: sty)
toSchema (WithEntityPlainId (Entity key :: Key t
key x :: t
x))
= NP (Field w sch) ('FieldDef idArgName ('TPrimitive Int64) : args)
-> Term w sch (sch :/: sty)
forall typeName fieldName (w :: * -> *)
(sch :: Schema typeName fieldName)
(args :: [FieldDef typeName fieldName]) (name :: typeName).
NP (Field w sch) args -> Term w sch ('DRecord name args)
TRecord (NP (Field w sch) ('FieldDef idArgName ('TPrimitive Int64) : args)
-> Term w sch (sch :/: sty))
-> NP
(Field w sch) ('FieldDef idArgName ('TPrimitive Int64) : args)
-> Term w sch (sch :/: sty)
forall a b. (a -> b) -> a -> b
$ w (FieldValue w sch ('TPrimitive Int64))
-> Field w sch ('FieldDef idArgName ('TPrimitive Int64))
forall typeName fieldName (w :: * -> *)
(sch :: Schema typeName fieldName) (t :: FieldType typeName)
(name :: fieldName).
w (FieldValue w sch t) -> Field w sch ('FieldDef name t)
Field (FieldValue w sch ('TPrimitive Int64)
-> w (FieldValue w sch ('TPrimitive Int64))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldValue w sch ('TPrimitive Int64)
-> w (FieldValue w sch ('TPrimitive Int64)))
-> FieldValue w sch ('TPrimitive Int64)
-> w (FieldValue w sch ('TPrimitive Int64))
forall a b. (a -> b) -> a -> b
$ Int64 -> FieldValue w sch ('TPrimitive Int64)
forall typeName fieldName t1 (w :: * -> *)
(sch :: Schema typeName fieldName).
t1 -> FieldValue w sch ('TPrimitive t1)
FPrimitive (BackendKey SqlBackend -> Int64
unSqlBackendKey (BackendKey SqlBackend -> Int64) -> BackendKey SqlBackend -> Int64
forall a b. (a -> b) -> a -> b
$ Key t -> BackendKey SqlBackend
forall backend record.
ToBackendKey backend record =>
Key record -> BackendKey backend
toBackendKey Key t
key))
Field w sch ('FieldDef idArgName ('TPrimitive Int64))
-> NP (Field w sch) args
-> NP
(Field w sch) ('FieldDef idArgName ('TPrimitive Int64) : args)
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* (forall a. Identity a -> w a)
-> NP (Field Identity sch) args -> NP (Field w sch) args
forall tn fn (sch :: Schema tn fn) (args :: [FieldDef tn fn])
(u :: * -> *) (v :: * -> *).
Functor u =>
(forall a. u a -> v a)
-> NP (Field u sch) args -> NP (Field v sch) args
transFieldsNoMaps forall a. Identity a -> w a
up (Proxy fmap -> f Any -> NP (Field Identity sch) args
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
(fmap :: Mappings Symbol fs) (args :: [FieldDef ts fs])
(f :: * -> *) a.
GToSchemaRecord w sch fmap args f =>
Proxy fmap -> f a -> NP (Field w sch) args
toSchemaRecord (Proxy fmap
forall k (t :: k). Proxy t
Proxy @fmap) (M1 C cInfo f Any -> f Any
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (M1 C cInfo f Any -> f Any) -> M1 C cInfo f Any -> f Any
forall a b. (a -> b) -> a -> b
$ M1 D dInfo (C1 cInfo f) Any -> M1 C cInfo f Any
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (M1 D dInfo (C1 cInfo f) Any -> M1 C cInfo f Any)
-> M1 D dInfo (C1 cInfo f) Any -> M1 C cInfo f Any
forall a b. (a -> b) -> a -> b
$ t -> Rep t Any
forall a x. Generic a => a -> Rep a x
from t
x))
where up :: Identity a -> w a
up :: Identity a -> w a
up (Identity i :: a
i) = a -> w a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
i
instance ( Generic t, Applicative w
, (sch :/: sty) ~ 'DRecord name (nestedIdArg ': args)
, nestedIdArg ~ 'Mu.Schema.FieldDef fname ('TSchematic idTy)
, (sch :/: idTy) ~ 'DRecord idName '[idArg]
, idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64)
, Rep t ~ D1 dInfo (C1 cInfo f)
, GToSchemaRecord Identity sch fmap args f
, ToBackendKey (PersistEntityBackend t) t
, PersistEntityBackend t ~ SqlBackend )
=> ToSchema w sch sty (WithEntityNestedId sty fmap (Entity t)) where
toSchema :: WithEntityNestedId sty fmap (Entity t) -> Term w sch (sch :/: sty)
toSchema (WithEntityNestedId (Entity key :: Key t
key x :: t
x))
= NP (Field w sch) ('FieldDef fname ('TSchematic idTy) : args)
-> Term w sch (sch :/: sty)
forall typeName fieldName (w :: * -> *)
(sch :: Schema typeName fieldName)
(args :: [FieldDef typeName fieldName]) (name :: typeName).
NP (Field w sch) args -> Term w sch ('DRecord name args)
TRecord (NP (Field w sch) ('FieldDef fname ('TSchematic idTy) : args)
-> Term w sch (sch :/: sty))
-> NP (Field w sch) ('FieldDef fname ('TSchematic idTy) : args)
-> Term w sch (sch :/: sty)
forall a b. (a -> b) -> a -> b
$ w (FieldValue w sch ('TSchematic idTy))
-> Field w sch ('FieldDef fname ('TSchematic idTy))
forall typeName fieldName (w :: * -> *)
(sch :: Schema typeName fieldName) (t :: FieldType typeName)
(name :: fieldName).
w (FieldValue w sch t) -> Field w sch ('FieldDef name t)
Field (FieldValue w sch ('TSchematic idTy)
-> w (FieldValue w sch ('TSchematic idTy))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldValue w sch ('TSchematic idTy)
-> w (FieldValue w sch ('TSchematic idTy)))
-> FieldValue w sch ('TSchematic idTy)
-> w (FieldValue w sch ('TSchematic idTy))
forall a b. (a -> b) -> a -> b
$ Term w sch (sch :/: idTy) -> FieldValue w sch ('TSchematic idTy)
forall typeName fieldName (w :: * -> *)
(sch :: Schema typeName fieldName) (t1 :: typeName).
Term w sch (sch :/: t1) -> FieldValue w sch ('TSchematic t1)
FSchematic (Term w sch (sch :/: idTy) -> FieldValue w sch ('TSchematic idTy))
-> Term w sch (sch :/: idTy) -> FieldValue w sch ('TSchematic idTy)
forall a b. (a -> b) -> a -> b
$ NP (Field w sch) '[ 'FieldDef idArgName ('TPrimitive Int64)]
-> Term
w sch ('DRecord idName '[ 'FieldDef idArgName ('TPrimitive Int64)])
forall typeName fieldName (w :: * -> *)
(sch :: Schema typeName fieldName)
(args :: [FieldDef typeName fieldName]) (name :: typeName).
NP (Field w sch) args -> Term w sch ('DRecord name args)
TRecord (w (FieldValue w sch ('TPrimitive Int64))
-> Field w sch ('FieldDef idArgName ('TPrimitive Int64))
forall typeName fieldName (w :: * -> *)
(sch :: Schema typeName fieldName) (t :: FieldType typeName)
(name :: fieldName).
w (FieldValue w sch t) -> Field w sch ('FieldDef name t)
Field (FieldValue w sch ('TPrimitive Int64)
-> w (FieldValue w sch ('TPrimitive Int64))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldValue w sch ('TPrimitive Int64)
-> w (FieldValue w sch ('TPrimitive Int64)))
-> FieldValue w sch ('TPrimitive Int64)
-> w (FieldValue w sch ('TPrimitive Int64))
forall a b. (a -> b) -> a -> b
$ Int64 -> FieldValue w sch ('TPrimitive Int64)
forall typeName fieldName t1 (w :: * -> *)
(sch :: Schema typeName fieldName).
t1 -> FieldValue w sch ('TPrimitive t1)
FPrimitive Int64
key') Field w sch ('FieldDef idArgName ('TPrimitive Int64))
-> NP (Field w sch) '[]
-> NP (Field w sch) '[ 'FieldDef idArgName ('TPrimitive Int64)]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (Field w sch) '[]
forall k (a :: k -> *). NP a '[]
Nil))
Field w sch ('FieldDef fname ('TSchematic idTy))
-> NP (Field w sch) args
-> NP (Field w sch) ('FieldDef fname ('TSchematic idTy) : args)
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* (forall a. Identity a -> w a)
-> NP (Field Identity sch) args -> NP (Field w sch) args
forall tn fn (sch :: Schema tn fn) (args :: [FieldDef tn fn])
(u :: * -> *) (v :: * -> *).
Functor u =>
(forall a. u a -> v a)
-> NP (Field u sch) args -> NP (Field v sch) args
transFieldsNoMaps forall a. Identity a -> w a
up (Proxy fmap -> f Any -> NP (Field Identity sch) args
forall ts fs (w :: * -> *) (sch :: Schema ts fs)
(fmap :: Mappings Symbol fs) (args :: [FieldDef ts fs])
(f :: * -> *) a.
GToSchemaRecord w sch fmap args f =>
Proxy fmap -> f a -> NP (Field w sch) args
toSchemaRecord (Proxy fmap
forall k (t :: k). Proxy t
Proxy @fmap) (M1 C cInfo f Any -> f Any
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (M1 C cInfo f Any -> f Any) -> M1 C cInfo f Any -> f Any
forall a b. (a -> b) -> a -> b
$ M1 D dInfo (C1 cInfo f) Any -> M1 C cInfo f Any
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (M1 D dInfo (C1 cInfo f) Any -> M1 C cInfo f Any)
-> M1 D dInfo (C1 cInfo f) Any -> M1 C cInfo f Any
forall a b. (a -> b) -> a -> b
$ t -> Rep t Any
forall a x. Generic a => a -> Rep a x
from t
x))
where key' :: Int64
key' = BackendKey SqlBackend -> Int64
unSqlBackendKey (BackendKey SqlBackend -> Int64) -> BackendKey SqlBackend -> Int64
forall a b. (a -> b) -> a -> b
$ Key t -> BackendKey SqlBackend
forall backend record.
ToBackendKey backend record =>
Key record -> BackendKey backend
toBackendKey Key t
key
up :: Identity a -> w a
up :: Identity a -> w a
up (Identity i :: a
i) = a -> w a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
i
runDb :: MonadIO m
=> SqlBackend
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> m a
runDb :: SqlBackend
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a
runDb = (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a)
-> (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a)
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a)
-> (SqlBackend
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a)
-> SqlBackend
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> SqlBackend -> IO a)
-> SqlBackend
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a
-> SqlBackend -> IO a
forall backend a.
BackendCompatible SqlBackend backend =>
ReaderT backend (NoLoggingT (ResourceT IO)) a -> backend -> IO a
runSqlPersistM