mirror of
https://github.com/circuithub/rel8.git
synced 2024-08-18 04:10:25 +03:00
Rename OuterJoin to HMaybe and add HList and HNonEmpty
I've also updated these to take a `a :: Type` rather than a `t :: (Type -> Type) -> Type`. This is more general and means `HMaybe` can replace both `OuterJoin` and `OuterJoin2` from the old Rel8.
This commit is contained in:
parent
8fb5051c1d
commit
98687b592b
56
src/Rel8.hs
56
src/Rel8.hs
@ -54,7 +54,6 @@ module Rel8
|
|||||||
|
|
||||||
-- ** Table schemas
|
-- ** Table schemas
|
||||||
, Column
|
, Column
|
||||||
, OuterJoin
|
|
||||||
, TableSchema(..)
|
, TableSchema(..)
|
||||||
, ColumnSchema
|
, ColumnSchema
|
||||||
|
|
||||||
@ -119,8 +118,7 @@ module Rel8
|
|||||||
, exceptAll
|
, exceptAll
|
||||||
|
|
||||||
-- ** Optional 'Query's
|
-- ** Optional 'Query's
|
||||||
, optional
|
, MaybeTable, HMaybe, optional
|
||||||
, MaybeTable
|
|
||||||
, maybeTable
|
, maybeTable
|
||||||
, noTable
|
, noTable
|
||||||
, catMaybeTable
|
, catMaybeTable
|
||||||
@ -135,8 +133,8 @@ module Rel8
|
|||||||
, DBMax (max)
|
, DBMax (max)
|
||||||
|
|
||||||
-- *** List aggregation
|
-- *** List aggregation
|
||||||
, ListTable, many
|
, ListTable, HList, many
|
||||||
, NonEmptyTable, some
|
, NonEmptyTable, HNonEmpty, some
|
||||||
|
|
||||||
-- ** Ordering
|
-- ** Ordering
|
||||||
, orderBy
|
, orderBy
|
||||||
@ -881,12 +879,6 @@ type family Column (context :: (Type -> Type)) (a :: Type) :: Type where
|
|||||||
Column f a = f a
|
Column f a = f a
|
||||||
|
|
||||||
|
|
||||||
type family OuterJoin (context :: Type -> Type) (t :: (Type -> Type) -> Type) :: Type where
|
|
||||||
OuterJoin Identity t = Maybe (t Identity)
|
|
||||||
OuterJoin Expr t = MaybeTable (t Expr)
|
|
||||||
OuterJoin f t = HMaybeTable (GRep t) (Context f)
|
|
||||||
|
|
||||||
|
|
||||||
-- | The @C@ newtype simply wraps 'Column', but this allows us to work around
|
-- | The @C@ newtype simply wraps 'Column', but this allows us to work around
|
||||||
-- injectivity problems of functions that return type family applications.
|
-- injectivity problems of functions that return type family applications.
|
||||||
newtype C f x = MkC { toColumn :: Column f x }
|
newtype C f x = MkC { toColumn :: Column f x }
|
||||||
@ -1015,6 +1007,7 @@ instance (GHigherKindedTableImpl context f, GHigherKindedTableImpl context g) =>
|
|||||||
ghigherKindedTo (x :*: y) = HPair (ghigherKindedTo @context @f x) (ghigherKindedTo @context @g y)
|
ghigherKindedTo (x :*: y) = HPair (ghigherKindedTo @context @f x) (ghigherKindedTo @context @g y)
|
||||||
ghigherKindedFrom (HPair x y) = ghigherKindedFrom @context @f x :*: ghigherKindedFrom @context @g y
|
ghigherKindedFrom (HPair x y) = ghigherKindedFrom @context @f x :*: ghigherKindedFrom @context @g y
|
||||||
|
|
||||||
|
|
||||||
instance Table context a => GHigherKindedTableImpl context (K1 i a) where
|
instance Table context a => GHigherKindedTableImpl context (K1 i a) where
|
||||||
type GColumns (K1 i a) = Columns a
|
type GColumns (K1 i a) = Columns a
|
||||||
ghigherKindedTo (K1 a) = toColumns a
|
ghigherKindedTo (K1 a) = toColumns a
|
||||||
@ -1224,14 +1217,14 @@ their to be multiple expression types. Usually this is not the case, but for
|
|||||||
@ExprFor a' a@), or just @Expr (Maybe a)@ (if @a@ is a single column).
|
@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
|
||||||
instance {-# OVERLAPPABLE #-} (DBType b, a ~ Expr b) => ExprFor a b
|
instance {-# OVERLAPPABLE #-} (DBType b, a ~ Expr b) => ExprFor a b
|
||||||
instance DBType a => ExprFor (Expr (Maybe a)) (Maybe a)
|
instance DBType a => ExprFor (Expr (Maybe a)) (Maybe a)
|
||||||
instance (ExprFor a b, Table Expr a) => ExprFor (MaybeTable a) (Maybe b)
|
instance (ExprFor a b, Table Expr a) => ExprFor (MaybeTable a) (Maybe b)
|
||||||
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]
|
||||||
instance (a ~ NonEmptyTable x, Table Expr (NonEmptyTable x), ExprFor x b) => ExprFor a (NonEmpty b)
|
instance (a ~ NonEmptyTable x, Table Expr (NonEmptyTable x), ExprFor x b) => ExprFor a (NonEmpty b)
|
||||||
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)
|
||||||
instance (HigherKindedTable t, a ~ t (Context Expr), identity ~ (Context Identity)) => ExprFor a (t identity)
|
instance (HigherKindedTable t, a ~ t (Context Expr), identity ~ Context Identity) => ExprFor a (t identity)
|
||||||
instance (GHigherKindedTable t, a ~ t Expr, identity ~ Identity) => ExprFor a (t identity)
|
instance (GHigherKindedTable t, a ~ t Expr, identity ~ Identity) => ExprFor a (t identity)
|
||||||
|
|
||||||
|
|
||||||
-- | Any higher-kinded records can be @SELECT@ed, as long as we know how to
|
-- | Any higher-kinded records can be @SELECT@ed, as long as we know how to
|
||||||
@ -1341,6 +1334,12 @@ instance Table Expr a => Table Expr (MaybeTable a) where
|
|||||||
fromColumns (HMaybeTable (HIdentity x) y) = MaybeTable x (fromColumns y)
|
fromColumns (HMaybeTable (HIdentity x) y) = MaybeTable x (fromColumns y)
|
||||||
|
|
||||||
|
|
||||||
|
type family HMaybe (context :: Type -> Type) (a :: Type) :: Type where
|
||||||
|
HMaybe Identity a = Maybe a
|
||||||
|
HMaybe Expr a = MaybeTable a
|
||||||
|
HMaybe f a = HMaybeTable (Columns a) (Context f)
|
||||||
|
|
||||||
|
|
||||||
-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
|
-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
|
||||||
maybeTable
|
maybeTable
|
||||||
:: Table Expr b
|
:: Table Expr b
|
||||||
@ -2341,6 +2340,12 @@ instance Table Expr a => Monoid (ListTable a) where
|
|||||||
MkC Dict -> MkC $ ComposeInner $ monolit []
|
MkC Dict -> MkC $ ComposeInner $ monolit []
|
||||||
|
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
|
||||||
-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0
|
-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0
|
||||||
-- rows, this function will produce a 'Query' that returns one row containing
|
-- rows, this function will produce a 'Query' that returns one row containing
|
||||||
-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will
|
-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will
|
||||||
@ -2395,6 +2400,12 @@ instance Table Expr a => Semigroup (NonEmptyTable a) where
|
|||||||
NonEmptyTable (hzipWith (zipComposeInnerWith (zipCWith (binaryOperator "||"))) a b)
|
NonEmptyTable (hzipWith (zipComposeInnerWith (zipCWith (binaryOperator "||"))) a b)
|
||||||
|
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
|
||||||
-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns
|
-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns
|
||||||
-- 0 rows, this function will produce a 'Query' that is empty - that is, will
|
-- 0 rows, this function will produce a 'Query' that is empty - that is, will
|
||||||
-- produce zero @NonEmptyTable@s. If the supplied @Query@ does return rows,
|
-- produce zero @NonEmptyTable@s. If the supplied @Query@ does return rows,
|
||||||
@ -2539,10 +2550,3 @@ instance (HigherKindedTable t, forall a. DBType a => DBType (f a)) => HigherKind
|
|||||||
|
|
||||||
hdbtype :: HComposeTable f t (Context (Dict DBType))
|
hdbtype :: HComposeTable f t (Context (Dict DBType))
|
||||||
hdbtype = HComposeTable $ hmap (mapC \Dict -> ComposeInner Dict) hdbtype
|
hdbtype = HComposeTable $ hmap (mapC \Dict -> ComposeInner Dict) hdbtype
|
||||||
|
|
||||||
|
|
||||||
data Tab f = Tab
|
|
||||||
{ foo :: Column f Bool
|
|
||||||
, bar :: Column f Int64
|
|
||||||
}
|
|
||||||
deriving (Generic, GHigherKindedTable)
|
|
||||||
|
@ -687,7 +687,7 @@ testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \t
|
|||||||
|
|
||||||
data NestedMaybeTable f = NestedMaybeTable
|
data NestedMaybeTable f = NestedMaybeTable
|
||||||
{ nmt1 :: Rel8.Column f Bool
|
{ nmt1 :: Rel8.Column f Bool
|
||||||
, nmt2 :: Rel8.OuterJoin f TestTable
|
, nmt2 :: Rel8.HMaybe f (TestTable f)
|
||||||
}
|
}
|
||||||
deriving stock Generic
|
deriving stock Generic
|
||||||
deriving anyclass Rel8.GHigherKindedTable
|
deriving anyclass Rel8.GHigherKindedTable
|
||||||
|
Loading…
Reference in New Issue
Block a user