{-# LANGUAGE DeriveFoldable  #-}
{-# LANGUAGE DeriveFunctor   #-}
{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds #-}

-- | Information about a field in a record
--
-- Intended for qualified import
--
-- > import Data.Record.Anon.Internal.Plugin.TC.Row.KnownField (KnownField(..))
-- > import qualified Data.Record.Anonymous.Row.Record.KnownField as KnownField
module Data.Record.Anon.Internal.Plugin.TC.Row.KnownField (
    -- * Definition
    KnownField(..)
    -- * Interop with @large-generics@
  , fromString
    -- * Code generation
  , toExpr
  , toType
  ) where

import Data.Record.Anon.Internal.Core.FieldName (FieldName(..))
import qualified Data.Record.Anon.Internal.Core.FieldName as FieldName

import Data.Record.Anon.Internal.Plugin.TC.GhcTcPluginAPI

{-------------------------------------------------------------------------------
  Definition
-------------------------------------------------------------------------------}

-- | Context-free information about a field in a record
--
-- In other words, we do /not/ know the /index/ of the field here, as that
-- depends the context (the particular record it is part of).
data KnownField a = KnownField {
      forall a. KnownField a -> FieldName
knownFieldName :: FieldName
    , forall a. KnownField a -> a
knownFieldInfo :: a
    }
  deriving ((forall a b. (a -> b) -> KnownField a -> KnownField b)
-> (forall a b. a -> KnownField b -> KnownField a)
-> Functor KnownField
forall a b. a -> KnownField b -> KnownField a
forall a b. (a -> b) -> KnownField a -> KnownField b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> KnownField a -> KnownField b
fmap :: forall a b. (a -> b) -> KnownField a -> KnownField b
$c<$ :: forall a b. a -> KnownField b -> KnownField a
<$ :: forall a b. a -> KnownField b -> KnownField a
Functor, (forall m. Monoid m => KnownField m -> m)
-> (forall m a. Monoid m => (a -> m) -> KnownField a -> m)
-> (forall m a. Monoid m => (a -> m) -> KnownField a -> m)
-> (forall a b. (a -> b -> b) -> b -> KnownField a -> b)
-> (forall a b. (a -> b -> b) -> b -> KnownField a -> b)
-> (forall b a. (b -> a -> b) -> b -> KnownField a -> b)
-> (forall b a. (b -> a -> b) -> b -> KnownField a -> b)
-> (forall a. (a -> a -> a) -> KnownField a -> a)
-> (forall a. (a -> a -> a) -> KnownField a -> a)
-> (forall a. KnownField a -> [a])
-> (forall a. KnownField a -> Bool)
-> (forall a. KnownField a -> Int)
-> (forall a. Eq a => a -> KnownField a -> Bool)
-> (forall a. Ord a => KnownField a -> a)
-> (forall a. Ord a => KnownField a -> a)
-> (forall a. Num a => KnownField a -> a)
-> (forall a. Num a => KnownField a -> a)
-> Foldable KnownField
forall a. Eq a => a -> KnownField a -> Bool
forall a. Num a => KnownField a -> a
forall a. Ord a => KnownField a -> a
forall m. Monoid m => KnownField m -> m
forall a. KnownField a -> Bool
forall a. KnownField a -> Int
forall a. KnownField a -> [a]
forall a. (a -> a -> a) -> KnownField a -> a
forall m a. Monoid m => (a -> m) -> KnownField a -> m
forall b a. (b -> a -> b) -> b -> KnownField a -> b
forall a b. (a -> b -> b) -> b -> KnownField a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => KnownField m -> m
fold :: forall m. Monoid m => KnownField m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> KnownField a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> KnownField a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> KnownField a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> KnownField a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> KnownField a -> b
foldr :: forall a b. (a -> b -> b) -> b -> KnownField a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> KnownField a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> KnownField a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> KnownField a -> b
foldl :: forall b a. (b -> a -> b) -> b -> KnownField a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> KnownField a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> KnownField a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> KnownField a -> a
foldr1 :: forall a. (a -> a -> a) -> KnownField a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> KnownField a -> a
foldl1 :: forall a. (a -> a -> a) -> KnownField a -> a
$ctoList :: forall a. KnownField a -> [a]
toList :: forall a. KnownField a -> [a]
$cnull :: forall a. KnownField a -> Bool
null :: forall a. KnownField a -> Bool
$clength :: forall a. KnownField a -> Int
length :: forall a. KnownField a -> Int
$celem :: forall a. Eq a => a -> KnownField a -> Bool
elem :: forall a. Eq a => a -> KnownField a -> Bool
$cmaximum :: forall a. Ord a => KnownField a -> a
maximum :: forall a. Ord a => KnownField a -> a
$cminimum :: forall a. Ord a => KnownField a -> a
minimum :: forall a. Ord a => KnownField a -> a
$csum :: forall a. Num a => KnownField a -> a
sum :: forall a. Num a => KnownField a -> a
$cproduct :: forall a. Num a => KnownField a -> a
product :: forall a. Num a => KnownField a -> a
Foldable)

{-------------------------------------------------------------------------------
  Interop with @large-generics@
-------------------------------------------------------------------------------}

-- | Construct 'KnownField' from just a string
--
-- NOTE: This involves a hash computation. This is unavoidable as long as
-- @large-generics@ does not precompute those.
fromString :: String -> KnownField ()
fromString :: String -> KnownField ()
fromString String
name = KnownField {
      knownFieldName :: FieldName
knownFieldName = String -> FieldName
forall a. IsString a => String -> a
FieldName.fromString String
name
    , knownFieldInfo :: ()
knownFieldInfo = ()
    }

{-------------------------------------------------------------------------------
  Code generation
-------------------------------------------------------------------------------}

-- | Name of the field as a term-level expression
toExpr :: KnownField a -> TcPluginM 'Solve CoreExpr
toExpr :: forall a. KnownField a -> TcPluginM 'Solve CoreExpr
toExpr KnownField{knownFieldName :: forall a. KnownField a -> FieldName
knownFieldName = FieldName{Int
String
fieldNameHash :: Int
fieldNameLabel :: String
fieldNameHash :: FieldName -> Int
fieldNameLabel :: FieldName -> String
..}} =
    String -> TcPluginM 'Solve CoreExpr
forall (m :: * -> *). MonadThings m => String -> m CoreExpr
mkStringExpr String
fieldNameLabel

-- | Type-level pair @'(n, a)@ or @'(n, f a)@
toType :: Maybe Type -> KnownField Type -> Type
toType :: Maybe Type -> KnownField Type -> Type
toType Maybe Type
mf KnownField{knownFieldName :: forall a. KnownField a -> FieldName
knownFieldName = FieldName{Int
String
fieldNameHash :: FieldName -> Int
fieldNameLabel :: FieldName -> String
fieldNameHash :: Int
fieldNameLabel :: String
..}, Type
knownFieldInfo :: forall a. KnownField a -> a
knownFieldInfo :: Type
knownFieldInfo} =
    -- mkPromotedPairTy is only introduced in ghc 9.2
    TyCon -> [Type] -> Type
mkTyConApp
      (Boxity -> Int -> TyCon
promotedTupleDataCon Boxity
Boxed Int
2)
      [ TyCon -> Type
mkTyConTy TyCon
typeSymbolKindCon -- kind of first arg
      , Type
liftedTypeKind              -- kind of second arg
      , FastString -> Type
mkStrLitTy (String -> FastString
fsLit String
fieldNameLabel)
      , case Maybe Type
mf of
          Just Type
f  -> Type
f Type -> Type -> Type
`mkAppTy` Type
knownFieldInfo
          Maybe Type
Nothing -> Type
knownFieldInfo
      ]

{-------------------------------------------------------------------------------
  Outputable
-------------------------------------------------------------------------------}

instance Outputable a => Outputable (KnownField a) where
  ppr :: KnownField a -> SDoc
ppr (KnownField FieldName
name a
info) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"KnownField"
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FieldName -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldName
name
      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
info