Monoid instance for FromItemExpr

I added `Monoid` and `Semigroup` instances to `FromItemExpr` to support
writing queries with empty from lists with `mempty` or Cartesian
product from lists with `<>`.

I added an `Empty` constructor and an `appendWithCommaSpace` helper to
`RawSql` to facilitate the `Semigroup` instance, since we need to
generate different SQL if any of the `FromItemExpr`s being appended are
empty.

orville-postgresql/orville-postgresql.cabal

@@ -201,6 +201,7 @@ test-suite spec
       Test.Expr.ConditionalExpr
       Test.Expr.Count
       Test.Expr.Cursor
+      Test.Expr.FromItemExpr
       Test.Expr.GroupBy
       Test.Expr.GroupByOrderBy
       Test.Expr.InsertUpdateDelete

orville-postgresql/src/Orville/PostgreSQL/Expr/FromItemExpr.hs

@@ -37,6 +37,15 @@ newtype FromItemExpr
   = FromItemExpr RawSql.RawSql
   deriving (RawSql.SqlExpression)
 
+-- | @since 1.1.0.0
+instance Semigroup FromItemExpr where
+  FromItemExpr a <> FromItemExpr b =
+    FromItemExpr $ RawSql.appendWithCommaSpace a b
+
+-- | @since 1.1.0.0
+instance Monoid FromItemExpr where
+  mempty = FromItemExpr mempty
+
 {- |
   Constructs a 'FromItemExpr' consisting of just the specified table
   name.

orville-postgresql/src/Orville/PostgreSQL/Raw/RawSql.hs

@@ -19,6 +19,7 @@ module Orville.PostgreSQL.Raw.RawSql
   , execute
   , executeVoid
   , connectionQuoting
+  , appendWithCommaSpace
 
     -- * Fragments provided for convenience
   , space
@@ -84,6 +85,7 @@ data RawSql
   | StringLiteral BS.ByteString
   | Identifier BS.ByteString
   | Append RawSql RawSql
+  | Empty
 
 instance Semigroup RawSql where
   (SqlSection builderA) <> (SqlSection builderB) =
@@ -92,7 +94,19 @@ instance Semigroup RawSql where
     Append otherA otherB
 
 instance Monoid RawSql where
-  mempty = SqlSection mempty
+  mempty = Empty
+
+{- |
+  Append two 'RawSql' values together with 'commaSpace' in between, unless
+  either of the values are empty.
+
+@since 1.1.0.0
+-}
+appendWithCommaSpace :: RawSql -> RawSql -> RawSql
+appendWithCommaSpace a b = case (a, b) of
+  (Empty, x) -> x
+  (x, Empty) -> x
+  (x, y) -> x <> commaSpace <> y
 
 {- |
  'SqlExpression' provides a common interface for converting types to and from
@@ -308,6 +322,8 @@ buildSqlWithProgress quoting progress rawSql =
       (firstBuilder, nextProgress) <- buildSqlWithProgress quoting progress first
       (secondBuilder, finalProgress) <- buildSqlWithProgress quoting nextProgress second
       pure (firstBuilder <> secondBuilder, finalProgress)
+    Empty ->
+      pure (mempty, progress)
 
 {- |
   Constructs a 'RawSql' from a 'String' value using UTF-8 encoding.

orville-postgresql/test/Main.hs

@@ -19,6 +19,7 @@ import qualified Test.Execution as Execution
 import qualified Test.Expr.ConditionalExpr as ExprConditional
 import qualified Test.Expr.Count as ExprCount
 import qualified Test.Expr.Cursor as ExprCursor
+import qualified Test.Expr.FromItemExpr as ExprFromItem
 import qualified Test.Expr.GroupBy as ExprGroupBy
 import qualified Test.Expr.GroupByOrderBy as ExprGroupByOrderBy
 import qualified Test.Expr.InsertUpdateDelete as ExprInsertUpdateDelete
@@ -73,6 +74,7 @@ main = do
       , ExprTrigger.triggerTests pool
       , ExprVacuum.vacuumTests
       , ExprJoin.joinTests
+      , ExprFromItem.fromItemExprTests
       , ExprConditional.conditionalTests
       , FieldDefinition.fieldDefinitionTests pool
       , SqlMarshaller.sqlMarshallerTests

orville-postgresql/test/Test/Expr/FromItemExpr.hs

@@ -0,0 +1,69 @@
+module Test.Expr.FromItemExpr
+  ( fromItemExprTests
+  ) where
+
+import qualified Data.ByteString.Char8 as B8
+import GHC.Stack (HasCallStack, withFrozenCallStack)
+import qualified Hedgehog as HH
+
+import qualified Orville.PostgreSQL.Expr as Expr
+import qualified Orville.PostgreSQL.Raw.RawSql as RawSql
+
+import qualified Test.Property as Property
+
+fromItemExprTests :: Property.Group
+fromItemExprTests =
+  Property.group
+    "Expr - FromItemExpr"
+    [ prop_appendJoin
+    , prop_cartesianProduct
+    , prop_appendFromItemIdentity
+    , prop_appendFromItemAssociativity
+    ]
+
+prop_appendJoin :: Property.NamedProperty
+prop_appendJoin =
+  Property.singletonNamedProperty "appending a single joinExpr with left join lateral and trivial on clause to another FromItemExpr generates expected sql"
+    $ assertFromItemEquals
+      "\"bar\" LEFT JOIN LATERAL \"foo\" ON TRUE"
+      . Expr.appendJoinFromItem barFromItem
+      . pure
+    $ Expr.joinExpr Expr.leftLateralJoinType fooFromItem joinOnTrue
+
+prop_cartesianProduct :: Property.NamedProperty
+prop_cartesianProduct =
+  Property.singletonNamedProperty "appending two FromItemExprs results in a cartesian product FromItemExpr" $
+    assertFromItemEquals
+      "\"foo\", \"bar\""
+      (fooFromItem <> barFromItem)
+
+prop_appendFromItemIdentity :: Property.NamedProperty
+prop_appendFromItemIdentity =
+  Property.singletonNamedProperty "FromItemExpr Monoid identity" $ do
+    let
+      expected = "\"foo\""
+    assertFromItemEquals expected (mempty <> fooFromItem)
+    assertFromItemEquals expected (fooFromItem <> mempty)
+
+prop_appendFromItemAssociativity :: Property.NamedProperty
+prop_appendFromItemAssociativity =
+  Property.singletonNamedProperty "FromItemExpr Semigroup associativity" $ do
+    let
+      expected = "\"bar\", \"foo\", \"bar\""
+    assertFromItemEquals expected (barFromItem <> (fooFromItem <> barFromItem))
+    assertFromItemEquals expected ((barFromItem <> fooFromItem) <> barFromItem)
+
+assertFromItemEquals :: (HH.MonadTest m, HasCallStack) => String -> Expr.FromItemExpr -> m ()
+assertFromItemEquals mbFromItemStr fromItemExpr =
+  withFrozenCallStack $
+    RawSql.toExampleBytes fromItemExpr HH.=== B8.pack mbFromItemStr
+
+joinOnTrue :: Expr.JoinConstraint
+joinOnTrue =
+  Expr.joinOnConstraint $ Expr.literalBooleanExpr True
+
+fooFromItem :: Expr.FromItemExpr
+fooFromItem = Expr.tableFromItem . Expr.qualifyTable Nothing $ Expr.tableName "foo"
+
+barFromItem :: Expr.FromItemExpr
+barFromItem = Expr.tableFromItem . Expr.qualifyTable Nothing $ Expr.tableName "bar"

orville-postgresql/test/Test/Expr/Join.hs

@@ -15,9 +15,8 @@ import qualified Test.Property as Property
 joinTests :: Property.Group
 joinTests =
   Property.group
-    "Expr - Join"
+    "Expr - Join and FromItemExpr"
     [ prop_leftJoinOnTrue
-    , prop_appendJoin
     ]
 
 prop_leftJoinOnTrue :: Property.NamedProperty
@@ -27,31 +26,14 @@ prop_leftJoinOnTrue =
       "LEFT JOIN \"foo\" ON TRUE"
     $ Expr.joinExpr Expr.leftJoinType fooFromItem joinOnTrue
 
-prop_appendJoin :: Property.NamedProperty
-prop_appendJoin =
-  Property.singletonNamedProperty "appending a single joinExpr with left join lateral and trivial on clause to another FromItemExpr generates expected sql"
-    $ assertFromItemEquals
-      "\"bar\" LEFT JOIN LATERAL \"foo\" ON TRUE"
-      . Expr.appendJoinFromItem barFromItem
-      . pure
-    $ Expr.joinExpr Expr.leftLateralJoinType fooFromItem joinOnTrue
-
 assertJoinEquals :: (HH.MonadTest m, HasCallStack) => String -> Expr.JoinExpr -> m ()
 assertJoinEquals mbJoinStr joinExpr =
   withFrozenCallStack $
     RawSql.toExampleBytes joinExpr HH.=== B8.pack mbJoinStr
 
-assertFromItemEquals :: (HH.MonadTest m, HasCallStack) => String -> Expr.FromItemExpr -> m ()
-assertFromItemEquals mbFromItemStr fromItemExpr =
-  withFrozenCallStack $
-    RawSql.toExampleBytes fromItemExpr HH.=== B8.pack mbFromItemStr
-
 joinOnTrue :: Expr.JoinConstraint
 joinOnTrue =
   Expr.joinOnConstraint $ Expr.literalBooleanExpr True
 
 fooFromItem :: Expr.FromItemExpr
 fooFromItem = Expr.tableFromItem . Expr.qualifyTable Nothing $ Expr.tableName "foo"
-
-barFromItem :: Expr.FromItemExpr
-barFromItem = Expr.tableFromItem . Expr.qualifyTable Nothing $ Expr.tableName "bar"