{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | The core of the plugin implementation.
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

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

-- | Generate all large-records definitions for a 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
      ]
    ]

{-------------------------------------------------------------------------------
  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 :: 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
    -- 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 :: [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)

-- | 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 :: 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."
            ]

{-------------------------------------------------------------------------------
  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 :: 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

-- | 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 :: 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

-- | 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 :: 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]]
          )
        ]
        []

{-------------------------------------------------------------------------------
  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 :: 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

-- | 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 -> 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          = []

-- | 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 :: 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])

-- | 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 :: 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)]
        []

-- | 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 :: 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

-- | Generate definition for `from` in the `Generic` instance
--
-- Generates something like
--
-- > repFromVectorStrict . vectorFromT
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)

-- | 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 :: 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)

-- | 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 :: 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
              ]
        ]

{-------------------------------------------------------------------------------
  "Stock" instances
-------------------------------------------------------------------------------}

-- | Generate stock instances
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
    ]

-- | 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 :: 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)]
          []

{-------------------------------------------------------------------------------
  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 :: 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
      ]

{-------------------------------------------------------------------------------
  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 -> 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]

{-------------------------------------------------------------------------------
  Pick names for generated code
-------------------------------------------------------------------------------}

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

-- | Make name derived from the name of the record
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_"

{-------------------------------------------------------------------------------
  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 -> 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