{-# 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.Schema.QualifiedName (QualifiedName)
import Rel8.Type ( DBType, typeInformation )
import Rel8.Type.Decoder (Decoder (..))
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)


-- | 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 :: Decoder (Enum a)
decode =
        let
          mapping :: [(Text, Enum a)]
mapping = (String -> Text
pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. DBEnum a => a -> String
enumValue (a -> Text) -> (a -> Enum a) -> a -> (Text, Enum a)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a -> Enum a
forall a. a -> Enum a
Enum) (a -> (Text, Enum a))
-> (Rep a Any -> a) -> Rep a Any -> (Text, Enum a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> (Text, Enum a)) -> [Rep a Any] -> [(Text, Enum a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rep :: * -> *) x. GEnumable rep => [rep x]
genumerate @(Rep a)
          unrecognised :: Either String b
unrecognised = String -> Either String b
forall a b. a -> Either a b
Left String
"enum: unrecognised value"
        in
          Decoder
            { binary :: Value (Enum a)
binary = (Text -> Maybe (Enum a)) -> Value (Enum a)
forall a. (Text -> Maybe a) -> Value a
Hasql.enum (Text -> [(Text, Enum a)] -> Maybe (Enum a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Text, Enum a)]
mapping)
            , parser :: Parser (Enum a)
parser = Either String (Enum a)
-> (Enum a -> Either String (Enum a))
-> Maybe (Enum a)
-> Either String (Enum a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Either String (Enum a)
forall {b}. Either String b
unrecognised Enum a -> Either String (Enum a)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Enum a) -> Either String (Enum a))
-> (ByteString -> Maybe (Enum a)) -> Parser (Enum a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [(Text, Enum a)] -> Maybe (Enum a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Text, Enum a)]
mapping) (Text -> Maybe (Enum a))
-> (ByteString -> Text) -> ByteString -> Maybe (Enum a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8
            , delimiter :: Char
delimiter = Char
','
            }
    , encode :: Enum a -> PrimExpr
encode =
        Literal -> PrimExpr
Opaleye.ConstExpr (Literal -> PrimExpr) -> (Enum a -> Literal) -> Enum a -> PrimExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> Literal
Opaleye.StringLit (String -> Literal) -> (Enum a -> String) -> Enum a -> Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall a. DBEnum a => a -> String
enumValue @a (a -> String) -> (Enum a -> a) -> Enum a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        Enum a -> a
forall a. Enum a -> a
unEnum
    , typeName :: TypeName
typeName =
        TypeName
          { name :: QualifiedName
name = forall a. DBEnum a => QualifiedName
enumTypeName @a
          , modifiers :: [String]
modifiers = []
          , arrayDepth :: Word
arrayDepth = Word
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, 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) (Rep a Any -> String) -> (a -> Rep a Any) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

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


-- | 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 = rep x -> M1 D meta rep x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (rep x -> M1 D meta rep x) -> [rep x] -> [M1 D meta rep x]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [rep x]
forall x. [rep x]
forall (rep :: * -> *) x. GEnumable rep => [rep x]
genumerate
  gshow :: forall x. M1 D meta rep x -> String
gshow (M1 rep x
rep) = rep x -> String
forall x. rep x -> String
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 = a x -> (:+:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a x -> (:+:) a b x) -> [a x] -> [(:+:) a b x]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a x]
forall x. [a x]
forall (rep :: * -> *) x. GEnumable rep => [rep x]
genumerate [(:+:) a b x] -> [(:+:) a b x] -> [(:+:) a b x]
forall a. [a] -> [a] -> [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> b x -> (:+:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b x -> (:+:) a b x) -> [b x] -> [(:+:) a b x]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [b x]
forall x. [b x]
forall (rep :: * -> *) x. GEnumable rep => [rep x]
genumerate
  gshow :: forall x. (:+:) a b x -> String
gshow = \case
    L1 a x
a -> a x -> String
forall x. a x -> String
forall (rep :: * -> *) x. GEnumable rep => rep x -> String
gshow a x
a
    R1 b x
a -> b x -> String
forall x. b x -> String
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 = [U1 x -> M1 C meta U1 x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 U1 x
forall k (p :: k). U1 p
U1]
  gshow :: forall x. M1 C meta U1 x -> String
gshow (M1 U1 x
U1) = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)