content: {-# language AllowAmbiguousTypes #-}
  {-# language DataKinds #-}
  {-# language DefaultSignatures #-}
  {-# language DisambiguateRecordFields #-}
  {-# language FlexibleContexts #-}
  {-# language FlexibleInstances #-}
  {-# language LambdaCase #-}
  {-# language RankNTypes #-}
  {-# language ScopedTypeVariables #-}
  {-# language StandaloneKindSignatures #-}
  {-# language TypeApplications #-}
  {-# language TypeFamilies #-}
  {-# language TypeOperators #-}
  {-# language UndecidableInstances #-}
  
  module Rel8.Type.Enum
    ( Enum( Enum )
    , DBEnum( enumValue, enumTypeName, enumerate )
    , Enumable
    )
  where
  
  -- base
  import Control.Applicative ( (<|>) )
  import Control.Arrow ( (&&&) )
  import Data.Kind ( Constraint, Type )
  import Data.Proxy ( Proxy( Proxy ) )
  import GHC.Generics
    ( Generic, Rep, from, to
    , (:+:)( L1, R1 ), M1( M1 ), U1( U1 )
    , D, C, Meta( MetaCons )
    )
  import GHC.TypeLits ( KnownSymbol, symbolVal )
  import Prelude hiding ( Enum )
  
  -- 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.Schema.QualifiedName (QualifiedName)
  import Rel8.Type ( DBType, typeInformation )
  import Rel8.Type.Decoder (Decoder (..))
  import Rel8.Type.Encoder (Encoder (..))
  import Rel8.Type.Eq ( DBEq )
  import Rel8.Type.Information ( TypeInformation(..) )
  import Rel8.Type.Name (TypeName (..))
  import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )
  
  -- text
  import Data.Text (pack)
  import Data.Text.Encoding (decodeUtf8, encodeUtf8Builder)
  
  
  -- | A deriving-via helper type for column types that store an \"enum\" type
  -- (in Haskell terms, a sum type where all constructors are nullary) using a
  -- Postgres @enum@ type.
  --
  -- Note that this should map to a specific type in your database's schema
  -- (explicitly created with @CREATE TYPE ... AS ENUM@). Use 'DBEnum' to
  -- specify the name of this Postgres type and the names of the individual
  -- values. If left unspecified, the names of the values of the Postgres
  -- @enum@ are assumed to match exactly exactly the names of the constructors
  -- of the Haskell type (up to and including case sensitivity).
  type Enum :: Type -> Type
  newtype Enum a = Enum
    { unEnum :: a
    }
  
  
  instance DBEnum a => DBType (Enum a) where
    typeInformation = TypeInformation
      { encode =
          let
            toText (Enum a) = pack $ enumValue a
          in
          Encoder
            { binary = Encoders.enum toText
            , text = encodeUtf8Builder . toText
            , quote =
                Opaleye.ConstExpr .
                Opaleye.StringLit .
                enumValue @a .
                unEnum
            }
      , decode =
          let
            mapping = (pack . enumValue &&& Enum) <$> enumerate
            unrecognised = Left "enum: unrecognised value"
          in
            Decoder
              { binary = Decoders.enum (`lookup` mapping)
              , text = maybe unrecognised pure . (`lookup` mapping) . decodeUtf8
              }
      , delimiter = ','
      , typeName =
          TypeName
            { name = enumTypeName @a
            , modifiers = []
            , arrayDepth = 0
            }
      }
  
  
  instance DBEnum a => DBEq (Enum a)
  
  
  instance DBEnum a => DBOrd (Enum a)
  
  
  instance DBEnum a => DBMax (Enum a)
  
  
  instance DBEnum a => DBMin (Enum a)
  
  
  -- | @DBEnum@ contains the necessary metadata to describe a PostgreSQL @enum@ type.
  type DBEnum :: Type -> Constraint
  class DBType a => DBEnum a where
    -- | Map Haskell values to the corresponding element of the @enum@ type. The
    -- default implementation of this method will use the exact name of the
    -- Haskell constructors.
    enumValue :: a -> String
  
    -- | The name of the PostgreSQL @enum@ type that @a@ maps to.
    enumTypeName :: QualifiedName
  
    -- | List of all possible values of the enum type.
    enumerate :: [a]
  
    default enumValue :: Enumable a => a -> String
    enumValue = gshow @(Rep a) . from
  
    default enumerate :: Enumable a => [a]
    enumerate = to <$> genumerate @(Rep a)
  
  
  -- | Types that are sum types, where each constructor is unary (that is, has no
  -- fields).
  type Enumable :: Type -> Constraint
  class (Generic a, GEnumable (Rep a)) => Enumable a
  instance (Generic a, GEnumable (Rep a)) => Enumable a
  
  
  type GEnumable :: (Type -> Type) -> Constraint
  class GEnumable rep where
    genumerate :: [rep x]
    gshow :: rep x -> String
  
  
  instance GEnumable rep => GEnumable (M1 D meta rep) where
    genumerate = M1 <$> genumerate
    gshow (M1 rep) = gshow rep
  
  
  instance (GEnumable a, GEnumable b) => GEnumable (a :+: b) where
    genumerate = L1 <$> genumerate <|> R1 <$> genumerate
    gshow = \case
      L1 a -> gshow a
      R1 a -> gshow a
  
  
  instance
    ( meta ~ 'MetaCons name _fixity _isRecord
    , KnownSymbol name
    )
    => GEnumable (M1 C meta U1)
   where
    genumerate = [M1 U1]
    gshow (M1 U1) = symbolVal (Proxy @name)
  