From 47e7842c0f8eb7d8efe87a60000c7bfd875d44a5 Mon Sep 17 00:00:00 2001 From: Shane O'Brien Date: Fri, 16 Apr 2021 15:17:39 +0100 Subject: [PATCH] Sketch of HKD-lifting of Generic types --- cabal.project.haskell-nix | 6 + default.nix | 2 +- rel8.cabal | 2 + src/Rel8.hs | 4 + src/Rel8/Schema/Field.hs | 3 +- src/Rel8/Schema/Generic/Test.hs | 30 +++- src/Rel8/Schema/HKD.hs | 303 ++++++++++++++++++++++++++++++++ src/Rel8/Table/Serialize.hs | 156 ++++++++-------- 8 files changed, 418 insertions(+), 88 deletions(-) create mode 100644 src/Rel8/Schema/HKD.hs diff --git a/cabal.project.haskell-nix b/cabal.project.haskell-nix index 49a9b68..885b3bf 100644 --- a/cabal.project.haskell-nix +++ b/cabal.project.haskell-nix @@ -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 diff --git a/default.nix b/default.nix index 1f7acac..fe1119e 100644 --- a/default.nix +++ b/default.nix @@ -5,7 +5,7 @@ let nixpkgsArgs = haskellNix.nixpkgsArgs; - compiler-nix-name = "ghc901"; + compiler-nix-name = "ghc8104"; pkgs = import nixpkgsSrc nixpkgsArgs; diff --git a/rel8.cabal b/rel8.cabal index 3e49abe..f464735 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -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 diff --git a/src/Rel8.hs b/src/Rel8.hs index 378682c..e1a348c 100644 --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -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 ) diff --git a/src/Rel8/Schema/Field.hs b/src/Rel8/Schema/Field.hs index 05cda3d..b5d94b8 100644 --- a/src/Rel8/Schema/Field.hs +++ b/src/Rel8/Schema/Field.hs @@ -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 diff --git a/src/Rel8/Schema/Generic/Test.hs b/src/Rel8/Schema/Generic/Test.hs index 8629f4f..073065b 100644 --- a/src/Rel8/Schema/Generic/Test.hs +++ b/src/Rel8/Schema/Generic/Test.hs @@ -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 diff --git a/src/Rel8/Schema/HKD.hs b/src/Rel8/Schema/HKD.hs new file mode 100644 index 0000000..80817f8 --- /dev/null +++ b/src/Rel8/Schema/HKD.hs @@ -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 diff --git a/src/Rel8/Table/Serialize.hs b/src/Rel8/Table/Serialize.hs index 82f1d2e..7550e4b 100644 --- a/src/Rel8/Table/Serialize.hs +++ b/src/Rel8/Table/Serialize.hs @@ -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