diff --git a/rel8.cabal b/rel8.cabal index 059d8fd..5df72d2 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -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 diff --git a/src/Rel8.hs b/src/Rel8.hs index 2e2b9c2..c606eaf 100644 --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -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 diff --git a/src/Rel8/Generic/Rel8able/Test.hs b/src/Rel8/Generic/Rel8able/Test.hs index 1ad3750..4676557 100644 --- a/src/Rel8/Generic/Rel8able/Test.hs +++ b/src/Rel8/Generic/Rel8able/Test.hs @@ -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 diff --git a/src/Rel8/Schema/HTable/Nullify.hs b/src/Rel8/Schema/HTable/Nullify.hs index 780d2f2..4b26ba5 100644 --- a/src/Rel8/Schema/HTable/Nullify.hs +++ b/src/Rel8/Schema/HTable/Nullify.hs @@ -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 diff --git a/src/Rel8/Schema/HTable/Vectorize.hs b/src/Rel8/Schema/HTable/Vectorize.hs index 3242219..41253ff 100644 --- a/src/Rel8/Schema/HTable/Vectorize.hs +++ b/src/Rel8/Schema/HTable/Vectorize.hs @@ -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 , .. } diff --git a/src/Rel8/Schema/Null.hs b/src/Rel8/Schema/Null.hs index cf51fd9..11f7db7 100644 --- a/src/Rel8/Schema/Null.hs +++ b/src/Rel8/Schema/Null.hs @@ -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 diff --git a/src/Rel8/Schema/Serialize.hs b/src/Rel8/Schema/Serialize.hs new file mode 100644 index 0000000..ec3ef7c --- /dev/null +++ b/src/Rel8/Schema/Serialize.hs @@ -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 diff --git a/src/Rel8/Schema/Spec.hs b/src/Rel8/Schema/Spec.hs index f9df91a..26e7bab 100644 --- a/src/Rel8/Schema/Spec.hs +++ b/src/Rel8/Schema/Spec.hs @@ -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 } diff --git a/src/Rel8/Schema/Spec/ConstrainDBType.hs b/src/Rel8/Schema/Spec/ConstrainDBType.hs index 334ecac..f5bd8f7 100644 --- a/src/Rel8/Schema/Spec/ConstrainDBType.hs +++ b/src/Rel8/Schema/Spec/ConstrainDBType.hs @@ -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 diff --git a/src/Rel8/Table/HKD.hs b/src/Rel8/Table/HKD.hs index e5680fa..874f81e 100644 --- a/src/Rel8/Table/HKD.hs +++ b/src/Rel8/Table/HKD.hs @@ -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 diff --git a/src/Rel8/Table/Serialize.hs b/src/Rel8/Table/Serialize.hs index 753c6a9..e466b23 100644 --- a/src/Rel8/Table/Serialize.hs +++ b/src/Rel8/Table/Serialize.hs @@ -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 diff --git a/src/Rel8/Type.hs b/src/Rel8/Type.hs index 8cede8b..ed89523 100644 --- a/src/Rel8/Type.hs +++ b/src/Rel8/Type.hs @@ -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 diff --git a/src/Rel8/Type/Composite.hs b/src/Rel8/Type/Composite.hs index a549aa1..ffd1021 100644 --- a/src/Rel8/Type/Composite.hs +++ b/src/Rel8/Type/Composite.hs @@ -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) diff --git a/src/Rel8/Type/Enum.hs b/src/Rel8/Type/Enum.hs index c6ce610..aaeff5a 100644 --- a/src/Rel8/Type/Enum.hs +++ b/src/Rel8/Type/Enum.hs @@ -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 = diff --git a/src/Rel8/Type/Eq.hs b/src/Rel8/Type/Eq.hs index 02e1127..a5e42d5 100644 --- a/src/Rel8/Type/Eq.hs +++ b/src/Rel8/Type/Eq.hs @@ -4,6 +4,7 @@ {-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-} {-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} module Rel8.Type.Eq ( DBEq diff --git a/src/Rel8/Type/JSONBEncoded.hs b/src/Rel8/Type/JSONBEncoded.hs index 4a29a0b..9810001 100644 --- a/src/Rel8/Type/JSONBEncoded.hs +++ b/src/Rel8/Type/JSONBEncoded.hs @@ -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) diff --git a/src/Rel8/Type/JSONEncoded.hs b/src/Rel8/Type/JSONEncoded.hs index 4dd2605..c973a1c 100644 --- a/src/Rel8/Type/JSONEncoded.hs +++ b/src/Rel8/Type/JSONEncoded.hs @@ -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) diff --git a/src/Rel8/Type/Monoid.hs b/src/Rel8/Type/Monoid.hs index d9623ea..7f3d539 100644 --- a/src/Rel8/Type/Monoid.hs +++ b/src/Rel8/Type/Monoid.hs @@ -6,6 +6,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-} {-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} module Rel8.Type.Monoid ( DBMonoid( memptyExpr ) diff --git a/src/Rel8/Type/Num.hs b/src/Rel8/Type/Num.hs index 8b55011..a8cff34 100644 --- a/src/Rel8/Type/Num.hs +++ b/src/Rel8/Type/Num.hs @@ -5,6 +5,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-} {-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} module Rel8.Type.Num ( DBNum, DBIntegral, DBFractional, DBFloating diff --git a/src/Rel8/Type/Ord.hs b/src/Rel8/Type/Ord.hs index 6075fd0..4b59238 100644 --- a/src/Rel8/Type/Ord.hs +++ b/src/Rel8/Type/Ord.hs @@ -4,6 +4,7 @@ {-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-} {-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} module Rel8.Type.Ord ( DBOrd diff --git a/src/Rel8/Type/ReadShow.hs b/src/Rel8/Type/ReadShow.hs index 581a021..8436557 100644 --- a/src/Rel8/Type/ReadShow.hs +++ b/src/Rel8/Type/ReadShow.hs @@ -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) diff --git a/src/Rel8/Type/Semigroup.hs b/src/Rel8/Type/Semigroup.hs index c76e8e4..ada06e3 100644 --- a/src/Rel8/Type/Semigroup.hs +++ b/src/Rel8/Type/Semigroup.hs @@ -6,6 +6,7 @@ {-# language StandaloneKindSignatures #-} {-# language TypeFamilies #-} {-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} module Rel8.Type.Semigroup ( DBSemigroup( (<>.)) diff --git a/src/Rel8/Type/Serialize.hs b/src/Rel8/Type/Serialize.hs new file mode 100644 index 0000000..9ed37f5 --- /dev/null +++ b/src/Rel8/Type/Serialize.hs @@ -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 diff --git a/src/Rel8/Type/String.hs b/src/Rel8/Type/String.hs index 302022a..760db77 100644 --- a/src/Rel8/Type/String.hs +++ b/src/Rel8/Type/String.hs @@ -3,6 +3,7 @@ {-# language MultiParamTypeClasses #-} {-# language StandaloneKindSignatures #-} {-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} module Rel8.Type.String ( DBString diff --git a/src/Rel8/Type/Sum.hs b/src/Rel8/Type/Sum.hs index 3808b32..c855a5f 100644 --- a/src/Rel8/Type/Sum.hs +++ b/src/Rel8/Type/Sum.hs @@ -5,6 +5,7 @@ {-# language TypeFamilies #-} {-# language StandaloneKindSignatures #-} {-# language UndecidableInstances #-} +{-# language UndecidableSuperClasses #-} module Rel8.Type.Sum ( DBSum diff --git a/src/Rel8/Type/Tag.hs b/src/Rel8/Type/Tag.hs index 92b7434..548d3d7 100644 --- a/src/Rel8/Type/Tag.hs +++ b/src/Rel8/Type/Tag.hs @@ -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 )