{-# LANGUAGE ScopedTypeVariables, TypeOperators #-}
{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
module Database.Selda.MakeSelectors
( Selectors, GSelectors
, selectors, tableWithSelectors
) where
import Control.Monad.State.Strict
( MonadState(state), State, evalState )
import Data.Proxy ( Proxy(..) )
import GHC.Generics ( Generic(Rep), K1, M1 )
import qualified GHC.Generics as G
import Database.Selda.Generic (Relational)
import Database.Selda.Selectors ( Selector, unsafeSelector )
import Database.Selda.SqlRow ( SqlRow )
import Database.Selda.SqlType ( SqlType )
import Database.Selda.Table ( Table, Attr, table )
import Database.Selda.Types ( type (:*:)(..), TableName )
selectors :: forall a. (Relational a, GSelectors a (Rep a))
=> Table a
-> Selectors a
selectors :: forall a.
(Relational a, GSelectors a (Rep a)) =>
Table a -> Selectors a
selectors Table a
_ = forall r. GSelectors r (Rep r) => Proxy r -> Selectors r
selectorsFor (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
tableWithSelectors :: forall a. (Relational a, GSelectors a (Rep a))
=> TableName
-> [Attr a]
-> (Table a, Selectors a)
tableWithSelectors :: forall a.
(Relational a, GSelectors a (Rep a)) =>
TableName -> [Attr a] -> (Table a, Selectors a)
tableWithSelectors TableName
name [Attr a]
cs = (Table a
t, Selectors a
s)
where
t :: Table a
t = forall a. Relational a => TableName -> [Attr a] -> Table a
table TableName
name [Attr a]
cs
s :: Selectors a
s = forall a.
(Relational a, GSelectors a (Rep a)) =>
Table a -> Selectors a
selectors Table a
t
selectorsFor :: forall r. GSelectors r (Rep r) => Proxy r -> Selectors r
selectorsFor :: forall r. GSelectors r (Rep r) => Proxy r -> Selectors r
selectorsFor = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (f :: * -> *).
GSelectors t f =>
Proxy f -> Proxy t -> State Int (Sels t f)
mkSel (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Rep r))
type Selectors r = Sels r (Rep r)
type family Sels t f where
Sels t ((a G.:*: b) G.:*: c) = Sels t (a G.:*: (b G.:*: c))
Sels t (a G.:*: b) = Sels t a :*: Sels t b
Sels t (M1 x y f) = Sels t f
Sels t (K1 i a) = Selector t a
class GSelectors t (f :: * -> *) where
mkSel :: Proxy f -> Proxy t -> State Int (Sels t f)
instance (SqlRow t, SqlType a) => GSelectors t (K1 i a) where
mkSel :: Proxy (K1 i a) -> Proxy t -> State Int (Sels t (K1 i a))
mkSel Proxy (K1 i a)
_ Proxy t
_ = forall a b. (SqlRow a, SqlType b) => Int -> Selector a b
unsafeSelector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\Int
n -> (Int
n, Int
nforall a. Num a => a -> a -> a
+Int
1))
instance (GSelectors t f, Sels t f ~ Sels t (M1 x y f)) =>
GSelectors t (M1 x y f) where
mkSel :: Proxy (M1 x y f) -> Proxy t -> State Int (Sels t (M1 x y f))
mkSel Proxy (M1 x y f)
_ = forall t (f :: * -> *).
GSelectors t f =>
Proxy f -> Proxy t -> State Int (Sels t f)
mkSel (forall {k} (t :: k). Proxy t
Proxy :: Proxy f)
instance GSelectors t (a G.:*: (b G.:*: c)) =>
GSelectors t ((a G.:*: b) G.:*: c) where
mkSel :: Proxy ((a :*: b) :*: c)
-> Proxy t -> State Int (Sels t ((a :*: b) :*: c))
mkSel Proxy ((a :*: b) :*: c)
_ = forall t (f :: * -> *).
GSelectors t f =>
Proxy f -> Proxy t -> State Int (Sels t f)
mkSel (forall {k} (t :: k). Proxy t
Proxy :: Proxy (a G.:*: (b G.:*: c)))
instance {-# OVERLAPPABLE #-}
( GSelectors t a
, GSelectors t b
, Sels t (a G.:*: b) ~ (Sels t a :*: Sels t b)
) => GSelectors t (a G.:*: b) where
mkSel :: Proxy (a :*: b) -> Proxy t -> State Int (Sels t (a :*: b))
mkSel Proxy (a :*: b)
_ Proxy t
p = do
Sels t a
x <- forall t (f :: * -> *).
GSelectors t f =>
Proxy f -> Proxy t -> State Int (Sels t f)
mkSel (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) Proxy t
p
Sels t b
xs <- forall t (f :: * -> *).
GSelectors t f =>
Proxy f -> Proxy t -> State Int (Sels t f)
mkSel (forall {k} (t :: k). Proxy t
Proxy :: Proxy b) Proxy t
p
forall (m :: * -> *) a. Monad m => a -> m a
return (Sels t a
x forall a b. a -> b -> a :*: b
:*: Sels t b
xs)