{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}

module Opaleye.Internal.Inferrable where

import qualified Opaleye.Field as F
import           Opaleye.Internal.RunQuery (FromField, FromFields)
import qualified Opaleye.Internal.RunQuery as RQ
import qualified Opaleye.SqlTypes as T
import           Opaleye.Internal.Constant (ToFields)

import qualified Data.ByteString as SBS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.CaseInsensitive as CI
import qualified Data.Profunctor as P
import qualified Data.Profunctor.Product as PP
import qualified Data.Profunctor.Product.Default as D
import qualified Data.Scientific                 as Sci
import qualified Data.Text.Lazy as LT
import qualified Data.Text as ST
import qualified Data.Time.Compat as Time
import           Data.Typeable (Typeable)
import           Data.UUID (UUID)
import qualified Database.PostgreSQL.Simple.Range as R
import           GHC.Int (Int32, Int64)

-- | Despite its name, 'Inferrable' doesn't provide any inferability
-- improvements itself, it's just a conveniently-named newtype wrapper
-- to hang instances with better inferrability off of.
newtype Inferrable p a b = Inferrable { forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable :: p a b }

-- FromFields

instance
  D.Default (Inferrable FromField) a b
  => D.Default (Inferrable FromFields) (F.Field a) b where
  def :: Inferrable FromFields (Field a) b
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable (forall a b. FromField a b -> FromFields (Field a) b
RQ.fromFields (forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def))

instance
     (D.Default (Inferrable FromField) a b, Maybe b ~ maybe_b)
  => D.Default (Inferrable FromFields) (F.FieldNullable a) maybe_b where
  def :: Inferrable FromFields (FieldNullable a) maybe_b
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable (forall a b. FromField a b -> FromFields (FieldNullable a) (Maybe b)
RQ.fromFieldsNullable (forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def))

-- FromField

instance int ~ Int => D.Default (Inferrable FromField) T.SqlInt4 int where
  def :: Inferrable FromField SqlInt4 int
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance int64 ~ Int64 => D.Default (Inferrable FromField) T.SqlInt8 int64 where
  def :: Inferrable FromField SqlInt8 int64
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance text ~ ST.Text => D.Default (Inferrable FromField) T.SqlText text where
  def :: Inferrable FromField SqlText text
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance varchar ~ ST.Text => D.Default (Inferrable FromField) T.SqlVarcharN varchar where
  def :: Inferrable FromField SqlVarcharN varchar
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance (Typeable h, D.Default (Inferrable FromField) f h, hs ~ [h])
  => D.Default (Inferrable FromField) (T.SqlArray f) hs where
  def :: Inferrable FromField (SqlArray f) hs
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable (forall h f.
Typeable h =>
FromField f h -> FromField (SqlArray_ 'NonNullable f) [h]
RQ.fromFieldArray (forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def))

instance (Typeable h, D.Default (Inferrable FromField) f h, hs ~ [Maybe h])
  => D.Default (Inferrable FromField) (T.SqlArray_ F.Nullable f) hs where
  def :: Inferrable FromField (SqlArray_ 'Nullable f) hs
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable (forall h f.
Typeable h =>
FromField f h -> FromField (SqlArray_ 'Nullable f) [Maybe h]
RQ.fromFieldArrayNullable (forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def))

instance double ~ Double => D.Default (Inferrable FromField) T.SqlFloat8 double where
  def :: Inferrable FromField SqlFloat8 double
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance scientific ~ Sci.Scientific
  => D.Default (Inferrable FromField) T.SqlNumeric scientific where
  def :: Inferrable FromField SqlNumeric scientific
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance bool ~ Bool => D.Default (Inferrable FromField) T.SqlBool bool where
  def :: Inferrable FromField SqlBool bool
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance uuid ~ UUID => D.Default (Inferrable FromField) T.SqlUuid uuid where
  def :: Inferrable FromField SqlUuid uuid
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance bytestring ~ SBS.ByteString
  => D.Default (Inferrable FromField) T.SqlBytea bytestring where
  def :: Inferrable FromField SqlBytea bytestring
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance day ~ Time.Day
  => D.Default (Inferrable FromField) T.SqlDate day where
  def :: Inferrable FromField SqlDate day
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

-- I'm not certain what we should map timestamptz to.  The
-- postgresql-simple types it maps to are ZonedTime and UTCTime, but
-- maybe it's more accurate to map it to a *pair* of LocalTime and a
-- time zone.

--instance utctime ~ Time.UTCTime
--  => D.Default (Inferrable FromField) T.SqlTimestamptz utctime where
--  def = Inferrable D.def

instance localtime ~ Time.LocalTime
  => D.Default (Inferrable FromField) T.SqlTimestamp localtime where
  def :: Inferrable FromField SqlTimestamp localtime
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance timeofday ~ Time.TimeOfDay
  => D.Default (Inferrable FromField) T.SqlTime timeofday where
  def :: Inferrable FromField SqlTime timeofday
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance calendardifftime ~ Time.CalendarDiffTime
  => D.Default (Inferrable FromField) T.SqlInterval calendardifftime where
  def :: Inferrable FromField SqlInterval calendardifftime
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance cttext ~ CI.CI ST.Text
  => D.Default (Inferrable FromField) T.SqlCitext cttext where
  def :: Inferrable FromField SqlCitext cttext
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

-- It's not clear what to map JSON types to

{-
instance DefaultFromField T.PGJson String where
  defaultFromField = fromPGSFieldParser jsonFieldParser

instance DefaultFromField T.PGJson Ae.Value where
  defaultFromField = fromPGSFromField

instance DefaultFromField T.PGJsonb String where
  defaultFromField = fromPGSFieldParser jsonbFieldParser

instance DefaultFromField T.PGJsonb Ae.Value where
  defaultFromField = fromPGSFromField

instance DefaultFromField T.PGTimestamptz Time.UTCTime where
  defaultFromField = fromPGSFromField

instance DefaultFromField T.PGTimestamptz Time.ZonedTime where
  defaultFromField = fromPGSFromField
-}

-- ToFields

{- The instance for arrays would clash with String.  String is going to
   be used far more, so to get arrays you'll have to explicitly use
   `sqlArray`.

instance (D.Default (Inferrable ToFields) a (C.Column b),
          T.IsSqlType b,
          C.Column (T.SqlArray b) ~ cSqlArrayb)
         => D.Default (Inferrable ToFields) [a] cSqlArrayb where
  def = Inferrable (toToFields (T.sqlArray (toFieldsExplicit
                                               (runInferrable D.def))))
-}

instance F.Field a ~ fieldA
  => D.Default (Inferrable ToFields) (F.Field a) fieldA where
  def :: Inferrable ToFields (Field a) fieldA
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlText ~ cSqlText
  => D.Default (Inferrable ToFields) String cSqlText where
  def :: Inferrable ToFields String cSqlText
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlBytea ~ cSqlBytea
  => D.Default (Inferrable ToFields) LBS.ByteString cSqlBytea where
  def :: Inferrable ToFields ByteString cSqlBytea
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlBytea ~ cSqlBytea
  => D.Default (Inferrable ToFields) SBS.ByteString cSqlBytea where
  def :: Inferrable ToFields ByteString cSqlBytea
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlText ~ cSqlText
  => D.Default (Inferrable ToFields) ST.Text cSqlText where
  def :: Inferrable ToFields Text cSqlText
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlText ~ cSqlText
  => D.Default (Inferrable ToFields) LT.Text cSqlText where
  def :: Inferrable ToFields Text cSqlText
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlNumeric ~ cSqlNumeric
  => D.Default (Inferrable ToFields) Sci.Scientific cSqlNumeric where
  def :: Inferrable ToFields Scientific cSqlNumeric
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlInt4 ~ cSqlInt4
  => D.Default (Inferrable ToFields) Int cSqlInt4 where
  def :: Inferrable ToFields Int cSqlInt4
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlInt4 ~ cSqlInt4
  => D.Default (Inferrable ToFields) Int32 cSqlInt4 where
  def :: Inferrable ToFields Int32 cSqlInt4
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlInt8 ~ cSqlInt8
  => D.Default (Inferrable ToFields) Int64 cSqlInt8 where
  def :: Inferrable ToFields Int64 cSqlInt8
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlFloat8 ~ cSqlFloat8
  => D.Default (Inferrable ToFields) Double cSqlFloat8 where
  def :: Inferrable ToFields Double cSqlFloat8
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlBool ~ cSqlBool
  => D.Default (Inferrable ToFields) Bool cSqlBool where
  def :: Inferrable ToFields Bool cSqlBool
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlUuid ~ cSqlUuid
  => D.Default (Inferrable ToFields) UUID cSqlUuid where
  def :: Inferrable ToFields UUID cSqlUuid
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlDate ~ cSqlDate
  => D.Default (Inferrable ToFields) Time.Day cSqlDate where
  def :: Inferrable ToFields Day cSqlDate
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlTimestamptz ~ cSqlTimestamptz
  => D.Default (Inferrable ToFields) Time.UTCTime cSqlTimestamptz where
  def :: Inferrable ToFields UTCTime cSqlTimestamptz
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlTimestamptz ~ cSqlTimestamptz
  => D.Default (Inferrable ToFields) Time.ZonedTime cSqlTimestamptz where
  def :: Inferrable ToFields ZonedTime cSqlTimestamptz
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlTime ~ cSqlTime
  => D.Default (Inferrable ToFields) Time.TimeOfDay cSqlTime where
  def :: Inferrable ToFields TimeOfDay cSqlTime
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlInterval ~ cSqlInterval
  => D.Default (Inferrable ToFields) Time.CalendarDiffTime cSqlInterval where
  def :: Inferrable ToFields CalendarDiffTime cSqlInterval
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlCitext ~ cSqlCitext
  => D.Default (Inferrable ToFields) (CI.CI ST.Text) cSqlCitext where
  def :: Inferrable ToFields (CI Text) cSqlCitext
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field T.SqlCitext ~ cSqlCitext
  => D.Default (Inferrable ToFields) (CI.CI LT.Text) cSqlCitext where
  def :: Inferrable ToFields (CI Text) cSqlCitext
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field (T.SqlRange T.SqlInt4) ~ cRangeInt4
  => D.Default (Inferrable ToFields) (R.PGRange Int) cRangeInt4 where
  def :: Inferrable ToFields (PGRange Int) cRangeInt4
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field (T.SqlRange T.SqlInt8) ~ cRangeInt8
  => D.Default (Inferrable ToFields) (R.PGRange Int64) cRangeInt8 where
  def :: Inferrable ToFields (PGRange Int64) cRangeInt8
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field (T.SqlRange T.SqlNumeric) ~ cRangeScientific
  => D.Default (Inferrable ToFields) (R.PGRange Sci.Scientific) cRangeScientific where
  def :: Inferrable ToFields (PGRange Scientific) cRangeScientific
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field (T.SqlRange T.SqlTimestamp) ~ cRangeTimestamp
  => D.Default (Inferrable ToFields) (R.PGRange Time.LocalTime) cRangeTimestamp where
  def :: Inferrable ToFields (PGRange LocalTime) cRangeTimestamp
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field (T.SqlRange T.SqlTimestamptz) ~ cRangeTimestamptz
  => D.Default (Inferrable ToFields) (R.PGRange Time.UTCTime) cRangeTimestamptz where
  def :: Inferrable ToFields (PGRange UTCTime) cRangeTimestamptz
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

instance F.Field (T.SqlRange T.SqlDate) ~ cRangeDate
  => D.Default (Inferrable ToFields) (R.PGRange Time.Day) cRangeDate where
  def :: Inferrable ToFields (PGRange Day) cRangeDate
def = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall (p :: * -> * -> *) a b. Default p a b => p a b
D.def

{-  It's not clear if Aeson Value should map to JSON or JSONB.

instance D.Default ToFields Ae.Value (Column T.SqlJson) where
  def = Constant T.sqlValueJSON

instance D.Default ToFields Ae.Value (Column T.SqlJsonb) where
  def = Constant T.sqlValueJSONB

-}

-- Boilerplate instances

instance Functor (p a) => Functor (Inferrable p a) where
  fmap :: forall a b. (a -> b) -> Inferrable p a a -> Inferrable p a b
fmap a -> b
f = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable

instance Applicative (p a) => Applicative (Inferrable p a) where
  pure :: forall a. a -> Inferrable p a a
pure = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Inferrable p a (a -> b)
f <*> :: forall a b.
Inferrable p a (a -> b) -> Inferrable p a a -> Inferrable p a b
<*> Inferrable p a a
x = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable (forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable Inferrable p a (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable Inferrable p a a
x)

instance P.Profunctor p => P.Profunctor (Inferrable p) where
  dimap :: forall a b c d.
(a -> b) -> (c -> d) -> Inferrable p b c -> Inferrable p a d
dimap a -> b
f c -> d
g = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
P.dimap a -> b
f c -> d
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable

instance PP.ProductProfunctor p => PP.ProductProfunctor (Inferrable p) where
  purePP :: forall b a. b -> Inferrable p a b
purePP = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b a. ProductProfunctor p => b -> p a b
PP.purePP
  Inferrable p a (b -> c)
f **** :: forall a b c.
Inferrable p a (b -> c) -> Inferrable p a b -> Inferrable p a c
**** Inferrable p a b
g = forall (p :: * -> * -> *) a b. p a b -> Inferrable p a b
Inferrable (forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable Inferrable p a (b -> c)
f forall (p :: * -> * -> *) a b c.
ProductProfunctor p =>
p a (b -> c) -> p a b -> p a c
PP.**** forall (p :: * -> * -> *) a b. Inferrable p a b -> p a b
runInferrable Inferrable p a b
g)