Postgresql Date Truncation (#180)

* write test case

* weird

* better error message

test/Common/Test.hs

@@ -55,9 +55,13 @@ module Common.Test
     , Numbers (..)
     , OneUnique(..)
     , Unique(..)
+    , DateTruncTest(..)
+    , DateTruncTestId
+    , Key(..)
     ) where
 
 import Data.Either
+import Data.Time
 import Control.Monad (forM_, replicateM, replicateM_, void)
 import Control.Monad.Reader (ask)
 import Control.Monad.Catch (MonadCatch)
@@ -229,6 +233,10 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
     joinOther JoinOtherId
     joinOne   JoinOneId
     deriving Eq Show
+
+  DateTruncTest
+    created   UTCTime
+    deriving Eq Show
 |]
 
 -- Unique Test schema
@@ -2584,6 +2592,8 @@ cleanDB = do
   delete $ from $ \(_ :: SqlExpr (Entity JoinOne))    -> return ()
   delete $ from $ \(_ :: SqlExpr (Entity JoinOther))    -> return ()
 
+  delete $ from $ \(_ :: SqlExpr (Entity DateTruncTest)) -> pure ()
+
 
 cleanUniques
   :: (forall m. RunDbMonad m

test/PostgreSQL/Test.hs

@@ -7,9 +7,15 @@
            , ScopedTypeVariables
            , TypeApplications
            , TypeFamilies
+           , PartialTypeSignatures
  #-}
 module Main (main) where
 
+import Data.Coerce
+import Data.Foldable
+import qualified Data.Map.Strict as Map
+import Data.Map (Map)
+import Data.Time
 import Control.Arrow ((&&&))
 import Control.Monad (void, when)
 import Control.Monad.Catch (MonadCatch, catch)
@@ -36,6 +42,7 @@ import Database.Persist.Postgresql (withPostgresqlConn)
 import Database.PostgreSQL.Simple (SqlError(..), ExecStatus(..))
 import System.Environment
 import Test.Hspec
+import Test.Hspec.QuickCheck
 
 import Common.Test
 import PostgreSQL.MigrateJSON
@@ -52,10 +59,6 @@ testPostgresqlCoalesce = do
         return (coalesce [p ^. PersonAge])
       return ()
 
-
-
-
-
 nameContains :: (BaseBackend backend ~ SqlBackend,
                  BackendCompatible SqlBackend backend,
                  MonadIO m, SqlString s,
@@ -486,6 +489,52 @@ testAggregateFunctions = do
 
 testPostgresModule :: Spec
 testPostgresModule = do
+  describe "date_trunc" $ do
+    prop "works" $ \listOfDateParts -> run $ do
+      let
+        utcTimes =
+          map
+            (\(y, m, d, s) ->
+              fromInteger s
+                `addUTCTime`
+                  UTCTime (fromGregorian (2000 + y) m d) 0
+            )
+          listOfDateParts
+        truncateDate
+          :: SqlExpr (Value String)  -- ^ .e.g (val "day")
+          -> SqlExpr (Value UTCTime) -- ^ input field
+          -> SqlExpr (Value UTCTime) -- ^ truncated date
+        truncateDate datePart expr =
+          ES.unsafeSqlFunction "date_trunc" (datePart, expr)
+        vals =
+          zip (map (DateTruncTestKey . fromInteger) [1..]) utcTimes
+      for_ vals $ \(idx, utcTime) -> do
+        insertKey idx (DateTruncTest utcTime)
+
+      ret <-
+        fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $
+        select $
+        from $ \dt -> do
+        pure
+          ( dt ^. DateTruncTestId
+          , ( dt ^. DateTruncTestCreated
+            , truncateDate (val "day") (dt ^. DateTruncTestCreated)
+            )
+          )
+
+      liftIO $ for_ vals $ \(idx, utcTime) -> do
+        case Map.lookup idx ret of
+          Nothing ->
+            expectationFailure "index not found"
+          Just (original, expected) -> do
+            utcTime `shouldBe` original
+            if utctDay utcTime == utctDay expected
+              then
+                utctDay utcTime `shouldBe` utctDay expected
+              else
+                -- use this if/else to get a beter error message
+                utcTime `shouldBe` expected
+
   describe "PostgreSQL module" $ do
     describe "Aggregate functions" testAggregateFunctions
     it "chr looks sane" $