From 01604be570468c7f405d42ea10491bd0d7f1a9ce Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 19 Dec 2018 09:50:10 -0700 Subject: [PATCH] Add more tests --- src/Database/Esqueleto/Internal/Sql.hs | 26 +++++------- test/Common/Test.hs | 26 +++++++++++- test/expected-compile-failures/package.yaml | 23 +++++++++++ test/expected-compile-failures/src/Lib.hs | 30 ++++++++++++++ test/expected-compile-failures/test.sh | 17 +++++--- .../update-read-role/Main.hs | 41 +++++++++++++++++++ .../write-read-role/Main.hs | 37 +++-------------- 7 files changed, 146 insertions(+), 54 deletions(-) create mode 100644 test/expected-compile-failures/update-read-role/Main.hs diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index 16a24e9..7f2e0c9 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -987,27 +987,21 @@ deleteCount = rawEsqueleto DELETE -- @ update :: - ( PersistEntityBackend val ~ backend - , PersistEntity val - , PersistUniqueWrite backend - , PersistQueryWrite backend - , BackendCompatible SqlBackend backend - , PersistEntity val - , MonadIO m + ( MonadIO m, PersistEntity val + , BackendCompatible SqlBackend (PersistEntityBackend val) ) => (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 - , PersistEntity val - , PersistEntityBackend val ~ backend - , BackendCompatible SqlBackend backend - , PersistQueryWrite backend - , PersistUniqueWrite backend) - => (SqlExpr (Entity val) -> SqlQuery ()) - -> R.ReaderT backend m Int64 +updateCount + :: + ( MonadIO m, PersistEntity val + , BackendCompatible SqlBackend (PersistEntityBackend val) + ) + => (SqlExpr (Entity val) -> SqlQuery ()) + -> SqlWriteT m Int64 updateCount = rawEsqueleto UPDATE . from diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 34c9c87..d5cac2c 100644 --- a/test/Common/Test.hs +++ b/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 diff --git a/test/expected-compile-failures/package.yaml b/test/expected-compile-failures/package.yaml index c69b2d2..97dcc27 100644 --- a/test/expected-compile-failures/package.yaml +++ b/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 diff --git a/test/expected-compile-failures/src/Lib.hs b/test/expected-compile-failures/src/Lib.hs index 6d85a26..677f7d6 100644 --- a/test/expected-compile-failures/src/Lib.hs +++ b/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 +|] + + diff --git a/test/expected-compile-failures/test.sh b/test/expected-compile-failures/test.sh index f56db51..9430449 100644 --- a/test/expected-compile-failures/test.sh +++ b/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 - exit 1 -else - exit 0 -fi +# This script attempts to build each executable in the package, which should all +# fail with a compiler error. If any executable builds successfully, then we exit +# the script. + +# 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 diff --git a/test/expected-compile-failures/update-read-role/Main.hs b/test/expected-compile-failures/update-read-role/Main.hs new file mode 100644 index 0000000..149f58a --- /dev/null +++ b/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 diff --git a/test/expected-compile-failures/write-read-role/Main.hs b/test/expected-compile-failures/write-read-role/Main.hs index 6d258cd..ddefd92 100644 --- a/test/expected-compile-failures/write-read-role/Main.hs +++ b/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 - , mkDeleteCascade sqlSettings - , 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 = +insertQuery :: SqlQuery (SqlExpr (Insertion BlogPost)) +insertQuery = from $ \p -> return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId) shouldFail :: MonadIO m => SqlReadT m () -shouldFail = insertSelect writeQuery +shouldFail = insertSelect insertQuery