mirror of
https://github.com/circuithub/rel8.git
synced 2024-10-05 21:29:35 +03:00
Incomplete sketch on using FCF
This commit is contained in:
Ollie Charles
parent
a779ca8346
commit
e5b89e9d83
@ -46,8 +46,6 @@ library
|
||||
Rel8.Aggregate
|
||||
Rel8.Context
|
||||
Rel8.DatabaseType
|
||||
Rel8.DatabaseType.Decoder
|
||||
Rel8.DBFunctor
|
||||
Rel8.DBType
|
||||
Rel8.DBType.DBEq
|
||||
Rel8.DBType.DBMax
|
||||
@ -64,10 +62,11 @@ library
|
||||
Rel8.Function
|
||||
Rel8.Generic
|
||||
Rel8.HTable
|
||||
Rel8.HTable.HComposeTable
|
||||
Rel8.HTable.HMapTable
|
||||
Rel8.HTable.HMaybeTable
|
||||
Rel8.HTable.HPair
|
||||
Rel8.HTable.Identity
|
||||
Rel8.Info
|
||||
Rel8.Optimize
|
||||
Rel8.Query
|
||||
Rel8.Query.Order
|
||||
|
||||
@ -47,6 +47,7 @@ module Rel8
|
||||
-- * Database types
|
||||
-- ** @DBType@
|
||||
DBType(..)
|
||||
, HasInfo
|
||||
|
||||
-- *** Deriving-via helpers
|
||||
-- **** @JSONEncoded@
|
||||
@ -79,6 +80,7 @@ module Rel8
|
||||
|
||||
-- * Expressions
|
||||
, Expr
|
||||
, lit
|
||||
, unsafeCastExpr
|
||||
, unsafeCoerceExpr
|
||||
, unsafeLiteral
|
||||
@ -191,7 +193,7 @@ module Rel8
|
||||
, nullsLast
|
||||
|
||||
-- * IO
|
||||
, Serializable(..)
|
||||
, Serializable
|
||||
, ExprFor
|
||||
|
||||
-- * Running statements
|
||||
@ -263,6 +265,7 @@ import Rel8.Expr.Opaleye ( unsafeLiteral )
|
||||
import Rel8.Function ( Function, function, nullaryFunction )
|
||||
import Rel8.Generic ( Column, HList, HMaybe, HNonEmpty, HigherKindedTable )
|
||||
import Rel8.HTable ( HTable )
|
||||
import Rel8.Info ( HasInfo )
|
||||
import Rel8.Query
|
||||
( Query
|
||||
, countRows
|
||||
@ -285,7 +288,7 @@ import Rel8.Query
|
||||
, where_
|
||||
)
|
||||
import Rel8.Query.Order ( Order, asc, desc, distinctOnBy, nullsFirst, nullsLast, orderBy )
|
||||
import Rel8.Serializable ( ExprFor, Serializable( rowParser, lit ) )
|
||||
import Rel8.Serializable ( ExprFor, Serializable, lit )
|
||||
import Rel8.Statement.Delete ( Delete( Delete, from, deleteWhere, returning ), delete )
|
||||
import Rel8.Statement.Insert ( Insert( Insert, into, rows, returning, onConflict ), OnConflict( Abort, DoNothing ), insert )
|
||||
import Rel8.Statement.Returning ( Returning( NumberOfRowsAffected, Projection ) )
|
||||
|
||||
@ -31,11 +31,10 @@ import qualified Opaleye.Internal.Aggregate as Opaleye
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
import qualified Opaleye.Internal.PackMap as Opaleye
|
||||
import Rel8.Expr ( Expr( Expr ) )
|
||||
import Rel8.HTable ( htraverse )
|
||||
import Rel8.HTable.HComposeTable ( ComposeInner( ComposeInner ) )
|
||||
import Rel8.HTable ( hmap, htraverse )
|
||||
import Rel8.HTable.HMapTable ( HMapTable( HMapTable ), Precompose( Precompose ) )
|
||||
import Rel8.Query ( Query, mapOpaleye )
|
||||
import Rel8.Table ( Table( toColumns ), fromColumns )
|
||||
import Rel8.Table.Congruent ( traverseTable )
|
||||
import Rel8.Table.ListTable ( ListTable( ListTable ) )
|
||||
import Rel8.Table.MaybeTable ( maybeTable, optional )
|
||||
import Rel8.Table.NonEmptyTable ( NonEmptyTable( NonEmptyTable ) )
|
||||
@ -183,20 +182,20 @@ traverseAggrExpr f = \case
|
||||
-- return (order, items)
|
||||
-- @
|
||||
listAgg :: Table Expr exprs => exprs -> Aggregate (ListTable exprs)
|
||||
listAgg = fmap ListTable . traverseTable (fmap ComposeInner . go)
|
||||
listAgg = Aggregate . ListTable . HMapTable . hmap (Precompose . go) . toColumns
|
||||
where
|
||||
go :: Expr a -> Aggregate (Expr [a])
|
||||
go :: Expr a -> Expr [a]
|
||||
go (Expr a) =
|
||||
Aggregate $ Expr $
|
||||
Expr $
|
||||
Opaleye.FunExpr "row" [Opaleye.AggrExpr Opaleye.AggrAll Opaleye.AggrArr a []]
|
||||
|
||||
|
||||
-- | Like 'listAgg', but the result is guaranteed to be a non-empty list.
|
||||
nonEmptyAgg :: Table Expr exprs => exprs -> Aggregate (NonEmptyTable exprs)
|
||||
nonEmptyAgg = fmap NonEmptyTable . traverseTable (fmap ComposeInner . go)
|
||||
nonEmptyAgg = Aggregate . NonEmptyTable . HMapTable . hmap (Precompose . go) . toColumns
|
||||
where
|
||||
go :: Expr a -> Aggregate (Expr (NonEmpty a))
|
||||
go (Expr a) = Aggregate $ Expr $ Opaleye.FunExpr "row" [Opaleye.AggrExpr Opaleye.AggrAll Opaleye.AggrArr a []]
|
||||
go :: Expr a -> Expr (NonEmpty a)
|
||||
go (Expr a) = Expr $ Opaleye.FunExpr "row" [Opaleye.AggrExpr Opaleye.AggrAll Opaleye.AggrArr a []]
|
||||
|
||||
|
||||
-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns
|
||||
|
||||
@ -1,33 +0,0 @@
|
||||
{-# language BlockArguments #-}
|
||||
{-# language LambdaCase #-}
|
||||
{-# language NamedFieldPuns #-}
|
||||
|
||||
module Rel8.DBFunctor ( DBFunctor(..) ) where
|
||||
|
||||
-- base
|
||||
import Data.Foldable ( toList )
|
||||
import Data.List.NonEmpty ( NonEmpty, nonEmpty )
|
||||
|
||||
-- rel8
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
import Rel8.DatabaseType ( DatabaseType( DatabaseType, encode, typeName, decoder ), parseDatabaseType )
|
||||
import Rel8.DatabaseType.Decoder ( listDecoder )
|
||||
|
||||
|
||||
class DBFunctor f where
|
||||
liftDatabaseType :: DatabaseType a -> DatabaseType (f a)
|
||||
|
||||
|
||||
instance DBFunctor [] where
|
||||
liftDatabaseType DatabaseType{ encode, typeName, decoder } = DatabaseType
|
||||
{ encode = Opaleye.FunExpr "row" . pure . Opaleye.CastExpr (typeName <> "[]") . Opaleye.ArrayExpr . map encode
|
||||
, decoder = listDecoder decoder
|
||||
, typeName = "record"
|
||||
}
|
||||
|
||||
|
||||
instance DBFunctor NonEmpty where
|
||||
liftDatabaseType = parseDatabaseType nonEmptyEither toList . liftDatabaseType
|
||||
where
|
||||
nonEmptyEither =
|
||||
maybe (Left "DBType.NonEmpty.decode: empty list") Right . nonEmpty
|
||||
@ -1,15 +1,18 @@
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeFamilies #-}
|
||||
|
||||
module Rel8.DBType ( DBType(..) ) where
|
||||
|
||||
--
|
||||
import qualified Hasql.Decoders as Hasql
|
||||
|
||||
-- aeson
|
||||
import Data.Aeson ( Value )
|
||||
|
||||
-- base
|
||||
import Data.Int ( Int16, Int32, Int64 )
|
||||
import Data.Kind ( Constraint, Type )
|
||||
import Data.List.NonEmpty ( NonEmpty )
|
||||
import Numeric.Natural ( Natural )
|
||||
|
||||
-- bytestring
|
||||
@ -20,15 +23,10 @@ import qualified Data.ByteString.Lazy
|
||||
import Data.CaseInsensitive ( CI )
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
-- hasql
|
||||
import qualified Hasql.Decoders as Hasql
|
||||
|
||||
-- rel8
|
||||
import Opaleye ( pgBool, pgDay, pgDouble, pgInt4, pgInt8, pgLocalTime, pgNumeric, pgStrictByteString, pgStrictText, pgTimeOfDay, pgUTCTime, pgUUID, pgValueJSON )
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
import Rel8.DBFunctor ( DBFunctor( liftDatabaseType ) )
|
||||
import Rel8.DatabaseType ( DatabaseType, DatabaseType( DatabaseType ), decoder, encode, fromOpaleye, mapDatabaseType, nullDatabaseType, typeName )
|
||||
import Rel8.DatabaseType.Decoder ( valueDecoder )
|
||||
import Rel8.DatabaseType ( DatabaseType, DatabaseType( DatabaseType ), decoder, encode, fromOpaleye, mapDatabaseType, typeName )
|
||||
|
||||
-- scientific
|
||||
import Data.Scientific ( Scientific )
|
||||
@ -68,18 +66,21 @@ type DBType :: Type -> Constraint
|
||||
|
||||
|
||||
class DBType a where
|
||||
type BaseType a :: Type
|
||||
type BaseType a = a
|
||||
|
||||
-- | Lookup the type information for the type @a@.
|
||||
typeInformation :: DatabaseType a
|
||||
|
||||
|
||||
-- | Corresponds to the @json@ PostgreSQL type.
|
||||
instance DBType Value where
|
||||
typeInformation = fromOpaleye pgValueJSON $ valueDecoder Hasql.json
|
||||
typeInformation = fromOpaleye pgValueJSON Hasql.json
|
||||
|
||||
|
||||
-- | Corresponds to the @text@ PostgreSQL type.
|
||||
instance DBType Text where
|
||||
typeInformation = fromOpaleye pgStrictText $ valueDecoder Hasql.text
|
||||
typeInformation = fromOpaleye pgStrictText Hasql.text
|
||||
|
||||
|
||||
-- | Corresponds to the @text@ PostgreSQL type.
|
||||
@ -89,41 +90,35 @@ instance DBType Data.Text.Lazy.Text where
|
||||
|
||||
-- | Corresponds to the @bool@ PostgreSQL type.
|
||||
instance DBType Bool where
|
||||
typeInformation = fromOpaleye pgBool $ valueDecoder Hasql.bool
|
||||
typeInformation = fromOpaleye pgBool Hasql.bool
|
||||
|
||||
|
||||
-- | Corresponds to the @int2@ PostgreSQL type.
|
||||
instance DBType Int16 where
|
||||
typeInformation = (mapDatabaseType fromIntegral fromIntegral $ fromOpaleye pgInt4 $ fromIntegral <$> valueDecoder Hasql.int2) -- TODO
|
||||
typeInformation = (mapDatabaseType fromIntegral fromIntegral $ fromOpaleye pgInt4 $ fromIntegral <$> Hasql.int2) -- TODO
|
||||
{ typeName = "int2" }
|
||||
|
||||
|
||||
-- | Corresponds to the @int4@ PostgreSQL type.
|
||||
instance DBType Int32 where
|
||||
typeInformation = mapDatabaseType fromIntegral fromIntegral $ fromOpaleye pgInt4 $ fromIntegral <$> valueDecoder Hasql.int4 -- TODO
|
||||
typeInformation = mapDatabaseType fromIntegral fromIntegral $ fromOpaleye pgInt4 $ fromIntegral <$> Hasql.int4 -- TODO
|
||||
|
||||
|
||||
-- | Corresponds to the @int8@ PostgreSQL type.
|
||||
instance DBType Int64 where
|
||||
typeInformation = fromOpaleye pgInt8 $ valueDecoder Hasql.int8
|
||||
typeInformation = fromOpaleye pgInt8 Hasql.int8
|
||||
|
||||
|
||||
instance DBType Float where
|
||||
typeInformation = DatabaseType
|
||||
{ encode = Opaleye.ConstExpr . Opaleye.NumericLit . realToFrac
|
||||
, decoder = valueDecoder Hasql.float4
|
||||
, decoder = Hasql.float4
|
||||
, typeName = "float4"
|
||||
}
|
||||
|
||||
|
||||
instance DBType UTCTime where
|
||||
typeInformation = fromOpaleye pgUTCTime $ valueDecoder Hasql.timestamptz
|
||||
|
||||
|
||||
-- | Extends any @DBType@ with the value @null@. Note that you cannot "stack"
|
||||
-- @Maybe@s, as SQL doesn't distinguish @Just Nothing@ from @Nothing@.
|
||||
instance DBType a => DBType (Maybe a) where
|
||||
typeInformation = nullDatabaseType typeInformation
|
||||
typeInformation = fromOpaleye pgUTCTime Hasql.timestamptz
|
||||
|
||||
|
||||
instance DBType Data.ByteString.Lazy.ByteString where
|
||||
@ -131,36 +126,36 @@ instance DBType Data.ByteString.Lazy.ByteString where
|
||||
|
||||
|
||||
instance DBType Data.ByteString.ByteString where
|
||||
typeInformation = fromOpaleye pgStrictByteString $ valueDecoder Hasql.bytea
|
||||
typeInformation = fromOpaleye pgStrictByteString Hasql.bytea
|
||||
|
||||
|
||||
instance DBType Scientific where
|
||||
typeInformation = fromOpaleye pgNumeric $ valueDecoder Hasql.numeric
|
||||
typeInformation = fromOpaleye pgNumeric Hasql.numeric
|
||||
|
||||
|
||||
-- TODO
|
||||
instance DBType Natural where
|
||||
typeInformation = mapDatabaseType round fromIntegral $ fromOpaleye pgNumeric $ valueDecoder Hasql.numeric
|
||||
typeInformation = mapDatabaseType round fromIntegral $ fromOpaleye pgNumeric Hasql.numeric
|
||||
|
||||
|
||||
instance DBType Double where
|
||||
typeInformation = fromOpaleye pgDouble $ valueDecoder Hasql.float8
|
||||
typeInformation = fromOpaleye pgDouble Hasql.float8
|
||||
|
||||
|
||||
instance DBType UUID where
|
||||
typeInformation = fromOpaleye pgUUID $ valueDecoder Hasql.uuid
|
||||
typeInformation = fromOpaleye pgUUID Hasql.uuid
|
||||
|
||||
|
||||
instance DBType Day where
|
||||
typeInformation = fromOpaleye pgDay $ valueDecoder Hasql.date
|
||||
typeInformation = fromOpaleye pgDay Hasql.date
|
||||
|
||||
|
||||
instance DBType LocalTime where
|
||||
typeInformation = fromOpaleye pgLocalTime $ valueDecoder Hasql.timestamp
|
||||
typeInformation = fromOpaleye pgLocalTime Hasql.timestamp
|
||||
|
||||
|
||||
instance DBType TimeOfDay where
|
||||
typeInformation = fromOpaleye pgTimeOfDay $ valueDecoder Hasql.time
|
||||
typeInformation = fromOpaleye pgTimeOfDay Hasql.time
|
||||
|
||||
|
||||
instance DBType (CI Text) where
|
||||
@ -169,11 +164,3 @@ instance DBType (CI Text) where
|
||||
|
||||
instance DBType (CI Data.Text.Lazy.Text) where
|
||||
typeInformation = (mapDatabaseType CI.mk CI.original typeInformation) { typeName = "citext" }
|
||||
|
||||
|
||||
instance DBType a => DBType [a] where
|
||||
typeInformation = liftDatabaseType typeInformation
|
||||
|
||||
|
||||
instance DBType a => DBType (NonEmpty a) where
|
||||
typeInformation = liftDatabaseType typeInformation
|
||||
|
||||
@ -13,10 +13,10 @@ import Data.CaseInsensitive ( CI )
|
||||
|
||||
-- rel8
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
import Rel8.DBType ( DBType )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Bool ( (||.), not_ )
|
||||
import Rel8.Expr.Opaleye ( binExpr, litExpr )
|
||||
import Rel8.Info ( HasInfo )
|
||||
|
||||
-- scientific
|
||||
import Data.Scientific ( Scientific )
|
||||
@ -63,7 +63,7 @@ import Data.Time ( Day, UTCTime )
|
||||
-- This means @Color@s will be treated as the literal strings @"Red"@,
|
||||
-- @"Green"@, etc, in the database, and they can be compared for equality by
|
||||
-- just using @=@.
|
||||
class DBType a => DBEq (a :: Type) where
|
||||
class HasInfo a => DBEq (a :: Type) where
|
||||
(==.) :: Expr a -> Expr a -> Expr Bool
|
||||
(==.) = binExpr (Opaleye.:==)
|
||||
|
||||
|
||||
@ -8,6 +8,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
import Rel8.Aggregate ( Aggregate, aggregateAllExprs )
|
||||
import Rel8.DBType ( DBType )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Info ( HasInfo )
|
||||
|
||||
-- scientific
|
||||
import Data.Scientific ( Scientific )
|
||||
@ -23,7 +24,7 @@ import Data.Time ( UTCTime )
|
||||
--
|
||||
-- If you have a custom type that you know supports @max@, you can use
|
||||
-- @DeriveAnyClass@ to derive a default implementation that calls @max@.
|
||||
class DBType a => DBMax a where
|
||||
class HasInfo a => DBMax a where
|
||||
-- | Produce an aggregation for @Expr a@ using the @max@ function.
|
||||
max :: Expr a -> Aggregate (Expr a)
|
||||
max = aggregateAllExprs Opaleye.AggrMax
|
||||
@ -53,4 +54,4 @@ instance DBMax Text
|
||||
instance DBMax UTCTime
|
||||
|
||||
|
||||
instance DBMax a => DBMax (Maybe a)
|
||||
instance DBType a => DBMax (Maybe a)
|
||||
|
||||
@ -8,6 +8,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
import Rel8.Aggregate ( Aggregate, aggregateAllExprs )
|
||||
import Rel8.DBType ( DBType )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Info ( HasInfo )
|
||||
|
||||
-- scientific
|
||||
import Data.Scientific ( Scientific )
|
||||
@ -23,7 +24,7 @@ import Data.Time ( UTCTime )
|
||||
--
|
||||
-- If you have a custom type that you know supports @min@, you can use
|
||||
-- @DeriveAnyClass@ to derive a default implementation that calls @min@.
|
||||
class DBType a => DBMin a where
|
||||
class HasInfo a => DBMin a where
|
||||
-- | Produce an aggregation for @Expr a@ using the @max@ function.
|
||||
min :: Expr a -> Aggregate (Expr a)
|
||||
min = aggregateAllExprs Opaleye.AggrMin
|
||||
@ -53,4 +54,4 @@ instance DBMin Text
|
||||
instance DBMin UTCTime
|
||||
|
||||
|
||||
instance DBMin a => DBMin (Maybe a) -- TODO: Do we want this?
|
||||
instance DBType a => DBMin (Maybe a) -- TODO: Do we want this?
|
||||
|
||||
@ -1,19 +1,18 @@
|
||||
module Rel8.DBType.JSONBEncoded ( JSONBEncoded(..) ) where
|
||||
|
||||
--
|
||||
import qualified Hasql.Decoders as Hasql
|
||||
|
||||
-- aeson
|
||||
import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON )
|
||||
import Data.Aeson.Types ( parseEither )
|
||||
|
||||
-- hasql
|
||||
import qualified Hasql.Decoders as Hasql
|
||||
|
||||
-- rel8
|
||||
import Rel8.DBType ( DBType( typeInformation ) )
|
||||
import Rel8.DatabaseType
|
||||
( DatabaseType( encode, decoder, typeName, DatabaseType )
|
||||
, parseDatabaseType
|
||||
)
|
||||
import Rel8.DatabaseType.Decoder ( valueDecoder )
|
||||
|
||||
|
||||
-- | Like 'JSONEncoded', but works for @jsonb@ columns.
|
||||
@ -23,7 +22,7 @@ newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a }
|
||||
instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where
|
||||
typeInformation = parseDatabaseType f g DatabaseType
|
||||
{ encode = encode typeInformation
|
||||
, decoder = valueDecoder Hasql.jsonb
|
||||
, decoder = Hasql.jsonb
|
||||
, typeName = "jsonb"
|
||||
}
|
||||
where
|
||||
|
||||
@ -1,4 +1,6 @@
|
||||
{-# language LambdaCase #-}
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeApplications #-}
|
||||
@ -8,18 +10,29 @@ module Rel8.DatabaseType
|
||||
, mapDatabaseType
|
||||
, parseDatabaseType
|
||||
, fromOpaleye
|
||||
, nullDatabaseType
|
||||
, nonEmptyNotNull
|
||||
, nonEmptyNull
|
||||
, listOfNull
|
||||
, listOfNotNull
|
||||
) where
|
||||
|
||||
--
|
||||
import qualified Hasql.Decoders as Hasql
|
||||
|
||||
-- base
|
||||
import Data.Bifunctor ( first )
|
||||
import Data.Data ( Proxy( Proxy ) )
|
||||
import Data.Foldable ( toList )
|
||||
import Data.Kind ( Type )
|
||||
import Data.List.NonEmpty ( NonEmpty( (:|) ) )
|
||||
|
||||
-- rel8
|
||||
import Opaleye ( Column, IsSqlType, showSqlType )
|
||||
import qualified Opaleye.Internal.Column as Opaleye
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
import Rel8.DatabaseType.Decoder ( Decoder, acceptNull, parseDecoder )
|
||||
|
||||
-- text
|
||||
import Data.Text ( pack )
|
||||
|
||||
|
||||
-- | A @DatabaseType@ describes how to encode and decode a Haskell type to and
|
||||
@ -33,7 +46,7 @@ data DatabaseType a = DatabaseType
|
||||
-- ^ How to encode a single Haskell value as a SQL expression.
|
||||
, typeName :: String
|
||||
-- ^ The name of the SQL type.
|
||||
, decoder :: Decoder a
|
||||
, decoder :: Hasql.Value a
|
||||
-- ^ How to deserialize a single result back to Haskell.
|
||||
}
|
||||
|
||||
@ -63,7 +76,7 @@ data DatabaseType a = DatabaseType
|
||||
parseDatabaseType :: (a -> Either String b) -> (b -> a) -> DatabaseType a -> DatabaseType b
|
||||
parseDatabaseType aToB bToA DatabaseType{ encode, typeName, decoder } = DatabaseType
|
||||
{ encode = encode . bToA
|
||||
, decoder = parseDecoder aToB decoder
|
||||
, decoder = Hasql.refine (first pack . aToB) decoder
|
||||
, typeName
|
||||
}
|
||||
|
||||
@ -84,7 +97,7 @@ mapDatabaseType aToB bToA DatabaseType{ encode, typeName, decoder } = DatabaseTy
|
||||
|
||||
fromOpaleye :: forall a b. IsSqlType b
|
||||
=> (a -> Opaleye.Column b)
|
||||
-> Decoder a
|
||||
-> Hasql.Value a
|
||||
-> DatabaseType a
|
||||
fromOpaleye f decoder =
|
||||
DatabaseType
|
||||
@ -94,9 +107,57 @@ fromOpaleye f decoder =
|
||||
}
|
||||
|
||||
|
||||
nullDatabaseType :: DatabaseType a -> DatabaseType (Maybe a)
|
||||
nullDatabaseType DatabaseType{ encode, typeName, decoder } = DatabaseType
|
||||
{ encode = maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
|
||||
, decoder = acceptNull decoder
|
||||
, typeName
|
||||
nonEmptyNotNull :: DatabaseType a -> DatabaseType (NonEmpty a)
|
||||
nonEmptyNotNull DatabaseType{ encode, typeName, decoder } = DatabaseType
|
||||
{ encode = Opaleye.FunExpr "row" . pure . Opaleye.CastExpr (typeName <> "[]") . Opaleye.ArrayExpr . map encode . toList
|
||||
, decoder = Hasql.refine parse $ compositeArrayOf $ Hasql.nonNullable decoder
|
||||
, typeName = "record"
|
||||
}
|
||||
where
|
||||
parse = \case
|
||||
[] -> Left "Unexpected empty list"
|
||||
x:xs -> Right (x :| xs)
|
||||
|
||||
compositeArrayOf =
|
||||
Hasql.composite . Hasql.field . Hasql.nonNullable . Hasql.listArray
|
||||
|
||||
|
||||
nonEmptyNull :: DatabaseType a -> DatabaseType (NonEmpty (Maybe a))
|
||||
nonEmptyNull DatabaseType{ encode, typeName, decoder } = DatabaseType
|
||||
{ encode = Opaleye.FunExpr "row" . pure . Opaleye.CastExpr (typeName <> "[]") . Opaleye.ArrayExpr . map (maybe nullExpr encode) . toList
|
||||
, decoder = Hasql.refine parse $ compositeArrayOf $ Hasql.nullable decoder
|
||||
, typeName = "record"
|
||||
}
|
||||
where
|
||||
nullExpr = Opaleye.ConstExpr Opaleye.NullLit
|
||||
|
||||
parse = \case
|
||||
[] -> Left "Unexpected empty list"
|
||||
x:xs -> Right (x :| xs)
|
||||
|
||||
compositeArrayOf =
|
||||
Hasql.composite . Hasql.field . Hasql.nonNullable . Hasql.listArray
|
||||
|
||||
|
||||
listOfNotNull :: DatabaseType a -> DatabaseType [a]
|
||||
listOfNotNull DatabaseType{ encode, typeName, decoder } = DatabaseType
|
||||
{ encode = Opaleye.FunExpr "row" . pure . Opaleye.CastExpr (typeName <> "[]") . Opaleye.ArrayExpr . map encode . toList
|
||||
, decoder = compositeArrayOf $ Hasql.nonNullable decoder
|
||||
, typeName = "record"
|
||||
}
|
||||
where
|
||||
compositeArrayOf =
|
||||
Hasql.composite . Hasql.field . Hasql.nonNullable . Hasql.listArray
|
||||
|
||||
|
||||
listOfNull :: DatabaseType a -> DatabaseType [Maybe a]
|
||||
listOfNull DatabaseType{ encode, typeName, decoder } = DatabaseType
|
||||
{ encode = Opaleye.FunExpr "row" . pure . Opaleye.CastExpr (typeName <> "[]") . Opaleye.ArrayExpr . map (maybe nullExpr encode) . toList
|
||||
, decoder = compositeArrayOf $ Hasql.nullable decoder
|
||||
, typeName = "record"
|
||||
}
|
||||
where
|
||||
nullExpr = Opaleye.ConstExpr Opaleye.NullLit
|
||||
|
||||
compositeArrayOf =
|
||||
Hasql.composite . Hasql.field . Hasql.nonNullable . Hasql.listArray
|
||||
|
||||
@ -1,84 +0,0 @@
|
||||
{-# language BlockArguments #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language LambdaCase #-}
|
||||
|
||||
module Rel8.DatabaseType.Decoder
|
||||
( Decoder(..)
|
||||
-- * Construcing Decoders
|
||||
, valueDecoder
|
||||
|
||||
-- * Running Decoders
|
||||
, runDecoder
|
||||
|
||||
-- ** Transforming Decoders
|
||||
, parseDecoder
|
||||
, acceptNull
|
||||
, listDecoder
|
||||
) where
|
||||
|
||||
-- base
|
||||
import Control.Monad ( (<=<) )
|
||||
import Data.Bifunctor ( first )
|
||||
|
||||
-- hasql
|
||||
import qualified Hasql.Decoders as Hasql
|
||||
|
||||
-- text
|
||||
import Data.Text ( pack )
|
||||
|
||||
|
||||
data Decoder a where
|
||||
DecodeNotNull :: Hasql.Value x -> (x -> a) -> Decoder a
|
||||
DecodeNull :: Hasql.Value x -> (Maybe x -> Either String a) -> Decoder a
|
||||
|
||||
|
||||
instance Functor Decoder where
|
||||
fmap f = \case
|
||||
DecodeNotNull v g -> DecodeNotNull v (f . g)
|
||||
DecodeNull v g -> DecodeNull v (fmap f . g)
|
||||
|
||||
|
||||
valueDecoder :: Hasql.Value a -> Decoder a
|
||||
valueDecoder v = DecodeNotNull v id
|
||||
|
||||
|
||||
-- | Enrich a 'DatabaseType' with the ability to parse @null@.
|
||||
acceptNull :: Decoder a -> Decoder (Maybe a)
|
||||
acceptNull = \case
|
||||
DecodeNotNull v f -> fmap f <$> nullDecoder
|
||||
where nullDecoder = DecodeNull v pure
|
||||
|
||||
DecodeNull v f -> DecodeNull v (fmap Just . f)
|
||||
|
||||
|
||||
listDecoder :: Decoder a -> Decoder [a]
|
||||
listDecoder = \case
|
||||
DecodeNotNull v f -> DecodeNotNull v' id
|
||||
where v' = compositeArrayOf (Hasql.nonNullable (f <$> v))
|
||||
|
||||
DecodeNull v f -> DecodeNull v' \case
|
||||
Nothing -> pure <$> f Nothing
|
||||
Just xs -> traverse f xs
|
||||
where v' = compositeArrayOf (Hasql.nullable v)
|
||||
where
|
||||
compositeArrayOf =
|
||||
Hasql.composite . Hasql.field . Hasql.nonNullable . Hasql.listArray
|
||||
|
||||
|
||||
-- | Apply a parser to a decoder.
|
||||
parseDecoder :: (a -> Either String b) -> Decoder a -> Decoder b
|
||||
parseDecoder f = \case
|
||||
DecodeNotNull v g -> DecodeNotNull v' id
|
||||
where
|
||||
v' = Hasql.refine (first pack . f . g) v
|
||||
|
||||
DecodeNull v g -> DecodeNull v (f <=< g)
|
||||
|
||||
|
||||
runDecoder :: Decoder x -> Hasql.Row x
|
||||
runDecoder = \case
|
||||
DecodeNotNull v f ->
|
||||
Hasql.column $ Hasql.nonNullable (f <$> v)
|
||||
|
||||
DecodeNull v f ->
|
||||
either fail pure . f =<< Hasql.column (Hasql.nullable v)
|
||||
@ -35,9 +35,9 @@ import Prelude
|
||||
import qualified Opaleye ( PGInt8 )
|
||||
import qualified Opaleye.Internal.Column as Opaleye
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
import Rel8.DBType ( DBType )
|
||||
import Rel8.Expr.Opaleye ( columnToExpr, exprToColumn, litExpr )
|
||||
import Rel8.Function ( function )
|
||||
import Rel8.Info ( HasInfo )
|
||||
|
||||
|
||||
-- | Typed SQL expressions
|
||||
@ -55,7 +55,7 @@ newtype Expr a = Expr { toPrimExpr :: Opaleye.PrimExpr }
|
||||
-- *However*, if this is not the case, you should `newtype` the Haskell type
|
||||
-- and avoid providing a 'Num' instance, or you may write be able to write
|
||||
-- ill-typed queries!
|
||||
instance (DBType a, Num a) => Num (Expr a) where
|
||||
instance (HasInfo a, Num a) => Num (Expr a) where
|
||||
a + b = columnToExpr (Opaleye.binOp (Opaleye.:+) (exprToColumn a) (exprToColumn b))
|
||||
a - b = columnToExpr (Opaleye.binOp (Opaleye.:-) (exprToColumn a) (exprToColumn b))
|
||||
a * b = columnToExpr (Opaleye.binOp (Opaleye.:*) (exprToColumn a) (exprToColumn b))
|
||||
@ -65,12 +65,12 @@ instance (DBType a, Num a) => Num (Expr a) where
|
||||
negate = columnToExpr @Opaleye.PGInt8 . negate . exprToColumn
|
||||
|
||||
|
||||
instance (DBType a, Fractional a) => Fractional (Expr a) where
|
||||
instance (HasInfo a, Fractional a) => Fractional (Expr a) where
|
||||
a / b = columnToExpr (Opaleye.binOp (Opaleye.:/) (exprToColumn a) (exprToColumn b))
|
||||
fromRational = litExpr . fromRational
|
||||
|
||||
|
||||
instance (IsString a, DBType a) => IsString (Expr a) where
|
||||
instance (IsString a, HasInfo a) => IsString (Expr a) where
|
||||
fromString = litExpr . fromString
|
||||
|
||||
|
||||
|
||||
@ -20,6 +20,7 @@ import Rel8.DBType.DBEq ( DBEq( (==.) ) )
|
||||
import Rel8.Expr ( Expr, retype, unsafeCoerceExpr )
|
||||
import Rel8.Expr.Bool ( not_ )
|
||||
import Rel8.Expr.Opaleye ( litExpr, mapPrimExpr )
|
||||
import Rel8.Info ( HasInfo )
|
||||
import Rel8.Query ( Query, where_ )
|
||||
import Rel8.Table.Bool ( ifThenElse_ )
|
||||
|
||||
@ -31,7 +32,7 @@ import Rel8.Table.Bool ( ifThenElse_ )
|
||||
--
|
||||
-- >>> select c $ pure $ null 0 id (lit (Just 42) :: Expr (Maybe Int32))
|
||||
-- [42]
|
||||
null :: DBType b => Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
|
||||
null :: HasInfo b => Expr b -> (Expr a -> Expr b) -> Expr (Maybe a) -> Expr b
|
||||
null whenNull f a = ifThenElse_ (isNull a) whenNull (f (retype a))
|
||||
|
||||
|
||||
@ -69,7 +70,7 @@ mapNull :: (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
|
||||
mapNull f = retype . f . retype
|
||||
|
||||
|
||||
fromNull :: DBType a => Expr a -> Expr (Maybe a) -> Expr a
|
||||
fromNull :: HasInfo a => Expr a -> Expr (Maybe a) -> Expr a
|
||||
fromNull x = null x id
|
||||
|
||||
|
||||
@ -98,6 +99,6 @@ catMaybe e = do
|
||||
return $ unsafeCoerceExpr e
|
||||
|
||||
|
||||
instance DBEq a => DBEq ( Maybe a ) where
|
||||
instance (DBType a, DBEq a) => DBEq (Maybe a) where
|
||||
a ==. b =
|
||||
null ( isNull b ) ( \a' -> null ( litExpr False ) ( a' ==. ) b ) a
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# language GADTs #-}
|
||||
{-# language LambdaCase #-}
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
@ -11,16 +13,14 @@ module Rel8.Expr.Opaleye
|
||||
, unsafeLiteral
|
||||
, litExprWith
|
||||
, litExpr
|
||||
, listOfExprs
|
||||
) where
|
||||
|
||||
-- rel8
|
||||
import qualified Opaleye.Internal.Column as Opaleye
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
import Rel8.DBFunctor ( DBFunctor( liftDatabaseType ) )
|
||||
import Rel8.DBType ( DBType( typeInformation ) )
|
||||
import Rel8.DatabaseType ( DatabaseType( DatabaseType, encode, typeName ) )
|
||||
import {-# source #-} Rel8.Expr ( Expr( Expr ), toPrimExpr )
|
||||
import Rel8.Info ( HasInfo( info ), Info( NotNull, Null ) )
|
||||
import {-# source #-} Rel8.Expr ( Expr( Expr ) )
|
||||
|
||||
|
||||
binExpr :: Opaleye.BinOp -> Expr a -> Expr a -> Expr b
|
||||
@ -56,17 +56,11 @@ fromPrimExpr :: Opaleye.PrimExpr -> Expr a
|
||||
fromPrimExpr = Expr
|
||||
|
||||
|
||||
litExpr :: DBType a => a -> Expr a
|
||||
litExpr = litExprWith typeInformation
|
||||
litExpr :: HasInfo a => a -> Expr a
|
||||
litExpr = litExprWith info
|
||||
|
||||
|
||||
litExprWith :: DatabaseType a -> a -> Expr a
|
||||
litExprWith DatabaseType{ encode, typeName } = Expr . Opaleye.CastExpr typeName . encode
|
||||
|
||||
|
||||
listOfExprs :: DatabaseType x -> [Expr x] -> Expr [x]
|
||||
listOfExprs databaseType as = fromPrimExpr $
|
||||
Opaleye.CastExpr array $
|
||||
Opaleye.ArrayExpr (map toPrimExpr as)
|
||||
where
|
||||
array = typeName (liftDatabaseType @[] databaseType)
|
||||
litExprWith :: Info a -> a -> Expr a
|
||||
litExprWith = \case
|
||||
NotNull DatabaseType{ encode, typeName } -> Expr . Opaleye.CastExpr typeName . encode
|
||||
Null DatabaseType{ encode, typeName } -> Expr . Opaleye.CastExpr typeName . maybe (Opaleye.ConstExpr Opaleye.NullLit) encode
|
||||
|
||||
@ -17,28 +17,23 @@
|
||||
module Rel8.Generic ( Column, HList, HMaybe, HNonEmpty, HigherKindedTable ) where
|
||||
|
||||
-- base
|
||||
import Control.Applicative ( Applicative(liftA2) )
|
||||
import Data.Functor.Identity ( Identity )
|
||||
import Data.Kind (Type)
|
||||
import Data.List.NonEmpty ( NonEmpty )
|
||||
import GHC.Generics ( Generic( Rep, from, to ), K1(K1, unK1), M1(M1, unM1), type (:*:)((:*:)))
|
||||
|
||||
-- hasql
|
||||
import qualified Hasql.Decoders as Hasql
|
||||
import GHC.Generics ( Generic( Rep, from, to ), K1(K1), M1(M1, unM1), type (:*:)((:*:)))
|
||||
|
||||
-- rel8
|
||||
import Rel8.Context ( Context, KContext )
|
||||
import Rel8.DatabaseType.Decoder ( Decoder )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.HTable ( HTable )
|
||||
import Rel8.HTable.HComposeTable ( HComposeTable )
|
||||
import Rel8.HTable.HMapTable ( HMapTable )
|
||||
import Rel8.HTable.HMaybeTable ( HMaybeTable )
|
||||
import Rel8.HTable.HPair ( HPair(HPair) )
|
||||
import Rel8.Serializable ( Serializable(rowParser, lit), ExprFor )
|
||||
import Rel8.Serializable ( Serializable, ExprFor( unpack, pack ) )
|
||||
import Rel8.Table ( Table(Columns, fromColumns, toColumns) )
|
||||
import Rel8.Table.ListTable ( ListTable )
|
||||
import Rel8.Table.ListTable ( ListTable, ListOf )
|
||||
import Rel8.Table.MaybeTable ( MaybeTable )
|
||||
import Rel8.Table.NonEmptyTable ( NonEmptyTable )
|
||||
import Rel8.Table.NonEmptyTable ( NonEmptyTable, NonEmptyList )
|
||||
import Rel8.Table.Selects ( Selects )
|
||||
import Rel8.TableSchema.ColumnSchema ( ColumnSchema )
|
||||
|
||||
@ -87,13 +82,13 @@ type family HMaybe (context :: Type -> Type) (a :: Type) :: Type where
|
||||
type family HList (context :: Type -> Type) (a :: Type) :: Type where
|
||||
HList Identity a = [a]
|
||||
HList Expr a = ListTable a
|
||||
HList f a = HComposeTable [] (Columns a) (Context f)
|
||||
HList f a = HMapTable ListOf (Columns a) (Context f)
|
||||
|
||||
|
||||
type family HNonEmpty (context :: Type -> Type) (a :: Type) :: Type where
|
||||
HNonEmpty Identity a = NonEmpty a
|
||||
HNonEmpty Expr a = NonEmptyTable a
|
||||
HNonEmpty f a = HComposeTable NonEmpty (Columns a) (Context f)
|
||||
HNonEmpty f a = HMapTable NonEmptyList (Columns a) (Context f)
|
||||
|
||||
|
||||
-- | Higher-kinded data types.
|
||||
@ -181,50 +176,44 @@ class HTable (GRep t) => HigherKindedTable (t :: (Type -> Type) -> Type) where
|
||||
=> GRep t (Context ColumnSchema) -> t ColumnSchema
|
||||
fromColumnSchemas = to @_ @() . ghigherKindedFrom @ColumnSchema @(Rep (t ColumnSchema))
|
||||
|
||||
glit :: t Identity -> t Expr
|
||||
default glit
|
||||
gpack :: GRep t (Context Identity) -> t Identity
|
||||
gunpack :: t Identity -> GRep t (Context Identity)
|
||||
|
||||
default gpack
|
||||
:: ( Generic (t Identity)
|
||||
, Generic (t Expr)
|
||||
, GSerializable (Rep (t Expr)) (Rep (t Identity))
|
||||
)
|
||||
=> t Identity -> t Expr
|
||||
glit = to @_ @() . glitImpl @(Rep (t Expr)) @(Rep (t Identity)) . GHC.Generics.from @_ @()
|
||||
, GPack (Rep (t Expr)) (Rep (t Identity))
|
||||
, GColumns (Rep (t Expr)) ~ GRep t
|
||||
)
|
||||
=> GRep t (Context Identity) -> t Identity
|
||||
gpack = to @_ @() . gpackImpl @(Rep (t Expr)) @(Rep (t Identity))
|
||||
|
||||
growParser :: (Applicative f, Traversable f)
|
||||
=> (forall a. Decoder a -> Decoder (f a))
|
||||
-> Hasql.Row (f (t Identity))
|
||||
default growParser
|
||||
default gunpack
|
||||
:: ( Generic (t Identity)
|
||||
, GSerializable (Rep (t Expr)) (Rep (t Identity))
|
||||
, Applicative f
|
||||
, Traversable f
|
||||
)
|
||||
=> (forall a. Decoder a -> Decoder (f a))
|
||||
-> Hasql.Row (f (t Identity))
|
||||
growParser f = fmap (to @_ @()) <$> growParserImpl @(Rep (t Expr)) @(Rep (t Identity)) f
|
||||
, GPack (Rep (t Expr)) (Rep (t Identity))
|
||||
, GColumns (Rep (t Expr)) ~ GRep t
|
||||
)
|
||||
=> t Identity -> GRep t (Context Identity)
|
||||
gunpack = gunpackImpl @(Rep (t Expr)) @(Rep (t Identity)) . from @_ @()
|
||||
|
||||
|
||||
class GSerializable (expr :: Type -> Type) (haskell :: Type -> Type) where
|
||||
glitImpl :: haskell x -> expr x
|
||||
|
||||
growParserImpl :: (Applicative f, Traversable f)
|
||||
=> (forall a. Decoder a -> Decoder (f a))
|
||||
-> Hasql.Row (f (haskell x))
|
||||
class GPack f g where
|
||||
gpackImpl :: GColumns f (Context Identity) -> g x
|
||||
gunpackImpl :: g x -> GColumns f (Context Identity)
|
||||
|
||||
|
||||
instance GSerializable f f' => GSerializable (M1 i c f) (M1 i' c' f') where
|
||||
glitImpl = M1 . glitImpl @f @f' . unM1
|
||||
growParserImpl f = fmap M1 <$> growParserImpl @f @f' f
|
||||
instance GPack f g => GPack (M1 i c f) (M1 i' c' g) where
|
||||
gpackImpl = M1 . gpackImpl @f @g
|
||||
gunpackImpl (M1 a) = gunpackImpl @f @g a
|
||||
|
||||
|
||||
instance (GSerializable f f', GSerializable g g') => GSerializable (f :*: g) (f' :*: g') where
|
||||
glitImpl (x :*: y) = glitImpl @f @f' x :*: glitImpl @g @g' y
|
||||
growParserImpl f = liftA2 (liftA2 (:*:)) (growParserImpl @f @f' f) (growParserImpl @g @g' f)
|
||||
instance (GPack f1 f2, GPack g1 g2) => GPack (f1 :*: g1) (f2 :*: g2) where
|
||||
gpackImpl (HPair x y) = gpackImpl @f1 @f2 x :*: gpackImpl @g1 @g2 y
|
||||
gunpackImpl (x :*: y) = HPair (gunpackImpl @f1 @f2 x) (gunpackImpl @g1 @g2 y)
|
||||
|
||||
|
||||
instance Serializable expr haskell => GSerializable (K1 i expr) (K1 i haskell) where
|
||||
glitImpl = K1 . lit . unK1
|
||||
growParserImpl f = fmap K1 <$> rowParser @expr @haskell f
|
||||
instance Serializable a a' => GPack (K1 i a) (K1 i' a') where
|
||||
gpackImpl = K1 . pack @a
|
||||
gunpackImpl (K1 a) = unpack @a a
|
||||
|
||||
|
||||
class HigherKindedTableImpl (context :: Type -> Type) (rep :: Type -> Type) where
|
||||
@ -272,11 +261,12 @@ instance HigherKindedTable t => Helper ColumnSchema t where
|
||||
helperFrom = fromColumnSchemas
|
||||
|
||||
|
||||
instance (HigherKindedTable t, s ~ t, columnSchema ~ ColumnSchema, expr ~ Expr) => Selects (s columnSchema) (t expr)
|
||||
instance (HigherKindedTable t, s ~ t, columnSchema ~ ColumnSchema, expr ~ Expr) => Selects (s columnSchema) (t expr)
|
||||
|
||||
|
||||
instance (HigherKindedTable t, a ~ t Expr, identity ~ Identity) => ExprFor a (t identity)
|
||||
instance (HigherKindedTable t, a ~ t Expr, identity ~ Identity) => ExprFor a (t identity) where
|
||||
pack = gpack
|
||||
unpack = gunpack
|
||||
|
||||
instance (s ~ t, expr ~ Expr, identity ~ Identity, HigherKindedTable t) => Serializable (s expr) (t identity) where
|
||||
lit = glit
|
||||
rowParser = growParser
|
||||
|
||||
|
||||
@ -1,8 +1,16 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language FunctionalDependencies #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language KindSignatures #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeFamilyDependencies #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
|
||||
module Rel8.HTable ( HTable(..), hmap, hzipWith ) where
|
||||
|
||||
@ -11,7 +19,7 @@ import Data.Kind ( Type )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Context ( Context, KContext )
|
||||
import Rel8.DatabaseType ( DatabaseType )
|
||||
import Rel8.Info ( Info )
|
||||
|
||||
|
||||
class HTable (t :: KContext -> Type) where
|
||||
@ -20,7 +28,7 @@ class HTable (t :: KContext -> Type) where
|
||||
hfield :: t (Context f) -> HField t x -> f x
|
||||
htabulate :: forall f. (forall x. HField t x -> f x) -> t (Context f)
|
||||
htraverse :: forall f g m. Applicative m => (forall x. f x -> m (g x)) -> t (Context f) -> m (t (Context g))
|
||||
hdbtype :: t (Context DatabaseType)
|
||||
hdbtype :: t (Context Info)
|
||||
|
||||
|
||||
hmap :: HTable t => (forall x. f x -> g x) -> t (Context f) -> t (Context g)
|
||||
@ -29,5 +37,3 @@ hmap f t = htabulate $ f <$> hfield t
|
||||
|
||||
hzipWith :: HTable t => (forall x. f x -> g x -> h x) -> t (Context f) -> t (Context g) -> t (Context h)
|
||||
hzipWith f t u = htabulate $ f <$> hfield t <*> hfield u
|
||||
|
||||
|
||||
|
||||
@ -1,53 +0,0 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language TypeFamilies #-}
|
||||
|
||||
module Rel8.HTable.HComposeTable
|
||||
( HComposeTable(..)
|
||||
, ComposeInner(..)
|
||||
, zipComposeInnerWith
|
||||
) where
|
||||
|
||||
-- rel8
|
||||
import Rel8.Context ( Context, KContext )
|
||||
import Rel8.DBFunctor ( DBFunctor( liftDatabaseType ) )
|
||||
import Rel8.HTable ( HTable( HField, hfield, htabulate, htraverse, hdbtype ), hmap )
|
||||
|
||||
|
||||
newtype HComposeTable g t (f :: KContext) = HComposeTable (t (Context (ComposeInner f g)))
|
||||
|
||||
|
||||
data HComposeField f t a where
|
||||
HComposeField :: HField t a -> HComposeField f t (f a)
|
||||
|
||||
|
||||
instance (HTable t, DBFunctor f) => HTable (HComposeTable f t) where
|
||||
type HField (HComposeTable f t) = HComposeField f t
|
||||
|
||||
hfield (HComposeTable columns) (HComposeField field) =
|
||||
getComposeInner (hfield columns field)
|
||||
|
||||
htabulate f = HComposeTable (htabulate (ComposeInner . f . HComposeField))
|
||||
|
||||
htraverse f (HComposeTable t) = HComposeTable <$> htraverse (traverseComposeInner f) t
|
||||
|
||||
hdbtype = HComposeTable $ hmap (ComposeInner . liftDatabaseType) hdbtype
|
||||
|
||||
|
||||
data ComposeInner context g a where
|
||||
ComposeInner :: { getComposeInner :: f (g a) } -> ComposeInner (Context f) g a
|
||||
|
||||
|
||||
traverseComposeInner :: Applicative m
|
||||
=> (forall x. f x -> m (g x))
|
||||
-> ComposeInner (Context f) t a -> m (ComposeInner (Context g) t a)
|
||||
traverseComposeInner f (ComposeInner a) =
|
||||
ComposeInner <$> f a
|
||||
|
||||
|
||||
zipComposeInnerWith :: ()
|
||||
=> (forall x. f x -> g x -> h x)
|
||||
-> ComposeInner (Context f) t a -> ComposeInner (Context g) t a -> ComposeInner (Context h) t a
|
||||
zipComposeInnerWith f (ComposeInner a) (ComposeInner b) =
|
||||
ComposeInner $ f a b
|
||||
67
src/Rel8/HTable/HMapTable.hs
Normal file
67
src/Rel8/HTable/HMapTable.hs
Normal file
@ -0,0 +1,67 @@
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language BlockArguments #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language InstanceSigs #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language StandaloneKindSignatures #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
|
||||
module Rel8.HTable.HMapTable ( HMapTable(..), Exp, Eval, MapInfo(..), Precompose(..), HMapTableField(..) ) where
|
||||
|
||||
-- base
|
||||
import Data.Kind ( Type )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Context ( Context, KContext )
|
||||
import Rel8.HTable ( HField, HTable, hdbtype, hfield, htabulate, htraverse )
|
||||
import Rel8.Info ( Info )
|
||||
|
||||
|
||||
type Exp :: Type -> Type
|
||||
|
||||
|
||||
type Exp a = a -> Type
|
||||
|
||||
|
||||
type family Eval (e :: Exp a) :: a
|
||||
|
||||
|
||||
data HMapTable :: (Type -> Exp Type) -> (KContext -> Type) -> KContext -> Type where
|
||||
HMapTable :: { unHMapTable :: t (Context (Precompose f g)) } -> HMapTable f t (Context g)
|
||||
|
||||
|
||||
newtype Precompose :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type where
|
||||
Precompose :: { precomposed :: g (Eval (f x)) } -> Precompose f g x
|
||||
|
||||
|
||||
data HMapTableField :: (Type -> Exp Type) -> (KContext -> Type) -> Type -> Type where
|
||||
HMapTableField :: HField t a -> HMapTableField f t (Eval (f a))
|
||||
|
||||
|
||||
instance (HTable t, MapInfo f) => HTable (HMapTable f t) where
|
||||
type HField (HMapTable f t) = HMapTableField f t
|
||||
|
||||
hfield (HMapTable x) (HMapTableField i) =
|
||||
case hfield x i of
|
||||
Precompose y -> y
|
||||
|
||||
htabulate f = HMapTable $ htabulate (Precompose . f . HMapTableField)
|
||||
|
||||
htraverse :: forall g h m. Applicative m
|
||||
=> (forall x. g x -> m (h x)) -> HMapTable f t (Context g) -> m (HMapTable f t (Context h))
|
||||
htraverse f (HMapTable x) = HMapTable <$> htraverse go x
|
||||
where
|
||||
go :: forall x. Precompose f g x -> m (Precompose f h x)
|
||||
go (Precompose a) = Precompose <$> f a
|
||||
|
||||
hdbtype = HMapTable $ htabulate \i ->
|
||||
case hfield (hdbtype @t) i of
|
||||
x -> Precompose (mapInfo @f x)
|
||||
|
||||
|
||||
class MapInfo f where
|
||||
mapInfo :: Info x -> Info (Eval (f x))
|
||||
@ -1,3 +1,4 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language DeriveGeneric #-}
|
||||
{-# language DerivingStrategies #-}
|
||||
{-# language GADTs #-}
|
||||
@ -5,26 +6,41 @@
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language TypeFamilies #-}
|
||||
|
||||
module Rel8.HTable.HMaybeTable ( HMaybeTable(..) ) where
|
||||
module Rel8.HTable.HMaybeTable ( HMaybeTable(..), MakeNull ) where
|
||||
|
||||
-- base
|
||||
import Data.Kind ( Type )
|
||||
import GHC.Generics ( Generic )
|
||||
|
||||
-- rel8
|
||||
import Rel8.HTable ( HField, HTable, hdbtype, hfield, htabulate, htraverse )
|
||||
import Rel8.HTable.HMapTable ( Eval, Exp, HMapTable, MapInfo( mapInfo ) )
|
||||
import Rel8.HTable.Identity ( HIdentity( unHIdentity, HIdentity ) )
|
||||
import Rel8.Info ( Info( Null, NotNull ), Nullify )
|
||||
|
||||
|
||||
data MakeNull :: Type -> Exp Type
|
||||
|
||||
|
||||
type instance Eval (MakeNull x) = Nullify x
|
||||
|
||||
|
||||
instance MapInfo MakeNull where
|
||||
mapInfo = \case
|
||||
NotNull t -> Null t
|
||||
Null t -> Null t
|
||||
|
||||
|
||||
data HMaybeTable g f = HMaybeTable
|
||||
{ hnullTag :: HIdentity (Maybe Bool) f
|
||||
, htable :: g f
|
||||
, htable :: HMapTable MakeNull g f
|
||||
}
|
||||
deriving stock Generic
|
||||
|
||||
|
||||
data HMaybeField g a where
|
||||
HNullTag :: HMaybeField g (Maybe Bool)
|
||||
HMaybeField :: HField g a -> HMaybeField g a
|
||||
HMaybeField :: HField (HMapTable MakeNull g) a -> HMaybeField g a
|
||||
|
||||
|
||||
instance HTable g => HTable (HMaybeTable g) where
|
||||
|
||||
@ -8,8 +8,8 @@ module Rel8.HTable.Identity ( HIdentity(..) ) where
|
||||
|
||||
-- rel8
|
||||
import Rel8.Context ( Context )
|
||||
import Rel8.DBType ( DBType, typeInformation )
|
||||
import Rel8.HTable ( HTable( HField, htabulate, htraverse, hfield, hdbtype ) )
|
||||
import Rel8.Info ( HasInfo( info ) )
|
||||
|
||||
|
||||
-- | A single-column higher-kinded table. This is primarily useful for
|
||||
@ -22,12 +22,12 @@ data HIdentityField x y where
|
||||
HIdentityField :: HIdentityField x x
|
||||
|
||||
|
||||
instance DBType a => HTable (HIdentity a) where
|
||||
instance HasInfo a => HTable (HIdentity a) where
|
||||
type HField (HIdentity a) = HIdentityField a
|
||||
|
||||
hfield (HIdentity a) HIdentityField = a
|
||||
htabulate f = HIdentity $ f HIdentityField
|
||||
hdbtype = HIdentity typeInformation
|
||||
hdbtype = HIdentity info
|
||||
|
||||
htraverse :: forall f g m. Applicative m => (forall x. f x -> m (g x)) -> HIdentity a (Context f) -> m (HIdentity a (Context g))
|
||||
htraverse f (HIdentity a) = HIdentity <$> f (a :: f a)
|
||||
|
||||
41
src/Rel8/Info.hs
Normal file
41
src/Rel8/Info.hs
Normal file
@ -0,0 +1,41 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language KindSignatures #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
|
||||
module Rel8.Info ( Info(..), HasInfo(..), Nullify ) where
|
||||
|
||||
-- base
|
||||
import Data.Kind ( Type )
|
||||
|
||||
-- rel8
|
||||
import Rel8.DBType ( DBType( typeInformation ) )
|
||||
import Rel8.DatabaseType ( DatabaseType )
|
||||
|
||||
|
||||
data Info :: Type -> Type where
|
||||
NotNull :: Nullify a ~ Maybe a => DatabaseType a -> Info a
|
||||
Null :: DatabaseType a -> Info (Maybe a)
|
||||
|
||||
|
||||
type family Nullify (a :: Type) :: Type where
|
||||
Nullify (Maybe a) = Maybe a
|
||||
Nullify a = Maybe a
|
||||
|
||||
|
||||
class HasInfo a where
|
||||
info :: Info a
|
||||
|
||||
|
||||
instance {-# overlapping #-} DBType a => HasInfo (Maybe a) where
|
||||
info = Null typeInformation
|
||||
|
||||
|
||||
instance (DBType a, Nullify a ~ Maybe a) => HasInfo a where
|
||||
info = NotNull typeInformation
|
||||
@ -3,6 +3,8 @@
|
||||
{-# language GeneralizedNewtypeDeriving #-}
|
||||
{-# language RankNTypes #-}
|
||||
|
||||
{-# options_ghc -Wno-simplifiable-class-constraints #-}
|
||||
|
||||
module Rel8.Query.Order
|
||||
( Order(..)
|
||||
, orderBy
|
||||
@ -28,9 +30,9 @@ import qualified Opaleye.Internal.Order as Opaleye
|
||||
import qualified Opaleye.Internal.QueryArr as Opaleye
|
||||
import qualified Opaleye.Lateral as Opaleye
|
||||
import qualified Opaleye.Order as Opaleye ( orderBy )
|
||||
import Rel8.DBType ( DBType )
|
||||
import Rel8.Expr ( Expr( Expr ), retype )
|
||||
import Rel8.HTable ( htraverse )
|
||||
import Rel8.Info ( HasInfo )
|
||||
import Rel8.Query ( Query, liftOpaleye, mapOpaleye, toOpaleye )
|
||||
import Rel8.Table ( Table, toColumns )
|
||||
import Rel8.Table.Opaleye ( unpackspec )
|
||||
@ -59,7 +61,7 @@ newtype Order a = Order (Opaleye.Order a)
|
||||
--
|
||||
-- >>> select c $ orderBy asc $ values [ lit x | x <- [1..5 :: Int32] ]
|
||||
-- [1,2,3,4,5]
|
||||
asc :: DBType a => Order (Expr a)
|
||||
asc :: HasInfo a => Order (Expr a)
|
||||
asc = Order $ Opaleye.Order (getConst . htraverse f . toColumns)
|
||||
where
|
||||
f :: forall x. Expr x -> Const [(Opaleye.OrderOp, Opaleye.PrimExpr)] (Expr x)
|
||||
@ -76,7 +78,7 @@ asc = Order $ Opaleye.Order (getConst . htraverse f . toColumns)
|
||||
--
|
||||
-- >>> select c $ orderBy desc $ values [ lit x | x <- [1..5 :: Int32] ]
|
||||
-- [5,4,3,2,1]
|
||||
desc :: DBType a => Order (Expr a)
|
||||
desc :: HasInfo a => Order (Expr a)
|
||||
desc = Order $ Opaleye.Order (getConst . htraverse f . toColumns)
|
||||
where
|
||||
f :: forall x. Expr x -> Const [(Opaleye.OrderOp, Opaleye.PrimExpr)] (Expr x)
|
||||
|
||||
@ -11,37 +11,31 @@
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
|
||||
module Rel8.Serializable ( ExprFor, Serializable(..), hasqlRowDecoder ) where
|
||||
module Rel8.Serializable ( ExprFor(..), Serializable, hasqlRowDecoder, lit ) where
|
||||
|
||||
-- base
|
||||
import Control.Applicative ( Applicative( liftA2 ), liftA3 )
|
||||
import Data.Functor.Compose ( Compose( Compose, getCompose ) )
|
||||
import Data.Functor.Identity ( Identity( Identity ), runIdentity )
|
||||
|
||||
-- hasql
|
||||
--
|
||||
import qualified Hasql.Decoders as Hasql
|
||||
|
||||
-- base
|
||||
import Data.Functor.Identity ( Identity( Identity ), runIdentity )
|
||||
|
||||
-- rel8
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
import Rel8.Context ( Context )
|
||||
import Rel8.DBType ( DBType( typeInformation ) )
|
||||
import Rel8.DatabaseType ( DatabaseType( DatabaseType, encode, typeName, decoder ) )
|
||||
import Rel8.DatabaseType.Decoder ( Decoder, runDecoder )
|
||||
import Rel8.Expr ( Expr( Expr ) )
|
||||
import Rel8.DBType ( DBType )
|
||||
import Rel8.DatabaseType ( DatabaseType( decoder ) )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Opaleye ( litExprWith )
|
||||
import Rel8.HTable ( HTable( HField, htraverse, htabulate, hdbtype, hfield ) )
|
||||
import Rel8.Table ( Table, fromColumns )
|
||||
import Rel8.HTable ( HTable( htraverse, htabulate, hdbtype, hfield ) )
|
||||
import Rel8.HTable.HPair ( HPair( HPair ) )
|
||||
import Rel8.HTable.Identity ( HIdentity( HIdentity ) )
|
||||
import Rel8.Info ( HasInfo, Info( Null, NotNull ) )
|
||||
import Rel8.Table ( Columns, Table, fromColumns )
|
||||
|
||||
|
||||
-- | @Serializable@ witnesses the one-to-one correspondence between the type
|
||||
-- @sql@, which contains SQL expressions, and the type @haskell@, which
|
||||
-- contains the Haskell decoding of rows containing @sql@ SQL expressions.
|
||||
class ExprFor expr haskell => Serializable expr haskell | expr -> haskell where
|
||||
lit :: haskell -> expr
|
||||
|
||||
rowParser :: forall f. (Applicative f, Traversable f)
|
||||
=> (forall x. Decoder x -> Decoder (f x))
|
||||
-> Hasql.Row (f haskell)
|
||||
|
||||
|
||||
-- | @ExprFor expr haskell@ witnesses that @expr@ is the "expression
|
||||
@ -55,71 +49,70 @@ class ExprFor expr haskell => Serializable expr haskell | expr -> haskell where
|
||||
-- their to be multiple expression types. Usually this is not the case, but for
|
||||
-- @Maybe a@, we may allow expressions to be either @MaybeTable a'@ (where
|
||||
-- @ExprFor a' a@), or just @Expr (Maybe a)@ (if @a@ is a single column).
|
||||
class Table Expr expr => ExprFor expr haskell
|
||||
class Table Expr expr => ExprFor expr haskell where
|
||||
unpack :: haskell -> Columns expr (Context Identity)
|
||||
pack :: Columns expr (Context Identity) -> haskell
|
||||
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (DBType b, a ~ Expr b) => ExprFor a b
|
||||
instance {-# OVERLAPPABLE #-} (HasInfo b, a ~ Expr b) => ExprFor a b where
|
||||
unpack = HIdentity . pure
|
||||
pack (HIdentity a) = runIdentity a
|
||||
|
||||
|
||||
instance DBType a => ExprFor (Expr (Maybe a)) (Maybe a)
|
||||
instance DBType a => ExprFor (Expr (Maybe a)) (Maybe a) where
|
||||
unpack = HIdentity . pure
|
||||
pack (HIdentity a) = runIdentity a
|
||||
|
||||
|
||||
instance (a ~ (a1, a2), ExprFor a1 b1, ExprFor a2 b2) => ExprFor a (b1, b2)
|
||||
instance (a ~ (a1, a2), ExprFor a1 b1, ExprFor a2 b2) => ExprFor a (b1, b2) where
|
||||
unpack (a, b) = HPair (unpack @a1 a) (unpack @a2 b)
|
||||
pack (HPair a b) = (pack @a1 a, pack @a2 b)
|
||||
|
||||
|
||||
instance (a ~ (a1, a2, a3), ExprFor a1 b1, ExprFor a2 b2, ExprFor a3 b3) => ExprFor a (b1, b2, b3)
|
||||
instance (a ~ (a1, a2, a3), ExprFor a1 b1, ExprFor a2 b2, ExprFor a3 b3) => ExprFor a (b1, b2, b3) where
|
||||
unpack (a, b, c) = HPair (unpack @a1 a) (HPair (unpack @a2 b) (unpack @a3 c))
|
||||
pack (HPair a (HPair b c)) = (pack @a1 a, pack @a2 b, pack @a3 c)
|
||||
|
||||
|
||||
instance (a ~ (a1, a2, a3, a4), ExprFor a1 b1, ExprFor a2 b2, ExprFor a3 b3, ExprFor a4 b4) => ExprFor a (b1, b2, b3, b4)
|
||||
instance (a ~ (a1, a2, a3, a4), ExprFor a1 b1, ExprFor a2 b2, ExprFor a3 b3, ExprFor a4 b4) => ExprFor a (b1, b2, b3, b4) where
|
||||
unpack (a, b, c, d) = HPair (HPair (unpack @a1 a) (unpack @a2 b)) (HPair (unpack @a3 c) (unpack @a4 d))
|
||||
pack (HPair (HPair a b) (HPair c d)) = (pack @a1 a, pack @a2 b, pack @a3 c, pack @a4 d)
|
||||
|
||||
|
||||
instance (HTable t, a ~ t (Context Expr), identity ~ Context Identity) => ExprFor a (t identity)
|
||||
instance (HTable t, a ~ t (Context Expr), identity ~ Context Identity) => ExprFor a (t identity) where
|
||||
unpack = id
|
||||
pack = id
|
||||
|
||||
|
||||
-- | Any higher-kinded records can be @SELECT@ed, as long as we know how to
|
||||
-- decode all of the records constituent part's.
|
||||
instance (s ~ t, expr ~ Context Expr, identity ~ Context Identity, HTable t) => Serializable (s expr) (t identity) where
|
||||
rowParser liftDecoder = getCompose $ htraverse (fmap pure) $ htabulate (f liftDecoder)
|
||||
where
|
||||
f :: forall f x. (forall y. Decoder y -> Decoder (f y)) -> HField t x -> Compose Hasql.Row f x
|
||||
f liftDecoder_ i = case hfield hdbtype i of
|
||||
databaseType -> Compose $ runDecoder $ liftDecoder_ $ decoder databaseType
|
||||
|
||||
lit t =
|
||||
fromColumns $ htabulate \i ->
|
||||
case (hfield (hdbtype @t) i, hfield t i) of
|
||||
(databaseType, Identity x) -> litExprWith databaseType x
|
||||
|
||||
|
||||
instance (DBType a, a ~ b) => Serializable (Expr a) b where
|
||||
rowParser liftDecoder =
|
||||
runDecoder (liftDecoder (decoder (typeInformation @a)))
|
||||
|
||||
lit = Expr . Opaleye.CastExpr typeName . encode
|
||||
where
|
||||
DatabaseType{ encode, typeName } = typeInformation
|
||||
instance (a ~ b, HasInfo b) => Serializable (Expr a) b where
|
||||
|
||||
|
||||
instance (Serializable a1 b1, Serializable a2 b2) => Serializable (a1, a2) (b1, b2) where
|
||||
rowParser liftValue =
|
||||
liftA2 (liftA2 (,)) (rowParser @a1 liftValue) (rowParser @a2 liftValue)
|
||||
|
||||
lit (a, b) = (lit a, lit b)
|
||||
|
||||
|
||||
instance (Serializable a1 b1, Serializable a2 b2, Serializable a3 b3) => Serializable (a1, a2, a3) (b1, b2, b3) where
|
||||
rowParser liftValue =
|
||||
liftA3 (liftA3 (,,)) (rowParser @a1 liftValue) (rowParser @a2 liftValue) (rowParser @a3 liftValue)
|
||||
|
||||
lit (a, b, c) = (lit a, lit b, lit c)
|
||||
|
||||
|
||||
instance (Serializable a1 b1, Serializable a2 b2, Serializable a3 b3, Serializable a4 b4) => Serializable (a1, a2, a3, a4) (b1, b2, b3, b4) where
|
||||
rowParser liftValue =
|
||||
(\a b c d -> (,,,) <$> a <*> b <*> c <*> d) <$> rowParser @a1 liftValue <*> rowParser @a2 liftValue <*> rowParser @a3 liftValue <*> rowParser @a4 liftValue
|
||||
|
||||
lit (a, b, c, d) = (lit a, lit b, lit c, lit d)
|
||||
|
||||
|
||||
hasqlRowDecoder :: forall row haskell. Serializable row haskell => Hasql.Row haskell
|
||||
hasqlRowDecoder = runIdentity <$> rowParser @row (fmap Identity)
|
||||
lit :: forall exprs haskell. Serializable exprs haskell => haskell -> exprs
|
||||
lit x = fromColumns $ htabulate \i ->
|
||||
litExprWith (hfield hdbtype i) $ runIdentity $ hfield unpacked i
|
||||
where
|
||||
unpacked = unpack @exprs x
|
||||
|
||||
|
||||
hasqlRowDecoder :: forall exprs haskell. Serializable exprs haskell => Hasql.Row haskell
|
||||
hasqlRowDecoder = pack @exprs <$> htraverse (fmap Identity) decoders
|
||||
where
|
||||
decoders :: Columns exprs (Context Hasql.Row)
|
||||
decoders = htabulate \i ->
|
||||
case hfield hdbtype i of
|
||||
NotNull t -> Hasql.column (Hasql.nonNullable (decoder t))
|
||||
Null t -> Hasql.column (Hasql.nullable (decoder t))
|
||||
|
||||
@ -14,11 +14,11 @@ import Data.Kind ( Type )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Context ( Context, KContext )
|
||||
import Rel8.DBType ( DBType )
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.HTable ( HTable )
|
||||
import Rel8.HTable.HPair ( HPair( HPair ) )
|
||||
import Rel8.HTable.Identity ( HIdentity( HIdentity, unHIdentity ) )
|
||||
import Rel8.Info ( HasInfo )
|
||||
|
||||
|
||||
-- | Types that represent SQL tables.
|
||||
@ -33,7 +33,7 @@ class HTable (Columns t) => Table (context :: Type -> Type) (t :: Type) | t -> c
|
||||
fromColumns :: Columns t (Context context) -> t
|
||||
|
||||
|
||||
instance (DBType a, expr ~ Expr) => Table expr (Expr a) where
|
||||
instance (HasInfo a, expr ~ Expr) => Table expr (Expr a) where
|
||||
type Columns (Expr a) = HIdentity a
|
||||
toColumns = HIdentity
|
||||
fromColumns = unHIdentity
|
||||
|
||||
@ -1,4 +1,7 @@
|
||||
{-# language BlockArguments #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language LambdaCase #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
@ -8,60 +11,72 @@
|
||||
|
||||
{-# options_ghc -Wno-orphans #-}
|
||||
|
||||
module Rel8.Table.ListTable ( ListTable( ListTable ) ) where
|
||||
module Rel8.Table.ListTable ( ListTable( ListTable ), ListOf ) where
|
||||
|
||||
-- base
|
||||
import Control.Applicative ( ZipList( ZipList, getZipList ) )
|
||||
import Data.Functor.Compose ( Compose( Compose, getCompose ) )
|
||||
import Data.Functor.Identity ( Identity( runIdentity ) )
|
||||
import Data.Kind ( Type )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Context ( Context )
|
||||
import Rel8.DBFunctor ( DBFunctor( liftDatabaseType ) )
|
||||
import Rel8.DatabaseType.Decoder ( listDecoder )
|
||||
import Rel8.DatabaseType ( listOfNotNull, listOfNull )
|
||||
import Rel8.Expr ( Expr, binaryOperator )
|
||||
import Rel8.Expr.Opaleye ( listOfExprs, litExprWith )
|
||||
import Rel8.HTable ( HTable( hdbtype, htabulate, hfield ), hzipWith )
|
||||
import Rel8.HTable.HComposeTable
|
||||
( ComposeInner( ComposeInner )
|
||||
, HComposeTable( HComposeTable )
|
||||
, zipComposeInnerWith
|
||||
import Rel8.Expr.Opaleye ( litExprWith )
|
||||
import Rel8.HTable ( HTable( hdbtype, htabulate, hfield ), htraverse, hzipWith )
|
||||
import Rel8.HTable.HMapTable
|
||||
( Eval
|
||||
, Exp
|
||||
, HMapTable
|
||||
, HMapTableField( HMapTableField )
|
||||
, MapInfo( mapInfo )
|
||||
, precomposed
|
||||
, unHMapTable
|
||||
)
|
||||
import Rel8.Serializable ( ExprFor, Serializable( lit, rowParser ) )
|
||||
import Rel8.Info ( Info( NotNull, Null ) )
|
||||
import Rel8.Serializable ( ExprFor( pack, unpack ), Serializable )
|
||||
import Rel8.Table ( Table( Columns, toColumns, fromColumns ) )
|
||||
|
||||
|
||||
data ListOf :: Type -> Exp Type
|
||||
|
||||
|
||||
type instance Eval (ListOf x) = [x]
|
||||
|
||||
|
||||
instance MapInfo ListOf where
|
||||
mapInfo = \case
|
||||
NotNull t -> NotNull $ listOfNotNull t
|
||||
Null t -> NotNull $ listOfNull t
|
||||
|
||||
|
||||
-- | A @ListTable@ value contains zero or more instances of @a@. You construct
|
||||
-- @ListTable@s with 'many' or 'listAgg'.
|
||||
newtype ListTable a = ListTable (Columns a (Context (ComposeInner (Context Expr) [])))
|
||||
newtype ListTable a = ListTable (HMapTable ListOf (Columns a) (Context Expr))
|
||||
|
||||
|
||||
instance Table Expr a => Semigroup (ListTable a) where
|
||||
ListTable a <> ListTable b =
|
||||
ListTable (hzipWith (zipComposeInnerWith (binaryOperator "||")) a b)
|
||||
ListTable (hzipWith (binaryOperator "||") a b)
|
||||
|
||||
|
||||
instance Table Expr a => Monoid (ListTable a) where
|
||||
mempty = ListTable $ htabulate $ \field ->
|
||||
case hfield hdbtype field of
|
||||
databaseType -> ComposeInner $ litExprWith (liftDatabaseType databaseType) []
|
||||
mempty = ListTable $ htabulate $ \i@HMapTableField {} ->
|
||||
litExprWith (hfield hdbtype i) []
|
||||
|
||||
|
||||
instance (f ~ Expr, Table f a) => Table f (ListTable a) where
|
||||
type Columns (ListTable a) = HComposeTable [] (Columns a)
|
||||
type Columns (ListTable a) = HMapTable ListOf (Columns a)
|
||||
|
||||
toColumns (ListTable a) = HComposeTable a
|
||||
fromColumns (HComposeTable a) = ListTable a
|
||||
toColumns (ListTable a) = a
|
||||
fromColumns a = ListTable a
|
||||
|
||||
|
||||
instance (a ~ ListTable x, Table Expr (ListTable x), ExprFor x b) => ExprFor a [b]
|
||||
instance (a ~ ListTable x, Table Expr (ListTable x), ExprFor x b) => ExprFor a [b] where
|
||||
pack (unHMapTable -> xs) =
|
||||
pack @x <$> htraverse (sequenceA . precomposed) xs
|
||||
|
||||
unpack (fmap (unpack @x) -> xs) = htabulate \(HMapTableField i) ->
|
||||
pure (fmap (runIdentity . flip hfield i) xs)
|
||||
|
||||
|
||||
instance Serializable a b => Serializable (ListTable a) [b] where
|
||||
lit (map (lit @a) -> xs) = ListTable $ htabulate $ \field ->
|
||||
case hfield hdbtype field of
|
||||
databaseType -> ComposeInner $ listOfExprs databaseType $
|
||||
map (\x -> hfield (toColumns x) field) xs
|
||||
|
||||
rowParser liftHasqlDecoder =
|
||||
fmap getZipList . getCompose <$>
|
||||
rowParser @a (\x -> Compose <$> liftHasqlDecoder (fmap ZipList (listDecoder x)))
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# language BlockArguments #-}
|
||||
{-# language DeriveFunctor #-}
|
||||
{-# language DerivingStrategies #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
@ -24,12 +25,11 @@ module Rel8.Table.MaybeTable
|
||||
) where
|
||||
|
||||
-- base
|
||||
import Control.Applicative ( liftA2 )
|
||||
import Data.Functor.Compose ( Compose( Compose, getCompose ) )
|
||||
import Data.Functor.Identity ( Identity( Identity ) )
|
||||
import Prelude
|
||||
( Applicative( (<*>), pure )
|
||||
, Bool( True, False )
|
||||
, Functor( fmap )
|
||||
, Functor
|
||||
, Maybe( Just, Nothing )
|
||||
, Monad( return, (>>=) )
|
||||
, ($)
|
||||
@ -48,19 +48,23 @@ import qualified Opaleye.Internal.QueryArr as Opaleye
|
||||
import qualified Opaleye.Internal.Tag as Opaleye
|
||||
import qualified Opaleye.Internal.Unpackspec as Opaleye
|
||||
import qualified Opaleye.Lateral as Opaleye
|
||||
import Rel8.DBType ( DBType( typeInformation ) )
|
||||
import Rel8.DBType.DBEq ( (==.) )
|
||||
import Rel8.DatabaseType ( DatabaseType( decoder ), nullDatabaseType )
|
||||
import Rel8.DatabaseType.Decoder ( acceptNull, runDecoder )
|
||||
import Rel8.Expr ( Expr, liftOpNull, toPrimExpr, unsafeCoerceExpr )
|
||||
import Rel8.Expr.Bool ( (&&.), not_ )
|
||||
import Rel8.Expr.Null ( isNull, isNull, null )
|
||||
import Rel8.Expr.Opaleye ( litExpr, litExprWith )
|
||||
import Rel8.HTable ( HTable( htabulate, HField, hfield, hdbtype ) )
|
||||
import Rel8.HTable.HMaybeTable ( HMaybeTable( HMaybeTable ) )
|
||||
import Rel8.HTable ( HTable( htabulate, HField, hfield, hdbtype ), hmap )
|
||||
import Rel8.HTable.HMapTable
|
||||
( HMapTable( HMapTable )
|
||||
, HMapTableField( HMapTableField )
|
||||
, Precompose( Precompose )
|
||||
, mapInfo
|
||||
)
|
||||
import Rel8.HTable.HMaybeTable ( HMaybeTable( HMaybeTable, hnullTag, htable ), MakeNull )
|
||||
import Rel8.HTable.Identity ( HIdentity( HIdentity ) )
|
||||
import Rel8.Info ( Info( Null, NotNull ) )
|
||||
import Rel8.Query ( Query, mapOpaleye, where_ )
|
||||
import Rel8.Serializable ( ExprFor, Serializable( rowParser, lit ) )
|
||||
import Rel8.Serializable ( ExprFor( pack, unpack ), Serializable, lit )
|
||||
import Rel8.Table ( Table( Columns, fromColumns, toColumns ) )
|
||||
import Rel8.Table.Bool ( ifThenElse_ )
|
||||
import Rel8.Table.Opaleye ( unpackspec )
|
||||
@ -101,11 +105,47 @@ instance Monad MaybeTable where
|
||||
instance Table Expr a => Table Expr (MaybeTable a) where
|
||||
type Columns (MaybeTable a) = HMaybeTable (Columns a)
|
||||
|
||||
toColumns (MaybeTable x y) = HMaybeTable (HIdentity x) (toColumns y)
|
||||
fromColumns (HMaybeTable (HIdentity x) y) = MaybeTable x (fromColumns y)
|
||||
toColumns (MaybeTable x y) =
|
||||
HMaybeTable (HIdentity x) (HMapTable $ hmap (Precompose . unsafeCoerceExpr) (toColumns y))
|
||||
|
||||
fromColumns (HMaybeTable (HIdentity x) (HMapTable y)) =
|
||||
MaybeTable x (fromColumns (hmap (\(Precompose e) -> unsafeCoerceExpr e) y))
|
||||
|
||||
|
||||
instance (ExprFor a b, Table Expr a) => ExprFor (MaybeTable a) (Maybe b)
|
||||
instance (ExprFor a b, Table Expr a) => ExprFor (MaybeTable a) (Maybe b) where
|
||||
pack HMaybeTable{ hnullTag = HIdentity (Identity nullTag), htable = HMapTable t } =
|
||||
case nullTag of
|
||||
Just True -> Just $ pack @a $ htabulate \i ->
|
||||
case hfield hdbtype i of
|
||||
NotNull _ ->
|
||||
case hfield t i of
|
||||
Precompose (Identity Nothing) -> error "Impossible"
|
||||
Precompose (Identity (Just x)) -> pure x
|
||||
|
||||
Null _ ->
|
||||
case hfield t i of
|
||||
Precompose (Identity x) -> pure x
|
||||
|
||||
_ -> Nothing
|
||||
|
||||
unpack = \case
|
||||
Just a -> HMaybeTable
|
||||
{ hnullTag = HIdentity (pure (Just True))
|
||||
, htable = htabulate \(HMapTableField i) ->
|
||||
case hfield hdbtype i of
|
||||
NotNull _ -> Just <$> hfield unpacked i
|
||||
Null _ -> hfield unpacked i
|
||||
}
|
||||
where
|
||||
unpacked = unpack @a a
|
||||
|
||||
Nothing -> HMaybeTable
|
||||
{ hnullTag = HIdentity (pure Nothing)
|
||||
, htable = htabulate \(HMapTableField i) ->
|
||||
case hfield hdbtype i of
|
||||
NotNull _ -> pure Nothing
|
||||
Null _ -> pure Nothing
|
||||
}
|
||||
|
||||
|
||||
-- |
|
||||
@ -118,19 +158,6 @@ instance (ExprFor a b, Table Expr a) => ExprFor (MaybeTable a) (Maybe b)
|
||||
-- > select c $ pure (noTable :: MaybeTable (Expr (Maybe Bool)))
|
||||
-- [Nothing]
|
||||
instance Serializable a b => Serializable (MaybeTable a) (Maybe b) where
|
||||
rowParser liftDecoder = do
|
||||
tags <- runDecoder (liftDecoder (decoder (typeInformation @(Maybe Bool))))
|
||||
rows <- rowParser @a (fmap Compose . liftDecoder . acceptNull)
|
||||
return $ liftA2 f tags (getCompose rows)
|
||||
where
|
||||
f :: Maybe Bool -> Maybe b -> Maybe b
|
||||
f (Just True) (Just row) = Just row
|
||||
f (Just True) Nothing = error "TODO"
|
||||
f _ _ = Nothing
|
||||
|
||||
lit = \case
|
||||
Nothing -> noTable
|
||||
Just x -> pure $ lit x
|
||||
|
||||
|
||||
-- | @bindMaybeTable f x@ is similar to the monadic bind (@>>=@) operation. It
|
||||
@ -260,5 +287,6 @@ noTable = MaybeTable (lit Nothing) $ fromColumns $ htabulate f
|
||||
where
|
||||
f :: forall x. HField (Columns a) x -> Expr x
|
||||
f i =
|
||||
case hfield (hdbtype @(Columns a)) i of
|
||||
databaseType -> unsafeCoerceExpr (litExprWith (nullDatabaseType databaseType) (Nothing :: Maybe x))
|
||||
case hfield hdbtype i of
|
||||
NotNull{} -> unsafeCoerceExpr (litExprWith (mapInfo @MakeNull (hfield hdbtype i)) Nothing)
|
||||
Null{} -> unsafeCoerceExpr (litExprWith (mapInfo @MakeNull (hfield hdbtype i)) Nothing)
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# language BlockArguments #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language LambdaCase #-}
|
||||
@ -11,64 +12,60 @@
|
||||
|
||||
{-# options_ghc -Wno-orphans #-}
|
||||
|
||||
module Rel8.Table.NonEmptyTable ( NonEmptyTable(..) ) where
|
||||
module Rel8.Table.NonEmptyTable ( NonEmptyTable(..), NonEmptyList ) where
|
||||
|
||||
-- base
|
||||
import Control.Applicative ( ZipList( ZipList, getZipList ) )
|
||||
import Data.Functor.Compose ( Compose( Compose, getCompose ) )
|
||||
import Data.Functor.Identity ( Identity( runIdentity ) )
|
||||
import Data.Kind ( Type )
|
||||
import Data.List.NonEmpty ( NonEmpty, toList )
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
-- rel8
|
||||
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
|
||||
import Rel8.Context ( Context )
|
||||
import Rel8.DBFunctor ( DBFunctor( liftDatabaseType ) )
|
||||
import Rel8.DatabaseType ( DatabaseType( typeName ) )
|
||||
import Rel8.DatabaseType.Decoder ( listDecoder )
|
||||
import Rel8.Expr ( Expr( toPrimExpr ), binaryOperator, fromPrimExpr )
|
||||
import Rel8.HTable ( HTable( hfield, htabulate, hdbtype ), hzipWith )
|
||||
import Rel8.HTable.HComposeTable
|
||||
( ComposeInner( ComposeInner )
|
||||
, HComposeTable( HComposeTable )
|
||||
, zipComposeInnerWith
|
||||
)
|
||||
import Rel8.Serializable ( ExprFor, Serializable( rowParser, lit ) )
|
||||
import Rel8.DatabaseType ( nonEmptyNotNull, nonEmptyNull )
|
||||
import Rel8.Expr ( Expr, binaryOperator )
|
||||
import Rel8.HTable ( HTable( hfield, htabulate, htraverse ), hzipWith )
|
||||
import Rel8.HTable.HMapTable ( Eval, Exp, HMapTable, HMapTableField( HMapTableField ), MapInfo( mapInfo ), precomposed, unHMapTable )
|
||||
import Rel8.Info ( Info( NotNull, Null ) )
|
||||
import Rel8.Serializable ( ExprFor( pack, unpack ), Serializable )
|
||||
import Rel8.Table ( Table( Columns, fromColumns, toColumns ) )
|
||||
|
||||
|
||||
data NonEmptyList :: Type -> Exp Type
|
||||
|
||||
|
||||
type instance Eval (NonEmptyList a) = NonEmpty a
|
||||
|
||||
|
||||
instance MapInfo NonEmptyList where
|
||||
mapInfo = \case
|
||||
NotNull t -> NotNull $ nonEmptyNotNull t
|
||||
Null t -> NotNull $ nonEmptyNull t
|
||||
|
||||
|
||||
-- | A @NonEmptyTable@ value contains one or more instances of @a@. You
|
||||
-- construct @NonEmptyTable@s with 'some' or 'nonEmptyAgg'.
|
||||
newtype NonEmptyTable a = NonEmptyTable (Columns a (Context (ComposeInner (Context Expr) NonEmpty)))
|
||||
newtype NonEmptyTable a = NonEmptyTable (HMapTable NonEmptyList (Columns a) (Context Expr))
|
||||
|
||||
|
||||
instance (f ~ Expr, Table f a) => Table f (NonEmptyTable a) where
|
||||
type Columns (NonEmptyTable a) = HComposeTable NonEmpty (Columns a)
|
||||
type Columns (NonEmptyTable a) = HMapTable NonEmptyList (Columns a)
|
||||
|
||||
toColumns (NonEmptyTable a) = HComposeTable a
|
||||
fromColumns (HComposeTable a) = NonEmptyTable a
|
||||
toColumns (NonEmptyTable a) = a
|
||||
fromColumns = NonEmptyTable
|
||||
|
||||
|
||||
instance (a ~ NonEmptyTable x, Table Expr (NonEmptyTable x), ExprFor x b) => ExprFor a (NonEmpty b)
|
||||
instance (Serializable x b, a ~ NonEmptyTable x, Table Expr (NonEmptyTable x)) => ExprFor a (NonEmpty b) where
|
||||
pack (unHMapTable -> xs) = NonEmpty.fromList $ getZipList $ pack @x <$> htraverse (fmap pure . ZipList . toList . runIdentity . precomposed) xs
|
||||
|
||||
unpack (fmap (unpack @x) -> xs) = htabulate \(HMapTableField i) ->
|
||||
pure (fmap (runIdentity . flip hfield i) xs)
|
||||
|
||||
|
||||
instance Serializable a b => Serializable (NonEmptyTable a) (NonEmpty b) where
|
||||
lit (fmap (lit @a) -> xs) = NonEmptyTable $ htabulate $ \field ->
|
||||
case hfield hdbtype field of
|
||||
databaseType -> ComposeInner $ nonEmptyOf databaseType $
|
||||
fmap (\x -> hfield (toColumns x) field) xs
|
||||
where
|
||||
nonEmptyOf :: DatabaseType x -> NonEmpty (Expr x) -> Expr (NonEmpty x)
|
||||
nonEmptyOf databaseType as = fromPrimExpr $
|
||||
Opaleye.CastExpr array $
|
||||
Opaleye.ArrayExpr (fmap toPrimExpr (toList as))
|
||||
where
|
||||
array = typeName (liftDatabaseType @NonEmpty databaseType)
|
||||
|
||||
rowParser liftHasqlDecoder =
|
||||
fmap (NonEmpty.fromList . getZipList) . getCompose <$>
|
||||
rowParser @a (\x -> Compose <$> liftHasqlDecoder (fmap ZipList (listDecoder x)))
|
||||
|
||||
|
||||
instance Table Expr a => Semigroup (NonEmptyTable a) where
|
||||
NonEmptyTable a <> NonEmptyTable b =
|
||||
NonEmptyTable (hzipWith (zipComposeInnerWith (binaryOperator "||")) a b)
|
||||
NonEmptyTable (hzipWith (binaryOperator "||") a b)
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# language BlockArguments #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
@ -17,7 +18,8 @@ import qualified Opaleye.Internal.Values as Opaleye
|
||||
import Rel8.Context ( Context )
|
||||
import Rel8.DatabaseType ( DatabaseType( DatabaseType, typeName ) )
|
||||
import Rel8.Expr ( Expr, fromPrimExpr, toPrimExpr, traversePrimExpr, unsafeCastExpr )
|
||||
import Rel8.HTable ( HTable( HField, hfield, htraverse, htabulate ), hdbtype )
|
||||
import Rel8.HTable ( HTable( HField, hfield, htraverse, htabulate, hdbtype ) )
|
||||
import Rel8.Info ( Info( Null, NotNull ) )
|
||||
import Rel8.Table ( Columns, Table( toColumns, fromColumns ) )
|
||||
import Rel8.Table.Congruent ( traverseTable, zipTablesWithM )
|
||||
|
||||
@ -31,7 +33,9 @@ unpackspec =
|
||||
addCasts columns = htabulate go
|
||||
where
|
||||
go :: forall x. HField f x -> Expr x
|
||||
go i = unsafeCastExpr (typeName (hfield hdbtype i)) (hfield columns i)
|
||||
go i = case hfield hdbtype i of
|
||||
NotNull t -> unsafeCastExpr (typeName t) (hfield columns i)
|
||||
Null t -> unsafeCastExpr (typeName t) (hfield columns i)
|
||||
|
||||
|
||||
binaryspec :: Table Expr a => Opaleye.Binaryspec a a
|
||||
@ -55,7 +59,8 @@ valuesspec = Opaleye.ValuesspecSafe packmap unpackspec
|
||||
htraverse (traversePrimExpr f) $
|
||||
htabulate @(Columns expr) @Expr \i ->
|
||||
case hfield (hdbtype @(Columns expr)) i of
|
||||
databaseType -> fromPrimExpr $ nullPrimExpr databaseType
|
||||
NotNull databaseType -> fromPrimExpr $ nullPrimExpr databaseType
|
||||
Null databaseType -> fromPrimExpr $ nullPrimExpr databaseType
|
||||
where
|
||||
nullPrimExpr :: DatabaseType a -> Opaleye.PrimExpr
|
||||
nullPrimExpr DatabaseType{ typeName } =
|
||||
|
||||
@ -12,8 +12,8 @@ import Data.Kind ( Type )
|
||||
import Data.String ( IsString( fromString ) )
|
||||
|
||||
-- rel8
|
||||
import Rel8.DBType ( DBType )
|
||||
import Rel8.HTable.Identity ( HIdentity( HIdentity, unHIdentity ) )
|
||||
import Rel8.Info ( HasInfo )
|
||||
import Rel8.Table ( Table( Columns, fromColumns, toColumns ) )
|
||||
|
||||
|
||||
@ -44,7 +44,7 @@ instance IsString (ColumnSchema a) where
|
||||
fromString = ColumnSchema
|
||||
|
||||
|
||||
instance (DBType a, f ~ ColumnSchema) => Table f (ColumnSchema a) where
|
||||
instance (HasInfo a, f ~ ColumnSchema) => Table f (ColumnSchema a) where
|
||||
type Columns (ColumnSchema a) = HIdentity a
|
||||
toColumns = HIdentity
|
||||
fromColumns = unHIdentity
|
||||
|
||||
@ -399,13 +399,13 @@ testDBType getTestDatabase = testGroup "DBType instances"
|
||||
]
|
||||
|
||||
where
|
||||
dbTypeTest :: (Eq a, Rel8.DBType a, Show a) => TestName -> Gen a -> TestTree
|
||||
dbTypeTest :: (Eq a, Rel8.HasInfo a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
|
||||
dbTypeTest name generator = testGroup name
|
||||
[ databasePropertyTest name (t (==) generator) getTestDatabase
|
||||
, databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
|
||||
]
|
||||
|
||||
t :: forall a b. (Rel8.DBType a, Show a) => (a -> a -> Bool) -> Gen a -> ((Connection -> TestT IO ()) -> PropertyT IO b) -> PropertyT IO b
|
||||
t :: forall a b. (Rel8.HasInfo a, Show a) => (a -> a -> Bool) -> Gen a -> ((Connection -> TestT IO ()) -> PropertyT IO b) -> PropertyT IO b
|
||||
t eq generator transaction = do
|
||||
x <- forAll generator
|
||||
|
||||
@ -445,7 +445,7 @@ testDBEq getTestDatabase = testGroup "DBEq instances"
|
||||
]
|
||||
|
||||
where
|
||||
dbEqTest :: (Eq a, Show a, Rel8.DBEq a) => TestName -> Gen a -> TestTree
|
||||
dbEqTest :: (Eq a, Show a, Rel8.DBEq a, Rel8.DBType a) => TestName -> Gen a -> TestTree
|
||||
dbEqTest name generator = testGroup name
|
||||
[ databasePropertyTest name (t generator) getTestDatabase
|
||||
, databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
|
||||
|
||||
Loading…
Reference in New Issue
Block a user