Add more tests

src/Database/Esqueleto/Internal/Sql.hs

@@ -987,27 +987,21 @@ deleteCount = rawEsqueleto DELETE
 -- @
 update
   ::
-  ( PersistEntityBackend val ~ backend
+  ( MonadIO m, PersistEntity val
-  , PersistEntity val
+  , BackendCompatible SqlBackend (PersistEntityBackend val)
-  , PersistUniqueWrite backend
-  , PersistQueryWrite backend
-  , BackendCompatible SqlBackend backend
-  , PersistEntity val
-  , MonadIO m
   )
   => (SqlExpr (Entity val) -> SqlQuery ())
-  -> R.ReaderT backend m ()
+  -> SqlWriteT m ()
 update = void . updateCount
 
 -- | Same as 'update', but returns the number of rows affected.
-updateCount :: ( MonadIO m
+updateCount
-               , PersistEntity val
+  ::
-               , PersistEntityBackend val ~ backend
+  ( MonadIO m, PersistEntity val
-               , BackendCompatible SqlBackend backend
+  , BackendCompatible SqlBackend (PersistEntityBackend val)
-               , PersistQueryWrite backend
+  )
-               , PersistUniqueWrite backend)
+  => (SqlExpr (Entity val) -> SqlQuery ())
-            => (SqlExpr (Entity val) -> SqlQuery ())
+  -> SqlWriteT m Int64
-            -> R.ReaderT backend m Int64
 updateCount = rawEsqueleto UPDATE . from
 
 

test/Common/Test.hs

@@ -219,7 +219,6 @@ testSelect run = do
         liftIO $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ]
 
 
-
 testSelectSource :: Run -> Spec
 testSelectSource run = do
   describe "selectSource" $ do
@@ -1057,6 +1056,31 @@ testUpdate run = do
                                 , (Entity p3k p3, Value 7) ]
 
 
+-- we only care that this compiles. check that SqlWriteT doesn't fail on
+-- updates.
+testSqlWriteT :: MonadIO m => SqlWriteT m ()
+testSqlWriteT =
+  update $ \p -> do
+    set p [ PersonAge =. just (val 6) ]
+
+-- we only care that this compiles. checks that the SqlWriteT monad can run
+-- select queries.
+testSqlWriteTRead :: MonadIO m => SqlWriteT m [(Value (Key Lord), Value Int)]
+testSqlWriteTRead =
+  select $
+  from $ \ ( lord `InnerJoin` deed ) -> do
+  on $ lord ^. LordId ==. deed ^. DeedOwnerId
+  groupBy (lord ^. LordId)
+  return (lord ^. LordId, count $ deed ^. DeedId)
+
+-- we only care that this compiles checks that SqlReadT allows
+testSqlReadT :: MonadIO m => SqlReadT m [(Value (Key Lord), Value Int)]
+testSqlReadT =
+  select $
+  from $ \ ( lord `InnerJoin` deed ) -> do
+  on $ lord ^. LordId ==. deed ^. DeedOwnerId
+  groupBy (lord ^. LordId)
+  return (lord ^. LordId, count $ deed ^. DeedId)
 
 testListOfValues :: Run -> Spec
 testListOfValues run = do

test/expected-compile-failures/package.yaml

@@ -18,10 +18,33 @@ dependencies:
 - persistent
 - persistent-template
 
+default-extensions:
+- FlexibleContexts
+- FlexibleInstances
+- GADTs
+- GeneralizedNewtypeDeriving
+- MultiParamTypeClasses
+- NoMonomorphismRestriction
+- OverloadedStrings
+- QuasiQuotes
+- ScopedTypeVariables
+- StandaloneDeriving
+- TemplateHaskell
+- TypeFamilies
+
 library:
   source-dirs: src
 
 executables:
+  update-with-read-role:
+    main:                Main.hs
+    source-dirs:         update-read-role
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - expected-compile-failures
   write-with-read-role:
     main:                Main.hs
     source-dirs:         write-read-role

test/expected-compile-failures/src/Lib.hs

@@ -1 +1,31 @@
 module Lib where
+
+import Control.Monad.IO.Class (MonadIO)
+import Database.Persist.Sql (SqlReadT)
+import           Database.Esqueleto                   (SqlExpr, SqlQuery, from,
+                                                       val, (<#), insertSelect, (<&>), (^.))
+import           Database.Esqueleto.Internal.Language (Insertion)
+import           Database.Persist.TH                  (mkDeleteCascade,
+                                                       mkMigrate, mkPersist,
+                                                       persistLowerCase, share,
+                                                       sqlSettings)
+
+share [ mkPersist sqlSettings
+      , mkDeleteCascade sqlSettings
+      , mkMigrate "migrateAll"] [persistLowerCase|
+  Person
+    name String
+    age Int Maybe
+    born Int Maybe
+    deriving Eq Show
+  BlogPost
+    title String
+    authorId PersonId
+    deriving Eq Show
+  Follow
+    follower PersonId
+    followed PersonId
+    deriving Eq Show
+|]
+
+

test/expected-compile-failures/test.sh

@@ -1,7 +1,14 @@
 #!/bin/env bash
 
-if stack build --fast expected-compile-failures:exe:write-with-read-role; then
+# This script attempts to build each executable in the package, which should all
-    exit 1
+# fail with a compiler error. If any executable builds successfully, then we exit
-else
+# the script.
-    exit 0
+
-fi
+# We have to use 2>&1 because `stack ide targets` outputs to stderr for some
+# reason.
+for target in $(stack ide targets 2>&1 | grep exe); do
+    echo "Building target: $target"
+    if stack build --fast $target; then
+        exit 1
+    fi
+done

test/expected-compile-failures/update-read-role/Main.hs

@@ -0,0 +1,41 @@
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
+module Main where
+
+import Control.Monad.IO.Class (MonadIO)
+import Database.Persist.Sql (SqlWriteT)
+import           Database.Esqueleto
+
+import           Database.Esqueleto.Internal.Language (Insertion)
+import           Database.Persist.TH                  (mkDeleteCascade,
+                                                       mkMigrate, mkPersist,
+                                                       persistLowerCase, share,
+                                                       sqlSettings)
+
+import Lib
+
+main :: IO ()
+main = pure ()
+
+updateQuery :: SqlExpr (Entity Person) -> SqlQuery ()
+updateQuery = \p -> do
+    set p [ PersonAge =. just (val 123) -. p ^. PersonBorn ]
+    where_ $ isNothing (p ^. PersonAge)
+
+-- Currently gives the error:
+--
+--     /home/matt/Projects/esqueleto/test/expected-compile-failures/update-read-role/Main.hs:26:14
+-- : error:
+--         • Couldn't match type ‘backend’ with ‘SqlBackend’
+--             arising from a use of ‘update’
+--           ‘backend’ is a rigid type variable bound by
+--             the type signature for:
+--               shouldFail :: SqlReadT m ()
+--             at update-read-role/Main.hs:26:1-31
+--         • In the expression: update updateQuery
+--           In an equation for ‘shouldFail’: shouldFail = update updateQuery
+--        |
+--     26 | shouldFail = update updateQuery
+--        |              ^^^^^^^^^^^^^^^^^^
+shouldFail :: MonadIO m => SqlReadT m ()
+shouldFail = update updateQuery

test/expected-compile-failures/write-read-role/Main.hs

@@ -1,15 +1,3 @@
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GADTs                      #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoMonomorphismRestriction  #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE QuasiQuotes                #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE StandaloneDeriving         #-}
-{-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE TypeFamilies               #-}
 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 
 module Main where
@@ -24,30 +12,15 @@ import           Database.Persist.TH                  (mkDeleteCascade,
                                                        persistLowerCase, share,
                                                        sqlSettings)
 
+import Lib
+
 main :: IO ()
 main = pure ()
 
-share [ mkPersist sqlSettings
+insertQuery :: SqlQuery (SqlExpr (Insertion BlogPost))
-      , mkDeleteCascade sqlSettings
+insertQuery =
-      , mkMigrate "migrateAll"] [persistLowerCase|
-  Person
-    name String
-    age Int Maybe
-    deriving Eq Show
-  BlogPost
-    title String
-    authorId PersonId
-    deriving Eq Show
-  Follow
-    follower PersonId
-    followed PersonId
-    deriving Eq Show
-|]
-
-writeQuery :: SqlQuery (SqlExpr (Insertion BlogPost))
-writeQuery =
   from $ \p ->
   return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId)
 
 shouldFail :: MonadIO m => SqlReadT m ()
-shouldFail = insertSelect writeQuery
+shouldFail = insertSelect insertQuery