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

-- | The core of the plugin implementation.
module Data.Record.Internal.Plugin.CodeGen (genLargeRecord) where

import Prelude hiding (error)

import Data.List (nubBy)
import Data.List.NonEmpty (NonEmpty(..))

import Language.Haskell.TH (Extension(StrictData))

import qualified Data.Generics as SYB

import Data.Record.Internal.GHC.Fresh
import Data.Record.Internal.GHC.Shim 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]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
..} DynFlags
dynFlags = [m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM [
      (GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> [a] -> [a]
:[]) (GenLocated SrcSpanAnnA (HsDecl GhcPs)
 -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> m (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Record -> m (LHsDecl GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
Record -> m (LHsDecl GhcPs)
genDatatype           Record
r
    , QualifiedNames -> Record -> m [LHsDecl GhcPs]
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m [LHsDecl GhcPs]
genVectorConversions      QualifiedNames
names Record
r
    , QualifiedNames -> Record -> m [LHsDecl GhcPs]
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m [LHsDecl GhcPs]
genIndexedAccessor        QualifiedNames
names Record
r
    , QualifiedNames -> Record -> m [LHsDecl GhcPs]
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m [LHsDecl GhcPs]
genUnsafeSetIndex         QualifiedNames
names Record
r
    , QualifiedNames -> Record -> m [LHsDecl GhcPs]
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m [LHsDecl GhcPs]
genStockInstances         QualifiedNames
names Record
r
    , (Field -> m (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> [Field] -> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (QualifiedNames -> Record -> Field -> m (LHsDecl GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> Field -> m (LHsDecl GhcPs)
genHasFieldInstance QualifiedNames
names Record
r) [Field]
recordFields
    , [m (GenLocated SrcSpanAnnA (HsDecl GhcPs))]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: Type -> Type) a. Monad m => [m a] -> m [a]
sequence [
          QualifiedNames -> Record -> m (LHsDecl GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsDecl GhcPs)
genConstraintsClass    QualifiedNames
names Record
r
        , QualifiedNames -> Record -> m (LHsDecl GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsDecl GhcPs)
genConstraintsInstance QualifiedNames
names Record
r
        , QualifiedNames -> Record -> DynFlags -> m (LHsDecl GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> DynFlags -> m (LHsDecl GhcPs)
genGenericInstance     QualifiedNames
names Record
r DynFlags
dynFlags
        , QualifiedNames -> Record -> m (LHsDecl GhcPs)
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]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} = LHsDecl GhcPs -> m (LHsDecl GhcPs)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (LHsDecl GhcPs -> m (LHsDecl GhcPs))
-> LHsDecl GhcPs -> m (LHsDecl GhcPs)
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
          ((LRdrName -> Field -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> [LRdrName] -> [Field] -> [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith LRdrName -> Field -> LHsType GhcPs
LRdrName -> Field -> GenLocated SrcSpanAnnA (HsType GhcPs)
fieldContext [LRdrName]
vars [Field]
recordFields)
          LRdrName
recordConName
          ((LRdrName
 -> Field -> (LRdrName, GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [LRdrName]
-> [Field]
-> [(LRdrName, GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith LRdrName -> Field -> (LRdrName, LHsType GhcPs)
LRdrName
-> Field -> (LRdrName, GenLocated SrcSpanAnnA (HsType GhcPs))
fieldExistentialType [LRdrName]
vars [Field]
recordFields)

      ]
      [ Maybe (LDerivStrategy GhcPs)
-> NonEmpty (LHsType GhcPs) -> LHsDerivingClause GhcPs
DerivClause (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcPs)
-> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcPs))
forall a. a -> Maybe a
Just (DerivStrategy GhcPs
-> GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcPs)
forall a b. InheritLoc SrcSpan a b => a -> b
withoutLoc ((XAnyClassStrategy GhcPs -> DerivStrategy GhcPs)
-> DerivStrategy GhcPs
forall a b. HasDefaultExt a => (a -> b) -> b
withDefExt XAnyClassStrategy GhcPs -> DerivStrategy GhcPs
forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy))) (LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
c GenLocated SrcSpanAnnA (HsType GhcPs)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> NonEmpty (GenLocated SrcSpanAnnA (HsType GhcPs))
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" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)
        | (Int
i, Field
_) <- [Int] -> [Field] -> [(Int, 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 = HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XBangTy GhcPs -> HsSrcBang -> LHsType GhcPs -> HsType GhcPs
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy XBangTy GhcPs
EpAnn [AddEpAnn]
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
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) (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ HasCallStack => LRdrName -> LHsType GhcPs
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
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} = [m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM [
      m [LHsDecl GhcPs]
m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
fromVector
    , m [LHsDecl GhcPs]
m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
toVector
    ]
  where
    fromVector :: m [LHsDecl GhcPs]
    fromVector :: m [LHsDecl GhcPs]
fromVector = do
        [LRdrName]
args <- (Field -> m LRdrName) -> [Field] -> m [LRdrName]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName)
-> (Field -> LRdrName) -> Field -> m LRdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> LRdrName
fieldName) [Field]
recordFields
        [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [
            LRdrName -> LHsType GhcPs -> LHsDecl GhcPs
sigD LRdrName
name (LHsType GhcPs -> LHsDecl GhcPs) -> LHsType GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
              LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
funT
                (Record -> LHsType GhcPs
recordTypeT Record
r)
                (HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
type_AnyArray)
          , LRdrName -> LHsExpr GhcPs -> LHsDecl GhcPs
valD LRdrName
name (LHsExpr GhcPs -> LHsDecl GhcPs) -> LHsExpr GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
              LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> [LPat GhcPs] -> LPat GhcPs
conP LRdrName
recordConName ((LRdrName -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [LRdrName] -> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LRdrName -> LPat GhcPs
LRdrName -> GenLocated SrcSpanAnnA (Pat GhcPs)
varP [LRdrName]
args)) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
                LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
                  (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
anyArrayFromList)
                  ([LHsExpr GhcPs] -> LHsExpr GhcPs
listE [ HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
noInlineUnsafeCo LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
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    <- LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"x"
        [LRdrName]
args <- (Field -> m LRdrName) -> [Field] -> m [LRdrName]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName)
-> (Field -> LRdrName) -> Field -> m LRdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> LRdrName
fieldName) [Field]
recordFields
        [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
 -> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b. (a -> b) -> a -> b
$ [
            LRdrName -> LHsType GhcPs -> LHsDecl GhcPs
sigD LRdrName
name (LHsType GhcPs -> LHsDecl GhcPs) -> LHsType GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
              LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
funT
                (HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
type_AnyArray)
                (Record -> LHsType GhcPs
recordTypeT Record
r)
          , LRdrName -> LHsExpr GhcPs -> LHsDecl GhcPs
valD LRdrName
name (LHsExpr GhcPs -> LHsDecl GhcPs) -> LHsExpr GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
              LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> LPat GhcPs
varP LRdrName
x) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
                LHsExpr GhcPs -> [(LPat GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs
caseE
                  (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
anyArrayToList LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
x)
                  [ ( [LPat GhcPs] -> LPat GhcPs
listP ((LRdrName -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [LRdrName] -> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LRdrName -> LPat GhcPs
LRdrName -> GenLocated SrcSpanAnnA (Pat GhcPs)
varP [LRdrName]
args)
                    , LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE
                        (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
ConE LRdrName
recordConName)
                        [ HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
noInlineUnsafeCo LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
arg
                        | LRdrName
arg <- [LRdrName]
args
                        ]
                    )
                  , ( LPat GhcPs
wildP
                    , HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
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 = [String] -> String
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
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} = do
    LRdrName
x <- Bool -> LRdrName -> m LRdrName
forall (m :: Type -> Type).
MonadFresh m =>
Bool -> LRdrName -> m LRdrName
freshName' Bool
False (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkTyVar  SrcSpan
recordAnnLoc String
"x"
    LRdrName
n <- LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"n"
    LRdrName
t <- LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"t"
    [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [
        LRdrName -> LHsType GhcPs -> LHsDecl GhcPs
sigD LRdrName
name (LHsType GhcPs -> LHsDecl GhcPs) -> LHsType GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
          LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
funT
            (HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
type_Int)
            (Record -> LHsType GhcPs
recordTypeT Record
r LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`funT` HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
VarT LRdrName
x)
      , LRdrName -> LHsExpr GhcPs -> LHsDecl GhcPs
valD LRdrName
name (LHsExpr GhcPs -> LHsDecl GhcPs) -> LHsExpr GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
          NonEmpty (LPat GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE (LRdrName -> LPat GhcPs
varP LRdrName
n GenLocated SrcSpanAnnA (Pat GhcPs)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> NonEmpty (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> [a] -> NonEmpty a
:| [LRdrName -> LPat GhcPs
varP LRdrName
t]) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
            LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
              (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
noInlineUnsafeCo)
              (LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE
                 (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
anyArrayIndex)
                 [ HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameVectorFrom Record
r) LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
t
                 , HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
n
                 ]
              )
      ]
  where
    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
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} = do
    LRdrName
x   <- Bool -> LRdrName -> m LRdrName
forall (m :: Type -> Type).
MonadFresh m =>
Bool -> LRdrName -> m LRdrName
freshName' Bool
False (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkTyVar  SrcSpan
recordAnnLoc String
"x"
    LRdrName
n   <- LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"n"
    LRdrName
t   <- LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"t"
    LRdrName
val <- LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"val"
    [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return [
      LRdrName -> LHsType GhcPs -> LHsDecl GhcPs
sigD LRdrName
name (LHsType GhcPs -> LHsDecl GhcPs) -> LHsType GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
               HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
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
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 (LHsExpr GhcPs -> LHsDecl GhcPs) -> LHsExpr GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$
          NonEmpty (LPat GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE (LRdrName -> LPat GhcPs
varP LRdrName
n GenLocated SrcSpanAnnA (Pat GhcPs)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> NonEmpty (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> [a] -> NonEmpty a
:| [LRdrName -> LPat GhcPs
varP LRdrName
t, (LRdrName -> LPat GhcPs
varP LRdrName
val)]) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
            LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
              (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameVectorTo Record
r))
              (LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE
                 (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
anyArrayUpdate)
                 [ HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameVectorFrom Record
r) LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
t
                 , [LHsExpr GhcPs] -> LHsExpr GhcPs
listE [
                       NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs
tupE (NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
                             HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
n
                         GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> NonEmpty (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> [a] -> NonEmpty a
:| [HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
noInlineUnsafeCo LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
val]
                     ]
                 ]
              )
      ]
  where
    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
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} Field{Int
LHsType GhcPs
LRdrName
HsSrcBang
fieldType :: Field -> LHsType GhcPs
fieldName :: Field -> LRdrName
fieldStrictness :: Field -> HsSrcBang
fieldName :: LRdrName
fieldType :: LHsType GhcPs
fieldStrictness :: HsSrcBang
fieldIndex :: Int
fieldIndex :: Field -> Int
..} = do
    LRdrName
x <- Bool -> LRdrName -> m LRdrName
forall (m :: Type -> Type).
MonadFresh m =>
Bool -> LRdrName -> m LRdrName
freshName' Bool
False (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkTyVar  SrcSpan
recordAnnLoc String
"x"
    LRdrName
t <- LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"t"
    LHsDecl GhcPs -> m (LHsDecl GhcPs)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LHsDecl GhcPs -> m (LHsDecl GhcPs))
-> LHsDecl GhcPs -> m (LHsDecl GhcPs)
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
LRdrName -> LHsType GhcPs
VarT LRdrName
x) LHsType GhcPs
fieldType]
        (LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
appsT
           (HasCallStack => LRdrName -> LHsType GhcPs
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
LRdrName -> LHsType GhcPs
VarT LRdrName
x
           ]
        )
        [ ( LRdrName
hasField
          , LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> LPat GhcPs
varP LRdrName
t) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
              NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs
tupE (NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
                    LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameUnsafeSetIndex Record
r)) [Int -> LHsExpr GhcPs
forall a. Integral a => a -> LHsExpr GhcPs
intE Int
fieldIndex, HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
t]
                GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> NonEmpty (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> [a] -> NonEmpty a
:| [LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameUnsafeGetIndex Record
r)) [Int -> LHsExpr GhcPs
forall a. Integral a => a -> LHsExpr GhcPs
intE Int
fieldIndex, HasCallStack => LRdrName -> LHsExpr GhcPs
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
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} = do
    LRdrName
c <- Bool -> LRdrName -> m LRdrName
forall (m :: Type -> Type).
MonadFresh m =>
Bool -> LRdrName -> m LRdrName
freshName' Bool
False (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkTyVar SrcSpan
recordAnnLoc String
"c"
    LHsDecl GhcPs -> m (LHsDecl GhcPs)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LHsDecl GhcPs -> m (LHsDecl GhcPs))
-> LHsDecl GhcPs -> m (LHsDecl GhcPs)
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]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
recordTyVars [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
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
LRdrName -> LHsType GhcPs
ConT LRdrName
type_Proxy LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
VarT LRdrName
c)
            (LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
appsT
               (HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
type_Rep)
               [ HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
type_Dict LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
VarT LRdrName
c
               , Record -> LHsType GhcPs
recordTypeT Record
r
               ]
            )
        )
      ]
  where
    cKind :: LHsType GhcPs
    cKind :: LHsType GhcPs
cKind = HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
type_Type LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`funT` HasCallStack => LRdrName -> LHsType GhcPs
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]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} LHsType GhcPs
c =
    (LHsType GhcPs -> LHsType GhcPs -> Bool)
-> [LHsType GhcPs] -> [LHsType GhcPs]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy LHsType GhcPs -> LHsType GhcPs -> Bool
sameType ([LHsType GhcPs] -> [LHsType GhcPs])
-> [LHsType GhcPs] -> [LHsType GhcPs]
forall a b. (a -> b) -> a -> b
$ (LHsType GhcPs -> Bool) -> [LHsType GhcPs] -> [LHsType GhcPs]
forall a. (a -> Bool) -> [a] -> [a]
filter LHsType GhcPs -> Bool
hasTypeVar ([LHsType GhcPs] -> [LHsType GhcPs])
-> [LHsType GhcPs] -> [LHsType GhcPs]
forall a b. (a -> b) -> a -> b
$ (Field -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> [Field] -> [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map Field -> LHsType GhcPs
Field -> GenLocated SrcSpanAnnA (HsType GhcPs)
constrainField [Field]
recordFields
  where
    constrainField :: Field -> LHsType GhcPs
    constrainField :: Field -> LHsType GhcPs
constrainField Field{Int
LHsType GhcPs
LRdrName
HsSrcBang
fieldType :: Field -> LHsType GhcPs
fieldName :: Field -> LRdrName
fieldStrictness :: Field -> HsSrcBang
fieldIndex :: Field -> Int
fieldName :: LRdrName
fieldType :: LHsType GhcPs
fieldStrictness :: HsSrcBang
fieldIndex :: Int
..} = 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 = LHsType GhcPs -> LHsType GhcPs -> Bool
GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs) -> Bool
forall a. Data a => a -> a -> Bool
compareHs

    hasTypeVar :: LHsType GhcPs -> Bool
    hasTypeVar :: LHsType GhcPs -> Bool
hasTypeVar = Bool -> Bool
not (Bool -> Bool)
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> Bool)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null ([String] -> Bool)
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> [String])
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcPs -> [String]
GenLocated SrcSpanAnnA (HsType GhcPs) -> [String]
allTyVars

    allTyVars :: LHsType GhcPs -> [String]
    allTyVars :: LHsType GhcPs -> [String]
allTyVars = ([String] -> [String] -> [String])
-> GenericQ [String] -> GenericQ [String]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
SYB.everything [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
(++) ([String]
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> [String])
-> a
-> [String]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
SYB.mkQ [] LHsType GhcPs -> [String]
GenLocated SrcSpanAnnA (HsType 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
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
..} Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} = do
    LRdrName
p <- LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"p"
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
      LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> LPat GhcPs
varP LRdrName
p) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
          (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
mkDicts)
          ([LHsExpr GhcPs] -> LHsExpr GhcPs
listE ((Field -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [Field] -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
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
LRdrName
HsSrcBang
fieldType :: Field -> LHsType GhcPs
fieldName :: Field -> LRdrName
fieldStrictness :: Field -> HsSrcBang
fieldIndex :: Field -> Int
fieldName :: LRdrName
fieldType :: LHsType GhcPs
fieldStrictness :: HsSrcBang
fieldIndex :: Int
..} =
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
          (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
noInlineUnsafeCo)
          (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
mkDict LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
`appsE` [HasCallStack => LRdrName -> LHsExpr GhcPs
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]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} = do
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
body <- QualifiedNames -> Record -> m (LHsExpr GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsExpr GhcPs)
genDict QualifiedNames
names Record
r
    LRdrName
c    <- Bool -> LRdrName -> m LRdrName
forall (m :: Type -> Type).
MonadFresh m =>
Bool -> LRdrName -> m LRdrName
freshName' Bool
False (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkTyVar SrcSpan
recordAnnLoc String
"c"
    LHsDecl GhcPs -> m (LHsDecl GhcPs)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LHsDecl GhcPs -> m (LHsDecl GhcPs))
-> LHsDecl GhcPs -> m (LHsDecl GhcPs)
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
LRdrName -> LHsType GhcPs
VarT LRdrName
c))
        (LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
appsT
           (HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT (Record -> LRdrName
nameConstraints Record
r))
           ([HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
VarT (LHsTyVarBndr GhcPs -> LRdrName
tyVarBndrName LHsTyVarBndr GhcPs
GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
v) | GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
v <- [LHsTyVarBndr GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
recordTyVars] [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall a. [a] -> [a] -> [a]
++ [HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
VarT LRdrName
c]))
        [(Record -> LRdrName
nameDictConstraints Record
r, LHsExpr GhcPs
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
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} DynFlags
dynFlags = do
    LRdrName
p <- LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"p"
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
      LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> LPat GhcPs
varP LRdrName
p) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
        LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE (HasCallStack => LRdrName -> LHsExpr GhcPs
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 ((Field -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [Field] -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map Field -> LHsExpr GhcPs
Field -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
auxField [Field]
recordFields)
          ]
  where
    auxField :: Field -> LHsExpr GhcPs
    auxField :: Field -> LHsExpr GhcPs
auxField Field{Int
LHsType GhcPs
LRdrName
HsSrcBang
fieldType :: Field -> LHsType GhcPs
fieldName :: Field -> LRdrName
fieldStrictness :: Field -> HsSrcBang
fieldIndex :: Field -> Int
fieldName :: LRdrName
fieldType :: LHsType GhcPs
fieldStrictness :: HsSrcBang
fieldIndex :: Int
..} =
          (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> LHsExpr GhcPs
appE (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> LHsExpr GhcPs)
-> (LRdrName -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> LRdrName
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
LRdrName -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
VarE (LRdrName
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> LHsExpr GhcPs)
-> LRdrName
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ if DynFlags -> HsSrcBang -> Bool
isStrict DynFlags
dynFlags HsSrcBang
fieldStrictness
            then LRdrName
mkStrictField
            else LRdrName
mkLazyField)
        (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> LHsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ QualifiedNames -> LHsType GhcPs -> LHsExpr GhcPs
proxyE QualifiedNames
names
        (LHsType GhcPs -> LHsExpr GhcPs) -> LHsType GhcPs -> LHsExpr GhcPs
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
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} = do
    LRdrName
x <- LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"x"
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
      LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> LPat GhcPs
varP LRdrName
x) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
        HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
anyArrayToRep LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameVectorFrom Record
r) LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
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
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} = do
    LRdrName
x <- LRdrName -> m LRdrName
forall (m :: Type -> Type). MonadFresh m => LRdrName -> m LRdrName
freshName (LRdrName -> m LRdrName) -> LRdrName -> m LRdrName
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> LRdrName
mkExpVar SrcSpan
recordAnnLoc String
"x"
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> m (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> m (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
      LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
lamE1 (LRdrName -> LPat GhcPs
varP LRdrName
x) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
        HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameVectorTo Record
r) LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
anyArrayFromRep LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
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
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
..} r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} DynFlags
dynFlags  = do
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
metadata <- QualifiedNames -> Record -> DynFlags -> m (LHsExpr GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> DynFlags -> m (LHsExpr GhcPs)
genMetadata QualifiedNames
names Record
r DynFlags
dynFlags
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
from     <- QualifiedNames -> Record -> m (LHsExpr GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsExpr GhcPs)
genFrom     QualifiedNames
names Record
r
    GenLocated SrcSpanAnnA (HsExpr GhcPs)
to       <- QualifiedNames -> Record -> m (LHsExpr GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
QualifiedNames -> Record -> m (LHsExpr GhcPs)
genTo       QualifiedNames
names Record
r
    LHsDecl GhcPs -> m (LHsDecl GhcPs)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LHsDecl GhcPs -> m (LHsDecl GhcPs))
-> LHsDecl GhcPs -> m (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
      [LHsType GhcPs]
-> LHsType GhcPs
-> [(LRdrName, LHsExpr GhcPs)]
-> [LTyFamInstDecl GhcPs]
-> LHsDecl GhcPs
instanceD
        []
        (HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
type_LR_Generic LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` Record -> LHsType GhcPs
recordTypeT Record
r)
        [ ( LRdrName
lr_from     , LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
from                         )
        , ( LRdrName
lr_to       , LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
to                           )
        , ( LRdrName
lr_dict     , HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameDictConstraints Record
r) )
        , ( LRdrName
lr_metadata , LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
metadata                     )
        ]
        [ LRdrName
-> [LHsType GhcPs] -> LHsType GhcPs -> LTyFamInstDecl GhcPs
tySynEqn LRdrName
type_LR_Constraints [Record -> LHsType GhcPs
recordTypeT Record
r] (LHsType GhcPs -> LTyFamInstDecl GhcPs)
-> LHsType GhcPs -> LTyFamInstDecl GhcPs
forall a b. (a -> b) -> a -> b
$
            LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
appsT
              (HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT (Record -> LRdrName
nameConstraints Record
r))
              [HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
VarT (LHsTyVarBndr GhcPs -> LRdrName
tyVarBndrName LHsTyVarBndr GhcPs
GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
v) | GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
v <- [LHsTyVarBndr GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
recordTyVars]
        , LRdrName
-> [LHsType GhcPs] -> LHsType GhcPs -> LTyFamInstDecl GhcPs
tySynEqn LRdrName
type_LR_MetadataOf [Record -> LHsType GhcPs
recordTypeT Record
r] (LHsType GhcPs -> LTyFamInstDecl GhcPs)
-> LHsType GhcPs -> LTyFamInstDecl GhcPs
forall a b. (a -> b) -> a -> b
$
            [LHsType GhcPs] -> LHsType GhcPs
listT [
                NonEmpty (LHsType GhcPs) -> LHsType GhcPs
tupT (NonEmpty (LHsType GhcPs) -> LHsType GhcPs)
-> NonEmpty (LHsType GhcPs) -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ String -> LHsType GhcPs
stringT (LRdrName -> String
nameBase LRdrName
fieldName) GenLocated SrcSpanAnnA (HsType GhcPs)
-> [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> NonEmpty (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. a -> [a] -> NonEmpty a
:| [LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
fieldType]
              | Field{Int
LHsType GhcPs
LRdrName
HsSrcBang
fieldType :: Field -> LHsType GhcPs
fieldName :: Field -> LRdrName
fieldStrictness :: Field -> HsSrcBang
fieldIndex :: Field -> Int
fieldName :: LRdrName
fieldType :: LHsType GhcPs
fieldStrictness :: HsSrcBang
fieldIndex :: Int
..} <- [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]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} = [m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM [
      QualifiedNames -> Record -> StockDeriving -> m [LHsDecl GhcPs]
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
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
..} Record
r = [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
 -> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> (StockDeriving -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> StockDeriving
-> m [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    StockDeriving
Show    -> [LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs
mkInstance LRdrName
prelude_type_Show LRdrName
prelude_showsPrec LRdrName
gshowsPrec]
    StockDeriving
Eq      -> [LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs
mkInstance LRdrName
prelude_type_Eq   LRdrName
prelude_eq        LRdrName
geq       ]
    StockDeriving
Ord     -> [LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs
mkInstance LRdrName
prelude_type_Ord  LRdrName
prelude_compare   LRdrName
gcompare  ]
    StockDeriving
Generic -> []
  where
    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
LRdrName -> LHsType GhcPs
ConT LRdrName
cls))
          (HasCallStack => LRdrName -> LHsType GhcPs
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
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
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
..} Record
r = LHsDecl GhcPs -> m (LHsDecl GhcPs)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (LHsDecl GhcPs -> m (LHsDecl GhcPs))
-> LHsDecl GhcPs -> m (LHsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
    [LHsType GhcPs]
-> LHsType GhcPs
-> [(LRdrName, LHsExpr GhcPs)]
-> [LTyFamInstDecl GhcPs]
-> LHsDecl GhcPs
instanceD
      []
      (HasCallStack => LRdrName -> LHsType GhcPs
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
LRdrName -> LHsExpr GhcPs
VarE LRdrName
wrapThroughLRGenerics   )
      , ( LRdrName
ghc_to   , HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
unwrapThroughLRGenerics )
      ]
      [ LRdrName
-> [LHsType GhcPs] -> LHsType GhcPs -> LTyFamInstDecl GhcPs
tySynEqn LRdrName
type_GHC_Rep [Record -> LHsType GhcPs
recordTypeT Record
r] (LHsType GhcPs -> LTyFamInstDecl GhcPs)
-> LHsType GhcPs -> LTyFamInstDecl GhcPs
forall a b. (a -> b) -> a -> b
$
          HasCallStack => LRdrName -> LHsType GhcPs
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]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} =
    HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
recordTyName LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs
`appsT` [HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
VarT (LHsTyVarBndr GhcPs -> LRdrName
tyVarBndrName LHsTyVarBndr GhcPs
GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
f) | GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)
f <- [LHsTyVarBndr GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)]
recordTyVars]

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

nameRecord :: Record -> String
nameRecord :: Record -> String
nameRecord Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
LRdrName
SrcSpan
LargeRecordOptions
recordTyName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordConName :: Record -> LRdrName
recordFields :: Record -> [Field]
recordDerivings :: Record -> [RecordDeriving]
recordOptions :: Record -> LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordTyName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordConName :: LRdrName
recordFields :: [Field]
recordDerivings :: [RecordDeriving]
recordOptions :: LargeRecordOptions
recordAnnLoc :: SrcSpan
..} = 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 String -> String -> String
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
prelude_type_Eq :: QualifiedNames -> LRdrName
prelude_type_Ord :: QualifiedNames -> LRdrName
prelude_type_Show :: QualifiedNames -> LRdrName
prelude_compare :: QualifiedNames -> LRdrName
prelude_eq :: QualifiedNames -> LRdrName
prelude_showsPrec :: QualifiedNames -> LRdrName
type_Constraint :: QualifiedNames -> LRdrName
type_GHC_Generic :: QualifiedNames -> LRdrName
type_GHC_Rep :: QualifiedNames -> LRdrName
type_Int :: QualifiedNames -> LRdrName
type_Proxy :: QualifiedNames -> LRdrName
type_Type :: QualifiedNames -> LRdrName
error :: QualifiedNames -> LRdrName
ghc_from :: QualifiedNames -> LRdrName
ghc_to :: QualifiedNames -> LRdrName
proxy :: QualifiedNames -> LRdrName
type_AnyArray :: QualifiedNames -> LRdrName
anyArrayFromList :: QualifiedNames -> LRdrName
anyArrayToList :: QualifiedNames -> LRdrName
anyArrayIndex :: QualifiedNames -> LRdrName
anyArrayUpdate :: QualifiedNames -> LRdrName
type_LR_Generic :: QualifiedNames -> LRdrName
type_LR_MetadataOf :: QualifiedNames -> LRdrName
type_LR_Constraints :: QualifiedNames -> LRdrName
lr_from :: QualifiedNames -> LRdrName
lr_to :: QualifiedNames -> LRdrName
lr_dict :: QualifiedNames -> LRdrName
lr_metadata :: QualifiedNames -> LRdrName
type_Rep :: QualifiedNames -> LRdrName
type_Dict :: QualifiedNames -> LRdrName
gcompare :: QualifiedNames -> LRdrName
geq :: QualifiedNames -> LRdrName
gshowsPrec :: QualifiedNames -> LRdrName
noInlineUnsafeCo :: QualifiedNames -> LRdrName
anyArrayToRep :: QualifiedNames -> LRdrName
anyArrayFromRep :: QualifiedNames -> LRdrName
mkDicts :: QualifiedNames -> LRdrName
mkDict :: QualifiedNames -> LRdrName
mkStrictField :: QualifiedNames -> LRdrName
mkLazyField :: QualifiedNames -> LRdrName
mkMetadata :: QualifiedNames -> LRdrName
type_ThroughLRGenerics :: QualifiedNames -> LRdrName
wrapThroughLRGenerics :: QualifiedNames -> LRdrName
unwrapThroughLRGenerics :: QualifiedNames -> LRdrName
type_HasField :: QualifiedNames -> LRdrName
hasField :: QualifiedNames -> LRdrName
prelude_type_Eq :: LRdrName
prelude_type_Ord :: LRdrName
prelude_type_Show :: LRdrName
prelude_compare :: LRdrName
prelude_eq :: LRdrName
prelude_showsPrec :: LRdrName
type_Constraint :: LRdrName
type_GHC_Generic :: LRdrName
type_GHC_Rep :: LRdrName
type_Int :: LRdrName
type_Proxy :: LRdrName
type_Type :: LRdrName
error :: LRdrName
ghc_from :: LRdrName
ghc_to :: LRdrName
proxy :: LRdrName
type_AnyArray :: LRdrName
anyArrayFromList :: LRdrName
anyArrayToList :: LRdrName
anyArrayIndex :: LRdrName
anyArrayUpdate :: LRdrName
type_LR_Generic :: LRdrName
type_LR_MetadataOf :: LRdrName
type_LR_Constraints :: LRdrName
lr_from :: LRdrName
lr_to :: LRdrName
lr_dict :: LRdrName
lr_metadata :: LRdrName
type_Rep :: LRdrName
type_Dict :: LRdrName
gcompare :: LRdrName
geq :: LRdrName
gshowsPrec :: LRdrName
noInlineUnsafeCo :: LRdrName
anyArrayToRep :: LRdrName
anyArrayFromRep :: LRdrName
mkDicts :: LRdrName
mkDict :: LRdrName
mkStrictField :: LRdrName
mkLazyField :: LRdrName
mkMetadata :: LRdrName
type_ThroughLRGenerics :: LRdrName
wrapThroughLRGenerics :: LRdrName
unwrapThroughLRGenerics :: LRdrName
type_HasField :: LRdrName
hasField :: LRdrName
..} LHsType GhcPs
ty =
    LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
sigE (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
proxy) (HasCallStack => LRdrName -> LHsType GhcPs
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 = ([[a]] -> [a]) -> m [[a]] -> m [a]
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [[a]] -> [a]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat (m [[a]] -> m [a]) -> ([m [a]] -> m [[a]]) -> [m [a]] -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [m [a]] -> m [[a]]
forall (t :: Type -> Type) (f :: Type -> Type) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: Type -> Type) a. Applicative f => [f a] -> f [a]
sequenceA