104 lines
3.4 KiB
Haskell
104 lines
3.4 KiB
Haskell
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
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 Text.Shakespeare.Text (ToText(..))
|
|
|
|
import qualified Data.Text.Encoding as Text
|
|
|
|
import Language.Haskell.TH.Syntax (Lift(..))
|
|
|
|
import Data.Aeson (ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..))
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import Web.HttpApiData
|
|
|
|
import qualified Data.Csv as Csv
|
|
|
|
|
|
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 (E.SqlString a, PersistField (CI a)) => E.SqlString (CI a)
|
|
|
|
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 ToText a => ToText (CI a) where
|
|
toText = toText . 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 (CI.FoldCase t, Lift t) => Lift (CI t) where
|
|
liftTyped (CI.original -> orig) = [||CI.mk $$(liftTyped orig)||]
|
|
|
|
|
|
instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
|
|
fromPathPiece = fmap CI.mk . fromPathPiece
|
|
toPathPiece = toPathPiece . CI.original
|
|
|
|
instance ToHttpApiData s => ToHttpApiData (CI s) where
|
|
toUrlPiece = toUrlPiece . CI.original
|
|
toEncodedUrlPiece = toEncodedUrlPiece . CI.original
|
|
|
|
instance (CI.FoldCase s, FromHttpApiData s) => FromHttpApiData (CI s) where
|
|
parseUrlPiece = fmap CI.mk . parseUrlPiece
|
|
|
|
instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
|
|
fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
|
|
toPathMultiPiece = toPathMultiPiece . CI.original
|
|
|
|
instance Csv.ToField s => Csv.ToField (CI s) where
|
|
toField = Csv.toField . CI.original
|
|
|
|
instance (CI.FoldCase s, Csv.FromField s) => Csv.FromField (CI s) where
|
|
parseField = fmap CI.mk . Csv.parseField
|