-- | This module defines the type class 'Record' which enables much of the
-- functionality of the library. You can define instances of this record
-- manually, or you may use the @TemplateHaskell@ deriving function in
-- "Prairie.TH".
--
-- We'll use an example type @User@ throughout the documentation in this
-- module.
--
-- @
-- data User = User
--  { name :: String
--  , age :: Int
--  }
-- @
--
-- @since 0.0.1.0
module Prairie.Class where

import Control.Lens (Lens', set, view)
import Data.Aeson (ToJSON(..), FromJSON(..), withText)
import Data.Constraint (Dict(..))
import Data.Kind (Constraint, Type)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import Data.Typeable ((:~:)(..), Typeable, eqT)
import GHC.OverloadedLabels (IsLabel(..))
import GHC.TypeLits (Symbol)

-- | Instances of this class have a datatype 'Field' which allow you to
-- represent fields as a concrete datatype. This allows you to have
-- significant flexibility in working with data.
--
-- @since 0.0.1.0
class Record rec where
  -- | A datatype representing fields on the record.
  --
  -- This will be a @GADT@ with one constructor for each record field. By
  -- convention, it's best to name the constructors as with the type name
  -- leading and the field name following. This convention prevents any
  -- possible conflicts from different instances of 'Field'.
  --
  -- Using our example type @User@, we would define this as:
  --
  -- @
  -- data Field User ty where
  --   UserName :: Field User String
  --   UserAge :: Field User Int
  -- @
  --
  -- Now, we have a value @UserName@ that corresponds with the @name@ field
  -- on a @User@. The type of @User@ and @name@ are interesting to compare:
  --
  -- @
  -- UserName :: Field User    String
  -- name     ::       User -> String
  -- @
  --
  -- @since 0.0.1.0
  data Field rec :: Type -> Type

  -- | Given a 'Field' on the record, this function acts as a 'Lens'' into
  -- the record. This allows you to use a 'Field' as a getter or setter.
  --
  -- An example implementation for our 'User' type might look like this:
  --
  -- @
  -- recordFieldLens field =
  --   case field of
  --     UserName ->
  --       'lens' name (\\u n -> u { name = n })
  --     UserAge ->
  --      'lens' age (\\u a -> u { age = a })
  -- @
  --
  -- If you have derived lenses (either from Template Haskell or
  -- @generic-lens@, then you can provide those directly.
  --
  -- @since 0.0.1.0
  recordFieldLens :: Field rec ty -> Lens' rec ty

  -- | An enumeration of fields on the record.
  --
  -- This value uses the 'SomeField' existential wrapper, which allows
  -- 'Field's containing different types to be in the same list.
  --
  -- Our @User@ example would have this implementation:
  --
  -- @
  -- allFields = [SomeField UserAge, SomeField UserName]
  -- @
  --
  -- @since 0.0.1.0
  allFields :: [SomeField rec]

  -- | This function allows you to construct a 'Record' by providing
  -- a value for each 'Field' on the record.
  --
  -- Our @User@ would have an implementation like this:
  --
  -- @
  -- tabulateRecord fromField =
  --   User
  --     { name = fromField UserName
  --     , age = fromField UserAge
  --     }
  -- @
  --
  -- @since 0.0.1.0
  tabulateRecord :: (forall ty. Field rec ty -> ty) -> rec

  -- | Assign a 'Text' label for a record 'Field'.
  --
  -- This allows 'Field's to be converted to 'Text', which is useful for
  -- serialization concerns. For derserializing a 'Field', consider using
  -- @'fieldMap' :: 'Map' 'Text' ('SomeField' rec)@.
  --
  -- @since 0.0.1.0
  recordFieldLabel :: Field rec ty -> Text

-- | A mapping from 'Text' record field labels to the corresponding
-- 'SomeField' for that record.
--
-- @since 0.0.1.0
fieldMap :: Record rec => Map Text (SomeField rec)
fieldMap :: Map Text (SomeField rec)
fieldMap =
  (SomeField rec -> Map Text (SomeField rec))
-> [SomeField rec] -> Map Text (SomeField rec)
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
    (\sf :: SomeField rec
sf@(SomeField Field rec a
f) -> Text -> SomeField rec -> Map Text (SomeField rec)
forall k a. k -> a -> Map k a
Map.singleton (Field rec a -> Text
forall rec ty. Record rec => Field rec ty -> Text
recordFieldLabel Field rec a
f) SomeField rec
sf)
    [SomeField rec]
forall rec. Record rec => [SomeField rec]
allFields

-- | Use a 'Field' to access the corresponding value in the record.
--
-- @since 0.0.1.0
getRecordField :: Record rec => Field rec ty -> rec -> ty
getRecordField :: Field rec ty -> rec -> ty
getRecordField Field rec ty
f = Getting ty rec ty -> rec -> ty
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view (Field rec ty -> Lens' rec ty
forall rec ty. Record rec => Field rec ty -> Lens' rec ty
recordFieldLens Field rec ty
f)

-- | Use a 'Field' to set the corresponding value in the record.
--
-- @since 0.0.1.0
setRecordField :: Record rec => Field rec ty -> ty -> rec -> rec
setRecordField :: Field rec ty -> ty -> rec -> rec
setRecordField Field rec ty
f = ASetter rec rec ty ty -> ty -> rec -> rec
forall s t a b. ASetter s t a b -> b -> s -> t
set (Field rec ty -> Lens' rec ty
forall rec ty. Record rec => Field rec ty -> Lens' rec ty
recordFieldLens Field rec ty
f)

-- | An existential wrapper on a 'Field'. This hides the type of the value
-- of the field. This wrapper allows you to have a collection of 'Field's
-- for a record, or to have useful instances for classes like 'Eq' where
-- the type of the values being compared must be the same.
--
-- @since 0.0.1.0
data SomeField rec where
  SomeField :: Field rec a -> SomeField rec

-- | You can write a standalone deriving instance for 'Field':
--
-- @
-- deriving stock instance 'Show' ('Field' User a)
-- @
--
-- This instance is derived, so it'll result in:
--
-- @
-- >>> show (SomeField UserAge)
-- SomeField UserAge
-- @
--
-- @since 0.0.1.0
deriving stock instance (forall a. Show (Field rec a)) => Show (SomeField rec)

instance
  ( forall a. Eq (Field rec a)
  , FieldDict Typeable rec
  )
 =>
  Eq (SomeField rec)
 where
  SomeField (Field rec a
f0 :: Field rec a) == :: SomeField rec -> SomeField rec -> Bool
== SomeField (Field rec a
f1 :: Field rec b) =
    Field rec a -> (Typeable a => Bool) -> Bool
forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict @Typeable Field rec a
f0 ((Typeable a => Bool) -> Bool) -> (Typeable a => Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
    Field rec a -> (Typeable a => Bool) -> Bool
forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict @Typeable Field rec a
f1 ((Typeable a => Bool) -> Bool) -> (Typeable a => Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
    case (Typeable a, Typeable a) => Maybe (a :~: a)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @b of
      Just a :~: a
Refl ->
          Field rec a
f0 Field rec a -> Field rec a -> Bool
forall a. Eq a => a -> a -> Bool
== Field rec a
Field rec a
f1
      Maybe (a :~: a)
Nothing ->
        Bool
False

-- | This instance delegates to the underlying instance of 'ToJSON' for the
-- given field.
--
-- @since 0.0.1.0
instance (forall a. ToJSON (Field rec a)) => ToJSON (SomeField rec) where
  toJSON :: SomeField rec -> Value
toJSON (SomeField Field rec a
f) = Field rec a -> Value
forall a. ToJSON a => a -> Value
toJSON Field rec a
f

-- | This instance delegates to the underlying instance of 'FromJSON' for
-- the given field.
--
-- @since 0.0.1.0
instance (Record rec) => FromJSON (SomeField rec) where
  parseJSON :: Value -> Parser (SomeField rec)
parseJSON = String
-> (Text -> Parser (SomeField rec))
-> Value
-> Parser (SomeField rec)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Field" ((Text -> Parser (SomeField rec))
 -> Value -> Parser (SomeField rec))
-> (Text -> Parser (SomeField rec))
-> Value
-> Parser (SomeField rec)
forall a b. (a -> b) -> a -> b
$ \Text
txt ->
    case Text -> Map Text (SomeField rec) -> Maybe (SomeField rec)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
txt (Record rec => Map Text (SomeField rec)
forall rec. Record rec => Map Text (SomeField rec)
fieldMap @rec) of
      Just SomeField rec
field ->
        SomeField rec -> Parser (SomeField rec)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure SomeField rec
field
      Maybe (SomeField rec)
Nothing ->
        String -> Parser (SomeField rec)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Field not"

-- | This delegates to 'recordFieldLabel'  from the 'Record' class.
--
-- @since 0.0.1.0
instance Record rec => ToJSON (Field rec a) where
  toJSON :: Field rec a -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (Field rec a -> Text) -> Field rec a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field rec a -> Text
forall rec ty. Record rec => Field rec ty -> Text
recordFieldLabel

-- | This parses a 'Field' from a 'Text' given by the function
-- 'recordFieldLabel'.
--
-- @since 0.0.1.0
instance (Record rec, FieldDict Typeable rec, Typeable a) => FromJSON (Field rec a) where
  parseJSON :: Value -> Parser (Field rec a)
parseJSON = String
-> (Text -> Parser (Field rec a)) -> Value -> Parser (Field rec a)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Field" ((Text -> Parser (Field rec a)) -> Value -> Parser (Field rec a))
-> (Text -> Parser (Field rec a)) -> Value -> Parser (Field rec a)
forall a b. (a -> b) -> a -> b
$ \Text
txt ->
    case Text -> Map Text (SomeField rec) -> Maybe (SomeField rec)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
txt (Record rec => Map Text (SomeField rec)
forall rec. Record rec => Map Text (SomeField rec)
fieldMap @rec) of
      Just (SomeField (Field rec a
a :: Field rec b)) ->
        Field rec a
-> (Typeable a => Parser (Field rec a)) -> Parser (Field rec a)
forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict @Typeable Field rec a
a ((Typeable a => Parser (Field rec a)) -> Parser (Field rec a))
-> (Typeable a => Parser (Field rec a)) -> Parser (Field rec a)
forall a b. (a -> b) -> a -> b
$
        case (Typeable a, Typeable a) => Maybe (a :~: a)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @b of
          Just a :~: a
Refl ->
            Field rec a -> Parser (Field rec a)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Field rec a
a
          Maybe (a :~: a)
Nothing ->
            String -> Parser (Field rec a)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"types not same???"
      Maybe (SomeField rec)
Nothing ->
        String -> Parser (Field rec a)
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Field not"

-- | This class allows you to summon a type class instance based on a 'Field'
-- of the record. Use this type class when you need to assert that all the
-- fields of a record satisfy some type class instance.
--
-- For example, suppose we want to write a generic logging utility for all
-- records where all fields on the record is loggable.
--
-- @
-- class Loggable a where
--   toLog :: a -> LogMessage
-- @
--
-- We can implement a function based on 'Record' to log it:
--
-- @
-- logRecord :: (FieldDict Loggable rec) => rec -> LogMessage
-- logRecord record = foldMap go 'allFields'
--   where
--     go ('SomeField' field) =
--       'withFieldDict' @Loggable $
--       toLog ('getRecordField' field record)
-- @
--
-- The second parameter to 'withFieldDict' will have the instance of
-- 'Loggable a' in scope.
--
-- You can define instances polymorphic in the constraint with the
-- @ConstraintKinds@ language extension.
--
-- @since 0.0.1.0
class (Record r) => FieldDict (c :: Type -> Constraint) (r :: Type) where
  -- | Return the 'Dict' for the given field.
  --
  -- An implementation of this for the 'User' type would case on each field
  -- and return 'Dict' in each branch.
  --
  -- @
  -- getFieldDict userField =
  --   case userField of
  --    UserName -> Dict
  --    UserAge -> Dict
  -- @
  --
  -- @since 0.0.1.0
  getFieldDict :: Field r a -> Dict (c a)

-- | Given a record @field :: 'Field' rec a@, this function brings the
-- type class instance @c a@ into scope for the third argument.
--
-- This function is intended to be used with a @TypeApplication@ for the
-- constraint you want to instantiate. It is most useful for working with
-- generic records in type class instances.
--
-- @since 0.0.1.0
withFieldDict
  :: forall c rec a r
   . FieldDict c rec
  => Field rec a
  -- ^ The record field we want to unpack. We need this value in order to
  -- know what type we want the constraint to apply to.
  -> (c a => r)
  -- ^ A value that assumes the constraint @c@ holds for the type @a@.
  -> r
withFieldDict :: Field rec a -> (c a => r) -> r
withFieldDict Field rec a
l c a => r
k =
  case Field rec a -> Dict (c a)
forall (c :: Type -> Constraint) r a.
FieldDict c r =>
Field r a -> Dict (c a)
getFieldDict @c Field rec a
l of
    Dict (c a)
Dict -> r
c a => r
k

-- | This type class enables you to map a 'Symbol's to a record 'Field'.
--
-- To use this, you'll define an instance
--
-- @
-- instance 'SymbolToField' "age" User Int where
--   symbolToField = UserAge
--
-- instance 'SymbolToField' "name" User String where
--   symbolToField = UserName
-- @
--
-- The main utility here is that you can then write @OverloadedSymbols@
-- that correspond to record fields.
--
-- @
-- nameField :: ('SymbolToField'' "name" rec a) => 'Field' rec a
-- nameField = #name
--
-- userNameField :: 'Field' User String
-- userNameField = #name
-- @
--
-- Note that there's nothing forcing you to use a symbol that exactly
-- matches the type. You can write multiple instances of this for each
-- constructor. The following two instances are perfectly happy to live
-- together.
--
-- @
-- instance 'SymbolToField' "name" User String where
--   symbolToField = UserName
--
-- instance 'SymbolToField' "userName" User String where
--   symbolToField = UserName
-- @
--
-- @since 0.0.1.0
class Record rec => SymbolToField (sym :: Symbol) (rec :: Type) (a :: Type) | rec sym -> a where
  -- | This function is designed to be used with a type application:
  --
  -- @
  -- symbolToField @"age"
  -- @
  --
  -- @since 0.0.1.0
  symbolToField :: Field rec a

-- | If you've defined the relevant instances for 'SymbolToField', then you
-- can use @OverloadedLabels@ to write your labels. This can be convenient
-- if you want to avoid a lot of duplication and verbosity in the types.
--
-- Given the instances for the @User@ example type, we are able to write:
--
-- @
-- getUserName :: User -> String
-- getUserName = getRecordField #name
-- @
--
-- @since 0.0.1.0
instance (SymbolToField sym rec a) => IsLabel sym (Field rec a) where
  fromLabel :: Field rec a
fromLabel = forall rec a. SymbolToField sym rec a => Field rec a
forall (sym :: Symbol) rec a.
SymbolToField sym rec a =>
Field rec a
symbolToField @sym