mirror of
https://github.com/circuithub/rel8.git
synced 2024-10-05 21:29:35 +03:00
Add new Case
constraint which is more general than Table Expr
The `Case` constraint is used for functions like `bool`, `case_`, `maybeTable`, `nullable`, all of which ultimately compile down to a PostgreSQL `CASE` statement. `Case` has two instances: an overlapping `Table Expr a => Case a` instance, and a `Case b => Case (a -> b)` instance, that allows expressions like `maybeTable id (+)` which would not have been possible for.
This commit is contained in:
parent
d2f05bdcfd
commit
efd5c6f181
@ -162,6 +162,7 @@ library
|
||||
Rel8.Table.Aggregate
|
||||
Rel8.Table.Alternative
|
||||
Rel8.Table.Bool
|
||||
Rel8.Table.Case
|
||||
Rel8.Table.Cols
|
||||
Rel8.Table.Either
|
||||
Rel8.Table.Eq
|
||||
|
@ -50,6 +50,7 @@ module Rel8
|
||||
, EqTable(..), (==:), (/=:)
|
||||
, OrdTable(..), (<:), (<=:), (>:), (>=:), ascTable, descTable, greatest, least
|
||||
, lit
|
||||
, Case
|
||||
, bool
|
||||
, case_
|
||||
, castTable
|
||||
@ -409,6 +410,7 @@ import Rel8.Table.ADT
|
||||
import Rel8.Table.Aggregate
|
||||
import Rel8.Table.Alternative
|
||||
import Rel8.Table.Bool
|
||||
import Rel8.Table.Case
|
||||
import Rel8.Table.Either
|
||||
import Rel8.Table.Eq
|
||||
import Rel8.Table.HKD
|
||||
|
@ -66,7 +66,7 @@ import Rel8.Table
|
||||
( TTable, TColumns
|
||||
, Table, fromColumns, toColumns
|
||||
)
|
||||
import Rel8.Table.Bool ( case_ )
|
||||
import Rel8.Table.Case ( case_ )
|
||||
import Rel8.Type.Tag ( Tag )
|
||||
|
||||
|
||||
|
@ -23,7 +23,7 @@ import Rel8.Expr.Opaleye ( fromPrimExpr )
|
||||
import Rel8.Query ( Query( Query ) )
|
||||
import Rel8.Query.Rebind ( rebind )
|
||||
import Rel8.Table ( Table )
|
||||
import Rel8.Table.Bool ( case_ )
|
||||
import Rel8.Table.Case ( case_ )
|
||||
import Rel8.Table.Undefined ( undefined )
|
||||
|
||||
|
||||
|
@ -1,10 +1,7 @@
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language ViewPatterns #-}
|
||||
{-# language MonoLocalBinds #-}
|
||||
|
||||
module Rel8.Table.Bool
|
||||
( bool
|
||||
, case_
|
||||
, nullable
|
||||
)
|
||||
where
|
||||
@ -14,35 +11,18 @@ import Prelude
|
||||
|
||||
-- rel8
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Bool ( boolExpr, caseExpr )
|
||||
import Rel8.Expr.Null ( isNull, unsafeUnnullify )
|
||||
import Rel8.Schema.HTable ( htabulate, hfield )
|
||||
import Rel8.Table ( Table, fromColumns, toColumns )
|
||||
import Rel8.Table.Case (Case, case_)
|
||||
|
||||
|
||||
-- | An if-then-else expression on tables.
|
||||
--
|
||||
-- @bool x y p@ returns @x@ if @p@ is @False@, and returns @y@ if @p@ is
|
||||
-- @True@.
|
||||
bool :: Table Expr a => a -> a -> Expr Bool -> a
|
||||
bool (toColumns -> false) (toColumns -> true) condition =
|
||||
fromColumns $ htabulate $ \field ->
|
||||
case (hfield false field, hfield true field) of
|
||||
(falseExpr, trueExpr) -> boolExpr falseExpr trueExpr condition
|
||||
{-# INLINABLE bool #-}
|
||||
|
||||
|
||||
-- | Produce a table expression from a list of alternatives. Returns the first
|
||||
-- table where the @Expr Bool@ expression is @True@. If no alternatives are
|
||||
-- true, the given default is returned.
|
||||
case_ :: Table Expr a => [(Expr Bool, a)] -> a -> a
|
||||
case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
|
||||
fromColumns $ htabulate $ \field -> case hfield fallback field of
|
||||
fallbackExpr ->
|
||||
case map (fmap (`hfield` field)) branches of
|
||||
branchExprs -> caseExpr branchExprs fallbackExpr
|
||||
bool :: Case a => a -> a -> Expr Bool -> a
|
||||
bool ifFalse ifTrue condition = case_ [(condition, ifTrue)] ifFalse
|
||||
|
||||
|
||||
-- | Like 'maybe', but to eliminate @null@.
|
||||
nullable :: Table Expr b => b -> (Expr a -> b) -> Expr (Maybe a) -> b
|
||||
nullable :: Case b => b -> (Expr a -> b) -> Expr (Maybe a) -> b
|
||||
nullable b f ma = bool (f (unsafeUnnullify ma)) b (isNull ma)
|
||||
|
51
src/Rel8/Table/Case.hs
Normal file
51
src/Rel8/Table/Case.hs
Normal file
@ -0,0 +1,51 @@
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# language ViewPatterns #-}
|
||||
|
||||
module Rel8.Table.Case
|
||||
( Case
|
||||
, case_
|
||||
, undefined
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Prelude hiding ( undefined )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Bool ( caseExpr )
|
||||
import Rel8.Expr.Null ( snull, unsafeUnnullify )
|
||||
import Rel8.Schema.HTable ( hfield, htabulate, hspecs )
|
||||
import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
|
||||
import Rel8.Schema.Spec ( Spec(..) )
|
||||
import Rel8.Table ( Table, fromColumns, toColumns )
|
||||
|
||||
|
||||
class Case a where
|
||||
-- | Produce a table expression from a list of alternatives. Returns the
|
||||
-- first table where the @Expr Bool@ expression is @True@. If no
|
||||
-- alternatives are true, the given default is returned.
|
||||
case_ :: [(Expr Bool, a)] -> a -> a
|
||||
|
||||
undefined :: a
|
||||
|
||||
|
||||
instance {-# INCOHERENT #-} Table Expr a => Case a where
|
||||
case_ (map (fmap toColumns) -> branches) (toColumns -> fallback) =
|
||||
fromColumns $ htabulate $ \field -> case hfield fallback field of
|
||||
fallbackExpr ->
|
||||
case map (fmap (`hfield` field)) branches of
|
||||
branchExprs -> caseExpr branchExprs fallbackExpr
|
||||
undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of
|
||||
Spec {nullity, info} -> case nullity of
|
||||
Null -> snull info
|
||||
NotNull -> unsafeUnnullify (snull info)
|
||||
|
||||
|
||||
instance Case b => Case (a -> b) where
|
||||
case_ branches fallback a = case_ (map (fmap ($ a)) branches) (fallback a)
|
||||
undefined = const undefined
|
@ -51,6 +51,7 @@ import Rel8.Table
|
||||
, Transpose
|
||||
)
|
||||
import Rel8.Table.Bool ( bool )
|
||||
import Rel8.Table.Case ( Case )
|
||||
import Rel8.Table.Eq ( EqTable, eqTable )
|
||||
import Rel8.Table.Nullify ( Nullify, aggregateNullify, guard )
|
||||
import Rel8.Table.Ord ( OrdTable, ordTable )
|
||||
@ -198,7 +199,7 @@ isRightTable EitherTable {tag} = isRight tag
|
||||
|
||||
-- | Pattern match/eliminate an 'EitherTable', by providing mappings from a
|
||||
-- 'leftTable' and 'rightTable'.
|
||||
eitherTable :: Table Expr c
|
||||
eitherTable :: Case c
|
||||
=> (a -> c) -> (b -> c) -> EitherTable Expr a b -> c
|
||||
eitherTable f g EitherTable {tag, left, right} =
|
||||
bool (f (extract left)) (g (extract right)) (isRight tag)
|
||||
|
@ -57,6 +57,7 @@ import Rel8.Table.Alternative
|
||||
, AlternativeTable, emptyTable
|
||||
)
|
||||
import Rel8.Table.Bool ( bool )
|
||||
import Rel8.Table.Case ( Case )
|
||||
import Rel8.Table.Eq ( EqTable, eqTable )
|
||||
import Rel8.Table.Ord ( OrdTable, ordTable )
|
||||
import Rel8.Table.Projection ( Projectable, project )
|
||||
@ -191,7 +192,7 @@ isJustTable (MaybeTable tag _) = isNonNull tag
|
||||
|
||||
|
||||
-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
|
||||
maybeTable :: Table Expr b => b -> (a -> b) -> MaybeTable Expr a -> b
|
||||
maybeTable :: Case b => b -> (a -> b) -> MaybeTable Expr a -> b
|
||||
maybeTable b f ma@(MaybeTable _ a) = bool (f (extract a)) b (isNothingTable ma)
|
||||
{-# INLINABLE maybeTable #-}
|
||||
|
||||
|
@ -40,6 +40,7 @@ import Rel8.Table.Alternative
|
||||
, AlternativeTable, emptyTable
|
||||
)
|
||||
import Rel8.Table.Bool ( bool )
|
||||
import Rel8.Table.Case ( Case )
|
||||
import Rel8.Table.Eq ( EqTable, eqTable )
|
||||
import Rel8.Table.Maybe ( MaybeTable, justTable, maybeTable, nothingTable )
|
||||
import Rel8.Table.Nullify ( Nullify, isNull )
|
||||
@ -110,7 +111,7 @@ isNonNullTable = not_ . isNullTable
|
||||
|
||||
|
||||
-- | Like 'Rel8.nullable'.
|
||||
nullableTable :: (Table Expr a, Table Expr b)
|
||||
nullableTable :: (Table Expr a, Case b)
|
||||
=> b -> (a -> b) -> NullTable Expr a -> b
|
||||
nullableTable b f ma@(NullTable a) = bool (f (extract a)) b (isNullTable ma)
|
||||
|
||||
|
@ -161,8 +161,7 @@ instance (Table context a, Reifiable context, context ~ context') =>
|
||||
fromResult = fmap (fromResult @_ @a) . hunnullify R.unnullifier
|
||||
|
||||
toResult =
|
||||
maybe (hnulls (const R.null)) (hnullify R.nullifier) .
|
||||
fmap (toResult @_ @a)
|
||||
maybe (hnulls (const R.null)) (hnullify R.nullifier . toResult @_ @a)
|
||||
|
||||
|
||||
instance (EqTable a, context ~ Expr) => EqTable (Nullify context a) where
|
||||
|
@ -51,6 +51,7 @@ import Rel8.Table
|
||||
, FromExprs, fromResult, toResult
|
||||
, Transpose
|
||||
)
|
||||
import Rel8.Table.Case ( Case )
|
||||
import Rel8.Table.Eq ( EqTable, eqTable )
|
||||
import Rel8.Table.Maybe
|
||||
( MaybeTable(..)
|
||||
@ -315,7 +316,7 @@ thoseTable a b = TheseTable (justTable a) (justTable b)
|
||||
|
||||
|
||||
-- | Pattern match on a 'TheseTable'. Corresponds to 'these'.
|
||||
theseTable :: Table Expr c
|
||||
theseTable :: Case c
|
||||
=> (a -> c) -> (b -> c) -> (a -> b -> c) -> TheseTable Expr a b -> c
|
||||
theseTable f g h TheseTable {here, there} =
|
||||
maybeTable
|
||||
|
@ -1,7 +1,3 @@
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language TypeFamilies #-}
|
||||
|
||||
module Rel8.Table.Undefined
|
||||
( undefined
|
||||
)
|
||||
@ -11,16 +7,4 @@ where
|
||||
import Prelude hiding ( undefined )
|
||||
|
||||
-- rel8
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Null ( snull, unsafeUnnullify )
|
||||
import Rel8.Schema.HTable ( htabulate, hfield, hspecs )
|
||||
import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
|
||||
import Rel8.Schema.Spec ( Spec(..) )
|
||||
import Rel8.Table ( Table, fromColumns )
|
||||
|
||||
|
||||
undefined :: Table Expr a => a
|
||||
undefined = fromColumns $ htabulate $ \field -> case hfield hspecs field of
|
||||
Spec {nullity, info} -> case nullity of
|
||||
Null -> snull info
|
||||
NotNull -> unsafeUnnullify (snull info)
|
||||
import Rel8.Table.Case ( undefined )
|
||||
|
Loading…
Reference in New Issue
Block a user