--{-# LANGUAGE RankNTypes           #-}
--{-# LANGUAGE ScopedTypeVariables  #-}
module Database.GP.TypeInfo
  ( TypeInfo,
    typeConstructor,
    fieldNames,
    fieldTypes,
    typeName,
    typeInfo,
    typeInfoFromContext,
  )
where

import Data.Data

-- | A data type holding meta-data about a type. 
--   The Phantom type parameter `a` ensures type safety for reflective functions
--   that use this type to create type instances (See module RecordtypeReflection).
data TypeInfo a = TypeInfo
  { forall {k} (a :: k). TypeInfo a -> Constr
typeConstructor :: Constr,
    forall {k} (a :: k). TypeInfo a -> [String]
fieldNames      :: [String],
    forall {k} (a :: k). TypeInfo a -> [TypeRep]
fieldTypes      :: [TypeRep]
  }
  deriving (Int -> TypeInfo a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (a :: k). Int -> TypeInfo a -> ShowS
forall k (a :: k). [TypeInfo a] -> ShowS
forall k (a :: k). TypeInfo a -> String
showList :: [TypeInfo a] -> ShowS
$cshowList :: forall k (a :: k). [TypeInfo a] -> ShowS
show :: TypeInfo a -> String
$cshow :: forall k (a :: k). TypeInfo a -> String
showsPrec :: Int -> TypeInfo a -> ShowS
$cshowsPrec :: forall k (a :: k). Int -> TypeInfo a -> ShowS
Show)

-- | this function is a smart constructor for TypeInfo objects.
--   It takes a value of type `a` and returns a `TypeInfo a` object.
--   If the type has no named fields, an error is thrown.
--   If the type has more than one constructor, an error is thrown.
typeInfo :: Data a => a -> TypeInfo a
typeInfo :: forall a. Data a => a -> TypeInfo a
typeInfo a
x =
  TypeInfo
    { typeConstructor :: Constr
typeConstructor = DataType -> Constr
ensureSingleConstructor (forall a. Data a => a -> DataType
dataTypeOf a
x),
      fieldNames :: [String]
fieldNames = forall a. Data a => a -> [String]
fieldNamesOf a
x,
      fieldTypes :: [TypeRep]
fieldTypes = forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall a. Typeable a => a -> TypeRep
typeOf a
x
    }

-- | This function ensures that the type of `a` has exactly one constructor.
--   If the type has exactly one constructor, the constructor is returned.
--   otherwise, an error is thrown.
ensureSingleConstructor :: DataType -> Constr
ensureSingleConstructor :: DataType -> Constr
ensureSingleConstructor DataType
dt =
  case DataType -> [Constr]
dataTypeConstrs DataType
dt of
    [Constr
cnstr] -> Constr
cnstr
    [Constr]
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"ensureSingleConstructor: Only types with one constructor are supported (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DataType
dt forall a. [a] -> [a] -> [a]
++ String
")"

-- | This function creates a TypeInfo object from the context of a function call.
--   The Phantom Type parameter `a` is used to convince the compiler that the `TypeInfo a` object really describes type `a`.
--   See also https://stackoverflow.com/questions/75171829/how-to-obtain-a-data-data-constr-etc-from-a-type-representation
typeInfoFromContext :: forall a. Data a => TypeInfo a
typeInfoFromContext :: forall a. Data a => TypeInfo a
typeInfoFromContext =
  let dt :: DataType
dt = forall a. Data a => a -> DataType
dataTypeOf (forall a. HasCallStack => a
undefined :: a)    -- This is the trick to get the type a from the context.
      constr :: Constr
constr = DataType -> Constr
ensureSingleConstructor DataType
dt
      evidence :: a
evidence = forall a. Data a => Constr -> a
fromConstr Constr
constr :: a   -- this is evidence for the compiler that we have a value of type a
   in forall a. Data a => a -> TypeInfo a
typeInfo a
evidence

-- | This function returns the (unqualified) type name of `a` from a `TypeInfo a` object.
typeName :: TypeInfo a -> String
typeName :: forall k (a :: k). TypeInfo a -> String
typeName = DataType -> String
dataTypeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constr -> DataType
constrType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k). TypeInfo a -> Constr
typeConstructor

-- | This function returns the list of field names of an entity of type `a`.
fieldNamesOf :: (Data a) => a -> [String]
fieldNamesOf :: forall a. Data a => a -> [String]
fieldNamesOf a
x = [String]
names
  where
    constructor :: Constr
constructor = forall a. Data a => a -> Constr
toConstr a
x
    candidates :: [String]
candidates = Constr -> [String]
constrFields Constr
constructor
    constrs :: [Constr]
constrs = forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ forall a. Data a => a -> Constr
toConstr a
x
    names :: [String]
names =
      if forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
candidates forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Constr]
constrs
        then [String]
candidates
        else forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"fieldNamesOf: Type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Typeable a => a -> TypeRep
typeOf a
x) forall a. [a] -> [a] -> [a]
++ String
" does not have named fields"