{-# 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)
#if MIN_VERSION_opaleye(0,8,0)
import Opaleye (Field, requiredTableField, optionalTableField)
import Opaleye.Internal.Table (TableFields)
#else
import Opaleye (Column, required, optional)
import Opaleye.Internal.Table (TableProperties)
#endif

#if MIN_VERSION_opaleye(0,8,0)
-- |Helper typeclass which picks which of 'requiredTableField' or 'optionalTableField' to use for a pair of write column type and read column type.
--
-- @DefaultRecTableField (Maybe (Field a)) (Field a)@ uses 'optionalTableField'.
-- @DefaultRecTableField        (Field a)  (Field a)@ uses 'requiredTableField'.
class DefaultRecTableField write read where
  defaultRecTableField :: String -> TableFields write read

instance DefaultRecTableField (Maybe (Field a)) (Field a) where
  defaultRecTableField :: String -> TableFields (Maybe (Field a)) (Field a)
defaultRecTableField = String -> TableFields (Maybe (Field a)) (Field a)
forall (n :: Nullability) a.
String -> TableFields (Maybe (Field_ n a)) (Field_ n a)
optionalTableField

instance DefaultRecTableField (Field a) (Field a) where
  defaultRecTableField :: String -> TableFields (Field a) (Field a)
defaultRecTableField = String -> TableFields (Field a) (Field a)
forall (n :: Nullability) a.
String -> TableFields (Field_ n a) (Field_ n a)
requiredTableField
#else
-- |Helper typeclass which picks which of 'required' or 'optional' to use for a pair of write column type and read column type.
--
-- @DefaultRecTableField (Maybe (Column a)) (Column a)@ uses 'optional'.
-- @DefaultRecTableField        (Column a)  (Column a)@ uses 'required'.
class DefaultRecTableField write read where
  defaultRecTableField :: String -> TableProperties write read

instance DefaultRecTableField (Maybe (Column a)) (Column a) where
  defaultRecTableField = optional

instance DefaultRecTableField (Column a) (Column a) where
  defaultRecTableField = required
#endif

#if MIN_VERSION_opaleye(0,8,0)
-- |Type class for producing a default 'TableFields' schema for some expected record types. 'requiredTableField' and 'optionalTableField' are chosen automatically and the
-- column is named after the record fields.
--
-- For example, given:
--
-- >  type WriteRec = Record '["id" :-> Maybe (Field PGInt8), "name" :-> Field PGText]
-- >  type ReadRec  = Record '["id" :->        Field PGInt8 , "name" :-> Field PGText]
--
-- This:
--
-- >  defaultRecTable :: TableFields WriteRec ReadRec
--
-- Is equivalent to:
--
-- > pRec (optionalTableField "id" &: requiredTableField "name" &: Nil)
--
--
-- Alternately, use 'Composite.Opaleye.ProductProfunctors.pRec' and the usual Opaleye 'requiredTableField' and 'optionalTableField'.
class DefaultRecTable write read where
  defaultRecTable :: TableFields (Rec Identity write) (Rec Identity read)

instance DefaultRecTable '[] '[] where
  defaultRecTable :: TableFields (Rec Identity '[]) (Rec Identity '[])
defaultRecTable = (Rec Identity '[] -> ())
-> (() -> Rec Identity '[])
-> TableFields () ()
-> TableFields (Rec Identity '[]) (Rec Identity '[])
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (() -> Rec Identity '[] -> ()
forall a b. a -> b -> a
const ()) (Rec Identity '[] -> () -> Rec Identity '[]
forall a b. a -> b -> a
const Rec Identity '[]
forall u (a :: u -> *). Rec a '[]
RNil) TableFields () ()
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 =
    (Rec Identity ((s :-> w) : writes) -> (w, Rec Identity writes))
-> ((r, Rec Identity reads) -> Rec Identity ((s :-> r) : reads))
-> TableFields (w, Rec Identity writes) (r, Rec Identity reads)
-> TableFields
     (Rec Identity ((s :-> w) : writes))
     (Rec Identity ((s :-> r) : reads))
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (\ (Identity (Val w) :& Rec Identity rs
writeRs) -> (w
w, Rec Identity rs
writeRs))
          (\ (r
r, Rec Identity reads
readRs) -> ((s :-> r) -> Identity (s :-> r)
forall a. a -> Identity a
Identity (r -> s :-> r
forall (s :: Symbol) a. a -> s :-> a
Val r
r) Identity (s :-> r)
-> Rec Identity reads -> Rec Identity ((s :-> r) : reads)
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  TableFields w r
-> TableFields (Rec Identity writes) (Rec Identity reads)
-> TableFields (w, Rec Identity writes) (r, Rec Identity reads)
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 = String -> TableFields w r
forall write read.
DefaultRecTableField write read =>
String -> TableFields write read
defaultRecTableField (String -> TableFields w r) -> String -> TableFields w r
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
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 = TableFields (Rec Identity writes) (Rec Identity reads)
forall (write :: [*]) (read :: [*]).
DefaultRecTable write read =>
TableFields (Rec Identity write) (Rec Identity read)
defaultRecTable
#else
-- |Type class for producing a default 'TableProperties' schema for some expected record types. 'required' and 'optional' are chosen automatically and the
-- column is named after the record fields.
--
-- For example, given:
--
-- >  type WriteRec = Record '["id" :-> Maybe (Column PGInt8), "name" :-> Column PGText]
-- >  type ReadRec  = Record '["id" :->        Column PGInt8 , "name" :-> Column PGText]
--
-- This:
--
-- >  defaultRecTable :: TableProperties WriteRec ReadRec
--
-- Is equivalent to:
--
-- > pRec (optional "id" &: required "name" &: Nil)
--
--
-- Alternately, use 'Composite.Opaleye.ProductProfunctors.pRec' and the usual Opaleye 'required' and 'optional'.
class DefaultRecTable write read where
  defaultRecTable :: TableProperties (Rec Identity write) (Rec Identity read)

instance DefaultRecTable '[] '[] where
  defaultRecTable = dimap (const ()) (const RNil) 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 =
    dimap (\ (Identity (Val w) :& writeRs) -> (w, writeRs))
          (\ (r, readRs) -> (Identity (Val r) :& readRs))
          (step  ***! recur)
    where
      step :: TableProperties w r
      step = defaultRecTableField $ symbolVal (Proxy :: Proxy s)
      recur :: TableProperties (Rec Identity writes) (Rec Identity reads)
      recur = defaultRecTable
#endif