{-# language AllowAmbiguousTypes #-}
{-# language BlockArguments #-}
{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language UndecidableInstances #-}
{-# language UndecidableSuperClasses #-}
{-# language ViewPatterns #-}
module Rel8.Type.Composite
( Composite( Composite )
, DBComposite( compositeFields, compositeTypeName )
, compose, decompose
)
where
import Data.Functor.Const ( Const( Const ), getConst )
import Data.Functor.Identity ( Identity( Identity ) )
import Data.Kind ( Constraint, Type )
import Prelude
import qualified Hasql.Decoders as Hasql
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
import Rel8.Expr ( Expr )
import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
import Rel8.Schema.Name ( Name( Name ) )
import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )
import Rel8.Table.Eq ( EqTable )
import Rel8.Table.HKD ( HKD, HKDable )
import Rel8.Table.Ord ( OrdTable )
import Rel8.Table.Rel8able ()
import Rel8.Table.Serialize ( litHTable )
import Rel8.Type ( DBType, typeInformation )
import Rel8.Type.Eq ( DBEq )
import Rel8.Type.Information ( TypeInformation(..) )
import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
import Data.Functor.Apply ( WrappedApplicative(..) )
type Composite :: Type -> Type
newtype Composite a = Composite
{ Composite a -> a
unComposite :: a
}
instance DBComposite a => DBType (Composite a) where
typeInformation :: TypeInformation (Composite a)
typeInformation = TypeInformation :: forall a. (a -> PrimExpr) -> Value a -> String -> TypeInformation a
TypeInformation
{ decode :: Value (Composite a)
decode = Composite (Composite a) -> Value (Composite a)
forall a. Composite a -> Value a
Hasql.composite (a -> Composite a
forall a. a -> Composite a
Composite (a -> Composite a)
-> (Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Result
-> a)
-> Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Result
-> Composite a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table Expr (HKD a Expr) =>
Columns (HKD a Expr) Result -> FromExprs (HKD a Expr)
forall (context :: Context) a.
Table context a =>
Columns a Result -> FromExprs a
fromResult @_ @(HKD a Expr) (Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Result
-> Composite a)
-> Composite
(Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Result)
-> Composite (Composite a)
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> Composite
(Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Result)
forall (t :: HTable). HTable t => Composite (t Result)
decoder)
, encode :: Composite a -> PrimExpr
encode = Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Expr
-> PrimExpr
forall (t :: HTable). HTable t => t Expr -> PrimExpr
encoder (Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Expr
-> PrimExpr)
-> (Composite a
-> Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Expr)
-> Composite a
-> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Result
-> Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Expr
forall (t :: HTable). HTable t => t Result -> t Expr
litHTable (Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Result
-> Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Expr)
-> (Composite a
-> Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Result)
-> Composite a
-> Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table Expr (HKD a Expr) =>
FromExprs (HKD a Expr) -> Columns (HKD a Expr) Result
forall (context :: Context) a.
Table context a =>
FromExprs a -> Columns a Result
toResult @_ @(HKD a Expr) (a
-> Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Result)
-> (Composite a -> a)
-> Composite a
-> Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Composite a -> a
forall a. Composite a -> a
unComposite
, typeName :: String
typeName = DBComposite a => String
forall a. DBComposite a => String
compositeTypeName @a
}
instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a)
instance (DBComposite a, OrdTable (HKD a Expr)) => DBOrd (Composite a)
instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a)
instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)
type DBComposite :: Type -> Constraint
class (DBType a, HKDable a) => DBComposite a where
compositeFields :: HKD a Name
compositeTypeName :: String
compose :: DBComposite a => HKD a Expr -> Expr a
compose :: HKD a Expr -> Expr a
compose = Expr a -> Expr a
forall a. Sql DBType a => Expr a -> Expr a
castExpr (Expr a -> Expr a)
-> (HKD a Expr -> Expr a) -> HKD a Expr -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr (PrimExpr -> Expr a)
-> (HKD a Expr -> PrimExpr) -> HKD a Expr -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Expr
-> PrimExpr
forall (t :: HTable). HTable t => t Expr -> PrimExpr
encoder (Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Expr
-> PrimExpr)
-> (HKD a Expr
-> Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Expr)
-> HKD a Expr
-> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HKD a Expr
-> Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns
decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
decompose :: Expr a -> HKD a Expr
decompose (Expr a -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr -> PrimExpr
a) = Columns (HKD a Expr) Expr -> HKD a Expr
forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns (Columns (HKD a Expr) Expr -> HKD a Expr)
-> Columns (HKD a Expr) Expr -> HKD a Expr
forall a b. (a -> b) -> a -> b
$ (forall a.
HField
(Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a)))))
a
-> Expr a)
-> Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Expr
forall (t :: HTable) (context :: Context).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate \HField
(Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a)))))
a
field ->
case Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Name
-> HField
(Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a)))))
a
-> Name a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Name
Columns (HKD a Name) Name
names HField
(Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a)))))
a
field of
Name String
name -> case Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Spec
-> HField
(Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a)))))
a
-> Spec a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a))))
Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField
(Eval
(GGColumns
(GAlgebra (Rep a))
TColumns
(GRecord (GMap (TColumn Expr) (Rep a)))))
a
field of
Spec {} -> PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr (PrimExpr -> Expr a) -> PrimExpr -> Expr a
forall a b. (a -> b) -> a -> b
$ PrimExpr -> String -> PrimExpr
Opaleye.CompositeExpr PrimExpr
a String
name
where
names :: Columns (HKD a Name) Name
names = HKD a Name -> Columns (HKD a Name) Name
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns (DBComposite a => HKD a Name
forall a. DBComposite a => HKD a Name
compositeFields @a)
decoder :: HTable t => Hasql.Composite (t Result)
decoder :: Composite (t Result)
decoder = WrappedApplicative Composite (t Result) -> Composite (t Result)
forall (f :: Context) a. WrappedApplicative f a -> f a
unwrapApplicative (WrappedApplicative Composite (t Result) -> Composite (t Result))
-> WrappedApplicative Composite (t Result) -> Composite (t Result)
forall a b. (a -> b) -> a -> b
$ (forall a. HField t a -> WrappedApplicative Composite (Result a))
-> WrappedApplicative Composite (t Result)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA \HField t a
field ->
case t Spec -> HField t a -> Spec a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield t Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField t a
field of
Spec {Nullity a
nullity :: Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity, TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info :: forall a. Spec a -> TypeInformation (Unnullify a)
info} -> Composite (Result a) -> WrappedApplicative Composite (Result a)
forall (f :: Context) a. f a -> WrappedApplicative f a
WrapApplicative (Composite (Result a) -> WrappedApplicative Composite (Result a))
-> Composite (Result a) -> WrappedApplicative Composite (Result a)
forall a b. (a -> b) -> a -> b
$ a -> Result a
forall a. a -> Identity a
Identity (a -> Result a) -> Composite a -> Composite (Result a)
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$>
case Nullity a
nullity of
Nullity a
Null -> NullableOrNot Value (Maybe a) -> Composite (Maybe a)
forall a. NullableOrNot Value a -> Composite a
Hasql.field (NullableOrNot Value (Maybe a) -> Composite (Maybe a))
-> NullableOrNot Value (Maybe a) -> Composite (Maybe a)
forall a b. (a -> b) -> a -> b
$ Value a -> NullableOrNot Value (Maybe a)
forall (decoder :: Context) a.
decoder a -> NullableOrNot decoder (Maybe a)
Hasql.nullable (Value a -> NullableOrNot Value (Maybe a))
-> Value a -> NullableOrNot Value (Maybe a)
forall a b. (a -> b) -> a -> b
$ TypeInformation a -> Value a
forall a. TypeInformation a -> Value a
decode TypeInformation a
TypeInformation (Unnullify a)
info
Nullity a
NotNull -> NullableOrNot Value a -> Composite a
forall a. NullableOrNot Value a -> Composite a
Hasql.field (NullableOrNot Value a -> Composite a)
-> NullableOrNot Value a -> Composite a
forall a b. (a -> b) -> a -> b
$ Value a -> NullableOrNot Value a
forall (decoder :: Context) a. decoder a -> NullableOrNot decoder a
Hasql.nonNullable (Value a -> NullableOrNot Value a)
-> Value a -> NullableOrNot Value a
forall a b. (a -> b) -> a -> b
$ TypeInformation a -> Value a
forall a. TypeInformation a -> Value a
decode TypeInformation a
TypeInformation (Unnullify a)
info
encoder :: HTable t => t Expr -> Opaleye.PrimExpr
encoder :: t Expr -> PrimExpr
encoder t Expr
a = String -> [PrimExpr] -> PrimExpr
Opaleye.FunExpr String
"ROW" [PrimExpr]
exprs
where
exprs :: [PrimExpr]
exprs = Const [PrimExpr] (t Any) -> [PrimExpr]
forall a k (b :: k). Const a b -> a
getConst (Const [PrimExpr] (t Any) -> [PrimExpr])
-> Const [PrimExpr] (t Any) -> [PrimExpr]
forall a b. (a -> b) -> a -> b
$ (forall a. HField t a -> Const [PrimExpr] (Any a))
-> Const [PrimExpr] (t Any)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA \HField t a
field -> case t Expr -> HField t a -> Expr a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield t Expr
a HField t a
field of
Expr a
expr -> [PrimExpr] -> Const [PrimExpr] (Any a)
forall k a (b :: k). a -> Const a b
Const [Expr a -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr Expr a
expr]