mirror of
https://github.com/circuithub/rel8.git
synced 2024-08-17 20:00:23 +03:00
Add Encodable class for specifying what lit
should do for a given type
This means that users defining new `DBType`s will have to additionally derive `Encodable` (but a simple `deriving Encodable` will suffice). It also opens up the possibility of users defining non-`DBType`s that are `lit`able (and `select`able). For example, the `HKDT` helper makes allows arbitrary products of `DBType`s to be `lit`ed via `higgled`'s `HKD`: ```haskell data S3Object = S3Object { bucketName :: Text , objectKey :: Text } deriving stock Generic deriving Encodable via HKDT S3Object ``` With the above loaded into GHCi: ``` >>> :t lit (S3Object mempty mempty) lit (S3Object mempty mempty) :: HKD S3Object Expr ``` The implementation is extensible, allowing for the possibility of other "strategies" (in addition to `DBType` and `HKD`) in the future.
This commit is contained in:
parent
9903886bf7
commit
9105dbf67f
@ -130,6 +130,7 @@ library
|
||||
Rel8.Schema.Null
|
||||
Rel8.Schema.Reify
|
||||
Rel8.Schema.Result
|
||||
Rel8.Schema.Serialize
|
||||
Rel8.Schema.Spec
|
||||
Rel8.Schema.Spec.ConstrainDBType
|
||||
Rel8.Schema.Spec.ConstrainType
|
||||
@ -179,6 +180,7 @@ library
|
||||
Rel8.Type.Ord
|
||||
Rel8.Type.ReadShow
|
||||
Rel8.Type.Semigroup
|
||||
Rel8.Type.Serialize
|
||||
Rel8.Type.String
|
||||
Rel8.Type.Sum
|
||||
Rel8.Type.Tag
|
||||
|
@ -274,6 +274,7 @@ module Rel8
|
||||
-- TODO
|
||||
-- These need organizing, but are reachable from Rel8's documentation so we
|
||||
-- do need to export and document them.
|
||||
, Encodable
|
||||
, Nullable
|
||||
, NotNull
|
||||
, HTable
|
||||
@ -332,6 +333,7 @@ import Rel8.Schema.HTable
|
||||
import Rel8.Schema.Name
|
||||
import Rel8.Schema.Null hiding ( nullable )
|
||||
import Rel8.Schema.Result ( Result )
|
||||
import Rel8.Schema.Serialize
|
||||
import Rel8.Schema.Table
|
||||
import Rel8.Statement.Delete
|
||||
import Rel8.Statement.Insert
|
||||
|
@ -3,10 +3,6 @@
|
||||
{-# language DeriveGeneric #-}
|
||||
{-# language DerivingVia #-}
|
||||
{-# language DuplicateRecordFields #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language StandaloneDeriving #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
|
||||
{-# options_ghc -O0 #-}
|
||||
@ -96,26 +92,12 @@ data S3Object = S3Object
|
||||
, objectKey :: Text
|
||||
}
|
||||
deriving stock Generic
|
||||
|
||||
|
||||
deriving via HKDT S3Object
|
||||
instance Table Result S3Object
|
||||
|
||||
|
||||
deriving via HKDT S3Object
|
||||
instance x ~ HKD S3Object Expr => ToExprs x S3Object
|
||||
deriving Encodable via HKDT S3Object
|
||||
|
||||
|
||||
data HKDSum = HKDSumA Text | HKDSumB Bool Char | HKDSumC
|
||||
deriving stock Generic
|
||||
|
||||
|
||||
deriving via HKDT HKDSum
|
||||
instance Table Result HKDSum
|
||||
|
||||
|
||||
deriving via HKDT HKDSum
|
||||
instance x ~ HKD HKDSum Expr => ToExprs x HKDSum
|
||||
deriving Encodable via HKDT HKDSum
|
||||
|
||||
|
||||
data HKDTest f = HKDTest
|
||||
|
@ -10,6 +10,7 @@
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language QuantifiedConstraints #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language RecordWildCards #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeFamilies #-}
|
||||
@ -56,14 +57,12 @@ type instance Eval (Nullify ('Spec labels necessity a)) =
|
||||
|
||||
instance MapSpec Nullify where
|
||||
mapInfo = \case
|
||||
SSpec{labels, necessity, info, nullity} -> SSpec
|
||||
{ labels
|
||||
, necessity
|
||||
, info
|
||||
, nullity = case nullity of
|
||||
SSpec{labels, necessity, info, nullity, ..} -> SSpec
|
||||
{ nullity = case nullity of
|
||||
Null -> Null
|
||||
NotNull -> Null
|
||||
}
|
||||
, ..
|
||||
}
|
||||
|
||||
|
||||
hnulls :: HTable t
|
||||
|
@ -41,6 +41,7 @@ import Rel8.Schema.HTable
|
||||
, hfield, htabulate, htabulateA, hspecs
|
||||
)
|
||||
import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) )
|
||||
import Rel8.Schema.Serialize ( Exprable )
|
||||
import Rel8.Schema.Spec ( Spec( Spec ), SSpec(..) )
|
||||
import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
|
||||
import Rel8.Type.Information ( TypeInformation )
|
||||
@ -53,6 +54,7 @@ import GHC.Generics (Generic)
|
||||
|
||||
|
||||
class Vector list where
|
||||
listExprable :: proxy a -> Dict Exprable (list a)
|
||||
listNotNull :: proxy a -> Dict NotNull (list a)
|
||||
vectorTypeInformation :: ()
|
||||
=> Nullity a
|
||||
@ -61,11 +63,13 @@ class Vector list where
|
||||
|
||||
|
||||
instance Vector [] where
|
||||
listExprable _ = Dict
|
||||
listNotNull _ = Dict
|
||||
vectorTypeInformation = listTypeInformation
|
||||
|
||||
|
||||
instance Vector NonEmpty where
|
||||
listExprable _ = Dict
|
||||
listNotNull _ = Dict
|
||||
vectorTypeInformation = nonEmptyTypeInformation
|
||||
|
||||
@ -88,6 +92,7 @@ instance Vector list => MapSpec (Vectorize list) where
|
||||
Dict -> SSpec
|
||||
{ necessity = SRequired
|
||||
, nullity = NotNull
|
||||
, exprable = listExprable @list nullity
|
||||
, info = vectorTypeInformation nullity info
|
||||
, ..
|
||||
}
|
||||
|
@ -24,6 +24,9 @@ where
|
||||
import Data.Kind ( Constraint, Type )
|
||||
import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.Serialize ( Exprable )
|
||||
|
||||
|
||||
type IsMaybe :: Type -> Bool
|
||||
type family IsMaybe a where
|
||||
@ -106,5 +109,5 @@ nullable = nullable'
|
||||
-- supports equality, and @a@ can either be exactly an @a@, or it could also be
|
||||
-- @Maybe a@.
|
||||
type Sql :: (Type -> Constraint) -> Type -> Constraint
|
||||
class (constraint (Unnullify a), Nullable a) => Sql constraint a
|
||||
instance (constraint (Unnullify a), Nullable a) => Sql constraint a
|
||||
class (constraint (Unnullify a), Exprable a, Nullable a) => Sql constraint a
|
||||
instance (constraint (Unnullify a), Exprable a, Nullable a) => Sql constraint a
|
||||
|
88
src/Rel8/Schema/Serialize.hs
Normal file
88
src/Rel8/Schema/Serialize.hs
Normal file
@ -0,0 +1,88 @@
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.Schema.Serialize
|
||||
( Encodable( Encoding )
|
||||
, Constraints
|
||||
, Exprable
|
||||
)
|
||||
where
|
||||
|
||||
-- aeson
|
||||
import Data.Aeson ( Value )
|
||||
|
||||
-- base
|
||||
import Data.Int ( Int16, Int32, Int64 )
|
||||
import Data.List.NonEmpty ( NonEmpty )
|
||||
import Data.Kind ( Constraint, Type )
|
||||
import Data.Proxy ( Proxy )
|
||||
import Prelude
|
||||
|
||||
-- bytestring
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString.Lazy as Lazy ( ByteString )
|
||||
|
||||
-- case-insensitive
|
||||
import Data.CaseInsensitive ( CI )
|
||||
|
||||
-- rel8
|
||||
import {-# SOURCE #-} Rel8.Expr ( Expr )
|
||||
|
||||
-- scientific
|
||||
import Data.Scientific ( Scientific )
|
||||
|
||||
-- text
|
||||
import Data.Text ( Text )
|
||||
import qualified Data.Text.Lazy as Lazy ( Text )
|
||||
|
||||
-- time
|
||||
import Data.Time.Calendar ( Day )
|
||||
import Data.Time.Clock ( UTCTime )
|
||||
import Data.Time.LocalTime ( CalendarDiffTime, LocalTime, TimeOfDay )
|
||||
|
||||
-- uuid
|
||||
import Data.UUID ( UUID )
|
||||
|
||||
|
||||
type Constraints :: Type -> Type -> Constraint
|
||||
type family Constraints encoding a
|
||||
type instance Constraints (Proxy Expr) _a = ()
|
||||
|
||||
|
||||
type Encodable :: Type -> Constraint
|
||||
class Constraints (Encoding a) a => Encodable a where
|
||||
type Encoding a :: Type
|
||||
type Encoding _a = Proxy (Expr :: Type -> Type)
|
||||
|
||||
|
||||
instance Encodable Bool
|
||||
instance Encodable Char
|
||||
instance Encodable Int16
|
||||
instance Encodable Int32
|
||||
instance Encodable Int64
|
||||
instance Encodable Float
|
||||
instance Encodable Double
|
||||
instance Encodable Scientific
|
||||
instance Encodable UTCTime
|
||||
instance Encodable Day
|
||||
instance Encodable LocalTime
|
||||
instance Encodable TimeOfDay
|
||||
instance Encodable CalendarDiffTime
|
||||
instance Encodable Text
|
||||
instance Encodable Lazy.Text
|
||||
instance Encodable (CI Text)
|
||||
instance Encodable (CI Lazy.Text)
|
||||
instance Encodable ByteString
|
||||
instance Encodable Lazy.ByteString
|
||||
instance Encodable UUID
|
||||
instance Encodable Value
|
||||
instance Encodable [a]
|
||||
instance Encodable (NonEmpty a)
|
||||
instance Encodable (Maybe a)
|
||||
|
||||
|
||||
class (Encodable a, Encoding a ~ Proxy (Expr :: Type -> Type)) => Exprable a
|
||||
instance (Encodable a, Encoding a ~ Proxy (Expr :: Type -> Type)) => Exprable a
|
@ -6,7 +6,7 @@
|
||||
|
||||
module Rel8.Schema.Spec
|
||||
( Spec( Spec )
|
||||
, SSpec( SSpec, labels, necessity, info, nullity )
|
||||
, SSpec( SSpec, labels, necessity, info, nullity, exprable )
|
||||
, KnownSpec( specSing )
|
||||
)
|
||||
where
|
||||
@ -22,7 +22,9 @@ import Rel8.Kind.Necessity
|
||||
, SNecessity
|
||||
, KnownNecessity, necessitySing
|
||||
)
|
||||
import Rel8.Schema.Dict ( Dict( Dict ) )
|
||||
import Rel8.Schema.Null ( Nullity, Sql, Unnullify, nullable )
|
||||
import Rel8.Schema.Serialize ( Exprable )
|
||||
import Rel8.Type ( DBType, typeInformation )
|
||||
import Rel8.Type.Information ( TypeInformation )
|
||||
|
||||
@ -38,6 +40,7 @@ data SSpec spec where
|
||||
, necessity :: SNecessity necessity
|
||||
, info :: TypeInformation (Unnullify a)
|
||||
, nullity :: Nullity a
|
||||
, exprable :: Dict Exprable (Unnullify a)
|
||||
}
|
||||
-> SSpec ('Spec labels necessity a)
|
||||
|
||||
@ -59,4 +62,5 @@ instance
|
||||
, necessity = necessitySing
|
||||
, info = typeInformation
|
||||
, nullity = nullable
|
||||
, exprable = Dict
|
||||
}
|
||||
|
@ -24,9 +24,10 @@ import Rel8.Schema.Dict ( Dict( Dict ) )
|
||||
import Rel8.Schema.Null
|
||||
( Nullify, Unnullify
|
||||
, Nullity( Null, NotNull )
|
||||
, Sql, nullable
|
||||
, Nullable, Sql, nullable
|
||||
)
|
||||
import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec, nullity ) )
|
||||
import Rel8.Schema.Serialize ( Exprable )
|
||||
import Rel8.Schema.Spec ( Spec( Spec ), SSpec( SSpec, exprable, nullity ) )
|
||||
|
||||
|
||||
type ConstrainDBType :: (Type -> Constraint) -> Spec -> Constraint
|
||||
@ -44,13 +45,16 @@ instance
|
||||
|
||||
|
||||
dbTypeNullity :: Dict (ConstrainDBType c) ('Spec l n a) -> Nullity a
|
||||
dbTypeNullity = step2 . step1
|
||||
dbTypeNullity = step3 . step2 . step1
|
||||
where
|
||||
step1 :: Dict (ConstrainDBType c) ('Spec l n a) -> Dict (Sql c) a
|
||||
step1 Dict = Dict
|
||||
|
||||
step2 :: Dict (Sql c) a -> Nullity a
|
||||
step2 Dict = nullable
|
||||
step2 :: Dict (Sql c) a -> Dict Nullable a
|
||||
step2 Dict = Dict
|
||||
|
||||
step3 :: Dict Nullable a -> Nullity a
|
||||
step3 Dict = nullable
|
||||
|
||||
|
||||
dbTypeDict :: Dict (ConstrainDBType c) ('Spec l n a) -> Dict c (Unnullify a)
|
||||
@ -63,9 +67,9 @@ dbTypeDict = step2 . step1
|
||||
step2 Dict = Dict
|
||||
|
||||
|
||||
fromNullityDict :: Nullity a -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec l n a)
|
||||
fromNullityDict Null Dict = Dict
|
||||
fromNullityDict NotNull Dict = Dict
|
||||
fromNullityDict :: Nullity a -> Dict Exprable (Unnullify a) -> Dict c (Unnullify a) -> Dict (ConstrainDBType c) ('Spec l n a)
|
||||
fromNullityDict Null Dict Dict = Dict
|
||||
fromNullityDict NotNull Dict Dict = Dict
|
||||
|
||||
|
||||
nullifier :: ()
|
||||
@ -82,8 +86,8 @@ unnullifier :: ()
|
||||
=> SSpec ('Spec labels necessity a)
|
||||
-> Dict (ConstrainDBType c) ('Spec labels necessity (Nullify a))
|
||||
-> Dict (ConstrainDBType c) ('Spec labels necessity a)
|
||||
unnullifier SSpec {nullity} dict = case dbTypeDict dict of
|
||||
unnullifier SSpec {exprable, nullity} dict = case dbTypeDict dict of
|
||||
Dict -> case nullity of
|
||||
Null -> Dict
|
||||
NotNull -> case dbTypeNullity dict of
|
||||
Null -> fromNullityDict nullity Dict
|
||||
Null -> fromNullityDict nullity exprable Dict
|
||||
|
@ -1,7 +1,9 @@
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language DerivingStrategies #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GeneralizedNewtypeDeriving #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
@ -70,12 +72,13 @@ import Rel8.Schema.Insert ( Insert )
|
||||
import Rel8.Schema.Name ( Name )
|
||||
import Rel8.Schema.Reify ( Col( Reify ), Reify, hreify, hunreify, notReify )
|
||||
import Rel8.Schema.Result ( Result )
|
||||
import Rel8.Schema.Serialize ( Encodable, Encoding, Constraints )
|
||||
import Rel8.Table
|
||||
( Table, Columns, Context, Unreify
|
||||
, fromColumns, toColumns, reify, unreify
|
||||
, TTable, TColumns, TUnreify
|
||||
)
|
||||
import Rel8.Table.Serialize ( ToExprs, fromResult, toResult )
|
||||
import Rel8.Type.Serialize ( Strategy, ExprsFor, encode, decode )
|
||||
|
||||
|
||||
type GColumnsHKD :: Type -> K.HTable
|
||||
@ -142,6 +145,7 @@ type HKDT :: Type -> Type
|
||||
newtype HKDT a = HKDT
|
||||
{ unHKDT :: a
|
||||
}
|
||||
deriving newtype Generic
|
||||
|
||||
|
||||
instance HKDable a => Table Result (HKDT a) where
|
||||
@ -155,16 +159,18 @@ instance HKDable a => Table Result (HKDT a) where
|
||||
unreify = notReify
|
||||
|
||||
|
||||
instance
|
||||
( Table Expr (HKD a Expr)
|
||||
, Columns (HKD a Expr) ~ GColumns (HKD a)
|
||||
, HKDable a
|
||||
, x ~ HKD a Expr
|
||||
)
|
||||
=> ToExprs x (HKDT a)
|
||||
where
|
||||
toResult = (\(HKD a) -> a) . toHKD . (\(HKDT a) -> a)
|
||||
fromResult = HKDT . fromHKD . HKD
|
||||
instance HKDable (HKDT a) => Encodable (HKDT a) where
|
||||
type Encoding (HKDT a) = Proxy HKD
|
||||
|
||||
|
||||
instance Strategy (Proxy HKD) where
|
||||
type ExprsFor (Proxy HKD) a = HKD a Expr
|
||||
|
||||
encode = (\(HKD a) -> a) . toHKD
|
||||
decode = fromHKD . HKD
|
||||
|
||||
|
||||
type instance Constraints (Proxy HKD) a = HKDable a
|
||||
|
||||
|
||||
fromHKD :: HKDable a => HKD a Result -> a
|
||||
@ -193,6 +199,8 @@ class
|
||||
, GMappable Top (Rep a)
|
||||
, GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))
|
||||
, GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a)
|
||||
, Table Expr (HKD a Expr)
|
||||
, Columns (HKD a Expr) ~ GColumns (HKD a)
|
||||
)
|
||||
=> HKDable a
|
||||
instance
|
||||
@ -205,6 +213,8 @@ instance
|
||||
, GMappable Top (Rep a)
|
||||
, GMappable (TTable (Reify Result)) (GMap (TColumn (Reify Result)) (Rep a))
|
||||
, GMap TUnreify (GMap (TColumn (Reify Result)) (Rep a)) ~ GMap (TColumn Result) (Rep a)
|
||||
, Table Expr (HKD a Expr)
|
||||
, Columns (HKD a Expr) ~ GColumns (HKD a)
|
||||
)
|
||||
=> HKDable a
|
||||
|
||||
|
@ -41,11 +41,13 @@ import Rel8.Generic.Table
|
||||
import Rel8.Kind.Algebra ( KnownAlgebra )
|
||||
import Rel8.Schema.HTable ( HTable, htabulate, htabulateA, hfield, hspecs )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity( HType ) )
|
||||
import Rel8.Schema.Null ( NotNull, Sql )
|
||||
import Rel8.Schema.Null ( Sql )
|
||||
import Rel8.Schema.Result ( Col( R ), Result )
|
||||
import Rel8.Schema.Serialize ( Encoding, Encodable )
|
||||
import Rel8.Schema.Spec ( SSpec(..), KnownSpec )
|
||||
import Rel8.Table ( Table, Columns, fromColumns, toColumns, TColumns )
|
||||
import Rel8.Type ( DBType )
|
||||
import Rel8.Type.Serialize ( Strategy, ExprsFor, encode, decode )
|
||||
|
||||
-- semigroupoids
|
||||
import Data.Functor.Apply ( WrappedApplicative(..) )
|
||||
@ -95,9 +97,17 @@ data TToExprs :: Type -> Type -> Exp Constraint
|
||||
type instance Eval (TToExprs exprs a) = ToExprs exprs a
|
||||
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (Sql DBType a, x ~ Expr a) => ToExprs x a where
|
||||
fromResult (HType (R a)) = a
|
||||
toResult = HType . R
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
( Table Expr x
|
||||
, Encodable a
|
||||
, encoding ~ Encoding a
|
||||
, Strategy encoding
|
||||
, x ~ ExprsFor encoding a
|
||||
)
|
||||
=> ToExprs x a
|
||||
where
|
||||
fromResult = decode @encoding @a
|
||||
toResult = encode @encoding @a
|
||||
|
||||
|
||||
instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
|
||||
@ -105,14 +115,12 @@ instance (Sql DBType a, x ~ [a]) => ToExprs (Expr x) [a] where
|
||||
toResult = HType . R
|
||||
|
||||
|
||||
instance (Sql DBType a, NotNull a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a)
|
||||
where
|
||||
instance (DBType a, x ~ Maybe a) => ToExprs (Expr x) (Maybe a) where
|
||||
fromResult (HType (R a)) = a
|
||||
toResult = HType . R
|
||||
|
||||
|
||||
instance (Sql DBType a, NotNull a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a)
|
||||
where
|
||||
instance (Sql DBType a, x ~ NonEmpty a) => ToExprs (Expr x) (NonEmpty a) where
|
||||
fromResult (HType (R a)) = a
|
||||
toResult = HType . R
|
||||
|
||||
|
@ -1,8 +1,9 @@
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language MonoLocalBinds #-}
|
||||
{-# language MultiWayIf #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.Type
|
||||
( DBType (typeInformation)
|
||||
@ -37,6 +38,7 @@ import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.Null ( NotNull, Sql, nullable )
|
||||
import Rel8.Schema.Serialize ( Exprable )
|
||||
import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
|
||||
import Rel8.Type.Information ( TypeInformation(..), mapTypeInformation )
|
||||
|
||||
@ -74,7 +76,7 @@ import qualified Data.UUID as UUID
|
||||
-- types, such as types defined in PostgreSQL extensions, or custom domain
|
||||
-- types.
|
||||
type DBType :: Type -> Constraint
|
||||
class NotNull a => DBType a where
|
||||
class (NotNull a, Exprable a) => DBType a where
|
||||
typeInformation :: TypeInformation a
|
||||
|
||||
|
||||
|
@ -36,6 +36,7 @@ import Rel8.Schema.HTable ( hfield, hspecs, htabulate, htabulateA )
|
||||
import Rel8.Schema.Name ( Col( N ), Name( Name ) )
|
||||
import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
|
||||
import Rel8.Schema.Result ( Col( R ), Result )
|
||||
import Rel8.Schema.Serialize ( Encodable )
|
||||
import Rel8.Schema.Spec ( SSpec( SSpec, nullity, info ) )
|
||||
import Rel8.Table ( Table, fromColumns, toColumns )
|
||||
import Rel8.Table.Eq ( EqTable )
|
||||
@ -65,6 +66,9 @@ newtype Composite a = Composite
|
||||
}
|
||||
|
||||
|
||||
instance Encodable (Composite a)
|
||||
|
||||
|
||||
instance DBComposite a => DBType (Composite a) where
|
||||
typeInformation = TypeInformation
|
||||
{ decode = Hasql.composite (Composite . fromHKD <$> decoder)
|
||||
|
@ -10,6 +10,7 @@
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.Type.Enum
|
||||
( Enum( Enum )
|
||||
@ -38,6 +39,7 @@ import qualified Hasql.Decoders as Hasql
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.Serialize ( Encodable )
|
||||
import Rel8.Type ( DBType, typeInformation )
|
||||
import Rel8.Type.Eq ( DBEq )
|
||||
import Rel8.Type.Information ( TypeInformation(..) )
|
||||
@ -63,6 +65,9 @@ newtype Enum a = Enum
|
||||
}
|
||||
|
||||
|
||||
instance Encodable (Enum a)
|
||||
|
||||
|
||||
instance DBEnum a => DBType (Enum a) where
|
||||
typeInformation = TypeInformation
|
||||
{ decode =
|
||||
|
@ -4,6 +4,7 @@
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.Type.Eq
|
||||
( DBEq
|
||||
|
@ -12,6 +12,7 @@ import Prelude
|
||||
import qualified Hasql.Decoders as Hasql
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.Serialize ( Encodable )
|
||||
import Rel8.Type ( DBType(..) )
|
||||
import Rel8.Type.Information ( TypeInformation(..) )
|
||||
|
||||
@ -29,3 +30,6 @@ instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where
|
||||
, decode = Hasql.refine (first pack . fmap JSONBEncoded . parseEither parseJSON) Hasql.jsonb
|
||||
, typeName = "jsonb"
|
||||
}
|
||||
|
||||
|
||||
instance Encodable (JSONBEncoded a)
|
||||
|
@ -8,6 +8,7 @@ import Data.Aeson.Types ( parseEither )
|
||||
import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.Serialize ( Encodable )
|
||||
import Rel8.Type ( DBType(..) )
|
||||
import Rel8.Type.Information ( parseTypeInformation )
|
||||
|
||||
@ -23,3 +24,6 @@ instance (FromJSON a, ToJSON a) => DBType (JSONEncoded a) where
|
||||
where
|
||||
f = fmap JSONEncoded . parseEither parseJSON
|
||||
g = toJSON . fromJSONEncoded
|
||||
|
||||
|
||||
instance Encodable (JSONEncoded a)
|
||||
|
@ -6,6 +6,7 @@
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.Type.Monoid
|
||||
( DBMonoid( memptyExpr )
|
||||
|
@ -5,6 +5,7 @@
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.Type.Num
|
||||
( DBNum, DBIntegral, DBFractional, DBFloating
|
||||
|
@ -4,6 +4,7 @@
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.Type.Ord
|
||||
( DBOrd
|
||||
|
@ -11,6 +11,7 @@ import Prelude
|
||||
import Text.Read ( readMaybe )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Schema.Serialize ( Encodable )
|
||||
import Rel8.Type ( DBType( typeInformation ) )
|
||||
import Rel8.Type.Information ( parseTypeInformation )
|
||||
|
||||
@ -30,3 +31,6 @@ instance (Read a, Show a, Typeable a) => DBType (ReadShow a) where
|
||||
Just ok -> Right $ ReadShow ok
|
||||
Nothing -> Left $ "Could not read " <> t <> " as a " <> show (typeRep (Proxy @a))
|
||||
printer = Text.pack . show . fromReadShow
|
||||
|
||||
|
||||
instance Encodable (ReadShow a)
|
||||
|
@ -6,6 +6,7 @@
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.Type.Semigroup
|
||||
( DBSemigroup( (<>.))
|
||||
|
53
src/Rel8/Type/Serialize.hs
Normal file
53
src/Rel8/Type/Serialize.hs
Normal file
@ -0,0 +1,53 @@
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language DerivingVia #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeFamilyDependencies #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.Type.Serialize
|
||||
( Strategy( ExprsFor, encode, decode )
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Kind ( Constraint, Type )
|
||||
import Data.Proxy ( Proxy )
|
||||
import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Schema.HTable.Identity ( HIdentity(..) )
|
||||
import Rel8.Schema.Result ( Col( R ), Result )
|
||||
import Rel8.Schema.Serialize ( Constraints )
|
||||
import Rel8.Table ( Columns )
|
||||
|
||||
|
||||
type Strategy :: Type -> Constraint
|
||||
class Strategy strategy where
|
||||
type ExprsFor strategy (a :: Type) = (expr :: Type) | expr -> a strategy
|
||||
|
||||
encode :: forall a expr result.
|
||||
( expr ~ ExprsFor strategy a
|
||||
, result ~ Columns expr (Col Result)
|
||||
, Constraints strategy a
|
||||
)
|
||||
=> a -> result
|
||||
|
||||
decode :: forall a expr result.
|
||||
( expr ~ ExprsFor strategy a
|
||||
, result ~ Columns expr (Col Result)
|
||||
, Constraints strategy a
|
||||
)
|
||||
=> result -> a
|
||||
|
||||
|
||||
instance Strategy (Proxy Expr) where
|
||||
type ExprsFor (Proxy Expr) a = Expr a
|
||||
|
||||
decode (HType (R a)) = a
|
||||
encode = HType . R
|
@ -3,6 +3,7 @@
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.Type.String
|
||||
( DBString
|
||||
|
@ -5,6 +5,7 @@
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language UndecidableSuperClasses #-}
|
||||
|
||||
module Rel8.Type.Sum
|
||||
( DBSum
|
||||
|
@ -3,6 +3,7 @@
|
||||
{-# language DerivingVia #-}
|
||||
{-# language GeneralizedNewtypeDeriving #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
|
||||
module Rel8.Type.Tag
|
||||
( EitherTag( IsLeft, IsRight ), isLeft, isRight
|
||||
@ -25,6 +26,7 @@ import {-# SOURCE #-} Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Eq ( (==.) )
|
||||
import Rel8.Expr.Opaleye ( zipPrimExprsWith )
|
||||
import Rel8.Expr.Serialize ( litExpr )
|
||||
import Rel8.Schema.Serialize ( Encodable )
|
||||
import Rel8.Type.Eq ( DBEq )
|
||||
import Rel8.Type ( DBType, typeInformation )
|
||||
import Rel8.Type.Information ( mapTypeInformation, parseTypeInformation )
|
||||
@ -40,7 +42,7 @@ type EitherTag :: Type
|
||||
data EitherTag = IsLeft | IsRight
|
||||
deriving stock (Eq, Ord, Read, Show, Enum, Bounded)
|
||||
deriving (Semigroup, Monoid) via (Min EitherTag)
|
||||
deriving anyclass (DBEq, DBOrd)
|
||||
deriving anyclass (DBEq, DBOrd, Encodable)
|
||||
|
||||
|
||||
instance DBType EitherTag where
|
||||
@ -71,7 +73,7 @@ type MaybeTag :: Type
|
||||
data MaybeTag = IsJust
|
||||
deriving stock (Eq, Ord, Read, Show, Enum, Bounded)
|
||||
deriving (Semigroup, Monoid) via (Min MaybeTag)
|
||||
deriving anyclass (DBEq, DBOrd)
|
||||
deriving anyclass (DBEq, DBOrd, Encodable)
|
||||
|
||||
|
||||
instance DBType MaybeTag where
|
||||
@ -93,5 +95,5 @@ instance DBMonoid MaybeTag where
|
||||
newtype Tag = Tag Text
|
||||
deriving newtype
|
||||
( Eq, Ord, Read, Show
|
||||
, DBType, DBEq, DBOrd
|
||||
, DBType, DBEq, DBOrd, Encodable
|
||||
)
|
||||
|
Loading…
Reference in New Issue
Block a user