132 lines
4.4 KiB
Haskell
132 lines
4.4 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Data.CaseInsensitive.Instances
|
|
(
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod hiding (lift, Proxy(..))
|
|
|
|
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.Legacy as E
|
|
|
|
import Web.HttpApiData
|
|
|
|
import qualified Data.Csv as Csv
|
|
|
|
import qualified Data.Swagger as Swagger
|
|
|
|
import Utils.Persist
|
|
import Data.Proxy
|
|
|
|
import Data.Binary (Binary)
|
|
import qualified Data.Binary as Binary
|
|
|
|
|
|
instance PersistField (CI Text) where
|
|
toPersistValue ciText = PersistLiteralEscaped . Text.encodeUtf8 $ CI.original ciText
|
|
fromPersistValue (PersistLiteralEscaped bs) = Right . CI.mk $ Text.decodeUtf8 bs
|
|
fromPersistValue x = Left $ fromPersistValueErrorSql (Proxy @(CI Text)) x
|
|
|
|
instance PersistField (CI String) where
|
|
toPersistValue ciText = PersistLiteralEscaped . Text.encodeUtf8 . pack $ CI.original ciText
|
|
fromPersistValue (PersistLiteralEscaped bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs
|
|
fromPersistValue x = Left $ fromPersistValueErrorSql (Proxy @(CI String)) 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 PathPiece [CI Char] where
|
|
fromPathPiece = fmap (map CI.mk . (unpack :: Text -> [Char])) . fromPathPiece
|
|
toPathPiece = toPathPiece . (pack :: [Char] -> Text) . map CI.original
|
|
|
|
instance ToHttpApiData s => ToHttpApiData (CI s) where
|
|
toUrlPiece = toUrlPiece . CI.original
|
|
toEncodedUrlPiece = toEncodedUrlPiece . CI.original
|
|
toHeader = toHeader . CI.original
|
|
toQueryParam = toQueryParam . 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
|
|
|
|
instance Swagger.ToParamSchema s => Swagger.ToParamSchema (CI s) where
|
|
toParamSchema _ = Swagger.toParamSchema (Proxy @s)
|
|
|
|
instance Swagger.ToSchema s => Swagger.ToSchema (CI s) where
|
|
declareNamedSchema _ = Swagger.declareNamedSchema (Proxy @s)
|
|
|
|
instance (CI.FoldCase s, Binary s) => Binary (CI s) where
|
|
get = CI.mk <$> Binary.get
|
|
put = Binary.put . CI.original
|