69 lines
2.3 KiB
Haskell
69 lines
2.3 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Data.CaseInsensitive.Instances
|
|
(
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (lift)
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Database.Persist.Sql
|
|
|
|
import Text.Blaze (ToMarkup(..))
|
|
|
|
import Data.Text (Text)
|
|
import qualified Data.Text.Encoding as Text
|
|
|
|
import Language.Haskell.TH.Syntax (Lift(..))
|
|
|
|
import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..))
|
|
|
|
|
|
instance PersistField (CI Text) where
|
|
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
|
|
fromPersistValue (PersistDbSpecific bs) = Right . CI.mk $ Text.decodeUtf8 bs
|
|
fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
|
|
|
|
instance PersistField (CI String) where
|
|
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText
|
|
fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs
|
|
fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
|
|
|
|
instance PersistFieldSql (CI Text) where
|
|
sqlType _ = SqlOther "citext"
|
|
|
|
instance PersistFieldSql (CI String) where
|
|
sqlType _ = SqlOther "citext"
|
|
|
|
instance ToJSON a => ToJSON (CI a) where
|
|
toJSON = toJSON . CI.original
|
|
|
|
instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
|
|
parseJSON = fmap CI.mk . parseJSON
|
|
|
|
instance (ToJSONKey a, ToJSON a) => ToJSONKey (CI a) where
|
|
toJSONKey = case toJSONKey of
|
|
ToJSONKeyText toVal toEnc -> ToJSONKeyText (toVal . CI.original) (toEnc . CI.original)
|
|
ToJSONKeyValue toVal toEnc -> ToJSONKeyValue (toVal . CI.original) (toEnc . CI.original)
|
|
|
|
instance (FromJSON a, FromJSONKey a, CI.FoldCase a) => FromJSONKey (CI a) where
|
|
fromJSONKey = CI.mk <$> fromJSONKey
|
|
|
|
instance ToMessage a => ToMessage (CI a) where
|
|
toMessage = toMessage . CI.original
|
|
|
|
instance ToMarkup a => ToMarkup (CI a) where
|
|
toMarkup = toMarkup . CI.original
|
|
preEscapedToMarkup = preEscapedToMarkup . CI.original
|
|
|
|
instance ToWidget site a => ToWidget site (CI a) where
|
|
toWidget = toWidget . CI.original
|
|
|
|
instance RenderMessage site a => RenderMessage site (CI a) where
|
|
renderMessage f ls msg = renderMessage f ls $ CI.original msg
|
|
|
|
instance Lift t => Lift (CI t) where
|
|
lift (CI.original -> orig) = [e|CI.mk $(lift orig)|]
|