{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Hasql.Interpolate.Internal.Decoder
  ( -- * Decoding type classes
    DecodeValue (..),
    DecodeField (..),
    DecodeRow (..),
    DecodeResult (..),

    -- * Generics
    GDecodeRow (..),
  )
where

import Data.ByteString (ByteString)
import Data.ByteString.Lazy (LazyByteString)
import qualified Data.ByteString.Lazy as LazyByteString
import Data.IP (IPRange)
import Data.Int (Int16, Int32, Int64)
import Data.Scientific (Scientific)
import Data.Text (Text)
import Data.Time (Day, DiffTime, LocalTime, UTCTime)
import Data.UUID (UUID)
import Data.Vector (Vector)
import GHC.Generics
import Hasql.Decoders
import Hasql.Interpolate.Internal.Decoder.TH (genDecodeRowInstance)

-- | This type class determines which decoder we will apply to a query
-- field by the type of the result.
--
-- ==== __Example__
--
-- @
--
-- data ThreatLevel = None | Midnight
--
-- instance DecodeValue ThreatLevel where
--   decodeValue = enum \\case
--     "none"     -> Just None
--     "midnight" -> Just Midnight
--     _          -> Nothing
-- @
class DecodeValue a where
  decodeValue :: Value a

-- | You do not need to define instances for this class; The two
-- instances exported here cover all uses. The class only exists to
-- lift 'Value' to hasql's 'NullableOrNot' GADT.
class DecodeField a where
  decodeField :: NullableOrNot Value a

-- | Determine a row decoder from a Haskell type. Derivable with
-- generics for any product type.
--
-- ==== __Examples__
--
-- A manual instance:
--
-- @
-- data T = T Int64 Bool Text
--
-- instance DecodeRow T where
--   decodeRow = T
--     <$> column decodeField
--     <*> column decodeField
--     <*> column decodeField
-- @
--
-- A generic instance:
--
-- @
-- data T
--  = T Int64 Bool Text
--  deriving stock (Generic)
--  deriving anyclass (DecodeRow)
-- @
class DecodeRow a where
  decodeRow :: Row a
  default decodeRow :: (Generic a, GDecodeRow (Rep a)) => Row a
  decodeRow = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a) -> Row (Rep a Any) -> Row a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Row (Rep a Any)
forall p. Row (Rep a p)
forall (a :: * -> *) p. GDecodeRow a => Row (a p)
gdecodeRow

class GDecodeRow a where
  gdecodeRow :: Row (a p)

-- | Determine a result decoder from a Haskell type.
class DecodeResult a where
  decodeResult :: Result a

instance (GDecodeRow a) => GDecodeRow (M1 t i a) where
  gdecodeRow :: forall p. Row (M1 t i a p)
gdecodeRow = a p -> M1 t i a p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a p -> M1 t i a p) -> Row (a p) -> Row (M1 t i a p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Row (a p)
forall p. Row (a p)
forall (a :: * -> *) p. GDecodeRow a => Row (a p)
gdecodeRow

instance (GDecodeRow a, GDecodeRow b) => GDecodeRow (a :*: b) where
  gdecodeRow :: forall p. Row ((:*:) a b p)
gdecodeRow = a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a p -> b p -> (:*:) a b p)
-> Row (a p) -> Row (b p -> (:*:) a b p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Row (a p)
forall p. Row (a p)
forall (a :: * -> *) p. GDecodeRow a => Row (a p)
gdecodeRow Row (b p -> (:*:) a b p) -> Row (b p) -> Row ((:*:) a b p)
forall a b. Row (a -> b) -> Row a -> Row b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Row (b p)
forall p. Row (b p)
forall (a :: * -> *) p. GDecodeRow a => Row (a p)
gdecodeRow

instance (DecodeField a) => GDecodeRow (K1 i a) where
  gdecodeRow :: forall p. Row (K1 i a p)
gdecodeRow = a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a p) -> Row a -> Row (K1 i a p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NullableOrNot Value a -> Row a
forall a. NullableOrNot Value a -> Row a
column NullableOrNot Value a
forall a. DecodeField a => NullableOrNot Value a
decodeField

-- | Parse a postgres @array@ using 'listArray'
instance (DecodeField a) => DecodeValue [a] where
  decodeValue :: Value [a]
decodeValue = NullableOrNot Value a -> Value [a]
forall element. NullableOrNot Value element -> Value [element]
listArray NullableOrNot Value a
forall a. DecodeField a => NullableOrNot Value a
decodeField

-- | Parse a postgres @array@ using 'vectorArray'
instance (DecodeField a) => DecodeValue (Vector a) where
  decodeValue :: Value (Vector a)
decodeValue = NullableOrNot Value a -> Value (Vector a)
forall (vector :: * -> *) element.
Vector vector element =>
NullableOrNot Value element -> Value (vector element)
vectorArray NullableOrNot Value a
forall a. DecodeField a => NullableOrNot Value a
decodeField

-- | Parse a postgres @bool@ using 'bool'
instance DecodeValue Bool where
  decodeValue :: Value Bool
decodeValue = Value Bool
bool

-- | Parse a postgres @text@ using 'text'
instance DecodeValue Text where
  decodeValue :: Value Text
decodeValue = Value Text
text

-- | Parse a postgres @int2@ using 'int2'
instance DecodeValue Int16 where
  decodeValue :: Value Int16
decodeValue = Value Int16
int2

-- | Parse a postgres @int4@ using 'int4'
instance DecodeValue Int32 where
  decodeValue :: Value Int32
decodeValue = Value Int32
int4

-- | Parse a postgres @int8@ using 'int8'
instance DecodeValue Int64 where
  decodeValue :: Value Int64
decodeValue = Value Int64
int8

-- | Parse a postgres @float4@ using 'float4'
instance DecodeValue Float where
  decodeValue :: Value Float
decodeValue = Value Float
float4

-- | Parse a postgres @float8@ using 'float8'
instance DecodeValue Double where
  decodeValue :: Value Double
decodeValue = Value Double
float8

-- | Parse a postgres @char@ using 'char'
instance DecodeValue Char where
  decodeValue :: Value Char
decodeValue = Value Char
char

-- | Parse a postgres @date@ using 'date'
instance DecodeValue Day where
  decodeValue :: Value Day
decodeValue = Value Day
date

-- | Parse a postgres @timestamp@ using 'timestamp'
instance DecodeValue LocalTime where
  decodeValue :: Value LocalTime
decodeValue = Value LocalTime
timestamp

-- | Parse a postgres @timestamptz@ using 'timestamptz'
instance DecodeValue UTCTime where
  decodeValue :: Value UTCTime
decodeValue = Value UTCTime
timestamptz

-- | Parse a postgres @numeric@ using 'numeric'
instance DecodeValue Scientific where
  decodeValue :: Value Scientific
decodeValue = Value Scientific
numeric

-- | Parse a postgres @interval@ using 'interval'
instance DecodeValue DiffTime where
  decodeValue :: Value DiffTime
decodeValue = Value DiffTime
interval

-- | Parse a postgres @uuid@ using 'uuid'
instance DecodeValue UUID where
  decodeValue :: Value UUID
decodeValue = Value UUID
uuid

-- | Parse a postgres @inet@ using 'inet'
instance DecodeValue IPRange where
  decodeValue :: Value IPRange
decodeValue = Value IPRange
inet

-- | Parse a postgres @bytea@ using 'bytea'
instance DecodeValue ByteString where
  decodeValue :: Value ByteString
decodeValue = Value ByteString
bytea

-- | Parse a postgres @bytea@ using 'bytea'
instance DecodeValue LazyByteString where
  decodeValue :: Value LazyByteString
decodeValue = ByteString -> LazyByteString
LazyByteString.fromStrict (ByteString -> LazyByteString)
-> Value ByteString -> Value LazyByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value ByteString
bytea

-- | Overlappable instance for parsing non-nullable values
instance {-# OVERLAPPABLE #-} (DecodeValue a) => DecodeField a where
  decodeField :: NullableOrNot Value a
decodeField = Value a -> NullableOrNot Value a
forall (decoder :: * -> *) a. decoder a -> NullableOrNot decoder a
nonNullable Value a
forall a. DecodeValue a => Value a
decodeValue

-- | Instance for parsing nullable values
instance (DecodeValue a) => DecodeField (Maybe a) where
  decodeField :: NullableOrNot Value (Maybe a)
decodeField = Value a -> NullableOrNot Value (Maybe a)
forall (decoder :: * -> *) a.
decoder a -> NullableOrNot decoder (Maybe a)
nullable Value a
forall a. DecodeValue a => Value a
decodeValue

-- | Parse any number of rows into a list ('rowList')
instance (DecodeRow a) => DecodeResult [a] where
  decodeResult :: Result [a]
decodeResult = Row a -> Result [a]
forall a. Row a -> Result [a]
rowList Row a
forall a. DecodeRow a => Row a
decodeRow

-- | Parse any number of rows into a 'Vector' ('rowVector')
instance (DecodeRow a) => DecodeResult (Vector a) where
  decodeResult :: Result (Vector a)
decodeResult = Row a -> Result (Vector a)
forall a. Row a -> Result (Vector a)
rowVector Row a
forall a. DecodeRow a => Row a
decodeRow

-- | Parse zero or one rows, throw 'Hasql.Errors.UnexpectedAmountOfRows' otherwise. ('rowMaybe')
instance (DecodeRow a) => DecodeResult (Maybe a) where
  decodeResult :: Result (Maybe a)
decodeResult = Row a -> Result (Maybe a)
forall a. Row a -> Result (Maybe a)
rowMaybe Row a
forall a. DecodeRow a => Row a
decodeRow

-- | Ignore the query response ('noResult')
instance DecodeResult () where
  decodeResult :: Result ()
decodeResult = Result ()
noResult

$(traverse genDecodeRowInstance [2 .. 16])