{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}

-- | Interop with standard GHC generics
module Data.Record.Generic.GHC (
    -- * From GHC to LR generics
    ThroughLRGenerics(..)
    -- * GHC generics metadata
  , GhcMetadata(..)
  , GhcFieldMetadata(..)
  , ghcMetadata
  ) where

import Data.Kind
import Data.Proxy
import GHC.Generics hiding (Generic(..), Rep)
import GHC.TypeLits

import Data.Record.Generic

import qualified Data.Record.Generic.Rep as Rep

{-------------------------------------------------------------------------------
  From GHC to LR generics
-------------------------------------------------------------------------------}

-- | Route from GHC generics to LR generics
--
-- Suppose a function such as
--
-- > allEqualTo :: Eq a => a -> [a] -> Bool
-- > allEqualTo x = all (== x)
--
-- is instead written as
--
-- > allEqualTo :: (GHC.Generic a, GHC.GEq' (GHC.Rep a)) => a -> [a] -> Bool
-- > allEqualTo x = all (GHC.geqdefault x)
--
-- where instead of using an indirection through an auxiliary type class `Eq`,
-- it directly assumes @GHC.Generics@ and uses a concrete generic
-- implementation. Such design is arguably questionable, but for example
-- @beam-core@ contains many such deeply ingrained assumptions of the
-- availability of @GHC.Generics@.
--
-- In order to be able to call such a function on a large record @Foo@,
-- 'largeRecord' will generate an instance
--
-- > instance GHC.Generic Foo where
-- >   type Rep Foo = ThroughLRGenerics Foo
-- >
-- >   from = WrapThroughLRGenerics
-- >   to   = unwrapThroughLRGenerics
--
-- For our running example, this instance makes it possible to call 'allEqualTo'
-- provided we then provide an instance
--
-- > instance ( LR.Generic a
-- >          , LR.Constraints a Eq
-- >          ) => GHC.GEq' (ThroughLRGenerics a) where
-- >   geq' = LR.geq `on` unwrapThroughLRGenerics
--
-- Effectively, 'ThroughLRGenerics' can be used to redirect a function that uses
-- GHC generics to a function that uses LR generics.
newtype ThroughLRGenerics a p = WrapThroughLRGenerics {
      ThroughLRGenerics a p -> a
unwrapThroughLRGenerics :: a
    }

{-------------------------------------------------------------------------------
  GHC generics metadata
-------------------------------------------------------------------------------}

-- | GHC generics metadata
--
-- TODO: Currently we provide metadata only for the record fields, not the
-- constructor or type name
data GhcMetadata a = GhcMetadata {
      GhcMetadata a -> Rep GhcFieldMetadata a
ghcMetadataFields :: Rep GhcFieldMetadata a
    }

data GhcFieldMetadata :: Type -> Type where
  GhcFieldMetadata :: forall (f :: Meta) (a :: Type).
       Selector f
    => Proxy f -> GhcFieldMetadata a

withFieldMetadata :: forall (s :: Symbol) (r :: Type).
     KnownSymbol s
  => Proxy s
  -> FieldStrictness
  -> (forall (f :: Meta). Selector f => Proxy f -> r)
  -> r
withFieldMetadata :: Proxy s
-> FieldStrictness
-> (forall (f :: Meta). Selector f => Proxy f -> r)
-> r
withFieldMetadata Proxy s
_ FieldStrictness
s forall (f :: Meta). Selector f => Proxy f -> r
k =
    case FieldStrictness
s of
      FieldStrictness
FieldLazy   -> Proxy
  ('MetaSel
     ('Just s) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
-> r
forall (f :: Meta). Selector f => Proxy f -> r
k (Proxy
  ('MetaSel
     ('Just s) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
forall k (t :: k). Proxy t
Proxy @('MetaSel ('Just s) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy))
      FieldStrictness
FieldStrict -> Proxy
  ('MetaSel
     ('Just s) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedStrict)
-> r
forall (f :: Meta). Selector f => Proxy f -> r
k (Proxy
  ('MetaSel
     ('Just s) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedStrict)
forall k (t :: k). Proxy t
Proxy @('MetaSel ('Just s) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedStrict))

ghcMetadata :: Generic a => proxy a -> GhcMetadata a
ghcMetadata :: proxy a -> GhcMetadata a
ghcMetadata proxy a
pa = GhcMetadata :: forall a. Rep GhcFieldMetadata a -> GhcMetadata a
GhcMetadata {
      ghcMetadataFields :: Rep GhcFieldMetadata a
ghcMetadataFields = (forall x. FieldMetadata x -> GhcFieldMetadata x)
-> Rep FieldMetadata a -> Rep GhcFieldMetadata a
forall a (f :: Type -> Type) (g :: Type -> Type).
Generic a =>
(forall x. f x -> g x) -> Rep f a -> Rep g a
Rep.map forall x. FieldMetadata x -> GhcFieldMetadata x
ghcFieldMetadata Rep FieldMetadata a
recordFieldMetadata
    }
  where
    Metadata{Int
String
Rep FieldMetadata a
recordFieldMetadata :: forall a. Metadata a -> Rep FieldMetadata a
recordSize :: forall a. Metadata a -> Int
recordConstructor :: forall a. Metadata a -> String
recordName :: forall a. Metadata a -> String
recordSize :: Int
recordConstructor :: String
recordName :: String
recordFieldMetadata :: Rep FieldMetadata a
..} = proxy a -> Metadata a
forall a (proxy :: Type -> Type).
Generic a =>
proxy a -> Metadata a
metadata proxy a
pa

    ghcFieldMetadata :: FieldMetadata x -> GhcFieldMetadata x
    ghcFieldMetadata :: FieldMetadata x -> GhcFieldMetadata x
ghcFieldMetadata (FieldMetadata Proxy name
pName FieldStrictness
s) =
        Proxy name
-> FieldStrictness
-> (forall (f :: Meta).
    Selector f =>
    Proxy f -> GhcFieldMetadata x)
-> GhcFieldMetadata x
forall (s :: Symbol) r.
KnownSymbol s =>
Proxy s
-> FieldStrictness
-> (forall (f :: Meta). Selector f => Proxy f -> r)
-> r
withFieldMetadata Proxy name
pName FieldStrictness
s ((forall (f :: Meta). Selector f => Proxy f -> GhcFieldMetadata x)
 -> GhcFieldMetadata x)
-> (forall (f :: Meta).
    Selector f =>
    Proxy f -> GhcFieldMetadata x)
-> GhcFieldMetadata x
forall a b. (a -> b) -> a -> b
$ forall (f :: Meta). Selector f => Proxy f -> GhcFieldMetadata x
forall (f :: Meta) a. Selector f => Proxy f -> GhcFieldMetadata a
GhcFieldMetadata