mirror of
https://github.com/circuithub/rel8.git
synced 2024-10-27 02:08:37 +03:00
Sketch of HKD-lifting of Generic types
This commit is contained in:
parent
242dc79996
commit
47e7842c0f
@ -2,3 +2,9 @@
|
||||
-- will interpret them as local packages, and try to build them when we cabal
|
||||
-- build. The only reason we have to specify these is for Haskell.nix to know to
|
||||
-- override these packages by fetching them rather than using Hackage.
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: git://github.com/jcpetruzza/barbies
|
||||
tag: f99b05454874192e3511bd133555dfb6cc6a6ecb
|
||||
--sha256: 0yy2i2jbllwavv5d2176rf8lmm4l1ws90lxkmdlfgvfzqxidx0gi
|
||||
|
@ -5,7 +5,7 @@ let
|
||||
|
||||
nixpkgsArgs = haskellNix.nixpkgsArgs;
|
||||
|
||||
compiler-nix-name = "ghc901";
|
||||
compiler-nix-name = "ghc8104";
|
||||
|
||||
pkgs = import nixpkgsSrc nixpkgsArgs;
|
||||
|
||||
|
@ -17,6 +17,7 @@ library
|
||||
, casing
|
||||
, contravariant
|
||||
, hasql ^>= 1.4.5.1
|
||||
, higgledy
|
||||
, opaleye ^>= 0.7.1.0
|
||||
, profunctors
|
||||
, scientific
|
||||
@ -93,6 +94,7 @@ library
|
||||
Rel8.Schema.Field
|
||||
Rel8.Schema.Generic
|
||||
Rel8.Schema.Generic.Test
|
||||
Rel8.Schema.HKD
|
||||
Rel8.Schema.HTable
|
||||
Rel8.Schema.HTable.Either
|
||||
Rel8.Schema.HTable.Identity
|
||||
|
@ -29,10 +29,12 @@ module Rel8
|
||||
, Rel8able, KRel8able
|
||||
, Column, Field, Necessity( Required, Optional )
|
||||
, Default
|
||||
, HEither
|
||||
, HMaybe
|
||||
, HList
|
||||
, HNonEmpty
|
||||
, HThese
|
||||
, Lift
|
||||
|
||||
, Table(..)
|
||||
, AltTable((<|>:))
|
||||
@ -236,6 +238,7 @@ module Rel8
|
||||
, ToExprs(..)
|
||||
, FromExprs
|
||||
, Result
|
||||
, HKDT(..)
|
||||
) where
|
||||
|
||||
-- base
|
||||
@ -275,6 +278,7 @@ import Rel8.Schema.Column
|
||||
import Rel8.Schema.Context.Label
|
||||
import Rel8.Schema.Field
|
||||
import Rel8.Schema.Generic
|
||||
import Rel8.Schema.HKD
|
||||
import Rel8.Schema.HTable
|
||||
import Rel8.Schema.Name
|
||||
import Rel8.Schema.Null hiding ( nullable )
|
||||
|
@ -11,9 +11,10 @@ module Rel8.Schema.Field
|
||||
( Field
|
||||
, HEither, HList, HMaybe, HNonEmpty, HThese
|
||||
, Reify, hreify, hunreify
|
||||
, Reifiable
|
||||
, Reifiable(..)
|
||||
, AField(..)
|
||||
, AHEither(..), AHList(..), AHMaybe(..), AHNonEmpty(..), AHThese(..)
|
||||
, SContext(..)
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -1,8 +1,12 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language DeriveAnyClass #-}
|
||||
{-# language DeriveGeneric #-}
|
||||
{-# language DerivingStrategies #-}
|
||||
{-# language DerivingVia #-}
|
||||
{-# language DuplicateRecordFields #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language StandaloneDeriving #-}
|
||||
{-# language TypeFamilies #-}
|
||||
|
||||
module Rel8.Schema.Generic.Test
|
||||
( module Rel8.Schema.Generic.Test
|
||||
@ -13,10 +17,11 @@ where
|
||||
import GHC.Generics ( Generic )
|
||||
import Prelude
|
||||
|
||||
-- higgledy
|
||||
import Data.Generic.HKD ( HKD )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.Column
|
||||
import Rel8.Schema.Field
|
||||
import Rel8.Schema.Generic
|
||||
import Rel8
|
||||
|
||||
-- text
|
||||
import Data.Text ( Text )
|
||||
@ -76,3 +81,20 @@ data TableNonEmpty f = TableNonEmpty
|
||||
}
|
||||
deriving stock Generic
|
||||
deriving anyclass Rel8able
|
||||
|
||||
|
||||
data S3Object = S3Object
|
||||
{ bucketName :: Text
|
||||
, objectKey :: Text
|
||||
} deriving stock Generic
|
||||
|
||||
|
||||
deriving via HKDT S3Object
|
||||
instance x ~ HKD S3Object Expr => ToExprs x S3Object
|
||||
|
||||
|
||||
data HKDTest f = HKDTest
|
||||
{ s3Object :: Lift f S3Object
|
||||
}
|
||||
deriving stock Generic
|
||||
deriving anyclass Rel8able
|
||||
|
303
src/Rel8/Schema/HKD.hs
Normal file
303
src/Rel8/Schema/HKD.hs
Normal file
@ -0,0 +1,303 @@
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language BlockArguments #-}
|
||||
{-# language ConstraintKinds #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language FunctionalDependencies #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language LambdaCase #-}
|
||||
{-# language QuantifiedConstraints #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilyDependencies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
{-# options -Wno-orphans #-}
|
||||
|
||||
module Rel8.Schema.HKD
|
||||
( Lift
|
||||
, HKDT(..)
|
||||
) where
|
||||
|
||||
-- base
|
||||
import Data.Functor.Compose ( Compose(..) )
|
||||
import Data.Functor.Identity ( Identity(..), runIdentity )
|
||||
import Data.Kind ( Constraint, Type )
|
||||
import GHC.Generics
|
||||
( (:*:)( (:*:) ), K1( K1 ), M1( M1 ), C, D, S, Meta( MetaSel )
|
||||
, Rep
|
||||
)
|
||||
import GHC.TypeLits ( KnownSymbol )
|
||||
import Prelude
|
||||
|
||||
-- higgledy
|
||||
import Data.Generic.HKD ( Construct, HKD( HKD, runHKD ), GHKD_, construct, deconstruct )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Aggregate ( Col(..), Aggregate )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Schema.Context.Label
|
||||
( Labelable
|
||||
, HLabelable, hlabeler, hunlabeler
|
||||
)
|
||||
import Rel8.Schema.Dict ( Dict( Dict ) )
|
||||
import Rel8.Schema.Field ( Reify, Reifiable(..), SContext(..), hunreify, hreify )
|
||||
import Rel8.Schema.HTable ( HTable )
|
||||
import Rel8.Schema.HTable.Label ( HLabel, hlabel, hunlabel )
|
||||
import Rel8.Schema.HTable.Pair ( HPair( HPair ) )
|
||||
import Rel8.Schema.HTable.Type ( HType( HType ) )
|
||||
import Rel8.Schema.Insert ( Insert, Col(..) )
|
||||
import qualified Rel8.Schema.Kind as K
|
||||
import Rel8.Schema.Name ( Name(..) )
|
||||
import Rel8.Schema.Null ( Sql )
|
||||
import Rel8.Schema.Result ( Result )
|
||||
import Rel8.Table ( Table, Columns, Context, fromColumns, toColumns )
|
||||
import Rel8.Table.Recontextualize ( Recontextualize )
|
||||
import Rel8.Table.Serialize ( FromExprs, ToExprs, fromResult, toResult )
|
||||
import Rel8.Type ( DBType )
|
||||
|
||||
|
||||
type Column1Helper :: K.Context -> (Type -> Type) -> Type -> Constraint
|
||||
class
|
||||
( Table context (f a)
|
||||
, Context1 f ~ context
|
||||
, Context (f a) ~ context
|
||||
, Columns (f a) ~ HType a
|
||||
)
|
||||
=> Column1Helper context f a | f -> context
|
||||
instance
|
||||
( Table context (f a)
|
||||
, Context1 f ~ context
|
||||
, Context (f a) ~ context
|
||||
, Columns (f a) ~ HType a
|
||||
)
|
||||
=> Column1Helper context f a
|
||||
|
||||
|
||||
type Column1 :: K.Context -> (Type -> Type) -> Constraint
|
||||
class
|
||||
( forall a. Sql DBType a => Column1Helper context f a
|
||||
, Context1 f ~ context
|
||||
) =>
|
||||
Column1 context f | f -> context
|
||||
instance
|
||||
( forall a. Sql DBType a => Column1Helper context f a
|
||||
, Context1 f ~ context
|
||||
) =>
|
||||
Column1 context f
|
||||
|
||||
|
||||
type Context1 :: (Type -> Type) -> K.Context
|
||||
type Context1 f = Context (f Bool)
|
||||
|
||||
|
||||
toColumn1 :: forall a f context. (Column1 context f, Sql DBType a)
|
||||
=> f a -> HType a (Col context)
|
||||
toColumn1 = case Dict @(Column1Helper context f) @a of
|
||||
Dict -> toColumns
|
||||
|
||||
|
||||
fromColumn1 :: forall a f context. (Column1 context f, Sql DBType a)
|
||||
=> HType a (Col context) -> f a
|
||||
fromColumn1 = case Dict @(Column1Helper context f) @a of
|
||||
Dict -> fromColumns
|
||||
|
||||
|
||||
type Recontextualize1
|
||||
:: K.Context
|
||||
-> K.Context
|
||||
-> (Type -> Type)
|
||||
-> (Type -> Type)
|
||||
-> Constraint
|
||||
class Recontextualize context context' (f Bool) (f' Bool) =>
|
||||
Recontextualize1 context context' f f'
|
||||
instance Recontextualize context context' (f Bool) (f' Bool) =>
|
||||
Recontextualize1 context context' f f'
|
||||
|
||||
|
||||
class HTable (GColumns rep) => GTable rep where
|
||||
toGColumns :: HLabelable context
|
||||
=> (forall a. Sql DBType a => f a -> HType a context)
|
||||
-> GHKD_ f rep x
|
||||
-> GColumns rep context
|
||||
fromGColumns :: HLabelable context
|
||||
=> (forall a. Sql DBType a => HType a context -> f a)
|
||||
-> GColumns rep context
|
||||
-> GHKD_ f rep x
|
||||
|
||||
|
||||
instance GTable rep => GTable (M1 D c rep) where
|
||||
toGColumns f (M1 a) = toGColumns f a
|
||||
{-# INLINABLE toGColumns #-}
|
||||
|
||||
fromGColumns f = M1 . fromGColumns f
|
||||
{-# INLINABLE fromGColumns #-}
|
||||
|
||||
|
||||
instance GTable rep => GTable (M1 C c rep) where
|
||||
toGColumns f (M1 a) = toGColumns f a
|
||||
{-# INLINABLE toGColumns #-}
|
||||
|
||||
fromGColumns f = M1 . fromGColumns f
|
||||
{-# INLINABLE fromGColumns #-}
|
||||
|
||||
|
||||
instance (KnownSymbol name, Sql DBType a) =>
|
||||
GTable (M1 S ('MetaSel ('Just name) _su _ss _ds) (K1 i a))
|
||||
where
|
||||
toGColumns f (M1 (K1 a)) = hlabel hlabeler (f a)
|
||||
{-# INLINABLE toGColumns #-}
|
||||
|
||||
fromGColumns f a = M1 (K1 (f (hunlabel hunlabeler a)))
|
||||
{-# INLINABLE fromGColumns #-}
|
||||
|
||||
|
||||
instance (GTable f, GTable g) => GTable (f :*: g) where
|
||||
toGColumns f (x :*: y) = HPair (toGColumns f x) (toGColumns f y)
|
||||
{-# INLINABLE toGColumns #-}
|
||||
|
||||
fromGColumns f (HPair x y) = fromGColumns f x :*: fromGColumns f y
|
||||
{-# INLINABLE fromGColumns #-}
|
||||
|
||||
|
||||
type GRep a = GColumns (Rep a)
|
||||
|
||||
|
||||
type GColumns :: (Type -> Type) -> K.HTable
|
||||
type family GColumns rep where
|
||||
GColumns (M1 D _ f) = GColumns f
|
||||
GColumns (M1 C _ f) = GColumns f
|
||||
GColumns (M1 S ('MetaSel ('Just name) _ _ _) (K1 _ a)) =
|
||||
HLabel name (HType a)
|
||||
GColumns (f :*: g) = HPair (GColumns f) (GColumns g)
|
||||
|
||||
|
||||
instance (GTable (Rep a), Column1 context f, Labelable context) =>
|
||||
Table context (HKD a f)
|
||||
where
|
||||
type Columns (HKD a f) = GRep a
|
||||
type Context (HKD a f) = Context1 f
|
||||
|
||||
toColumns = toGColumns toColumn1 . runHKD
|
||||
fromColumns = HKD . fromGColumns fromColumn1
|
||||
|
||||
|
||||
instance
|
||||
( a ~ a'
|
||||
, GTable (Rep a)
|
||||
, Recontextualize1 context context' f f'
|
||||
, Column1 context f, Labelable context
|
||||
, Column1 context' f', Labelable context'
|
||||
) =>
|
||||
Recontextualize
|
||||
context
|
||||
context'
|
||||
(HKD a f)
|
||||
(HKD a' f')
|
||||
|
||||
|
||||
type Lift :: K.Context -> Type -> Type
|
||||
type family Lift context a where
|
||||
Lift (Reify context) a = ALift context a
|
||||
Lift Aggregate a = HKD a (Compose Aggregate Expr)
|
||||
Lift Expr a = HKD a Expr
|
||||
Lift Insert a = HKD a Expr
|
||||
Lift Name a = HKD a Name
|
||||
Lift Result a = a
|
||||
|
||||
|
||||
type ALift :: K.Context -> Type -> Type
|
||||
newtype ALift context a = ALift
|
||||
{ unALift :: Lift context a
|
||||
}
|
||||
|
||||
|
||||
instance
|
||||
( Reifiable context
|
||||
, GTable (Rep a)
|
||||
, Construct Identity a
|
||||
)
|
||||
=> Table (Reify context) (ALift context a)
|
||||
where
|
||||
type Context (ALift context a) = Reify context
|
||||
type Columns (ALift context a) = GRep a
|
||||
|
||||
fromColumns = sfromColumnsLift contextSing
|
||||
toColumns = stoColumnsLift contextSing
|
||||
|
||||
|
||||
instance
|
||||
( Reifiable context
|
||||
, Reifiable context'
|
||||
, GTable (Rep a)
|
||||
, Construct Identity a
|
||||
)
|
||||
=> Recontextualize
|
||||
(Reify context)
|
||||
(Reify context')
|
||||
(ALift context a)
|
||||
(ALift context' a)
|
||||
|
||||
|
||||
sfromColumnsLift :: forall a context. (GTable (Rep a), Construct Identity a)
|
||||
=> SContext context
|
||||
-> GRep a (Col (Reify context))
|
||||
-> ALift context a
|
||||
sfromColumnsLift = \case
|
||||
SAggregate ->
|
||||
ALift .
|
||||
HKD .
|
||||
fromGColumns (\(HType (Aggregation a)) -> Compose a) .
|
||||
hunreify
|
||||
SExpr -> ALift . fromColumns . hunreify
|
||||
SInsert ->
|
||||
ALift .
|
||||
HKD .
|
||||
fromGColumns (\(HType (RequiredInsert a)) -> a) .
|
||||
hunreify
|
||||
SName -> ALift . fromColumns . hunreify
|
||||
SResult -> ALift . runIdentity . construct . fromColumns . hunreify
|
||||
SReify context -> ALift . sfromColumnsLift context . hunreify
|
||||
|
||||
|
||||
stoColumnsLift :: forall a context. (GTable (Rep a), Construct Identity a)
|
||||
=> SContext context
|
||||
-> ALift context a
|
||||
-> GRep a (Col (Reify context))
|
||||
stoColumnsLift = \case
|
||||
SAggregate ->
|
||||
hreify .
|
||||
toGColumns (\(Compose a) -> HType (Aggregation a)) .
|
||||
runHKD .
|
||||
unALift
|
||||
SExpr -> hreify . toColumns . unALift
|
||||
SInsert ->
|
||||
hreify .
|
||||
toGColumns (HType . RequiredInsert) .
|
||||
runHKD .
|
||||
unALift
|
||||
SName -> hreify . toColumns . unALift
|
||||
SResult -> hreify . toColumns . deconstruct @Identity . unALift
|
||||
SReify context -> hreify . stoColumnsLift context . unALift
|
||||
|
||||
|
||||
type HKDT :: Type -> Type
|
||||
newtype HKDT a = HKDT
|
||||
{ unHKDT :: a
|
||||
}
|
||||
|
||||
|
||||
instance (GTable (Rep a), Construct Identity a, x ~ HKD a Expr) =>
|
||||
ToExprs x (HKDT a)
|
||||
where
|
||||
toResult = toColumns . deconstruct @Identity . unHKDT
|
||||
fromResult = HKDT . runIdentity . construct . fromColumns
|
||||
|
||||
|
||||
type instance FromExprs (HKD a Expr) = a
|
@ -59,175 +59,167 @@ import Data.Functor.Apply ( WrappedApplicative(..) )
|
||||
import Data.These ( These )
|
||||
|
||||
|
||||
fromResult' :: forall exprs a. ToExprs a exprs => Columns exprs (Col Result) -> a
|
||||
fromResult' = fromResult @_ @exprs
|
||||
|
||||
|
||||
toResult' :: forall exprs a. ToExprs a exprs => a -> Columns exprs (Col Result)
|
||||
toResult' = toResult @_ @exprs
|
||||
|
||||
|
||||
type ToExprs :: Type -> Type -> Constraint
|
||||
class Table Expr exprs => ToExprs a exprs where
|
||||
class Table Expr exprs => ToExprs exprs a where
|
||||
fromResult :: Columns exprs (Col Result) -> a
|
||||
toResult :: a -> Columns exprs (Col Result)
|
||||
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs a x where
|
||||
instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
|
||||
fromResult (HType (Result a)) = a
|
||||
toResult = HType . Result
|
||||
|
||||
|
||||
instance (Sql DBType a, x ~ [a]) => ToExprs [a] (Expr x) where
|
||||
instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
|
||||
fromResult (HType (Result a)) = a
|
||||
toResult = HType . Result
|
||||
|
||||
|
||||
instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Maybe a) (Expr x)
|
||||
instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
|
||||
where
|
||||
fromResult (HType (Result a)) = a
|
||||
toResult = HType . Result
|
||||
|
||||
|
||||
instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (NonEmpty a) (Expr x)
|
||||
instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
|
||||
where
|
||||
fromResult (HType (Result a)) = a
|
||||
toResult = HType . Result
|
||||
|
||||
|
||||
instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
|
||||
ToExprs (Either a b) x
|
||||
instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
|
||||
ToExprs x (Either a b)
|
||||
where
|
||||
fromResult =
|
||||
bimap (fromResult' @exprs1) (fromResult' @exprs2) .
|
||||
bimap (fromResult @exprs1) (fromResult @exprs2) .
|
||||
fromColumns
|
||||
toResult =
|
||||
toColumns .
|
||||
bimap (toResult' @exprs1) (toResult' @exprs2)
|
||||
bimap (toResult @exprs1) (toResult @exprs2)
|
||||
|
||||
|
||||
instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
|
||||
fromResult = fmap (fromResult' @exprs) . fromColumns
|
||||
toResult = toColumns . fmap (toResult' @exprs)
|
||||
instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where
|
||||
fromResult = fmap (fromResult @exprs) . fromColumns
|
||||
toResult = toColumns . fmap (toResult @exprs)
|
||||
|
||||
|
||||
instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
|
||||
fromResult = fmap (fromResult' @exprs) . fromColumns
|
||||
toResult = toColumns . fmap (toResult' @exprs)
|
||||
instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
|
||||
fromResult = fmap (fromResult @exprs) . fromColumns
|
||||
toResult = toColumns . fmap (toResult @exprs)
|
||||
|
||||
|
||||
instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
|
||||
instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)
|
||||
where
|
||||
fromResult = fmap (fromResult' @exprs) . fromColumns
|
||||
toResult = toColumns . fmap (toResult' @exprs)
|
||||
fromResult = fmap (fromResult @exprs) . fromColumns
|
||||
toResult = toColumns . fmap (toResult @exprs)
|
||||
|
||||
|
||||
instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
|
||||
ToExprs (These a b) x
|
||||
instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
|
||||
ToExprs x (These a b)
|
||||
where
|
||||
fromResult =
|
||||
bimap (fromResult' @exprs1) (fromResult' @exprs2) .
|
||||
bimap (fromResult @exprs1) (fromResult @exprs2) .
|
||||
fromColumns
|
||||
toResult =
|
||||
toColumns .
|
||||
bimap (toResult' @exprs1) (toResult' @exprs2)
|
||||
bimap (toResult @exprs1) (toResult @exprs2)
|
||||
|
||||
|
||||
instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
|
||||
ToExprs (a, b) x
|
||||
instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
|
||||
ToExprs x (a, b)
|
||||
where
|
||||
fromResult (HPair a b) =
|
||||
( fromResult' @exprs1 $ hunlabel unlabeler a
|
||||
, fromResult' @exprs2 $ hunlabel unlabeler b
|
||||
( fromResult @exprs1 $ hunlabel unlabeler a
|
||||
, fromResult @exprs2 $ hunlabel unlabeler b
|
||||
)
|
||||
toResult (a, b) = HPair
|
||||
{ hfst = hlabel labeler $ toResult' @exprs1 a
|
||||
, hsnd = hlabel labeler $ toResult' @exprs2 b
|
||||
{ hfst = hlabel labeler $ toResult @exprs1 a
|
||||
, hsnd = hlabel labeler $ toResult @exprs2 b
|
||||
}
|
||||
|
||||
|
||||
instance
|
||||
( ToExprs a exprs1
|
||||
, ToExprs b exprs2
|
||||
, ToExprs c exprs3
|
||||
( ToExprs exprs1 a
|
||||
, ToExprs exprs2 b
|
||||
, ToExprs exprs3 c
|
||||
, x ~ (exprs1, exprs2, exprs3)
|
||||
) => ToExprs (a, b, c) x
|
||||
) => ToExprs x (a, b, c)
|
||||
where
|
||||
fromResult (HTrio a b c) =
|
||||
( fromResult' @exprs1 $ hunlabel unlabeler a
|
||||
, fromResult' @exprs2 $ hunlabel unlabeler b
|
||||
, fromResult' @exprs3 $ hunlabel unlabeler c
|
||||
( fromResult @exprs1 $ hunlabel unlabeler a
|
||||
, fromResult @exprs2 $ hunlabel unlabeler b
|
||||
, fromResult @exprs3 $ hunlabel unlabeler c
|
||||
)
|
||||
toResult (a, b, c) = HTrio
|
||||
{ hfst = hlabel labeler $ toResult' @exprs1 a
|
||||
, hsnd = hlabel labeler $ toResult' @exprs2 b
|
||||
, htrd = hlabel labeler $ toResult' @exprs3 c
|
||||
{ hfst = hlabel labeler $ toResult @exprs1 a
|
||||
, hsnd = hlabel labeler $ toResult @exprs2 b
|
||||
, htrd = hlabel labeler $ toResult @exprs3 c
|
||||
}
|
||||
|
||||
|
||||
instance
|
||||
( ToExprs a exprs1
|
||||
, ToExprs b exprs2
|
||||
, ToExprs c exprs3
|
||||
, ToExprs d exprs4
|
||||
( ToExprs exprs1 a
|
||||
, ToExprs exprs2 b
|
||||
, ToExprs exprs3 c
|
||||
, ToExprs exprs4 d
|
||||
, x ~ (exprs1, exprs2, exprs3, exprs4)
|
||||
) => ToExprs (a, b, c, d) x
|
||||
) => ToExprs x (a, b, c, d)
|
||||
where
|
||||
fromResult (HQuartet a b c d) =
|
||||
( fromResult' @exprs1 $ hunlabel unlabeler a
|
||||
, fromResult' @exprs2 $ hunlabel unlabeler b
|
||||
, fromResult' @exprs3 $ hunlabel unlabeler c
|
||||
, fromResult' @exprs4 $ hunlabel unlabeler d
|
||||
( fromResult @exprs1 $ hunlabel unlabeler a
|
||||
, fromResult @exprs2 $ hunlabel unlabeler b
|
||||
, fromResult @exprs3 $ hunlabel unlabeler c
|
||||
, fromResult @exprs4 $ hunlabel unlabeler d
|
||||
)
|
||||
toResult (a, b, c, d) = HQuartet
|
||||
{ hfst = hlabel labeler $ toResult' @exprs1 a
|
||||
, hsnd = hlabel labeler $ toResult' @exprs2 b
|
||||
, htrd = hlabel labeler $ toResult' @exprs3 c
|
||||
, hfrt = hlabel labeler $ toResult' @exprs4 d
|
||||
{ hfst = hlabel labeler $ toResult @exprs1 a
|
||||
, hsnd = hlabel labeler $ toResult @exprs2 b
|
||||
, htrd = hlabel labeler $ toResult @exprs3 c
|
||||
, hfrt = hlabel labeler $ toResult @exprs4 d
|
||||
}
|
||||
|
||||
|
||||
instance
|
||||
( ToExprs a exprs1
|
||||
, ToExprs b exprs2
|
||||
, ToExprs c exprs3
|
||||
, ToExprs d exprs4
|
||||
, ToExprs e exprs5
|
||||
( ToExprs exprs1 a
|
||||
, ToExprs exprs2 b
|
||||
, ToExprs exprs3 c
|
||||
, ToExprs exprs4 d
|
||||
, ToExprs exprs5 e
|
||||
, x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
|
||||
) => ToExprs (a, b, c, d, e) x
|
||||
) => ToExprs x (a, b, c, d, e)
|
||||
where
|
||||
fromResult (HQuintet a b c d e) =
|
||||
( fromResult' @exprs1 $ hunlabel unlabeler a
|
||||
, fromResult' @exprs2 $ hunlabel unlabeler b
|
||||
, fromResult' @exprs3 $ hunlabel unlabeler c
|
||||
, fromResult' @exprs4 $ hunlabel unlabeler d
|
||||
, fromResult' @exprs5 $ hunlabel unlabeler e
|
||||
( fromResult @exprs1 $ hunlabel unlabeler a
|
||||
, fromResult @exprs2 $ hunlabel unlabeler b
|
||||
, fromResult @exprs3 $ hunlabel unlabeler c
|
||||
, fromResult @exprs4 $ hunlabel unlabeler d
|
||||
, fromResult @exprs5 $ hunlabel unlabeler e
|
||||
)
|
||||
toResult (a, b, c, d, e) = HQuintet
|
||||
{ hfst = hlabel labeler $ toResult' @exprs1 a
|
||||
, hsnd = hlabel labeler $ toResult' @exprs2 b
|
||||
, htrd = hlabel labeler $ toResult' @exprs3 c
|
||||
, hfrt = hlabel labeler $ toResult' @exprs4 d
|
||||
, hfft = hlabel labeler $ toResult' @exprs5 e
|
||||
{ hfst = hlabel labeler $ toResult @exprs1 a
|
||||
, hsnd = hlabel labeler $ toResult @exprs2 b
|
||||
, htrd = hlabel labeler $ toResult @exprs3 c
|
||||
, hfrt = hlabel labeler $ toResult @exprs4 d
|
||||
, hfft = hlabel labeler $ toResult @exprs5 e
|
||||
}
|
||||
|
||||
|
||||
instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
|
||||
ToExprs (t result) x
|
||||
ToExprs x (t result)
|
||||
where
|
||||
fromResult = id
|
||||
toResult = id
|
||||
|
||||
|
||||
instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
|
||||
ToExprs (t result) x
|
||||
ToExprs x (t result)
|
||||
where
|
||||
fromResult = fromColumns
|
||||
toResult = toColumns
|
||||
|
||||
|
||||
instance (KnownSpec spec, x ~ Col Expr spec) =>
|
||||
ToExprs (Col Result spec) x
|
||||
ToExprs x (Col Result spec)
|
||||
where
|
||||
fromResult = fromColumns
|
||||
toResult = toColumns
|
||||
@ -256,19 +248,19 @@ type instance FromExprs (t (Col Expr)) = t (Col Result)
|
||||
-- @sql@, which contains SQL expressions, and the type @haskell@, which
|
||||
-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
|
||||
type Serializable :: Type -> Type -> Constraint
|
||||
class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
|
||||
instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
|
||||
class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
|
||||
instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
|
||||
instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
|
||||
|
||||
|
||||
-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
|
||||
-- capable of lifting single @Expr@s to full tables.
|
||||
lit :: forall exprs a. Serializable exprs a => a -> exprs
|
||||
lit = fromColumns . litHTable . toResult' @exprs
|
||||
lit = fromColumns . litHTable . toResult @exprs
|
||||
|
||||
|
||||
parse :: forall exprs a. Serializable exprs a => Hasql.Row a
|
||||
parse = fromResult' @exprs <$> parseHTable
|
||||
parse = fromResult @exprs <$> parseHTable
|
||||
|
||||
|
||||
type Encodes :: Type -> Type -> Constraint
|
||||
|
Loading…
Reference in New Issue
Block a user