Type error on upsert.

persistent-mongoDB/test/EmbedTestMongo.hs

@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}

persistent-mongoDB/test/EntityEmbedTestMongo.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE EmptyDataDecls #-}

persistent-mongoDB/test/MongoInit.hs

@@ -14,8 +14,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module MongoInit (
-  isTravis
-  , BackendMonad
+  BackendMonad
   , runConn
   , MonadIO
   , persistSettings
@@ -71,7 +70,6 @@ import qualified Data.ByteString as BS
 import Data.Text (Text)
 import Database.Persist
 import Database.Persist.TH ()
-import System.Environment (getEnvironment)
 
 import Database.Persist.Sql (PersistFieldSql(..))
 import Database.Persist.TH (mkPersistSettings)

persistent-mongoDB/test/main.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# language RankNTypes #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}

persistent-mysql/test/InsertDuplicateUpdate.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE CPP                        #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE EmptyDataDecls             #-}

persistent-mysql/test/main.hs

@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP #-}

persistent-postgresql/test/EquivalentTypeTestPostgres.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}

persistent-postgresql/test/main.hs

@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP #-}

persistent-redis/tests/basic-test.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
 {-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-}
 {-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
 module Main where
 
 import qualified Database.Redis as R
@@ -12,7 +13,7 @@ import Control.Monad.IO.Class (liftIO)
 import Data.Text (Text, pack, unpack)
 
 let redisSettings = mkPersistSettings (ConT ''RedisBackend)
- in share [mkPersist redisSettings] [persistLowerCase| 
+ in share [mkPersist redisSettings] [persistLowerCase|
 Person
     name String
     age Int
@@ -34,7 +35,7 @@ mkKey s = case keyFromValues [PersistText s] of
     Left  a -> fail (unpack a)
 
 main :: IO ()
-main = 
+main =
     withRedisConn redisConf $ runRedisPool $ do
         _ <- liftIO $ print "Inserting..."
         s <- insert $ Person "Test" 12
@@ -45,4 +46,4 @@ main =
         g <- get key :: RedisT IO (Maybe Person)
         liftIO $ print g
         delete s
-        return ()
+        return ()

persistent-sqlite/test/SqliteInit.hs

@@ -46,6 +46,7 @@ module SqliteInit (
   , truncateUTCTime
   , arbText
   , liftA2
+  , MonadFail
   ) where
 
 import Init
@@ -57,12 +58,9 @@ import Init
     )
 
 -- re-exports
-import Control.Applicative (liftA2)
 import Test.QuickCheck.Instances ()
-import Data.Char (generalCategory, GeneralCategory(..))
-import qualified Data.Text as T
-import Data.Fixed (Pico,Micro)
-import Data.Time
+-- import Data.Fixed (Pico,Micro)
+-- import Data.Time
 import Control.Applicative as A ((<$>), (<*>))
 import Control.Exception (SomeException)
 import Control.Monad (void, replicateM, liftM, when, forM_)
@@ -72,22 +70,18 @@ import Test.Hspec
 
 -- testing
 import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool)
-import Test.QuickCheck
 
 import qualified Data.ByteString as BS
-import Data.Text (Text, unpack)
+import Data.Text (Text)
 import Database.Persist
 import Database.Persist.TH ()
-import System.Environment (getEnvironment)
 
 import Control.Monad.Logger
 import Control.Monad.Trans.Resource (ResourceT, runResourceT)
 import Database.Persist.Sql
 import System.Log.FastLogger (fromLogStr)
 
 import Database.Persist.Sqlite
-import Data.IORef (newIORef, IORef, writeIORef, readIORef)
-import System.IO.Unsafe (unsafePerformIO)
 
 import Control.Monad (unless, (>=>))
 import Control.Monad.IO.Unlift (MonadUnliftIO)

persistent-sqlite/test/main.hs

@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP #-}

persistent-template/ChangeLog.md

@@ -1,3 +1,7 @@
+## 2.7.0
+
+* Depends on `persistent-2.10.0` which provides the `OnlyOneUniqueKey` and `AtLeastOneUniqueKey` classes. Automatically generates instances for these classes based on how many unique keys the entity definition gets. This changes requires `UndecidableInstances` to be enabled on each module that generates entity definitions. [TODO: add issue number]()
+
 ## 2.6.0
 * [persistent#846](https://github.com/yesodweb/persistent/pull/846): Improve error message when marshalling fails
 * [persistent#826](https://github.com/yesodweb/persistent/pull/826): Change `Unique` derive `Show`

persistent-template/Database/Persist/TH.hs

@@ -47,11 +47,16 @@ module Database.Persist.TH
     , packPTH
     , lensPTH
     , parseReferences
+    , AtLeastOneUniqueKey(..)
+    , OnlyOneUniqueKey(..)
     ) where
 
 import Prelude hiding ((++), take, concat, splitAt, exp)
+
+import qualified Data.List.NonEmpty as NEL
 import Database.Persist
 import Database.Persist.Sql (Migration, migrate, SqlBackend, PersistFieldSql)
+-- import Database.Persist.Class
 import Database.Persist.Quasi
 import Language.Haskell.TH.Lib (
 #if MIN_VERSION_template_haskell(2,11,0)
@@ -61,7 +66,7 @@ import Language.Haskell.TH.Lib (
 import Language.Haskell.TH.Quote
 import Language.Haskell.TH.Syntax
 import Data.Char (toLower, toUpper)
-import Control.Monad (forM, (<=<), mzero)
+import Control.Monad (forM, unless, (<=<), mzero)
 import qualified System.IO as SIO
 import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripPrefix, stripSuffix)
 import qualified Data.Text as T
@@ -87,6 +92,8 @@ import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..))
 import GHC.Generics (Generic)
 import qualified Data.Text.Encoding as TE
 
+import GHC.TypeLits
+
 -- | This special-cases "type_" and strips out its underscore. When
 -- used for JSON serialization and deserialization, it works around
 -- <https://github.com/yesodweb/persistent/issues/412>
@@ -116,14 +123,14 @@ persistFileWith :: PersistSettings -> FilePath -> Q Exp
 persistFileWith ps fp = persistManyFileWith ps [fp]
 
 -- | Same as 'persistFileWith', but uses several external files instead of
--- one. Splitting your Persistent definitions into multiple modules can 
+-- one. Splitting your Persistent definitions into multiple modules can
 -- potentially dramatically speed up compile times.
 --
 -- The recommended file extension is @.persistentmodels@.
 --
 -- ==== __Examples__
 --
--- Split your Persistent definitions into multiple files (@models1@, @models2@), 
+-- Split your Persistent definitions into multiple files (@models1@, @models2@),
 -- then create a new module for each new file and run 'mkPersist' there:
 --
 -- @
@@ -145,13 +152,13 @@ persistFileWith ps fp = persistManyFileWith ps [fp]
 -- -- Migrate.hs
 -- 'share'
 --     ['mkMigrate' "migrateAll"]
---     $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"]) 
+--     $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"])
 -- @
 --
 -- Tip: To get the same import behavior as if you were declaring all your models in
 -- one file, import your new files @as Name@ into another file, then export @module Name@.
 --
--- This approach may be used in the future to reduce memory usage during compilation, 
+-- This approach may be used in the future to reduce memory usage during compilation,
 -- but so far we've only seen mild reductions.
 --
 -- See <https://github.com/yesodweb/persistent/issues/778 persistent#778> and
@@ -367,7 +374,8 @@ mkPersist mps ents' = do
     x <- fmap Data.Monoid.mconcat $ mapM (persistFieldFromEntity mps) ents
     y <- fmap mconcat $ mapM (mkEntity entMap mps) ents
     z <- fmap mconcat $ mapM (mkJSON mps) ents
-    return $ mconcat [x, y, z]
+    uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents
+    return $ mconcat [x, y, z, uniqueKeyInstances]
   where
     ents = map fixEntityDef ents'
     entMap = M.fromList $ map (\ent -> (entityHaskell ent, ent)) ents
@@ -1106,6 +1114,83 @@ mkEntity entMap mps t = do
     genDataType = genericDataType mps entName backendT
     entName = entityHaskell t
 
+mkUniqueKeyInstances :: MkPersistSettings -> EntityDef -> Q [Dec]
+mkUniqueKeyInstances mps t = do
+    undecidableInstancesEnabled <- isExtEnabled UndecidableInstances
+    unless undecidableInstancesEnabled . fail
+        $ "Generating Persistent entities now requires the 'UndecidableInstances' "
+        <> "language extension. Please enable it in your file by copy/pasting "
+        <> "this line into the top of your file: \n\n"
+        <> "{-# LANGUAGE UndecidableInstances #-}"
+    case entityUniques t of
+        [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne
+        [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey
+        (_:_) -> mappend <$> typeErrorMultiple <*> atLeastOneKey
+  where
+    requireUniquesPName = mkName "requireUniquesP"
+    onlyUniquePName = mkName "onlyUniqueP"
+    typeErrorSingle = mkOnlyUniqueError typeErrorNoneCtx
+    typeErrorMultiple = mkOnlyUniqueError typeErrorMultipleCtx
+
+    withPersistStoreWriteCxt =
+        if mpsGeneric mps
+            then do
+                write <- [t|PersistStoreWrite $(pure (VarT $ mkName "backend")) |]
+                pure [write]
+            else do
+                pure []
+
+    typeErrorNoneCtx = do
+        tyErr <- [t|TypeError (NoUniqueKeysError $(pure genDataType))|]
+        (tyErr :) <$> withPersistStoreWriteCxt
+
+    typeErrorMultipleCtx = do
+        tyErr <- [t|TypeError (MultipleUniqueKeysError $(pure genDataType))|]
+        (tyErr :) <$> withPersistStoreWriteCxt
+
+    mkOnlyUniqueError :: Q Cxt -> Q [Dec]
+    mkOnlyUniqueError mkCtx = do
+        ctx <- mkCtx
+        let impl = mkImpossible onlyUniquePName
+        pure [instanceD ctx onlyOneUniqueKeyClass impl]
+
+    mkImpossible name =
+        [ FunD name
+            [ Clause
+                [ WildP ]
+                (NormalB
+                    (VarE (mkName "error") `AppE` LitE (StringL "impossible"))
+                )
+                []
+            ]
+        ]
+
+    typeErrorAtLeastOne :: Q [Dec]
+    typeErrorAtLeastOne = do
+        let impl = mkImpossible requireUniquesPName
+        cxt <- typeErrorMultipleCtx
+        pure [instanceD cxt atLeastOneUniqueKeyClass impl]
+
+    singleUniqueKey :: Q [Dec]
+    singleUniqueKey = do
+        expr <- [e|\p -> head (persistUniqueKeysP p)|]
+        let impl = [FunD onlyUniquePName [Clause [] (NormalB expr) []]]
+        cxt <- withPersistStoreWriteCxt
+        pure [instanceD cxt onlyOneUniqueKeyClass impl]
+
+    atLeastOneUniqueKeyClass = ConT ''AtLeastOneUniqueKey `AppT` genDataType
+    onlyOneUniqueKeyClass =  ConT ''OnlyOneUniqueKey `AppT` genDataType
+
+    atLeastOneKey :: Q [Dec]
+    atLeastOneKey = do
+        expr <- [e|\p -> NEL.fromList (persistUniqueKeysP p)|]
+        let impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]]
+        cxt <- withPersistStoreWriteCxt
+        pure [instanceD cxt atLeastOneUniqueKeyClass impl]
+
+    genDataType = genericDataType mps (entityHaskell t) backendT
+
+
 entityText :: EntityDef -> Text
 entityText = unHaskellName . entityHaskell
 

persistent-template/persistent-template.cabal

@@ -1,5 +1,5 @@
 name:            persistent-template
-version:         2.6.0
+version:         2.7.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -15,9 +15,9 @@ bug-reports:     https://github.com/yesodweb/persistent/issues
 extra-source-files: test/main.hs ChangeLog.md README.md
 
 library
-    build-depends:   base                     >= 4.6         && < 5
+    build-depends:   base                     >= 4.6       && < 5
                    , template-haskell
-                   , persistent               >= 2.5       && < 3
+                   , persistent               >= 2.10      && < 3
                    , monad-control            >= 0.2       && < 1.1
                    , bytestring               >= 0.9
                    , text                     >= 0.5

persistent-template/test/main.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies, GADTs #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}

persistent-test/src/CustomPersistFieldTest.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# language RankNTypes #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -15,7 +16,6 @@ module CustomPersistFieldTest (specsWith, customFieldMigrate) where
 
 import Init
 import CustomPersistField
-import Control.Monad.Fail
 
 share [mkPersist sqlSettings { mpsGeneric = True },  mkMigrate "customFieldMigrate"] [persistLowerCase|
   BlogPost

persistent-test/src/CustomPrimaryKeyReferenceTest.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}

persistent-test/src/DataTypeTest.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
 {-# LANGUAGE RankNTypes #-}

persistent-test/src/EmbedOrderTest.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}
 {-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell,
              OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, MultiParamTypeClasses #-}

persistent-test/src/EmbedTest.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE FlexibleContexts #-}

persistent-test/src/EmptyEntityTest.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE FlexibleContexts #-}

persistent-test/src/EntityEmbedTest.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE EmptyDataDecls #-}