{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}

module Opaleye.Experimental.Enum
  (
    enumMapper,
    EnumMapper,
    enumFromField,
    enumToFields,
    fromFieldToFieldsEnum,
  ) where

import           Opaleye.Column (Column)
import qualified Opaleye as O
import qualified Opaleye.Internal.Inferrable as I
import qualified Opaleye.Internal.RunQuery as RQ

import           Data.ByteString.Char8 (unpack)
import qualified Data.Profunctor.Product.Default as D

data EnumMapper sqlEnum haskellSum = EnumMapper {
    EnumMapper sqlEnum haskellSum -> FromField sqlEnum haskellSum
enumFromField :: RQ.FromField sqlEnum haskellSum
  , EnumMapper sqlEnum haskellSum
-> ToFields haskellSum (Column sqlEnum)
enumToFields :: O.ToFields haskellSum (Column sqlEnum)
  }

-- | Create a mapping between a Postgres @ENUM@ type and a Haskell
-- type.  Also works for @DOMAIN@ types. For example, if you have the
-- following @ENUM@
--
-- @
-- CREATE TYPE public.mpaa_rating AS ENUM (
--    \'G\',
--    \'PG\',
--    \'PG-13\',
--    \'R\',
--    \'NC-17\'
-- );
-- @
--
-- then you can define data types to represent the enum on the SQL
-- side and Haskell side respectively
--
-- @
-- data SqlRating
-- data Rating = G | PG | PG13 | R | NC17 deriving Show
-- @
--
-- and functions to map between them
--
-- @
-- toSqlRatingString :: Rating -> String
-- toSqlRatingString r = case r of
--     G    -> \"G\"
--     PG   -> \"PG\"
--     PG13 -> \"PG-13\"
--     R    -> \"R\"
--     NC17 -> \"NC-17\"
--
-- fromSqlRatingString :: String -> Maybe Rating
-- fromSqlRatingString s = case s of
--     \"G\"     -> Just G
--     \"PG\"    -> Just PG
--     \"PG-13\" -> Just PG13
--     \"R\"     -> Just R
--     \"NC-17\" -> Just NC17
--     _       -> Nothing
-- @
--
-- Then you can use the mappings as follows
--
-- @
-- import qualified Opaleye as O
-- import qualified Data.Profunctor.Product.Default as D
--
-- sqlRatingMapper :: EnumMapper SqlRating Rating
-- sqlRatingMapper = enumMapper "mpaa_rating" fromSqlRatingString toSqlRatingString
--
-- instance O.DefaultFromField SqlRating Rating where
--   defaultFromField = enumFromField sqlRatingMapper
--
-- instance rating ~ Rating
--   => D.Default (Inferrable O.FromFields) (O.Column SqlRating) rating where
--   def = Inferrable D.def
--
-- instance D.Default O.ToFields Rating (O.Column SqlRating) where
--   def = enumToFields sqlRatingMapper
-- @
enumMapper :: String
           -- ^ The name of the @ENUM@ type
           -> (String -> Maybe haskellSum)
           -- ^ A function which converts from the string
           -- representation of the ENUM field
           -> (haskellSum -> String)
           -- ^ A function which converts to the string representation
           -- of the ENUM field
           -> EnumMapper sqlEnum haskellSum
           -- ^ The @sqlEnum@ type variable is phantom. To protect
           -- yourself against type mismatches you should set it to
           -- the Haskell type that you use to represent the @ENUM@.
enumMapper :: String
-> (String -> Maybe haskellSum)
-> (haskellSum -> String)
-> EnumMapper sqlEnum haskellSum
enumMapper String
type_ String -> Maybe haskellSum
from haskellSum -> String
to_ = EnumMapper :: forall sqlEnum haskellSum.
FromField sqlEnum haskellSum
-> ToFields haskellSum (Column sqlEnum)
-> EnumMapper sqlEnum haskellSum
EnumMapper {
    enumFromField :: FromField sqlEnum haskellSum
enumFromField = FromField sqlEnum haskellSum
forall a. FromField a haskellSum
fromFieldEnum
  , enumToFields :: ToFields haskellSum (Column sqlEnum)
enumToFields = ToFields haskellSum (Column sqlEnum)
forall b. ToFields haskellSum (Column b)
toFieldsEnum
  }
   where
     toFieldsEnum :: ToFields haskellSum (Column b)
toFieldsEnum = (haskellSum -> Column b) -> ToFields haskellSum (Column b)
forall haskells fields.
(haskells -> fields) -> ToFields haskells fields
O.toToFields (String -> Column SqlText -> Column b
forall a b. String -> Column a -> Column b
O.unsafeCast String
type_ (Column SqlText -> Column b)
-> (haskellSum -> Column SqlText) -> haskellSum -> Column b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Column SqlText
String -> Field SqlText
O.sqlString (String -> Column SqlText)
-> (haskellSum -> String) -> haskellSum -> Column SqlText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. haskellSum -> String
to_)
     fromFieldEnum :: FromField a haskellSum
fromFieldEnum = (((Field, Maybe ByteString) -> haskellSum)
 -> FromField a (Field, Maybe ByteString) -> FromField a haskellSum)
-> FromField a (Field, Maybe ByteString)
-> ((Field, Maybe ByteString) -> haskellSum)
-> FromField a haskellSum
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Field, Maybe ByteString) -> haskellSum)
-> FromField a (Field, Maybe ByteString) -> FromField a haskellSum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromField a (Field, Maybe ByteString)
forall a. FromField a (Field, Maybe ByteString)
RQ.unsafeFromFieldRaw (((Field, Maybe ByteString) -> haskellSum)
 -> FromField a haskellSum)
-> ((Field, Maybe ByteString) -> haskellSum)
-> FromField a haskellSum
forall a b. (a -> b) -> a -> b
$ \(Field
_, Maybe ByteString
mdata) -> case Maybe ByteString
mdata of
       Maybe ByteString
Nothing -> String -> haskellSum
forall a. HasCallStack => String -> a
error String
"Unexpected NULL"
       Just ByteString
s -> case String -> Maybe haskellSum
from (ByteString -> String
unpack ByteString
s) of
         Just haskellSum
r -> haskellSum
r
         Maybe haskellSum
Nothing -> String -> haskellSum
forall a. HasCallStack => String -> a
error (String
"Unexpected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
unpack ByteString
s)

-- | Use 'enumMapper' instead.  Will be deprecated in 0.8.
fromFieldToFieldsEnum :: String
                      -> (String -> Maybe haskellSum)
                      -> (haskellSum -> String)
                      -> (RQ.FromField sqlEnum haskellSum,
                          O.ToFields haskellSum (Column sqlEnum))
fromFieldToFieldsEnum :: String
-> (String -> Maybe haskellSum)
-> (haskellSum -> String)
-> (FromField sqlEnum haskellSum,
    ToFields haskellSum (Column sqlEnum))
fromFieldToFieldsEnum String
type_ String -> Maybe haskellSum
from haskellSum -> String
to_ = (EnumMapper sqlEnum haskellSum -> FromField sqlEnum haskellSum
forall sqlEnum haskellSum.
EnumMapper sqlEnum haskellSum -> FromField sqlEnum haskellSum
enumFromField EnumMapper sqlEnum haskellSum
forall sqlEnum. EnumMapper sqlEnum haskellSum
e, EnumMapper sqlEnum haskellSum
-> ToFields haskellSum (Column sqlEnum)
forall sqlEnum haskellSum.
EnumMapper sqlEnum haskellSum
-> ToFields haskellSum (Column sqlEnum)
enumToFields EnumMapper sqlEnum haskellSum
forall sqlEnum. EnumMapper sqlEnum haskellSum
e)
  where e :: EnumMapper sqlEnum haskellSum
e = String
-> (String -> Maybe haskellSum)
-> (haskellSum -> String)
-> EnumMapper sqlEnum haskellSum
forall haskellSum sqlEnum.
String
-> (String -> Maybe haskellSum)
-> (haskellSum -> String)
-> EnumMapper sqlEnum haskellSum
enumMapper String
type_ String -> Maybe haskellSum
from haskellSum -> String
to_