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

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

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

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

import qualified Data.Generics as SYB

import Data.Record.Internal.GHC.Fresh
import Data.Record.Internal.GHC.Shim hiding (mkTyVar)
import Data.Record.Internal.GHC.TemplateHaskellStyle
import Data.Record.Internal.Plugin.Record

import qualified Data.Record.Internal.Plugin.Names.GhcGenerics as GHC
import qualified Data.Record.Internal.Plugin.Names.Runtime     as RT

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

-- | Generate all large-records definitions for a record.
genLargeRecord :: MonadFresh m => Record -> DynFlags -> m [LHsDecl GhcPs]
genLargeRecord :: Record -> DynFlags -> m [LHsDecl GhcPs]
genLargeRecord r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
..} DynFlags
dynFlags = [m [LHsDecl GhcPs]] -> m [LHsDecl GhcPs]
forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM [
      (LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. a -> [a] -> [a]
:[]) (LHsDecl GhcPs -> [LHsDecl GhcPs])
-> m (LHsDecl GhcPs) -> m [LHsDecl 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
    , Record -> m [LHsDecl GhcPs]
forall (m :: Type -> Type).
MonadFresh m =>
Record -> m [LHsDecl GhcPs]
genVectorConversions  Record
r
    , Record -> m [LHsDecl GhcPs]
forall (m :: Type -> Type).
MonadFresh m =>
Record -> m [LHsDecl GhcPs]
genIndexedAccessor    Record
r
    , Record -> m [LHsDecl GhcPs]
forall (m :: Type -> Type).
MonadFresh m =>
Record -> m [LHsDecl GhcPs]
genUnsafeSetIndex     Record
r
    , Record -> m [LHsDecl GhcPs]
forall (m :: Type -> Type).
MonadFresh m =>
Record -> m [LHsDecl GhcPs]
genStockInstances     Record
r
    , (Field -> m (LHsDecl GhcPs)) -> [Field] -> m [LHsDecl GhcPs]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Record -> Field -> m (LHsDecl GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
Record -> Field -> m (LHsDecl GhcPs)
genHasFieldInstance Record
r) [Field]
recordFields
    , [m (LHsDecl GhcPs)] -> m [LHsDecl GhcPs]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
          Record -> m (LHsDecl GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
Record -> m (LHsDecl GhcPs)
genConstraintsClass    Record
r
        , Record -> m (LHsDecl GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
Record -> m (LHsDecl GhcPs)
genConstraintsInstance Record
r
        , Record -> DynFlags -> m (LHsDecl GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
Record -> DynFlags -> m (LHsDecl GhcPs)
genGenericInstance     Record
r DynFlags
dynFlags
        , Record -> m (LHsDecl GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
Record -> m (LHsDecl GhcPs)
genGHCGeneric          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 :: Record -> m (LHsDecl GhcPs)
genDatatype Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = LHsDecl GhcPs -> m (LHsDecl GhcPs)
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 -> LHsType GhcPs)
-> [LRdrName] -> [Field] -> [LHsType GhcPs]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith LRdrName -> Field -> LHsType GhcPs
fieldContext [LRdrName]
vars [Field]
recordFields)
          LRdrName
recordConName
          ((LRdrName -> Field -> (LRdrName, LHsType GhcPs))
-> [LRdrName] -> [Field] -> [(LRdrName, LHsType GhcPs)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith LRdrName -> Field -> (LRdrName, LHsType GhcPs)
fieldExistentialType [LRdrName]
vars [Field]
recordFields)

      ]
      [ Maybe (LDerivStrategy GhcPs)
-> NonEmpty (LHsType GhcPs) -> LHsDerivingClause GhcPs
DerivClause (LDerivStrategy GhcPs -> Maybe (LDerivStrategy GhcPs)
forall a. a -> Maybe a
Just (SrcSpanLess (LDerivStrategy GhcPs) -> LDerivStrategy GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (DerivStrategy GhcPs -> DerivStrategy GhcPs
forall a. a -> a
withDefExt DerivStrategy GhcPs
forall pass. DerivStrategy pass
AnyclassStrategy))) (LHsType GhcPs
c LHsType GhcPs -> [LHsType GhcPs] -> NonEmpty (LHsType 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 -> LHsType GhcPs
forall e. e -> Located e
noLocA (HsType GhcPs -> LHsType GhcPs)
-> (LHsType GhcPs -> HsType GhcPs)
-> LHsType GhcPs
-> LHsType 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
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 => Record -> m [LHsDecl GhcPs]
genVectorConversions :: Record -> m [LHsDecl GhcPs]
genVectorConversions r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = [m [LHsDecl GhcPs]] -> m [LHsDecl GhcPs]
forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM [
      m [LHsDecl GhcPs]
fromVector
    , m [LHsDecl 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)
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
        [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
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
RT.type_SmallArray LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
RT.type_Any)
          , 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 -> Located (Pat GhcPs))
-> [LRdrName] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LRdrName -> LPat GhcPs
LRdrName -> Located (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
RT.smallArrayFromList)
                  ([LHsExpr GhcPs] -> LHsExpr GhcPs
listE [ HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
RT.unsafeCoerce 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)
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
        [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
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
$ [
            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
RT.type_SmallArray LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
RT.type_Any)
                (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
RT.smallArrayToList LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
`appE` HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
x)
                  [ ( [LPat GhcPs] -> LPat GhcPs
listP ((LRdrName -> Located (Pat GhcPs))
-> [LRdrName] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LRdrName -> LPat GhcPs
LRdrName -> Located (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
RT.unsafeCoerce 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
RT.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 => Record -> m [LHsDecl GhcPs]
genIndexedAccessor :: Record -> m [LHsDecl GhcPs]
genIndexedAccessor r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
    LRdrName
x <- 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
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"
    [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
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
RT.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 Located (Pat GhcPs)
-> [Located (Pat GhcPs)] -> NonEmpty (Located (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
RT.noInlineUnsafeCo)
              (LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE
                 (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
RT.indexSmallArray)
                 [ 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 => Record -> m [LHsDecl GhcPs]
genUnsafeSetIndex :: Record -> m [LHsDecl GhcPs]
genUnsafeSetIndex r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
    LRdrName
x   <- 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
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"
    [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
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
RT.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 Located (Pat GhcPs)
-> [Located (Pat GhcPs)] -> NonEmpty (Located (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
RT.updateSmallArray)
                 [ 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
                         LHsExpr GhcPs -> [LHsExpr GhcPs] -> NonEmpty (LHsExpr GhcPs)
forall a. a -> [a] -> NonEmpty a
:| [HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
RT.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 => Record -> Field -> m (LHsDecl GhcPs)
genHasFieldInstance :: Record -> Field -> m (LHsDecl GhcPs)
genHasFieldInstance r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} Field{Int
HsSrcBang
LHsType GhcPs
LRdrName
fieldIndex :: Field -> Int
fieldIndex :: Int
fieldStrictness :: HsSrcBang
fieldType :: LHsType GhcPs
fieldName :: LRdrName
fieldStrictness :: Field -> HsSrcBang
fieldName :: Field -> LRdrName
fieldType :: Field -> LHsType GhcPs
..} = do
    LRdrName
x <- 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
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 (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
RT.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
RT.unq_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]
                LHsExpr GhcPs -> [LHsExpr GhcPs] -> NonEmpty (LHsExpr 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 => Record -> m (LHsDecl GhcPs)
genConstraintsClass :: Record -> m (LHsDecl GhcPs)
genConstraintsClass r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
    LRdrName
c <- 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
mkTyVar SrcSpan
recordAnnLoc String
"c"
    LHsDecl GhcPs -> m (LHsDecl GhcPs)
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]
recordTyVars [LHsTyVarBndr GhcPs]
-> [LHsTyVarBndr GhcPs] -> [LHsTyVarBndr 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
RT.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
RT.type_Rep)
               [ HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
RT.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
RT.type_Type LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`funT` HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
RT.type_Constraint

-- | Superclass constraints required by the constraints class instance
--
-- Generates something like
--
-- > (c Word, c Bool, c Char, c a, c [b])
--
-- However, we filter out constraints that are type variable free, so if we
-- pass, say, @Show@ for @c@, then we generate
--
-- > (Show a, Show [b])
--
-- instead. This avoids @ghc@ complaining about
--
-- > Redundant constraints: (Show Word, Show Bool, Show Char)
genRequiredConstraints :: Record -> LHsType GhcPs -> [LHsType GhcPs]
genRequiredConstraints :: Record -> LHsType GhcPs -> [LHsType GhcPs]
genRequiredConstraints Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} LHsType GhcPs
c =
    (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 -> LHsType GhcPs) -> [Field] -> [LHsType GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map Field -> LHsType GhcPs
constrainField [Field]
recordFields
  where
    constrainField :: Field -> LHsType GhcPs
    constrainField :: Field -> LHsType GhcPs
constrainField Field{Int
HsSrcBang
LHsType GhcPs
LRdrName
fieldIndex :: Int
fieldStrictness :: HsSrcBang
fieldType :: LHsType GhcPs
fieldName :: LRdrName
fieldIndex :: Field -> Int
fieldStrictness :: Field -> HsSrcBang
fieldName :: Field -> LRdrName
fieldType :: Field -> LHsType GhcPs
..} = LHsType GhcPs
c LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` LHsType GhcPs
fieldType

    sameType :: LHsType GhcPs -> LHsType GhcPs -> Bool
    sameType :: LHsType GhcPs -> LHsType GhcPs -> Bool
sameType = LHsType GhcPs -> LHsType GhcPs -> Bool
forall a. Data a => a -> a -> Bool
compareHs

    hasTypeVar :: LHsType GhcPs -> Bool
    hasTypeVar :: LHsType GhcPs -> Bool
hasTypeVar = Bool -> Bool
not (Bool -> Bool) -> (LHsType GhcPs -> Bool) -> LHsType GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null ([String] -> Bool)
-> (LHsType GhcPs -> [String]) -> LHsType GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType 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] -> (LHsType GhcPs -> [String]) -> a -> [String]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
SYB.mkQ [] LHsType GhcPs -> [String]
isTypeVar)

    isTypeVar :: LHsType GhcPs -> [String]
    isTypeVar :: LHsType GhcPs -> [String]
isTypeVar (VarT (TyVar String
name)) = [String
name]
    isTypeVar LHsType GhcPs
_otherwise          = []

-- | Generate the dictionary creation function ('dict')
--
-- Generates something like
--
-- > \p -> Rep (V.fromList [
-- >     noInlineUnsafeCo (dictFor p (Proxy :: Proxy Word))
-- >   , noInlineUnsafeCo (dictFor p (Proxy :: Proxy Bool))
-- >   , noInlineUnsafeCo (dictFor p (Proxy :: Proxy Char))
-- >   , noInlineUnsafeCo (dictFor p (Proxy :: Proxy a))
-- >   , noInlineUnsafeCo (dictFor p (Proxy :: Proxy [b]))
-- >   ])
genDict :: MonadFresh m => Record -> m (LHsExpr GhcPs)
genDict :: Record -> m (LHsExpr GhcPs)
genDict Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
    LRdrName
p <- 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"
    LHsExpr GhcPs -> m (LHsExpr GhcPs)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr 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
ConE LRdrName
RT.con_Rep)
          (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
             (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
RT.smallArrayFromList)
             ([LHsExpr GhcPs] -> LHsExpr GhcPs
listE ((Field -> LHsExpr GhcPs) -> [Field] -> [LHsExpr 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
HsSrcBang
LHsType GhcPs
LRdrName
fieldIndex :: Int
fieldStrictness :: HsSrcBang
fieldType :: LHsType GhcPs
fieldName :: LRdrName
fieldIndex :: Field -> Int
fieldStrictness :: Field -> HsSrcBang
fieldName :: Field -> LRdrName
fieldType :: Field -> LHsType GhcPs
..} =
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
          (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
RT.noInlineUnsafeCo)
          (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
RT.dictFor LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
`appsE` [HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
p, LHsType GhcPs -> LHsExpr GhcPs
proxyE 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 => Record -> m (LHsDecl GhcPs)
genConstraintsInstance :: Record -> m (LHsDecl GhcPs)
genConstraintsInstance r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
    LHsExpr GhcPs
body <- Record -> m (LHsExpr GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
Record -> m (LHsExpr GhcPs)
genDict Record
r
    LRdrName
c    <- 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
mkTyVar SrcSpan
recordAnnLoc String
"c"
    LHsDecl GhcPs -> m (LHsDecl GhcPs)
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
v) | LHsTyVarBndr GhcPs
v <- [LHsTyVarBndr GhcPs]
recordTyVars] [LHsType GhcPs] -> [LHsType GhcPs] -> [LHsType GhcPs]
forall a. [a] -> [a] -> [a]
++ [HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
VarT LRdrName
c]))
        [(Record -> LRdrName
nameDictConstraints Record
r, LHsExpr 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 => Record -> DynFlags -> m (LHsExpr GhcPs)
genMetadata :: Record -> DynFlags -> m (LHsExpr GhcPs)
genMetadata r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} DynFlags
dynFlags = do
    LRdrName
p <- 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"
    LHsExpr GhcPs -> m (LHsExpr GhcPs)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr 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
$
        LRdrName -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs
recConE
          LRdrName
RT.con_Metadata [
              ( LRdrName
RT.recordName
              , String -> LHsExpr GhcPs
stringE (Record -> String
nameRecord Record
r)
              )
            , ( LRdrName
RT.recordConstructor
              , String -> LHsExpr GhcPs
stringE (LRdrName -> String
nameBase LRdrName
recordConName)
              )
            , ( LRdrName
RT.recordSize
              , Int -> LHsExpr GhcPs
forall a. Integral a => a -> LHsExpr GhcPs
intE ([Field] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Field]
recordFields)
              )
            , ( LRdrName
RT.recordFieldMetadata
              , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
                  (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
ConE LRdrName
RT.con_Rep)
                  (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
appE
                     (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
RT.smallArrayFromList)
                     ([LHsExpr GhcPs] -> LHsExpr GhcPs
listE ((Field -> LHsExpr GhcPs) -> [Field] -> [LHsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map Field -> LHsExpr GhcPs
auxField [Field]
recordFields))
                  )
              )
            ]
  where
    auxField :: Field -> LHsExpr GhcPs
    auxField :: Field -> LHsExpr GhcPs
auxField Field{Int
HsSrcBang
LHsType GhcPs
LRdrName
fieldIndex :: Int
fieldStrictness :: HsSrcBang
fieldType :: LHsType GhcPs
fieldName :: LRdrName
fieldIndex :: Field -> Int
fieldStrictness :: Field -> HsSrcBang
fieldName :: Field -> LRdrName
fieldType :: Field -> LHsType GhcPs
..} =
        LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
appsE
          (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
ConE LRdrName
RT.con_FieldMetadata)
          [ LHsType GhcPs -> LHsExpr GhcPs
proxyE (String -> LHsType GhcPs
stringT (LRdrName -> String
nameBase LRdrName
fieldName))
          , HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
ConE (LRdrName -> LHsExpr GhcPs) -> LRdrName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ case DynFlags -> HsSrcBang -> HsImplBang
decideStrictness DynFlags
dynFlags HsSrcBang
fieldStrictness of
              HsImplBang
HsStrict                  -> LRdrName
RT.con_FieldStrict
              HsImplBang
HsLazy                    -> LRdrName
RT.con_FieldLazy
              HsUnpack Maybe Coercion
_                -> LRdrName
RT.con_FieldStrict
          ]

-- | Implementation of https://hackage.haskell.org/package/base-4.16.1.0/docs/GHC-Generics.html#t:DecidedStrictness
decideStrictness :: DynFlags -> HsSrcBang -> HsImplBang
decideStrictness :: DynFlags -> HsSrcBang -> HsImplBang
decideStrictness DynFlags
dynFlags (HsSrcBang SourceText
_ SrcUnpackedness
unpackedness SrcStrictness
strictness) =
  case (SrcUnpackedness
unpackedness, SrcStrictness -> HsImplBang
srcToImpl SrcStrictness
strictness) of
    (SrcUnpackedness
SrcUnpack, HsImplBang
HsStrict) | Bool
optimizations -> Maybe Coercion -> HsImplBang
HsUnpack Maybe Coercion
forall a. Maybe a
Nothing
    (SrcUnpackedness
_, HsImplBang
strictness') -> HsImplBang
strictness'
  where
    strictData :: Bool
strictData = Extension -> DynFlags -> Bool
xopt Extension
StrictData DynFlags
dynFlags
    optimizations :: Bool
optimizations = DynFlags -> Int
optLevel DynFlags
dynFlags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
    srcToImpl :: SrcStrictness -> HsImplBang
srcToImpl = \case
      SrcStrictness
SrcStrict -> HsImplBang
HsStrict
      SrcStrictness
SrcLazy -> HsImplBang
HsLazy
      SrcStrictness
NoSrcStrict -> if Bool
strictData then HsImplBang
HsStrict else HsImplBang
HsLazy

-- | Generate definition for `from` in the `Generic` instance
--
-- Generates something like
--
-- > repFromVectorStrict . vectorFromT
genFrom :: MonadFresh m => Record -> m (LHsExpr GhcPs)
genFrom :: Record -> m (LHsExpr GhcPs)
genFrom r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
    LRdrName
x <- 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"
    LHsExpr GhcPs -> m (LHsExpr GhcPs)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr 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
RT.repFromVector 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 => Record -> m (LHsExpr GhcPs)
genTo :: Record -> m (LHsExpr GhcPs)
genTo r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = do
    LRdrName
x <- 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"
    LHsExpr GhcPs -> m (LHsExpr GhcPs)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr 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
RT.repToVector 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 => Record -> DynFlags -> m (LHsDecl GhcPs)
genGenericInstance :: Record -> DynFlags -> m (LHsDecl GhcPs)
genGenericInstance r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} DynFlags
dynFlags  = do
    LHsExpr GhcPs
metadata <- Record -> DynFlags -> m (LHsExpr GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
Record -> DynFlags -> m (LHsExpr GhcPs)
genMetadata Record
r DynFlags
dynFlags
    LHsExpr GhcPs
from     <- Record -> m (LHsExpr GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
Record -> m (LHsExpr GhcPs)
genFrom     Record
r
    LHsExpr GhcPs
to       <- Record -> m (LHsExpr GhcPs)
forall (m :: Type -> Type).
MonadFresh m =>
Record -> m (LHsExpr GhcPs)
genTo       Record
r
    LHsDecl GhcPs -> m (LHsDecl GhcPs)
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
RT.type_Generic LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` Record -> LHsType GhcPs
recordTypeT Record
r)
        [ ( LRdrName
RT.unq_from     , LHsExpr GhcPs
from                         )
        , ( LRdrName
RT.unq_to       , LHsExpr GhcPs
to                           )
        , ( LRdrName
RT.unq_dict     , HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE (Record -> LRdrName
nameDictConstraints Record
r) )
        , ( LRdrName
RT.unq_metadata , LHsExpr GhcPs
metadata                     )
        ]
        [ LRdrName
-> [LHsType GhcPs] -> LHsType GhcPs -> LTyFamInstDecl GhcPs
tySynEqn LRdrName
RT.unq_type_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
v) | LHsTyVarBndr GhcPs
v <- [LHsTyVarBndr GhcPs]
recordTyVars]
        , LRdrName
-> [LHsType GhcPs] -> LHsType GhcPs -> LTyFamInstDecl GhcPs
tySynEqn LRdrName
RT.unq_type_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) LHsType GhcPs -> [LHsType GhcPs] -> NonEmpty (LHsType GhcPs)
forall a. a -> [a] -> NonEmpty a
:| [LHsType GhcPs
fieldType]
              | Field{Int
HsSrcBang
LHsType GhcPs
LRdrName
fieldIndex :: Int
fieldStrictness :: HsSrcBang
fieldType :: LHsType GhcPs
fieldName :: LRdrName
fieldIndex :: Field -> Int
fieldStrictness :: Field -> HsSrcBang
fieldName :: Field -> LRdrName
fieldType :: Field -> LHsType GhcPs
..} <- [Field]
recordFields
              ]
        ]
  where

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

-- | Generate stock instances
genStockInstances :: MonadFresh m => Record -> m [LHsDecl GhcPs]
genStockInstances :: Record -> m [LHsDecl GhcPs]
genStockInstances r :: Record
r@Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = [m [LHsDecl GhcPs]] -> m [LHsDecl GhcPs]
forall (m :: Type -> Type) a. Applicative m => [m [a]] -> m [a]
concatM [
      Record -> StockDeriving -> m [LHsDecl GhcPs]
forall (m :: Type -> Type).
MonadFresh m =>
Record -> StockDeriving -> m [LHsDecl GhcPs]
genStockInstance 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 => Record -> StockDeriving -> m [LHsDecl GhcPs]
genStockInstance :: Record -> StockDeriving -> m [LHsDecl GhcPs]
genStockInstance Record
r = [LHsDecl GhcPs] -> m [LHsDecl GhcPs]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([LHsDecl GhcPs] -> m [LHsDecl GhcPs])
-> (StockDeriving -> [LHsDecl GhcPs])
-> StockDeriving
-> m [LHsDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    StockDeriving
Show    -> [LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs
mkInstance LRdrName
RT.type_Show LRdrName
RT.unq_showsPrec LRdrName
RT.gshowsPrec]
    StockDeriving
Eq      -> [LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs
mkInstance LRdrName
RT.type_Eq   LRdrName
RT.unq_eq        LRdrName
RT.geq       ]
    StockDeriving
Ord     -> [LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs
mkInstance LRdrName
RT.type_Ord  LRdrName
RT.unq_compare   LRdrName
RT.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 => Record -> m (LHsDecl GhcPs)
genGHCGeneric :: Record -> m (LHsDecl GhcPs)
genGHCGeneric Record
r = LHsDecl GhcPs -> m (LHsDecl GhcPs)
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
GHC.type_Generic LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` Record -> LHsType GhcPs
recordTypeT Record
r)
      [ ( LRdrName
GHC.unq_from , HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
ConE LRdrName
RT.con_WrapThroughLRGenerics )
      , ( LRdrName
GHC.unq_to   , HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
VarE LRdrName
RT.unwrapThroughLRGenerics   )
      ]
      [ LRdrName
-> [LHsType GhcPs] -> LHsType GhcPs -> LTyFamInstDecl GhcPs
tySynEqn LRdrName
GHC.unq_type_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
RT.type_ThroughLRGenerics LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` Record -> LHsType GhcPs
recordTypeT Record
r
      ]

{-------------------------------------------------------------------------------
  Auxiliary functions for dealing with records
-------------------------------------------------------------------------------}

-- | The saturated type of the record (that is, with all type vars applied)
recordTypeT :: Record -> LHsType GhcPs
recordTypeT :: Record -> LHsType GhcPs
recordTypeT Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} =
    HasCallStack => LRdrName -> LHsType GhcPs
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
f) | LHsTyVarBndr GhcPs
f <- [LHsTyVarBndr GhcPs]
recordTyVars]

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

nameRecord :: Record -> String
nameRecord :: Record -> String
nameRecord Record{[LHsTyVarBndr GhcPs]
[RecordDeriving]
[Field]
SrcSpan
LRdrName
LargeRecordOptions
recordAnnLoc :: SrcSpan
recordOptions :: LargeRecordOptions
recordDerivings :: [RecordDeriving]
recordFields :: [Field]
recordConName :: LRdrName
recordTyVars :: [LHsTyVarBndr GhcPs]
recordTyName :: LRdrName
recordAnnLoc :: Record -> SrcSpan
recordOptions :: Record -> LargeRecordOptions
recordDerivings :: Record -> [RecordDeriving]
recordFields :: Record -> [Field]
recordConName :: Record -> LRdrName
recordTyVars :: Record -> [LHsTyVarBndr GhcPs]
recordTyName :: Record -> LRdrName
..} = LRdrName -> String
nameBase LRdrName
recordTyName

-- | Make name derived from the name of the record
mkDerived :: (SrcSpan -> String -> LRdrName) -> String -> Record -> LRdrName
mkDerived :: (SrcSpan -> String -> LRdrName) -> String -> Record -> LRdrName
mkDerived SrcSpan -> String -> LRdrName
f String
prefix Record
r = SrcSpan -> String -> LRdrName
f (Record -> SrcSpan
recordAnnLoc Record
r) (String
prefix 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 :: LHsType GhcPs -> LHsExpr GhcPs
proxyE :: LHsType GhcPs -> LHsExpr GhcPs
proxyE LHsType GhcPs
ty = LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
sigE (HasCallStack => LRdrName -> LHsExpr GhcPs
LRdrName -> LHsExpr GhcPs
ConE LRdrName
RT.con_Proxy) (HasCallStack => LRdrName -> LHsType GhcPs
LRdrName -> LHsType GhcPs
ConT LRdrName
RT.type_Proxy LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs
`appT` LHsType GhcPs
ty)

concatM :: Applicative m => [m [a]] -> m [a]
concatM :: [m [a]] -> m [a]
concatM = ([[a]] -> [a]) -> m [[a]] -> m [a]
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)
sequenceA