Implement SQL features in beam-sqlite.

.gitignore

@@ -23,3 +23,4 @@ TAGS
 docs/ChinookData
 result
 result-*
+/cabal.project.local

beam-core/Database/Beam/Query.hs

@@ -246,7 +246,7 @@ insert :: ( BeamSqlBackend be, ProjectibleWithPredicate AnyType () Text (table (
        -> SqlInsertValues be (table (QExpr be s))
           -- ^ Values to insert. See 'insertValues', 'insertExpressions', and 'insertFrom' for possibilities.
        -> SqlInsert be table
-insert tbl values = insertOnly tbl id values
+insert tbl = insertOnly tbl id
 
 -- | Run a 'SqlInsert' in a 'MonadBeam'
 runInsert :: (BeamSqlBackend be, MonadBeam be m)
@@ -497,7 +497,7 @@ updateTableRow' tbl row assignments =
   updateTable' tbl assignments (references_' (val_ (pk row)))
 
 set :: forall table be table'. Beamable table => table (QFieldAssignment be table')
-set = changeBeamRep (\_ -> Columnar' (QFieldAssignment (\_ -> Nothing))) (tblSkeleton :: TableSkeleton table)
+set = changeBeamRep (\_ -> Columnar' (QFieldAssignment (const Nothing))) (tblSkeleton :: TableSkeleton table)
 
 setFieldsTo :: forall table be table'
              . Table table => (forall s. table (QExpr be s)) -> table (QFieldAssignment be table')
@@ -527,11 +527,11 @@ setFieldsTo tbl =
 -- | Use with 'set' to set a field to an explicit new value that does
 -- not depend on any other value
 toNewValue :: (forall s. QExpr be s a) -> QFieldAssignment be table a
-toNewValue newVal = toUpdatedValue (\_ -> newVal)
+toNewValue newVal = toUpdatedValue (const newVal)
 
 -- | Use with 'set' to not modify the field
 toOldValue :: QFieldAssignment be table a
-toOldValue = toUpdatedValueMaybe (\_ -> Nothing)
+toOldValue = toUpdatedValueMaybe (const Nothing)
 
 -- | Use with 'set' to set a field to a new value that is calculated
 -- based on one or more fields from the existing row

beam-postgres/Database/Beam/Postgres/Syntax.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE LambdaCase #-}
 
 -- | Data types for Postgres syntax. Access is given mainly for extension
 -- modules. The types and definitions here are likely to change.
@@ -93,7 +94,7 @@ import           Database.Beam.Migrate
 import           Database.Beam.Migrate.SQL.Builder hiding (fromSqlConstraintAttributes)
 import           Database.Beam.Migrate.Serialization
 
-import           Control.Monad (guard)
+import           Control.Monad (guard, void)
 import           Control.Monad.Free
 import           Control.Monad.Free.Church
 
@@ -289,12 +290,11 @@ fromPgSelectLockingClause s =
     PgSelectLockingStrengthNoKeyUpdate -> emit "NO KEY UPDATE"
     PgSelectLockingStrengthShare -> emit "SHARE"
     PgSelectLockingStrengthKeyShare -> emit "KEY SHARE") <>
-  emitTables <>
-  (maybe mempty emitOptions $ pgSelectLockingClauseOptions s)
+  emitTables <> maybe mempty emitOptions (pgSelectLockingClauseOptions s)
   where
     emitTables = case pgSelectLockingTables s of
       [] -> mempty
-      tableNames -> emit " OF " <> (pgSepBy (emit ", ") (map pgQuotedIdentifier tableNames))
+      tableNames -> emit " OF " <> pgSepBy (emit ", ") (map pgQuotedIdentifier tableNames)
 
     emitOptions PgSelectLockingOptionsNoWait = emit " NOWAIT"
     emitOptions PgSelectLockingOptionsSkipLocked = emit " SKIP LOCKED"
@@ -470,10 +470,10 @@ instance IsSql92SelectTableSyntax PgSelectTableSyntax where
     emit "SELECT " <>
     maybe mempty (\setQuantifier' -> fromPgSelectSetQuantifier setQuantifier' <> emit " ") setQuantifier <>
     fromPgProjection proj <>
-    (maybe mempty (emit " FROM " <> ) (coerce from)) <>
-    (maybe mempty (emit " WHERE " <>) (coerce where_)) <>
-    (maybe mempty (emit " GROUP BY " <>) (coerce grouping)) <>
-    (maybe mempty (emit " HAVING " <>) (coerce having))
+    maybe mempty (emit " FROM " <> ) (coerce from) <>
+    maybe mempty (emit " WHERE " <>) (coerce where_) <>
+    maybe mempty (emit " GROUP BY " <>) (coerce grouping) <>
+    maybe mempty (emit " HAVING " <>) (coerce having)
 
   unionTables all = pgTableOp (if all then "UNION ALL" else "UNION")
   intersectTables all = pgTableOp (if all then "INTERSECT ALL" else "INTERSECT")
@@ -494,7 +494,7 @@ instance IsSql92FromSyntax PgFromSyntax where
   fromTable tableSrc (Just (nm, colNms)) =
       PgFromSyntax $
       coerce tableSrc <> emit " AS " <> pgQuotedIdentifier nm <>
-      maybe mempty (\colNms' -> pgParens (pgSepBy (emit ",") (map pgQuotedIdentifier colNms'))) colNms
+      maybe mempty (pgParens . pgSepBy (emit ",") . map pgQuotedIdentifier) colNms
 
   innerJoin a b Nothing = PgFromSyntax (fromPgFrom a <> emit " CROSS JOIN " <> fromPgFrom b)
   innerJoin a b (Just e) = pgJoin "INNER JOIN" a b (Just e)
@@ -677,13 +677,10 @@ mkNumericPrec (Just (whole, dec)) = Just $ (fromIntegral whole `shiftL` 16) .|.
 instance IsCustomSqlSyntax PgExpressionSyntax where
   newtype CustomSqlSyntax PgExpressionSyntax =
     PgCustomExpressionSyntax { fromPgCustomExpression :: PgSyntax }
-    deriving Monoid
+    deriving (Semigroup, Monoid)
   customExprSyntax = PgExpressionSyntax . fromPgCustomExpression
   renderSyntax = PgCustomExpressionSyntax . pgParens . fromPgExpression
 
-instance Semigroup (CustomSqlSyntax PgExpressionSyntax) where
-  (<>) = mappend
-
 instance IsString (CustomSqlSyntax PgExpressionSyntax) where
   fromString = PgCustomExpressionSyntax . emit . fromString
 
@@ -967,8 +964,7 @@ instance IsSql92TableSourceSyntax PgTableSourceSyntax where
   tableFromValues vss = PgTableSourceSyntax . pgParens $
                         emit "VALUES " <>
                         pgSepBy (emit ", ")
-                                (map (\vs -> pgParens (pgSepBy (emit ", ")
-                                                               (map fromPgExpression vs))) vss)
+                                (map (pgParens . pgSepBy (emit ", ") . map fromPgExpression) vss)
 
 instance IsSql92ProjectionSyntax PgProjectionSyntax where
   type Sql92ProjectionExpressionSyntax PgProjectionSyntax = PgExpressionSyntax
@@ -1301,7 +1297,7 @@ pgDebugRenderSyntax (PgSyntax p) = go p Nothing
             (EmitBuilder s next, lastBs) ->
               step (EmitByteString (toStrict (toLazyByteString s)) next) lastBs
             (x, Nothing) ->
-              nextSyntaxStep x (Just (fmap (const ()) x))
+              nextSyntaxStep x (Just (void x))
             (EmitByteString x next, Just (EmitByteString before _)) ->
               next (Just (EmitByteString (before <> x) ()))
             (EscapeString x next, Just (EscapeString before _)) ->
@@ -1312,7 +1308,7 @@ pgDebugRenderSyntax (PgSyntax p) = go p Nothing
               next (Just (EscapeIdentifier (before <> x) ()))
             (s, Just e) ->
               renderStep e >>
-              nextSyntaxStep s (Just (fmap (const ()) s))
+              nextSyntaxStep s (Just (void s))
 
         renderStep (EmitByteString x _) = putStrLn ("EmitByteString " <> show x)
         renderStep (EmitBuilder x _) = putStrLn ("EmitBuilder " <> show (toLazyByteString x))
@@ -1325,8 +1321,7 @@ pgDebugRenderSyntax (PgSyntax p) = go p Nothing
 
 pgBuildAction :: [ Pg.Action ] -> PgSyntax
 pgBuildAction =
-  foldMap $ \action ->
-  case action of
+  foldMap $ \case
     Pg.Plain x -> emitBuilder x
     Pg.Escape str -> emit "'" <> escapeString str <> emit "'"
     Pg.EscapeByteA bin -> emit "'" <> escapeBytea bin <> emit "'"