hasql-auto-0.1.0.0: lib/Hasql/Auto/Encoders.hs
-- | This module is sourced from and almost identical to that in the
-- [hasql-implicits](https://hackage.haskell.org/hasql-implicits) package. Its
-- purpose is that you don't have to depend on both 'hasql-auto', and to provide
-- the 'defaultParams' and 'defaultParamsSOP' functions. Those two functions are
-- similar to definitions found in
-- [hasql-generic](https://hackage.haskell.org/package/hasql-generic-0.1.0.5/docs/Hasql-Generic-HasParams.html),
-- with slightly different implementations. This package does not need types to
-- have an instance of a 'HasParams'-esque class, but it does require them to be
-- product types and have a 'Generics.SOP.Generic' instance.
--
-- == hasql-implicits credit, providing 'DefaultParamEncoder' and most of its instances
--
-- Copyright (c) 2019, Nikita Volkov
--
-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:
--
-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.
module Hasql.Auto.Encoders (
defaultParams,
defaultParamsNP,
defaultParam,
DefaultParamEncoder (..),
DefaultScalarParamEncoder (..),
) where
import Data.Aeson (ToJSON)
import Data.Aeson qualified as JSON
import Data.ByteString (ByteString)
import Data.Foldable qualified as F
import Data.Functor.Contravariant (Contravariant (contramap))
import Data.IP (IPRange)
import Data.Int (Int16, Int32, Int64)
import Data.Proxy (Proxy (..))
import Data.Scientific (Scientific)
import Data.Text (Text)
import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
import Data.UUID (UUID)
import Data.Vector (Vector)
import GHC.TypeError (Unsatisfiable)
import GHC.TypeLits (ErrorMessage (Text))
import Generics.SOP (All, Code (..), I (..), K (..), NP (..), SListI, unI)
import Generics.SOP qualified as SOP
import Hasql.Auto.Types
import Hasql.Encoders (NullableOrNot, Params, Value, array, dimension, element, nonNullable, nullable)
import Hasql.Encoders qualified as E
{-# INLINE defaultParams #-}
defaultParams :: (SOP.IsProductType a xs, All DefaultParamEncoder xs) => Params a
defaultParams = contramap SOP.productTypeFrom defaultParamsNP
{-# INLINE defaultParamsNP #-}
defaultParamsNP :: (All DefaultParamEncoder xs) => Params (NP I xs)
defaultParamsNP =
SOP.hcfoldMap
(Proxy :: Proxy DefaultParamEncoder)
(\(SOP.Fn getter) -> contramap (unI . getter . K) (E.param defaultParam))
SOP.projections
--------------------------------------------------------------------------------
class (DefaultParamEncoderImpl (IsScalar a) a) => DefaultParamEncoder a
instance (DefaultParamEncoderImpl (IsScalar a) a) => DefaultParamEncoder a
-- | Provides a default implementation of parameter encoder.
defaultParam :: forall a. (DefaultParamEncoder a) => NullableOrNot Value a
defaultParam = defaultParamImpl @(IsScalar a) @a
-- | Provides a default implementation of parameter encoder.
--
-- Don't implement instances to this typeclass.
class DefaultParamEncoderImpl isScalar a where
-- | Default parameter encoder with nullability specified.
defaultParamImpl :: NullableOrNot Value a
type family IsScalar a where
IsScalar (Maybe a) = 'False
IsScalar (Vector a) = 'False
IsScalar [a] = 'False
IsScalar _ = 'True
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'True a where
defaultParamImpl = nonNullable defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False [a] where
defaultParamImpl = (nonNullable . array . dimension F.foldl' . element . nonNullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False [Maybe a] where
defaultParamImpl = (nonNullable . array . dimension F.foldl' . element . nullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False [[a]] where
defaultParamImpl = (nonNullable . array . dimension F.foldl' . dimension F.foldl' . element . nonNullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False [[Maybe a]] where
defaultParamImpl = (nonNullable . array . dimension F.foldl' . dimension F.foldl' . element . nullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Vector a) where
defaultParamImpl = (nonNullable . array . dimension F.foldl' . element . nonNullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Vector (Maybe a)) where
defaultParamImpl = (nonNullable . array . dimension F.foldl' . element . nullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Vector (Vector a)) where
defaultParamImpl = (nonNullable . array . dimension F.foldl' . dimension F.foldl' . element . nonNullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Vector (Vector (Maybe a))) where
defaultParamImpl = (nonNullable . array . dimension F.foldl' . dimension F.foldl' . element . nullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Maybe a) where
defaultParamImpl = nullable defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Maybe [a]) where
defaultParamImpl = (nullable . array . dimension F.foldl' . element . nonNullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Maybe [Maybe a]) where
defaultParamImpl = (nullable . array . dimension F.foldl' . element . nullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Maybe [[a]]) where
defaultParamImpl = (nullable . array . dimension F.foldl' . dimension F.foldl' . element . nonNullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Maybe [[Maybe a]]) where
defaultParamImpl = (nullable . array . dimension F.foldl' . dimension F.foldl' . element . nullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Maybe (Vector a)) where
defaultParamImpl = (nullable . array . dimension F.foldl' . element . nonNullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Maybe (Vector (Maybe a))) where
defaultParamImpl = (nullable . array . dimension F.foldl' . element . nullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Maybe (Vector (Vector a))) where
defaultParamImpl = (nullable . array . dimension F.foldl' . dimension F.foldl' . element . nonNullable) defaultScalarParam
instance (DefaultScalarParamEncoder a) => DefaultParamEncoderImpl 'False (Maybe (Vector (Vector (Maybe a)))) where
defaultParamImpl = (nullable . array . dimension F.foldl' . dimension F.foldl' . element . nullable) defaultScalarParam
--------------------------------------------------------------------------------
class DefaultScalarParamEncoder a where
defaultScalarParam :: Value a
instance DefaultScalarParamEncoder Char where defaultScalarParam = E.char
instance DefaultScalarParamEncoder Double where defaultScalarParam = E.float8
instance DefaultScalarParamEncoder Float where defaultScalarParam = E.float4
instance DefaultScalarParamEncoder Int16 where defaultScalarParam = E.int2
instance DefaultScalarParamEncoder Int32 where defaultScalarParam = E.int4
instance DefaultScalarParamEncoder Int64 where defaultScalarParam = E.int8
instance DefaultScalarParamEncoder ByteString where defaultScalarParam = E.bytea
instance DefaultScalarParamEncoder Scientific where defaultScalarParam = E.numeric
instance DefaultScalarParamEncoder Text where defaultScalarParam = E.text
instance DefaultScalarParamEncoder UTCTime where defaultScalarParam = E.timestamptz
instance DefaultScalarParamEncoder JSON.Value where defaultScalarParam = E.jsonb
instance (JSON.ToJSON a) => DefaultScalarParamEncoder (ViaJSONB a) where defaultScalarParam = encodeViaJSONB
instance (JSON.ToJSON a) => DefaultScalarParamEncoder (ViaJSON a) where defaultScalarParam = encodeViaJSON
instance DefaultScalarParamEncoder UUID where defaultScalarParam = E.uuid
instance DefaultScalarParamEncoder Day where defaultScalarParam = E.date
instance DefaultScalarParamEncoder DiffTime where defaultScalarParam = E.interval
instance DefaultScalarParamEncoder TimeOfDay where defaultScalarParam = E.time
instance DefaultScalarParamEncoder LocalTime where defaultScalarParam = E.timestamp
instance DefaultScalarParamEncoder (TimeOfDay, TimeZone) where defaultScalarParam = E.timetz
instance DefaultScalarParamEncoder IPRange where defaultScalarParam = E.inet
instance DefaultScalarParamEncoder Bool where defaultScalarParam = E.bool
encodeViaJSONB :: (ToJSON a) => Value (ViaJSONB a)
encodeViaJSONB = contramap toBS E.jsonbLazyBytes
where
toBS (ViaJSONB a) = JSON.encode a
encodeViaJSON :: (ToJSON a) => Value (ViaJSON a)
encodeViaJSON = contramap toBS E.jsonLazyBytes
where
toBS (ViaJSON a) = JSON.encode a