{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Code generation shared by TH and QQ
--
-- Since these can also be used by QQ, these functions cannot take 'Options'.
module Data.Record.Internal.CodeGen (
    -- * Records
    recordTypeE
  , recordConstrE
  , recordTypeT
  , recordToVectorE
  , recordFromVectorDontForceE
  , recordIndexedAccessorE
  , recordIndexedOverwriteE
  , recordUndefinedValueE
    -- * Fields
  , fieldNameE
  , fieldNameT
  , fieldTypeT
  , fieldIndexE
  , fieldUntypedAccessorE
  , fieldUntypedOverwriteE
  ) where

import Language.Haskell.TH

import Data.Record.Internal.Naming
import Data.Record.Internal.Record
import Data.Record.Internal.TH.Util

import qualified Data.Record.Internal.TH.Name as N hiding (unqualified)

{-------------------------------------------------------------------------------
  Records
-------------------------------------------------------------------------------}

-- | Name of the record as a term-level literal
recordTypeE :: Record a -> Q Exp
recordTypeE :: Record a -> Q Exp
recordTypeE = String -> Q Exp
stringE (String -> Q Exp) -> (Record a -> String) -> Record a -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record a -> String
forall a. Record a -> String
recordType

-- | Name of the constructor as a term-level literal
recordConstrE :: Record a -> Q Exp
recordConstrE :: Record a -> Q Exp
recordConstrE = String -> Q Exp
stringE (String -> Q Exp) -> (Record a -> String) -> Record a -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record a -> String
forall a. Record a -> String
recordConstr

-- | The saturated type of the record (that is, with all type vars applied)
recordTypeT :: N.Qualifier -> Record a -> Q Type
recordTypeT :: Qualifier -> Record a -> Q Type
recordTypeT Qualifier
qual Record{String
[TyVarBndr]
[Field a]
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordFields :: [Field a]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} =
    Q Type -> [Q Type] -> Q Type
appsT (Name 'TcClsName 'Dynamic -> Q Type
forall (flavour :: Flavour). Name 'TcClsName flavour -> Q Type
N.conT (Qualifier -> String -> Name 'TcClsName 'Dynamic
forall (ns :: NameSpace). Qualifier -> String -> Name ns 'Dynamic
N.qualify Qualifier
qual String
recordType)) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ (TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Q Type
tyVarType [TyVarBndr]
recordTVars

-- | Coerce the record to the underlying @Vector Any@
recordToVectorE :: N.Qualifier -> Record a -> Q Exp
recordToVectorE :: Qualifier -> Record a -> Q Exp
recordToVectorE Qualifier
qual =
    Name 'VarName 'Dynamic -> Q Exp
forall (flavour :: Flavour). Name 'VarName flavour -> Q Exp
N.varE (Name 'VarName 'Dynamic -> Q Exp)
-> (Record a -> Name 'VarName 'Dynamic) -> Record a -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualifier -> String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). Qualifier -> String -> Name ns 'Dynamic
N.qualify Qualifier
qual (String -> Name 'VarName 'Dynamic)
-> (Record a -> String) -> Record a -> Name 'VarName 'Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nameRecordInternalField (String -> String) -> (Record a -> String) -> Record a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record a -> String
forall a. Record a -> String
recordType

-- | Construct record from the underlying @Vector Any@
--
-- This doesn't force any elements in the vector, so this can be used if
--
-- * the record has lazy fields, or
-- * we know through other means that all values are already forced.
--
-- See also 'recordFromVectorForceE'.
recordFromVectorDontForceE :: N.Qualifier -> Record a -> Q Exp
recordFromVectorDontForceE :: Qualifier -> Record a -> Q Exp
recordFromVectorDontForceE Qualifier
qual =
    Name 'DataName 'Dynamic -> Q Exp
forall (flavour :: Flavour). Name 'DataName flavour -> Q Exp
N.conE (Name 'DataName 'Dynamic -> Q Exp)
-> (Record a -> Name 'DataName 'Dynamic) -> Record a -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualifier -> String -> Name 'DataName 'Dynamic
forall (ns :: NameSpace). Qualifier -> String -> Name ns 'Dynamic
N.qualify Qualifier
qual (String -> Name 'DataName 'Dynamic)
-> (Record a -> String) -> Record a -> Name 'DataName 'Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nameRecordInternalConstr (String -> String) -> (Record a -> String) -> Record a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record a -> String
forall a. Record a -> String
recordConstr

-- | The (unsafe) indexed field accessor
recordIndexedAccessorE :: N.Qualifier -> Record a -> Q Exp
recordIndexedAccessorE :: Qualifier -> Record a -> Q Exp
recordIndexedAccessorE Qualifier
qual =
    Name 'VarName 'Dynamic -> Q Exp
forall (flavour :: Flavour). Name 'VarName flavour -> Q Exp
N.varE (Name 'VarName 'Dynamic -> Q Exp)
-> (Record a -> Name 'VarName 'Dynamic) -> Record a -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualifier -> String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). Qualifier -> String -> Name ns 'Dynamic
N.qualify Qualifier
qual (String -> Name 'VarName 'Dynamic)
-> (Record a -> String) -> Record a -> Name 'VarName 'Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nameRecordIndexedAccessor (String -> String) -> (Record a -> String) -> Record a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record a -> String
forall a. Record a -> String
recordType

-- | The (unsafe) indexed field overwrite
recordIndexedOverwriteE :: N.Qualifier -> Record a -> Q Exp
recordIndexedOverwriteE :: Qualifier -> Record a -> Q Exp
recordIndexedOverwriteE Qualifier
qual =
    Name 'VarName 'Dynamic -> Q Exp
forall (flavour :: Flavour). Name 'VarName flavour -> Q Exp
N.varE (Name 'VarName 'Dynamic -> Q Exp)
-> (Record a -> Name 'VarName 'Dynamic) -> Record a -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Qualifier -> String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). Qualifier -> String -> Name ns 'Dynamic
N.qualify Qualifier
qual (String -> Name 'VarName 'Dynamic)
-> (Record a -> String) -> Record a -> Name 'VarName 'Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nameRecordIndexedOverwrite (String -> String) -> (Record a -> String) -> Record a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record a -> String
forall a. Record a -> String
recordType

recordUndefinedValueE :: N.Qualifier -> Record a -> Q Exp
recordUndefinedValueE :: Qualifier -> Record a -> Q Exp
recordUndefinedValueE Qualifier
qual Record a
r =
    [| $(recordFromVectorDontForceE qual r) undefined |]

{-------------------------------------------------------------------------------
  Record fields
-------------------------------------------------------------------------------}

-- | Name of the field as a term-level literal
fieldNameE :: Field a -> Q Exp
fieldNameE :: Field a -> Q Exp
fieldNameE = String -> Q Exp
stringE (String -> Q Exp) -> (Field a -> String) -> Field a -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field a -> String
forall a. Field a -> String
fieldName

-- | Name of the field as a type-level literal
fieldNameT :: Field a -> Q Type
fieldNameT :: Field a -> Q Type
fieldNameT = TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> (Field a -> TyLitQ) -> Field a -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TyLitQ
strTyLit (String -> TyLitQ) -> (Field a -> String) -> Field a -> TyLitQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field a -> String
forall a. Field a -> String
fieldName

-- | Type of the field
fieldTypeT :: Field a -> Q Type
fieldTypeT :: Field a -> Q Type
fieldTypeT Field{a
Int
String
Type
fieldVal :: forall a. Field a -> a
fieldIndex :: forall a. Field a -> Int
fieldType :: forall a. Field a -> Type
fieldVal :: a
fieldIndex :: Int
fieldType :: Type
fieldName :: String
fieldName :: forall a. Field a -> String
..} = Type -> Q Type
forall (m :: Type -> Type) a. Monad m => a -> m a
return Type
fieldType

-- | Index of the field
fieldIndexE :: Field a -> Q Exp
fieldIndexE :: Field a -> Q Exp
fieldIndexE Field{a
Int
String
Type
fieldVal :: a
fieldIndex :: Int
fieldType :: Type
fieldName :: String
fieldVal :: forall a. Field a -> a
fieldIndex :: forall a. Field a -> Int
fieldType :: forall a. Field a -> Type
fieldName :: forall a. Field a -> String
..} = Lit -> Q Exp
litE (Lit -> Q Exp) -> (Integer -> Lit) -> Integer -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
integerL (Integer -> Q Exp) -> Integer -> Q Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fieldIndex

-- | The indexed field accessor, applied to this field
fieldUntypedAccessorE :: N.Qualifier -> Record a -> Field a -> Q Exp
fieldUntypedAccessorE :: Qualifier -> Record a -> Field a -> Q Exp
fieldUntypedAccessorE Qualifier
qual Record a
r Field a
f =
    [| $(recordIndexedAccessorE qual r) $(fieldIndexE f) |]

-- | The indexed field overwrite, applied to this field
fieldUntypedOverwriteE :: N.Qualifier -> Record a -> Field a -> Q Exp
fieldUntypedOverwriteE :: Qualifier -> Record a -> Field a -> Q Exp
fieldUntypedOverwriteE Qualifier
qual Record a
r Field a
f =
    [| $(recordIndexedOverwriteE qual r) $(fieldIndexE f) |]