Rework VALUES clause and fix a bug on SQLite

beam-core/Database/Beam/Backend/SQL.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Database.Beam.Backend.SQL
@@ -7,10 +8,12 @@ module Database.Beam.Backend.SQL
 
   , MonadBeam(..)
 
-  , BeamSqlBackend
+  , BeamSqlBackend(..)
   , BeamSqlBackendSyntax
   , MockSqlBackend
 
+  , beamSqlDefaultColumnNames
+
   , BeamSqlBackendIsString
 
   , BeamSql99ExpressionBackend
@@ -80,6 +83,7 @@ import qualified Control.Monad.State.Strict as Strict
 import qualified Control.Monad.Writer.Strict as Strict
 
 import           Data.Kind (Type)
+import           Data.String (fromString)
 import           Data.Tagged (Tagged)
 import           Data.Text (Text)
 
@@ -230,7 +234,17 @@ class ( -- Every SQL backend must be a beam backend
 
         -- Needed for the Eq instance on QGenExpr
       , Eq (BeamSqlBackendExpressionSyntax be)
-      ) => BeamSqlBackend be
+
+      , KnownBool (BeamSqlBackendSupportsColumnAliases be)
+      ) => BeamSqlBackend be where
+  type BeamSqlBackendSupportsColumnAliases be :: Bool
+
+  beamSqlBackendDefaultColumnNames :: [Text]
+  beamSqlBackendDefaultColumnNames = beamSqlDefaultColumnNames
+
+-- | Infinite list of column names that we use for projections, by default
+beamSqlDefaultColumnNames :: [Text]
+beamSqlDefaultColumnNames = map (\n -> "res" <> fromString (show n)) [0..]
 
 type family BeamSqlBackendSyntax be :: Type
 
@@ -252,7 +266,8 @@ instance ( IsSql92Syntax syntax
 
            -- Needed for the Eq instance on QGenExpr
          , Eq (Sql92ExpressionSyntax syntax)
-         ) => BeamSqlBackend (MockSqlBackend syntax)
+         ) => BeamSqlBackend (MockSqlBackend syntax) where
+    type BeamSqlBackendSupportsColumnAliases (MockSqlBackend syntax) = True
 type instance BeamSqlBackendSyntax (MockSqlBackend syntax) = syntax
 
 -- | Type class for things which are text-like in this backend

beam-core/Database/Beam/Backend/SQL/AST.hs

@@ -479,7 +479,7 @@ instance IsSql92TableNameSyntax TableName where
 data TableSource
   = TableNamed TableName
   | TableFromSubSelect Select
-  | TableFromValues [ [ Expression ] ]
+  | TableFromValues Int [ [ Expression ] ]
   deriving (Show, Eq)
 
 instance IsSql92TableSourceSyntax TableSource where

beam-core/Database/Beam/Backend/SQL/Builder.hs

@@ -397,7 +397,7 @@ instance IsSql92TableSourceSyntax SqlSyntaxBuilder where
 
   tableNamed = id
   tableFromSubSelect query = SqlSyntaxBuilder (byteString "(" <> buildSql query <> byteString ")")
-  tableFromValues vss =
+  tableFromValues _ vss =
       SqlSyntaxBuilder $
       byteString "VALUES " <>
       buildSepBy (byteString ", ")

beam-core/Database/Beam/Backend/SQL/SQL92.hs

@@ -362,7 +362,8 @@ class IsSql92TableNameSyntax (Sql92TableSourceTableNameSyntax tblSource) =>
   tableNamed :: Sql92TableSourceTableNameSyntax tblSource
              -> tblSource
   tableFromSubSelect :: Sql92TableSourceSelectSyntax tblSource -> tblSource
-  tableFromValues :: [ [ Sql92TableSourceExpressionSyntax tblSource ] ] -> tblSource
+  -- | First argument is the number of columns to return
+  tableFromValues :: Int -> [ [ Sql92TableSourceExpressionSyntax tblSource ] ] -> tblSource
 
 class IsSql92GroupingSyntax grouping where
   type Sql92GroupingExpressionSyntax grouping :: Type

beam-core/Database/Beam/Backend/Types.hs

@@ -1,7 +1,8 @@
-{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 
 module Database.Beam.Backend.Types
   ( BeamBackend(..)
+  , KnownBool(..)
 
   , Exposed, Nullable
 
@@ -28,3 +29,11 @@ data Exposed x
 --
 -- See 'Columnar' for more information.
 data Nullable (c :: Type -> Type) x
+
+class KnownBool (x :: Bool) where
+    knownBool :: Bool
+
+instance KnownBool 'True where
+    knownBool = True
+instance KnownBool 'False where
+    knownBool = False

beam-core/Database/Beam/Query/Combinators.hs

@@ -112,11 +112,17 @@ values_ :: forall be db s a
            , BeamSqlBackend be )
         => [ a ] -> Q be db s a
 values_ rows =
-    Q $ liftF (QAll (\tblPfx -> fromTable (tableFromValues (map (\row -> project (Proxy @be) row tblPfx) rows)) . Just . (,Just fieldNames))
-                    (\tblNm' -> fst $ mkFieldNames (qualifiedField tblNm'))
+    Q $ liftF (QAll (\tblPfx -> fromTable (tableFromValues colCount (map (\row -> project (Proxy @be) row tblPfx) rows)) . Just . (,colAliases))
+                    (\tblNm' -> if useAliases
+                                then fst $ mkFieldNames (qualifiedField tblNm')
+                                else fst $ mkDefaultFieldNames (qualifiedField tblNm'))
                     (\_ -> Nothing) snd)
     where
+      useAliases = knownBool @(BeamSqlBackendSupportsColumnAliases be)
+      colAliases | useAliases = Just fieldNames
+                 | otherwise  = Nothing
       fieldNames = snd $ mkFieldNames @be @a unqualifiedField
+      colCount = length fieldNames
 
 -- | Introduce all entries of a table into the 'Q' monad based on the
 --   given QExpr. The join condition is expected to return a

beam-core/Database/Beam/Query/Internal.hs

@@ -663,6 +663,20 @@ mkFieldNames mkField =
       tell [ fieldName' ]
       pure (\_ -> BeamSqlBackendExpressionSyntax' (fieldE (mkField fieldName')))
 
+mkDefaultFieldNames :: forall be res
+                     . ( BeamSqlBackend be, Projectible be res )
+                    => (T.Text -> BeamSqlBackendFieldNameSyntax be) -> (res, [T.Text])
+mkDefaultFieldNames mkField =
+    runWriter . flip evalStateT (beamSqlBackendDefaultColumnNames @be) . flip evalStateT 0 $
+    mkFieldsSkeleton @be @res $ \_ -> do
+      cols <- lift get
+      (x, xs) <- case cols of
+                   [] -> error "Not enough default column names"
+                   x:xs -> pure (x, xs)
+      tell [x]
+      lift (put xs)
+      pure (\_ -> BeamSqlBackendExpressionSyntax' (fieldE (mkField x)))
+
 tableNameFromEntity :: IsSql92TableNameSyntax name
                     => DatabaseEntityDescriptor be (TableEntity tbl)
                     -> name

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

@@ -1033,11 +1033,12 @@ instance IsSql92TableSourceSyntax PgTableSourceSyntax where
 
   tableNamed = PgTableSourceSyntax . fromPgTableName
   tableFromSubSelect s = PgTableSourceSyntax $ emit "(" <> fromPgSelect s <> emit ")"
-  tableFromValues vss = PgTableSourceSyntax . pgParens $
-                        emit "VALUES " <>
-                        pgSepBy (emit ", ")
-                                (map (\vs -> pgParens (pgSepBy (emit ", ")
-                                                               (map fromPgExpression vs))) vss)
+  tableFromValues _cnt vss =
+      PgTableSourceSyntax . pgParens $
+      emit "VALUES " <>
+      pgSepBy (emit ", ")
+              (map (\vs -> pgParens (pgSepBy (emit ", ")
+                                     (map fromPgExpression vs))) vss)
 
 instance IsSql92ProjectionSyntax PgProjectionSyntax where
   type Sql92ProjectionExpressionSyntax PgProjectionSyntax = PgExpressionSyntax

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

@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -162,7 +163,8 @@ instance FromBackendRow Postgres (Pg.Binary BL.ByteString)
 instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Pg.PGRange a)
 instance (Pg.FromField a, Pg.FromField b, Typeable a, Typeable b) => FromBackendRow Postgres (Either a b)
 
-instance BeamSqlBackend Postgres
+instance BeamSqlBackend Postgres where
+    type BeamSqlBackendSupportsColumnAliases Postgres = 'True
 instance BeamMigrateOnlySqlBackend Postgres
 type instance BeamSqlBackendSyntax Postgres = PgCommandSyntax
 

beam-sqlite/Database/Beam/Sqlite/Connection.hs

@@ -167,7 +167,8 @@ instance FromField SqliteScientific where
                      "No conversion to Scientific for '" <> s <> "'"
           Just s'  -> pure s'
 
-instance BeamSqlBackend Sqlite
+instance BeamSqlBackend Sqlite where
+    type BeamSqlBackendSupportsColumnAliases Sqlite = 'False
 instance BeamMigrateOnlySqlBackend Sqlite
 type instance BeamSqlBackendSyntax Sqlite = SqliteCommandSyntax
 
@@ -380,9 +381,8 @@ runInsertReturningList SqlInsertNoRows = pure []
 runInsertReturningList (SqlInsert tblSettings insertStmt_@(SqliteInsertSyntax nm _ _ _)) =
   do (logger, conn) <- SqliteM ask
      SqliteM . liftIO $ do
-
        -- We create a pseudo-random savepoint identification that can be referenced
-       -- throughout this operation. -- This used to be based on the process ID 
+       -- throughout this operation. -- This used to be based on the process ID
        -- (e.g. `System.Posix.Process.getProcessID` for UNIX),
        -- but using timestamps is more portable; see #738
        --