{-# LANGUAGE AllowAmbiguousTypes #-}
module Database.PostgreSQL.PQTypes.Deriving (
SQLEnum(..)
, EnumEncoding(..)
, SQLEnumAsText(..)
, EnumAsTextEncoding(..)
, isInjective
) where
import Control.Exception (SomeException(..), throwIO)
import Data.List.Extra (enumerate, nubSort)
import Data.Map.Strict (Map)
import Data.Text (Text)
import Data.Typeable
import Database.PostgreSQL.PQTypes
import Foreign.Storable
import qualified Data.Map.Strict as Map
newtype SQLEnum a = SQLEnum a
class
(
Enum a
, Bounded a
, Enum (EnumBase a)
, Ord (EnumBase a)
) => EnumEncoding a where
type EnumBase a
encodeEnum :: a -> EnumBase a
decodeEnum :: EnumBase a -> Either [(EnumBase a, EnumBase a)] a
decodeEnum EnumBase a
b = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Enum a, Ord a) => [a] -> [(a, a)]
intervals forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys (forall a. EnumEncoding a => Map (EnumBase a) a
decodeEnumMap @a)) forall a b. b -> Either a b
Right
forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup EnumBase a
b (forall a. EnumEncoding a => Map (EnumBase a) a
decodeEnumMap @a)
decodeEnumMap :: Map (EnumBase a) a
decodeEnumMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (forall a. EnumEncoding a => a -> EnumBase a
encodeEnum a
a, a
a) | a
a <- forall a. (Enum a, Bounded a) => [a]
enumerate ]
instance PQFormat (EnumBase a) => PQFormat (SQLEnum a) where
pqFormat :: ByteString
pqFormat = forall t. PQFormat t => ByteString
pqFormat @(EnumBase a)
instance
( EnumEncoding a
, PQFormat (EnumBase a)
, ToSQL (EnumBase a)
) => ToSQL (SQLEnum a) where
type PQDest (SQLEnum a) = PQDest (EnumBase a)
toSQL :: forall r.
SQLEnum a
-> ParamAllocator -> (Ptr (PQDest (SQLEnum a)) -> IO r) -> IO r
toSQL (SQLEnum a
a) = forall t r.
ToSQL t =>
t -> ParamAllocator -> (Ptr (PQDest t) -> IO r) -> IO r
toSQL forall a b. (a -> b) -> a -> b
$ forall a. EnumEncoding a => a -> EnumBase a
encodeEnum a
a
instance
( EnumEncoding a
, Storable (PQBase (EnumBase a))
, PQFormat (EnumBase a)
, FromSQL (EnumBase a)
, Show (EnumBase a)
, Typeable (EnumBase a)
) => FromSQL (SQLEnum a) where
type PQBase (SQLEnum a) = PQBase (EnumBase a)
fromSQL :: Maybe (PQBase (SQLEnum a)) -> IO (SQLEnum a)
fromSQL Maybe (PQBase (SQLEnum a))
base = do
EnumBase a
b <- forall t. FromSQL t => Maybe (PQBase t) -> IO t
fromSQL Maybe (PQBase (SQLEnum a))
base
case forall a.
EnumEncoding a =>
EnumBase a -> Either [(EnumBase a, EnumBase a)] a
decodeEnum EnumBase a
b of
Left [(EnumBase a, EnumBase a)]
validRange -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException RangeError
{ reRange :: [(EnumBase a, EnumBase a)]
reRange = [(EnumBase a, EnumBase a)]
validRange
, reValue :: EnumBase a
reValue = EnumBase a
b
}
Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> SQLEnum a
SQLEnum a
a
newtype SQLEnumAsText a = SQLEnumAsText a
class (Enum a, Bounded a) => EnumAsTextEncoding a where
encodeEnumAsText :: a -> Text
decodeEnumAsText :: Text -> Either [Text] a
decodeEnumAsText Text
text = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys (forall a. EnumAsTextEncoding a => Map Text a
decodeEnumAsTextMap @a)) forall a b. b -> Either a b
Right
forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
text (forall a. EnumAsTextEncoding a => Map Text a
decodeEnumAsTextMap @a)
decodeEnumAsTextMap :: Map Text a
decodeEnumAsTextMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (forall a. EnumAsTextEncoding a => a -> Text
encodeEnumAsText a
a, a
a) | a
a <- forall a. (Enum a, Bounded a) => [a]
enumerate ]
instance EnumAsTextEncoding a => PQFormat (SQLEnumAsText a) where
pqFormat :: ByteString
pqFormat = forall t. PQFormat t => ByteString
pqFormat @Text
instance EnumAsTextEncoding a => ToSQL (SQLEnumAsText a) where
type PQDest (SQLEnumAsText a) = PQDest Text
toSQL :: forall r.
SQLEnumAsText a
-> ParamAllocator
-> (Ptr (PQDest (SQLEnumAsText a)) -> IO r)
-> IO r
toSQL (SQLEnumAsText a
a) = forall t r.
ToSQL t =>
t -> ParamAllocator -> (Ptr (PQDest t) -> IO r) -> IO r
toSQL forall a b. (a -> b) -> a -> b
$ forall a. EnumAsTextEncoding a => a -> Text
encodeEnumAsText a
a
instance EnumAsTextEncoding a => FromSQL (SQLEnumAsText a) where
type PQBase (SQLEnumAsText a) = PQBase Text
fromSQL :: Maybe (PQBase (SQLEnumAsText a)) -> IO (SQLEnumAsText a)
fromSQL Maybe (PQBase (SQLEnumAsText a))
base = do
Text
text <- forall t. FromSQL t => Maybe (PQBase t) -> IO t
fromSQL Maybe (PQBase (SQLEnumAsText a))
base
case forall a. EnumAsTextEncoding a => Text -> Either [Text] a
decodeEnumAsText Text
text of
Left [Text]
validValues -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException InvalidValue
{ ivValue :: Text
ivValue = Text
text
, ivValidValues :: Maybe [Text]
ivValidValues = forall a. a -> Maybe a
Just [Text]
validValues
}
Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> SQLEnumAsText a
SQLEnumAsText a
a
isInjective :: (Enum a, Bounded a, Eq a, Eq b) => (a -> b) -> Bool
isInjective :: forall a b. (Enum a, Bounded a, Eq a, Eq b) => (a -> b) -> Bool
isInjective a -> b
f = forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ (a
a, a
b) | a
a <- forall a. (Enum a, Bounded a) => [a]
enumerate, a
b <- forall a. (Enum a, Bounded a) => [a]
enumerate, a
a forall a. Eq a => a -> a -> Bool
/= a
b, a -> b
f a
a forall a. Eq a => a -> a -> Bool
== a -> b
f a
b ]
intervals :: forall a . (Enum a, Ord a) => [a] -> [(a, a)]
intervals :: forall a. (Enum a, Ord a) => [a] -> [(a, a)]
intervals [a]
as = case forall a. Ord a => [a] -> [a]
nubSort [a]
as of
[] -> []
(a
first : [a]
ascendingRest) -> (a, a) -> [a] -> [(a, a)]
accumIntervals (a
first, a
first) [a]
ascendingRest
where
accumIntervals :: (a, a) -> [a] -> [(a, a)]
accumIntervals :: (a, a) -> [a] -> [(a, a)]
accumIntervals (a
lower, a
upper) [] = [(a
lower, a
upper)]
accumIntervals (a
lower, a
upper) (a
first' : [a]
ascendingRest') = if forall a. Enum a => a -> a
succ a
upper forall a. Eq a => a -> a -> Bool
== a
first'
then (a, a) -> [a] -> [(a, a)]
accumIntervals (a
lower, a
first') [a]
ascendingRest'
else (a
lower, a
upper) forall a. a -> [a] -> [a]
: (a, a) -> [a] -> [(a, a)]
accumIntervals (a
first', a
first') [a]
ascendingRest'