mirror of
https://github.com/circuithub/rel8.git
synced 2024-09-11 16:05:41 +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
|
-- 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
|
-- 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.
|
-- 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;
|
nixpkgsArgs = haskellNix.nixpkgsArgs;
|
||||||
|
|
||||||
compiler-nix-name = "ghc901";
|
compiler-nix-name = "ghc8104";
|
||||||
|
|
||||||
pkgs = import nixpkgsSrc nixpkgsArgs;
|
pkgs = import nixpkgsSrc nixpkgsArgs;
|
||||||
|
|
||||||
|
@ -17,6 +17,7 @@ library
|
|||||||
, casing
|
, casing
|
||||||
, contravariant
|
, contravariant
|
||||||
, hasql ^>= 1.4.5.1
|
, hasql ^>= 1.4.5.1
|
||||||
|
, higgledy
|
||||||
, opaleye ^>= 0.7.1.0
|
, opaleye ^>= 0.7.1.0
|
||||||
, profunctors
|
, profunctors
|
||||||
, scientific
|
, scientific
|
||||||
@ -93,6 +94,7 @@ library
|
|||||||
Rel8.Schema.Field
|
Rel8.Schema.Field
|
||||||
Rel8.Schema.Generic
|
Rel8.Schema.Generic
|
||||||
Rel8.Schema.Generic.Test
|
Rel8.Schema.Generic.Test
|
||||||
|
Rel8.Schema.HKD
|
||||||
Rel8.Schema.HTable
|
Rel8.Schema.HTable
|
||||||
Rel8.Schema.HTable.Either
|
Rel8.Schema.HTable.Either
|
||||||
Rel8.Schema.HTable.Identity
|
Rel8.Schema.HTable.Identity
|
||||||
|
@ -29,10 +29,12 @@ module Rel8
|
|||||||
, Rel8able, KRel8able
|
, Rel8able, KRel8able
|
||||||
, Column, Field, Necessity( Required, Optional )
|
, Column, Field, Necessity( Required, Optional )
|
||||||
, Default
|
, Default
|
||||||
|
, HEither
|
||||||
, HMaybe
|
, HMaybe
|
||||||
, HList
|
, HList
|
||||||
, HNonEmpty
|
, HNonEmpty
|
||||||
, HThese
|
, HThese
|
||||||
|
, Lift
|
||||||
|
|
||||||
, Table(..)
|
, Table(..)
|
||||||
, AltTable((<|>:))
|
, AltTable((<|>:))
|
||||||
@ -236,6 +238,7 @@ module Rel8
|
|||||||
, ToExprs(..)
|
, ToExprs(..)
|
||||||
, FromExprs
|
, FromExprs
|
||||||
, Result
|
, Result
|
||||||
|
, HKDT(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
@ -275,6 +278,7 @@ import Rel8.Schema.Column
|
|||||||
import Rel8.Schema.Context.Label
|
import Rel8.Schema.Context.Label
|
||||||
import Rel8.Schema.Field
|
import Rel8.Schema.Field
|
||||||
import Rel8.Schema.Generic
|
import Rel8.Schema.Generic
|
||||||
|
import Rel8.Schema.HKD
|
||||||
import Rel8.Schema.HTable
|
import Rel8.Schema.HTable
|
||||||
import Rel8.Schema.Name
|
import Rel8.Schema.Name
|
||||||
import Rel8.Schema.Null hiding ( nullable )
|
import Rel8.Schema.Null hiding ( nullable )
|
||||||
|
@ -11,9 +11,10 @@ module Rel8.Schema.Field
|
|||||||
( Field
|
( Field
|
||||||
, HEither, HList, HMaybe, HNonEmpty, HThese
|
, HEither, HList, HMaybe, HNonEmpty, HThese
|
||||||
, Reify, hreify, hunreify
|
, Reify, hreify, hunreify
|
||||||
, Reifiable
|
, Reifiable(..)
|
||||||
, AField(..)
|
, AField(..)
|
||||||
, AHEither(..), AHList(..), AHMaybe(..), AHNonEmpty(..), AHThese(..)
|
, AHEither(..), AHList(..), AHMaybe(..), AHNonEmpty(..), AHThese(..)
|
||||||
|
, SContext(..)
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -1,8 +1,12 @@
|
|||||||
{-# language DataKinds #-}
|
{-# language DataKinds #-}
|
||||||
{-# language DeriveAnyClass #-}
|
{-# language DeriveAnyClass #-}
|
||||||
{-# language DeriveGeneric #-}
|
{-# language DeriveGeneric #-}
|
||||||
{-# language DerivingStrategies #-}
|
{-# language DerivingVia #-}
|
||||||
{-# language DuplicateRecordFields #-}
|
{-# language DuplicateRecordFields #-}
|
||||||
|
{-# language FlexibleInstances #-}
|
||||||
|
{-# language MultiParamTypeClasses #-}
|
||||||
|
{-# language StandaloneDeriving #-}
|
||||||
|
{-# language TypeFamilies #-}
|
||||||
|
|
||||||
module Rel8.Schema.Generic.Test
|
module Rel8.Schema.Generic.Test
|
||||||
( module Rel8.Schema.Generic.Test
|
( module Rel8.Schema.Generic.Test
|
||||||
@ -13,10 +17,11 @@ where
|
|||||||
import GHC.Generics ( Generic )
|
import GHC.Generics ( Generic )
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
|
-- higgledy
|
||||||
|
import Data.Generic.HKD ( HKD )
|
||||||
|
|
||||||
-- rel8
|
-- rel8
|
||||||
import Rel8.Schema.Column
|
import Rel8
|
||||||
import Rel8.Schema.Field
|
|
||||||
import Rel8.Schema.Generic
|
|
||||||
|
|
||||||
-- text
|
-- text
|
||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
@ -76,3 +81,20 @@ data TableNonEmpty f = TableNonEmpty
|
|||||||
}
|
}
|
||||||
deriving stock Generic
|
deriving stock Generic
|
||||||
deriving anyclass Rel8able
|
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 )
|
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
|
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
|
fromResult :: Columns exprs (Col Result) -> a
|
||||||
toResult :: a -> Columns exprs (Col Result)
|
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
|
fromResult (HType (Result a)) = a
|
||||||
toResult = HType . Result
|
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
|
fromResult (HType (Result a)) = a
|
||||||
toResult = HType . Result
|
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
|
where
|
||||||
fromResult (HType (Result a)) = a
|
fromResult (HType (Result a)) = a
|
||||||
toResult = HType . Result
|
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
|
where
|
||||||
fromResult (HType (Result a)) = a
|
fromResult (HType (Result a)) = a
|
||||||
toResult = HType . Result
|
toResult = HType . Result
|
||||||
|
|
||||||
|
|
||||||
instance (ToExprs a exprs1, ToExprs b exprs2, x ~ EitherTable exprs1 exprs2) =>
|
instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ EitherTable exprs1 exprs2) =>
|
||||||
ToExprs (Either a b) x
|
ToExprs x (Either a b)
|
||||||
where
|
where
|
||||||
fromResult =
|
fromResult =
|
||||||
bimap (fromResult' @exprs1) (fromResult' @exprs2) .
|
bimap (fromResult @exprs1) (fromResult @exprs2) .
|
||||||
fromColumns
|
fromColumns
|
||||||
toResult =
|
toResult =
|
||||||
toColumns .
|
toColumns .
|
||||||
bimap (toResult' @exprs1) (toResult' @exprs2)
|
bimap (toResult @exprs1) (toResult @exprs2)
|
||||||
|
|
||||||
|
|
||||||
instance ToExprs a exprs => ToExprs [a] (ListTable exprs) where
|
instance ToExprs exprs a => ToExprs (ListTable exprs) [a] where
|
||||||
fromResult = fmap (fromResult' @exprs) . fromColumns
|
fromResult = fmap (fromResult @exprs) . fromColumns
|
||||||
toResult = toColumns . fmap (toResult' @exprs)
|
toResult = toColumns . fmap (toResult @exprs)
|
||||||
|
|
||||||
|
|
||||||
instance ToExprs a exprs => ToExprs (Maybe a) (MaybeTable exprs) where
|
instance ToExprs exprs a => ToExprs (MaybeTable exprs) (Maybe a) where
|
||||||
fromResult = fmap (fromResult' @exprs) . fromColumns
|
fromResult = fmap (fromResult @exprs) . fromColumns
|
||||||
toResult = toColumns . fmap (toResult' @exprs)
|
toResult = toColumns . fmap (toResult @exprs)
|
||||||
|
|
||||||
|
|
||||||
instance ToExprs a exprs => ToExprs (NonEmpty a) (NonEmptyTable exprs)
|
instance ToExprs exprs a => ToExprs (NonEmptyTable exprs) (NonEmpty a)
|
||||||
where
|
where
|
||||||
fromResult = fmap (fromResult' @exprs) . fromColumns
|
fromResult = fmap (fromResult @exprs) . fromColumns
|
||||||
toResult = toColumns . fmap (toResult' @exprs)
|
toResult = toColumns . fmap (toResult @exprs)
|
||||||
|
|
||||||
|
|
||||||
instance (ToExprs a exprs1, ToExprs b exprs2, x ~ TheseTable exprs1 exprs2) =>
|
instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ TheseTable exprs1 exprs2) =>
|
||||||
ToExprs (These a b) x
|
ToExprs x (These a b)
|
||||||
where
|
where
|
||||||
fromResult =
|
fromResult =
|
||||||
bimap (fromResult' @exprs1) (fromResult' @exprs2) .
|
bimap (fromResult @exprs1) (fromResult @exprs2) .
|
||||||
fromColumns
|
fromColumns
|
||||||
toResult =
|
toResult =
|
||||||
toColumns .
|
toColumns .
|
||||||
bimap (toResult' @exprs1) (toResult' @exprs2)
|
bimap (toResult @exprs1) (toResult @exprs2)
|
||||||
|
|
||||||
|
|
||||||
instance (ToExprs a exprs1, ToExprs b exprs2, x ~ (exprs1, exprs2)) =>
|
instance (ToExprs exprs1 a, ToExprs exprs2 b, x ~ (exprs1, exprs2)) =>
|
||||||
ToExprs (a, b) x
|
ToExprs x (a, b)
|
||||||
where
|
where
|
||||||
fromResult (HPair a b) =
|
fromResult (HPair a b) =
|
||||||
( fromResult' @exprs1 $ hunlabel unlabeler a
|
( fromResult @exprs1 $ hunlabel unlabeler a
|
||||||
, fromResult' @exprs2 $ hunlabel unlabeler b
|
, fromResult @exprs2 $ hunlabel unlabeler b
|
||||||
)
|
)
|
||||||
toResult (a, b) = HPair
|
toResult (a, b) = HPair
|
||||||
{ hfst = hlabel labeler $ toResult' @exprs1 a
|
{ hfst = hlabel labeler $ toResult @exprs1 a
|
||||||
, hsnd = hlabel labeler $ toResult' @exprs2 b
|
, hsnd = hlabel labeler $ toResult @exprs2 b
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
instance
|
instance
|
||||||
( ToExprs a exprs1
|
( ToExprs exprs1 a
|
||||||
, ToExprs b exprs2
|
, ToExprs exprs2 b
|
||||||
, ToExprs c exprs3
|
, ToExprs exprs3 c
|
||||||
, x ~ (exprs1, exprs2, exprs3)
|
, x ~ (exprs1, exprs2, exprs3)
|
||||||
) => ToExprs (a, b, c) x
|
) => ToExprs x (a, b, c)
|
||||||
where
|
where
|
||||||
fromResult (HTrio a b c) =
|
fromResult (HTrio a b c) =
|
||||||
( fromResult' @exprs1 $ hunlabel unlabeler a
|
( fromResult @exprs1 $ hunlabel unlabeler a
|
||||||
, fromResult' @exprs2 $ hunlabel unlabeler b
|
, fromResult @exprs2 $ hunlabel unlabeler b
|
||||||
, fromResult' @exprs3 $ hunlabel unlabeler c
|
, fromResult @exprs3 $ hunlabel unlabeler c
|
||||||
)
|
)
|
||||||
toResult (a, b, c) = HTrio
|
toResult (a, b, c) = HTrio
|
||||||
{ hfst = hlabel labeler $ toResult' @exprs1 a
|
{ hfst = hlabel labeler $ toResult @exprs1 a
|
||||||
, hsnd = hlabel labeler $ toResult' @exprs2 b
|
, hsnd = hlabel labeler $ toResult @exprs2 b
|
||||||
, htrd = hlabel labeler $ toResult' @exprs3 c
|
, htrd = hlabel labeler $ toResult @exprs3 c
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
instance
|
instance
|
||||||
( ToExprs a exprs1
|
( ToExprs exprs1 a
|
||||||
, ToExprs b exprs2
|
, ToExprs exprs2 b
|
||||||
, ToExprs c exprs3
|
, ToExprs exprs3 c
|
||||||
, ToExprs d exprs4
|
, ToExprs exprs4 d
|
||||||
, x ~ (exprs1, exprs2, exprs3, exprs4)
|
, x ~ (exprs1, exprs2, exprs3, exprs4)
|
||||||
) => ToExprs (a, b, c, d) x
|
) => ToExprs x (a, b, c, d)
|
||||||
where
|
where
|
||||||
fromResult (HQuartet a b c d) =
|
fromResult (HQuartet a b c d) =
|
||||||
( fromResult' @exprs1 $ hunlabel unlabeler a
|
( fromResult @exprs1 $ hunlabel unlabeler a
|
||||||
, fromResult' @exprs2 $ hunlabel unlabeler b
|
, fromResult @exprs2 $ hunlabel unlabeler b
|
||||||
, fromResult' @exprs3 $ hunlabel unlabeler c
|
, fromResult @exprs3 $ hunlabel unlabeler c
|
||||||
, fromResult' @exprs4 $ hunlabel unlabeler d
|
, fromResult @exprs4 $ hunlabel unlabeler d
|
||||||
)
|
)
|
||||||
toResult (a, b, c, d) = HQuartet
|
toResult (a, b, c, d) = HQuartet
|
||||||
{ hfst = hlabel labeler $ toResult' @exprs1 a
|
{ hfst = hlabel labeler $ toResult @exprs1 a
|
||||||
, hsnd = hlabel labeler $ toResult' @exprs2 b
|
, hsnd = hlabel labeler $ toResult @exprs2 b
|
||||||
, htrd = hlabel labeler $ toResult' @exprs3 c
|
, htrd = hlabel labeler $ toResult @exprs3 c
|
||||||
, hfrt = hlabel labeler $ toResult' @exprs4 d
|
, hfrt = hlabel labeler $ toResult @exprs4 d
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
instance
|
instance
|
||||||
( ToExprs a exprs1
|
( ToExprs exprs1 a
|
||||||
, ToExprs b exprs2
|
, ToExprs exprs2 b
|
||||||
, ToExprs c exprs3
|
, ToExprs exprs3 c
|
||||||
, ToExprs d exprs4
|
, ToExprs exprs4 d
|
||||||
, ToExprs e exprs5
|
, ToExprs exprs5 e
|
||||||
, x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
|
, x ~ (exprs1, exprs2, exprs3, exprs4, exprs5)
|
||||||
) => ToExprs (a, b, c, d, e) x
|
) => ToExprs x (a, b, c, d, e)
|
||||||
where
|
where
|
||||||
fromResult (HQuintet a b c d e) =
|
fromResult (HQuintet a b c d e) =
|
||||||
( fromResult' @exprs1 $ hunlabel unlabeler a
|
( fromResult @exprs1 $ hunlabel unlabeler a
|
||||||
, fromResult' @exprs2 $ hunlabel unlabeler b
|
, fromResult @exprs2 $ hunlabel unlabeler b
|
||||||
, fromResult' @exprs3 $ hunlabel unlabeler c
|
, fromResult @exprs3 $ hunlabel unlabeler c
|
||||||
, fromResult' @exprs4 $ hunlabel unlabeler d
|
, fromResult @exprs4 $ hunlabel unlabeler d
|
||||||
, fromResult' @exprs5 $ hunlabel unlabeler e
|
, fromResult @exprs5 $ hunlabel unlabeler e
|
||||||
)
|
)
|
||||||
toResult (a, b, c, d, e) = HQuintet
|
toResult (a, b, c, d, e) = HQuintet
|
||||||
{ hfst = hlabel labeler $ toResult' @exprs1 a
|
{ hfst = hlabel labeler $ toResult @exprs1 a
|
||||||
, hsnd = hlabel labeler $ toResult' @exprs2 b
|
, hsnd = hlabel labeler $ toResult @exprs2 b
|
||||||
, htrd = hlabel labeler $ toResult' @exprs3 c
|
, htrd = hlabel labeler $ toResult @exprs3 c
|
||||||
, hfrt = hlabel labeler $ toResult' @exprs4 d
|
, hfrt = hlabel labeler $ toResult @exprs4 d
|
||||||
, hfft = hlabel labeler $ toResult' @exprs5 e
|
, hfft = hlabel labeler $ toResult @exprs5 e
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
|
instance (HTable t, result ~ Col Result, x ~ t (Col Expr)) =>
|
||||||
ToExprs (t result) x
|
ToExprs x (t result)
|
||||||
where
|
where
|
||||||
fromResult = id
|
fromResult = id
|
||||||
toResult = id
|
toResult = id
|
||||||
|
|
||||||
|
|
||||||
instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
|
instance (Recontextualize Result Expr (t Result) (t Expr), result ~ Result, x ~ t Expr) =>
|
||||||
ToExprs (t result) x
|
ToExprs x (t result)
|
||||||
where
|
where
|
||||||
fromResult = fromColumns
|
fromResult = fromColumns
|
||||||
toResult = toColumns
|
toResult = toColumns
|
||||||
|
|
||||||
|
|
||||||
instance (KnownSpec spec, x ~ Col Expr spec) =>
|
instance (KnownSpec spec, x ~ Col Expr spec) =>
|
||||||
ToExprs (Col Result spec) x
|
ToExprs x (Col Result spec)
|
||||||
where
|
where
|
||||||
fromResult = fromColumns
|
fromResult = fromColumns
|
||||||
toResult = toColumns
|
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
|
-- @sql@, which contains SQL expressions, and the type @haskell@, which
|
||||||
-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
|
-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
|
||||||
type Serializable :: Type -> Type -> Constraint
|
type Serializable :: Type -> Type -> Constraint
|
||||||
class (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
|
class (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a | exprs -> a
|
||||||
instance (ToExprs a exprs, a ~ FromExprs exprs) => Serializable exprs a
|
instance (ToExprs exprs a, a ~ FromExprs exprs) => Serializable exprs a
|
||||||
instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
|
instance {-# OVERLAPPING #-} Sql DBType a => Serializable (Expr a) a
|
||||||
|
|
||||||
|
|
||||||
-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
|
-- | Use @lit@ to turn literal Haskell values into expressions. @lit@ is
|
||||||
-- capable of lifting single @Expr@s to full tables.
|
-- capable of lifting single @Expr@s to full tables.
|
||||||
lit :: forall exprs a. Serializable exprs a => a -> exprs
|
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 :: forall exprs a. Serializable exprs a => Hasql.Row a
|
||||||
parse = fromResult' @exprs <$> parseHTable
|
parse = fromResult @exprs <$> parseHTable
|
||||||
|
|
||||||
|
|
||||||
type Encodes :: Type -> Type -> Constraint
|
type Encodes :: Type -> Type -> Constraint
|
||||||
|
Loading…
Reference in New Issue
Block a user