Sketch of HKD-lifting of Generic types

This commit is contained in:
Shane O'Brien 2021-04-16 15:17:39 +01:00
parent 242dc79996
commit 47e7842c0f
No known key found for this signature in database
GPG Key ID: 35A00ED1B695C1A1
8 changed files with 418 additions and 88 deletions

View File

@ -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

View File

@ -5,7 +5,7 @@ let
nixpkgsArgs = haskellNix.nixpkgsArgs;
compiler-nix-name = "ghc901";
compiler-nix-name = "ghc8104";
pkgs = import nixpkgsSrc nixpkgsArgs;

View File

@ -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

View File

@ -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 )

View File

@ -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

View File

@ -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
View 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

View File

@ -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