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


instance DBEnum a => DBType (Enum a) where
  typeInformation :: TypeInformation (Enum a)
typeInformation = TypeInformation :: forall a. (a -> PrimExpr) -> Value a -> String -> TypeInformation a
TypeInformation
    { decode :: Value (Enum a)
decode =
        (Text -> Maybe (Enum a)) -> Value (Enum a)
forall a. (Text -> Maybe a) -> Value a
Hasql.enum ((Text -> Maybe (Enum a)) -> Value (Enum a))
-> (Text -> Maybe (Enum a)) -> Value (Enum a)
forall a b. (a -> b) -> a -> b
$
        (Text -> [(Text, Enum a)] -> Maybe (Enum a))
-> [(Text, Enum a)] -> Text -> Maybe (Enum a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> [(Text, Enum a)] -> Maybe (Enum a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ([(Text, Enum a)] -> Text -> Maybe (Enum a))
-> [(Text, Enum a)] -> Text -> Maybe (Enum a)
forall a b. (a -> b) -> a -> b
$
        (Rep a Any -> (Text, Enum a)) -> [Rep a Any] -> [(Text, Enum a)]
forall a b. (a -> b) -> [a] -> [b]
map ((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 (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
to) ([Rep a Any] -> [(Text, Enum a)])
-> [Rep a Any] -> [(Text, Enum a)]
forall a b. (a -> b) -> a -> b
$
        forall x. GEnumable (Rep a) => [Rep a x]
forall (rep :: * -> *) x. GEnumable rep => [rep x]
genumerate @(Rep a)
    , 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
.
        DBEnum a => a -> String
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 :: String
typeName = DBEnum a => String
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)


type DBEnum :: Type -> Constraint
class (DBType a, Enumable a) => DBEnum a where
  enumValue :: a -> String
  enumValue = forall x. GEnumable (Rep a) => Rep a x -> String
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 a x. Generic a => a -> Rep a x
from

  enumTypeName :: String


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 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 (rep :: * -> *) x. GEnumable rep => [rep x]
genumerate
  gshow :: M1 D meta rep x -> String
gshow (M1 rep x
rep) = 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 :: [(:+:) 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 (rep :: * -> *) x. GEnumable rep => [rep x]
genumerate [(:+:) a b x] -> [(:+:) a b x] -> [(:+:) a b x]
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 (rep :: * -> *) x. GEnumable rep => [rep x]
genumerate
  gshow :: (:+:) a b x -> String
gshow = \case
    L1 a x
a -> a x -> String
forall (rep :: * -> *) x. GEnumable rep => rep x -> String
gshow a x
a
    R1 b x
a -> 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 :: [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 :: 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 (Proxy name
forall k (t :: k). Proxy t
Proxy @name)