{-# 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 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

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 (CI.FoldCase s, Binary s) => Binary (CI s) where
  get = CI.mk <$> Binary.get
  put = Binary.put . CI.original