large-records-0.4.4: src/Data/Record/Internal/Plugin/CodeGen.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | The core of the plugin implementation.
module Data.Record.Internal.Plugin.CodeGen (genLargeRecord) where
import Prelude hiding (error)
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
import Data.Record.Internal.GHC.TemplateHaskellStyle
import Data.Record.Internal.Plugin.Names
import Data.Record.Internal.Plugin.Record
{-------------------------------------------------------------------------------
Top-level
-------------------------------------------------------------------------------}
-- | Generate all large-records definitions for a record.
genLargeRecord :: MonadFresh m
=> QualifiedNames
-> Record -> DynFlags -> m [LHsDecl GhcPs]
genLargeRecord names r@Record{..} dynFlags = concatM [
(:[]) <$> genDatatype r
, genVectorConversions names r
, genIndexedAccessor names r
, genUnsafeSetIndex names r
, genStockInstances names r
, mapM (genHasFieldInstance names r) recordFields
, mapM (genLabelOpticInstance names r) recordFields
, sequence [
genConstraintsClass names r
, genConstraintsInstance names r
, genGenericInstance names r dynFlags
, genGHCGeneric names r
]
]
{-------------------------------------------------------------------------------
The type itself and conversion to and from vectors
NOTE: All generation exampleshask assume as example
> data T a b = MkT {
> tWord :: Word
> , tBool :: Bool
> , tChar :: Char
> , tA :: a
> , tListB :: [b]
> }
> deriving (Eq, Show)
-------------------------------------------------------------------------------}
-- | Generate the datatype that will represent the record
--
-- Currently this generates something like
--
-- > data T a b =
-- > forall f0 f1 f2 f3 f4. (
-- > f0 ~ Word
-- > , f1 ~ Bool
-- > , f2 ~ Char
-- > , f3 ~ a
-- > , f4 ~ [b]
-- > )
-- > => MkT {
-- > tInt :: f0
-- > , tBool :: f1
-- > , tChar :: f2
-- > , tA :: f3
-- > , tListB :: f4
-- > }
-- > deriving anyclass C -- where applicable
--
-- (possibly with strict fields). This representation accomplishes two things:
--
-- 1. The use of the existentials with type equalities prevents ghc from
-- generating field accessors.
-- 2. It can still be used in the normal way to construct record values and
-- to pattern match on records.
--
-- TODO: From ghc 9.2 and up, we should generate
--
-- > newtype T a b = TFromVector {vectorFromT :: SmallArray Any}
-- > deriving anyclass C -- where applicable
--
-- instead, along with a pattern synonym.
genDatatype :: MonadFresh m => Record -> m (LHsDecl GhcPs)
genDatatype Record{..} = pure $
DataD
recordTyName
recordTyVars
[ forallRecC
vars
(zipWith fieldContext vars recordFields)
recordConName
(zipWith fieldExistentialType vars recordFields)
]
[ DerivClause (Just (withoutLoc strategy)) (c :| [])
| DeriveAnyClass c <- recordDerivings
]
where
#if __GLASGOW_HASKELL__ >= 902
strategy = AnyclassStrategy defExt
#else
strategy = AnyclassStrategy
#endif
-- There is no need to generate fresh va riables here, as these type vars
-- cannot clash with anything else (no other type vars can be in scope).
vars :: [LIdP GhcPs]
vars = [
mkNameTy recordAnnLoc ("lr_f" <> show i)
| (i, _) <- zip [1 :: Int ..] recordFields
]
optionalBang :: HsSrcBang -> LHsType GhcPs -> LHsType GhcPs
optionalBang bang = noLocA . HsBangTy defExt
#if __GLASGOW_HASKELL__ >= 912
(case bang of HsSrcBang _ b -> b)
#else
bang
#endif
fieldContext :: LIdP GhcPs -> Field -> LHsType GhcPs
fieldContext var fld = equalP (VarT var) (fieldType fld)
fieldExistentialType :: LIdP GhcPs -> Field -> (LIdP GhcPs, LHsType GhcPs)
fieldExistentialType var fld = (fieldName fld, optionalBang (fieldStrictness fld) $ VarT var)
-- | Generate conversion to and from an array
--
-- Generates something like
--
-- > vectorFromT :: T a b -> SmallArray Any
-- > vectorFromT = \x ->
-- > case x of
-- > MkT f0 f1 f2 f3 f4 -> smallArrayFromList [
-- > unsafeCoerce f0
-- > , unsafeCoerce f1
-- > , unsafeCoerce f2
-- > , unsafeCoerce f3
-- > , unsafeCoerce f4
-- > ]
-- >
-- > vectorToT :: SmallArray Any -> T a b
-- > vectorToT = \x ->
-- > case smallArrayToList x of
-- > [f0, f1, f2, f3, f4] ->
-- > MkT (unsafeCoerce f0)
-- > (unsafeCoerce f1)
-- > (unsafeCoerce f2)
-- > (unsafeCoerce f3)
-- > (unsafeCoerce f4)
-- > _ -> error "Pattern match failure in vectorToT: vector with invalid number of elements."
--
-- TODO: From ghc 9.2, these could be identity functions. See 'genDatatype'
-- for details.
genVectorConversions :: forall m.
MonadFresh m
=> QualifiedNames -> Record -> m [LHsDecl GhcPs]
genVectorConversions QualifiedNames{..} r@Record{..} = concatM [
fromVector
, toVector
]
where
fromVector :: m [LHsDecl GhcPs]
fromVector = do
args <- mapM (freshName . fieldName) recordFields
return [
sigD name $
funT
(recordTypeT r)
(ConT type_AnyArray)
, valD name $
lamE1 (conP recordConName (map varP args)) $
appE
(VarE anyArrayFromList)
(listE [ VarE noInlineUnsafeCo `appE` VarE arg
| arg <- args
]
)
]
where
name :: LIdP GhcPs
name = nameVectorFrom r
toVector :: m [LHsDecl GhcPs]
toVector = do
x <- freshName $ mkNameExp recordAnnLoc "x"
args <- mapM (freshName . fieldName) recordFields
return $ [
sigD name $
funT
(ConT type_AnyArray)
(recordTypeT r)
, valD name $
lamE1 (varP x) $
caseE
(VarE anyArrayToList `appE` VarE x)
[ ( listP (map varP args)
, appsE
(ConE recordConName)
[ VarE noInlineUnsafeCo `appE` VarE arg
| arg <- args
]
)
, ( wildP
, VarE error `appE` stringE matchErr
)
]
]
where
name :: LIdP GhcPs
name = nameVectorTo r
matchErr :: String
matchErr = concat [
"Pattern match failure in "
, nameBase (nameVectorTo r)
, ": vector with invalid number of elements."
]
{-------------------------------------------------------------------------------
Field accessors and 'HasField' instance
TODO: If we had support within GHC itself for accessing fields in records,
we might be able to integrate this a lot more closely with normal GHC,
especially when combined with the @NoFieldSelectors@ extension.
See <https://gitlab.haskell.org/ghc/ghc/-/issues/17991>
-------------------------------------------------------------------------------}
-- | Generate the indexed field accessor
--
-- Generates something like
--
-- > unsafeGetIndexT :: forall x a b. Int -> T a b -> x
-- > unsafeGetIndexT = \ n t -> noInlineUnsafeCo (V.unsafeIndex (vectorFromT t) n)
genIndexedAccessor ::
MonadFresh m
=> QualifiedNames
-> Record -> m [LHsDecl GhcPs]
genIndexedAccessor QualifiedNames{..} r@Record{..} = do
x <- freshName' False $ mkNameTy recordAnnLoc "x"
n <- freshName $ mkNameExp recordAnnLoc "n"
t <- freshName $ mkNameExp recordAnnLoc "t"
return [
sigD name $
funT
(ConT type_Int)
(recordTypeT r `funT` VarT x)
, valD name $
lamE (varP n :| [varP t]) $
appE
(VarE noInlineUnsafeCo)
(appsE
(VarE anyArrayIndex)
[ VarE (nameVectorFrom r) `appE` VarE t
, VarE n
]
)
]
where
name :: LIdP GhcPs
name = nameUnsafeGetIndex r
-- | Generate index field overwrite
--
-- Generates something like
--
-- > unsafeSetIndexT :: forall x a b. Int -> T a b -> x -> T a b
-- > unsafeSetIndexT = \n t val ->
-- > vectorToT (V.unsafeUpd (vectorFromT t) [(n, noInlineUnsafeCo val)])
--
-- NOTE: Like 'genTo', this function used to be more complicated, because it
-- would need to take the strictness of the fields into account. If we change
-- our internal representation, we might need to be more careful with that
-- again. See 'genTo' for further discussion.
genUnsafeSetIndex ::
MonadFresh m
=> QualifiedNames
-> Record -> m [LHsDecl GhcPs]
genUnsafeSetIndex QualifiedNames{..} r@Record{..} = do
x <- freshName' False $ mkNameTy recordAnnLoc "x"
n <- freshName $ mkNameExp recordAnnLoc "n"
t <- freshName $ mkNameExp recordAnnLoc "t"
val <- freshName $ mkNameExp recordAnnLoc "val"
return [
sigD name $
ConT type_Int
`funT` (recordTypeT r `funT` (VarT x `funT` recordTypeT r))
, valD name $
lamE (varP n :| [varP t, (varP val)]) $
appE
(VarE (nameVectorTo r))
(appsE
(VarE anyArrayUpdate)
[ VarE (nameVectorFrom r) `appE` VarE t
, listE [
tupE $
VarE n
:| [VarE noInlineUnsafeCo `appE` VarE val]
]
]
)
]
where
name :: LIdP GhcPs
name = nameUnsafeSetIndex r
-- | Generate 'HasField' instance for single field
--
-- Generates something like
--
-- > instance x ~ Word => HasField "tInt" (T a b) x where
-- > hasField = \t -> (unsafeSetIndexT 0 t, unsafeGetIndexT 0 t)
genHasFieldInstance :: MonadFresh m
=> QualifiedNames
-> Record -> Field -> m (LHsDecl GhcPs)
genHasFieldInstance QualifiedNames{..} r@Record{..} Field{..} = do
x <- freshName' False $ mkNameTy recordAnnLoc "x"
t <- freshName $ mkNameExp recordAnnLoc "t"
return $
instanceD
[equalP (VarT x) fieldType]
(appsT
(ConT type_HasField)
[ stringT (nameBase fieldName)
, recordTypeT r
, VarT x
]
)
[ ( hasField
, lamE1 (varP t) $
tupE $
appsE (VarE (nameUnsafeSetIndex r)) [intE fieldIndex, VarE t]
:| [appsE (VarE (nameUnsafeGetIndex r)) [intE fieldIndex, VarE t]]
)
]
[]
-- | Generate 'LabelOptic' instance for a single field
--
-- Generates something like
--
-- > instance (x ~ Word, y ~ Word) => LabelOptic "tInt" A_Lens (T a b) (T a b) x y where
-- > labelOptic = lens (unsafeGetIndexT 0) (unsafeSetIndexT 0)
genLabelOpticInstance :: MonadFresh m
=> QualifiedNames
-> Record -> Field -> m (LHsDecl GhcPs)
genLabelOpticInstance QualifiedNames{..} r@Record{..} Field{..} = do
x <- freshName' False $ mkNameTy recordAnnLoc "x"
y <- freshName' False $ mkNameTy recordAnnLoc "y"
return $
instanceD
[equalP (VarT x) fieldType, equalP (VarT y) fieldType]
(appsT
(ConT type_LabelOptic)
[ stringT (nameBase fieldName)
, ConT type_A_Lens
, recordTypeT r
, recordTypeT r
, VarT x
, VarT y
]
)
[ ( labelOptic
, appsE (VarE lens)
[ appsE (VarE (nameUnsafeGetIndex r)) [intE fieldIndex]
, appsE (VarE (nameUnsafeSetIndex r)) [intE fieldIndex]
]
)
]
[]
{-------------------------------------------------------------------------------
Generics
-------------------------------------------------------------------------------}
-- | Generate the class we will use to instantiate 'Constraints'
--
-- Generates something like this:
--
-- > class Constraints_T a b (c :: Type -> Constraint) where
-- > dictConstraints_T :: Proxy c -> Rep (Dict c) (T a b)
--
-- NOTE: It is critical that we don't give the class any superclass constraints
-- like
--
-- > class (c Word, c Bool, c Char, c a, c [b])
-- > => Constraints_T a b (c :: Type -> Constraint)
--
-- because then @ghc@ would use resolve @Constraints_T@ to that tuple instead,
-- and use lots of "tuple constraint extractor" functions, each of which have
-- the same size as the number of constraints (another example of a
-- @case f of { T x1 x2 x3 .. -> xn@ function, but now at the dictionary level).
genConstraintsClass ::
MonadFresh m
=> QualifiedNames -> Record -> m (LHsDecl GhcPs)
genConstraintsClass QualifiedNames{..} r@Record{..} = do
c <- freshName' False $ mkNameTy recordAnnLoc "c"
return $ classD
[]
(nameConstraints r)
(recordTyVars ++ [kindedTV c cKind])
[ ( nameDictConstraints r
, funT
(ConT type_Proxy `appT` VarT c)
(appsT
(ConT type_Rep)
[ ConT type_Dict `appT` VarT c
, recordTypeT r
]
)
)
]
where
cKind :: LHsType GhcPs
cKind = ConT type_Type `funT` ConT type_Constraint
-- | Superclass constraints required by the constraints class instance
--
-- Generates something like
--
-- > (c Word, c Bool, c Char, c a, c [b])
--
-- However, we filter out constraints that are type variable free, so if we
-- pass, say, @Show@ for @c@, then we generate
--
-- > (Show a, Show [b])
--
-- instead. This avoids @ghc@ complaining about
--
-- > Redundant constraints: (Show Word, Show Bool, Show Char)
genRequiredConstraints :: Record -> LHsType GhcPs -> [LHsType GhcPs]
genRequiredConstraints Record{..} c =
nubBy sameType $ filter hasTypeVar $ map constrainField recordFields
where
constrainField :: Field -> LHsType GhcPs
constrainField Field{..} = c `appT` fieldType
sameType :: LHsType GhcPs -> LHsType GhcPs -> Bool
sameType = compareHs
hasTypeVar :: LHsType GhcPs -> Bool
hasTypeVar = not . null . allTyVars
allTyVars :: LHsType GhcPs -> [String]
allTyVars = SYB.everything (++) (SYB.mkQ [] isTypeVar)
isTypeVar :: LHsType GhcPs -> [String]
isTypeVar (VarT (TyVar name)) = [name]
isTypeVar _otherwise = []
-- | Generate the dictionary creation function ('dict')
--
-- Generates something like
--
-- > \p -> Rep (V.fromList [
-- > noInlineUnsafeCo (dictFor p (Proxy :: Proxy Word))
-- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy Bool))
-- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy Char))
-- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy a))
-- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy [b]))
-- > ])
genDict ::
MonadFresh m
=> QualifiedNames
-> Record -> m (LHsExpr GhcPs)
genDict names@QualifiedNames{..} Record{..} = do
p <- freshName $ mkNameExp recordAnnLoc "p"
return $
lamE1 (varP p) $
appE
(VarE mkDicts)
(listE (map (dictForField p) recordFields))
where
dictForField :: LIdP GhcPs -> Field -> LHsExpr GhcPs
dictForField p Field{..} =
appE
(VarE noInlineUnsafeCo)
(VarE mkDict `appsE` [VarE p, proxyE names fieldType])
-- | Generate (one and only) instance of the constraints class
--
-- Generates something like
--
-- > instance (..) => Constraints_T a b c where
-- > dictConstraints_T = ..
--
-- where the body of @dictConstraints_T@ is generated by 'genDict'.
genConstraintsInstance ::
MonadFresh m
=> QualifiedNames -> Record -> m (LHsDecl GhcPs)
genConstraintsInstance names r@Record{..} = do
body <- genDict names r
c <- freshName' False $ mkNameTy recordAnnLoc "c"
return $
instanceD
(genRequiredConstraints r (VarT c))
(appsT
(ConT (nameConstraints r))
([VarT (tyVarBndrName v) | v <- recordTyVars] ++ [VarT c]))
[(nameDictConstraints r, body)]
[]
-- | Generate metadata
--
-- Generates something like
--
-- > \_p -> Metadata {
-- > recordName = "T"
-- > , recordConstructor = "MkT"
-- > , recordSize = 5
-- > , recordFieldMetadata = Rep $ V.fromList [
-- > FieldMetadata (Proxy :: Proxy "tInt")) FieldLazy
-- > , FieldMetadata (Proxy :: Proxy "tBool")) FieldLazy
-- > , FieldMetadata (Proxy :: Proxy "tChar")) FieldLazy
-- > , FieldMetadata (Proxy :: Proxy "tA")) FieldLazy
-- > , FieldMetadata (Proxy :: Proxy "tListB")) FieldLazy
-- > ]
-- > }
genMetadata ::
MonadFresh m
=> QualifiedNames
-> Record -> DynFlags -> m (LHsExpr GhcPs)
genMetadata names@QualifiedNames{..} r@Record{..} dynFlags = do
p <- freshName $ mkNameExp recordAnnLoc "p"
return $
lamE1 (varP p) $
appsE (VarE mkMetadata) [
stringE (nameRecord r)
, stringE (nameBase recordConName)
, listE (map auxField recordFields)
]
where
auxField :: Field -> LHsExpr GhcPs
auxField Field{..} =
(appE . VarE $ if isStrict dynFlags fieldStrictness
then mkStrictField
else mkLazyField)
$ proxyE names
$ stringT (nameBase fieldName)
isStrict :: DynFlags -> HsSrcBang -> Bool
#if __GLASGOW_HASKELL__ >= 912
isStrict dynFlags (HsSrcBang _ (HsBang _ strictness)) =
#else
isStrict dynFlags (HsSrcBang _ _ strictness) =
#endif
case strictness of
SrcStrict -> True
SrcLazy -> False
NoSrcStrict -> if strictData then True else False
where
strictData = xopt StrictData dynFlags
-- | Generate definition for `from` in the `Generic` instance
--
-- Generates something like
--
-- > repFromVectorStrict . vectorFromT
genFrom ::
MonadFresh m
=> QualifiedNames
-> Record -> m (LHsExpr GhcPs)
genFrom QualifiedNames{..} r@Record{..} = do
x <- freshName $ mkNameExp recordAnnLoc "x"
return $
lamE1 (varP x) $
VarE anyArrayToRep `appE` (VarE (nameVectorFrom r) `appE` VarE x)
-- | Generate definition for `to` in the `Generic` instance
--
-- > vectorToT . repToVector
--
-- NOTE: This function used to be more complicated. When the internal
-- representation of a record /is/ a vector, then we have to be very careful
-- with the strictness of the fields here. However, since we currently use a
-- " normal " record as our internal representation (albeit with strange types),
-- and the fields of that record have their own strictness annotation, we don't
-- have to worry about strictness here.
genTo ::
MonadFresh m
=> QualifiedNames
-> Record -> m (LHsExpr GhcPs)
genTo QualifiedNames{..} r@Record{..} = do
x <- freshName $ mkNameExp recordAnnLoc "x"
return $
lamE1 (varP x) $
VarE (nameVectorTo r) `appE` (VarE anyArrayFromRep `appE` VarE x)
-- | Generate an instance of large-records 'Data.Record.Generic'.
--
-- In the sample instance below, @vectorFromT@ and @vectorToT@ are generated
-- per-record by 'genVectorFrom' and 'genVectorTo' respectively.
--
-- > instance Generic (T ...) where
-- > type Constraints (T ...) = Constraints_T ...
-- > type MetadataOf (T ...) = '[ '("field1", fieldType1), ... ]
-- >
-- > from = ..
-- > to = ..
-- > dict = dictConstraints_T
-- > metadata = ..
genGenericInstance ::
MonadFresh m
=> QualifiedNames
-> Record -> DynFlags -> m (LHsDecl GhcPs)
genGenericInstance names@QualifiedNames{..} r@Record{..} dynFlags = do
metadata <- genMetadata names r dynFlags
from <- genFrom names r
to <- genTo names r
return $
instanceD
[]
(ConT type_LR_Generic `appT` recordTypeT r)
[ ( lr_from , from )
, ( lr_to , to )
, ( lr_dict , VarE (nameDictConstraints r) )
, ( lr_metadata , metadata )
]
[ tySynEqn type_LR_Constraints [recordTypeT r] $
appsT
(ConT (nameConstraints r))
[VarT (tyVarBndrName v) | v <- recordTyVars]
, tySynEqn type_LR_MetadataOf [recordTypeT r] $
listT [
tupT $ stringT (nameBase fieldName) :| [fieldType]
| Field{..} <- recordFields
]
]
{-------------------------------------------------------------------------------
"Stock" instances
-------------------------------------------------------------------------------}
-- | Generate stock instances
genStockInstances ::
MonadFresh m
=> QualifiedNames
-> Record -> m [LHsDecl GhcPs]
genStockInstances names r@Record{..} = concatM [
genStockInstance names r d
| DeriveStock d <- recordDerivings
]
-- | For a record type @T@ and stock-derivable class @C@, generate
--
-- > instance $(genRequiredConstraints T C) => C T where
-- > $(method) = $(generic implementation)
--
-- NOTE: All of these instances depend on the 'Data.Record.Generics.Generics'
-- instance.
--
-- TODO: For 'Generic' we currently don't do anything. We could change this so
-- that we generate the 'GHC.Generics' instance only when the user asks for a
-- 'Generics' instance?
genStockInstance :: MonadFresh m
=> QualifiedNames
-> Record -> StockDeriving -> m [LHsDecl GhcPs]
genStockInstance QualifiedNames{..} r = pure . \case
Show -> [mkInstance prelude_type_Show prelude_showsPrec gshowsPrec]
Eq -> [mkInstance prelude_type_Eq prelude_eq geq ]
Ord -> [mkInstance prelude_type_Ord prelude_compare gcompare ]
Generic -> []
where
mkInstance :: LIdP GhcPs -> LIdP GhcPs -> LIdP GhcPs -> LHsDecl GhcPs
mkInstance cls mthd gen =
instanceD
(genRequiredConstraints r (ConT cls))
(ConT cls `appT` recordTypeT r)
[(mthd, VarE gen)]
[]
{-------------------------------------------------------------------------------
GHC generics
-------------------------------------------------------------------------------}
-- | Generate GHC generics instance
--
-- Generates something like
--
-- > instance GHC.Generic ExampleRecord where
-- > type Rep ExampleRecord = ThroughLRGenerics ExampleRecord
-- >
-- > from = WrapThroughLRGenerics
-- > to = unwrapThroughLRGenerics
--
-- See 'ThroughLRGenerics' for documentation.
genGHCGeneric ::
MonadFresh m
=> QualifiedNames -> Record -> m (LHsDecl GhcPs)
genGHCGeneric QualifiedNames{..} r = pure $
instanceD
[]
(ConT type_GHC_Generic `appT` recordTypeT r)
[ ( ghc_from , VarE wrapThroughLRGenerics )
, ( ghc_to , VarE unwrapThroughLRGenerics )
]
[ tySynEqn type_GHC_Rep [recordTypeT r] $
ConT type_ThroughLRGenerics `appT` recordTypeT r
]
{-------------------------------------------------------------------------------
Auxiliary functions for dealing with records
-------------------------------------------------------------------------------}
-- | The saturated type of the record (that is, with all type vars applied)
recordTypeT :: Record -> LHsType GhcPs
recordTypeT Record{..} =
ConT recordTyName `appsT` [VarT (tyVarBndrName f) | f <- recordTyVars]
{-------------------------------------------------------------------------------
Pick names for generated code
-------------------------------------------------------------------------------}
nameRecord :: Record -> String
nameRecord Record{..} = nameBase recordTyName
-- | Make name derived from the name of the record
mkDerived :: (SrcSpan -> String -> LIdP GhcPs) -> String -> Record -> LIdP GhcPs
mkDerived f prefix r = f (recordAnnLoc r) (prefix <> nameRecord r)
nameVectorFrom :: Record -> LIdP GhcPs
nameVectorTo :: Record -> LIdP GhcPs
nameUnsafeGetIndex :: Record -> LIdP GhcPs
nameUnsafeSetIndex :: Record -> LIdP GhcPs
nameConstraints :: Record -> LIdP GhcPs
nameDictConstraints :: Record -> LIdP GhcPs
nameVectorFrom = mkDerived mkNameExp "vectorFrom"
nameVectorTo = mkDerived mkNameExp "vectorTo"
nameUnsafeGetIndex = mkDerived mkNameExp "unsafeGetIndex"
nameUnsafeSetIndex = mkDerived mkNameExp "unsafeSetIndex"
nameConstraints = mkDerived mkNameTyCon "Constraints_"
nameDictConstraints = mkDerived mkNameExp "dictConstraints_"
{-------------------------------------------------------------------------------
Auxiliary
-------------------------------------------------------------------------------}
-- | Generate a Proxy expression for the given type.
--
-- @proxyE [t|ty|]@ will result in a @Proxy :: Proxy ty@.
proxyE :: QualifiedNames -> LHsType GhcPs -> LHsExpr GhcPs
proxyE QualifiedNames{..} ty =
sigE (VarE proxy) (ConT type_Proxy `appT` ty)
concatM :: Applicative m => [m [a]] -> m [a]
concatM = fmap concat . sequenceA