{-# language AllowAmbiguousTypes #-}
{-# language DataKinds #-}
{-# 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 )
  , 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 Hasql

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

-- rel8
import Rel8.Type ( DBType, typeInformation )
import Rel8.Type.Eq ( DBEq )
import Rel8.Type.Information ( TypeInformation(..) )
import Rel8.Type.Ord ( DBOrd, DBMax, DBMin )

-- text
import Data.Text ( pack )


-- | 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
  { forall a. Enum a -> a
unEnum :: a
  }


instance DBEnum a => DBType (Enum a) where
  typeInformation :: TypeInformation (Enum a)
typeInformation = TypeInformation
    { decode :: Value (Enum a)
decode =
        forall a. (Text -> Maybe a) -> Value a
Hasql.enum forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map ((String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. DBEnum a => a -> String
enumValue forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> Enum a
Enum) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => Rep a x -> a
to) forall a b. (a -> b) -> a -> b
$
        forall (rep :: * -> *) x. GEnumable rep => [rep x]
genumerate @(Rep a)
    , encode :: Enum a -> PrimExpr
encode =
        Literal -> PrimExpr
Opaleye.ConstExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> Literal
Opaleye.StringLit forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall a. DBEnum a => a -> String
enumValue @a forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall a. Enum a -> a
unEnum
    , typeName :: String
typeName = forall a. DBEnum a => String
enumTypeName @a
    }


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, Enumable 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
  enumValue = forall (rep :: * -> *) x. GEnumable rep => rep x -> String
gshow @(Rep a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

  -- | The name of the PostgreSQL @enum@ type that @a@ maps to.
  enumTypeName :: String


-- | 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 :: forall x. [M1 D meta rep x]
genumerate = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) x. GEnumable rep => [rep x]
genumerate
  gshow :: forall x. M1 D meta rep x -> String
gshow (M1 rep x
rep) = forall (rep :: * -> *) x. GEnumable rep => rep x -> String
gshow rep x
rep


instance (GEnumable a, GEnumable b) => GEnumable (a :+: b) where
  genumerate :: forall x. [(:+:) a b x]
genumerate = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) x. GEnumable rep => [rep x]
genumerate forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) x. GEnumable rep => [rep x]
genumerate
  gshow :: forall x. (:+:) a b x -> String
gshow = \case
    L1 a x
a -> forall (rep :: * -> *) x. GEnumable rep => rep x -> String
gshow a x
a
    R1 b x
a -> forall (rep :: * -> *) x. GEnumable rep => rep x -> String
gshow b x
a


instance
  ( meta ~ 'MetaCons name _fixity _isRecord
  , KnownSymbol name
  )
  => GEnumable (M1 C meta U1)
 where
  genumerate :: forall x. [M1 C meta U1 x]
genumerate = [forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall k (p :: k). U1 p
U1]
  gshow :: forall x. M1 C meta U1 x -> String
gshow (M1 U1 x
U1) = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @name)