Decoders.hs

-- | Obtain row decoders automatically via either constructors or @ generics-sop @
module Hasql.Auto.Decoders (
  -- * Rows
  defaultRowFor,
  defaultRowForProductType,
  defaultColumn,

  -- * Composites
  defaultCompositeFor,
  defaultCompositeForProductType,
  defaultCompositeField,

  -- * Value decoding
  defaultNullableOrNotValue,
  DefaultValue (..),

  -- * Types
  LiftDefaultRow,
  DefaultRowFor,
  DefaultCompositeFor,
  DefaultNullableOrNotValue,
)
where

import Data.Aeson (FromJSON (..))
import Data.Aeson qualified as JSON
import Data.ByteString (ByteString)
import Data.Functor ((<&>))
import Data.Int (Int16, Int32, Int64)
import Data.Proxy (Proxy (..))
import Data.Scientific (Scientific)
import Data.String (fromString)
import Data.Text (Text)
import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
import Data.Vector (Vector)
import Generics.SOP qualified as SOP
import Hasql.Auto.Types
import Hasql.Decoders qualified as D
import PostgreSQL.Binary.Range (Multirange, Range (..))

--------------------------------------------------------------------------------
-- Rows
--------------------------------------------------------------------------------

-- | Create a 'D.Row' decoder for a given constructor function. Each argument of
-- the constructor function corresponds to a column to be decoded in the row,
-- whose decoder is provided by 'DefaultNullableOrNotValue', which determines
-- the use of 'D.nullable' or 'D.nonNullable', and is an abstraction over
-- the user-extensible 'DefaultValue' typeclass.
{-# INLINE defaultRowFor #-}
defaultRowFor
  :: forall a f
   . (DefaultRowFor a f)
  => f
  -> D.Row a
defaultRowFor f = liftDefaultRow @(GetConstructorShape f) (pure f)

-- | Create a 'D.Row' decoder for any product type with a 'SOP.Generic' instance
{-# INLINE defaultRowForProductType #-}
defaultRowForProductType :: (SOP.IsProductType a xs, SOP.All DefaultNullableOrNotValue xs) => D.Row a
defaultRowForProductType =
  SOP.productTypeTo
    <$> SOP.hsequence (SOP.hcpure (Proxy :: Proxy DefaultNullableOrNotValue) defaultColumn)

type DefaultRowFor a f = LiftDefaultRow (GetConstructorShape f) a f

class LiftDefaultRow (shape :: ConstructorShape) a f where
  liftDefaultRow :: D.Row f -> D.Row a

instance
  ( DefaultNullableOrNotValue x
  , LiftDefaultRow next r' r
  )
  => LiftDefaultRow (AddColumn next) r' (x -> r)
  where
  {-# INLINE liftDefaultRow #-}
  liftDefaultRow r = liftDefaultRow @next (r <*> defaultColumn)

instance (r ~ r') => LiftDefaultRow DecoderDone r r' where
  {-# INLINE liftDefaultRow #-}
  liftDefaultRow r = r

defaultColumn :: (DefaultNullableOrNotValue a) => D.Row a
defaultColumn = D.column defaultNullableOrNotValue

--------------------------------------------------------------------------------
-- Composite s
--------------------------------------------------------------------------------

type DefaultCompositeFor a f = LiftDefaultComposite (GetConstructorShape f) a f

-- | Create a 'D.Composite' decoder for a given constructor function, a la
-- 'defaultRowFor'.
{-# INLINE defaultCompositeFor #-}
defaultCompositeFor
  :: forall a f
   . (DefaultCompositeFor a f)
  => f
  -> D.Composite a
defaultCompositeFor f =
  liftDefaultComposite @(GetConstructorShape f) (pure f)

-- | Create a 'D.Composite' decoder for any product type with a 'SOP.Generic' instance
{-# INLINE defaultCompositeForProductType #-}
defaultCompositeForProductType :: (SOP.IsProductType a xs, SOP.All DefaultNullableOrNotValue xs) => D.Composite a
defaultCompositeForProductType =
  SOP.productTypeTo
    <$> SOP.hsequence (SOP.hcpure (Proxy :: Proxy DefaultNullableOrNotValue) defaultCompositeField)

class LiftDefaultComposite (shape :: ConstructorShape) a f where
  liftDefaultComposite :: D.Composite f -> D.Composite a

instance
  ( DefaultNullableOrNotValue x
  , LiftDefaultComposite next r' r
  )
  => LiftDefaultComposite (AddColumn next) r' (x -> r)
  where
  {-# INLINE liftDefaultComposite #-}
  liftDefaultComposite r = liftDefaultComposite @next (r <*> defaultCompositeField)

instance (r ~ r') => LiftDefaultComposite DecoderDone r r' where
  {-# INLINE liftDefaultComposite #-}
  liftDefaultComposite r = r

defaultCompositeField :: (DefaultNullableOrNotValue a) => D.Composite a
defaultCompositeField = D.field defaultNullableOrNotValue

--------------------------------------------------------------------------------
-- Value s
--------------------------------------------------------------------------------

defaultNullableOrNotValue
  :: forall a
   . (DefaultNullableOrNotValue a)
  => D.NullableOrNot D.Value a
defaultNullableOrNotValue = defaultNullableOrNotValue_

class DefaultValue a where
  defaultValue :: D.Value a

class DefaultNullableOrNotValue a where
  defaultNullableOrNotValue_ :: D.NullableOrNot D.Value a

-- | When both instances match, this instance takes precedence
instance {-# OVERLAPPING #-} (DefaultValue a) => DefaultNullableOrNotValue (Maybe a) where
  defaultNullableOrNotValue_ = D.nullable defaultValue

instance (DefaultValue a) => DefaultNullableOrNotValue a where
  defaultNullableOrNotValue_ = D.nonNullable defaultValue

--------------------------------------------------------------------------------
-- Instances for PostgreSQL types

instance DefaultValue Bool where
  {-# INLINE defaultValue #-}
  defaultValue = D.bool

instance DefaultValue Int16 where
  {-# INLINE defaultValue #-}
  defaultValue = D.int2

instance DefaultValue Int32 where
  {-# INLINE defaultValue #-}
  defaultValue = D.int4

instance DefaultValue Int64 where
  {-# INLINE defaultValue #-}
  defaultValue = D.int8

instance DefaultValue Float where
  {-# INLINE defaultValue #-}
  defaultValue = D.float4

instance DefaultValue Double where
  {-# INLINE defaultValue #-}
  defaultValue = D.float8

instance DefaultValue Scientific where
  {-# INLINE defaultValue #-}
  defaultValue = D.numeric

instance DefaultValue Char where
  {-# INLINE defaultValue #-}
  defaultValue = D.char

instance DefaultValue Text where
  {-# INLINE defaultValue #-}
  defaultValue = D.text

instance DefaultValue ByteString where
  {-# INLINE defaultValue #-}
  defaultValue = D.bytea

instance DefaultValue Day where
  {-# INLINE defaultValue #-}
  defaultValue = D.date

instance DefaultValue LocalTime where
  {-# INLINE defaultValue #-}
  defaultValue = D.timestamp

instance DefaultValue UTCTime where
  {-# INLINE defaultValue #-}
  defaultValue = D.timestamptz

instance DefaultValue TimeOfDay where
  {-# INLINE defaultValue #-}
  defaultValue = D.time

instance DefaultValue (TimeOfDay, TimeZone) where
  {-# INLINE defaultValue #-}
  defaultValue = D.timetz

instance DefaultValue DiffTime where
  {-# INLINE defaultValue #-}
  defaultValue = D.interval

instance DefaultValue JSON.Value where
  {-# INLINE defaultValue #-}
  defaultValue = D.jsonb

instance (DefaultValue a, DefaultNullableOrNotValue a) => DefaultValue (Vector a) where
  {-# INLINE defaultValue #-}
  defaultValue = D.vectorArray defaultNullableOrNotValue

instance (DefaultValue a, DefaultNullableOrNotValue a) => DefaultValue [a] where
  {-# INLINE defaultValue #-}
  defaultValue = D.listArray defaultNullableOrNotValue

instance DefaultValue (Range Int32) where
  {-# INLINE defaultValue #-}
  defaultValue = D.int4range

instance DefaultValue (Range Int64) where
  {-# INLINE defaultValue #-}
  defaultValue = D.int8range

instance DefaultValue (Range Scientific) where
  {-# INLINE defaultValue #-}
  defaultValue = D.numrange

instance DefaultValue (Range LocalTime) where
  {-# INLINE defaultValue #-}
  defaultValue = D.tsrange

instance DefaultValue (Range UTCTime) where
  {-# INLINE defaultValue #-}
  defaultValue = D.tstzrange

instance DefaultValue (Range Day) where
  {-# INLINE defaultValue #-}
  defaultValue = D.daterange

instance DefaultValue (Multirange Int32) where
  {-# INLINE defaultValue #-}
  defaultValue = D.int4multirange

instance DefaultValue (Multirange Int64) where
  {-# INLINE defaultValue #-}
  defaultValue = D.int8multirange

instance DefaultValue (Multirange Scientific) where
  {-# INLINE defaultValue #-}
  defaultValue = D.nummultirange

instance DefaultValue (Multirange LocalTime) where
  {-# INLINE defaultValue #-}
  defaultValue = D.tsmultirange

instance DefaultValue (Multirange UTCTime) where
  {-# INLINE defaultValue #-}
  defaultValue = D.tstzmultirange

instance DefaultValue (Multirange Day) where
  {-# INLINE defaultValue #-}
  defaultValue = D.datemultirange

--------------------------------------------------------------------------------
-- Extra helper types

instance (FromJSON a) => DefaultValue (ViaJSONB a) where
  {-# INLINE defaultValue #-}
  defaultValue =
    ViaJSONB
      <$> D.jsonbBytes (JSON.eitherDecodeStrict <&> either (Left . fromString) Right)

instance (FromJSON a) => DefaultValue (ViaJSON a) where
  {-# INLINE defaultValue #-}
  defaultValue =
    ViaJSON
      <$> D.jsonBytes (JSON.eitherDecodeStrict <&> either (Left . fromString) Right)

--------------------------------------------------------------------------------
-- Helper types

data ConstructorShape
  = DecoderDone
  | AddColumn ConstructorShape

type family GetConstructorShape a where
  GetConstructorShape (a -> b) = AddColumn (GetConstructorShape b)
  GetConstructorShape _ = DecoderDone