persistent-mongoDB-2.13.0.2: test/main.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

import qualified Data.ByteString as BS
import Data.IntMap (IntMap)
import qualified Data.Text as T
import Data.Time
import Database.MongoDB (runCommand1)
import Test.QuickCheck
import Text.Blaze.Html

-- FIXME: should this be added? (RawMongoHelpers module wasn't used)
-- import qualified RawMongoHelpers
import MongoInit

-- These tests are noops with the NoSQL flags set.
--
-- import qualified CompositeTest
-- import qualified CustomPrimaryKeyReferenceTest
-- import qualified InsertDuplicateUpdate
-- import qualified PersistUniqueTest
-- import qualified PrimaryTest
-- import qualified UniqueTest
-- import qualified MigrationColumnLengthTest
-- import qualified EquivalentTypeTest

-- These modules were quite complicated. Instead of fully extracting the
-- relevant common functionality, I just copied and de-CPPed manually.
import qualified EmbedTestMongo

-- These are done.
import qualified CustomPersistFieldTest
import qualified DataTypeTest
import qualified EmbedOrderTest
import qualified EmptyEntityTest
import qualified HtmlTest
import qualified LargeNumberTest
import qualified MaxLenTest
import qualified MaybeFieldDefsTest
import qualified MigrationOnlyTest
import qualified PersistentTest
import qualified Recursive
import qualified RenameTest
import qualified SumTypeTest
import qualified TypeLitFieldDefsTest
import qualified UpsertTest

type Tuple = (,)

dbNoCleanup :: Action IO () -> Assertion
dbNoCleanup = db' (pure ())

-- FIXME: This isn't actually used?
share [mkPersist persistSettings, mkMigrate "htmlMigrate"] [persistLowerCase|
HtmlTable
    html Html
    deriving
|]

mkPersist persistSettings [persistUpperCase|
DataTypeTable no-json
    text Text
    textMaxLen Text maxlen=100
    bytes ByteString
    bytesTextTuple (Tuple ByteString Text)
    bytesMaxLen ByteString maxlen=100
    int Int
    intList [Int]
    intMap (IntMap Int)
    double Double
    bool Bool
    day Day
    utc UTCTime
|]

instance Arbitrary DataTypeTable where
  arbitrary = DataTypeTable
     <$> arbText                -- text
     <*> (T.take 100 <$> arbText)          -- textManLen
     <*> arbitrary              -- bytes
     <*> liftA2 (,) arbitrary arbText      -- bytesTextTuple
     <*> (BS.take 100 <$> arbitrary)       -- bytesMaxLen
     <*> arbitrary              -- int
     <*> arbitrary              -- intList
     <*> arbitrary              -- intMap
     <*> arbitrary              -- double
     <*> arbitrary              -- bool
     <*> arbitrary              -- day
     <*> (truncateUTCTime   =<< arbitrary) -- utc

mkPersist persistSettings [persistUpperCase|
EmptyEntity
|]

main :: IO ()
main = do
  hspec $ afterAll dropDatabase $ do
    RenameTest.specsWith (db' RenameTest.cleanDB)
    DataTypeTest.specsWith
        dbNoCleanup
        Nothing
        [ TestFn "Text" dataTypeTableText
        , TestFn "Text" dataTypeTableTextMaxLen
        , TestFn "Bytes" dataTypeTableBytes
        , TestFn "Bytes" dataTypeTableBytesTextTuple
        , TestFn "Bytes" dataTypeTableBytesMaxLen
        , TestFn "Int" dataTypeTableInt
        , TestFn "Int" dataTypeTableIntList
        , TestFn "Int" dataTypeTableIntMap
        , TestFn "Double" dataTypeTableDouble
        , TestFn "Bool" dataTypeTableBool
        , TestFn "Day" dataTypeTableDay
        ]
        []
        dataTypeTableDouble
    HtmlTest.specsWith (db' HtmlTest.cleanDB) Nothing
    EmbedTestMongo.specs
    EmbedOrderTest.specsWith (db' EmbedOrderTest.cleanDB)
    LargeNumberTest.specsWith
        (db' (deleteWhere ([] :: [Filter (LargeNumberTest.NumberGeneric backend)])))
    MaxLenTest.specsWith dbNoCleanup
    MaybeFieldDefsTest.specsWith dbNoCleanup
    TypeLitFieldDefsTest.specsWith dbNoCleanup
    Recursive.specsWith (db' Recursive.cleanup)

    SumTypeTest.specsWith (dbNoCleanup) Nothing
    MigrationOnlyTest.specsWith
        dbNoCleanup
        Nothing
    PersistentTest.specsWith (db' PersistentTest.cleanDB)
    UpsertTest.specsWith
        (db' PersistentTest.cleanDB)
        UpsertTest.AssumeNullIsZero
        UpsertTest.UpsertGenerateNewKey
    EmptyEntityTest.specsWith
        (db' EmptyEntityTest.cleanDB)
        Nothing
    CustomPersistFieldTest.specsWith
        dbNoCleanup
    -- FIXME: should this be added? (RawMongoHelpers module wasn't used)
    -- RawMongoHelpers.specs

  where
    dropDatabase () = dbNoCleanup (void (runCommand1 $ T.pack "dropDatabase()"))