{-# LANGUAGE BangPatterns    #-}
{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections   #-}

-- | Code generation
module Data.Record.TH.CodeGen (
    largeRecord
  ) where

import Data.List (nub)
import Data.Maybe (catMaybes)
import Data.Proxy
import Data.Vector (Vector)
import GHC.Exts (Any)
import GHC.Records.Compat
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (NameSpace(..))

import qualified Data.Generics              as SYB
import qualified Data.Kind                  as Kind
import qualified Data.Vector                as V
import qualified GHC.Generics               as GHC
import qualified Language.Haskell.TH.Syntax as TH

import Data.Record.Generic
import Data.Record.Generic.Eq
import Data.Record.Generic.GHC
import Data.Record.Generic.Show

import Data.Record.Internal.CodeGen
import Data.Record.Internal.Naming
import Data.Record.Internal.Record
import Data.Record.Internal.Record.Parser
import Data.Record.Internal.Record.Resolution.Internal (putRecordInfo)
import Data.Record.Internal.TH.Util
import Data.Record.Internal.Util
import Data.Record.TH.CodeGen.Tree
import Data.Record.TH.Config.Options
import Data.Record.TH.Runtime

import qualified Data.Record.Generic.Rep.Internal as Rep
import qualified Data.Record.Internal.TH.Name as N

{-------------------------------------------------------------------------------
  Public API
-------------------------------------------------------------------------------}

-- | Declare a large record
--
-- Example usage:
--
-- > largeRecord defaultPureScript [d|
-- >     data R a = MkR { x :: Int, y :: [a] } deriving (Eq, Show)
-- >     data S a = S   { x :: Int, y :: [a] } deriving (Eq, Show)
-- >   |]
largeRecord :: Options -> Q [Dec] -> Q [Dec]
largeRecord :: Options -> Q [Dec] -> Q [Dec]
largeRecord Options
opts Q [Dec]
decls = do
    [Maybe (Record (), RecordInstances)]
rs <- (Dec -> Q (Maybe (Record (), RecordInstances)))
-> [Dec] -> Q [Maybe (Record (), RecordInstances)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec -> Q (Maybe (Record (), RecordInstances))
parseRecordDef ([Dec] -> Q [Maybe (Record (), RecordInstances)])
-> ([Dec] -> [Dec])
-> [Dec]
-> Q [Maybe (Record (), RecordInstances)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dec] -> [Dec]
dropUniques ([Dec] -> Q [Maybe (Record (), RecordInstances)])
-> Q [Dec] -> Q [Maybe (Record (), RecordInstances)]
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q [Dec]
decls
    ((Record (), RecordInstances) -> Q [Dec])
-> [(Record (), RecordInstances)] -> Q [Dec]
forall (m :: Type -> Type) a b.
Applicative m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM (Options -> (Record (), RecordInstances) -> Q [Dec]
genAll Options
opts) ([Maybe (Record (), RecordInstances)]
-> [(Record (), RecordInstances)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Record (), RecordInstances)]
rs)

{-------------------------------------------------------------------------------
  Top-level
-------------------------------------------------------------------------------}

-- | Generate all definitions
genAll :: Options -> (Record (), RecordInstances) -> Q [Dec]
genAll :: Options -> (Record (), RecordInstances) -> Q [Dec]
genAll opts :: Options
opts@Options{Bool
allFieldsStrict :: Options -> Bool
generateFieldAccessors :: Options -> Bool
generateHasFieldInstances :: Options -> Bool
generateConstructorFn :: Options -> Bool
generatePatternSynonym :: Options -> Bool
allFieldsStrict :: Bool
generateFieldAccessors :: Bool
generateHasFieldInstances :: Bool
generateConstructorFn :: Bool
generatePatternSynonym :: Bool
..} (Record ()
r, RecordInstances
instances) = do
    Record () -> Q ()
forall (m :: Type -> Type). Quasi m => Record () -> m ()
putRecordInfo Record ()
r
    [Q [Dec]] -> Q [Dec]
forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [
        (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Record () -> RecordInstances -> Q Dec
genNewtype Options
opts Record ()
r RecordInstances
instances
      , Options -> Record () -> Q [Dec]
genIndexedAccessor   Options
opts Record ()
r
      , Options -> Record () -> Q [Dec]
genIndexedOverwrite  Options
opts Record ()
r
      , Bool -> [Q [Dec]] -> Q [Dec]
when Bool
generateHasFieldInstances ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [
            Options -> Record () -> Q [Dec]
genHasFieldInstances Options
opts Record ()
r
          ]
        -- If we generate the pattern synonym, there is no need to generate
        -- field accessors, because GHC will generate them from the synonym
      , Bool -> [Q [Dec]] -> Q [Dec]
when (Bool
generateFieldAccessors Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
generatePatternSynonym) ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [
            Options -> Record () -> Q [Dec]
genFieldAccessors Options
opts Record ()
r
          ]
      , Bool -> [Q [Dec]] -> Q [Dec]
when Bool
generateConstructorFn [
            Options -> Record () -> Q [Dec]
genConstructorFn Options
opts Record ()
r
          ]
      , Bool -> [Q [Dec]] -> Q [Dec]
when Bool
generatePatternSynonym ([Q [Dec]] -> Q [Dec]) -> [Q [Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [
            Options -> Record () -> Q [Dec]
genRecordView Options
opts Record ()
r
          , Options -> Record () -> Q [Dec]
genPatSynonym Options
opts Record ()
r
          ]
      , Options -> Record () -> RecordInstances -> Q [Dec]
genGenericInstance Options
opts Record ()
r RecordInstances
instances
      , Options -> Record () -> Q [Dec]
genGhcGenericsInstances Options
opts Record ()
r
      ]
  where
    when :: Bool -> [Q [Dec]] -> Q [Dec]
    when :: Bool -> [Q [Dec]] -> Q [Dec]
when Bool
False [Q [Dec]]
_   = [Dec] -> Q [Dec]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
    when Bool
True  [Q [Dec]]
gen = [Q [Dec]] -> Q [Dec]
forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM [Q [Dec]]
gen

{-------------------------------------------------------------------------------
  Generation: the type itself

  NOTE: All generation exampleshask assume as example

  > data T a b = MkT {
  >       tWord  :: Word
  >     , tBool  :: Bool
  >     , tChar  :: Char
  >     , tA     :: a
  >     , tListB :: [b]
  >     }
  >   deriving (Eq, Show)
-------------------------------------------------------------------------------}

-- | Generate the newtype that will represent the record
--
-- Generates something like
--
-- > newtype T a b = TFromVector {vectorFromT :: Vector Any}
-- >   deriving anyclass C -- where applicable
genNewtype :: Options -> Record () -> RecordInstances -> Q Dec
genNewtype :: Options -> Record () -> RecordInstances -> Q Dec
genNewtype Options
_opts Record{String
[TyVarBndr]
[Field ()]
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
..} RecordInstances{[Type]
recordInstancesAnyclass :: RecordInstances -> [Type]
recordInstancesAnyclass :: [Type]
recordInstancesAnyclass} =
    CxtQ
-> Name 'TcClsName 'Dynamic
-> [TyVarBndr]
-> Maybe Type
-> ConQ
-> [DerivClauseQ]
-> Q Dec
N.newtypeD
      ([PredQ] -> CxtQ
cxt [])
      (String -> Name 'TcClsName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified String
recordType)
      [TyVarBndr]
recordTVars
      Maybe Type
forall a. Maybe a
Nothing
      (Name 'DataName 'Dynamic -> [VarBangTypeQ] -> ConQ
N.recC (String -> Name 'DataName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> String
nameRecordInternalConstr String
recordConstr)) [
           Name 'VarName 'Dynamic -> BangTypeQ -> VarBangTypeQ
N.varBangType (String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> String
nameRecordInternalField String
recordType)) (BangTypeQ -> VarBangTypeQ) -> BangTypeQ -> VarBangTypeQ
forall a b. (a -> b) -> a -> b
$
             BangQ -> PredQ -> BangTypeQ
bangType (Bang -> BangQ
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bang
DefaultBang) [t| Vector Any |]
         ])
      ((Type -> DerivClauseQ) -> [Type] -> [DerivClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> DerivClauseQ
anyclassDerivClause [Type]
recordInstancesAnyclass)
  where
    anyclassDerivClause :: Type -> DerivClauseQ
    anyclassDerivClause :: Type -> DerivClauseQ
anyclassDerivClause Type
clss = Maybe DerivStrategy -> [PredQ] -> DerivClauseQ
derivClause (DerivStrategy -> Maybe DerivStrategy
forall a. a -> Maybe a
Just DerivStrategy
AnyclassStrategy) [Type -> PredQ
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
clss]

{-------------------------------------------------------------------------------
  Generation: field accessors

  TODO: If we had support within GHC itself for accessing fields in records,
  we might be able to integrate this a lot more closely with normal GHC,
  especially when combined with the @NoFieldSelectors@ extension.

  See <https://gitlab.haskell.org/ghc/ghc/-/issues/17991>
-------------------------------------------------------------------------------}

-- | Generate the indexed field accessor
--
-- Generates something like
--
-- > unsafeGetIndexT :: forall x a b. Int -> T a b -> x
-- > unsafeGetIndexT = \ n t -> noInlineUnsafeCo (V.unsafeIndex (vectorFromT t) n)

genIndexedAccessor :: Options -> Record () -> Q [Dec]
genIndexedAccessor :: Options -> Record () -> Q [Dec]
genIndexedAccessor Options
_opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} = do
    Name
x <- String -> Q Name
newName String
"x"
    Name 'VarName 'Dynamic -> PredQ -> Q Exp -> Q [Dec]
forall (flavour :: Flavour).
Name 'VarName flavour -> PredQ -> Q Exp -> Q [Dec]
simpleFn
      (String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> String
nameRecordIndexedAccessor String
recordType))
      ([TyVarBndr] -> CxtQ -> PredQ -> PredQ
forallT
         (Name -> TyVarBndr
PlainTV Name
x TyVarBndr -> [TyVarBndr] -> [TyVarBndr]
forall a. a -> [a] -> [a]
: [TyVarBndr]
recordTVars)
         ([PredQ] -> CxtQ
cxt [])
         ([PredQ] -> PredQ -> PredQ
arrT [Name -> PredQ
conT ''Int, Qualifier -> Record () -> PredQ
forall a. Qualifier -> Record a -> PredQ
recordTypeT Qualifier
N.Unqual Record ()
r] (Name -> PredQ
varT Name
x)))
      [| \n t -> noInlineUnsafeCo $
           V.unsafeIndex ($(recordToVectorE N.Unqual r) t) n
      |]

-- | Generate index field overwrite
--
-- Generates something like
--
-- > unsafeSetIndexT :: forall x a b. Int -> T a b -> x -> T a b
-- > unsafeSetIndexT = \n t val ->
-- >     TFromVector (V.unsafeUpd (vectorFromT t) [(n, noInlineUnsafeCo val)])
--
-- If using 'allFieldsStrict', the function will be strict in @val@.
--
-- TODO: We should support per-field strictness.
genIndexedOverwrite :: Options -> Record () -> Q [Dec]
genIndexedOverwrite :: Options -> Record () -> Q [Dec]
genIndexedOverwrite Options{Bool
allFieldsStrict :: Bool
generateFieldAccessors :: Bool
generateHasFieldInstances :: Bool
generateConstructorFn :: Bool
generatePatternSynonym :: Bool
allFieldsStrict :: Options -> Bool
generateFieldAccessors :: Options -> Bool
generateHasFieldInstances :: Options -> Bool
generateConstructorFn :: Options -> Bool
generatePatternSynonym :: Options -> Bool
..} r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} = do
    Name
x <- String -> Q Name
newName String
"x"
    Name 'VarName 'Dynamic -> PredQ -> Q Exp -> Q [Dec]
forall (flavour :: Flavour).
Name 'VarName flavour -> PredQ -> Q Exp -> Q [Dec]
simpleFn
      (String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> String
nameRecordIndexedOverwrite String
recordType))
      ([TyVarBndr] -> CxtQ -> PredQ -> PredQ
forallT
        (Name -> TyVarBndr
PlainTV Name
x TyVarBndr -> [TyVarBndr] -> [TyVarBndr]
forall a. a -> [a] -> [a]
: [TyVarBndr]
recordTVars)
        ([PredQ] -> CxtQ
cxt [])
        ([PredQ] -> PredQ -> PredQ
arrT
          [Name -> PredQ
conT ''Int, Qualifier -> Record () -> PredQ
forall a. Qualifier -> Record a -> PredQ
recordTypeT Qualifier
N.Unqual Record ()
r, Name -> PredQ
varT Name
x]
          (Qualifier -> Record () -> PredQ
forall a. Qualifier -> Record a -> PredQ
recordTypeT Qualifier
N.Unqual Record ()
r))
        )
      Q Exp
body
  where
    body :: Q Exp
    body :: Q Exp
body
      | Bool
allFieldsStrict =
          [| \n t !val -> $(recordFromVectorDontForceE N.Unqual r) (
                 V.unsafeUpd ($(recordToVectorE N.Unqual r) t)
                   [(n, noInlineUnsafeCo val)]
               )
           |]
      | Bool
otherwise =
          [| \n t val -> $(recordFromVectorDontForceE N.Unqual r) (
                 V.unsafeUpd ($(recordToVectorE N.Unqual r) t)
                   [(n, noInlineUnsafeCo val)]
               )
           |]

-- | Generate field accessors for all fields
genFieldAccessors :: Options -> Record () -> Q [Dec]
genFieldAccessors :: Options -> Record () -> Q [Dec]
genFieldAccessors Options
opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} =
    (Field () -> Q [Dec]) -> [Field ()] -> Q [Dec]
forall (m :: Type -> Type) a b.
Applicative m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM (Options -> Record () -> Field () -> Q [Dec]
genFieldAccessor Options
opts Record ()
r) [Field ()]
recordFields

-- | Generate accessor for single field
--
-- Generates function such as
--
-- > tWord :: forall a b. T a b -> Word
-- > tWord = unsafeGetIndexT 0
genFieldAccessor :: Options -> Record () -> Field () -> Q [Dec]
genFieldAccessor :: Options -> Record () -> Field () -> Q [Dec]
genFieldAccessor Options
_opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} f :: Field ()
f@Field{Int
String
Type
()
fieldVal :: forall a. Field a -> a
fieldIndex :: forall a. Field a -> Int
fieldType :: forall a. Field a -> Type
fieldName :: forall a. Field a -> String
fieldVal :: ()
fieldIndex :: Int
fieldType :: Type
fieldName :: String
..} = do
    Name 'VarName 'Dynamic -> PredQ -> Q Exp -> Q [Dec]
forall (flavour :: Flavour).
Name 'VarName flavour -> PredQ -> Q Exp -> Q [Dec]
simpleFn
      (String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified String
fieldName)
      ([TyVarBndr] -> CxtQ -> PredQ -> PredQ
forallT [TyVarBndr]
recordTVars ([PredQ] -> CxtQ
cxt []) (PredQ -> PredQ) -> PredQ -> PredQ
forall a b. (a -> b) -> a -> b
$
         [PredQ] -> PredQ -> PredQ
arrT [Qualifier -> Record () -> PredQ
forall a. Qualifier -> Record a -> PredQ
recordTypeT Qualifier
N.Unqual Record ()
r] (Field () -> PredQ
forall a. Field a -> PredQ
fieldTypeT Field ()
f))
      (Qualifier -> Record () -> Field () -> Q Exp
forall a. Qualifier -> Record a -> Field a -> Q Exp
fieldUntypedAccessorE Qualifier
N.Unqual Record ()
r Field ()
f)

-- | Generate 'HasField' instances for all fields
genHasFieldInstances :: Options -> Record () -> Q [Dec]
genHasFieldInstances :: Options -> Record () -> Q [Dec]
genHasFieldInstances Options
opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} =
    (Field () -> Q Dec) -> [Field ()] -> Q [Dec]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Options -> Record () -> Field () -> Q Dec
genHasFieldInstance Options
opts Record ()
r) [Field ()]
recordFields

-- | Generate 'HasField' instance for single field
--
-- Generates something like
--
-- > instance x ~ Word => HasField "tInt" (T a b) x where
-- >   hasField = \t -> (unsafeSetIndexT 0 t, unsafeGetIndexT 0 t)
genHasFieldInstance :: Options -> Record () -> Field () -> Q Dec
genHasFieldInstance :: Options -> Record () -> Field () -> Q Dec
genHasFieldInstance Options
_opts Record ()
r f :: Field ()
f@Field{Int
String
Type
()
fieldVal :: ()
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
..} = do
    [Extension] -> Q ()
forall (m :: Type -> Type). Quasi m => [Extension] -> m ()
requiresExtensions [
        Extension
DataKinds
      , Extension
FlexibleInstances
      , Extension
MultiParamTypeClasses
      , Extension
TypeFamilies
      , Extension
UndecidableInstances
      ]
    Name
x <- String -> Q Name
newName String
"x"
    CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD
      ([PredQ] -> CxtQ
cxt [PredQ
equalityT PredQ -> PredQ -> PredQ
`appT` Name -> PredQ
varT Name
x PredQ -> PredQ -> PredQ
`appT` Field () -> PredQ
forall a. Field a -> PredQ
fieldTypeT Field ()
f])
      (PredQ -> [PredQ] -> PredQ
appsT (Name -> PredQ
conT ''HasField) [
          Field () -> PredQ
forall a. Field a -> PredQ
fieldNameT Field ()
f
        , Qualifier -> Record () -> PredQ
forall a. Qualifier -> Record a -> PredQ
recordTypeT Qualifier
N.Unqual Record ()
r
        , Name -> PredQ
varT Name
x
        ])
      [PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'hasField) (Q Exp -> BodyQ
normalB [|
          \t -> ( $(fieldUntypedOverwriteE N.Unqual r f) t
                , $(fieldUntypedAccessorE  N.Unqual r f) t
                )
        |]) []]

{-------------------------------------------------------------------------------
  Generation: constructor function
-------------------------------------------------------------------------------}

-- | Construct a value of the record
--
-- Generates something like
--
-- > \tWord' tBool' tChar' tA' tListB' -> (..) (V.fromList [
-- >   , noInlineUnsafeCo tWord'
-- >   , noInlineUnsafeCo tBool'
-- >   , noInlineUnsafeCo tChar'
-- >   , noInlineUnsafeCo tA'
-- >   , noInlineUnsafeCo tListB'
-- >   ])
--
-- where the " constructor " on the @"(..)"@ is generated by
-- 'recordFromUnforcedVectorQ', so that we correctly deal with strict/non-strict
-- fields.
--
-- However, this function is slightly more general than this, generalizing over
-- the "kind of lambda" we want to construct. We use this both in
-- 'genPatSynonym' and in 'genConstructorFn'.
genRecordVal :: Options -> Record () -> ([Q Pat] -> Q Exp -> Q a) -> Q a
genRecordVal :: Options -> Record () -> ([PatQ] -> Q Exp -> Q a) -> Q a
genRecordVal Options
opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} [PatQ] -> Q Exp -> Q a
mkFn = do
    -- The constructor arguments are locally bound, and should not have the
    -- same name as the fields themselves
    [Name 'VarName 'Unique]
vars <- (Field () -> Q (Name 'VarName 'Unique))
-> [Field ()] -> Q [Name 'VarName 'Unique]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Q (Name 'VarName 'Unique)
forall (ns :: NameSpace). String -> Q (Name ns 'Unique)
N.newName (String -> Q (Name 'VarName 'Unique))
-> (Field () -> String) -> Field () -> Q (Name 'VarName 'Unique)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field () -> String
forall a. Field a -> String
fieldName) [Field ()]
recordFields
    [PatQ] -> Q Exp -> Q a
mkFn ((Name 'VarName 'Unique -> PatQ)
-> [Name 'VarName 'Unique] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name 'VarName 'Unique -> PatQ
N.varLocalP [Name 'VarName 'Unique]
vars) [|
        $(recordFromVectorForceStrictFieldsE opts r)
        $(vectorE qNoInlineUnsafeCo vars)
      |]
  where
    qNoInlineUnsafeCo :: N.Name 'VarName 'N.Unique -> Q Exp
    qNoInlineUnsafeCo :: Name 'VarName 'Unique -> Q Exp
qNoInlineUnsafeCo Name 'VarName 'Unique
x = [| noInlineUnsafeCo $(N.varE x) |]

-- | Generate constructor function
--
-- Generates something like
--
-- > mkT :: forall a b. Word -> Bool -> Char -> a -> [b] -> T a b
-- > mkT = ..
--
-- where the body of @mkT@ is generated by 'genRecordVal'.
genConstructorFn :: Options -> Record () -> Q [Dec]
genConstructorFn :: Options -> Record () -> Q [Dec]
genConstructorFn Options
opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} = do
    Name 'VarName 'Dynamic -> PredQ -> Q Exp -> Q [Dec]
forall (flavour :: Flavour).
Name 'VarName flavour -> PredQ -> Q Exp -> Q [Dec]
simpleFn
      (String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> String
nameRecordTypedConstructorFn String
recordConstr))
      ([TyVarBndr] -> CxtQ -> PredQ -> PredQ
forallT [TyVarBndr]
recordTVars ([PredQ] -> CxtQ
cxt []) (PredQ -> PredQ) -> PredQ -> PredQ
forall a b. (a -> b) -> a -> b
$
         [PredQ] -> PredQ -> PredQ
arrT
           ((Field () -> PredQ) -> [Field ()] -> [PredQ]
forall a b. (a -> b) -> [a] -> [b]
map Field () -> PredQ
forall a. Field a -> PredQ
fieldTypeT [Field ()]
recordFields)
           (Qualifier -> Record () -> PredQ
forall a. Qualifier -> Record a -> PredQ
recordTypeT Qualifier
N.Unqual Record ()
r)
      )
      (Options -> Record () -> ([PatQ] -> Q Exp -> Q Exp) -> Q Exp
forall a. Options -> Record () -> ([PatQ] -> Q Exp -> Q a) -> Q a
genRecordVal Options
opts Record ()
r [PatQ] -> Q Exp -> Q Exp
lamE)

{-------------------------------------------------------------------------------
  Generation: type-level metadata
-------------------------------------------------------------------------------}

-- | Generate type-level metadata
--
-- Generates something like
--
-- > type MetadataOf (T a b) = '[
-- >     '("tInt", Word),
-- >   , '("tBool", Bool),
-- >   , '("tChar", Char),
-- >   , '("tA", a),
-- >   , '("tListB", [b])
-- >   ]
--
-- NOTE: We do not use type-level lists in most places, since it's difficult
-- to avoid quadratic core code size when working with type-level list. We use
-- this meta-data currently for two purposes only:
--
-- * The 'lr' quasi-quoter uses it as a way to lookup the record definition.
--   See "Data.Record.Internal.RecordInfo.Resolution.GHC".
-- * We use it to put a constraint on 'normalize'; this constraint is carefully
--   defined to avoid quadratic core code size.
--   See "Data.Record.Generic.Transform".
genInstanceMetadataOf :: Options -> Record () -> Q Dec
genInstanceMetadataOf :: Options -> Record () -> Q Dec
genInstanceMetadataOf Options
_opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} = TySynEqnQ -> Q Dec
tySynInstD (TySynEqnQ -> Q Dec) -> TySynEqnQ -> Q Dec
forall a b. (a -> b) -> a -> b
$
    Maybe [TyVarBndr] -> PredQ -> PredQ -> TySynEqnQ
tySynEqn
      Maybe [TyVarBndr]
forall a. Maybe a
Nothing
      [t| MetadataOf $(recordTypeT N.Unqual r) |]
      ([PredQ] -> PredQ
plistT ([PredQ] -> PredQ) -> [PredQ] -> PredQ
forall a b. (a -> b) -> a -> b
$ (Field () -> PredQ) -> [Field ()] -> [PredQ]
forall a b. (a -> b) -> [a] -> [b]
map Field () -> PredQ
fieldMetadata [Field ()]
recordFields)
  where
    fieldMetadata :: Field () -> Q Type
    fieldMetadata :: Field () -> PredQ
fieldMetadata Field ()
f = [PredQ] -> PredQ
ptupleT [Field () -> PredQ
forall a. Field a -> PredQ
fieldNameT Field ()
f, Field () -> PredQ
forall a. Field a -> PredQ
fieldTypeT Field ()
f]

{-------------------------------------------------------------------------------
  Generation: pattern synonym
-------------------------------------------------------------------------------}

-- | Generate view on the record
--
-- Generates function such as
--
-- > tupleFromT :: forall a b. T a b -> (Word, Bool, Char, a, [b])
-- > tupleFromT = \x -> (
-- >       unsafeGetIndexT 0 x
-- >     , unsafeGetIndexT 1 x
-- >     , unsafeGetIndexT 2 x
-- >     , unsafeGetIndexT 3 x
-- >     , unsafeGetIndexT 4 x
-- >     )
--
-- Modulo tuple nesting (see 'nest').
genRecordView :: Options -> Record () -> Q [Dec]
genRecordView :: Options -> Record () -> Q [Dec]
genRecordView Options
_opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} = do
    Name 'VarName 'Dynamic -> PredQ -> Q Exp -> Q [Dec]
forall (flavour :: Flavour).
Name 'VarName flavour -> PredQ -> Q Exp -> Q [Dec]
simpleFn
      (String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> String
nameRecordView String
recordType))
      ([TyVarBndr] -> CxtQ -> PredQ -> PredQ
forallT [TyVarBndr]
recordTVars ([PredQ] -> CxtQ
cxt []) (PredQ -> PredQ) -> PredQ -> PredQ
forall a b. (a -> b) -> a -> b
$
         [PredQ] -> PredQ -> PredQ
arrT [Qualifier -> Record () -> PredQ
forall a. Qualifier -> Record a -> PredQ
recordTypeT Qualifier
N.Unqual Record ()
r] PredQ
viewType
      )
      Q Exp
viewBody
  where
    viewType :: Q Type
    viewType :: PredQ
viewType = (Field () -> PredQ) -> Forest (Field ()) -> PredQ
forall a. (a -> PredQ) -> Forest a -> PredQ
mkTupleT Field () -> PredQ
forall a. Field a -> PredQ
fieldTypeT (Forest (Field ()) -> PredQ) -> Forest (Field ()) -> PredQ
forall a b. (a -> b) -> a -> b
$
                 TupleLimit -> [Field ()] -> Forest (Field ())
forall a. TupleLimit -> [a] -> Forest a
nest TupleLimit
DefaultGhcTupleLimit [Field ()]
recordFields

    viewBody :: Q Exp
    viewBody :: Q Exp
viewBody = do
        Name
x <- String -> Q Name
newName String
"x"
        [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
x] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Field () -> Q Exp) -> Forest (Field ()) -> Q Exp
forall a. (a -> Q Exp) -> Forest a -> Q Exp
mkTupleE (Name -> Field () -> Q Exp
viewField Name
x) (Forest (Field ()) -> Q Exp) -> Forest (Field ()) -> Q Exp
forall a b. (a -> b) -> a -> b
$
          TupleLimit -> [Field ()] -> Forest (Field ())
forall a. TupleLimit -> [a] -> Forest a
nest TupleLimit
DefaultGhcTupleLimit [Field ()]
recordFields

    -- We generate the view only if we are generating the pattern synonym,
    -- but when we do we don't generate the typed accessors, because they
    -- are instead derived from the pattern synonym by GHC. Since the synonym
    -- requires the view, we therefore use the untyped accessor here.
    viewField :: Name -> Field () -> Q Exp
    viewField :: Name -> Field () -> Q Exp
viewField Name
x Field ()
f = [| $(fieldUntypedAccessorE N.Unqual r f) $(varE x) |]

-- | Generate pattern synonym
--
-- Constructs something like this:
--
-- > pattern MkT :: forall a b. Word -> Bool -> Char -> a -> [b] -> T a b
-- > pattern MkT{tWord, tBool, tChar, tA, tListB} <-
-- >     (tupleFromT -> (tWord, tBool, tChar, tA, tListB) )
-- >   where
-- >     MkT tWord' tBool' tChar' tA' tListB' = ..
-- >
-- > {-# COMPLETE MkT #-}
--
-- modulo nesting ('nest'), where the body of 'MkT' (and its arguments) are
-- constructed by 'genRecordVal'.
genPatSynonym :: Options -> Record () -> Q [Dec]
genPatSynonym :: Options -> Record () -> Q [Dec]
genPatSynonym Options
opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} = do
    [Extension] -> Q ()
forall (m :: Type -> Type). Quasi m => [Extension] -> m ()
requiresExtensions [Extension
PatternSynonyms, Extension
ViewPatterns]
    [Q Dec] -> Q [Dec]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
        Name 'DataName 'Dynamic -> PredQ -> Q Dec
N.patSynSigD (String -> Name 'DataName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified String
recordConstr) (PredQ -> Q Dec) -> PredQ -> Q Dec
forall a b. (a -> b) -> a -> b
$
          [TyVarBndr] -> [PredQ] -> PredQ -> PredQ
simplePatSynType
            [TyVarBndr]
recordTVars
            ((Field () -> PredQ) -> [Field ()] -> [PredQ]
forall a b. (a -> b) -> [a] -> [b]
map Field () -> PredQ
forall a. Field a -> PredQ
fieldTypeT [Field ()]
recordFields)
            (Qualifier -> Record () -> PredQ
forall a. Qualifier -> Record a -> PredQ
recordTypeT Qualifier
N.Unqual Record ()
r)
      , Name 'DataName 'Dynamic
-> PatSynArgsQ -> PatSynDirQ -> PatQ -> Q Dec
N.patSynD (String -> Name 'DataName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified String
recordConstr)
          ([String] -> PatSynArgsQ
N.recordPatSyn ([String] -> PatSynArgsQ) -> [String] -> PatSynArgsQ
forall a b. (a -> b) -> a -> b
$ (Field () -> String) -> [Field ()] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Field () -> String
forall a. Field a -> String
fieldName [Field ()]
recordFields)
          PatSynDirQ
qDir
          PatQ
matchVector
      , [Name 'DataName 'Dynamic]
-> Maybe (Name 'TcClsName 'Dynamic) -> Q Dec
N.pragCompleteD [String -> Name 'DataName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified String
recordConstr] Maybe (Name 'TcClsName 'Dynamic)
forall a. Maybe a
Nothing
      ]
  where
    matchVector :: Q Pat
    matchVector :: PatQ
matchVector = Q Exp -> PatQ -> PatQ
viewP (Name 'VarName 'Dynamic -> Q Exp
forall (flavour :: Flavour). Name 'VarName flavour -> Q Exp
N.varE (String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> String
nameRecordView String
recordType))) (PatQ -> PatQ) -> PatQ -> PatQ
forall a b. (a -> b) -> a -> b
$
        (Field () -> PatQ) -> Forest (Field ()) -> PatQ
forall a. (a -> PatQ) -> Forest a -> PatQ
mkTupleP (Name 'VarName 'Dynamic -> PatQ
N.varGlobalP (Name 'VarName 'Dynamic -> PatQ)
-> (Field () -> Name 'VarName 'Dynamic) -> Field () -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> Name 'VarName 'Dynamic)
-> (Field () -> String) -> Field () -> Name 'VarName 'Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field () -> String
forall a. Field a -> String
fieldName) (Forest (Field ()) -> PatQ) -> Forest (Field ()) -> PatQ
forall a b. (a -> b) -> a -> b
$
          TupleLimit -> [Field ()] -> Forest (Field ())
forall a. TupleLimit -> [a] -> Forest a
nest TupleLimit
DefaultGhcTupleLimit [Field ()]
recordFields

    constrVector :: [Q Pat] -> Q Exp -> Q Clause
    constrVector :: [PatQ] -> Q Exp -> Q Clause
constrVector [PatQ]
xs Q Exp
body = [PatQ] -> BodyQ -> [Q Dec] -> Q Clause
clause [PatQ]
xs (Q Exp -> BodyQ
normalB Q Exp
body) []

    qDir :: Q PatSynDir
    qDir :: PatSynDirQ
qDir = [Q Clause] -> PatSynDirQ
explBidir ([Q Clause] -> PatSynDirQ)
-> (Q Clause -> [Q Clause]) -> Q Clause -> PatSynDirQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q Clause -> [Q Clause] -> [Q Clause]
forall a. a -> [a] -> [a]
:[]) (Q Clause -> PatSynDirQ) -> Q Clause -> PatSynDirQ
forall a b. (a -> b) -> a -> b
$ Options -> Record () -> ([PatQ] -> Q Exp -> Q Clause) -> Q Clause
forall a. Options -> Record () -> ([PatQ] -> Q Exp -> Q a) -> Q a
genRecordVal Options
opts Record ()
r [PatQ] -> Q Exp -> Q Clause
constrVector

{-------------------------------------------------------------------------------
  Generation: Generic instance
-------------------------------------------------------------------------------}

-- | Generate the class we will use to instantiate 'Constraints'
--
-- Generates something like this:
--
-- > class Constraints_T a b (c :: Type -> Constraint) where
-- >   dictConstraints_T :: Proxy c -> Rep (Dict c) (T a b)
--
-- NOTE: It is critical that we don't give the class any superclass constraints
-- like
--
-- > class (c Word, c Bool, c Char, c a, c [b])
-- >    => Constraints_T a b (c :: Type -> Constraint)
--
-- because then @ghc@ would use resolve @Constraints_T@ to that tuple instead,
-- and use lots of "tuple constraint extractor" functions, each of which have
-- the same size as the number of constraints (another example of a
-- @case f of { T x1 x2 x3 .. -> xn@ function, but now at the dictionary level).
genConstraintsClass :: Options -> Record () -> Q Dec
genConstraintsClass :: Options -> Record () -> Q Dec
genConstraintsClass Options
_opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} = do
    [Extension] -> Q ()
forall (m :: Type -> Type). Quasi m => [Extension] -> m ()
requiresExtensions [Extension
KindSignatures, Extension
ConstraintKinds]
    Name
c <- String -> Q Name
newName String
"c"
    Type
k <- [t| Kind.Type -> Kind.Constraint |]
    CxtQ
-> Name 'TcClsName 'Dynamic
-> [TyVarBndr]
-> [FunDep]
-> [Q Dec]
-> Q Dec
N.classD
      ([PredQ] -> CxtQ
cxt [])
      (String -> Name 'TcClsName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> String
nameRecordConstraintsClass String
recordType))
      ([TyVarBndr]
recordTVars [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [Name -> Type -> TyVarBndr
KindedTV Name
c Type
k])
      []
      [ Name 'VarName 'Dynamic -> PredQ -> Q Dec
N.sigD (String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> String
nameRecordConstraintsMethod String
recordType)) [t|
            Proxy $(varT c) -> Rep (Dict $(varT c)) $(recordTypeT N.Unqual r)
          |]
      ]

-- | Superclass constraints required by the constraints class instance
--
-- Generates something like
--
-- > (c Word, c Bool, c Char, c a, c [b])
--
-- However, we filter out constraints that are type variable free, so if we
-- pass, say, @Show@ for @c@, then we generate
--
-- > (Show a, Show [b])
--
-- instead. This avoids @ghc@ complaining about
--
-- > Redundant constraints: (Show Word, Show Bool, Show Char)
genRequiredConstraints :: Options -> Record () -> Q Type -> Q Cxt
genRequiredConstraints :: Options -> Record () -> PredQ -> CxtQ
genRequiredConstraints Options
_opts Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} PredQ
c = do
    [Extension] -> Q ()
forall (m :: Type -> Type). Quasi m => [Extension] -> m ()
requiresExtensions [Extension
FlexibleContexts]
    [Type]
constraints <- (Field () -> PredQ) -> [Field ()] -> CxtQ
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Field () -> PredQ
constrainField [Field ()]
recordFields
    [Type] -> CxtQ
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Type] -> CxtQ) -> [Type] -> CxtQ
forall a b. (a -> b) -> a -> b
$ [Type] -> [Type]
forall a. Eq a => [a] -> [a]
nub ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
hasTypeVar [Type]
constraints
  where
    constrainField :: Field () -> Q Pred
    constrainField :: Field () -> PredQ
constrainField Field ()
f = PredQ
c PredQ -> PredQ -> PredQ
`appT` Field () -> PredQ
forall a. Field a -> PredQ
fieldTypeT Field ()
f

    hasTypeVar :: Pred -> Bool
    hasTypeVar :: Type -> Bool
hasTypeVar = (Bool -> Bool -> Bool) -> GenericQ Bool -> GenericQ Bool
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
SYB.everything Bool -> Bool -> Bool
(||) (Bool -> (Type -> Bool) -> a -> Bool
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
SYB.mkQ Bool
False Type -> Bool
isTypeVar)

    isTypeVar :: Type -> Bool
    isTypeVar :: Type -> Bool
isTypeVar (VarT Name
_)   = Bool
True
    isTypeVar Type
_otherwise = Bool
False

-- | Generate the dictionary creation function ('dict')
--
-- Generates something like
--
-- > \p -> Rep (V.fromList [
-- >     noInlineUnsafeCo (dictFor p (Proxy :: Proxy Word))
-- >   , noInlineUnsafeCo (dictFor p (Proxy :: Proxy Bool))
-- >   , noInlineUnsafeCo (dictFor p (Proxy :: Proxy Char))
-- >   , noInlineUnsafeCo (dictFor p (Proxy :: Proxy a))
-- >   , noInlineUnsafeCo (dictFor p (Proxy :: Proxy [b]))
-- >   ])
genDict :: Options -> Record () -> Q Exp
genDict :: Options -> Record () -> Q Exp
genDict Options
_opts Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} = do
    Name
p <- String -> Q Name
newName String
"p"
    [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
p] [| Rep $(vectorE (dictForField p) recordFields) |]
  where
    dictForField :: Name -> Field () -> Q Exp
    dictForField :: Name -> Field () -> Q Exp
dictForField Name
p Field ()
f = [|
          noInlineUnsafeCo (dictFor $(varE p) (Proxy :: Proxy $(fieldTypeT f)))
        |]

-- | Generate (one and only) instance of the constraints class
--
-- Generates something like
--
-- > instance (..) => Constraints_T a b c where
-- >   dictConstraints_T = ..
--
-- where the body of @dictConstraints_T@ is generated by 'genDict'.
genConstraintsClassInstance :: Options -> Record () -> Q Dec
genConstraintsClassInstance :: Options -> Record () -> Q Dec
genConstraintsClassInstance Options
opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} = do
    [Extension] -> Q ()
forall (m :: Type -> Type). Quasi m => [Extension] -> m ()
requiresExtensions [Extension
ScopedTypeVariables]
    Name
c <- String -> Q Name
newName String
"c"
    CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD
      (Options -> Record () -> PredQ -> CxtQ
genRequiredConstraints Options
opts Record ()
r (Name -> PredQ
varT Name
c))
      (PredQ -> [PredQ] -> PredQ
appsT (Name 'TcClsName 'Dynamic -> PredQ
forall (flavour :: Flavour). Name 'TcClsName flavour -> PredQ
N.conT (String -> Name 'TcClsName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> String
nameRecordConstraintsClass String
recordType))) ([PredQ] -> PredQ) -> [PredQ] -> PredQ
forall a b. (a -> b) -> a -> b
$
         (TyVarBndr -> PredQ) -> [TyVarBndr] -> [PredQ]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> PredQ
tyVarType [TyVarBndr]
recordTVars [PredQ] -> [PredQ] -> [PredQ]
forall a. [a] -> [a] -> [a]
++ [Name -> PredQ
varT Name
c])
      [ PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name 'VarName 'Dynamic -> PatQ
N.varGlobalP (String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> String
nameRecordConstraintsMethod String
recordType)))
             (Q Exp -> BodyQ
normalB (Options -> Record () -> Q Exp
genDict Options
opts Record ()
r))
             []
      ]

-- | Generate the Constraints type family instance
--
-- Generates something like
--
-- > type Constraints (T a b) = Constraints_T a b
genInstanceConstraints :: Options -> Record () -> Q Dec
genInstanceConstraints :: Options -> Record () -> Q Dec
genInstanceConstraints Options
_opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} = TySynEqnQ -> Q Dec
tySynInstD (TySynEqnQ -> Q Dec) -> TySynEqnQ -> Q Dec
forall a b. (a -> b) -> a -> b
$
    Maybe [TyVarBndr] -> PredQ -> PredQ -> TySynEqnQ
tySynEqn
      Maybe [TyVarBndr]
forall a. Maybe a
Nothing
      [t| Constraints $(recordTypeT N.Unqual r) |]
      (PredQ -> [PredQ] -> PredQ
appsT (Name 'TcClsName 'Dynamic -> PredQ
forall (flavour :: Flavour). Name 'TcClsName flavour -> PredQ
N.conT (String -> Name 'TcClsName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> String
nameRecordConstraintsClass String
recordType))) ([PredQ] -> PredQ) -> [PredQ] -> PredQ
forall a b. (a -> b) -> a -> b
$
         (TyVarBndr -> PredQ) -> [TyVarBndr] -> [PredQ]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> PredQ
tyVarType [TyVarBndr]
recordTVars)

-- | Generate metadata
--
-- Generates something like
--
-- > \_p  -> Metadata {
-- >     recordName          = "T"
-- >   , recordConstructor   = "MkT"
-- >   , recordSize          = 5
-- >   , recordFieldMetadata = Rep $ Data.Vector.fromList [
-- >         FieldMetadata (Proxy :: Proxy "tInt"))   FieldLazy
-- >       , FieldMetadata (Proxy :: Proxy "tBool"))  FieldLazy
-- >       , FieldMetadata (Proxy :: Proxy "tChar"))  FieldLazy
-- >       , FieldMetadata (Proxy :: Proxy "tA"))     FieldLazy
-- >       , FieldMetadata (Proxy :: Proxy "tListB")) FieldLazy
-- >       ]
-- >   }
genMetadata :: Options -> Record () -> Q Exp
genMetadata :: Options -> Record () -> Q Exp
genMetadata Options{Bool
allFieldsStrict :: Bool
generateFieldAccessors :: Bool
generateHasFieldInstances :: Bool
generateConstructorFn :: Bool
generatePatternSynonym :: Bool
allFieldsStrict :: Options -> Bool
generateFieldAccessors :: Options -> Bool
generateHasFieldInstances :: Options -> Bool
generateConstructorFn :: Options -> Bool
generatePatternSynonym :: Options -> Bool
..} r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} = do
    Name
p <- String -> Q Name
newName String
"_p"
    [PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
p] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> [Q (Name, Exp)] -> Q Exp
recConE 'Metadata [
        Name -> Q Exp -> Q (Name, Exp)
fieldExp 'recordName          (Q Exp -> Q (Name, Exp)) -> Q Exp -> Q (Name, Exp)
forall a b. (a -> b) -> a -> b
$ Record () -> Q Exp
forall a. Record a -> Q Exp
recordTypeE Record ()
r
      , Name -> Q Exp -> Q (Name, Exp)
fieldExp 'recordConstructor   (Q Exp -> Q (Name, Exp)) -> Q Exp -> Q (Name, Exp)
forall a b. (a -> b) -> a -> b
$ Record () -> Q Exp
forall a. Record a -> Q Exp
recordConstrE Record ()
r
      , Name -> Q Exp -> Q (Name, Exp)
fieldExp 'recordSize          (Q Exp -> Q (Name, Exp)) -> Q Exp -> Q (Name, Exp)
forall a b. (a -> b) -> a -> b
$ Lit -> Q Exp
litE (Integer -> Lit
integerL Integer
numFields)
      , Name -> Q Exp -> Q (Name, Exp)
fieldExp 'recordFieldMetadata (Q Exp -> Q (Name, Exp)) -> Q Exp -> Q (Name, Exp)
forall a b. (a -> b) -> a -> b
$ [| Rep.Rep $ V.fromList $fieldMetadata |]
      ]
  where
    numFields :: Integer
    numFields :: Integer
numFields = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [Field ()] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Field ()]
recordFields

    fieldMetadata :: Q Exp
    fieldMetadata :: Q Exp
fieldMetadata = [Q Exp] -> Q Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Field () -> Q Exp) -> [Field ()] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Field () -> Q Exp
mkFieldMetadata [Field ()]
recordFields

    mkFieldMetadata :: Field () -> ExpQ
    mkFieldMetadata :: Field () -> Q Exp
mkFieldMetadata Field ()
f = [|
          FieldMetadata
            (Proxy :: Proxy $(fieldNameT f) )
            $(if allFieldsStrict
                then [| FieldStrict |]
                else [| FieldLazy   |])
        |]

-- | Generate instance for specific class
--
-- Generates one of the following:
--
-- * 'Show':
--
--   > instance (..) => Eq (T a b) where
--   >   (==) = geq
--
-- * 'Eq':
--
--   > instance (..) => Show (T a b) where
--   >   showsPrec = gshowsPrec
--
-- where the @(..)@ constraints are generated by 'genRequiredConstraints'
-- (i.e., a constraint for each field).
--
-- TODO: Think about DeriveFunctor?
genDeriving :: Options -> Record () -> Deriving -> Q Dec
genDeriving :: Options -> Record () -> Deriving -> Q Dec
genDeriving Options
opts Record ()
r = \case
    Deriving
DeriveEq    -> Name -> Name -> Name -> Q Dec
inst ''Eq   '(==)      'geq
    Deriving
DeriveOrd   -> Name -> Name -> Name -> Q Dec
inst ''Ord  'compare   'gcompare
    Deriving
DeriveShow  -> Name -> Name -> Name -> Q Dec
inst ''Show 'showsPrec 'gshowsPrec
  where
    inst :: Name -> Name -> Name -> Q Dec
    inst :: Name -> Name -> Name -> Q Dec
inst Name
clss Name
fn Name
gfn =
        CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD
          (Options -> Record () -> PredQ -> CxtQ
genRequiredConstraints Options
opts Record ()
r (Name -> PredQ
conT Name
clss))
          [t| $(conT clss) $(recordTypeT N.Unqual r) |]
          [PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
fn) (Q Exp -> BodyQ
normalB (Name -> Q Exp
varE Name
gfn)) []]

-- | Generate definition for `from` in the `Generic` instance
--
-- Generates something like
--
-- > repFromVectorStrict . vectorFromT
genFrom :: Options -> Record () -> Q Exp
genFrom :: Options -> Record () -> Q Exp
genFrom Options
_opts Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} = [|
         repFromVector
       . $(N.varE (N.unqualified (nameRecordInternalField recordType)))
    |]

-- | Generate definition for `to` in the `Generic` instance
--
-- > (..) . repToVector
--
-- where the @(..)@ is generated by 'recordFromVectorForceStrictFieldsE'
-- (which will any strict fields in the vector).
genTo :: Options -> Record () -> Q Exp
genTo :: Options -> Record () -> Q Exp
genTo Options
opts Record ()
r = [|
        $(recordFromVectorForceStrictFieldsE opts r)
      . repToVector
    |]

-- | Generate the definitions required to provide the instance for 'Generic'
--
-- > instance Generic T where
-- >   type Constraints T = Constraints_T
-- >   from       = coerce
-- >   to         = coerce
-- >   dict       = dictConstraints_T
-- >   metadata   = ..
genGenericInstance :: Options -> Record () -> RecordInstances -> Q [Dec]
genGenericInstance :: Options -> Record () -> RecordInstances -> Q [Dec]
genGenericInstance Options
opts r :: Record ()
r@Record{String
[TyVarBndr]
[Field ()]
recordFields :: [Field ()]
recordTVars :: [TyVarBndr]
recordConstr :: String
recordType :: String
recordFields :: forall a. Record a -> [Field a]
recordTVars :: forall a. Record a -> [TyVarBndr]
recordConstr :: forall a. Record a -> String
recordType :: forall a. Record a -> String
..} RecordInstances{[Deriving]
recordInstancesDerived :: RecordInstances -> [Deriving]
recordInstancesDerived :: [Deriving]
recordInstancesDerived} =
    [Q [Dec]] -> Q [Dec]
forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM [
         [Q Dec] -> Q [Dec]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
             Options -> Record () -> Q Dec
genConstraintsClass         Options
opts Record ()
r
           , Options -> Record () -> Q Dec
genConstraintsClassInstance Options
opts Record ()
r
           , CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD
               ([PredQ] -> CxtQ
cxt [])
               [t| Generic $(recordTypeT N.Unqual r) |]
               [ Options -> Record () -> Q Dec
genInstanceConstraints Options
opts Record ()
r
               , Options -> Record () -> Q Dec
genInstanceMetadataOf  Options
opts Record ()
r
               , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'from)     (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Options -> Record () -> Q Exp
genFrom Options
opts Record ()
r)                                                      []
               , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'to)       (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Options -> Record () -> Q Exp
genTo   Options
opts Record ()
r)                                                      []
               , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'dict)     (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name 'VarName 'Dynamic -> Q Exp
forall (flavour :: Flavour). Name 'VarName flavour -> Q Exp
N.varE (Name 'VarName 'Dynamic -> Q Exp)
-> (String -> Name 'VarName 'Dynamic) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name 'VarName 'Dynamic
forall (ns :: NameSpace). String -> Name ns 'Dynamic
N.unqualified (String -> Name 'VarName 'Dynamic)
-> (String -> String) -> String -> Name 'VarName 'Dynamic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
nameRecordConstraintsMethod (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
recordType) []
               , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'metadata) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Options -> Record () -> Q Exp
genMetadata Options
opts Record ()
r)                                                  []
               ]
           ]
      , (Deriving -> Q Dec) -> [Deriving] -> Q [Dec]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Options -> Record () -> Deriving -> Q Dec
genDeriving Options
opts Record ()
r) [Deriving]
recordInstancesDerived
      ]

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

-- | Generate GHC generics instance
--
-- Generates something like
--
-- > instance GHC.Generic ExampleRecord where
-- >   type Rep ExampleRecord = ThroughLRGenerics ExampleRecord
-- >
-- >   from = WrapThroughLRGenerics
-- >   to   = unwrapThroughLRGenerics
--
-- See 'ThroughLRGenerics' for documentation.

genGhcGenericsInstances :: Options -> Record () -> Q [Dec]
genGhcGenericsInstances :: Options -> Record () -> Q [Dec]
genGhcGenericsInstances Options
_opts Record ()
r = [Q Dec] -> Q [Dec]
forall (t :: Type -> Type) (f :: Type -> Type) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [
      CxtQ -> PredQ -> [Q Dec] -> Q Dec
instanceD
        ([PredQ] -> CxtQ
cxt [])
        [t| GHC.Generic $(recordTypeT N.Unqual r) |]
        [ TySynEqnQ -> Q Dec
tySynInstD (TySynEqnQ -> Q Dec) -> TySynEqnQ -> Q Dec
forall a b. (a -> b) -> a -> b
$
            Maybe [TyVarBndr] -> PredQ -> PredQ -> TySynEqnQ
tySynEqn
              Maybe [TyVarBndr]
forall a. Maybe a
Nothing
              [t| GHC.Rep $(recordTypeT N.Unqual r) |]
              [t| ThroughLRGenerics $(recordTypeT N.Unqual r) |]
        , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'GHC.from) (Q Exp -> BodyQ
normalB (Name -> Q Exp
conE 'WrapThroughLRGenerics))   []
        , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'GHC.to)   (Q Exp -> BodyQ
normalB (Name -> Q Exp
varE 'unwrapThroughLRGenerics)) []
        ]
    ]

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

-- | Construct record from the underlying @Vector Any@, forcing strict fields
--
-- Currently either /all/ fields are strict or /none/, so we either just force
-- all fields, or none of them.
--
-- See also 'recordFromVectorDontForceE'.
recordFromVectorForceStrictFieldsE :: Options -> Record () -> Q Exp
recordFromVectorForceStrictFieldsE :: Options -> Record () -> Q Exp
recordFromVectorForceStrictFieldsE Options{Bool
allFieldsStrict :: Bool
generateFieldAccessors :: Bool
generateHasFieldInstances :: Bool
generateConstructorFn :: Bool
generatePatternSynonym :: Bool
allFieldsStrict :: Options -> Bool
generateFieldAccessors :: Options -> Bool
generateHasFieldInstances :: Options -> Bool
generateConstructorFn :: Options -> Bool
generatePatternSynonym :: Options -> Bool
..} Record ()
r
    | Bool
allFieldsStrict = [|
          \v -> rnfVectorAny v `seq` $(recordFromVectorDontForceE N.Unqual r) v
        |]
    | Bool
otherwise =
        Qualifier -> Record () -> Q Exp
forall a. Qualifier -> Record a -> Q Exp
recordFromVectorDontForceE Qualifier
N.Unqual Record ()
r

{-------------------------------------------------------------------------------
  Fix TH naming

  TH distinguishes between global names (names from an explicit package/module),
  dynamically bound names that are resolved and bound after splicing in, and
  unique names, that are meant to be different from all other names.

  Specifically, 'mkName' is intended to create names that are meant to be
  capturable after splicing; 'mkName' generates dynamic names.

  For some strange reason however binder names of declarations in a @[d| ... |]@
  splice are given a unique name rather than a dynamic name. This is
  inconsistent, and complicates the already complicated story for correctly
  dealing with names. We therefore " fix " this here and makes those names
  dynamic.

  Since we are only interested in declaration splices containing /type/
  declarations, nothing else, it suffices to drop the uniques from type
  constructors. Type /variables/ can (and should) remain to have a unique
  flavour, as they are locally bound by the type declarations.
-------------------------------------------------------------------------------}

dropUniques :: [Dec] -> [Dec]
dropUniques :: [Dec] -> [Dec]
dropUniques = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
SYB.everywhere ((Type -> Type) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
SYB.mkT Type -> Type
dropUnique)
  where
    dropUnique :: Type -> Type
    dropUnique :: Type -> Type
dropUnique (ConT n :: Name
n@(TH.Name OccName
occ NameFlavour
flavour)) = Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$
        case NameFlavour
flavour of
          TH.NameU Integer
_ -> OccName -> NameFlavour -> Name
TH.Name OccName
occ NameFlavour
TH.NameS
          NameFlavour
_otherwise -> Name
n
    dropUnique Type
typ = Type
typ