{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Record.Internal.Plugin.CodeGen (genLargeRecord) where
import Data.List (nubBy)
import Data.List.NonEmpty (NonEmpty(..))
import Language.Haskell.TH (Extension(StrictData))
import qualified Data.Generics as SYB
import Data.Record.Internal.GHC.Fresh
import Data.Record.Internal.GHC.Shim hiding (mkTyVar)
import Data.Record.Internal.GHC.TemplateHaskellStyle
import Data.Record.Internal.Plugin.Names
import Data.Record.Internal.Plugin.Record
genLargeRecord :: MonadFresh m
=> QualifiedNames
-> Record -> DynFlags -> m [LHsDecl GhcPs]
genLargeRecord :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> DynFlags -> m [LHsDecl GhcPs]
genLargeRecord QualifiedNames
names r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
..} DynFlags
dynFlags = forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM [
(forall a. a -> [a] -> [a]
:[]) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: Type -> Type).
MonadFresh m =>
Record -> m (LHsDecl GhcPs)
genDatatype Record
r
, forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m [LHsDecl GhcPs]
genVectorConversions QualifiedNames
names Record
r
, forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m [LHsDecl GhcPs]
genIndexedAccessor QualifiedNames
names Record
r
, forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m [LHsDecl GhcPs]
genUnsafeSetIndex QualifiedNames
names Record
r
, forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m [LHsDecl GhcPs]
genStockInstances QualifiedNames
names Record
r
, forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> Field -> m (LHsDecl GhcPs)
genHasFieldInstance QualifiedNames
names Record
r) [Field]
recordFields
, forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsDecl GhcPs)
genConstraintsClass QualifiedNames
names Record
r
, forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsDecl GhcPs)
genConstraintsInstance QualifiedNames
names Record
r
, forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> DynFlags -> m (LHsDecl GhcPs)
genGenericInstance QualifiedNames
names Record
r DynFlags
dynFlags
, forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsDecl GhcPs)
genGHCGeneric QualifiedNames
names Record
r
]
]
genDatatype :: MonadFresh m => Record -> m (LHsDecl GhcPs)
genDatatype :: forall (m :: Type -> Type).
MonadFresh m =>
Record -> m (LHsDecl GhcPs)
genDatatype Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
LRdrName
-> [LHsTyVarBndr GhcPs]
-> [LConDecl GhcPs]
-> [LHsDerivingClause GhcPs]
-> LHsDecl GhcPs
DataD
LRdrName
recordTyName
[LHsTyVarBndr GhcPs]
recordTyVars
[ [LRdrName]
-> [LHsType GhcPs]
-> LRdrName
-> [(LRdrName, LHsType GhcPs)]
-> LConDecl GhcPs
forallRecC
[LRdrName]
vars
(forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith LRdrName -> Field -> LHsType GhcPs
fieldContext [LRdrName]
vars [Field]
recordFields)
LRdrName
recordConName
(forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith LRdrName -> Field -> (LRdrName, LHsType GhcPs)
fieldExistentialType [LRdrName]
vars [Field]
recordFields)
]
[ Maybe (LDerivStrategy GhcPs)
-> NonEmpty (LHsType GhcPs) -> LHsDerivingClause GhcPs
DerivClause (forall a. a -> Maybe a
Just (forall a b. InheritLoc SrcSpan a b => a -> b
withoutLoc (forall a b. HasDefaultExt a => (a -> b) -> b
withDefExt forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy))) (LHsType GhcPs
c forall a. a -> [a] -> NonEmpty a
:| [])
| DeriveAnyClass LHsType GhcPs
c <- [RecordDeriving]
recordDerivings
]
where
vars :: [LRdrName]
vars :: [LRdrName]
vars = [
SrcSpan -> String -> LRdrName
mkTyVar SrcSpan
recordAnnLoc (String
"lr_f" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
i)
| (Int
i, Field
_) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] [Field]
recordFields
]
optionalBang :: HsSrcBang -> LHsType GhcPs -> LHsType GhcPs
optionalBang :: HsSrcBang -> LHsType GhcPs -> LHsType GhcPs
optionalBang HsSrcBang
bang = forall a an. a -> LocatedAn an a
noLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy forall a. HasDefaultExt a => a
defExt HsSrcBang
bang
fieldContext :: LRdrName -> Field -> LHsType GhcPs
fieldContext :: LRdrName -> Field -> LHsType GhcPs
fieldContext LRdrName
var Field
fld = LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
equalP (HasCallStack => LRdrName -> LHsType GhcPs
VarT LRdrName
var) (Field -> LHsType GhcPs
fieldType Field
fld)
fieldExistentialType :: LRdrName -> Field -> (LRdrName, LHsType GhcPs)
fieldExistentialType :: LRdrName -> Field -> (LRdrName, LHsType GhcPs)
fieldExistentialType LRdrName
var Field
fld = (Field -> LRdrName
fieldName Field
fld, HsSrcBang -> LHsType GhcPs -> LHsType GhcPs
optionalBang (Field -> HsSrcBang
fieldStrictness Field
fld) forall a b. (a -> b) -> a -> b
$ HasCallStack => LRdrName -> LHsType GhcPs
VarT LRdrName
var)
genVectorConversions :: forall m.
MonadFresh m
=> QualifiedNames -> Record -> m [LHsDecl GhcPs]
genVectorConversions :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m [LHsDecl GhcPs]
genVectorConversions QualifiedNames{LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM [
m [LHsDecl GhcPs]
fromVector
, m [LHsDecl GhcPs]
toVector
]
where
UnqualifiedNames{LRdrName
unq_showsPrec :: UnqualifiedNames -> LRdrName
unq_error :: UnqualifiedNames -> LRdrName
unq_eq :: UnqualifiedNames -> LRdrName
unq_compare :: UnqualifiedNames -> LRdrName
unq_type_Show :: UnqualifiedNames -> LRdrName
unq_type_Ord :: UnqualifiedNames -> LRdrName
unq_type_Int :: UnqualifiedNames -> LRdrName
unq_type_Eq :: UnqualifiedNames -> LRdrName
unq_showsPrec :: LRdrName
unq_error :: LRdrName
unq_eq :: LRdrName
unq_compare :: LRdrName
unq_type_Show :: LRdrName
unq_type_Ord :: LRdrName
unq_type_Int :: LRdrName
unq_type_Eq :: LRdrName
..} = UnqualifiedNames
getUnqualifiedNames
fromVector :: m [LHsDecl GhcPs]
fromVector :: m [LHsDecl GhcPs]
fromVector = do
[LRdrName]
args <- forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> LRdrName
fieldName) [Field]
recordFields
forall (m :: Type -> Type) a. Monad m => a -> m a
return [
LRdrName -> LHsType GhcPs -> LHsDecl GhcPs
sigD LRdrName
name forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
funT
(Record -> LHsType GhcPs
recordTypeT Record
r)
(HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
type_AnyArray)
, LRdrName -> LHsExpr GhcPs -> LHsDecl GhcPs
valD LRdrName
name forall a b. (a -> b) -> a -> b
$
LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> [LPat GhcPs] -> LPat GhcPs
conP LRdrName
recordConName (forall a b. (a -> b) -> [a] -> [b]
map LRdrName -> LPat GhcPs
varP [LRdrName]
args)) forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
(HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
anyArrayFromList)
([LHsExpr GhcPs] -> LHsExpr GhcPs
listE [ HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
noInlineUnsafeCo LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
arg
| LRdrName
arg <- [LRdrName]
args
]
)
]
where
name :: LRdrName
name :: LRdrName
name = Record -> LRdrName
nameVectorFrom Record
r
toVector :: m [LHsDecl GhcPs]
toVector :: m [LHsDecl GhcPs]
toVector = do
LRdrName
x <- forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"x"
[LRdrName]
args <- forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> LRdrName
fieldName) [Field]
recordFields
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [
LRdrName -> LHsType GhcPs -> LHsDecl GhcPs
sigD LRdrName
name forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
funT
(HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
type_AnyArray)
(Record -> LHsType GhcPs
recordTypeT Record
r)
, LRdrName -> LHsExpr GhcPs -> LHsDecl GhcPs
valD LRdrName
name forall a b. (a -> b) -> a -> b
$
LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> LPat GhcPs
varP LRdrName
x) forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> [(LPat GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs
caseE
(HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
anyArrayToList LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
x)
[ ( [LPat GhcPs] -> LPat GhcPs
listP (forall a b. (a -> b) -> [a] -> [b]
map LRdrName -> LPat GhcPs
varP [LRdrName]
args)
, LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE
(HasCallStack => LRdrName -> LHsExpr GhcPs
ConE LRdrName
recordConName)
[ HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
noInlineUnsafeCo LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
arg
| LRdrName
arg <- [LRdrName]
args
]
)
, ( LPat GhcPs
wildP
, HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
unq_error LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` String -> LHsExpr GhcPs
stringE String
matchErr
)
]
]
where
name :: LRdrName
name :: LRdrName
name = Record -> LRdrName
nameVectorTo Record
r
matchErr :: String
matchErr :: String
matchErr = forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [
String
"Pattern match failure in "
, LRdrName -> String
nameBase (Record -> LRdrName
nameVectorTo Record
r)
, String
": vector with invalid number of elements."
]
genIndexedAccessor ::
MonadFresh m
=> QualifiedNames
-> Record -> m [LHsDecl GhcPs]
genIndexedAccessor :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m [LHsDecl GhcPs]
genIndexedAccessor QualifiedNames{LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
LRdrName
x <- forall (m :: Type -> Type).
MonadFresh m =>
Bool -> LRdrName -> m LRdrName
freshName' Bool
False forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkTyVar SrcSpan
recordAnnLoc String
"x"
LRdrName
n <- forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"n"
LRdrName
t <- forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"t"
forall (m :: Type -> Type) a. Monad m => a -> m a
return [
LRdrName -> LHsType GhcPs -> LHsDecl GhcPs
sigD LRdrName
name forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
funT
(HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
unq_type_Int)
(Record -> LHsType GhcPs
recordTypeT Record
r LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`funT` HasCallStack => LRdrName -> LHsType GhcPs
VarT LRdrName
x)
, LRdrName -> LHsExpr GhcPs -> LHsDecl GhcPs
valD LRdrName
name forall a b. (a -> b) -> a -> b
$
NonEmpty (LPat GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE (LRdrName -> LPat GhcPs
varP LRdrName
n forall a. a -> [a] -> NonEmpty a
:| [LRdrName -> LPat GhcPs
varP LRdrName
t]) forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
(HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
noInlineUnsafeCo)
(LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE
(HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
anyArrayIndex)
[ HasCallStack => LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameVectorFrom Record
r) LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
t
, HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
n
]
)
]
where
UnqualifiedNames{LRdrName
unq_showsPrec :: LRdrName
unq_error :: LRdrName
unq_eq :: LRdrName
unq_compare :: LRdrName
unq_type_Show :: LRdrName
unq_type_Ord :: LRdrName
unq_type_Eq :: LRdrName
unq_type_Int :: LRdrName
unq_showsPrec :: UnqualifiedNames -> LRdrName
unq_error :: UnqualifiedNames -> LRdrName
unq_eq :: UnqualifiedNames -> LRdrName
unq_compare :: UnqualifiedNames -> LRdrName
unq_type_Show :: UnqualifiedNames -> LRdrName
unq_type_Ord :: UnqualifiedNames -> LRdrName
unq_type_Int :: UnqualifiedNames -> LRdrName
unq_type_Eq :: UnqualifiedNames -> LRdrName
..} = UnqualifiedNames
getUnqualifiedNames
name :: LRdrName
name :: LRdrName
name = Record -> LRdrName
nameUnsafeGetIndex Record
r
genUnsafeSetIndex ::
MonadFresh m
=> QualifiedNames
-> Record -> m [LHsDecl GhcPs]
genUnsafeSetIndex :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m [LHsDecl GhcPs]
genUnsafeSetIndex QualifiedNames{LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
LRdrName
x <- forall (m :: Type -> Type).
MonadFresh m =>
Bool -> LRdrName -> m LRdrName
freshName' Bool
False forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkTyVar SrcSpan
recordAnnLoc String
"x"
LRdrName
n <- forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"n"
LRdrName
t <- forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"t"
LRdrName
val <- forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"val"
forall (m :: Type -> Type) a. Monad m => a -> m a
return [
LRdrName -> LHsType GhcPs -> LHsDecl GhcPs
sigD LRdrName
name forall a b. (a -> b) -> a -> b
$
HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
unq_type_Int
LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`funT` (Record -> LHsType GhcPs
recordTypeT Record
r LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`funT` (HasCallStack => LRdrName -> LHsType GhcPs
VarT LRdrName
x LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`funT` Record -> LHsType GhcPs
recordTypeT Record
r))
, LRdrName -> LHsExpr GhcPs -> LHsDecl GhcPs
valD LRdrName
name forall a b. (a -> b) -> a -> b
$
NonEmpty (LPat GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE (LRdrName -> LPat GhcPs
varP LRdrName
n forall a. a -> [a] -> NonEmpty a
:| [LRdrName -> LPat GhcPs
varP LRdrName
t, (LRdrName -> LPat GhcPs
varP LRdrName
val)]) forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
(HasCallStack => LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameVectorTo Record
r))
(LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE
(HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
anyArrayUpdate)
[ HasCallStack => LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameVectorFrom Record
r) LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
t
, [LHsExpr GhcPs] -> LHsExpr GhcPs
listE [
NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs
tupE forall a b. (a -> b) -> a -> b
$
HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
n
forall a. a -> [a] -> NonEmpty a
:| [HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
noInlineUnsafeCo LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
val]
]
]
)
]
where
UnqualifiedNames{LRdrName
unq_showsPrec :: LRdrName
unq_error :: LRdrName
unq_eq :: LRdrName
unq_compare :: LRdrName
unq_type_Show :: LRdrName
unq_type_Ord :: LRdrName
unq_type_Eq :: LRdrName
unq_type_Int :: LRdrName
unq_showsPrec :: UnqualifiedNames -> LRdrName
unq_error :: UnqualifiedNames -> LRdrName
unq_eq :: UnqualifiedNames -> LRdrName
unq_compare :: UnqualifiedNames -> LRdrName
unq_type_Show :: UnqualifiedNames -> LRdrName
unq_type_Ord :: UnqualifiedNames -> LRdrName
unq_type_Int :: UnqualifiedNames -> LRdrName
unq_type_Eq :: UnqualifiedNames -> LRdrName
..} = UnqualifiedNames
getUnqualifiedNames
name :: LRdrName
name :: LRdrName
name = Record -> LRdrName
nameUnsafeSetIndex Record
r
genHasFieldInstance :: MonadFresh m
=> QualifiedNames
-> Record -> Field -> m (LHsDecl GhcPs)
genHasFieldInstance :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> Field -> m (LHsDecl GhcPs)
genHasFieldInstance QualifiedNames{LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} Field{Int
LHsType GhcPs
HsSrcBang
LRdrName
fieldIndex :: Field -> Int
fieldIndex :: Int
fieldStrictness :: HsSrcBang
fieldType :: LHsType GhcPs
fieldName :: LRdrName
fieldStrictness :: Field -> HsSrcBang
fieldName :: Field -> LRdrName
fieldType :: Field -> LHsType GhcPs
..} = do
LRdrName
x <- forall (m :: Type -> Type).
MonadFresh m =>
Bool -> LRdrName -> m LRdrName
freshName' Bool
False forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkTyVar SrcSpan
recordAnnLoc String
"x"
LRdrName
t <- forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"t"
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
[LHsType GhcPs]
-> LHsType GhcPs
-> [(LRdrName, LHsExpr GhcPs)]
-> [LTyFamInstDecl GhcPs]
-> LHsDecl GhcPs
instanceD
[LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
equalP (HasCallStack => LRdrName -> LHsType GhcPs
VarT LRdrName
x) LHsType GhcPs
fieldType]
(LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
appsT
(HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
type_HasField)
[ String -> LHsType GhcPs
stringT (LRdrName -> String
nameBase LRdrName
fieldName)
, Record -> LHsType GhcPs
recordTypeT Record
r
, HasCallStack => LRdrName -> LHsType GhcPs
VarT LRdrName
x
]
)
[ ( LRdrName
hasField
, LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> LPat GhcPs
varP LRdrName
t) forall a b. (a -> b) -> a -> b
$
NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs
tupE forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE (HasCallStack => LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameUnsafeSetIndex Record
r)) [forall a. Integral a => a -> LHsExpr GhcPs
intE Int
fieldIndex, HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
t]
forall a. a -> [a] -> NonEmpty a
:| [LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE (HasCallStack => LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameUnsafeGetIndex Record
r)) [forall a. Integral a => a -> LHsExpr GhcPs
intE Int
fieldIndex, HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
t]]
)
]
[]
genConstraintsClass ::
MonadFresh m
=> QualifiedNames -> Record -> m (LHsDecl GhcPs)
genConstraintsClass :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsDecl GhcPs)
genConstraintsClass QualifiedNames{LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
LRdrName
c <- forall (m :: Type -> Type).
MonadFresh m =>
Bool -> LRdrName -> m LRdrName
freshName' Bool
False forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkTyVar SrcSpan
recordAnnLoc String
"c"
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [LHsType GhcPs]
-> LRdrName
-> [LHsTyVarBndr GhcPs]
-> [(LRdrName, LHsType GhcPs)]
-> LHsDecl GhcPs
classD
[]
(Record -> LRdrName
nameConstraints Record
r)
([LHsTyVarBndr GhcPs]
recordTyVars forall a. [a] -> [a] -> [a]
++ [LRdrName -> LHsType GhcPs -> LHsTyVarBndr GhcPs
kindedTV LRdrName
c LHsType GhcPs
cKind])
[ ( Record -> LRdrName
nameDictConstraints Record
r
, LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
funT
(HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
type_Proxy LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` HasCallStack => LRdrName -> LHsType GhcPs
VarT LRdrName
c)
(LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
appsT
(HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
type_Rep)
[ HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
type_Dict LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` HasCallStack => LRdrName -> LHsType GhcPs
VarT LRdrName
c
, Record -> LHsType GhcPs
recordTypeT Record
r
]
)
)
]
where
cKind :: LHsType GhcPs
cKind :: LHsType GhcPs
cKind = HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
type_Type LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`funT` HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
type_Constraint
genRequiredConstraints :: Record -> LHsType GhcPs -> [LHsType GhcPs]
genRequiredConstraints :: Record -> LHsType GhcPs -> [LHsType GhcPs]
genRequiredConstraints Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} LHsType GhcPs
c =
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy LHsType GhcPs -> LHsType GhcPs -> Bool
sameType forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter LHsType GhcPs -> Bool
hasTypeVar forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Field -> LHsType GhcPs
constrainField [Field]
recordFields
where
constrainField :: Field -> LHsType GhcPs
constrainField :: Field -> LHsType GhcPs
constrainField Field{Int
LHsType GhcPs
HsSrcBang
LRdrName
fieldIndex :: Int
fieldStrictness :: HsSrcBang
fieldType :: LHsType GhcPs
fieldName :: LRdrName
fieldIndex :: Field -> Int
fieldStrictness :: Field -> HsSrcBang
fieldName :: Field -> LRdrName
fieldType :: Field -> LHsType GhcPs
..} = LHsType GhcPs
c LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` LHsType GhcPs
fieldType
sameType :: LHsType GhcPs -> LHsType GhcPs -> Bool
sameType :: LHsType GhcPs -> LHsType GhcPs -> Bool
sameType = forall a. Data a => a -> a -> Bool
compareHs
hasTypeVar :: LHsType GhcPs -> Bool
hasTypeVar :: LHsType GhcPs -> Bool
hasTypeVar = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcPs -> [String]
allTyVars
allTyVars :: LHsType GhcPs -> [String]
allTyVars :: LHsType GhcPs -> [String]
allTyVars = forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
SYB.everything forall a. [a] -> [a] -> [a]
(++) (forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
SYB.mkQ [] LHsType GhcPs -> [String]
isTypeVar)
isTypeVar :: LHsType GhcPs -> [String]
isTypeVar :: LHsType GhcPs -> [String]
isTypeVar (VarT (TyVar String
name)) = [String
name]
isTypeVar LHsType GhcPs
_otherwise = []
genDict ::
MonadFresh m
=> QualifiedNames
-> Record -> m (LHsExpr GhcPs)
genDict :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsExpr GhcPs)
genDict names :: QualifiedNames
names@QualifiedNames{LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
..} Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
LRdrName
p <- forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"p"
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> LPat GhcPs
varP LRdrName
p) forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
(HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
mkDicts)
([LHsExpr GhcPs] -> LHsExpr GhcPs
listE (forall a b. (a -> b) -> [a] -> [b]
map (LRdrName -> Field -> LHsExpr GhcPs
dictForField LRdrName
p) [Field]
recordFields))
where
dictForField :: LRdrName -> Field -> LHsExpr GhcPs
dictForField :: LRdrName -> Field -> LHsExpr GhcPs
dictForField LRdrName
p Field{Int
LHsType GhcPs
HsSrcBang
LRdrName
fieldIndex :: Int
fieldStrictness :: HsSrcBang
fieldType :: LHsType GhcPs
fieldName :: LRdrName
fieldIndex :: Field -> Int
fieldStrictness :: Field -> HsSrcBang
fieldName :: Field -> LRdrName
fieldType :: Field -> LHsType GhcPs
..} =
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
(HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
noInlineUnsafeCo)
(HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
mkDict LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
`appsE` [HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
p, QualifiedNames -> LHsType GhcPs -> LHsExpr GhcPs
proxyE QualifiedNames
names LHsType GhcPs
fieldType])
genConstraintsInstance ::
MonadFresh m
=> QualifiedNames -> Record -> m (LHsDecl GhcPs)
genConstraintsInstance :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsDecl GhcPs)
genConstraintsInstance QualifiedNames
names r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body <- forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsExpr GhcPs)
genDict QualifiedNames
names Record
r
LRdrName
c <- forall (m :: Type -> Type).
MonadFresh m =>
Bool -> LRdrName -> m LRdrName
freshName' Bool
False forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkTyVar SrcSpan
recordAnnLoc String
"c"
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
[LHsType GhcPs]
-> LHsType GhcPs
-> [(LRdrName, LHsExpr GhcPs)]
-> [LTyFamInstDecl GhcPs]
-> LHsDecl GhcPs
instanceD
(Record -> LHsType GhcPs -> [LHsType GhcPs]
genRequiredConstraints Record
r (HasCallStack => LRdrName -> LHsType GhcPs
VarT LRdrName
c))
(LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
appsT
(HasCallStack => LRdrName -> LHsType GhcPs
ConT (Record -> LRdrName
nameConstraints Record
r))
([HasCallStack => LRdrName -> LHsType GhcPs
VarT (LHsTyVarBndr GhcPs -> LRdrName
tyVarBndrName GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
v) | GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
v <- [LHsTyVarBndr GhcPs]
recordTyVars] forall a. [a] -> [a] -> [a]
++ [HasCallStack => LRdrName -> LHsType GhcPs
VarT LRdrName
c]))
[(Record -> LRdrName
nameDictConstraints Record
r, GenLocated SrcSpanAnnA (HsExpr GhcPs)
body)]
[]
genMetadata ::
MonadFresh m
=> QualifiedNames
-> Record -> DynFlags -> m (LHsExpr GhcPs)
genMetadata :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> DynFlags -> m (LHsExpr GhcPs)
genMetadata names :: QualifiedNames
names@QualifiedNames{LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} DynFlags
dynFlags = do
LRdrName
p <- forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"p"
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> LPat GhcPs
varP LRdrName
p) forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE (HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
mkMetadata) [
String -> LHsExpr GhcPs
stringE (Record -> String
nameRecord Record
r)
, String -> LHsExpr GhcPs
stringE (LRdrName -> String
nameBase LRdrName
recordConName)
, [LHsExpr GhcPs] -> LHsExpr GhcPs
listE (forall a b. (a -> b) -> [a] -> [b]
map Field -> LHsExpr GhcPs
auxField [Field]
recordFields)
]
where
auxField :: Field -> LHsExpr GhcPs
auxField :: Field -> LHsExpr GhcPs
auxField Field{Int
LHsType GhcPs
HsSrcBang
LRdrName
fieldIndex :: Int
fieldStrictness :: HsSrcBang
fieldType :: LHsType GhcPs
fieldName :: LRdrName
fieldIndex :: Field -> Int
fieldStrictness :: Field -> HsSrcBang
fieldName :: Field -> LRdrName
fieldType :: Field -> LHsType GhcPs
..} =
(LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => LRdrName -> LHsExpr GhcPs
VarE forall a b. (a -> b) -> a -> b
$ if DynFlags -> HsSrcBang -> Bool
isStrict DynFlags
dynFlags HsSrcBang
fieldStrictness
then LRdrName
mkStrictField
else LRdrName
mkLazyField)
forall a b. (a -> b) -> a -> b
$ QualifiedNames -> LHsType GhcPs -> LHsExpr GhcPs
proxyE QualifiedNames
names
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
stringT (LRdrName -> String
nameBase LRdrName
fieldName)
isStrict :: DynFlags -> HsSrcBang -> Bool
isStrict :: DynFlags -> HsSrcBang -> Bool
isStrict DynFlags
dynFlags (HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
strictness) =
case SrcStrictness
strictness of
SrcStrictness
SrcStrict -> Bool
True
SrcStrictness
SrcLazy -> Bool
False
SrcStrictness
NoSrcStrict -> if Bool
strictData then Bool
True else Bool
False
where
strictData :: Bool
strictData = Extension -> DynFlags -> Bool
xopt Extension
StrictData DynFlags
dynFlags
genFrom ::
MonadFresh m
=> QualifiedNames
-> Record -> m (LHsExpr GhcPs)
genFrom :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsExpr GhcPs)
genFrom QualifiedNames{LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
LRdrName
x <- forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"x"
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> LPat GhcPs
varP LRdrName
x) forall a b. (a -> b) -> a -> b
$
HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
anyArrayToRep LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` (HasCallStack => LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameVectorFrom Record
r) LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
x)
genTo ::
MonadFresh m
=> QualifiedNames
-> Record -> m (LHsExpr GhcPs)
genTo :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsExpr GhcPs)
genTo QualifiedNames{LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
LRdrName
x <- forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"x"
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> LPat GhcPs
varP LRdrName
x) forall a b. (a -> b) -> a -> b
$
HasCallStack => LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameVectorTo Record
r) LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` (HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
anyArrayFromRep LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
x)
genGenericInstance ::
MonadFresh m
=> QualifiedNames
-> Record -> DynFlags -> m (LHsDecl GhcPs)
genGenericInstance :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> DynFlags -> m (LHsDecl GhcPs)
genGenericInstance names :: QualifiedNames
names@QualifiedNames{LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} DynFlags
dynFlags = do
GenLocated SrcSpanAnnA (HsExpr GhcPs)
metadata <- forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> DynFlags -> m (LHsExpr GhcPs)
genMetadata QualifiedNames
names Record
r DynFlags
dynFlags
GenLocated SrcSpanAnnA (HsExpr GhcPs)
from <- forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsExpr GhcPs)
genFrom QualifiedNames
names Record
r
GenLocated SrcSpanAnnA (HsExpr GhcPs)
to <- forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsExpr GhcPs)
genTo QualifiedNames
names Record
r
forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
[LHsType GhcPs]
-> LHsType GhcPs
-> [(LRdrName, LHsExpr GhcPs)]
-> [LTyFamInstDecl GhcPs]
-> LHsDecl GhcPs
instanceD
[]
(HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
type_LR_Generic LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` Record -> LHsType GhcPs
recordTypeT Record
r)
[ ( LRdrName
lr_from , GenLocated SrcSpanAnnA (HsExpr GhcPs)
from )
, ( LRdrName
lr_to , GenLocated SrcSpanAnnA (HsExpr GhcPs)
to )
, ( LRdrName
lr_dict , HasCallStack => LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameDictConstraints Record
r) )
, ( LRdrName
lr_metadata , GenLocated SrcSpanAnnA (HsExpr GhcPs)
metadata )
]
[ LRdrName
-> [LHsType GhcPs] -> LHsType GhcPs -> LTyFamInstDecl GhcPs
tySynEqn LRdrName
type_LR_Constraints [Record -> LHsType GhcPs
recordTypeT Record
r] forall a b. (a -> b) -> a -> b
$
LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
appsT
(HasCallStack => LRdrName -> LHsType GhcPs
ConT (Record -> LRdrName
nameConstraints Record
r))
[HasCallStack => LRdrName -> LHsType GhcPs
VarT (LHsTyVarBndr GhcPs -> LRdrName
tyVarBndrName GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
v) | GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
v <- [LHsTyVarBndr GhcPs]
recordTyVars]
, LRdrName
-> [LHsType GhcPs] -> LHsType GhcPs -> LTyFamInstDecl GhcPs
tySynEqn LRdrName
type_LR_MetadataOf [Record -> LHsType GhcPs
recordTypeT Record
r] forall a b. (a -> b) -> a -> b
$
[LHsType GhcPs] -> LHsType GhcPs
listT [
NonEmpty (LHsType GhcPs) -> LHsType GhcPs
tupT forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
stringT (LRdrName -> String
nameBase LRdrName
fieldName) forall a. a -> [a] -> NonEmpty a
:| [LHsType GhcPs
fieldType]
| Field{Int
LHsType GhcPs
HsSrcBang
LRdrName
fieldIndex :: Int
fieldStrictness :: HsSrcBang
fieldType :: LHsType GhcPs
fieldName :: LRdrName
fieldIndex :: Field -> Int
fieldStrictness :: Field -> HsSrcBang
fieldName :: Field -> LRdrName
fieldType :: Field -> LHsType GhcPs
..} <- [Field]
recordFields
]
]
genStockInstances ::
MonadFresh m
=> QualifiedNames
-> Record -> m [LHsDecl GhcPs]
genStockInstances :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m [LHsDecl GhcPs]
genStockInstances QualifiedNames
names r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM [
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> StockDeriving -> m [LHsDecl GhcPs]
genStockInstance QualifiedNames
names Record
r StockDeriving
d
| DeriveStock StockDeriving
d <- [RecordDeriving]
recordDerivings
]
genStockInstance :: MonadFresh m
=> QualifiedNames
-> Record -> StockDeriving -> m [LHsDecl GhcPs]
genStockInstance :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> StockDeriving -> m [LHsDecl GhcPs]
genStockInstance QualifiedNames{LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
..} Record
r = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
StockDeriving
Show -> [LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs
mkInstance LRdrName
unq_type_Show LRdrName
unq_showsPrec LRdrName
gshowsPrec]
StockDeriving
Eq -> [LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs
mkInstance LRdrName
unq_type_Eq LRdrName
unq_eq LRdrName
geq ]
StockDeriving
Ord -> [LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs
mkInstance LRdrName
unq_type_Ord LRdrName
unq_compare LRdrName
gcompare ]
StockDeriving
Generic -> []
where
UnqualifiedNames{LRdrName
unq_error :: LRdrName
unq_type_Int :: LRdrName
unq_compare :: LRdrName
unq_type_Ord :: LRdrName
unq_eq :: LRdrName
unq_type_Eq :: LRdrName
unq_showsPrec :: LRdrName
unq_type_Show :: LRdrName
unq_showsPrec :: UnqualifiedNames -> LRdrName
unq_error :: UnqualifiedNames -> LRdrName
unq_eq :: UnqualifiedNames -> LRdrName
unq_compare :: UnqualifiedNames -> LRdrName
unq_type_Show :: UnqualifiedNames -> LRdrName
unq_type_Ord :: UnqualifiedNames -> LRdrName
unq_type_Int :: UnqualifiedNames -> LRdrName
unq_type_Eq :: UnqualifiedNames -> LRdrName
..} = UnqualifiedNames
getUnqualifiedNames
mkInstance :: LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs
mkInstance :: LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs
mkInstance LRdrName
cls LRdrName
mthd LRdrName
gen =
[LHsType GhcPs]
-> LHsType GhcPs
-> [(LRdrName, LHsExpr GhcPs)]
-> [LTyFamInstDecl GhcPs]
-> LHsDecl GhcPs
instanceD
(Record -> LHsType GhcPs -> [LHsType GhcPs]
genRequiredConstraints Record
r (HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
cls))
(HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
cls LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` Record -> LHsType GhcPs
recordTypeT Record
r)
[(LRdrName
mthd, HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
gen)]
[]
genGHCGeneric ::
MonadFresh m
=> QualifiedNames -> Record -> m (LHsDecl GhcPs)
genGHCGeneric :: forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsDecl GhcPs)
genGHCGeneric QualifiedNames{LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
..} Record
r = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
[LHsType GhcPs]
-> LHsType GhcPs
-> [(LRdrName, LHsExpr GhcPs)]
-> [LTyFamInstDecl GhcPs]
-> LHsDecl GhcPs
instanceD
[]
(HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
type_GHC_Generic LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` Record -> LHsType GhcPs
recordTypeT Record
r)
[ ( LRdrName
ghc_from , HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
wrapThroughLRGenerics )
, ( LRdrName
ghc_to , HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
unwrapThroughLRGenerics )
]
[ LRdrName
-> [LHsType GhcPs] -> LHsType GhcPs -> LTyFamInstDecl GhcPs
tySynEqn LRdrName
type_GHC_Rep [Record -> LHsType GhcPs
recordTypeT Record
r] forall a b. (a -> b) -> a -> b
$
HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
type_ThroughLRGenerics LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` Record -> LHsType GhcPs
recordTypeT Record
r
]
recordTypeT :: Record -> LHsType GhcPs
recordTypeT :: Record -> LHsType GhcPs
recordTypeT Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} =
HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
recordTyName LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
`appsT` [HasCallStack => LRdrName -> LHsType GhcPs
VarT (LHsTyVarBndr GhcPs -> LRdrName
tyVarBndrName GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
f) | GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
f <- [LHsTyVarBndr GhcPs]
recordTyVars]
nameRecord :: Record -> String
nameRecord :: Record -> String
nameRecord Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = LRdrName -> String
nameBase LRdrName
recordTyName
mkDerived :: (SrcSpan -> String -> LRdrName) -> String -> Record -> LRdrName
mkDerived :: (SrcSpan -> String -> LRdrName) -> String -> Record -> LRdrName
mkDerived SrcSpan -> String -> LRdrName
f String
prefix Record
r = SrcSpan -> String -> LRdrName
f (Record -> SrcSpan
recordAnnLoc Record
r) (String
prefix forall a. Semigroup a => a -> a -> a
<> Record -> String
nameRecord Record
r)
nameVectorFrom :: Record -> LRdrName
nameVectorTo :: Record -> LRdrName
nameUnsafeGetIndex :: Record -> LRdrName
nameUnsafeSetIndex :: Record -> LRdrName
nameConstraints :: Record -> LRdrName
nameDictConstraints :: Record -> LRdrName
nameVectorFrom :: Record -> LRdrName
nameVectorFrom = (SrcSpan -> String -> LRdrName) -> String -> Record -> LRdrName
mkDerived SrcSpan -> String -> LRdrName
mkExpVar String
"vectorFrom"
nameVectorTo :: Record -> LRdrName
nameVectorTo = (SrcSpan -> String -> LRdrName) -> String -> Record -> LRdrName
mkDerived SrcSpan -> String -> LRdrName
mkExpVar String
"vectorTo"
nameUnsafeGetIndex :: Record -> LRdrName
nameUnsafeGetIndex = (SrcSpan -> String -> LRdrName) -> String -> Record -> LRdrName
mkDerived SrcSpan -> String -> LRdrName
mkExpVar String
"unsafeGetIndex"
nameUnsafeSetIndex :: Record -> LRdrName
nameUnsafeSetIndex = (SrcSpan -> String -> LRdrName) -> String -> Record -> LRdrName
mkDerived SrcSpan -> String -> LRdrName
mkExpVar String
"unsafeSetIndex"
nameConstraints :: Record -> LRdrName
nameConstraints = (SrcSpan -> String -> LRdrName) -> String -> Record -> LRdrName
mkDerived SrcSpan -> String -> LRdrName
mkTyCon String
"Constraints_"
nameDictConstraints :: Record -> LRdrName
nameDictConstraints = (SrcSpan -> String -> LRdrName) -> String -> Record -> LRdrName
mkDerived SrcSpan -> String -> LRdrName
mkExpVar String
"dictConstraints_"
proxyE :: QualifiedNames -> LHsType GhcPs -> LHsExpr GhcPs
proxyE :: QualifiedNames -> LHsType GhcPs -> LHsExpr GhcPs
proxyE QualifiedNames{LRdrName
hasField :: LRdrName
type_HasField :: LRdrName
unwrapThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
type_ThroughLRGenerics :: LRdrName
mkMetadata :: LRdrName
mkLazyField :: LRdrName
mkStrictField :: LRdrName
mkDict :: LRdrName
mkDicts :: LRdrName
anyArrayFromRep :: LRdrName
anyArrayToRep :: LRdrName
noInlineUnsafeCo :: LRdrName
gshowsPrec :: LRdrName
geq :: LRdrName
gcompare :: LRdrName
type_Dict :: LRdrName
type_Rep :: LRdrName
lr_metadata :: LRdrName
lr_dict :: LRdrName
lr_to :: LRdrName
lr_from :: LRdrName
type_LR_Constraints :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Generic :: LRdrName
anyArrayUpdate :: LRdrName
anyArrayIndex :: LRdrName
anyArrayToList :: LRdrName
anyArrayFromList :: LRdrName
type_AnyArray :: LRdrName
ghc_to :: LRdrName
ghc_from :: LRdrName
proxy :: LRdrName
type_Type :: LRdrName
type_Proxy :: LRdrName
type_GHC_Rep :: LRdrName
type_GHC_Generic :: LRdrName
type_Constraint :: LRdrName
hasField :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
..} LHsType GhcPs
ty =
LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
sigE (HasCallStack => LRdrName -> LHsExpr GhcPs
VarE LRdrName
proxy) (HasCallStack => LRdrName -> LHsType GhcPs
ConT LRdrName
type_Proxy LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` LHsType GhcPs
ty)
concatM :: Applicative m => [m [a]] -> m [a]
concatM :: forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM = forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type) (f :: Type -> Type) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA