{-# LANGUAGE CPP #-}
module Composite.Opaleye.RecordTable where
import Composite.Record ((:->)(Val), Rec((:&), RNil))
import Data.Functor.Identity (Identity(Identity))
import Data.Profunctor (dimap)
import Data.Profunctor.Product ((***!))
import qualified Data.Profunctor.Product as PP
import Data.Proxy (Proxy(Proxy))
import GHC.TypeLits (KnownSymbol, symbolVal)
import Opaleye (Field_, requiredTableField, optionalTableField)
import Opaleye.Internal.Table (TableFields)
class DefaultRecTableField write read where
defaultRecTableField :: String -> TableFields write read
instance DefaultRecTableField (Maybe (Field_ n a)) (Field_ n a) where
defaultRecTableField :: String -> TableFields (Maybe (Field_ n a)) (Field_ n a)
defaultRecTableField = forall (n :: Nullability) a.
String -> TableFields (Maybe (Field_ n a)) (Field_ n a)
optionalTableField
instance DefaultRecTableField (Field_ n a) (Field_ n a) where
defaultRecTableField :: String -> TableFields (Field_ n a) (Field_ n a)
defaultRecTableField = forall (n :: Nullability) a.
String -> TableFields (Field_ n a) (Field_ n a)
requiredTableField
class DefaultRecTable write read where
defaultRecTable :: TableFields (Rec Identity write) (Rec Identity read)
instance DefaultRecTable '[] '[] where
defaultRecTable :: TableFields (Rec Identity '[]) (Rec Identity '[])
defaultRecTable = forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (forall a b. a -> b -> a
const ()) (forall a b. a -> b -> a
const forall {u} (a :: u -> *). Rec a '[]
RNil) forall (p :: * -> * -> *). ProductProfunctor p => p () ()
PP.empty
instance
forall s r reads w writes.
( KnownSymbol s
, DefaultRecTableField w r
, DefaultRecTable writes reads
) => DefaultRecTable (s :-> w ': writes) (s :-> r ': reads) where
defaultRecTable :: TableFields
(Rec Identity ((s :-> w) : writes))
(Rec Identity ((s :-> r) : reads))
defaultRecTable =
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (\ (Identity (Val w
w) :& Rec Identity rs
writeRs) -> (w
w, Rec Identity rs
writeRs))
(\ (r
r, Rec Identity reads
readRs) -> (forall a. a -> Identity a
Identity (forall (s :: Symbol) a. a -> s :-> a
Val r
r) forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec Identity reads
readRs))
(TableFields w r
step forall (p :: * -> * -> *) a b a' b'.
ProductProfunctor p =>
p a b -> p a' b' -> p (a, a') (b, b')
***! TableFields (Rec Identity writes) (Rec Identity reads)
recur)
where
step :: TableFields w r
step :: TableFields w r
step = forall write read.
DefaultRecTableField write read =>
String -> TableFields write read
defaultRecTableField forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy s)
recur :: TableFields (Rec Identity writes) (Rec Identity reads)
recur :: TableFields (Rec Identity writes) (Rec Identity reads)
recur = forall (write :: [*]) (read :: [*]).
DefaultRecTable write read =>
TableFields (Rec Identity write) (Rec Identity read)
defaultRecTable