{-# 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 Data.Text (Text)
import qualified Data.Text.Encoding as Text

import Language.Haskell.TH.Syntax (Lift(..))

import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..))

import qualified Database.Esqueleto as E

import Web.HttpApiData

import Data.Binary (Binary)
import qualified Data.Binary as Binary

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 Lift t => Lift (CI t) where
  lift (CI.original -> orig) = [e|CI.mk $(lift 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 (CI.FoldCase s, Binary s) => Binary (CI s) where
  get = CI.mk <$> Binary.get
  put = Binary.put . CI.original
  putList = Binary.putList . map 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