{-# language AllowAmbiguousTypes #-}
{-# language BlockArguments #-}
{-# language DataKinds #-}
{-# language DisambiguateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language OverloadedStrings #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language UndecidableInstances #-}
{-# language UndecidableSuperClasses #-}
{-# language ViewPatterns #-}

module Rel8.Type.Composite
  ( Composite( Composite )
  , DBComposite( compositeFields, compositeTypeName )
  , compose, decompose
  )
where

-- attoparsec
import qualified Data.Attoparsec.ByteString.Char8 as A

-- base
import Control.Applicative ((<|>), many, optional)
import Data.Foldable (fold)
import Data.Functor.Const (Const (Const), getConst)
import Data.Functor.Contravariant ((>$<))
import Data.Functor.Identity (Identity (Identity), runIdentity)
import Data.Kind ( Constraint, Type )
import Data.List (uncons)
import Prelude

-- bytestring
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Builder (Builder)
import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Builder as B
import Data.ByteString.Lazy (toStrict)

-- hasql
import qualified Hasql.Decoders as Decoders
import qualified Hasql.Encoders as Encoders

-- opaleye
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

-- rel8
import Rel8.Expr ( Expr )
import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
import Rel8.Schema.Name ( Name( Name ) )
import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
import Rel8.Schema.QualifiedName (QualifiedName)
import Rel8.Schema.Result ( Result )
import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
import Rel8.Table ( fromColumns, toColumns, fromResult, toResult )
import Rel8.Table.Eq ( EqTable )
import Rel8.Table.HKD ( HKD, HKDable )
import Rel8.Table.Ord ( OrdTable )
import Rel8.Table.Rel8able ()
import Rel8.Table.Serialize ( litHTable )
import Rel8.Type ( DBType, typeInformation )
import Rel8.Type.Builder.Fold (interfoldMap)
import Rel8.Type.Decoder (Decoder (Decoder), Parser)
import qualified Rel8.Type.Decoder as Decoder
import Rel8.Type.Encoder (Encoder (Encoder))
import qualified Rel8.Type.Encoder as Encoder
import Rel8.Type.Eq ( DBEq )
import Rel8.Type.Information ( TypeInformation(..) )
import Rel8.Type.Name (TypeName (..))
import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
import Rel8.Type.Parser (parse)

-- semigroupoids
import Data.Functor.Apply ( WrappedApplicative(..) )

-- transformers
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict (StateT (StateT), runStateT)


-- | A deriving-via helper type for column types that store a Haskell product
-- type in a single Postgres column using a Postgres composite type.
--
-- Note that this must map to a specific extant type in your database's schema
-- (created with @CREATE TYPE@). Use 'DBComposite' to specify the name of this
-- Postgres type and the names of the individual fields (for projecting with
-- 'decompose').
type Composite :: Type -> Type
newtype Composite a = Composite
  { forall a. Composite a -> a
unComposite :: a
  }


instance DBComposite a => DBType (Composite a) where
  typeInformation :: TypeInformation (Composite a)
typeInformation = TypeInformation
    { decode :: Decoder (Composite a)
decode =
        Decoder
          { binary :: Value (Composite a)
binary = Composite (Composite a) -> Value (Composite a)
forall a. Composite a -> Value a
Decoders.composite (a -> Composite a
forall a. a -> Composite a
Composite (a -> Composite a)
-> (Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn Expr) (Rep a))))
      Result
    -> a)
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a))))
     Result
-> Composite a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (context :: Context) a.
Table context a =>
Columns a Result -> FromExprs a
fromResult @_ @(HKD a Expr) (Eval
   (GGColumns
      (GAlgebra (Rep a))
      TColumns
      (GRecord (GMap (TColumn Expr) (Rep a))))
   Result
 -> Composite a)
-> Composite
     (Eval
        (GGColumns
           (GAlgebra (Rep a))
           TColumns
           (GRecord (GMap (TColumn Expr) (Rep a))))
        Result)
-> Composite (Composite a)
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> Composite
  (Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a))))
     Result)
forall (t :: HTable). HTable t => Composite (t Result)
decoder)
          , text :: Parser (Composite a)
text = (Eval
   (GGColumns
      (GAlgebra (Rep a))
      TColumns
      (GRecord (GMap (TColumn Expr) (Rep a))))
   Result
 -> Composite a)
-> Either
     String
     (Eval
        (GGColumns
           (GAlgebra (Rep a))
           TColumns
           (GRecord (GMap (TColumn Expr) (Rep a))))
        Result)
-> Either String (Composite a)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Composite a
forall a. a -> Composite a
Composite (a -> Composite a)
-> (Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn Expr) (Rep a))))
      Result
    -> a)
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a))))
     Result
-> Composite a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (context :: Context) a.
Table context a =>
Columns a Result -> FromExprs a
fromResult @_ @(HKD a Expr)) (Either
   String
   (Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn Expr) (Rep a))))
      Result)
 -> Either String (Composite a))
-> (ByteString
    -> Either
         String
         (Eval
            (GGColumns
               (GAlgebra (Rep a))
               TColumns
               (GRecord (GMap (TColumn Expr) (Rep a))))
            Result))
-> Parser (Composite a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> Either
     String
     (Eval
        (GGColumns
           (GAlgebra (Rep a))
           TColumns
           (GRecord (GMap (TColumn Expr) (Rep a))))
        Result)
forall (t :: HTable). HTable t => Parser (t Result)
parser
          }
    , encode :: Encoder (Composite a)
encode =
        Encoder
          { binary :: Value (Composite a)
binary = Composite (Composite a) -> Value (Composite a)
forall a. Composite a -> Value a
Encoders.composite (forall (context :: Context) a.
Table context a =>
FromExprs a -> Columns a Result
toResult @_ @(HKD a Expr) (a
 -> Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn Expr) (Rep a))))
      Result)
-> (Composite a -> a)
-> Composite a
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a))))
     Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Composite a -> a
forall a. Composite a -> a
unComposite (Composite a
 -> Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn Expr) (Rep a))))
      Result)
-> Composite
     (Eval
        (GGColumns
           (GAlgebra (Rep a))
           TColumns
           (GRecord (GMap (TColumn Expr) (Rep a))))
        Result)
-> Composite (Composite a)
forall (f :: Context) a b.
Contravariant f =>
(a -> b) -> f b -> f a
>$< Composite
  (Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a))))
     Result)
forall (t :: HTable). HTable t => Composite (t Result)
encoder)
          , text :: Composite a -> Builder
text = Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn Expr) (Rep a))))
  Result
-> Builder
forall (t :: HTable). HTable t => t Result -> Builder
builder (Eval
   (GGColumns
      (GAlgebra (Rep a))
      TColumns
      (GRecord (GMap (TColumn Expr) (Rep a))))
   Result
 -> Builder)
-> (Composite a
    -> Eval
         (GGColumns
            (GAlgebra (Rep a))
            TColumns
            (GRecord (GMap (TColumn Expr) (Rep a))))
         Result)
-> Composite a
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (context :: Context) a.
Table context a =>
FromExprs a -> Columns a Result
toResult @_ @(HKD a Expr) (a
 -> Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn Expr) (Rep a))))
      Result)
-> (Composite a -> a)
-> Composite a
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a))))
     Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Composite a -> a
forall a. Composite a -> a
unComposite
          , quote :: Composite a -> PrimExpr
quote = Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn Expr) (Rep a))))
  Expr
-> PrimExpr
forall (t :: HTable). HTable t => t Expr -> PrimExpr
quoter (Eval
   (GGColumns
      (GAlgebra (Rep a))
      TColumns
      (GRecord (GMap (TColumn Expr) (Rep a))))
   Expr
 -> PrimExpr)
-> (Composite a
    -> Eval
         (GGColumns
            (GAlgebra (Rep a))
            TColumns
            (GRecord (GMap (TColumn Expr) (Rep a))))
         Expr)
-> Composite a
-> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn Expr) (Rep a))))
  Result
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a))))
     Expr
forall (t :: HTable). HTable t => t Result -> t Expr
litHTable (Eval
   (GGColumns
      (GAlgebra (Rep a))
      TColumns
      (GRecord (GMap (TColumn Expr) (Rep a))))
   Result
 -> Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn Expr) (Rep a))))
      Expr)
-> (Composite a
    -> Eval
         (GGColumns
            (GAlgebra (Rep a))
            TColumns
            (GRecord (GMap (TColumn Expr) (Rep a))))
         Result)
-> Composite a
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a))))
     Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (context :: Context) a.
Table context a =>
FromExprs a -> Columns a Result
toResult @_ @(HKD a Expr) (a
 -> Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn Expr) (Rep a))))
      Result)
-> (Composite a -> a)
-> Composite a
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a))))
     Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Composite a -> a
forall a. Composite a -> a
unComposite
          }
    , delimiter :: Char
delimiter = Char
','
    , typeName :: TypeName
typeName =
        TypeName
          { name :: QualifiedName
name = forall a. DBComposite a => QualifiedName
compositeTypeName @a
          , modifiers :: [String]
modifiers = []
          , arrayDepth :: Word
arrayDepth = Word
0
          }
    }


instance (DBComposite a, EqTable (HKD a Expr)) => DBEq (Composite a)


instance (DBComposite a, OrdTable (HKD a Expr)) => DBOrd (Composite a)


instance (DBComposite a, OrdTable (HKD a Expr)) => DBMax (Composite a)


instance (DBComposite a, OrdTable (HKD a Expr)) => DBMin (Composite a)


-- | 'DBComposite' is used to associate composite type metadata with a Haskell
-- type.
type DBComposite :: Type -> Constraint
class (DBType a, HKDable a) => DBComposite a where
  -- | The names of all fields in the composite type that @a@ maps to.
  compositeFields :: HKD a Name

  -- | The name of the composite type that @a@ maps to.
  compositeTypeName :: QualifiedName


-- | Collapse a 'HKD' into a PostgreSQL composite type.
--
-- 'HKD' values are represented in queries by having a column for each field in
-- the corresponding Haskell type. 'compose' collapses these columns into a
-- single column expression, by combining them into a PostgreSQL composite
-- type.
compose :: DBComposite a => HKD a Expr -> Expr a
compose :: forall a. DBComposite a => HKD a Expr -> Expr a
compose = Expr a -> Expr a
forall a. Sql DBType a => Expr a -> Expr a
castExpr (Expr a -> Expr a)
-> (HKD a Expr -> Expr a) -> HKD a Expr -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr (PrimExpr -> Expr a)
-> (HKD a Expr -> PrimExpr) -> HKD a Expr -> Expr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn Expr) (Rep a))))
  Expr
-> PrimExpr
forall (t :: HTable). HTable t => t Expr -> PrimExpr
quoter (Eval
   (GGColumns
      (GAlgebra (Rep a))
      TColumns
      (GRecord (GMap (TColumn Expr) (Rep a))))
   Expr
 -> PrimExpr)
-> (HKD a Expr
    -> Eval
         (GGColumns
            (GAlgebra (Rep a))
            TColumns
            (GRecord (GMap (TColumn Expr) (Rep a))))
         Expr)
-> HKD a Expr
-> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HKD a Expr
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a))))
     Expr
HKD a Expr -> Columns (HKD a Expr) Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns


-- | Expand a composite type into a 'HKD'.
--
-- 'decompose' is the inverse of 'compose'.
decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
decompose :: forall a. DBComposite a => Expr a -> HKD a Expr
decompose (Expr a -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr -> PrimExpr
a) = Columns (HKD a Expr) Expr -> HKD a Expr
forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns (Columns (HKD a Expr) Expr -> HKD a Expr)
-> Columns (HKD a Expr) Expr -> HKD a Expr
forall a b. (a -> b) -> a -> b
$ (forall a.
 HField
   (Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn Expr) (Rep a)))))
   a
 -> Expr a)
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a))))
     Expr
forall (context :: Context).
(forall a.
 HField
   (Eval
      (GGColumns
         (GAlgebra (Rep a))
         TColumns
         (GRecord (GMap (TColumn Expr) (Rep a)))))
   a
 -> context a)
-> Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a))))
     context
forall (t :: HTable) (context :: Context).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate \HField
  (Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a)))))
  a
field ->
  case Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn Expr) (Rep a))))
  Name
-> HField
     (Eval
        (GGColumns
           (GAlgebra (Rep a))
           TColumns
           (GRecord (GMap (TColumn Expr) (Rep a)))))
     a
-> Name a
forall (context :: Context) a.
Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn Expr) (Rep a))))
  context
-> HField
     (Eval
        (GGColumns
           (GAlgebra (Rep a))
           TColumns
           (GRecord (GMap (TColumn Expr) (Rep a)))))
     a
-> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn Expr) (Rep a))))
  Name
Columns (HKD a Name) Name
names HField
  (Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a)))))
  a
field of
    Name String
name -> case Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn Expr) (Rep a))))
  Spec
-> HField
     (Eval
        (GGColumns
           (GAlgebra (Rep a))
           TColumns
           (GRecord (GMap (TColumn Expr) (Rep a)))))
     a
-> Spec a
forall (context :: Context) a.
Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn Expr) (Rep a))))
  context
-> HField
     (Eval
        (GGColumns
           (GAlgebra (Rep a))
           TColumns
           (GRecord (GMap (TColumn Expr) (Rep a)))))
     a
-> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Eval
  (GGColumns
     (GAlgebra (Rep a))
     TColumns
     (GRecord (GMap (TColumn Expr) (Rep a))))
  Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField
  (Eval
     (GGColumns
        (GAlgebra (Rep a))
        TColumns
        (GRecord (GMap (TColumn Expr) (Rep a)))))
  a
field of
      Spec {} -> PrimExpr -> Expr a
forall a. PrimExpr -> Expr a
fromPrimExpr (PrimExpr -> Expr a) -> PrimExpr -> Expr a
forall a b. (a -> b) -> a -> b
$ PrimExpr -> String -> PrimExpr
Opaleye.CompositeExpr PrimExpr
a String
name
  where
    names :: Columns (HKD a Name) Name
names = HKD a Name -> Columns (HKD a Name) Name
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns (forall a. DBComposite a => HKD a Name
compositeFields @a)


decoder :: HTable t => Decoders.Composite (t Result)
decoder :: forall (t :: HTable). HTable t => Composite (t Result)
decoder = WrappedApplicative Composite (t Result) -> Composite (t Result)
forall (f :: Context) a. WrappedApplicative f a -> f a
unwrapApplicative (WrappedApplicative Composite (t Result) -> Composite (t Result))
-> WrappedApplicative Composite (t Result) -> Composite (t Result)
forall a b. (a -> b) -> a -> b
$ (forall a. HField t a -> WrappedApplicative Composite (Result a))
-> WrappedApplicative Composite (t Result)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA \HField t a
field ->
  case t Spec -> HField t a -> Spec a
forall (context :: Context) a. t context -> HField t a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield t Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField t a
field of
    Spec {Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity :: Nullity a
nullity, TypeInformation (Unnullify a)
info :: forall a. Spec a -> TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info} -> Composite (Result a) -> WrappedApplicative Composite (Result a)
forall (f :: Context) a. f a -> WrappedApplicative f a
WrapApplicative (Composite (Result a) -> WrappedApplicative Composite (Result a))
-> Composite (Result a) -> WrappedApplicative Composite (Result a)
forall a b. (a -> b) -> a -> b
$ a -> Result a
forall a. a -> Identity a
Identity (a -> Result a) -> Composite a -> Composite (Result a)
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$>
      case Nullity a
nullity of
        Nullity a
Null -> NullableOrNot Value a -> Composite a
forall a. NullableOrNot Value a -> Composite a
Decoders.field (NullableOrNot Value a -> Composite a)
-> NullableOrNot Value a -> Composite a
forall a b. (a -> b) -> a -> b
$ Value a1 -> NullableOrNot Value (Maybe a1)
forall (decoder :: Context) a.
decoder a -> NullableOrNot decoder (Maybe a)
Decoders.nullable (Value a1 -> NullableOrNot Value (Maybe a1))
-> Value a1 -> NullableOrNot Value (Maybe a1)
forall a b. (a -> b) -> a -> b
$ Decoder a1 -> Value a1
forall a. Decoder a -> Value a
Decoder.binary (Decoder a1 -> Value a1) -> Decoder a1 -> Value a1
forall a b. (a -> b) -> a -> b
$ TypeInformation a1 -> Decoder a1
forall a. TypeInformation a -> Decoder a
decode TypeInformation a1
TypeInformation (Unnullify a)
info
        Nullity a
NotNull -> NullableOrNot Value a -> Composite a
forall a. NullableOrNot Value a -> Composite a
Decoders.field (NullableOrNot Value a -> Composite a)
-> NullableOrNot Value a -> Composite a
forall a b. (a -> b) -> a -> b
$ Value a -> NullableOrNot Value a
forall (decoder :: Context) a. decoder a -> NullableOrNot decoder a
Decoders.nonNullable (Value a -> NullableOrNot Value a)
-> Value a -> NullableOrNot Value a
forall a b. (a -> b) -> a -> b
$ Decoder a -> Value a
forall a. Decoder a -> Value a
Decoder.binary (Decoder a -> Value a) -> Decoder a -> Value a
forall a b. (a -> b) -> a -> b
$ TypeInformation a -> Decoder a
forall a. TypeInformation a -> Decoder a
decode TypeInformation a
TypeInformation (Unnullify a)
info


parser :: HTable t => Parser (t Result)
parser :: forall (t :: HTable). HTable t => Parser (t Result)
parser ByteString
input = do
  [Maybe ByteString]
fields <- ByteString -> Either String [Maybe ByteString]
parseRow ByteString
input
  (t Result
a, [Maybe ByteString]
rest) <- StateT [Maybe ByteString] (Either String) (t Result)
-> [Maybe ByteString]
-> Either String (t Result, [Maybe ByteString])
forall s (m :: Context) a. StateT s m a -> s -> m (a, s)
runStateT StateT [Maybe ByteString] (Either String) (t Result)
go [Maybe ByteString]
fields
  case [Maybe ByteString]
rest of
    [] -> t Result -> Either String (t Result)
forall a. a -> Either String a
forall (f :: Context) a. Applicative f => a -> f a
pure t Result
a
    [Maybe ByteString]
_ -> String -> Either String (t Result)
forall a b. a -> Either a b
Left String
"composite: too many fields"
  where
    go :: StateT [Maybe ByteString] (Either String) (t Result)
go = (forall a.
 HField t a -> StateT [Maybe ByteString] (Either String) (Result a))
-> StateT [Maybe ByteString] (Either String) (t Result)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA \HField t a
field -> do
      Maybe ByteString
mbytes <- ([Maybe ByteString]
 -> Either String (Maybe ByteString, [Maybe ByteString]))
-> StateT [Maybe ByteString] (Either String) (Maybe ByteString)
forall s (m :: Context) a. (s -> m (a, s)) -> StateT s m a
StateT (([Maybe ByteString]
  -> Either String (Maybe ByteString, [Maybe ByteString]))
 -> StateT [Maybe ByteString] (Either String) (Maybe ByteString))
-> ([Maybe ByteString]
    -> Either String (Maybe ByteString, [Maybe ByteString]))
-> StateT [Maybe ByteString] (Either String) (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Either String (Maybe ByteString, [Maybe ByteString])
-> ((Maybe ByteString, [Maybe ByteString])
    -> Either String (Maybe ByteString, [Maybe ByteString]))
-> Maybe (Maybe ByteString, [Maybe ByteString])
-> Either String (Maybe ByteString, [Maybe ByteString])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Either String (Maybe ByteString, [Maybe ByteString])
forall {b}. Either String b
missing (Maybe ByteString, [Maybe ByteString])
-> Either String (Maybe ByteString, [Maybe ByteString])
forall a. a -> Either String a
forall (f :: Context) a. Applicative f => a -> f a
pure (Maybe (Maybe ByteString, [Maybe ByteString])
 -> Either String (Maybe ByteString, [Maybe ByteString]))
-> ([Maybe ByteString]
    -> Maybe (Maybe ByteString, [Maybe ByteString]))
-> [Maybe ByteString]
-> Either String (Maybe ByteString, [Maybe ByteString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ByteString] -> Maybe (Maybe ByteString, [Maybe ByteString])
forall a. [a] -> Maybe (a, [a])
uncons
      Either String (Result a)
-> StateT [Maybe ByteString] (Either String) (Result a)
forall (m :: Context) a.
Monad m =>
m a -> StateT [Maybe ByteString] m a
forall (t :: Context -> Context) (m :: Context) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String (Result a)
 -> StateT [Maybe ByteString] (Either String) (Result a))
-> Either String (Result a)
-> StateT [Maybe ByteString] (Either String) (Result a)
forall a b. (a -> b) -> a -> b
$ a -> Result a
forall a. a -> Identity a
Identity (a -> Result a) -> Either String a -> Either String (Result a)
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> case t Spec -> HField t a -> Spec a
forall (context :: Context) a. t context -> HField t a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield t Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField t a
field of
        Spec {Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity :: Nullity a
nullity, TypeInformation (Unnullify a)
info :: forall a. Spec a -> TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info} -> case Nullity a
nullity of
          Nullity a
Null -> (ByteString -> Either String a1)
-> Maybe ByteString -> Either String (Maybe a1)
forall (t :: Context) (f :: Context) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Context) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Decoder a1 -> ByteString -> Either String a1
forall a. Decoder a -> Parser a
Decoder.text (TypeInformation a1 -> Decoder a1
forall a. TypeInformation a -> Decoder a
decode TypeInformation a1
TypeInformation (Unnullify a)
info)) Maybe ByteString
mbytes
          Nullity a
NotNull -> case Maybe ByteString
mbytes of
            Maybe ByteString
Nothing -> String -> Either String a
forall a b. a -> Either a b
Left String
"composite: unexpected null"
            Just ByteString
bytes -> Decoder a -> Parser a
forall a. Decoder a -> Parser a
Decoder.text (TypeInformation a -> Decoder a
forall a. TypeInformation a -> Decoder a
decode TypeInformation a
TypeInformation (Unnullify a)
info) ByteString
bytes
    missing :: Either String b
missing = String -> Either String b
forall a b. a -> Either a b
Left String
"composite: missing fields"


parseRow :: ByteString -> Either String [Maybe ByteString]
parseRow :: ByteString -> Either String [Maybe ByteString]
parseRow = Parser [Maybe ByteString]
-> ByteString -> Either String [Maybe ByteString]
forall a. Parser a -> ByteString -> Either String a
parse (Parser [Maybe ByteString]
 -> ByteString -> Either String [Maybe ByteString])
-> Parser [Maybe ByteString]
-> ByteString
-> Either String [Maybe ByteString]
forall a b. (a -> b) -> a -> b
$ do
  Char -> Parser Char
A.char Char
'(' Parser Char
-> Parser [Maybe ByteString] -> Parser [Maybe ByteString]
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: Context) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (Maybe ByteString)
-> Parser Char -> Parser [Maybe ByteString]
forall (f :: Context) a s. Alternative f => f a -> f s -> f [a]
A.sepBy Parser ByteString (Maybe ByteString)
element (Char -> Parser Char
A.char Char
',') Parser [Maybe ByteString]
-> Parser Char -> Parser [Maybe ByteString]
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: Context) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
')'
  where
    element :: Parser ByteString (Maybe ByteString)
element = Parser ByteString ByteString
-> Parser ByteString (Maybe ByteString)
forall (f :: Context) a. Alternative f => f a -> f (Maybe a)
optional (Parser ByteString ByteString
quoted Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: Context) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
unquoted)
      where
        unquoted :: Parser ByteString ByteString
unquoted = (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile1 (String -> Char -> Bool
A.notInClass String
",\"()")
        quoted :: Parser ByteString ByteString
quoted = Char -> Parser Char
A.char Char
'"' Parser Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: Context) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
contents Parser ByteString ByteString
-> Parser Char -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: Context) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
A.char Char
'"'
          where
            contents :: Parser ByteString ByteString
contents = [ByteString] -> ByteString
forall m. Monoid m => [m] -> m
forall (t :: Context) m. (Foldable t, Monoid m) => t m -> m
fold ([ByteString] -> ByteString)
-> Parser ByteString [ByteString] -> Parser ByteString ByteString
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString -> Parser ByteString [ByteString]
forall a. Parser ByteString a -> Parser ByteString [a]
forall (f :: Context) a. Alternative f => f a -> f [a]
many (Parser ByteString ByteString
unquote Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: Context) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
unescape Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: Context) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
quote)
              where
                unquote :: Parser ByteString ByteString
unquote = (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile1 (String -> Char -> Bool
A.notInClass String
"\"\\")
                unescape :: Parser ByteString ByteString
unescape = Char -> Parser Char
A.char Char
'\\' Parser Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: Context) a b. Applicative f => f a -> f b -> f b
*> do
                  Char -> ByteString
BS.singleton (Char -> ByteString) -> Parser Char -> Parser ByteString ByteString
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                    Char -> Parser Char
A.char Char
'\\' Parser Char -> Parser Char -> Parser Char
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: Context) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
A.char Char
'"'
                quote :: Parser ByteString ByteString
quote = ByteString
"\"" ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: Context) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
A.string ByteString
"\"\""


encoder :: forall t. HTable t => Encoders.Composite (t Result)
encoder :: forall (t :: HTable). HTable t => Composite (t Result)
encoder = Const (Composite (t Result)) (t Any) -> Composite (t Result)
forall {k} a (b :: k). Const a b -> a
getConst (Const (Composite (t Result)) (t Any) -> Composite (t Result))
-> Const (Composite (t Result)) (t Any) -> Composite (t Result)
forall a b. (a -> b) -> a -> b
$ forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA @t \HField t a
field ->
  case t Spec -> HField t a -> Spec a
forall (context :: Context) a. t context -> HField t a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield t Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField t a
field of
    Spec {Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity :: Nullity a
nullity, TypeInformation (Unnullify a)
info :: forall a. Spec a -> TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info} -> Composite (t Result) -> Const (Composite (t Result)) (Any a)
forall {k} a (b :: k). a -> Const a b
Const (Composite (t Result) -> Const (Composite (t Result)) (Any a))
-> Composite (t Result) -> Const (Composite (t Result)) (Any a)
forall a b. (a -> b) -> a -> b
$
      Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (t Result -> Identity a) -> t Result -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t Result -> HField t a -> Identity a
forall (context :: Context) a. t context -> HField t a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
`hfield` HField t a
field) (t Result -> a) -> Composite a -> Composite (t Result)
forall (f :: Context) a b.
Contravariant f =>
(a -> b) -> f b -> f a
>$<
        case Nullity a
nullity of
          Nullity a
Null -> NullableOrNot Value a -> Composite a
forall a. NullableOrNot Value a -> Composite a
Encoders.field (NullableOrNot Value a -> Composite a)
-> NullableOrNot Value a -> Composite a
forall a b. (a -> b) -> a -> b
$ Value (Unnullify a) -> NullableOrNot Value (Maybe (Unnullify a))
forall (encoder :: Context) a.
encoder a -> NullableOrNot encoder (Maybe a)
Encoders.nullable Value (Unnullify a)
build
          Nullity a
NotNull -> NullableOrNot Value a -> Composite a
forall a. NullableOrNot Value a -> Composite a
Encoders.field (NullableOrNot Value a -> Composite a)
-> NullableOrNot Value a -> Composite a
forall a b. (a -> b) -> a -> b
$ Value a -> NullableOrNot Value a
forall (encoder :: Context) a. encoder a -> NullableOrNot encoder a
Encoders.nonNullable Value a
Value (Unnullify a)
build
        where
          build :: Value (Unnullify a)
build = Encoder (Unnullify a) -> Value (Unnullify a)
forall a. Encoder a -> Value a
Encoder.binary (TypeInformation (Unnullify a) -> Encoder (Unnullify a)
forall a. TypeInformation a -> Encoder a
encode TypeInformation (Unnullify a)
info)


builder :: HTable t => t Result -> Builder
builder :: forall (t :: HTable). HTable t => t Result -> Builder
builder t Result
input = [Maybe ByteString] -> Builder
buildRow ([Maybe ByteString] -> Builder) -> [Maybe ByteString] -> Builder
forall a b. (a -> b) -> a -> b
$ Const [Maybe ByteString] (t Any) -> [Maybe ByteString]
forall {k} a (b :: k). Const a b -> a
getConst (Const [Maybe ByteString] (t Any) -> [Maybe ByteString])
-> Const [Maybe ByteString] (t Any) -> [Maybe ByteString]
forall a b. (a -> b) -> a -> b
$ (forall a. HField t a -> Const [Maybe ByteString] (Any a))
-> Const [Maybe ByteString] (t Any)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA \HField t a
field ->
  [Maybe ByteString] -> Const [Maybe ByteString] (Any a)
forall {k} a (b :: k). a -> Const a b
Const ([Maybe ByteString] -> Const [Maybe ByteString] (Any a))
-> [Maybe ByteString] -> Const [Maybe ByteString] (Any a)
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> [Maybe ByteString]
forall a. a -> [a]
forall (f :: Context) a. Applicative f => a -> f a
pure (Maybe ByteString -> [Maybe ByteString])
-> Maybe ByteString -> [Maybe ByteString]
forall a b. (a -> b) -> a -> b
$
    case t Result -> HField t a -> Result a
forall (context :: Context) a. t context -> HField t a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield t Result
input HField t a
field of
      Identity a
a ->
        case t Spec -> HField t a -> Spec a
forall (context :: Context) a. t context -> HField t a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield t Spec
forall (t :: HTable). HTable t => t Spec
hspecs HField t a
field of
          Spec {Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity :: Nullity a
nullity, TypeInformation (Unnullify a)
info :: forall a. Spec a -> TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info} -> case Nullity a
nullity of
            Nullity a
Null -> Unnullify a -> ByteString
build (Unnullify a -> ByteString)
-> Maybe (Unnullify a) -> Maybe ByteString
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
<$> a
Maybe (Unnullify a)
a
            Nullity a
NotNull -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Unnullify a -> ByteString
build a
Unnullify a
a
            where
              build :: Unnullify a -> ByteString
build =
                LazyByteString -> ByteString
toStrict (LazyByteString -> ByteString)
-> (Unnullify a -> LazyByteString) -> Unnullify a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
toLazyByteString (Builder -> LazyByteString)
-> (Unnullify a -> Builder) -> Unnullify a -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoder (Unnullify a) -> Unnullify a -> Builder
forall a. Encoder a -> a -> Builder
Encoder.text (TypeInformation (Unnullify a) -> Encoder (Unnullify a)
forall a. TypeInformation a -> Encoder a
encode TypeInformation (Unnullify a)
info)


buildRow :: [Maybe ByteString] -> Builder
buildRow :: [Maybe ByteString] -> Builder
buildRow [Maybe ByteString]
elements =
  Char -> Builder
B.char8 Char
'(' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Builder
-> (Maybe ByteString -> Builder) -> [Maybe ByteString] -> Builder
forall (t :: Context) m a.
(Foldable t, Monoid m) =>
m -> (a -> m) -> t a -> m
interfoldMap (Char -> Builder
B.char8 Char
',') ((ByteString -> Builder) -> Maybe ByteString -> Builder
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: Context) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> Builder
element) [Maybe ByteString]
elements Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Char -> Builder
B.char8 Char
')'
  where
    element :: ByteString -> Builder
element ByteString
a
        | ByteString -> Bool
BS.null ByteString
a = Builder
"\"\""
        | (Char -> Bool) -> ByteString -> Bool
BS.all (String -> Char -> Bool
A.notInClass String
escapeClass) ByteString
a = ByteString -> Builder
B.byteString ByteString
a
        | Bool
otherwise =
            Char -> Builder
B.char8 Char
'"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Char -> Builder -> Builder) -> Builder -> ByteString -> Builder
forall a. (Char -> a -> a) -> a -> ByteString -> a
BS.foldr (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
(<>) (Builder -> Builder -> Builder)
-> (Char -> Builder) -> Char -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Builder
escape) Builder
forall a. Monoid a => a
mempty ByteString
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.char8 Char
'"'
        where
          escapeClass :: String
escapeClass = String
",\\\"()\t\n"
          escape :: Char -> Builder
escape = \case
            Char
'"' -> String -> Builder
B.string7 String
"\"\""
            Char
'\\' -> String -> Builder
B.string7 String
"\\\\"
            Char
c -> Char -> Builder
B.char8 Char
c


quoter :: HTable t => t Expr -> Opaleye.PrimExpr
quoter :: forall (t :: HTable). HTable t => t Expr -> PrimExpr
quoter t Expr
a = String -> [PrimExpr] -> PrimExpr
Opaleye.FunExpr String
"ROW" [PrimExpr]
exprs
  where
    exprs :: [PrimExpr]
exprs = Const [PrimExpr] (t Any) -> [PrimExpr]
forall {k} a (b :: k). Const a b -> a
getConst (Const [PrimExpr] (t Any) -> [PrimExpr])
-> Const [PrimExpr] (t Any) -> [PrimExpr]
forall a b. (a -> b) -> a -> b
$ (forall a. HField t a -> Const [PrimExpr] (Any a))
-> Const [PrimExpr] (t Any)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA \HField t a
field -> case t Expr -> HField t a -> Expr a
forall (context :: Context) a. t context -> HField t a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield t Expr
a HField t a
field of
      Expr a
expr -> [PrimExpr] -> Const [PrimExpr] (Any a)
forall {k} a (b :: k). a -> Const a b
Const [Expr a -> PrimExpr
forall a. Expr a -> PrimExpr
toPrimExpr Expr a
expr]