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.

Author: shane-circuithub

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

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

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 )
 
 

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 )
 
 

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)

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

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)

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 #-}
 

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)
 

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

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

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 )