{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
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
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)
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
]
, 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
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]
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
|]
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)]
)
|]
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
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)
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
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
)
|]) []]
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
[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) |]
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)
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]
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
viewField :: Name -> Field () -> Q Exp
viewField :: Name -> Field () -> Q Exp
viewField Name
x Field ()
f = [| $(fieldUntypedAccessorE N.Unqual r f) $(varE x) |]
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
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)
|]
]
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
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)))
|]
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))
[]
]
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)
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 |])
|]
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)) []]
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)))
|]
genTo :: Options -> Record () -> Q Exp
genTo :: Options -> Record () -> Q Exp
genTo Options
opts Record ()
r = [|
$(recordFromVectorForceStrictFieldsE opts r)
. repToVector
|]
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
]
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)) []
]
]
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
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