diff --git a/.travis.yml b/.travis.yml index ab81996..da15d92 100644 --- a/.travis.yml +++ b/.travis.yml @@ -30,9 +30,9 @@ script: - stack setup - stack update - stack build - - stack test --flag esqueleto:postgresql - - stack test --flag esqueleto:-mysql - - stack test + - stack test -- esqueleto:postgresql + - stack test -- esqueleto:mysql + - stack test -- esqueleto:sqlite cache: directories: diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 897436c..3a2aa5c 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -87,14 +87,14 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| deriving Eq Show Lord - county String + county String maxlen=100 dogs Int Maybe Primary county deriving Show Deed - contract String - ownerId LordId + contract String maxlen=100 + ownerId LordId maxlen=100 Primary contract deriving Show @@ -117,12 +117,12 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| Foreign Frontcover fkfrontcover frontcoverNumber deriving Eq Show Tag - name String + name String maxlen=100 Primary name deriving Eq Show ArticleTag articleId ArticleId - tagId TagId + tagId TagId maxlen=100 Primary articleId tagId deriving Eq Show Article2 @@ -155,6 +155,13 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| sameElementsAs :: Eq a => [a] -> [a] -> Bool sameElementsAs l1 l2 = null (l1 L.\\ l2) +-- | Helper for rounding to a specific digit +-- Prelude> map (flip roundTo 12.3456) [0..5] +-- [12.0, 12.3, 12.35, 12.346, 12.3456, 12.3456] +roundTo :: (Fractional a, RealFrac a1, Integral b) => b -> a1 -> a +roundTo n f = + (fromInteger $ round $ f * (10^n)) / (10.0^^n) + p1 :: Person p1 = Person "John" (Just 36) Nothing 1 @@ -633,7 +640,12 @@ testSelectWhere run = do ret <- select $ from $ \p-> return $ joinV $ avg_ (p ^. PersonAge) - liftIO $ ret `shouldBe` [ Value $ Just ((36 + 17 + 17) / 3 :: Double) ] + let testV :: Double + testV = roundTo 4 $ (36 + 17 + 17) / 3 + + retV :: [Value (Maybe Double)] + retV = map (Value . fmap (roundTo 4) . unValue) (ret :: [Value (Maybe Double)]) + liftIO $ retV `shouldBe` [ Value $ Just testV ] it "works with min_" $ run $ do @@ -933,27 +945,6 @@ testCoasleceDefault run = do ------------------------------------------------------------------------------- -testTextFunctions :: Run -> Spec -testTextFunctions run = do - describe "text functions" $ do - it "like, (%) and (++.) work on a simple example" $ - run $ do - [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] - let nameContains t expected = do - ret <- select $ - from $ \p -> do - where_ (p ^. PersonName `like` (%) ++. val t ++. (%)) - orderBy [asc (p ^. PersonName)] - return p - liftIO $ ret `shouldBe` expected - nameContains "h" [p1e, p2e] - nameContains "i" [p4e, p3e] - nameContains "iv" [p4e] - - -------------------------------------------------------------------------------- - - testDelete :: Run -> Spec testDelete run = do describe "delete" $ @@ -1403,7 +1394,6 @@ tests run = do testSelectOrderBy run testSelectDistinct run testCoasleceDefault run - testTextFunctions run testDelete run testUpdate run testListOfValues run diff --git a/test/MySQL/Test.hs b/test/MySQL/Test.hs index c2730aa..d350c27 100644 --- a/test/MySQL/Test.hs +++ b/test/MySQL/Test.hs @@ -1,14 +1,15 @@ {-# LANGUAGE ScopedTypeVariables , FlexibleContexts , RankNTypes + , TypeFamilies #-} module Main (main) where import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Logger (MonadLogger(..), runStderrLoggingT, runNoLoggingT) -import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT) +import Control.Monad.Trans.Reader (ReaderT) import Database.Persist.MySQL ( withMySQLConn , connectHost , connectDatabase @@ -133,6 +134,40 @@ testMysqlUpdate = do ------------------------------------------------------------------------------- +nameContains :: (BaseBackend backend ~ SqlBackend, + Esqueleto query expr backend, MonadIO m, SqlString s, + IsPersistBackend backend, PersistQueryRead backend, + PersistUniqueRead backend) + => (SqlExpr (Value [Char]) + -> expr (Value s) + -> SqlExpr (Value Bool)) + -> s + -> [Entity Person] + -> ReaderT backend m () +nameContains f t expected = do + ret <- select $ + from $ \p -> do + where_ (f + (p ^. PersonName) + (concat_ [(%), val t, (%)])) + orderBy [asc (p ^. PersonName)] + return p + liftIO $ ret `shouldBe` expected + + +testMysqlTextFunctions :: Spec +testMysqlTextFunctions = do + describe "text functions" $ do + it "like, (%) and (++.) work on a simple example" $ + run $ do + [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] + nameContains like "h" [p1e, p2e] + nameContains like "i" [p4e, p3e] + nameContains like "iv" [p4e] + + +------------------------------------------------------------------------------- + main :: IO () main = do hspec $ do @@ -148,6 +183,7 @@ main = do testMysqlOneAscOneDesc testMysqlCoalesce testMysqlUpdate + testMysqlTextFunctions ------------------------------------------------------------------------------- diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index d1423d7..f8fc8b5 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -1,25 +1,16 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# LANGUAGE ConstraintKinds - , EmptyDataDecls +{-# LANGUAGE ScopedTypeVariables , FlexibleContexts - , FlexibleInstances - , DeriveGeneric - , GADTs - , GeneralizedNewtypeDeriving - , MultiParamTypeClasses - , OverloadedStrings - , QuasiQuotes - , Rank2Types - , TemplateHaskell + , RankNTypes , TypeFamilies - , ScopedTypeVariables - , TypeSynonymInstances + , OverloadedStrings #-} module Main (main) where import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT) +import Control.Monad.Trans.Reader (ReaderT) import Database.Esqueleto import Database.Persist.Postgresql (withPostgresqlConn) import Data.Ord (comparing) @@ -49,20 +40,49 @@ testPostgresqlCoalesce = do ------------------------------------------------------------------------------- -testPostgresqlTextFunction :: Spec -testPostgresqlTextFunction = do - it "ilike, (%) and (++.) work on a simple example on PostgreSQL" $ - run $ do - [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5] - let nameContains t expected = do - ret <- select $ - from $ \p -> do - where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%)) - orderBy [asc (p ^. PersonName)] - return p - liftIO $ ret `shouldBe` expected - nameContains "mi" [p3e, p5e] - nameContains "JOHN" [p1e] +nameContains :: (BaseBackend backend ~ SqlBackend, + Esqueleto query expr backend, MonadIO m, SqlString s, + IsPersistBackend backend, PersistQueryRead backend, + PersistUniqueRead backend) + => (SqlExpr (Value [Char]) + -> expr (Value s) + -> SqlExpr (Value Bool)) + -> s + -> [Entity Person] + -> ReaderT backend m () +nameContains f t expected = do + ret <- select $ + from $ \p -> do + where_ (f + (p ^. PersonName) + ((%) ++. val t ++. (%))) + orderBy [asc (p ^. PersonName)] + return p + liftIO $ ret `shouldBe` expected + + +testPostgresqlTextFunctions :: Spec +testPostgresqlTextFunctions = do + describe "text functions" $ do + it "like, (%) and (++.) work on a simple example" $ + run $ do + [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] + nameContains like "h" [p1e, p2e] + nameContains like "i" [p4e, p3e] + nameContains like "iv" [p4e] + + it "ilike, (%) and (++.) work on a simple example on PostgreSQL" $ + run $ do + [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5] + let nameContains t expected = do + ret <- select $ + from $ \p -> do + where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%)) + orderBy [asc (p ^. PersonName)] + return p + liftIO $ ret `shouldBe` expected + nameContains "mi" [p3e, p5e] + nameContains "JOHN" [p1e] ------------------------------------------------------------------------------- @@ -276,8 +296,8 @@ main = do testPostgresqlSum testPostgresqlRandom testPostgresqlUpdate - testPostgresqlTextFunction testPostgresqlCoalesce + testPostgresqlTextFunctions ------------------------------------------------------------------------------- diff --git a/test/SQLite/Test.hs b/test/SQLite/Test.hs index 868cfa3..b4d2c0e 100644 --- a/test/SQLite/Test.hs +++ b/test/SQLite/Test.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables , FlexibleContexts , RankNTypes + , TypeFamilies , OverloadedStrings #-} @@ -9,6 +10,7 @@ module Main (main) where import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT) +import Control.Monad.Trans.Reader (ReaderT) import Database.Persist.Sqlite (withSqliteConn) import Database.Sqlite (SqliteException) import Database.Esqueleto @@ -127,6 +129,40 @@ testSqliteUpdate = do ------------------------------------------------------------------------------- +nameContains :: (BaseBackend backend ~ SqlBackend, + Esqueleto query expr backend, MonadIO m, SqlString s, + IsPersistBackend backend, PersistQueryRead backend, + PersistUniqueRead backend) + => (SqlExpr (Value [Char]) + -> expr (Value s) + -> SqlExpr (Value Bool)) + -> s + -> [Entity Person] + -> ReaderT backend m () +nameContains f t expected = do + ret <- select $ + from $ \p -> do + where_ (f + (p ^. PersonName) + ((%) ++. val t ++. (%))) + orderBy [asc (p ^. PersonName)] + return p + liftIO $ ret `shouldBe` expected + +testSqliteTextFunctions :: Spec +testSqliteTextFunctions = do + describe "text functions" $ do + it "like, (%) and (++.) work on a simple example" $ + run $ do + [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] + nameContains like "h" [p1e, p2e] + nameContains like "i" [p4e, p3e] + nameContains like "iv" [p4e] + + +------------------------------------------------------------------------------- + + main :: IO () main = do hspec $ do @@ -142,6 +178,7 @@ main = do testSqliteOneAscOneDesc testSqliteCoalesce testSqliteUpdate + testSqliteTextFunctions -------------------------------------------------------------------------------