43 lines
1.2 KiB
Haskell
43 lines
1.2 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# LANGUAGE UndecidableInstances, GeneralizedNewtypeDeriving #-}
|
|
|
|
module Database.Persist.Class.Instances
|
|
(
|
|
) where
|
|
|
|
import ClassyPrelude
|
|
|
|
import Database.Persist.Class
|
|
import Database.Persist.Types.Instances ()
|
|
import Database.Persist.Sql
|
|
|
|
import Data.Binary (Binary)
|
|
import qualified Data.Binary as Binary
|
|
import Data.Binary.Instances.Time as Import ()
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import Data.Aeson (ToJSONKey, FromJSONKey)
|
|
|
|
import Control.Monad.Fail
|
|
|
|
|
|
instance PersistEntity record => Hashable (Key record) where
|
|
hashWithSalt s = hashWithSalt s . toPersistValue
|
|
|
|
instance PersistEntity record => Binary (Key record) where
|
|
put = Binary.put . toPersistValue
|
|
putList = Binary.putList . map toPersistValue
|
|
get = either (fail . unpack) return . fromPersistValue =<< Binary.get
|
|
|
|
|
|
uniqueToMap :: PersistEntity record => Unique record -> Map (FieldNameHS, FieldNameDB) PersistValue
|
|
uniqueToMap = fmap Map.fromList $ zip <$> fmap toList persistUniqueToFieldNames <*> persistUniqueToValues
|
|
|
|
instance PersistEntity record => Eq (Unique record) where
|
|
(==) = (==) `on` uniqueToMap
|
|
|
|
|
|
deriving newtype instance ToJSONKey (BackendKey SqlBackend)
|
|
deriving newtype instance FromJSONKey (BackendKey SqlBackend)
|