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