{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- |
  Description: Monomorphic squeal row types.

  This module provides a type family that converts a squeal row type into
  a specific, monomorphic tuple representation meant to be consumed by the
  user. The purpose of this so that the squeal quasiquoter won't produce
  polymorphic types, though it will produce a *different* monomorphic
  type depending on the columns returned by the query. The reason we want
  this is to help type inference as much as possible. Squeal already
  has some problems with type inference, and the burden on the user of
  navigating them is only likely to increase when a lot of the squeal
  "code" itself is hidden behind a quasiquoter.
-}
module Squeal.QuasiQuotes.RowType (
  RowType,
  monoQuery,
  monoManipulation,
  Field (..),
) where

import Data.Aeson (Value)
import Data.Int (Int32, Int64)
import Data.Text (Text)
import Data.Time (Day, UTCTime)
import Data.UUID (UUID)
import GHC.TypeLits (Symbol)
import Generics.SOP (SListI)
import Prelude (Applicative(pure), (<$>), Bool, Maybe)
import Squeal.PostgreSQL
  ( FromValue(fromValue), IsLabel(fromLabel), NullType(NotNull, Null)
  , PGType(PGbool, PGdate, PGint4, PGint8, PGjson, PGjsonb, PGtext, PGtimestamptz, PGuuid)
  , (:::), Json, Jsonb
  )
import qualified Squeal.PostgreSQL as Squeal




{- FOURMOLU_DISABLE -}
type family RowType a = b | b -> a where
  {-
    It would be more convenient to use a helper type family here that
    would map PGtypes to Haskell types. But if we did that, we would
    not be able to make this type family injective.

    This is Because GHC would not be able to tell that the right-hand
    side of this type family did not overlap even if that the helper
    type family were itself injective. Injectivity of the helper is not
    enough. The specific helper definition must happen to not produce
    instances that overlap with any Maybe type when used here.

    For instance, this example helper type family is injective, but when
    used here it would produce overlapping values for the `NotNull PGint4`
    and `Null PGbool` equations.

    type family Helper x = a | a -> x where
      Helper Int32 = Maybe Bool
      Helper Bool = Bool
  -}
  RowType (fld ::: 'NotNull PGbool ': more) = (Field fld Bool, RowType more)
  RowType (fld ::: 'NotNull PGint4 ': more) = (Field fld Int32, RowType more)
  RowType (fld ::: 'NotNull PGint8 ': more) = (Field fld Int64, RowType more)
  RowType (fld ::: 'NotNull PGtext ': more) = (Field fld Text, RowType more)
  RowType (fld ::: 'NotNull PGuuid ': more) = (Field fld UUID, RowType more)
  RowType (fld ::: 'NotNull PGdate ': more) = (Field fld Day, RowType more)
  RowType (fld ::: 'NotNull PGtimestamptz ': more) = (Field fld UTCTime, RowType more)
  RowType (fld ::: 'NotNull PGjsonb ': more) = (Field fld (Jsonb Value), RowType more)
  RowType (fld ::: 'NotNull PGjson ': more) = (Field fld (Json Value), RowType more)

  RowType (fld ::: 'Null PGbool ': more) = (Field fld (Maybe Bool), RowType more)
  RowType (fld ::: 'Null PGint4 ': more) = (Field fld (Maybe Int32), RowType more)
  RowType (fld ::: 'Null PGint8 ': more) = (Field fld (Maybe Int64), RowType more)
  RowType (fld ::: 'Null PGtext ': more) = (Field fld (Maybe Text), RowType more)
  RowType (fld ::: 'Null PGuuid ': more) = (Field fld (Maybe UUID), RowType more)
  RowType (fld ::: 'Null PGdate ': more) = (Field fld (Maybe Day), RowType more)
  RowType (fld ::: 'Null PGtimestamptz ': more) = (Field fld (Maybe UTCTime), RowType more)
  RowType (fld ::: 'Null PGjsonb ': more) = (Field fld (Maybe (Jsonb Value)), RowType more)
  RowType (fld ::: 'Null PGjson ': more) = (Field fld (Maybe (Json Value)), RowType more)
  RowType '[] = ()
{- FOURMOLU_ENABLE -}


newtype Field (name :: Symbol) a = Field
  { forall (name :: Symbol) a. Field name a -> a
unField :: a
  }
instance
    (Squeal.FromValue pg hask)
  =>
    Squeal.FromValue pg (Field name hask)
  where
    fromValue :: Maybe ByteString -> Either Text (Field name hask)
fromValue Maybe ByteString
mbs = forall (name :: Symbol) a. a -> Field name a
Field @name (hask -> Field name hask)
-> Either Text hask -> Either Text (Field name hask)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ty :: NullType) y.
FromValue ty y =>
Maybe ByteString -> Either Text y
Squeal.fromValue @pg Maybe ByteString
mbs


{- |
  Like 'Squeal.query', but use the monomorphizing 'RowType' family to
  fully specify the output rows. This is mainly a convenience to the
  template haskell code so it can simply quote this function instead of
  having to basically inline it directly in TH.
-}
monoQuery
  :: forall db params input row ignored.
     ( HasRowDecoder row (RowType row)
     , SListI row
     , Squeal.GenericParams db params input ignored
     )
  => Squeal.Query '[] '[] db params row
  -> Squeal.Statement db input (RowType row)
monoQuery :: forall (db :: SchemasType) (params :: [NullType]) input
       (row :: RowType) (ignored :: [*]).
(HasRowDecoder row (RowType row), SListI row,
 GenericParams db params input ignored) =>
Query '[] '[] db params row -> Statement db input (RowType row)
monoQuery = EncodeParams db params input
-> DecodeRow row (RowType row)
-> Query '[] '[] db params row
-> Statement db input (RowType row)
forall (db :: SchemasType) (params :: [NullType]) (row :: RowType)
       x y.
(All (OidOfNull db) params, SListI row) =>
EncodeParams db params x
-> DecodeRow row y
-> Query '[] '[] db params row
-> Statement db x y
Squeal.Query EncodeParams db params input
forall (db :: SchemasType) (params :: [NullType]) x (xs :: [*]).
GenericParams db params x xs =>
EncodeParams db params x
Squeal.genericParams DecodeRow row (RowType row)
forall (row :: RowType) x. HasRowDecoder row x => DecodeRow row x
getRowDecoder


monoManipulation
  :: forall db params input row ignored.
     ( HasRowDecoder row (RowType row)
     , SListI row
     , Squeal.GenericParams db params input ignored
     )
  => Squeal.Manipulation '[] db params row
  -> Squeal.Statement db input (RowType row)
monoManipulation :: forall (db :: SchemasType) (params :: [NullType]) input
       (row :: RowType) (ignored :: [*]).
(HasRowDecoder row (RowType row), SListI row,
 GenericParams db params input ignored) =>
Manipulation '[] db params row -> Statement db input (RowType row)
monoManipulation = EncodeParams db params input
-> DecodeRow row (RowType row)
-> Manipulation '[] db params row
-> Statement db input (RowType row)
forall (db :: SchemasType) (params :: [NullType]) (row :: RowType)
       x y.
(All (OidOfNull db) params, SListI row) =>
EncodeParams db params x
-> DecodeRow row y
-> Manipulation '[] db params row
-> Statement db x y
Squeal.Manipulation EncodeParams db params input
forall (db :: SchemasType) (params :: [NullType]) x (xs :: [*]).
GenericParams db params x xs =>
EncodeParams db params x
Squeal.genericParams DecodeRow row (RowType row)
forall (row :: RowType) x. HasRowDecoder row x => DecodeRow row x
getRowDecoder


class HasRowDecoder row x where
  getRowDecoder :: Squeal.DecodeRow row x
instance
    ( HasRowDecoder moreRow moreFields
    , Squeal.FromValue typ t
    )
  =>
    HasRowDecoder ((fld ::: typ) ': moreRow) (Field fld t, moreFields)
  where
    getRowDecoder :: DecodeRow ((fld ::: typ) : moreRow) (Field fld t, moreFields)
getRowDecoder =
      (Field fld t -> moreFields -> (Field fld t, moreFields))
-> Alias fld
-> DecodeRow moreRow moreFields
-> DecodeRow ((fld ::: typ) : moreRow) (Field fld t, moreFields)
forall (head :: NullType) h t z (col :: Symbol) (tail :: RowType).
FromValue head h =>
(h -> t -> z)
-> Alias col
-> DecodeRow tail t
-> DecodeRow ((col ::: head) : tail) z
Squeal.consRow
        (,)
        (forall (x :: Symbol) a. IsLabel x a => a
fromLabel @fld)
        (forall (row :: RowType) x. HasRowDecoder row x => DecodeRow row x
getRowDecoder @moreRow @moreFields)
instance () => HasRowDecoder '[] () where
  getRowDecoder :: DecodeRow '[] ()
getRowDecoder = () -> DecodeRow '[] ()
forall a. a -> DecodeRow '[] a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()