{-# LANGUAGE AllowAmbiguousTypes #-}

module Database.GP.TypeInfo
  ( TypeInfo,
    fieldNames,
    fieldTypes,
    constructorName,
    typeInfo,
    HasConstructor (..),
    HasSelectors (..),
  )
where

import           Data.Kind       (Type)
import           GHC.Generics
import           Type.Reflection (SomeTypeRep (..), Typeable, typeRep)

-- | 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.
data TypeInfo a = TypeInfo
  { forall {k} (a :: k). TypeInfo a -> String
constructorName :: String,
    forall {k} (a :: k). TypeInfo a -> [String]
fieldNames      :: [String],
    forall {k} (a :: k). TypeInfo a -> [SomeTypeRep]
fieldTypes      :: [SomeTypeRep]
  }
  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 :: forall a. (HasConstructor (Rep a), HasSelectors (Rep a), Generic a) => TypeInfo a
typeInfo :: forall a.
(HasConstructor (Rep a), HasSelectors (Rep a), Generic a) =>
TypeInfo a
typeInfo =
  TypeInfo
    { constructorName :: String
constructorName = forall a. (HasConstructor (Rep a), Generic a) => a -> String
gConstrName a
x,
      fieldNames :: [String]
fieldNames = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall a. HasSelectors (Rep a) => a -> [(String, SomeTypeRep)]
gSelectors a
x),
      fieldTypes :: [SomeTypeRep]
fieldTypes = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall a. HasSelectors (Rep a) => a -> [(String, SomeTypeRep)]
gSelectors a
x)
    }
  where
    x :: a
x = forall a. HasCallStack => a
undefined :: a

-- Generic implementations

gConstrName :: (HasConstructor (Rep a), Generic a) => a -> String
gConstrName :: forall a. (HasConstructor (Rep a), Generic a) => a -> String
gConstrName = forall (f :: * -> *) x. HasConstructor f => f x -> String
genericConstrName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

class HasConstructor (f :: Type -> Type) where
  genericConstrName :: f x -> String

instance HasConstructor f => HasConstructor (D1 c f) where
  genericConstrName :: forall x. D1 c f x -> String
genericConstrName (M1 f x
x) = forall (f :: * -> *) x. HasConstructor f => f x -> String
genericConstrName f x
x

instance (HasConstructor x, HasConstructor y) => HasConstructor (x :+: y) where
  genericConstrName :: forall x. (:+:) x y x -> String
genericConstrName (L1 x x
l) = forall (f :: * -> *) x. HasConstructor f => f x -> String
genericConstrName x x
l
  genericConstrName (R1 y x
r) = forall (f :: * -> *) x. HasConstructor f => f x -> String
genericConstrName y x
r

instance Constructor c => HasConstructor (C1 c f) where
  genericConstrName :: forall x. C1 c f x -> String
genericConstrName = forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName

-- field names & types

gSelectors :: forall a. (HasSelectors (Rep a)) => a -> [(String, SomeTypeRep)]
gSelectors :: forall a. HasSelectors (Rep a) => a -> [(String, SomeTypeRep)]
gSelectors a
_x = forall {k} (rep :: k). HasSelectors rep => [(String, SomeTypeRep)]
selectors @(Rep a)

class HasSelectors rep where
  selectors :: [(String, SomeTypeRep)]

instance HasSelectors f => HasSelectors (M1 D x f) where
  selectors :: [(String, SomeTypeRep)]
selectors = forall {k} (rep :: k). HasSelectors rep => [(String, SomeTypeRep)]
selectors @f

instance HasSelectors f => HasSelectors (M1 C x f) where
  selectors :: [(String, SomeTypeRep)]
selectors = forall {k} (rep :: k). HasSelectors rep => [(String, SomeTypeRep)]
selectors @f

instance (Selector s, Typeable t) => HasSelectors (M1 S s (K1 R t)) where
  selectors :: [(String, SomeTypeRep)]
selectors =
    [(forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall a. HasCallStack => a
undefined :: M1 S s (K1 R t) ()), forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (forall {k} (a :: k). Typeable a => TypeRep a
typeRep @t))]

instance (HasSelectors a, HasSelectors b) => HasSelectors (a :*: b) where
  selectors :: [(String, SomeTypeRep)]
selectors = forall {k} (rep :: k). HasSelectors rep => [(String, SomeTypeRep)]
selectors @a forall a. [a] -> [a] -> [a]
++ forall {k} (rep :: k). HasSelectors rep => [(String, SomeTypeRep)]
selectors @b

instance HasSelectors U1 where
  selectors :: [(String, SomeTypeRep)]
selectors = []