diff --git a/rel8.cabal b/rel8.cabal index 3929d5fd..225a8efc 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -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 diff --git a/src/Rel8.hs b/src/Rel8.hs index baf30595..d09aea61 100644 --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -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 diff --git a/src/Rel8/Generic/Construction.hs b/src/Rel8/Generic/Construction.hs index 1868684f..db3dfb3f 100644 --- a/src/Rel8/Generic/Construction.hs +++ b/src/Rel8/Generic/Construction.hs @@ -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 ) diff --git a/src/Rel8/Query/Evaluate.hs b/src/Rel8/Query/Evaluate.hs index 5816387c..73511259 100644 --- a/src/Rel8/Query/Evaluate.hs +++ b/src/Rel8/Query/Evaluate.hs @@ -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 ) diff --git a/src/Rel8/Table/Bool.hs b/src/Rel8/Table/Bool.hs index 557c27fa..2e1c34e0 100644 --- a/src/Rel8/Table/Bool.hs +++ b/src/Rel8/Table/Bool.hs @@ -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) diff --git a/src/Rel8/Table/Case.hs b/src/Rel8/Table/Case.hs new file mode 100644 index 00000000..608bddbd --- /dev/null +++ b/src/Rel8/Table/Case.hs @@ -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 diff --git a/src/Rel8/Table/Either.hs b/src/Rel8/Table/Either.hs index 33faeef1..77bc823c 100644 --- a/src/Rel8/Table/Either.hs +++ b/src/Rel8/Table/Either.hs @@ -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) diff --git a/src/Rel8/Table/Maybe.hs b/src/Rel8/Table/Maybe.hs index 9c27ade7..6e51a707 100644 --- a/src/Rel8/Table/Maybe.hs +++ b/src/Rel8/Table/Maybe.hs @@ -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 #-} diff --git a/src/Rel8/Table/Null.hs b/src/Rel8/Table/Null.hs index b9e68fa4..db474e89 100644 --- a/src/Rel8/Table/Null.hs +++ b/src/Rel8/Table/Null.hs @@ -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) diff --git a/src/Rel8/Table/Nullify.hs b/src/Rel8/Table/Nullify.hs index 4d92f9cc..e2208246 100644 --- a/src/Rel8/Table/Nullify.hs +++ b/src/Rel8/Table/Nullify.hs @@ -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 diff --git a/src/Rel8/Table/These.hs b/src/Rel8/Table/These.hs index dcf7abd6..1b3d9109 100644 --- a/src/Rel8/Table/These.hs +++ b/src/Rel8/Table/These.hs @@ -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 diff --git a/src/Rel8/Table/Undefined.hs b/src/Rel8/Table/Undefined.hs index 3e42ebd2..885eb094 100644 --- a/src/Rel8/Table/Undefined.hs +++ b/src/Rel8/Table/Undefined.hs @@ -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 )