{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module Database.Persist.Class.PersistEntity
    ( PersistEntity (..)
    , Update (..)
    , BackendSpecificUpdate
    , SelectOpt (..)
    , Filter (..)
    , FilterValue (..)
    , BackendSpecificFilter
    , Entity (..)

    , recordName
    , entityValues
    , keyValueEntityToJSON, keyValueEntityFromJSON
    , entityIdToJSON, entityIdFromJSON
      -- * PersistField based on other typeclasses
    , toPersistValueJSON, fromPersistValueJSON
    , toPersistValueEnum, fromPersistValueEnum
      -- * Support for @OverloadedLabels@ with 'EntityField'
    , SymbolToField (..)
    ) where

import Data.Aeson (ToJSON (..), withObject, FromJSON (..), fromJSON, object, (.:), (.=), Value (Object))
import qualified Data.Aeson.Parser as AP
import Data.Aeson.Types (Parser,Result(Error,Success))
import Data.Aeson.Text (encodeToTextBuilder)
import Data.Attoparsec.ByteString (parseOnly)
import qualified Data.HashMap.Strict as HM
import Data.Maybe (isJust)
import Data.Monoid (mappend)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as TB
import GHC.Generics
import GHC.OverloadedLabels
import GHC.TypeLits

import Database.Persist.Class.PersistField
import Database.Persist.Types.Base

-- | Persistent serialized Haskell records to the database.
-- A Database 'Entity' (A row in SQL, a document in MongoDB, etc)
-- corresponds to a 'Key' plus a Haskell record.
--
-- For every Haskell record type stored in the database there is a
-- corresponding 'PersistEntity' instance. An instance of PersistEntity
-- contains meta-data for the record.  PersistEntity also helps abstract
-- over different record types. That way the same query interface can return
-- a 'PersistEntity', with each query returning different types of Haskell
-- records.
--
-- Some advanced type system capabilities are used to make this process
-- type-safe. Persistent users usually don't need to understand the class
-- associated data and functions.
class ( PersistField (Key record), ToJSON (Key record), FromJSON (Key record)
      , Show (Key record), Read (Key record), Eq (Key record), Ord (Key record))
  => PersistEntity record where
    -- | Persistent allows multiple different backends (databases).
    type PersistEntityBackend record

    -- | By default, a backend will automatically generate the key
    -- Instead you can specify a Primary key made up of unique values.
    data Key record
    -- | A lower-level key operation.
    keyToValues :: Key record -> [PersistValue]
    -- | A lower-level key operation.
    keyFromValues :: [PersistValue] -> Either Text (Key record)
    -- | A meta-operation to retrieve the 'Key' 'EntityField'.
    persistIdField :: EntityField record (Key record)

    -- | Retrieve the 'EntityDef' meta-data for the record.
    entityDef :: proxy record -> EntityDef

    -- | An 'EntityField' is parameterised by the Haskell record it belongs to
    -- and the additional type of that field.
    --
    -- As of @persistent-2.11.0.0@, it's possible to use the @OverloadedLabels@
    -- language extension to refer to 'EntityField' values polymorphically. See
    -- the documentation on 'SymbolToField' for more information.
    data EntityField record :: * -> *
    -- | Return meta-data for a given 'EntityField'.
    persistFieldDef :: EntityField record typ -> FieldDef
    -- | A meta-operation to get the database fields of a record.
    toPersistFields :: record -> [SomePersistField]
    -- | A lower-level operation to convert from database values to a Haskell record.
    fromPersistValues :: [PersistValue] -> Either Text record

    -- | Unique keys besides the 'Key'.
    data Unique record
    -- | A meta operation to retrieve all the 'Unique' keys.
    persistUniqueKeys :: record -> [Unique record]
    -- | A lower level operation.
    persistUniqueToFieldNames :: Unique record -> [(FieldNameHS, FieldNameDB)]
    -- | A lower level operation.
    persistUniqueToValues :: Unique record -> [PersistValue]

    -- | Use a 'PersistField' as a lens.
    fieldLens :: EntityField record field
              -> (forall f. Functor f => (field -> f field) -> Entity record -> f (Entity record))

    -- | Extract a @'Key' record@ from a @record@ value. Currently, this is
    -- only defined for entities using the @Primary@ syntax for
    -- natural/composite keys. In a future version of @persistent@ which
    -- incorporates the ID directly into the entity, this will always be Just.
    --
    -- @since 2.11.0.0
    keyFromRecordM :: Maybe (record -> Key record)
    keyFromRecordM = Maybe (record -> Key record)
forall a. Maybe a
Nothing

type family BackendSpecificUpdate backend record

-- Moved over from Database.Persist.Class.PersistUnique
-- | Textual representation of the record
recordName
    :: (PersistEntity record)
    => record -> Text
recordName :: record -> Text
recordName = EntityNameHS -> Text
unEntityNameHS (EntityNameHS -> Text)
-> (record -> EntityNameHS) -> record -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameHS
entityHaskell (EntityDef -> EntityNameHS)
-> (record -> EntityDef) -> record -> EntityNameHS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Maybe record -> EntityDef)
-> (record -> Maybe record) -> record -> EntityDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. record -> Maybe record
forall a. a -> Maybe a
Just

-- | Updating a database entity.
--
-- Persistent users use combinators to create these.
data Update record = forall typ. PersistField typ => Update
    { ()
updateField :: EntityField record typ
    , ()
updateValue :: typ
    -- FIXME Replace with expr down the road
    , Update record -> PersistUpdate
updateUpdate :: PersistUpdate
    }
    | BackendUpdate
          (BackendSpecificUpdate (PersistEntityBackend record) record)

-- | Query options.
--
-- Persistent users use these directly.
data SelectOpt record = forall typ. Asc  (EntityField record typ)
                      | forall typ. Desc (EntityField record typ)
                      | OffsetBy Int
                      | LimitTo Int

type family BackendSpecificFilter backend record

-- | Filters which are available for 'select', 'updateWhere' and
-- 'deleteWhere'. Each filter constructor specifies the field being
-- filtered on, the type of comparison applied (equals, not equals, etc)
-- and the argument for the comparison.
--
-- Persistent users use combinators to create these.
--
-- Note that it's important to be careful about the 'PersistFilter' that
-- you are using, if you use this directly. For example, using the 'In'
-- 'PersistFilter' requires that you have an array- or list-shaped
-- 'EntityField'. It is possible to construct values using this that will
-- create malformed runtime values.
data Filter record = forall typ. PersistField typ => Filter
    { ()
filterField  :: EntityField record typ
    , ()
filterValue  :: FilterValue typ
    , Filter record -> PersistFilter
filterFilter :: PersistFilter -- FIXME
    }
    | FilterAnd [Filter record] -- ^ convenient for internal use, not needed for the API
    | FilterOr  [Filter record]
    | BackendFilter
          (BackendSpecificFilter (PersistEntityBackend record) record)

-- | Value to filter with. Highly dependant on the type of filter used.
--
-- @since 2.10.0
data FilterValue typ where
  FilterValue  :: typ -> FilterValue typ
  FilterValues :: [typ] -> FilterValue typ
  UnsafeValue  :: forall a typ. PersistField a => a -> FilterValue typ

-- | Datatype that represents an entity, with both its 'Key' and
-- its Haskell record representation.
--
-- When using a SQL-based backend (such as SQLite or
-- PostgreSQL), an 'Entity' may take any number of columns
-- depending on how many fields it has. In order to reconstruct
-- your entity on the Haskell side, @persistent@ needs all of
-- your entity columns and in the right order.  Note that you
-- don't need to worry about this when using @persistent@\'s API
-- since everything is handled correctly behind the scenes.
--
-- However, if you want to issue a raw SQL command that returns
-- an 'Entity', then you have to be careful with the column
-- order.  While you could use @SELECT Entity.* WHERE ...@ and
-- that would work most of the time, there are times when the
-- order of the columns on your database is different from the
-- order that @persistent@ expects (for example, if you add a new
-- field in the middle of you entity definition and then use the
-- migration code -- @persistent@ will expect the column to be in
-- the middle, but your DBMS will put it as the last column).
-- So, instead of using a query like the one above, you may use
-- 'Database.Persist.GenericSql.rawSql' (from the
-- "Database.Persist.GenericSql" module) with its /entity
-- selection placeholder/ (a double question mark @??@).  Using
-- @rawSql@ the query above must be written as @SELECT ??  WHERE
-- ..@.  Then @rawSql@ will replace @??@ with the list of all
-- columns that we need from your entity in the right order.  If
-- your query returns two entities (i.e. @(Entity backend a,
-- Entity backend b)@), then you must you use @SELECT ??, ??
-- WHERE ...@, and so on.
data Entity record =
    Entity { Entity record -> Key record
entityKey :: Key record
           , Entity record -> record
entityVal :: record }

deriving instance (Generic (Key record), Generic record) => Generic (Entity record)
deriving instance (Eq (Key record), Eq record) => Eq (Entity record)
deriving instance (Ord (Key record), Ord record) => Ord (Entity record)
deriving instance (Show (Key record), Show record) => Show (Entity record)
deriving instance (Read (Key record), Read record) => Read (Entity record)

-- | Get list of values corresponding to given entity.
entityValues :: PersistEntity record => Entity record -> [PersistValue]
entityValues :: Entity record -> [PersistValue]
entityValues (Entity Key record
k record
record) =
  if Maybe CompositeDef -> Bool
forall a. Maybe a -> Bool
isJust (EntityDef -> Maybe CompositeDef
entityPrimary EntityDef
ent)
    then
      -- TODO: check against the key
      (SomePersistField -> PersistValue)
-> [SomePersistField] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map SomePersistField -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (record -> [SomePersistField]
forall record. PersistEntity record => record -> [SomePersistField]
toPersistFields record
record)
    else
      Key record -> [PersistValue]
forall record. PersistEntity record => Key record -> [PersistValue]
keyToValues Key record
k [PersistValue] -> [PersistValue] -> [PersistValue]
forall a. [a] -> [a] -> [a]
++ (SomePersistField -> PersistValue)
-> [SomePersistField] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map SomePersistField -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (record -> [SomePersistField]
forall record. PersistEntity record => record -> [SomePersistField]
toPersistFields record
record)
  where
    ent :: EntityDef
ent = Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Maybe record -> EntityDef) -> Maybe record -> EntityDef
forall a b. (a -> b) -> a -> b
$ record -> Maybe record
forall a. a -> Maybe a
Just record
record

-- | Predefined @toJSON@. The resulting JSON looks like
-- @{"key": 1, "value": {"name": ...}}@.
--
-- The typical usage is:
--
-- @
-- instance ToJSON (Entity User) where
--     toJSON = keyValueEntityToJSON
-- @
keyValueEntityToJSON :: (PersistEntity record, ToJSON record)
                     => Entity record -> Value
keyValueEntityToJSON :: Entity record -> Value
keyValueEntityToJSON (Entity Key record
key record
value) = [Pair] -> Value
object
    [ Text
"key" Text -> Key record -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Key record
key
    , Text
"value" Text -> record -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= record
value
    ]

-- | Predefined @parseJSON@. The input JSON looks like
-- @{"key": 1, "value": {"name": ...}}@.
--
-- The typical usage is:
--
-- @
-- instance FromJSON (Entity User) where
--     parseJSON = keyValueEntityFromJSON
-- @
keyValueEntityFromJSON :: (PersistEntity record, FromJSON record)
                       => Value -> Parser (Entity record)
keyValueEntityFromJSON :: Value -> Parser (Entity record)
keyValueEntityFromJSON (Object Object
o) = Key record -> record -> Entity record
forall record. Key record -> record -> Entity record
Entity
    (Key record -> record -> Entity record)
-> Parser (Key record) -> Parser (record -> Entity record)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Key record)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"key"
    Parser (record -> Entity record)
-> Parser record -> Parser (Entity record)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser record
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"value"
keyValueEntityFromJSON Value
_ = String -> Parser (Entity record)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"keyValueEntityFromJSON: not an object"

-- | Predefined @toJSON@. The resulting JSON looks like
-- @{"id": 1, "name": ...}@.
--
-- The typical usage is:
--
-- @
-- instance ToJSON (Entity User) where
--     toJSON = entityIdToJSON
-- @
entityIdToJSON :: (PersistEntity record, ToJSON record) => Entity record -> Value
entityIdToJSON :: Entity record -> Value
entityIdToJSON (Entity Key record
key record
value) = case record -> Value
forall a. ToJSON a => a -> Value
toJSON record
value of
        Object Object
o -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
"id" (Key record -> Value
forall a. ToJSON a => a -> Value
toJSON Key record
key) Object
o
        Value
x -> Value
x

-- | Predefined @parseJSON@. The input JSON looks like
-- @{"id": 1, "name": ...}@.
--
-- The typical usage is:
--
-- @
-- instance FromJSON (Entity User) where
--     parseJSON = entityIdFromJSON
-- @
entityIdFromJSON :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record)
entityIdFromJSON :: Value -> Parser (Entity record)
entityIdFromJSON = String
-> (Object -> Parser (Entity record))
-> Value
-> Parser (Entity record)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"entityIdFromJSON" ((Object -> Parser (Entity record))
 -> Value -> Parser (Entity record))
-> (Object -> Parser (Entity record))
-> Value
-> Parser (Entity record)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    record
val <- Value -> Parser record
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
    Key record
k <- case Maybe (record -> Key record)
forall record. PersistEntity record => Maybe (record -> Key record)
keyFromRecordM of
        Maybe (record -> Key record)
Nothing ->
            Object
o Object -> Text -> Parser (Key record)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"id"
        Just record -> Key record
func ->
            Key record -> Parser (Key record)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key record -> Parser (Key record))
-> Key record -> Parser (Key record)
forall a b. (a -> b) -> a -> b
$ record -> Key record
func record
val
    Entity record -> Parser (Entity record)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Entity record -> Parser (Entity record))
-> Entity record -> Parser (Entity record)
forall a b. (a -> b) -> a -> b
$ Key record -> record -> Entity record
forall record. Key record -> record -> Entity record
Entity Key record
k record
val

instance (PersistEntity record, PersistField record, PersistField (Key record))
  => PersistField (Entity record) where
    toPersistValue :: Entity record -> PersistValue
toPersistValue (Entity Key record
key record
value) = case record -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue record
value of
        (PersistMap [(Text, PersistValue)]
alist) -> [(Text, PersistValue)] -> PersistValue
PersistMap ((Text
idField, Key record -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue Key record
key) (Text, PersistValue)
-> [(Text, PersistValue)] -> [(Text, PersistValue)]
forall a. a -> [a] -> [a]
: [(Text, PersistValue)]
alist)
        PersistValue
_ -> String -> PersistValue
forall a. HasCallStack => String -> a
error (String -> PersistValue) -> String -> PersistValue
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
errMsg Text
"expected PersistMap"

    fromPersistValue :: PersistValue -> Either Text (Entity record)
fromPersistValue (PersistMap [(Text, PersistValue)]
alist) = case [(Text, PersistValue)]
after of
        [] -> Text -> Either Text (Entity record)
forall a b. a -> Either a b
Left (Text -> Either Text (Entity record))
-> Text -> Either Text (Entity record)
forall a b. (a -> b) -> a -> b
$ Text -> Text
errMsg (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"did not find " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`Data.Monoid.mappend` Text
idField Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
" field"
        (Text
"_id", PersistValue
kv):[(Text, PersistValue)]
afterRest ->
            PersistValue -> Either Text record
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue ([(Text, PersistValue)] -> PersistValue
PersistMap ([(Text, PersistValue)]
before [(Text, PersistValue)]
-> [(Text, PersistValue)] -> [(Text, PersistValue)]
forall a. [a] -> [a] -> [a]
++ [(Text, PersistValue)]
afterRest)) Either Text record
-> (record -> Either Text (Entity record))
-> Either Text (Entity record)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \record
record ->
                [PersistValue] -> Either Text (Key record)
forall record.
PersistEntity record =>
[PersistValue] -> Either Text (Key record)
keyFromValues [PersistValue
kv] Either Text (Key record)
-> (Key record -> Either Text (Entity record))
-> Either Text (Entity record)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Key record
k ->
                    Entity record -> Either Text (Entity record)
forall a b. b -> Either a b
Right (Key record -> record -> Entity record
forall record. Key record -> record -> Entity record
Entity Key record
k record
record)
        [(Text, PersistValue)]
_ -> Text -> Either Text (Entity record)
forall a b. a -> Either a b
Left (Text -> Either Text (Entity record))
-> Text -> Either Text (Entity record)
forall a b. (a -> b) -> a -> b
$ Text -> Text
errMsg (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"impossible id field: " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` String -> Text
T.pack ([(Text, PersistValue)] -> String
forall a. Show a => a -> String
show [(Text, PersistValue)]
alist)
      where
        ([(Text, PersistValue)]
before, [(Text, PersistValue)]
after) = ((Text, PersistValue) -> Bool)
-> [(Text, PersistValue)]
-> ([(Text, PersistValue)], [(Text, PersistValue)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
idField) (Text -> Bool)
-> ((Text, PersistValue) -> Text) -> (Text, PersistValue) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, PersistValue) -> Text
forall a b. (a, b) -> a
fst) [(Text, PersistValue)]
alist

    fromPersistValue PersistValue
x = Text -> Either Text (Entity record)
forall a b. a -> Either a b
Left (Text -> Either Text (Entity record))
-> Text -> Either Text (Entity record)
forall a b. (a -> b) -> a -> b
$
          Text -> Text
errMsg Text
"Expected PersistMap, received: " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` String -> Text
T.pack (PersistValue -> String
forall a. Show a => a -> String
show PersistValue
x)

errMsg :: Text -> Text
errMsg :: Text -> Text
errMsg = Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend Text
"PersistField entity fromPersistValue: "

-- | Realistically this is only going to be used for MongoDB,
-- so lets use MongoDB conventions
idField :: Text
idField :: Text
idField = Text
"_id"

-- | Convenience function for getting a free 'PersistField' instance
-- from a type with JSON instances.
--
--
-- Example usage in combination with 'fromPersistValueJSON':
--
-- @
-- instance PersistField MyData where
--   fromPersistValue = fromPersistValueJSON
--   toPersistValue = toPersistValueJSON
-- @
toPersistValueJSON :: ToJSON a => a -> PersistValue
toPersistValueJSON :: a -> PersistValue
toPersistValueJSON = Text -> PersistValue
PersistText (Text -> PersistValue) -> (a -> Text) -> a -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
LT.toStrict (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
TB.toLazyText (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Builder
forall a. ToJSON a => a -> Builder
encodeToTextBuilder (Value -> Builder) -> (a -> Value) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON

-- | Convenience function for getting a free 'PersistField' instance
-- from a type with JSON instances. The JSON parser used will accept JSON
-- values other that object and arrays. So, if your instance serializes the
-- data to a JSON string, this will still work.
--
--
-- Example usage in combination with 'toPersistValueJSON':
--
-- @
-- instance PersistField MyData where
--   fromPersistValue = fromPersistValueJSON
--   toPersistValue = toPersistValueJSON
-- @
fromPersistValueJSON :: FromJSON a => PersistValue -> Either Text a
fromPersistValueJSON :: PersistValue -> Either Text a
fromPersistValueJSON PersistValue
z = case PersistValue
z of
  PersistByteString ByteString
bs -> (Text -> Text) -> Either Text a -> Either Text a
forall t a b. (t -> a) -> Either t b -> Either a b
mapLeft (Text -> Text -> Text
T.append Text
"Could not parse the JSON (was a PersistByteString): ")
                        (Either Text a -> Either Text a) -> Either Text a -> Either Text a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text a
forall b. FromJSON b => ByteString -> Either Text b
parseGo ByteString
bs
  PersistText Text
t -> (Text -> Text) -> Either Text a -> Either Text a
forall t a b. (t -> a) -> Either t b -> Either a b
mapLeft (Text -> Text -> Text
T.append Text
"Could not parse the JSON (was PersistText): ")
                 (Either Text a -> Either Text a) -> Either Text a -> Either Text a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either Text a
forall b. FromJSON b => ByteString -> Either Text b
parseGo (Text -> ByteString
TE.encodeUtf8 Text
t)
  PersistValue
a -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"Expected PersistByteString, received: " (String -> Text
T.pack (PersistValue -> String
forall a. Show a => a -> String
show PersistValue
a))
  where parseGo :: ByteString -> Either Text b
parseGo ByteString
bs = (String -> Text) -> Either String b -> Either Text b
forall t a b. (t -> a) -> Either t b -> Either a b
mapLeft String -> Text
T.pack (Either String b -> Either Text b)
-> Either String b -> Either Text b
forall a b. (a -> b) -> a -> b
$ case Parser Value -> ByteString -> Either String Value
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser Value
AP.value ByteString
bs of
          Left String
err -> String -> Either String b
forall a b. a -> Either a b
Left String
err
          Right Value
v -> case Value -> Result b
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
            Error String
err -> String -> Either String b
forall a b. a -> Either a b
Left String
err
            Success b
a -> b -> Either String b
forall a b. b -> Either a b
Right b
a
        mapLeft :: (t -> a) -> Either t b -> Either a b
mapLeft t -> a
_ (Right b
a) = b -> Either a b
forall a b. b -> Either a b
Right b
a
        mapLeft t -> a
f (Left t
b)  = a -> Either a b
forall a b. a -> Either a b
Left (t -> a
f t
b)

-- | Convenience function for getting a free 'PersistField' instance
-- from a type with an 'Enum' instance. The function 'derivePersistField'
-- from the persistent-template package should generally be preferred.
-- However, if you want to ensure that an @ORDER BY@ clause that uses
-- your field will order rows by the data constructor order, this is
-- a better choice.
--
-- Example usage in combination with 'fromPersistValueEnum':
--
-- @
-- data SeverityLevel = Low | Medium | Critical | High
--   deriving (Enum, Bounded)
-- instance PersistField SeverityLevel where
--   fromPersistValue = fromPersistValueEnum
--   toPersistValue = toPersistValueEnum
-- @
toPersistValueEnum :: Enum a => a -> PersistValue
toPersistValueEnum :: a -> PersistValue
toPersistValueEnum = Int -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue (Int -> PersistValue) -> (a -> Int) -> a -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum

-- | Convenience function for getting a free 'PersistField' instance
-- from a type with an 'Enum' instance. This function also requires
-- a `Bounded` instance to improve the reporting of errors.
--
-- Example usage in combination with 'toPersistValueEnum':
--
-- @
-- data SeverityLevel = Low | Medium | Critical | High
--   deriving (Enum, Bounded)
-- instance PersistField SeverityLevel where
--   fromPersistValue = fromPersistValueEnum
--   toPersistValue = toPersistValueEnum
-- @
fromPersistValueEnum :: (Enum a, Bounded a) => PersistValue -> Either Text a
fromPersistValueEnum :: PersistValue -> Either Text a
fromPersistValueEnum PersistValue
v = PersistValue -> Either Text Int
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v Either Text Int -> (Int -> Either Text a) -> Either Text a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Either Text a
forall b. (Enum b, Bounded b) => Int -> Either Text b
go
  where go :: Int -> Either Text b
go Int
i = let res :: b
res = Int -> b
forall a. Enum a => Int -> a
toEnum Int
i in
               if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= b -> Int
forall a. Enum a => a -> Int
fromEnum (b -> b -> b
forall a. a -> a -> a
asTypeOf b
forall a. Bounded a => a
minBound b
res) Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= b -> Int
forall a. Enum a => a -> Int
fromEnum (b -> b -> b
forall a. a -> a -> a
asTypeOf b
forall a. Bounded a => a
maxBound b
res)
                 then b -> Either Text b
forall a b. b -> Either a b
Right b
res
                 else Text -> Either Text b
forall a b. a -> Either a b
Left (Text
"The number " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
i) Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
" was out of the "
                  Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
"allowed bounds for an enum type")

-- | This type class is used with the @OverloadedLabels@ extension to
-- provide a more convenient means of using the 'EntityField' type.
-- 'EntityField' definitions are prefixed with the type name to avoid
-- ambiguity, but this ambiguity can result in verbose code.
--
-- If you have a table @User@ with a @name Text@ field, then the
-- corresponding 'EntityField' is @UserName@. With this, we can write
-- @#name :: 'EntityField' User Text@.
--
-- What's more fun is that the type is more general: it's actually
-- @
-- #name
--     :: ('SymbolToField' "name" rec typ)
--     => EntityField rec typ
-- @
--
-- Which means it is *polymorphic* over the actual record. This allows you
-- to write code that can be generic over the tables, provided they have
-- the right fields.
--
-- @since 2.11.0.0
class SymbolToField (sym :: Symbol) rec typ | sym rec -> typ where
    symbolToField :: EntityField rec typ

-- | This instance delegates to 'SymbolToField' to provide
-- @OverloadedLabels@ support to the 'EntityField' type.
--
-- @since 2.11.0.0
instance SymbolToField sym rec typ => IsLabel sym (EntityField rec typ) where
    fromLabel :: EntityField rec typ
fromLabel = forall rec typ. SymbolToField sym rec typ => EntityField rec typ
forall (sym :: Symbol) rec typ.
SymbolToField sym rec typ =>
EntityField rec typ
symbolToField @sym