{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DerivingVia #-}
{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}
-- | Shared substrate for the Stock plugin: environments, the representation
-- EDSL, Core/dictionary builders, the variance walk, and the @Solver@ monoid.
module Stock.Internal (module Stock.Internal) where
-- Most names below (data-con/type builders, coercion builders, occ-name
-- helpers, …) are re-exported by 'GHC.Plugins', so we only import explicitly
-- the ones it does not provide.
import GHC.Plugins hiding (TcPlugin)
import GHC.Tc.Plugin
import GHC.Tc.Types
import GHC.Tc.Types.Constraint
#if MIN_VERSION_ghc(9,12,0)
import GHC.Tc.Types.CtLoc (CtLoc)
#else
import GHC.Tc.Types.Constraint (CtLoc)
#endif
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad (addErrTc)
import GHC.Tc.Errors.Types (mkTcRnUnknownMessage)
import GHC.Types.Error (mkPlainError, noHints)
import GHC.Core.Class (Class, className, classMethods, classOpItems, classTyCon)
import GHC.Core.Predicate (classifyPredType, Pred(ClassPred), mkClassPred)
#if MIN_VERSION_ghc(9,14,0)
import GHC.Core.Predicate (mkReprEqPred)
#else
import GHC.Core.Predicate (mkReprPrimEqPred)
#endif
import GHC.Builtin.Types (promotedConsDataCon, promotedNilDataCon, unitTy)
import GHC.Builtin.Types.Prim (intPrimTy)
import GHC.Builtin.PrimOps (PrimOp(TagToEnumOp))
import GHC.Builtin.PrimOps.Ids (primOpId)
import GHC.Builtin.Names ( eqClassName, ordClassName, appendName
                         , enumClassName, mapName, numClassName
                         , enumFromToName, enumFromThenToName
                         , eqStringName
                         , genClassName, repTyConName, u1TyConName, k1TyConName
                         , prodTyConName, sumTyConName
                         , monoidClassName, foldableClassName, functorClassName
                         , semigroupClassName, monadClassName )
import Stock.Compat ( gHC_INTERNAL_SHOW, gHC_INTERNAL_READ
                    , gHC_INTERNAL_LIST, gHC_INTERNAL_GENERICS
                    , tEXT_READPREC, tEXT_READ_LEX )
import GHC.Core.Reduction (mkReduction)
import GHC.Core.TyCo.Rep (UnivCoProvenance(PluginProv))
import GHC.Rename.Fixity (lookupFixityRn)
import GHC.Types.Fixity (Fixity(..), defaultFixity, FixityDirection(..))
import GHC.Types.SourceText (SourceText(NoSourceText))
import GHC.Core.DataCon (dataConSrcBangs, dataConImplBangs, HsSrcBang(..), HsImplBang(..), SrcStrictness(..), SrcUnpackedness(..))
import GHC.Core.TyCo.Compare (eqType)
import GHC.Core.Multiplicity (scaledThing)
import GHC.Core.SimpleOpt (defaultSimpleOpts)
import GHC.Core.Unfold.Make (mkInlineUnfoldingWithArity)
import GHC.Core.InstEnv (classInstances, is_dfun, is_tys)
import GHC.Runtime.Loader (getValueSafely)
import Stock.Derive
import Data.Maybe (catMaybes, fromJust, isJust, fromMaybe, listToMaybe)
import Data.List (zipWith4)
import Data.Traversable (for)
import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'
import Stock.Trans (MaybeT(..))
import Control.Monad (zipWithM, unless, guard)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef')
-- | Entities looked up once for @Generic@ synthesis: the @Generic@ class, the
-- @Rep@ family, and the representation pieces @U1@, @K1@/@Rec0@ and @:*:@.
data GenEnv = GenEnv
  { GenEnv -> Maybe TyCon
geStock   :: Maybe TyCon  -- ^ our @Stock.Stock@ ('Nothing' if not in scope)
  , GenEnv -> Maybe TyCon
geStock1  :: Maybe TyCon  -- ^ our @Stock.Stock1@
  , GenEnv -> Maybe TyCon
geStock2  :: Maybe TyCon  -- ^ our @Stock.Stock2@
  , GenEnv -> Maybe Class
geWitness :: Maybe Class -- ^ @Stock.Derive.DeriveStock@ (for discovered derivers)
  , GenEnv -> Class
geGen     :: Class
  , GenEnv -> TyCon
geRepTc   :: TyCon
  , GenEnv -> TyCon
geU1Tc    :: TyCon
  , GenEnv -> TyCon
geK1Tc    :: TyCon
  , GenEnv -> TyCon
geProdTc  :: TyCon
  , GenEnv -> DataCon
geProdDc  :: DataCon
  , GenEnv -> TyCon
geSumTc   :: TyCon       -- ^ @:+:@ (for sum-type @Rep@s)
  , GenEnv -> MetaEnv
geMeta    :: MetaEnv     -- ^ @M1@ + promoted @Meta@ pieces (for metadata layers)
  , GenEnv -> Gen1Env
geGen1    :: Gen1Env     -- ^ @Generic1@ / @Rep1@ pieces
  , GenEnv -> Type
geRTy     :: Type     -- ^ the @R@ tag (for @Rec0 = K1 R@)
  , GenEnv -> Maybe TyCon
geOverride :: Maybe TyCon  -- ^ @Stock.Override.Override@ ('Nothing' if not in scope)
  , GenEnv -> Maybe TyCon
geAssign   :: Maybe TyCon  -- ^ @Stock.Override.(:=)@ — the config-entry marker
  , GenEnv -> Maybe TyCon
geAt       :: Maybe TyCon  -- ^ @Stock.Override.At@ — the positional selector marker
  , GenEnv -> Maybe TyCon
geKeep     :: Maybe TyCon  -- ^ @Stock.Override.Keep@ — the positional no-op (@_@) marker
  , GenEnv -> Maybe TyCon
geArrow    :: Maybe TyCon  -- ^ @Stock.Override.(-->)@ — the path-addressing marker
  , GenEnv -> Maybe Class
geWitness1 :: Maybe Class  -- ^ @Stock.Derive.DeriveStock1@ (lifted discovered derivers)
  , GenEnv -> Maybe Class
geWitness2 :: Maybe Class  -- ^ @Stock.Derive.DeriveStock2@ (bi-lifted discovered derivers)
  , GenEnv -> Maybe TyCon
geOverride2 :: Maybe TyCon -- ^ @Stock.Override.Override2@ — per-field override at the @Stock2@ level
  , GenEnv -> Maybe TyCon
geOverride1 :: Maybe TyCon -- ^ @Stock.Override.Override1@ — per-field override at the @Stock1@ level
  }

-- | The @M1@ newtype and the promoted @Meta@ pieces needed to build the
-- @D1@/@C1@/@S1@ metadata layers of a faithful (nominal) @Rep@.
data MetaEnv = MetaEnv
  { MetaEnv -> TyCon
meM1          :: TyCon        -- ^ @M1@
  , MetaEnv -> Type
meD, MetaEnv -> Type
meC, MetaEnv -> Type
meS :: Type        -- ^ the @D@\/@C@\/@S@ tags (kind @Type@)
  , MetaEnv -> TyCon
meMetaData    :: TyCon        -- ^ promoted @'MetaData@
  , MetaEnv -> TyCon
meMetaCons    :: TyCon        -- ^ promoted @'MetaCons@
  , MetaEnv -> TyCon
meMetaSel     :: TyCon        -- ^ promoted @'MetaSel@
  , MetaEnv -> Type
mePrefixI     :: Type         -- ^ @'PrefixI@
  , MetaEnv -> TyCon
meInfixI      :: TyCon        -- ^ promoted @'InfixI@ (assoc → nat → FixityI)
  , MetaEnv -> Type
meLeftAssoc, MetaEnv -> Type
meRightAssoc, MetaEnv -> Type
meNotAssoc :: Type  -- ^ promoted @Associativity@
  , MetaEnv -> Type
meNoUnpack, MetaEnv -> Type
meSrcNoUnpack, MetaEnv -> Type
meSrcUnpack :: Type -- ^ promoted @SourceUnpackedness@
  , MetaEnv -> Type
meNoStrict, MetaEnv -> Type
meSrcLazy, MetaEnv -> Type
meSrcStrict     :: Type -- ^ promoted @SourceStrictness@
  , MetaEnv -> Type
meDecidedLazy, MetaEnv -> Type
meDecidedStrict, MetaEnv -> Type
meDecidedUnpack :: Type -- ^ promoted @DecidedStrictness@
  , MetaEnv -> TyCon
meJustSym     :: TyCon        -- ^ promoted @'Just@ \@Symbol
  , MetaEnv -> Type
meNothingSym  :: Type         -- ^ @'Nothing \@Symbol@
  }

-- | @Generic1@ entities: the class, the @Rep1@ family, and the parameter-aware
-- representation pieces @Par1@\/@Rec1@\/@(:.:)@.
data Gen1Env = Gen1Env
  { Gen1Env -> TyCon
g1RepTc  :: TyCon   -- ^ @Rep1@
  , Gen1Env -> TyCon
g1Par1Tc :: TyCon   -- ^ @Par1@ (the bare parameter)
  , Gen1Env -> TyCon
g1Rec1Tc :: TyCon   -- ^ @Rec1@ (@g a@)
  , Gen1Env -> TyCon
g1CompTc :: TyCon   -- ^ @(:.:)@ (composition, @f (g a)@)
  }

-- | Plugin state: error-message dedup set + the @Generic@ entities.
data PluginState = PluginState
  { PluginState -> IORef [String]
psSeen :: IORef [String]
  , PluginState -> GenEnv
psGen  :: GenEnv
  }

-- | Short-circuiting conjunction of @Bool@-valued Core expressions — reads like
-- @and [b0, b1, …]@ but builds the nested @case e of { False -> False; True ->
-- … }@ chain, the same Core a derived @&&@ chain produces: no list, no
-- allocation, byte-identical to stock deriving.
andE :: [CoreExpr] -> TcPluginM CoreExpr
andE :: [CoreExpr] -> TcPluginM CoreExpr
andE []     = CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
trueDataCon))
andE [CoreExpr
a]    = CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
a
andE (CoreExpr
a:[CoreExpr]
as) = do
  CoreExpr
r   <- [CoreExpr] -> TcPluginM CoreExpr
andE [CoreExpr]
as
  Id
scr <- Type -> String -> TcPluginM Id
freshId Type
boolTy String
"c"
  CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
a Id
scr Type
boolTy [ AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
falseDataCon) [] (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId DataCon
falseDataCon))
                          , AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
trueDataCon)  [] CoreExpr
r ])

lookupTyConMaybe :: String -> String -> TcPluginM (Maybe TyCon)
lookupTyConMaybe :: String -> String -> TcPluginM (Maybe TyCon)
lookupTyConMaybe String
modName String
occ = do
  FindResult
res <- ModuleName -> PkgQual -> TcPluginM FindResult
findImportedModule (String -> ModuleName
mkModuleName String
modName) PkgQual
NoPkgQual
  case FindResult
res of
    Found ModLocation
_ Module
m -> TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just (TyCon -> Maybe TyCon)
-> TcPluginM TyCon -> TcPluginM (Maybe TyCon)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Module -> OccName -> TcPluginM Name
lookupOrig Module
m (String -> OccName
mkTcOcc String
occ) TcPluginM Name -> (Name -> TcPluginM TyCon) -> TcPluginM TyCon
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM TyCon
tcLookupTyCon)
    FindResult
_         -> Maybe TyCon -> TcPluginM (Maybe TyCon)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TyCon
forall a. Maybe a
Nothing

-- | Look up the @M1@ + promoted @Meta@ entities for metadata layers.
lookupMetaEnv :: TcPluginM MetaEnv
lookupMetaEnv :: TcPluginM MetaEnv
lookupMetaEnv = do
  let gTc :: String -> TcPluginM TyCon
gTc String
occ = Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_GENERICS (String -> OccName
mkTcOcc String
occ)   TcPluginM Name -> (Name -> TcPluginM TyCon) -> TcPluginM TyCon
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM TyCon
tcLookupTyCon
      gDc :: String -> TcPluginM DataCon
gDc String
occ = Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_GENERICS (String -> OccName
mkDataOcc String
occ) TcPluginM Name -> (Name -> TcPluginM DataCon) -> TcPluginM DataCon
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM DataCon
tcLookupDataCon
      promTy :: String -> TcPluginM Type
promTy  = (DataCon -> Type) -> TcPluginM DataCon -> TcPluginM Type
forall a b. (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyCon -> Type
mkTyConTy (TyCon -> Type) -> (DataCon -> TyCon) -> DataCon -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> TyCon
promoteDataCon) (TcPluginM DataCon -> TcPluginM Type)
-> (String -> TcPluginM DataCon) -> String -> TcPluginM Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TcPluginM DataCon
gDc
  TyCon
m1  <- String -> TcPluginM TyCon
gTc String
"M1"
  Type
dT  <- TyCon -> Type
mkTyConTy (TyCon -> Type) -> TcPluginM TyCon -> TcPluginM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> TcPluginM TyCon
gTc String
"D" ; Type
cT <- TyCon -> Type
mkTyConTy (TyCon -> Type) -> TcPluginM TyCon -> TcPluginM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> TcPluginM TyCon
gTc String
"C" ; Type
sT <- TyCon -> Type
mkTyConTy (TyCon -> Type) -> TcPluginM TyCon -> TcPluginM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> TcPluginM TyCon
gTc String
"S"
  TyCon
md  <- DataCon -> TyCon
promoteDataCon (DataCon -> TyCon) -> TcPluginM DataCon -> TcPluginM TyCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> TcPluginM DataCon
gDc String
"MetaData"
  TyCon
mc  <- DataCon -> TyCon
promoteDataCon (DataCon -> TyCon) -> TcPluginM DataCon -> TcPluginM TyCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> TcPluginM DataCon
gDc String
"MetaCons"
  TyCon
ms  <- DataCon -> TyCon
promoteDataCon (DataCon -> TyCon) -> TcPluginM DataCon -> TcPluginM TyCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> TcPluginM DataCon
gDc String
"MetaSel"
  Type
pfx <- String -> TcPluginM Type
promTy String
"PrefixI"
  TyCon
inI <- DataCon -> TyCon
promoteDataCon (DataCon -> TyCon) -> TcPluginM DataCon -> TcPluginM TyCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> TcPluginM DataCon
gDc String
"InfixI"
  Type
la  <- String -> TcPluginM Type
promTy String
"LeftAssociative" ; Type
ra <- String -> TcPluginM Type
promTy String
"RightAssociative" ; Type
na <- String -> TcPluginM Type
promTy String
"NotAssociative"
  Type
nu  <- String -> TcPluginM Type
promTy String
"NoSourceUnpackedness" ; Type
snu <- String -> TcPluginM Type
promTy String
"SourceNoUnpack" ; Type
su <- String -> TcPluginM Type
promTy String
"SourceUnpack"
  Type
ns  <- String -> TcPluginM Type
promTy String
"NoSourceStrictness"   ; Type
sl  <- String -> TcPluginM Type
promTy String
"SourceLazy"     ; Type
ss <- String -> TcPluginM Type
promTy String
"SourceStrict"
  Type
dl  <- String -> TcPluginM Type
promTy String
"DecidedLazy" ; Type
ds <- String -> TcPluginM Type
promTy String
"DecidedStrict" ; Type
du <- String -> TcPluginM Type
promTy String
"DecidedUnpack"
  MetaEnv -> TcPluginM MetaEnv
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MetaEnv { meM1 :: TyCon
meM1 = TyCon
m1, meD :: Type
meD = Type
dT, meC :: Type
meC = Type
cT, meS :: Type
meS = Type
sT
               , meMetaData :: TyCon
meMetaData = TyCon
md, meMetaCons :: TyCon
meMetaCons = TyCon
mc, meMetaSel :: TyCon
meMetaSel = TyCon
ms
               , mePrefixI :: Type
mePrefixI = Type
pfx, meInfixI :: TyCon
meInfixI = TyCon
inI
               , meLeftAssoc :: Type
meLeftAssoc = Type
la, meRightAssoc :: Type
meRightAssoc = Type
ra, meNotAssoc :: Type
meNotAssoc = Type
na
               , meNoUnpack :: Type
meNoUnpack = Type
nu, meSrcNoUnpack :: Type
meSrcNoUnpack = Type
snu, meSrcUnpack :: Type
meSrcUnpack = Type
su
               , meNoStrict :: Type
meNoStrict = Type
ns, meSrcLazy :: Type
meSrcLazy = Type
sl, meSrcStrict :: Type
meSrcStrict = Type
ss
               , meDecidedLazy :: Type
meDecidedLazy = Type
dl, meDecidedStrict :: Type
meDecidedStrict = Type
ds, meDecidedUnpack :: Type
meDecidedUnpack = Type
du
               , meJustSym :: TyCon
meJustSym = TyCon
promotedJustDataCon
               , meNothingSym :: Type
meNothingSym = TyCon -> [Type] -> Type
mkTyConApp TyCon
promotedNothingDataCon [Type
typeSymbolKind] }

-- | Look up the @Generic1@ / @Rep1@ entities.
lookupGen1Env :: TcPluginM Gen1Env
lookupGen1Env :: TcPluginM Gen1Env
lookupGen1Env = do
  let gTc :: String -> TcPluginM TyCon
gTc String
occ = Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_GENERICS (String -> OccName
mkTcOcc String
occ) TcPluginM Name -> (Name -> TcPluginM TyCon) -> TcPluginM TyCon
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM TyCon
tcLookupTyCon
  TyCon -> TyCon -> TyCon -> TyCon -> Gen1Env
Gen1Env (TyCon -> TyCon -> TyCon -> TyCon -> Gen1Env)
-> TcPluginM TyCon
-> TcPluginM (TyCon -> TyCon -> TyCon -> Gen1Env)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> TcPluginM TyCon
gTc String
"Rep1" TcPluginM (TyCon -> TyCon -> TyCon -> Gen1Env)
-> TcPluginM TyCon -> TcPluginM (TyCon -> TyCon -> Gen1Env)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> TcPluginM TyCon
gTc String
"Par1" TcPluginM (TyCon -> TyCon -> Gen1Env)
-> TcPluginM TyCon -> TcPluginM (TyCon -> Gen1Env)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> TcPluginM TyCon
gTc String
"Rec1" TcPluginM (TyCon -> Gen1Env)
-> TcPluginM TyCon -> TcPluginM Gen1Env
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> TcPluginM TyCon
gTc String
":.:"

-- | Look up a class by module + name, 'Nothing' if its module isn't available.
lookupClassMaybe :: String -> String -> TcPluginM (Maybe Class)
lookupClassMaybe :: String -> String -> TcPluginM (Maybe Class)
lookupClassMaybe String
modName String
occ = do
  FindResult
res <- ModuleName -> PkgQual -> TcPluginM FindResult
findImportedModule (String -> ModuleName
mkModuleName String
modName) PkgQual
NoPkgQual
  case FindResult
res of
    Found ModLocation
_ Module
m -> Class -> Maybe Class
forall a. a -> Maybe a
Just (Class -> Maybe Class)
-> TcPluginM Class -> TcPluginM (Maybe Class)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Module -> OccName -> TcPluginM Name
lookupOrig Module
m (String -> OccName
mkTcOcc String
occ) TcPluginM Name -> (Name -> TcPluginM Class) -> TcPluginM Class
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Class
tcLookupClass)
    FindResult
_         -> Maybe Class -> TcPluginM (Maybe Class)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Class
forall a. Maybe a
Nothing

-- | Look up a term-level identifier (a function\/value) by module + name,
-- 'Nothing' if its module isn't available — for companion derivers that need to
-- reference a library function (e.g. QuickCheck's @oneof@).
lookupIdMaybe :: String -> String -> TcPluginM (Maybe Id)
lookupIdMaybe :: String -> String -> TcPluginM (Maybe Id)
lookupIdMaybe String
modName String
occ = do
  FindResult
res <- ModuleName -> PkgQual -> TcPluginM FindResult
findImportedModule (String -> ModuleName
mkModuleName String
modName) PkgQual
NoPkgQual
  case FindResult
res of
    Found ModLocation
_ Module
m -> Id -> Maybe Id
forall a. a -> Maybe a
Just (Id -> Maybe Id) -> TcPluginM Id -> TcPluginM (Maybe Id)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Module -> OccName -> TcPluginM Name
lookupOrig Module
m (String -> OccName
mkVarOcc String
occ) TcPluginM Name -> (Name -> TcPluginM Id) -> TcPluginM Id
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Id
tcLookupId)
    FindResult
_         -> Maybe Id -> TcPluginM (Maybe Id)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Id
forall a. Maybe a
Nothing

-- | Rewrite @Rep (Stock T)@ to its structural representation.  The coercion is
-- a plugin-asserted univ coercion (there is no real @Generic@ axiom); the
-- @from@/@to@ we synthesize use the same assertion, so the two cohere.  We only
-- handle single-constructor types (products) so far.
repData :: GenEnv -> [[Type]] -> Type
repData :: GenEnv -> [[Type]] -> Type
repData GenEnv
gen [[Type]
fts] = GenEnv -> [Type] -> Type
repStruct GenEnv
gen [Type]
fts
repData GenEnv
gen [[Type]]
ftss  = (Type -> Type -> Type) -> [Type] -> Type
forall a. (a -> a -> a) -> [a] -> a
foldBal Type -> Type -> Type
sumOf (([Type] -> Type) -> [[Type]] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (GenEnv -> [Type] -> Type
repStruct GenEnv
gen) [[Type]]
ftss) where 
  sumOf :: Type -> Type -> Type
  sumOf :: Type -> Type -> Type
sumOf Type
f Type
g = TyCon -> [Type] -> Type
mkTyConApp (GenEnv -> TyCon
geSumTc GenEnv
gen) [Type
liftedTypeKind, Type
f, Type
g]

-- | The /faithful/ @Rep@ with metadata layers: @D1 meta (C1 meta (S1 meta Rec0
-- … :*: …) :+: …)@ — byte-identical in shape to GHC's stock @Rep@ (balanced
-- @:+:@/@:*:@, @M1@ wrappers carrying promoted @Meta@).  Used as the rewrite
-- target; the value-level @from@\/@to@ build the un-@M1@ 'repData' value and
-- bridge with a representational coercion (the @M1@s are newtypes).
-- | @Rec0 t = K1 R t@ — the field representation for a constant (and for every
-- field in plain @Generic@).
rec0Of :: GenEnv -> Type -> Type
rec0Of :: GenEnv -> Type -> Type
rec0Of GenEnv
gen Type
t = TyCon -> [Type] -> Type
mkTyConApp (GenEnv -> TyCon
geK1Tc GenEnv
gen) [Type
liftedTypeKind, GenEnv -> Type
geRTy GenEnv
gen, Type
t]

repMeta :: GenEnv -> (DataCon -> Type) -> Type -> [DataCon] -> Type
repMeta :: GenEnv -> (DataCon -> Type) -> Type -> [DataCon] -> Type
repMeta GenEnv
gen DataCon -> Type
fixOf Type
innerTy [DataCon]
dcons =
  GenEnv
-> (DataCon -> Type)
-> (Type -> Type)
-> Type
-> [(DataCon, [Type])]
-> Type
repMetaWith GenEnv
gen DataCon -> Type
fixOf (GenEnv -> Type -> Type
rec0Of GenEnv
gen) Type
innerTy [ (DataCon
dc, Type -> DataCon -> [Type]
fieldTysAt Type
innerTy DataCon
dc) | DataCon
dc <- [DataCon]
dcons ]

-- | 'repMeta' with explicit per-constructor field types — the @Generic@ leaves
-- carry these (the /modifier/ types under an @Override@, the real types
-- otherwise).  Pairs with the @from@\/@to@ that 'Stock.Generic' builds.
repMetaFts :: GenEnv -> (DataCon -> Type) -> Type -> [(DataCon, [Type])] -> Type
repMetaFts :: GenEnv -> (DataCon -> Type) -> Type -> [(DataCon, [Type])] -> Type
repMetaFts GenEnv
gen DataCon -> Type
fixOf = GenEnv
-> (DataCon -> Type)
-> (Type -> Type)
-> Type
-> [(DataCon, [Type])]
-> Type
repMetaWith GenEnv
gen DataCon -> Type
fixOf (GenEnv -> Type -> Type
rec0Of GenEnv
gen)

-- | 'repMeta' generalised over the per-field leaf representation: @Generic@
-- uses @Rec0@; @Generic1@ uses @Par1@\/@Rec1@\/@(:.:)@ ('rep1Field').  Each
-- constructor comes with the field types its leaves should carry.
repMetaWith :: GenEnv -> (DataCon -> Type) -> (Type -> Type) -> Type -> [(DataCon, [Type])] -> Type
repMetaWith :: GenEnv
-> (DataCon -> Type)
-> (Type -> Type)
-> Type
-> [(DataCon, [Type])]
-> Type
repMetaWith GenEnv
gen DataCon -> Type
fixOf Type -> Type
leaf Type
innerTy [(DataCon, [Type])]
cons =
  Type -> Type -> Type
d1 (TyCon -> Type
metaData TyCon
innerTc) ((Type -> Type -> Type) -> [Type] -> Type
forall a. (a -> a -> a) -> [a] -> a
foldBal Type -> Type -> Type
sumTy (((DataCon, [Type]) -> Type) -> [(DataCon, [Type])] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (DataCon, [Type]) -> Type
conRep [(DataCon, [Type])]
cons)) where
  me :: MetaEnv
me      = GenEnv -> MetaEnv
geMeta GenEnv
gen
  innerTc :: TyCon
innerTc = HasDebugCallStack => Type -> TyCon
Type -> TyCon
tyConAppTyCon Type
innerTy
  kTy :: Type
kTy     = Type
liftedTypeKind
  m1 :: Type -> Type -> Type -> Type
m1 Type
i Type
c Type
f = TyCon -> [Type] -> Type
mkTyConApp (MetaEnv -> TyCon
meM1 MetaEnv
me) [Type
kTy, Type
i, Type
c, Type
f]
  d1 :: Type -> Type -> Type
d1 = Type -> Type -> Type -> Type
m1 (MetaEnv -> Type
meD MetaEnv
me) ; c1 :: Type -> Type -> Type
c1 = Type -> Type -> Type -> Type
m1 (MetaEnv -> Type
meC MetaEnv
me) ; s1 :: Type -> Type -> Type
s1 = Type -> Type -> Type -> Type
m1 (MetaEnv -> Type
meS MetaEnv
me)
  sumTy :: Type -> Type -> Type
sumTy  Type
a Type
b = TyCon -> [Type] -> Type
mkTyConApp (GenEnv -> TyCon
geSumTc GenEnv
gen)  [Type
kTy, Type
a, Type
b]
  prodTy :: Type -> Type -> Type
prodTy Type
a Type
b = TyCon -> [Type] -> Type
mkTyConApp (GenEnv -> TyCon
geProdTc GenEnv
gen) [Type
kTy, Type
a, Type
b]
  u1 :: Type
u1     = TyCon -> [Type] -> Type
mkTyConApp (GenEnv -> TyCon
geU1Tc GenEnv
gen) [Type
kTy]
  strLit :: String -> Type
strLit = FastString -> Type
mkStrLitTy (FastString -> Type) -> (String -> FastString) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FastString
fsLit
  boolT :: Bool -> Type
boolT Bool
b = TyCon -> Type
mkTyConTy (if Bool
b then TyCon
promotedTrueDataCon else TyCon
promotedFalseDataCon)
  metaData :: TyCon -> Type
metaData TyCon
tc = TyCon -> [Type] -> Type
mkTyConApp (MetaEnv -> TyCon
meMetaData MetaEnv
me)
                  [ String -> Type
strLit (OccName -> String
occNameString (Name -> OccName
nameOccName (TyCon -> Name
tyConName TyCon
tc)))
                  , String -> Type
strLit (ModuleName -> String
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
modu))
                  , String -> Type
strLit (Unit -> String
forall u. IsUnitId u => u -> String
unitString (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
modu))
                  , Bool -> Type
boolT (TyCon -> Bool
isNewTyCon TyCon
tc) ]
    where modu :: Module
modu = HasDebugCallStack => Name -> Module
Name -> Module
nameModule (TyCon -> Name
tyConName TyCon
tc)
  -- MetaCons carries the constructor's FIXITY ('Infix assoc prec for an infix
  -- constructor, else 'PrefixI) — supplied by the (monadic) 'mkFixOf'.
  metaCons :: DataCon -> Type
metaCons DataCon
dc = TyCon -> [Type] -> Type
mkTyConApp (MetaEnv -> TyCon
meMetaCons MetaEnv
me)
                  [ String -> Type
strLit (OccName -> String
occNameString (DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
dc))
                  , DataCon -> Type
fixOf DataCon
dc
                  , Bool -> Type
boolT (Bool -> Bool
not ([FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc))) ]
  -- MetaSel carries the field's real source/decided strictness.
  metaSel :: Maybe String -> (Type, Type, Type) -> Type
metaSel Maybe String
mnm (Type
suT, Type
ssT, Type
dsT) = TyCon -> [Type] -> Type
mkTyConApp (MetaEnv -> TyCon
meMetaSel MetaEnv
me)
                  [ Type -> (String -> Type) -> Maybe String -> Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MetaEnv -> Type
meNothingSym MetaEnv
me)
                          (\String
nm -> TyCon -> [Type] -> Type
mkTyConApp (MetaEnv -> TyCon
meJustSym MetaEnv
me) [Type
typeSymbolKind, String -> Type
strLit String
nm]) Maybe String
mnm
                  , Type
suT, Type
ssT, Type
dsT ]
  -- derive (SourceUnpackedness, SourceStrictness, DecidedStrictness) from the
  -- DECIDED bang ('HsImplBang' is stable across GHC versions, unlike 'HsSrcBang'
  -- which changed shape thrice): an unannotated field is lazy; a @!@ field is
  -- source-strict + decided-strict; an UNPACK field is source-unpack (the rare
  -- explicit @~@ lazy annotation is the one case this can't tell from plain).
  selStr :: DataCon -> Int -> (Type, Type, Type)
selStr DataCon
dc Int
i = case if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [HsImplBang] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsImplBang]
implB then [HsImplBang]
implB [HsImplBang] -> Int -> HsImplBang
forall a. HasCallStack => [a] -> Int -> a
!! Int
i else HsImplBang
HsLazy of
      HsImplBang
HsLazy     -> (MetaEnv -> Type
meNoUnpack MetaEnv
me,  MetaEnv -> Type
meNoStrict MetaEnv
me,  MetaEnv -> Type
meDecidedLazy MetaEnv
me)
      HsStrict Bool
_ -> (MetaEnv -> Type
meNoUnpack MetaEnv
me,  MetaEnv -> Type
meSrcStrict MetaEnv
me, MetaEnv -> Type
meDecidedStrict MetaEnv
me)
      HsUnpack Maybe Coercion
_ -> (MetaEnv -> Type
meSrcUnpack MetaEnv
me, MetaEnv -> Type
meSrcStrict MetaEnv
me, MetaEnv -> Type
meDecidedUnpack MetaEnv
me)
    where implB :: [HsImplBang]
implB = DataCon -> [HsImplBang]
dataConImplBangs DataCon
dc
  conRep :: (DataCon, [Type]) -> Type
conRep (DataCon
dc, [Type]
fts) = Type -> Type -> Type
c1 (DataCon -> Type
metaCons DataCon
dc) Type
prod
    where labels :: [FieldLabel]
labels = DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc
          nameAt :: Int -> Maybe String
nameAt Int
i | [FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
labels = Maybe String
forall a. Maybe a
Nothing
                   | Bool
otherwise   = String -> Maybe String
forall a. a -> Maybe a
Just (OccName -> String
occNameString (Name -> OccName
nameOccName (FieldLabel -> Name
flSelector ([FieldLabel]
labels [FieldLabel] -> Int -> FieldLabel
forall a. HasCallStack => [a] -> Int -> a
!! Int
i))))
          prod :: Type
prod = case [Type]
fts of
                   [] -> Type
u1
                   [Type]
_  -> (Type -> Type -> Type) -> [Type] -> Type
forall a. (a -> a -> a) -> [a] -> a
foldBal Type -> Type -> Type
prodTy
                           [ Type -> Type -> Type
s1 (Maybe String -> (Type, Type, Type) -> Type
metaSel (Int -> Maybe String
nameAt Int
i) (DataCon -> Int -> (Type, Type, Type)
selStr DataCon
dc Int
i)) (Type -> Type
leaf Type
ft)
                           | (Int
i, Type
ft) <- [Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Type]
fts ]

-- 'Fixity' lost its leading 'SourceText' in GHC 9.12 (2-arg from 9.12 on).
fixityParts :: Fixity -> (Int, FixityDirection)
#if MIN_VERSION_ghc(9,12,0)
fixityParts (Fixity p d)   = (p, d)
#else
fixityParts :: Fixity -> (Int, FixityDirection)
fixityParts (Fixity SourceText
_ Int
p FixityDirection
d) = (Int
p, FixityDirection
d)
#endif

-- | The per-constructor MetaCons fixity meta ('Infix assoc prec / 'PrefixI),
-- precomputed (it needs the renamer's fixity environment).
conFixityTy :: MetaEnv -> DataCon -> TcPluginM Type
conFixityTy :: MetaEnv -> DataCon -> TcPluginM Type
conFixityTy MetaEnv
me DataCon
dc
  | DataCon -> Bool
dataConIsInfix DataCon
dc = do
      Fixity
fx <- TcM Fixity -> TcPluginM Fixity
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (Name -> TcM Fixity
lookupFixityRn (DataCon -> Name
dataConName DataCon
dc))
      let (Int
prec, FixityDirection
dir) = Fixity -> (Int, FixityDirection)
fixityParts Fixity
fx
          assoc :: Type
assoc = case FixityDirection
dir of FixityDirection
InfixL -> MetaEnv -> Type
meLeftAssoc MetaEnv
me; FixityDirection
InfixR -> MetaEnv -> Type
meRightAssoc MetaEnv
me; FixityDirection
InfixN -> MetaEnv -> Type
meNotAssoc MetaEnv
me
      Type -> TcPluginM Type
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyCon -> [Type] -> Type
mkTyConApp (MetaEnv -> TyCon
meInfixI MetaEnv
me) [Type
assoc, Integer -> Type
mkNumLitTy (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
prec)])
  | Bool
otherwise = Type -> TcPluginM Type
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MetaEnv -> Type
mePrefixI MetaEnv
me)

-- | A pure fixity lookup over a fixed constructor set (for 'repMetaWith').
mkFixOf :: MetaEnv -> [DataCon] -> TcPluginM (DataCon -> Type)
mkFixOf :: MetaEnv -> [DataCon] -> TcPluginM (DataCon -> Type)
mkFixOf MetaEnv
me [DataCon]
dcs = do
  [Type]
tys <- (DataCon -> TcPluginM Type) -> [DataCon] -> TcPluginM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (MetaEnv -> DataCon -> TcPluginM Type
conFixityTy MetaEnv
me) [DataCon]
dcs
  let m :: [(Unique, Type)]
m = [Unique] -> [Type] -> [(Unique, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((DataCon -> Unique) -> [DataCon] -> [Unique]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique [DataCon]
dcs) [Type]
tys
  (DataCon -> Type) -> TcPluginM (DataCon -> Type)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\DataCon
dc -> Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe (MetaEnv -> Type
mePrefixI MetaEnv
me) (Unique -> [(Unique, Type)] -> Maybe Type
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (DataCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique DataCon
dc) [(Unique, Type)]
m))

-- | The structural @Rep@ type for a single constructor with the given field
-- types: @U1@ when there are no fields, otherwise a /balanced/ @:*:@ tree of
-- @Rec0 field@ (matching GHC's @foldBal@ nesting).  No @M1@ metadata layers
-- yet — this is a valid representation that @Generically@ can use, just not
-- byte-identical to stock's.
repStruct :: GenEnv -> [Type] -> Type
repStruct :: GenEnv -> [Type] -> Type
repStruct GenEnv
gen []  = TyCon -> [Type] -> Type
mkTyConApp (GenEnv -> TyCon
geU1Tc GenEnv
gen) [Type
liftedTypeKind]    -- U1 @Type
repStruct GenEnv
gen [Type]
fts = (Type -> Type -> Type) -> [Type] -> Type
forall a. (a -> a -> a) -> [a] -> a
foldBal Type -> Type -> Type
prodOf ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
rec0 [Type]
fts) where

  rec0 :: Type -> Type
rec0 Type
t    = TyCon -> [Type] -> Type
mkTyConApp (GenEnv -> TyCon
geK1Tc GenEnv
gen)   [Type
liftedTypeKind, GenEnv -> Type
geRTy GenEnv
gen, Type
t]  -- K1 @Type R t
  prodOf :: Type -> Type -> Type
prodOf Type
f Type
g = TyCon -> [Type] -> Type
mkTyConApp (GenEnv -> TyCon
geProdTc GenEnv
gen) [Type
liftedTypeKind, Type
f, Type
g]         -- (f :*: g) @Type

-- | Classify a field for @Rep1@: the bare parameter @a@ ⇒ @Par1@; @g a@ with
-- @g@ closed ⇒ @Rec1 g@; a field without the parameter ⇒ @Rec0@ (constant).
-- 'Nothing' for shapes we don't yet handle (composition @f (g a)@, or the
-- parameter in a position other than the last argument of a closed functor).
rep1Field :: GenEnv -> TyVar -> Type -> Maybe Type
rep1Field :: GenEnv -> Id -> Type -> Maybe Type
rep1Field GenEnv
gen Id
aTv Type
ft
  | Type
ft Type -> Type -> Bool
`eqType` Type
aTy                          = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
par1
  | Bool -> Bool
not (Id
aTv Id -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
ft) = Type -> Maybe Type
forall a. a -> Maybe a
Just (GenEnv -> Type -> Type
rec0Of GenEnv
gen Type
ft)
  | Just (Type
h, Type
larg) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ft
  , Bool -> Bool
not (Id
aTv Id -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
h)  =
      if Type
larg Type -> Type -> Bool
`eqType` Type
aTy then Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Type
rec1 Type
h)             -- @h a@      ⇒ Rec1 h
      else Type -> Type -> Type
comp Type
h (Type -> Type) -> Maybe Type -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenEnv -> Id -> Type -> Maybe Type
rep1Field GenEnv
gen Id
aTv Type
larg              -- @h (g..a)@ ⇒ h :.: <inner>
  | Bool
otherwise                                = Maybe Type
forall a. Maybe a
Nothing
  where
    g1 :: Gen1Env
g1   = GenEnv -> Gen1Env
geGen1 GenEnv
gen ; kTy :: Type
kTy = Type
liftedTypeKind ; aTy :: Type
aTy = Id -> Type
mkTyVarTy Id
aTv
    par1 :: Type
par1 = TyCon -> Type
mkTyConTy (Gen1Env -> TyCon
g1Par1Tc Gen1Env
g1)
    rec1 :: Type -> Type
rec1 Type
h     = TyCon -> [Type] -> Type
mkTyConApp (Gen1Env -> TyCon
g1Rec1Tc Gen1Env
g1) [Type
kTy, Type
h]
    comp :: Type -> Type -> Type
comp Type
h Type
inr = TyCon -> [Type] -> Type
mkTyConApp (Gen1Env -> TyCon
g1CompTc Gen1Env
g1) [Type
kTy, Type
kTy, Type
h, Type
inr]

-- | A balanced binary fold (GHC's @foldBal@): splits the list in half and
-- recurses, giving @(a \`op\` b) \`op\` (c \`op\` d)@ rather than a right-nested
-- chain.  Precondition: non-empty.
foldBal :: (a -> a -> a) -> [a] -> a
foldBal :: forall a. (a -> a -> a) -> [a] -> a
foldBal a -> a -> a
_  [a
x] = a
x
foldBal a -> a -> a
op [a]
xs  = let ([a]
l, [a]
r) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [a]
xs
                 in a -> a -> a
op ((a -> a -> a) -> [a] -> a
forall a. (a -> a -> a) -> [a] -> a
foldBal a -> a -> a
op [a]
l) ((a -> a -> a) -> [a] -> a
forall a. (a -> a -> a) -> [a] -> a
foldBal a -> a -> a
op [a]
r)

-- | Try to solve every wanted constraint by direct synthesis.  Synthesis may
-- emit further wanted constraints (e.g. @Eq@ on a field type), which we hand
-- back to the solver alongside our solutions.
type Attempt = (Maybe (EvTerm, Ct), [Ct], [Ct])

-- ---------------------------------------------------------------------------
-- A little EDSL describing the datatype representation a Stock-wrapped type
-- exposes.  Everything the synthesizers need to inspect lives here, so the
-- "is this something we can build an instance for, and what does it look like"
-- question is answered in exactly one place.
-- ---------------------------------------------------------------------------

-- | One constructor's representation: the constructor itself and its field
-- types (instantiated at the inner type's arguments).
data ConInfo = ConInfo
  { ConInfo -> DataCon
ciCon      :: DataCon
  , ConInfo -> [Type]
ciFields   :: [Type]        -- ^ field types the synthesizer sees (modifier types if overridden)
  , ConInfo -> [Coercion]
ciFieldCos :: [Coercion]    -- ^ per field, @realFieldType ~R ciFields!!i@ (Refl if not overridden)
  }

-- | The representation of @Stock Inner@: the inner type, the newtype-unwrapping
-- coercion @wrapped ~R inner@, and the constructors.
data Repr = Repr
  { Repr -> Type
rInner :: Type
  , Repr -> Coercion
rCo    :: Coercion
  , Repr -> [ConInfo]
rCons  :: [ConInfo]
  }

-- | Recognise @Stock Inner@ where @Stock@ is exactly /our/ wrapper newtype
-- (identified by 'TyCon', not by name — so an unrelated user type called
-- @Stock@ is never touched) and @Inner@ is a concrete algebraic type, and read
-- off its representation.  Returns 'Nothing' for anything we don't own or can't
-- analyse (including when our @Stock@ couldn't be located, i.e. @ourStock@ is
-- 'Nothing').
mkRepr :: Maybe TyCon -> Type -> Maybe Repr
mkRepr :: Maybe TyCon -> Type -> Maybe Repr
mkRepr Maybe TyCon
ourStock Type
wrappedTy = do
  TyCon
ourTc   <- Maybe TyCon
ourStock
  TyCon
stockTc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
wrappedTy
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TyCon
stockTc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ourTc)
  Type
innerTy <- case HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy of { (Type
a:[Type]
_) -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
a; [Type]
_ -> Maybe Type
forall a. Maybe a
Nothing }
  TyCon
innerTc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
innerTy
  let dcons :: [DataCon]
dcons = TyCon -> [DataCon]
tyConDataCons TyCon
innerTc
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not ([DataCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
dcons))
  let co :: Coercion
co = Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational
             (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
stockTc) (HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy) []
      cons :: [ConInfo]
cons = [ DataCon -> [Type] -> [Coercion] -> ConInfo
ConInfo DataCon
dc [Type]
fts ((Type -> Coercion) -> [Type] -> [Coercion]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Coercion
mkRepReflCo [Type]
fts)
             | DataCon
dc <- [DataCon]
dcons, let fts :: [Type]
fts = Type -> DataCon -> [Type]
fieldTysAt Type
innerTy DataCon
dc ]
  Repr -> Maybe Repr
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Coercion -> [ConInfo] -> Repr
Repr Type
innerTy Coercion
co [ConInfo]
cons)

-- | A plugin-asserted coercion (there is no real axiom; the plugin vouches for
-- the representational equality).  'mkUnivCo' gained a @[Coercion]@ dependency
-- argument in GHC 9.12, so this wrapper keeps call sites version-agnostic.
mkStockCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion
#if MIN_VERSION_ghc(9,12,0)
mkStockCo prov = mkUnivCo prov []
#else
mkStockCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkUnivCo
#endif

-- | The @Override(1\/2)@ field reshape coercion @h t ~R m t@ — 'Refl' when the
-- field is not overridden (@h == m@), else the plugin-asserted representational
-- equality.  Shared by every synthesizer that reshapes a functor field.
reshapeCo :: Type -> Type -> Type -> Coercion
reshapeCo :: Type -> Type -> Type -> Coercion
reshapeCo Type
h Type
m Type
t
  | Type
h Type -> Type -> Bool
`eqType` Type
m = Type -> Coercion
mkRepReflCo (Type -> Type -> Type
mkAppTy Type
h Type
t)
  | Bool
otherwise    = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo (String -> UnivCoProvenance
PluginProv String
"stock") Role
Representational (Type -> Type -> Type
mkAppTy Type
h Type
t) (Type -> Type -> Type
mkAppTy Type
m Type
t)

-- | Cast by a reshape coercion, skipping the no-op 'Refl' (so non-overridden
-- fields stay syntactically untouched and the emitted Core is byte-identical).
castReshape :: CoreExpr -> Coercion -> CoreExpr
castReshape :: CoreExpr -> Coercion -> CoreExpr
castReshape CoreExpr
e Coercion
co = if Coercion -> Bool
isReflCo Coercion
co then CoreExpr
e else CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
e Coercion
co

-- ---------------------------------------------------------------------------
-- Override: per-field deriving modifiers (see docs/override-design.md)
-- ---------------------------------------------------------------------------

-- | Peel @Override1 cfg f@ to the real constructor and its per-field positional
-- modifiers (single inner list); a non-overridden @f@ gives @(f, Nothing)@.
peelOverride1 :: GenEnv -> Type -> (Type, Maybe [Type])
peelOverride1 :: GenEnv -> Type -> (Type, Maybe [Type])
peelOverride1 GenEnv
gen = OvTcs -> Type -> (Type, Maybe [Type])
peelOverride1With (String -> GenEnv -> OvTcs
ovTcsGen String
"Override1" GenEnv
gen)

-- | The @Override@-config 'TyCon's a config decoder needs.  Bundled so the
-- satellite 'Deriver1'\/'Deriver2's (which have no 'GenEnv') can pass them.
data OvTcs = OvTcs
  { OvTcs -> Maybe TyCon
ovWrap   :: Maybe TyCon   -- ^ @Override1@ \/ @Override2@
  , OvTcs -> Maybe TyCon
ovKeep   :: Maybe TyCon   -- ^ @Keep@
  , OvTcs -> Maybe TyCon
ovArrow  :: Maybe TyCon   -- ^ @-->@
  , OvTcs -> Maybe TyCon
ovAssign :: Maybe TyCon   -- ^ @:=@
  , OvTcs -> Maybe TyCon
ovAt     :: Maybe TyCon   -- ^ @At@
  }

-- | The bundle, from a 'GenEnv' (for the built-in synthesizers).
ovTcsGen :: String -> GenEnv -> OvTcs
ovTcsGen :: String -> GenEnv -> OvTcs
ovTcsGen String
wrap GenEnv
gen = Maybe TyCon
-> Maybe TyCon
-> Maybe TyCon
-> Maybe TyCon
-> Maybe TyCon
-> OvTcs
OvTcs
  (if String
wrap String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Override2" then GenEnv -> Maybe TyCon
geOverride2 GenEnv
gen else GenEnv -> Maybe TyCon
geOverride1 GenEnv
gen)
  (GenEnv -> Maybe TyCon
geKeep GenEnv
gen) (GenEnv -> Maybe TyCon
geArrow GenEnv
gen) (GenEnv -> Maybe TyCon
geAssign GenEnv
gen) (GenEnv -> Maybe TyCon
geAt GenEnv
gen)

-- | The bundle, looked up by name (for the satellite 'Deriver1'\/'Deriver2's).
lookupOvTcs :: String -> TcPluginM OvTcs
lookupOvTcs :: String -> TcPluginM OvTcs
lookupOvTcs String
wrap = Maybe TyCon
-> Maybe TyCon
-> Maybe TyCon
-> Maybe TyCon
-> Maybe TyCon
-> OvTcs
OvTcs
  (Maybe TyCon
 -> Maybe TyCon
 -> Maybe TyCon
 -> Maybe TyCon
 -> Maybe TyCon
 -> OvTcs)
-> TcPluginM (Maybe TyCon)
-> TcPluginM
     (Maybe TyCon -> Maybe TyCon -> Maybe TyCon -> Maybe TyCon -> OvTcs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> TcPluginM (Maybe TyCon)
lookupTyConMaybe String
"Stock.Override" String
wrap
  TcPluginM
  (Maybe TyCon -> Maybe TyCon -> Maybe TyCon -> Maybe TyCon -> OvTcs)
-> TcPluginM (Maybe TyCon)
-> TcPluginM (Maybe TyCon -> Maybe TyCon -> Maybe TyCon -> OvTcs)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> TcPluginM (Maybe TyCon)
lookupTyConMaybe String
"Stock.Override" String
"Keep"
  TcPluginM (Maybe TyCon -> Maybe TyCon -> Maybe TyCon -> OvTcs)
-> TcPluginM (Maybe TyCon)
-> TcPluginM (Maybe TyCon -> Maybe TyCon -> OvTcs)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> TcPluginM (Maybe TyCon)
lookupTyConMaybe String
"Stock.Override" String
"-->"
  TcPluginM (Maybe TyCon -> Maybe TyCon -> OvTcs)
-> TcPluginM (Maybe TyCon) -> TcPluginM (Maybe TyCon -> OvTcs)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> TcPluginM (Maybe TyCon)
lookupTyConMaybe String
"Stock.Override" String
":="
  TcPluginM (Maybe TyCon -> OvTcs)
-> TcPluginM (Maybe TyCon) -> TcPluginM OvTcs
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> TcPluginM (Maybe TyCon)
lookupTyConMaybe String
"Stock.Override" String
"At"

-- | As 'peelOverride1', but taking the 'TyCon' bundle directly so callers
-- without a 'GenEnv' (the companion 'Deriver1's) can peel @Override1@ too.
peelOverride1With :: OvTcs -> Type -> (Type, Maybe [Type])
peelOverride1With :: OvTcs -> Type -> (Type, Maybe [Type])
peelOverride1With OvTcs
tcs Type
f = case OvTcs -> Maybe TyCon
ovWrap OvTcs
tcs of
  Just TyCon
ov1Tc | Just (TyCon
tc, [Type
_, Type
_, Type
realF, Type
cfg]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
f, TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ov1Tc
             -> (Type
realF, OvTcs -> Type -> Type -> Maybe [Type]
decodeOvCfg OvTcs
tcs Type
realF Type
cfg)
  Maybe TyCon
_          -> (Type
f, Maybe [Type]
forall a. Maybe a
Nothing)

-- | Decode an @Override1@\/@Override2@ config to the (first) constructor's
-- per-field /raw/ modifiers (@Keep@ where a field is unaddressed).  Both the
-- positional @'[ '[m, _, …] ]@ form AND the field-keyed entry list @'[ "x" ':=
-- m, 'C '--> 0 '--> m, … ]@ work — the same surface as value @Override@, only
-- the modifier kind differs (a functor here).  'modifierType' is /not/ applied:
-- the synthesizers receive @m@ and reshape @h a@ to @m a@ themselves.
decodeOvCfg :: OvTcs -> Type -> Type -> Maybe [Type]
decodeOvCfg :: OvTcs -> Type -> Type -> Maybe [Type]
decodeOvCfg OvTcs
tcs Type
realInner Type
cfg =
  case Type -> Maybe [[Type]]
decodePositional Type
cfg of
    Just [[Type]]
perCon -> [[Type]] -> Maybe [Type]
forall a. [a] -> Maybe a
listToMaybe [[Type]]
perCon                -- positional [[..]] form
    Maybe [[Type]]
Nothing -> do                                    -- field-keyed entry list
      TyCon
arrowTc <- OvTcs -> Maybe TyCon
ovArrow OvTcs
tcs ; TyCon
assignTc <- OvTcs -> Maybe TyCon
ovAssign OvTcs
tcs
      TyCon
atTc    <- OvTcs -> Maybe TyCon
ovAt OvTcs
tcs    ; TyCon
keepTc   <- OvTcs -> Maybe TyCon
ovKeep OvTcs
tcs
      TyCon
fTc     <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realInner
      let dcons :: [DataCon]
dcons = TyCon -> [DataCon]
tyConDataCons TyCon
fTc
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not ([DataCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
dcons))
      [(Addr, Type)]
entries <- Type -> Maybe [Type]
promotedListElems Type
cfg Maybe [Type]
-> ([Type] -> Maybe [(Addr, Type)]) -> Maybe [(Addr, Type)]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Type -> Maybe (Addr, Type)) -> [Type] -> Maybe [(Addr, Type)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (TyCon -> TyCon -> TyCon -> Type -> Maybe (Addr, Type)
decodeEntry TyCon
arrowTc TyCon
assignTc TyCon
atTc)
      [((Int, Int), Type)]
cells   <- (SDoc -> Maybe [((Int, Int), Type)])
-> ([((Int, Int), Type)] -> Maybe [((Int, Int), Type)])
-> Either SDoc [((Int, Int), Type)]
-> Maybe [((Int, Int), Type)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe [((Int, Int), Type)] -> SDoc -> Maybe [((Int, Int), Type)]
forall a b. a -> b -> a
const Maybe [((Int, Int), Type)]
forall a. Maybe a
Nothing) [((Int, Int), Type)] -> Maybe [((Int, Int), Type)]
forall a. a -> Maybe a
Just ([DataCon]
-> Type -> [(Addr, Type)] -> Either SDoc [((Int, Int), Type)]
resolveCellsRaw [DataCon]
dcons Type
realInner [(Addr, Type)]
entries)
      -- @realInner@ is an unsaturated @j -> Type@ here, so use the source arity
      -- (not 'fieldTysAt', which would instantiate the datacon and panic).
      [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [ Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe (TyCon -> Type
mkTyConTy TyCon
keepTc) ((Int, Int) -> [((Int, Int), Type)] -> Maybe Type
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Int
0, Int
fi) [((Int, Int), Type)]
cells)
           | Int
fi <- [Int
0 .. DataCon -> Int
dataConSourceArity ([DataCon] -> DataCon
forall a. HasCallStack => [a] -> a
head [DataCon]
dcons) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]

-- | The modifier functor for field @i@ under an @Override1@ config, if any (and
-- not @Keep@): the field's @h a@ is then reshaped to @m a@.
override1Mod :: GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod :: GenEnv -> Maybe [Type] -> Int -> Maybe Type
override1Mod GenEnv
gen = Maybe TyCon -> Maybe [Type] -> Int -> Maybe Type
override1ModWith (GenEnv -> Maybe TyCon
geKeep GenEnv
gen)

-- | As 'override1Mod', but taking the @Keep@ 'TyCon' directly (for 'Deriver1's).
override1ModWith :: Maybe TyCon -> Maybe [Type] -> Int -> Maybe Type
override1ModWith :: Maybe TyCon -> Maybe [Type] -> Int -> Maybe Type
override1ModWith Maybe TyCon
mKeep Maybe [Type]
mMods Int
i = case Maybe [Type]
mMods of
  Just [Type]
mods | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
mods
            , let m :: Type
m = [Type]
mods [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
            , Bool -> Bool
not (Bool -> (TyCon -> Bool) -> Maybe TyCon -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\TyCon
k -> Type -> Maybe TyCon
tyConAppTyCon_maybe Type
m Maybe TyCon -> Maybe TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
k) Maybe TyCon
mKeep)
            -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
m
  Maybe [Type]
_ -> Maybe Type
forall a. Maybe a
Nothing

-- | @Stock1 (Override1 cfg realF) t ~R realF t@ — two newtype hops (one when
-- there is no @Override1@ wrapper).
coDown1 :: GenEnv -> TyCon -> Type -> Type -> Type -> Type -> Coercion
coDown1 :: GenEnv -> TyCon -> Type -> Type -> Type -> Type -> Coercion
coDown1 GenEnv
gen = Maybe TyCon -> TyCon -> Type -> Type -> Type -> Type -> Coercion
coDown1With (GenEnv -> Maybe TyCon
geOverride1 GenEnv
gen)

-- | As 'coDown1', but taking the @Override1@ 'TyCon' directly (for 'Deriver1's).
coDown1With :: Maybe TyCon -> TyCon -> Type -> Type -> Type -> Type -> Coercion
coDown1With :: Maybe TyCon -> TyCon -> Type -> Type -> Type -> Type -> Coercion
coDown1With Maybe TyCon
mOv1 TyCon
st1Tc Type
wrappedTy Type
f0 Type
realF Type
t = Coercion -> Coercion -> Coercion
mkTransCo
  (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
st1Tc) (HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
t]) [])
  (case Maybe TyCon
mOv1 of
     Just TyCon
ov1Tc | Type -> Maybe TyCon
tyConAppTyCon_maybe Type
f0 Maybe TyCon -> Maybe TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
ov1Tc ->
       Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
ov1Tc) (HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
f0 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
t]) []
     Maybe TyCon
_ -> Type -> Coercion
mkRepReflCo (Type -> Type -> Type
mkAppTy Type
realF Type
t))

-- | The @Stock2@ counterpart of 'peelOverride1With': peel @Override2 cfg realP@
-- to the real constructor and its per-field positional modifiers (for 'Deriver2's).
peelOverride2With :: OvTcs -> Type -> (Type, Maybe [Type])
peelOverride2With :: OvTcs -> Type -> (Type, Maybe [Type])
peelOverride2With OvTcs
tcs Type
p = case OvTcs -> Maybe TyCon
ovWrap OvTcs
tcs of
  Just TyCon
ov2Tc | Just (TyCon
tc, [Type
_, Type
rp, Type
cfg]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
p, TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ov2Tc
             -> (Type
rp, OvTcs -> Type -> Type -> Maybe [Type]
decodeOvCfg OvTcs
tcs Type
rp Type
cfg)
  Maybe TyCon
_          -> (Type
p, Maybe [Type]
forall a. Maybe a
Nothing)

-- | @Stock2 (Override2 cfg realP) t1 t2 ~R realP t1 t2@ — two newtype hops (one
-- when there is no @Override2@ wrapper).  For 'Deriver2's.
coDown2With :: Maybe TyCon -> TyCon -> Type -> Type -> Type -> Type -> Type -> Coercion
coDown2With :: Maybe TyCon
-> TyCon -> Type -> Type -> Type -> Type -> Type -> Coercion
coDown2With Maybe TyCon
mOv2 TyCon
st2Tc Type
wrappedTy Type
p0 Type
realP Type
t1 Type
t2 = Coercion -> Coercion -> Coercion
mkTransCo
  (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
st2Tc) (HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
t1, Type
t2]) [])
  (case Maybe TyCon
mOv2 of
     Just TyCon
ov2Tc | Type -> Maybe TyCon
tyConAppTyCon_maybe Type
p0 Maybe TyCon -> Maybe TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
ov2Tc ->
       Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
ov2Tc) (HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
p0 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
t1, Type
t2]) []
     Maybe TyCon
_ -> Type -> Coercion
mkRepReflCo (Type -> Type -> Type
mkAppTy (Type -> Type -> Type
mkAppTy Type
realP Type
t1) Type
t2))

-- | Recognise @Stock (Override T cfg)@ and build the override representation of
-- @T@.  The unwrap coercion chains through /both/ newtypes; fields named in
-- @cfg@ take their modifier type, with a per-cell @realτ ~R modτ@ coercion
-- emitted as a wanted (so GHC validates the override and reports a clean error
-- if it isn't coercible); unnamed fields are unchanged.  'Nothing' if this is
-- not an @Override@; @Left@ if it is but malformed.  v1: single-constructor,
-- keyed by record-field name, modifiers saturated (@Type@, pin) or unary
-- (@Type -> Type@, broadcast).
-- | Representational primitive equality @a ~R# b@ — the wanted whose evidence
-- coercion we splice per overridden cell.  (Renamed in GHC 9.14.)
mkStockReprEq :: Type -> Type -> Type
#if MIN_VERSION_ghc(9,14,0)
mkStockReprEq = mkReprEqPred
#else
mkStockReprEq :: Type -> Type -> Type
mkStockReprEq = Type -> Type -> Type
mkReprPrimEqPred
#endif

-- | Pure decode of @Stock (Override T cfg)@ to @T@ and its constructors paired
-- with their per-field /modifier/ types (@Keep@ or an unmatched cell ⇒ the real
-- field type).  The 'Generic' Rep rewriter ('Stock.Generic.rewriteRep') needs
-- only these types; the value-level coercion wanteds are emitted by the solver
-- ('synthGeneric' via 'mkOverrideRepr'), and both compute identical modifier
-- types (same 'modifierType') so the @Rep@ and @from@\/@to@ cohere.  'Nothing'
-- if @arg@ is not a @Stock (Override …)@ (the caller falls back to 'mkRepr').
overrideFieldTypes :: GenEnv -> Type -> Maybe (Type, [(DataCon, [Type])])
overrideFieldTypes :: GenEnv -> Type -> Maybe (Type, [(DataCon, [Type])])
overrideFieldTypes GenEnv
gen Type
arg = do
  TyCon
ourStock <- GenEnv -> Maybe TyCon
geStock GenEnv
gen
  TyCon
overTc   <- GenEnv -> Maybe TyCon
geOverride GenEnv
gen
  TyCon
keepTc   <- GenEnv -> Maybe TyCon
geKeep GenEnv
gen ; TyCon
arrowTc <- GenEnv -> Maybe TyCon
geArrow GenEnv
gen
  TyCon
assignTc <- GenEnv -> Maybe TyCon
geAssign GenEnv
gen ; TyCon
atTc <- GenEnv -> Maybe TyCon
geAt GenEnv
gen
  (TyCon
stockTc, [Type
innerOver]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
arg
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TyCon
stockTc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ourStock)
  (TyCon
oTc, [Type]
oArgs) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
innerOver
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TyCon
oTc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
overTc)
  (Type
cfg : Type
realInner : [Type]
_) <- [Type] -> Maybe [Type]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
oArgs)
  TyCon
innerTc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realInner
  let dcons :: [DataCon]
dcons = TyCon -> [DataCon]
tyConDataCons TyCon
innerTc
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not ([DataCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
dcons))
  [[Type]]
perCon <-
    case Type -> Maybe [[Type]]
decodePositional Type
cfg of
      Just [[Type]]
perCon                           -- positional [[..]] form
        | [[Type]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Type]]
perCon Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [DataCon] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
dcons ->
            [Maybe [Type]] -> Maybe [[Type]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((DataCon -> [Type] -> Maybe [Type])
-> [DataCon] -> [[Type]] -> [Maybe [Type]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (TyCon -> Type -> DataCon -> [Type] -> Maybe [Type]
posCon TyCon
keepTc Type
realInner) [DataCon]
dcons [[Type]]
perCon)
        | Bool
otherwise -> Maybe [[Type]]
forall a. Maybe a
Nothing
      Maybe [[Type]]
Nothing -> do                          -- entry-list / --> path form
        [(Addr, Type)]
entries <- Type -> Maybe [Type]
promotedListElems Type
cfg Maybe [Type]
-> ([Type] -> Maybe [(Addr, Type)]) -> Maybe [(Addr, Type)]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Type -> Maybe (Addr, Type)) -> [Type] -> Maybe [(Addr, Type)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (TyCon -> TyCon -> TyCon -> Type -> Maybe (Addr, Type)
decodeEntry TyCon
arrowTc TyCon
assignTc TyCon
atTc)
        case [DataCon]
-> Type -> [(Addr, Type)] -> Either SDoc [((Int, Int), Type)]
resolveCells [DataCon]
dcons Type
realInner [(Addr, Type)]
entries of
          Left SDoc
_      -> Maybe [[Type]]
forall a. Maybe a
Nothing
          Right [((Int, Int), Type)]
cells -> [[Type]] -> Maybe [[Type]]
forall a. a -> Maybe a
Just [ [ Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
rft ((Int, Int) -> [((Int, Int), Type)] -> Maybe Type
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Int
ci, Int
fi) [((Int, Int), Type)]
cells)
                                | (Int
fi, Type
rft) <- [Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (Type -> DataCon -> [Type]
fieldTysAt Type
realInner DataCon
dc) ]
                              | (Int
ci, DataCon
dc) <- [Int] -> [DataCon] -> [(Int, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [DataCon]
dcons ]
  (Type, [(DataCon, [Type])]) -> Maybe (Type, [(DataCon, [Type])])
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
realInner, [DataCon] -> [[Type]] -> [(DataCon, [Type])]
forall a b. [a] -> [b] -> [(a, b)]
zip [DataCon]
dcons [[Type]]
perCon)
  where
    -- one positional constructor: each slot a modifier type or @Keep@ (no change)
    posCon :: TyCon -> Type -> DataCon -> [Type] -> Maybe [Type]
posCon TyCon
keepTc Type
realInner DataCon
dc [Type]
mods
      | [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
mods Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
rfts = Maybe [Type]
forall a. Maybe a
Nothing
      | Bool
otherwise = [Maybe Type] -> Maybe [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((Type -> Type -> Maybe Type) -> [Type] -> [Type] -> [Maybe Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Type -> Maybe Type
cell [Type]
rfts [Type]
mods)
      where rfts :: [Type]
rfts = Type -> DataCon -> [Type]
fieldTysAt Type
realInner DataCon
dc
            cell :: Type -> Type -> Maybe Type
cell Type
rft Type
m
              | Type -> Maybe TyCon
tyConAppTyCon_maybe Type
m Maybe TyCon -> Maybe TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
keepTc = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
rft
              | Bool
otherwise = (SDoc -> Maybe Type)
-> (Type -> Maybe Type) -> Either SDoc Type -> Maybe Type
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Type -> SDoc -> Maybe Type
forall a b. a -> b -> a
const Maybe Type
forall a. Maybe a
Nothing) Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Type -> Either SDoc Type
modifierType Type
m Type
rft)

mkOverrideRepr :: GenEnv -> CtLoc -> Type -> TcPluginM (Maybe (Either SDoc (Repr, [Ct])))
mkOverrideRepr :: GenEnv
-> CtLoc -> Type -> TcPluginM (Maybe (Either SDoc (Repr, [Ct])))
mkOverrideRepr GenEnv
gen CtLoc
loc Type
wrappedTy
  | Just TyCon
ourStock <- GenEnv -> Maybe TyCon
geStock GenEnv
gen
  , Just TyCon
overTc   <- GenEnv -> Maybe TyCon
geOverride GenEnv
gen
  , Just TyCon
assignTc <- GenEnv -> Maybe TyCon
geAssign GenEnv
gen
  , Just (TyCon
stockTc, [Type
innerOver]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
wrappedTy
  , TyCon
stockTc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ourStock
  , Just (TyCon
oTc, [Type]
oArgs) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
innerOver
  , TyCon
oTc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
overTc
  , (Type
cfg : Type
realInner : [Type]
_) <- [Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
oArgs  -- last two visible args (drop the invisible cfg kind)
  , Just TyCon
atTc    <- GenEnv -> Maybe TyCon
geAt GenEnv
gen
  , Just TyCon
keepTc  <- GenEnv -> Maybe TyCon
geKeep GenEnv
gen
  , Just TyCon
arrowTc <- GenEnv -> Maybe TyCon
geArrow GenEnv
gen
  = Either SDoc (Repr, [Ct]) -> Maybe (Either SDoc (Repr, [Ct]))
forall a. a -> Maybe a
Just (Either SDoc (Repr, [Ct]) -> Maybe (Either SDoc (Repr, [Ct])))
-> TcPluginM (Either SDoc (Repr, [Ct]))
-> TcPluginM (Maybe (Either SDoc (Repr, [Ct])))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CtLoc
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> Type
-> Type
-> Type
-> TcPluginM (Either SDoc (Repr, [Ct]))
buildOverride CtLoc
loc TyCon
ourStock TyCon
overTc TyCon
assignTc TyCon
atTc TyCon
keepTc TyCon
arrowTc Type
innerOver Type
cfg Type
realInner
  | Bool
otherwise = Maybe (Either SDoc (Repr, [Ct]))
-> TcPluginM (Maybe (Either SDoc (Repr, [Ct])))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either SDoc (Repr, [Ct]))
forall a. Maybe a
Nothing

-- | The body of 'mkOverrideRepr', once it is known to be an @Override@.
-- Two config shapes (see @docs\/override-design.md@): a /positional/
-- list-of-lists @'[ '[m, …], … ]@ (one inner list per constructor, one element
-- per field, @Keep@ = no change), or an /entry list/ @'[ sel ':= m, 'C --> n
-- --> m, … ]@ — both multi-constructor, selector- and path-addressed.
buildOverride :: CtLoc -> TyCon -> TyCon -> TyCon -> TyCon -> TyCon -> TyCon
              -> Type -> Type -> Type -> TcPluginM (Either SDoc (Repr, [Ct]))
buildOverride :: CtLoc
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> Type
-> Type
-> Type
-> TcPluginM (Either SDoc (Repr, [Ct]))
buildOverride CtLoc
loc TyCon
ourStock TyCon
overTc TyCon
assignTc TyCon
atTc TyCon
keepTc TyCon
arrowTc Type
innerOver Type
cfg Type
realInner =
  case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
realInner of
    Maybe TyCon
Nothing -> SDoc -> TcPluginM (Either SDoc (Repr, [Ct]))
forall {a} {b}. a -> TcPluginM (Either a b)
bad (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override target is not a concrete algebraic type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
realInner)
    Just TyCon
innerTc -> case TyCon -> [DataCon]
tyConDataCons TyCon
innerTc of
      [] -> SDoc -> TcPluginM (Either SDoc (Repr, [Ct]))
forall {a} {b}. a -> TcPluginM (Either a b)
bad (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override: type has no constructors:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
realInner)
      [DataCon]
dcons
        | (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any DataCon -> Bool
dcUnpacked [DataCon]
dcons -> SDoc -> TcPluginM (Either SDoc (Repr, [Ct]))
forall {a} {b}. a -> TcPluginM (Either a b)
bad (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override: a constructor has UNPACKed/strict-unboxed"
                                       SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"or existential fields, unsupported")
        -- positional [[..]] form: one inner list per constructor
        | Just [[Type]]
perCon <- Type -> Maybe [[Type]]
decodePositional Type
cfg ->
            CtLoc
-> TyCon
-> TyCon
-> TyCon
-> Type
-> Type
-> Type
-> [DataCon]
-> [[Type]]
-> TcPluginM (Either SDoc (Repr, [Ct]))
buildPositional CtLoc
loc TyCon
ourStock TyCon
overTc TyCon
keepTc Type
innerOver Type
cfg Type
realInner [DataCon]
dcons [[Type]]
perCon
        -- entry-list form ( := / At / --> paths ), multi-constructor
        | Bool
otherwise ->
            case Type -> Maybe [Type]
promotedListElems Type
cfg Maybe [Type]
-> ([Type] -> Maybe [(Addr, Type)]) -> Maybe [(Addr, Type)]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Type -> Maybe (Addr, Type)) -> [Type] -> Maybe [(Addr, Type)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (TyCon -> TyCon -> TyCon -> Type -> Maybe (Addr, Type)
decodeEntry TyCon
arrowTc TyCon
assignTc TyCon
atTc) of
              Maybe [(Addr, Type)]
Nothing      -> SDoc -> TcPluginM (Either SDoc (Repr, [Ct]))
forall {a} {b}. a -> TcPluginM (Either a b)
bad (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override config is not a concrete list of"
                                   SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"selector := modifier / path --> modifier entries:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cfg)
              Just [(Addr, Type)]
entries -> CtLoc
-> TyCon
-> TyCon
-> Type
-> Type
-> Type
-> [DataCon]
-> [(Addr, Type)]
-> TcPluginM (Either SDoc (Repr, [Ct]))
resolveOverride CtLoc
loc TyCon
ourStock TyCon
overTc Type
innerOver Type
cfg Type
realInner [DataCon]
dcons [(Addr, Type)]
entries
  where bad :: a -> TcPluginM (Either a b)
bad = Either a b -> TcPluginM (Either a b)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a b -> TcPluginM (Either a b))
-> (a -> Either a b) -> a -> TcPluginM (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left

-- | A positional config @'[ '[m00, m01, …], … ]@ as per-constructor,
-- per-field modifier lists, or 'Nothing' if @cfg@ is not a concrete
-- list-of-lists (in which case the entry-list decoder is tried instead).
decodePositional :: Type -> Maybe [[Type]]
decodePositional :: Type -> Maybe [[Type]]
decodePositional Type
cfg = case Type -> Maybe [Type]
promotedListElems Type
cfg of
  Just es :: [Type]
es@(Type
_ : [Type]
_) -> (Type -> Maybe [Type]) -> [Type] -> Maybe [[Type]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> Maybe [Type]
promotedListElems [Type]
es   -- one inner list per constructor
  Maybe [Type]
_               -> Maybe [[Type]]
forall a. Maybe a
Nothing                          -- empty @'[]@ is identity, not "0
                                                      -- constructors": fall through to the
                                                      -- entry-list branch (@resolveOverride []@)

-- | Build the 'Repr' for a positional config: each constructor's inner list
-- gives a modifier per field — @Keep@ leaves the field, any other type @m@
-- replaces it (kind-dispatched 'pin' vs 'broadcast' by 'modifierType'), with a
-- per-cell @realτ ~R modτ@ coercion emitted as a wanted.
buildPositional :: CtLoc -> TyCon -> TyCon -> TyCon -> Type -> Type -> Type
                -> [DataCon] -> [[Type]] -> TcPluginM (Either SDoc (Repr, [Ct]))
buildPositional :: CtLoc
-> TyCon
-> TyCon
-> TyCon
-> Type
-> Type
-> Type
-> [DataCon]
-> [[Type]]
-> TcPluginM (Either SDoc (Repr, [Ct]))
buildPositional CtLoc
loc TyCon
ourStock TyCon
overTc TyCon
keepTc Type
innerOver Type
cfg Type
realInner [DataCon]
dcons [[Type]]
perCon
  | [[Type]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Type]]
perCon Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [DataCon] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
dcons =
      Either SDoc (Repr, [Ct]) -> TcPluginM (Either SDoc (Repr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SDoc -> Either SDoc (Repr, [Ct])
forall a b. a -> Either a b
Left (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override: positional config has" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int ([[Type]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Type]]
perCon)
                  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"constructor list(s) but" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
realInner SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has"
                  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int ([DataCon] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
dcons)))
  | Bool
otherwise = do
      let co :: Coercion
co = Coercion -> Coercion -> Coercion
mkTransCo (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
ourStock) [Type
innerOver] [])
                         (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
overTc) [HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
cfg, Type
realInner, Type
cfg] [])
      [Either SDoc (ConInfo, [Ct])]
results <- ((DataCon, [Type]) -> TcPluginM (Either SDoc (ConInfo, [Ct])))
-> [(DataCon, [Type])] -> TcPluginM [Either SDoc (ConInfo, [Ct])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((DataCon -> [Type] -> TcPluginM (Either SDoc (ConInfo, [Ct])))
-> (DataCon, [Type]) -> TcPluginM (Either SDoc (ConInfo, [Ct]))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry DataCon -> [Type] -> TcPluginM (Either SDoc (ConInfo, [Ct]))
conInfo) ([DataCon] -> [[Type]] -> [(DataCon, [Type])]
forall a b. [a] -> [b] -> [(a, b)]
zip [DataCon]
dcons [[Type]]
perCon)
      Either SDoc (Repr, [Ct]) -> TcPluginM (Either SDoc (Repr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SDoc (Repr, [Ct]) -> TcPluginM (Either SDoc (Repr, [Ct])))
-> Either SDoc (Repr, [Ct]) -> TcPluginM (Either SDoc (Repr, [Ct]))
forall a b. (a -> b) -> a -> b
$ case [Either SDoc (ConInfo, [Ct])] -> Either SDoc [(ConInfo, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Either SDoc (ConInfo, [Ct])]
results of
        Left SDoc
err   -> SDoc -> Either SDoc (Repr, [Ct])
forall a b. a -> Either a b
Left SDoc
err
        Right [(ConInfo, [Ct])]
cws  -> (Repr, [Ct]) -> Either SDoc (Repr, [Ct])
forall a b. b -> Either a b
Right (Type -> Coercion -> [ConInfo] -> Repr
Repr Type
realInner Coercion
co (((ConInfo, [Ct]) -> ConInfo) -> [(ConInfo, [Ct])] -> [ConInfo]
forall a b. (a -> b) -> [a] -> [b]
map (ConInfo, [Ct]) -> ConInfo
forall a b. (a, b) -> a
fst [(ConInfo, [Ct])]
cws), ((ConInfo, [Ct]) -> [Ct]) -> [(ConInfo, [Ct])] -> [Ct]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ConInfo, [Ct]) -> [Ct]
forall a b. (a, b) -> b
snd [(ConInfo, [Ct])]
cws)
  where
    conInfo :: DataCon -> [Type] -> TcPluginM (Either SDoc (ConInfo, [Ct]))
    conInfo :: DataCon -> [Type] -> TcPluginM (Either SDoc (ConInfo, [Ct]))
conInfo DataCon
dc [Type]
mods
      | [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
mods Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
realFts =
          Either SDoc (ConInfo, [Ct])
-> TcPluginM (Either SDoc (ConInfo, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SDoc -> Either SDoc (ConInfo, [Ct])
forall a b. a -> Either a b
Left (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override: constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
realFts)
                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"field(s) but its positional list has" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
mods)))
      | Bool
otherwise = do
          [Either SDoc ((Type, Coercion), [Ct])]
cells <- ((Type, Type) -> TcPluginM (Either SDoc ((Type, Coercion), [Ct])))
-> [(Type, Type)]
-> TcPluginM [Either SDoc ((Type, Coercion), [Ct])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Type, Type) -> TcPluginM (Either SDoc ((Type, Coercion), [Ct]))
cell ([Type] -> [Type] -> [(Type, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
realFts [Type]
mods)
          Either SDoc (ConInfo, [Ct])
-> TcPluginM (Either SDoc (ConInfo, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SDoc (ConInfo, [Ct])
 -> TcPluginM (Either SDoc (ConInfo, [Ct])))
-> Either SDoc (ConInfo, [Ct])
-> TcPluginM (Either SDoc (ConInfo, [Ct]))
forall a b. (a -> b) -> a -> b
$ case [Either SDoc ((Type, Coercion), [Ct])]
-> Either SDoc [((Type, Coercion), [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Either SDoc ((Type, Coercion), [Ct])]
cells of
            Left SDoc
err -> SDoc -> Either SDoc (ConInfo, [Ct])
forall a b. a -> Either a b
Left SDoc
err
            Right [((Type, Coercion), [Ct])]
fs -> (ConInfo, [Ct]) -> Either SDoc (ConInfo, [Ct])
forall a b. b -> Either a b
Right (DataCon -> [Type] -> [Coercion] -> ConInfo
ConInfo DataCon
dc ((((Type, Coercion), [Ct]) -> Type)
-> [((Type, Coercion), [Ct])] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ((Type, Coercion) -> Type
forall a b. (a, b) -> a
fst ((Type, Coercion) -> Type)
-> (((Type, Coercion), [Ct]) -> (Type, Coercion))
-> ((Type, Coercion), [Ct])
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, Coercion), [Ct]) -> (Type, Coercion)
forall a b. (a, b) -> a
fst) [((Type, Coercion), [Ct])]
fs) ((((Type, Coercion), [Ct]) -> Coercion)
-> [((Type, Coercion), [Ct])] -> [Coercion]
forall a b. (a -> b) -> [a] -> [b]
map ((Type, Coercion) -> Coercion
forall a b. (a, b) -> b
snd ((Type, Coercion) -> Coercion)
-> (((Type, Coercion), [Ct]) -> (Type, Coercion))
-> ((Type, Coercion), [Ct])
-> Coercion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, Coercion), [Ct]) -> (Type, Coercion)
forall a b. (a, b) -> a
fst) [((Type, Coercion), [Ct])]
fs)
                              , (((Type, Coercion), [Ct]) -> [Ct])
-> [((Type, Coercion), [Ct])] -> [Ct]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Type, Coercion), [Ct]) -> [Ct]
forall a b. (a, b) -> b
snd [((Type, Coercion), [Ct])]
fs)
      where realFts :: [Type]
realFts = Type -> DataCon -> [Type]
fieldTysAt Type
realInner DataCon
dc
    -- one field: Keep ⇒ (realτ, Refl); modifier m ⇒ (modτ, evidence coercion + wanted)
    cell :: (Type, Type) -> TcPluginM (Either SDoc ((Type, Coercion), [Ct]))
    cell :: (Type, Type) -> TcPluginM (Either SDoc ((Type, Coercion), [Ct]))
cell (Type
ft, Type
m)
      | Type -> Maybe TyCon
tyConAppTyCon_maybe Type
m Maybe TyCon -> Maybe TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
keepTc = Either SDoc ((Type, Coercion), [Ct])
-> TcPluginM (Either SDoc ((Type, Coercion), [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Type, Coercion), [Ct]) -> Either SDoc ((Type, Coercion), [Ct])
forall a b. b -> Either a b
Right ((Type
ft, Type -> Coercion
mkRepReflCo Type
ft), []))
      | Bool
otherwise = case Type -> Type -> Either SDoc Type
modifierType Type
m Type
ft of
          Left SDoc
err    -> Either SDoc ((Type, Coercion), [Ct])
-> TcPluginM (Either SDoc ((Type, Coercion), [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SDoc -> Either SDoc ((Type, Coercion), [Ct])
forall a b. a -> Either a b
Left SDoc
err)
          Right Type
modTy -> do
            CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Type -> Type -> Type
mkStockReprEq Type
ft Type
modTy)
            Either SDoc ((Type, Coercion), [Ct])
-> TcPluginM (Either SDoc ((Type, Coercion), [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Type, Coercion), [Ct]) -> Either SDoc ((Type, Coercion), [Ct])
forall a b. b -> Either a b
Right ((Type
modTy, HasDebugCallStack => CtEvidence -> Coercion
CtEvidence -> Coercion
ctEvCoercion CtEvidence
ev), [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))

-- | A path hop (design §4): a constructor, a field by position, or a field by
-- label.  Constructor hops match by /occ-name/, so both @'P@ and (for a
-- single-constructor type) the bare type name resolve.
data Hop = HopCon FastString | HopPos Integer | HopLabel FastString

-- | A decoded entry's address: a @-->@ \/ @:=@ path of hops (narrowing the
-- @(constructor, field)@ scope), or a type selector.
data Addr = AddrPath [Hop] | AddrType Type

-- | Resolve decoded @(addr, modifier)@ entries against /all/ the type's
-- constructors: turn each address into its cell set @(ctorIndex, fieldIndex)@,
-- reject any cell claimed twice, kind-dispatch each modifier per cell, emit the
-- per-cell coercion wanteds, and assemble the (multi-constructor) 'Repr'.
resolveOverride :: CtLoc -> TyCon -> TyCon -> Type -> Type -> Type -> [DataCon]
                -> [(Addr, Type)] -> TcPluginM (Either SDoc (Repr, [Ct]))
resolveOverride :: CtLoc
-> TyCon
-> TyCon
-> Type
-> Type
-> Type
-> [DataCon]
-> [(Addr, Type)]
-> TcPluginM (Either SDoc (Repr, [Ct]))
resolveOverride CtLoc
loc TyCon
ourStock TyCon
overTc Type
innerOver Type
cfg Type
realInner [DataCon]
dcons [(Addr, Type)]
entries =
  case [DataCon]
-> Type -> [(Addr, Type)] -> Either SDoc [((Int, Int), Type)]
resolveCells [DataCon]
dcons Type
realInner [(Addr, Type)]
entries of
    Left SDoc
err    -> Either SDoc (Repr, [Ct]) -> TcPluginM (Either SDoc (Repr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SDoc -> Either SDoc (Repr, [Ct])
forall a b. a -> Either a b
Left SDoc
err)
    Right [((Int, Int), Type)]
cells -> do
      [(((Int, Int), (Type, Coercion)), Ct)]
tagged <- [((Int, Int), Type)]
-> (((Int, Int), Type)
    -> TcPluginM (((Int, Int), (Type, Coercion)), Ct))
-> TcPluginM [(((Int, Int), (Type, Coercion)), Ct)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [((Int, Int), Type)]
cells \((Int
ci, Int
fi), Type
modTy) -> do
        let realFt :: Type
realFt = Type -> DataCon -> [Type]
fieldTysAt Type
realInner ([DataCon]
dcons [DataCon] -> Int -> DataCon
forall a. HasCallStack => [a] -> Int -> a
!! Int
ci) [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
fi
        CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Type -> Type -> Type
mkStockReprEq Type
realFt Type
modTy)
        (((Int, Int), (Type, Coercion)), Ct)
-> TcPluginM (((Int, Int), (Type, Coercion)), Ct)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Int
ci, Int
fi), (Type
modTy, HasDebugCallStack => CtEvidence -> Coercion
CtEvidence -> Coercion
ctEvCoercion CtEvidence
ev)), CtEvidence -> Ct
mkNonCanonical CtEvidence
ev)
      let cellMap :: [((Int, Int), (Type, Coercion))]
cellMap = ((((Int, Int), (Type, Coercion)), Ct)
 -> ((Int, Int), (Type, Coercion)))
-> [(((Int, Int), (Type, Coercion)), Ct)]
-> [((Int, Int), (Type, Coercion))]
forall a b. (a -> b) -> [a] -> [b]
map (((Int, Int), (Type, Coercion)), Ct)
-> ((Int, Int), (Type, Coercion))
forall a b. (a, b) -> a
fst [(((Int, Int), (Type, Coercion)), Ct)]
tagged
          wanteds :: [Ct]
wanteds = ((((Int, Int), (Type, Coercion)), Ct) -> Ct)
-> [(((Int, Int), (Type, Coercion)), Ct)] -> [Ct]
forall a b. (a -> b) -> [a] -> [b]
map (((Int, Int), (Type, Coercion)), Ct) -> Ct
forall a b. (a, b) -> b
snd [(((Int, Int), (Type, Coercion)), Ct)]
tagged
          -- Stock (Override T cfg) ~R Override T cfg ~R T
          co :: Coercion
co = Coercion -> Coercion -> Coercion
mkTransCo (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
ourStock) [Type
innerOver] [])
                         (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
overTc) [HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
cfg, Type
realInner, Type
cfg] [])
          cons :: [ConInfo]
cons = [ DataCon -> [Type] -> [Coercion] -> ConInfo
ConInfo DataCon
dc (((Type, Coercion) -> Type) -> [(Type, Coercion)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Coercion) -> Type
forall a b. (a, b) -> a
fst [(Type, Coercion)]
fields) (((Type, Coercion) -> Coercion) -> [(Type, Coercion)] -> [Coercion]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Coercion) -> Coercion
forall a b. (a, b) -> b
snd [(Type, Coercion)]
fields)
                 | (Int
ci, DataCon
dc) <- [Int] -> [DataCon] -> [(Int, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [DataCon]
dcons
                 , let fields :: [(Type, Coercion)]
fields = [ (Type, Coercion) -> Maybe (Type, Coercion) -> (Type, Coercion)
forall a. a -> Maybe a -> a
fromMaybe (Type
ft, Type -> Coercion
mkRepReflCo Type
ft) ((Int, Int)
-> [((Int, Int), (Type, Coercion))] -> Maybe (Type, Coercion)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Int
ci, Int
fi) [((Int, Int), (Type, Coercion))]
cellMap)
                                | (Int
fi, Type
ft) <- [Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] (Type -> DataCon -> [Type]
fieldTysAt Type
realInner DataCon
dc) ] ]
      Either SDoc (Repr, [Ct]) -> TcPluginM (Either SDoc (Repr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Repr, [Ct]) -> Either SDoc (Repr, [Ct])
forall a b. b -> Either a b
Right (Type -> Coercion -> [ConInfo] -> Repr
Repr Type
realInner Coercion
co [ConInfo]
cons, [Ct]
wanteds))

-- | As 'resolveCells', but keeping the /raw/ modifier @m@ per cell (not
-- 'modifierType'-applied) — for @Override1@\/@Override2@, whose synthesizers
-- want the bare functor modifier (they reshape @h a@ to @m a@ themselves).
resolveCellsRaw :: [DataCon] -> Type -> [(Addr, Type)] -> Either SDoc [((Int, Int), Type)]
resolveCellsRaw :: [DataCon]
-> Type -> [(Addr, Type)] -> Either SDoc [((Int, Int), Type)]
resolveCellsRaw [DataCon]
dcons Type
targetTy = [(Int, Int)] -> [(Addr, Type)] -> Either SDoc [((Int, Int), Type)]
forall {b}.
[(Int, Int)] -> [(Addr, b)] -> Either SDoc [((Int, Int), b)]
go []
  where
    go :: [(Int, Int)] -> [(Addr, b)] -> Either SDoc [((Int, Int), b)]
go [(Int, Int)]
_       []                 = [((Int, Int), b)] -> Either SDoc [((Int, Int), b)]
forall a b. b -> Either a b
Right []
    go [(Int, Int)]
claimed ((Addr
addr, b
m) : [(Addr, b)]
rest) = do
      [(Int, Int)]
cells <- [DataCon] -> Type -> Addr -> Either SDoc [(Int, Int)]
resolveAddr [DataCon]
dcons Type
targetTy Addr
addr
      case ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int, Int) -> [(Int, Int)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Int, Int)]
claimed) [(Int, Int)]
cells of
        clash :: [(Int, Int)]
clash@((Int, Int)
_ : [(Int, Int)]
_) -> SDoc -> Either SDoc [((Int, Int), b)]
forall a b. a -> Either a b
Left (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override: cell(s)" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(Int, Int)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Int, Int)]
clash
                               SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"claimed by more than one entry (make them disjoint)")
        [] -> ((((Int, Int) -> ((Int, Int), b))
-> [(Int, Int)] -> [((Int, Int), b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int, Int)
c -> ((Int, Int)
c, b
m)) [(Int, Int)]
cells) ++) ([((Int, Int), b)] -> [((Int, Int), b)])
-> Either SDoc [((Int, Int), b)] -> Either SDoc [((Int, Int), b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Int)] -> [(Addr, b)] -> Either SDoc [((Int, Int), b)]
go ([(Int, Int)]
cells [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int, Int)]
claimed) [(Addr, b)]
rest

-- | Resolve every entry to its cells (with kind-dispatched modifier types),
-- left to right, enforcing the no-overlap law against the cells already claimed.
resolveCells :: [DataCon] -> Type -> [(Addr, Type)]
             -> Either SDoc [((Int, Int), Type)]
resolveCells :: [DataCon]
-> Type -> [(Addr, Type)] -> Either SDoc [((Int, Int), Type)]
resolveCells [DataCon]
dcons Type
targetTy = [(Int, Int)] -> [(Addr, Type)] -> Either SDoc [((Int, Int), Type)]
go []
  where
    go :: [(Int, Int)] -> [(Addr, Type)] -> Either SDoc [((Int, Int), Type)]
go [(Int, Int)]
_       []                 = [((Int, Int), Type)] -> Either SDoc [((Int, Int), Type)]
forall a b. b -> Either a b
Right []
    go [(Int, Int)]
claimed ((Addr
addr, Type
m) : [(Addr, Type)]
rest) = do
      [(Int, Int)]
cells <- [DataCon] -> Type -> Addr -> Either SDoc [(Int, Int)]
resolveAddr [DataCon]
dcons Type
targetTy Addr
addr
      case ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int, Int) -> [(Int, Int)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Int, Int)]
claimed) [(Int, Int)]
cells of
        clash :: [(Int, Int)]
clash@((Int, Int)
_ : [(Int, Int)]
_) -> SDoc -> Either SDoc [((Int, Int), Type)]
forall a b. a -> Either a b
Left (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override: cell(s)" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(Int, Int)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Int, Int)]
clash
                               SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"claimed by more than one entry (make them disjoint)")
        [] -> do
          [((Int, Int), Type)]
here <- [(Int, Int)]
-> ((Int, Int) -> Either SDoc ((Int, Int), Type))
-> Either SDoc [((Int, Int), Type)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Int, Int)]
cells \(Int
ci, Int
fi) ->
                    (,) (Int
ci, Int
fi) (Type -> ((Int, Int), Type))
-> Either SDoc Type -> Either SDoc ((Int, Int), Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Type -> Either SDoc Type
modifierType Type
m (Type -> DataCon -> [Type]
fieldTysAt Type
targetTy ([DataCon]
dcons [DataCon] -> Int -> DataCon
forall a. HasCallStack => [a] -> Int -> a
!! Int
ci) [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
fi)
          ([((Int, Int), Type)]
here ++) ([((Int, Int), Type)] -> [((Int, Int), Type)])
-> Either SDoc [((Int, Int), Type)]
-> Either SDoc [((Int, Int), Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Int)] -> [(Addr, Type)] -> Either SDoc [((Int, Int), Type)]
go ([(Int, Int)]
cells [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int, Int)]
claimed) [(Addr, Type)]
rest

-- | Resolve one address to its @(ctorIndex, fieldIndex)@ cell set.
resolveAddr :: [DataCon] -> Type -> Addr -> Either SDoc [(Int, Int)]
resolveAddr :: [DataCon] -> Type -> Addr -> Either SDoc [(Int, Int)]
resolveAddr [DataCon]
dcons Type
targetTy Addr
addr = case Addr
addr of
  AddrType Type
t
    | Type
t Type -> Type -> Bool
`eqType` Type
targetTy -> [(Int, Int)] -> Either SDoc [(Int, Int)]
forall a b. b -> Either a b
Right ([DataCon] -> Type -> [(Int, Int)]
allCells [DataCon]
dcons Type
targetTy)
    | Bool
otherwise -> case [ (Int
ci, Int
fi) | (Int
ci, DataCon
dc) <- [Int] -> [DataCon] -> [(Int, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [DataCon]
dcons
                                   , (Int
fi, Type
ft) <- [Int] -> [Type] -> [(Int, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (Type -> DataCon -> [Type]
fieldTysAt Type
targetTy DataCon
dc)
                                   , Type
ft Type -> Type -> Bool
`eqType` Type
t ] of
        [] -> SDoc -> Either SDoc [(Int, Int)]
forall a b. a -> Either a b
Left (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override: no field of type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t))
        [(Int, Int)]
cs -> [(Int, Int)] -> Either SDoc [(Int, Int)]
forall a b. b -> Either a b
Right [(Int, Int)]
cs
  AddrPath [Hop]
hops -> [DataCon]
-> Type -> [(Int, Int)] -> [Hop] -> Either SDoc [(Int, Int)]
foldHops [DataCon]
dcons Type
targetTy ([DataCon] -> Type -> [(Int, Int)]
allCells [DataCon]
dcons Type
targetTy) [Hop]
hops

-- | Narrow the cell scope by each hop in turn.
foldHops :: [DataCon] -> Type -> [(Int, Int)] -> [Hop] -> Either SDoc [(Int, Int)]
foldHops :: [DataCon]
-> Type -> [(Int, Int)] -> [Hop] -> Either SDoc [(Int, Int)]
foldHops [DataCon]
_     Type
_        [(Int, Int)]
scope []               = [(Int, Int)] -> Either SDoc [(Int, Int)]
forall a b. b -> Either a b
Right [(Int, Int)]
scope
foldHops [DataCon]
dcons Type
targetTy [(Int, Int)]
scope (HopCon FastString
nm : [Hop]
hs) =
  case [ Int
ci | (Int
ci, DataCon
dc) <- [Int] -> [DataCon] -> [(Int, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [DataCon]
dcons, OccName -> FastString
occNameFS (DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
dc) FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
nm ] of
    []  -> SDoc -> Either SDoc [(Int, Int)]
forall a b. a -> Either a b
Left (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override: unknown constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
nm))
    [Int]
cis -> [DataCon]
-> Type -> [(Int, Int)] -> [Hop] -> Either SDoc [(Int, Int)]
foldHops [DataCon]
dcons Type
targetTy (((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
cis) (Int -> Bool) -> ((Int, Int) -> Int) -> (Int, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst) [(Int, Int)]
scope) [Hop]
hs
foldHops [DataCon]
dcons Type
targetTy [(Int, Int)]
scope (HopPos Integer
n : [Hop]
hs) =
  case ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) (Int -> Bool) -> ((Int, Int) -> Int) -> (Int, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd) [(Int, Int)]
scope of
    []  -> SDoc -> Either SDoc [(Int, Int)]
forall a b. a -> Either a b
Left (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override: no field at position" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer Integer
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the addressed scope")
    [(Int, Int)]
sc' -> [DataCon]
-> Type -> [(Int, Int)] -> [Hop] -> Either SDoc [(Int, Int)]
foldHops [DataCon]
dcons Type
targetTy [(Int, Int)]
sc' [Hop]
hs
foldHops [DataCon]
dcons Type
targetTy [(Int, Int)]
scope (HopLabel FastString
l : [Hop]
hs) =
  case [ (Int
ci, Int
fi) | (Int
ci, Int
fi) <- [(Int, Int)]
scope, DataCon -> Int -> Maybe String
labelAt ([DataCon]
dcons [DataCon] -> Int -> DataCon
forall a. HasCallStack => [a] -> Int -> a
!! Int
ci) Int
fi Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just (FastString -> String
unpackFS FastString
l) ] of
    []  -> SDoc -> Either SDoc [(Int, Int)]
forall a b. a -> Either a b
Left (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override: no field labelled" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
l) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the addressed scope")
    [(Int, Int)]
sc' -> [DataCon]
-> Type -> [(Int, Int)] -> [Hop] -> Either SDoc [(Int, Int)]
foldHops [DataCon]
dcons Type
targetTy [(Int, Int)]
sc' [Hop]
hs

-- | Every @(ctorIndex, fieldIndex)@ cell of the type.  Uses the source arity
-- (not 'fieldTysAt') so it is safe when @targetTy@ is an unsaturated @j -> Type@
-- (the @Override1@\/@Override2@ case).
allCells :: [DataCon] -> Type -> [(Int, Int)]
allCells :: [DataCon] -> Type -> [(Int, Int)]
allCells [DataCon]
dcons Type
_ =
  [ (Int
ci, Int
fi) | (Int
ci, DataCon
dc) <- [Int] -> [DataCon] -> [(Int, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [DataCon]
dcons, Int
fi <- [Int
0 .. DataCon -> Int
dataConSourceArity DataCon
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]

-- | The record label of a constructor's @i@-th field, if it has one.
labelAt :: DataCon -> Int -> Maybe String
labelAt :: DataCon -> Int -> Maybe String
labelAt DataCon
dc Int
i =
  let ls :: [String]
ls = (FieldLabel -> String) -> [FieldLabel] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString (OccName -> String)
-> (FieldLabel -> OccName) -> FieldLabel -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (FieldLabel -> Name) -> FieldLabel -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> Name
flSelector) (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc)
  in if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls then String -> Maybe String
forall a. a -> Maybe a
Just ([String]
ls [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) else Maybe String
forall a. Maybe a
Nothing

-- | Kind-dispatch a modifier: a saturated @Type@ pins the field to that type;
-- a unary @Type -> Type@ is applied to the field's own type (broadcast).
modifierType :: Type -> Type -> Either SDoc Type
modifierType :: Type -> Type -> Either SDoc Type
modifierType Type
m Type
fieldTy
  | Type
k Type -> Type -> Bool
`eqType` Type
liftedTypeKind                              = Type -> Either SDoc Type
forall a b. b -> Either a b
Right Type
m
  | Type
k Type -> Type -> Bool
`eqType` HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
liftedTypeKind Type
liftedTypeKind = Type -> Either SDoc Type
forall a b. b -> Either a b
Right (Type -> Type -> Type
mkAppTy Type
m Type
fieldTy)
  | Bool
otherwise = SDoc -> Either SDoc Type
forall a b. a -> Either a b
Left (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Override: modifier" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
m SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"has unsupported kind"
                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(expected Type or Type -> Type)")
  where k :: Type
k = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
m

-- | A balanced list of the elements of a promoted type-level list
-- (@'[a, b, …]@), or 'Nothing' if @ty@ is not a concrete promoted list.
promotedListElems :: Type -> Maybe [Type]
promotedListElems :: Type -> Maybe [Type]
promotedListElems Type
ty = do
  (TyCon
tc, [Type]
args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
  if | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
promotedNilDataCon  -> [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just []
     | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
promotedConsDataCon -> case [Type]
args of
         [Type
_k, Type
x, Type
rest] -> (Type
x :) ([Type] -> [Type]) -> Maybe [Type] -> Maybe [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe [Type]
promotedListElems Type
rest
         [Type]
_             -> Maybe [Type]
forall a. Maybe a
Nothing
     | Bool
otherwise -> Maybe [Type]
forall a. Maybe a
Nothing

-- | Decode one config entry into its address and modifier.  Three surfaces:
-- a @-->@ path (@'P --> 0 --> m@), a @:=@ entry (@"x" := m@ or @At C n := m@),
-- or — still through @:=@ — a type selector (@Int := m@).  Robust to leading
-- invisible kind arguments (the visible operands are the last two).
decodeEntry :: TyCon -> TyCon -> TyCon -> Type -> Maybe (Addr, Type)
decodeEntry :: TyCon -> TyCon -> TyCon -> Type -> Maybe (Addr, Type)
decodeEntry TyCon
arrowTc TyCon
assignTc TyCon
atTc Type
e
  | Just ([Type]
hops, Type
m) <- TyCon -> Type -> Maybe ([Type], Type)
decodeArrow TyCon
arrowTc Type
e =
      (\[Hop]
hs -> ([Hop] -> Addr
AddrPath [Hop]
hs, Type
m)) ([Hop] -> (Addr, Type)) -> Maybe [Hop] -> Maybe (Addr, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Maybe Hop) -> [Type] -> Maybe [Hop]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> Maybe Hop
decodeHop [Type]
hops
  | Just (TyCon
tc, [Type]
args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
e, TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
assignTc
  , (Type
m : Type
sel : [Type]
_) <- [Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
args = (, Type
m) (Addr -> (Addr, Type)) -> Maybe Addr -> Maybe (Addr, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon -> Type -> Maybe Addr
decodeSel TyCon
atTc Type
sel
  | Bool
otherwise = Maybe (Addr, Type)
forall a. Maybe a
Nothing

-- | Flatten a right-nested @a --> b --> … --> m@ into its hop types and the
-- terminal modifier; 'Nothing' if @e@ is not a @-->@ application.
decodeArrow :: TyCon -> Type -> Maybe ([Type], Type)
decodeArrow :: TyCon -> Type -> Maybe ([Type], Type)
decodeArrow TyCon
arrowTc Type
e = do
  (TyCon
tc, [Type]
args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
e
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
arrowTc)
  case [Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
args of
    (Type
rhs : Type
lhs : [Type]
_) -> case TyCon -> Type -> Maybe ([Type], Type)
decodeArrow TyCon
arrowTc Type
rhs of
      Just ([Type]
hs, Type
m) -> ([Type], Type) -> Maybe ([Type], Type)
forall a. a -> Maybe a
Just (Type
lhs Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
hs, Type
m)   -- rhs continues the path
      Maybe ([Type], Type)
Nothing      -> ([Type], Type) -> Maybe ([Type], Type)
forall a. a -> Maybe a
Just ([Type
lhs], Type
rhs)    -- rhs is the terminal modifier
    [Type]
_ -> Maybe ([Type], Type)
forall a. Maybe a
Nothing

-- | Classify a path hop by kind: 'Symbol' ⇒ label, 'Nat' ⇒ position, otherwise
-- a (promoted constructor \/ type) matched later by occ-name.
decodeHop :: Type -> Maybe Hop
decodeHop :: Type -> Maybe Hop
decodeHop Type
h
  | Just FastString
fs <- Type -> Maybe FastString
isStrLitTy Type
h          = Hop -> Maybe Hop
forall a. a -> Maybe a
Just (FastString -> Hop
HopLabel FastString
fs)
  | Just Integer
n  <- Type -> Maybe Integer
isNumLitTy Type
h          = Hop -> Maybe Hop
forall a. a -> Maybe a
Just (Integer -> Hop
HopPos Integer
n)
  | Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
h = Hop -> Maybe Hop
forall a. a -> Maybe a
Just (FastString -> Hop
HopCon (OccName -> FastString
occNameFS (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
tc)))
  | Bool
otherwise                        = Maybe Hop
forall a. Maybe a
Nothing

-- | Classify the left of @:=@: a 'Symbol' is a label path, @At C n@ a
-- constructor+position path, anything else a type selector.
decodeSel :: TyCon -> Type -> Maybe Addr
decodeSel :: TyCon -> Type -> Maybe Addr
decodeSel TyCon
atTc Type
sel
  | Just FastString
fs <- Type -> Maybe FastString
isStrLitTy Type
sel = Addr -> Maybe Addr
forall a. a -> Maybe a
Just ([Hop] -> Addr
AddrPath [FastString -> Hop
HopLabel FastString
fs])
  | Just (TyCon
tc, [Type]
args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
sel, TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
atTc
  , (Type
pos : Type
con : [Type]
_) <- [Type] -> [Type]
forall a. [a] -> [a]
reverse [Type]
args, Just Integer
n <- Type -> Maybe Integer
isNumLitTy Type
pos
  , Just TyCon
ctc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
con =
      Addr -> Maybe Addr
forall a. a -> Maybe a
Just ([Hop] -> Addr
AddrPath [FastString -> Hop
HopCon (OccName -> FastString
occNameFS (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName TyCon
ctc)), Integer -> Hop
HopPos Integer
n])
  | Bool
otherwise = Addr -> Maybe Addr
forall a. a -> Maybe a
Just (Type -> Addr
AddrType Type
sel)

-- | Does any cell carry a non-trivial override (a modifier coercion that isn't
-- reflexivity)?  The raw @viaSynth@ synthesizers (Ord\/Show\/Read\/Enum\/Ix)
-- recompute field types from the constructor and so cannot honour an override;
-- the dispatcher uses this to reject them loudly rather than silently ignore it.
reprOverridden :: Repr -> Bool
reprOverridden :: Repr -> Bool
reprOverridden = (ConInfo -> Bool) -> [ConInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Coercion -> Bool) -> [Coercion] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Coercion -> Bool) -> Coercion -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coercion -> Bool
isReflCo) ([Coercion] -> Bool) -> (ConInfo -> [Coercion]) -> ConInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConInfo -> [Coercion]
ciFieldCos) ([ConInfo] -> Bool) -> (Repr -> [ConInfo]) -> Repr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repr -> [ConInfo]
rCons

-- Representation predicates ("checking the datatype representation").
reprHasFields, reprIsEnum, reprSingleCon, reprEmpty :: Repr -> Bool
reprHasFields :: Repr -> Bool
reprHasFields = (ConInfo -> Bool) -> [ConInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (ConInfo -> Bool) -> ConInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Type] -> Bool) -> (ConInfo -> [Type]) -> ConInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConInfo -> [Type]
ciFields) ([ConInfo] -> Bool) -> (Repr -> [ConInfo]) -> Repr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repr -> [ConInfo]
rCons
-- GHC: an enumeration has >= 1 nullary constructor.  Requiring non-empty here
-- makes Enum/Ix/Bounded reject 0-constructor types cleanly (rather than build
-- degenerate Core: maxTag = -1, head/last of []), matching GHC's rejection.
reprIsEnum :: Repr -> Bool
reprIsEnum    Repr
r = Bool -> Bool
not (Repr -> Bool
reprEmpty Repr
r) Bool -> Bool -> Bool
&& Bool -> Bool
not (Repr -> Bool
reprHasFields Repr
r)
reprSingleCon :: Repr -> Bool
reprSingleCon = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> (Repr -> Int) -> Repr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ConInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ConInfo] -> Int) -> (Repr -> [ConInfo]) -> Repr -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repr -> [ConInfo]
rCons
reprEmpty :: Repr -> Bool
reprEmpty     = [ConInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ConInfo] -> Bool) -> (Repr -> [ConInfo]) -> Repr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repr -> [ConInfo]
rCons

-- | Does any constructor have fields whose runtime representation differs from
-- their source types?  This happens with @UNPACK@ / @-funbox-small-strict-fields@
-- (a strict @!Int@ becomes @Int#@) and with existentials/GADTs.  We match on the
-- source types, so such constructors would yield ill-typed Core — we refuse them.
reprUnpacked :: Repr -> Bool
reprUnpacked :: Repr -> Bool
reprUnpacked = (ConInfo -> Bool) -> [ConInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (DataCon -> Bool
dcUnpacked (DataCon -> Bool) -> (ConInfo -> DataCon) -> ConInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConInfo -> DataCon
ciCon) ([ConInfo] -> Bool) -> (Repr -> [ConInfo]) -> Repr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repr -> [ConInfo]
rCons

-- | True if a constructor's runtime arg representation differs from its source
-- arg types (UNPACK, @-funbox-small-strict-fields@, existentials, …).
dcUnpacked :: DataCon -> Bool
dcUnpacked :: DataCon -> Bool
dcUnpacked DataCon
dc =
  let rep :: [Type]
rep  = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Scaled Type]
dataConRepArgTys DataCon
dc)
      orig :: [Type]
orig = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
dc)
  in [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
rep Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
orig Bool -> Bool -> Bool
|| Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Type -> Type -> Bool) -> [Type] -> [Type] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Type -> Bool
eqType [Type]
rep [Type]
orig))

-- | Apply a class's dictionary constructor: @C:Cls \@ty m1 .. mn@.
mkClassDict :: Class -> Type -> [CoreExpr] -> CoreExpr
mkClassDict :: Class -> Type -> [CoreExpr] -> CoreExpr
mkClassDict Class
cls Type
ty [CoreExpr]
methods =
  CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWorkId (Class -> DataCon
classDataCon Class
cls))) (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
methods)

-- | A constructor's field types, instantiated at the inner type's arguments,
-- so a parameterised type such as @Pair Int@ yields @[Int, Int]@ rather than
-- @[a, a]@ (and @Pair a@ yields the skolem @[a, a]@).
fieldTysAt :: Type -> DataCon -> [Type]
fieldTysAt :: Type -> DataCon -> [Type]
fieldTysAt Type
innerTy DataCon
dc = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc (HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
innerTy))

-- | Apply a constructor, supplying the inner type's type arguments first
-- (e.g. @Pair \@Int e1 e2@), so it works for parameterised types.
conAppAt :: Type -> DataCon -> [CoreExpr] -> CoreExpr
conAppAt :: Type -> DataCon -> [CoreExpr] -> CoreExpr
conAppAt Type
innerTy DataCon
dc [CoreExpr]
args = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
dc ((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type (HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
innerTy) [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
args)

-- | Build a (possibly self-referential) dictionary: @let rec d = C:Cls ty (mk d)
-- in d@.  The callback receives the dictionary binder so fields can refer back
-- to it (e.g. to use class default methods).
recClassDict :: Class -> Type -> (Id -> TcPluginM [CoreExpr]) -> TcPluginM CoreExpr
recClassDict :: Class -> Type -> (Id -> TcPluginM [CoreExpr]) -> TcPluginM CoreExpr
recClassDict Class
cls Type
ty Id -> TcPluginM [CoreExpr]
mk = do
  Id
dvar   <- Type -> String -> TcPluginM Id
freshId (Class -> [Type] -> Type
mkClassPred Class
cls [Type
ty]) String
"dict"
  [CoreExpr]
fields <- Id -> TcPluginM [CoreExpr]
mk Id
dvar
  CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bind Id -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let ([(Id, CoreExpr)] -> Bind Id
forall b. [(b, Expr b)] -> Bind b
Rec [(Id
dvar, Class -> Type -> [CoreExpr] -> CoreExpr
mkClassDict Class
cls Type
ty [CoreExpr]
fields)]) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
dvar))

-- | Build a recursive dictionary giving explicit superclass dicts and explicit
-- implementations for the listed method indices; every other method comes from
-- the class's own default method (applied to the recursive dictionary).  This
-- is how we fill many-method classes (@Foldable@) from a single key method.
recDictWith :: Class -> Type -> [CoreExpr] -> [(Int, CoreExpr)] -> TcPluginM CoreExpr
recDictWith :: Class
-> Type -> [CoreExpr] -> [(Int, CoreExpr)] -> TcPluginM CoreExpr
recDictWith Class
cls Type
ty [CoreExpr]
supers [(Int, CoreExpr)]
overrides = do
  Id
dvar <- Type -> String -> TcPluginM Id
freshId (Class -> [Type] -> Type
mkClassPred Class
cls [Type
ty]) String
"dict"
  [CoreExpr]
methodFields <- [(Int, Id)]
-> ((Int, Id) -> TcPluginM CoreExpr) -> TcPluginM [CoreExpr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Int] -> [Id] -> [(Int, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (Class -> [Id]
classMethods Class
cls)) \(Int
i, Id
_) ->
    case Int -> [(Int, CoreExpr)] -> Maybe CoreExpr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i [(Int, CoreExpr)]
overrides of
      Just CoreExpr
e  -> CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CoreExpr
e
      Maybe CoreExpr
Nothing -> do Id
dm <- Class -> Int -> TcPluginM Id
defMethId Class
cls Int
i
                    CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
dm) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
dvar])
  CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bind Id -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let ([(Id, CoreExpr)] -> Bind Id
forall b. [(b, Expr b)] -> Bind b
Rec [(Id
dvar, Class -> Type -> [CoreExpr] -> CoreExpr
mkClassDict Class
cls Type
ty ([CoreExpr]
supers [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
methodFields))]) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
dvar))

-- | How a constructor field relates to the functor parameter @a@.
data FieldKind = FParam | FConst | FApp Type   -- ^ is @a@ / no @a@ / @H a@ (covariant)

classifyField :: TyVar -> Type -> Type -> Maybe FieldKind
classifyField :: Id -> Type -> Type -> Maybe FieldKind
classifyField Id
atv Type
aTy Type
ft
  | Type
ft Type -> Type -> Bool
`eqType` Type
aTy                              = FieldKind -> Maybe FieldKind
forall a. a -> Maybe a
Just FieldKind
FParam
  | Bool -> Bool
not (Id
atv Id -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
ft)     = FieldKind -> Maybe FieldKind
forall a. a -> Maybe a
Just FieldKind
FConst
  | Just (Type
h, Type
larg) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ft
  , Type
larg Type -> Type -> Bool
`eqType` Type
aTy
  , Bool -> Bool
not (Id
atv Id -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
h)      = FieldKind -> Maybe FieldKind
forall a. a -> Maybe a
Just (Type -> FieldKind
FApp Type
h)
  | Bool
otherwise                                    = Maybe FieldKind
forall a. Maybe a
Nothing

-- | How to use one constructor field, by its relationship to the parameter.
-- This is the single place that distinguishes a lifted class (@Eq1@\/@Ord1@\/
-- @Show1@\/@Read1@) from its twin: the @onParam@ leaf is what changes (the
-- supplied function vs the field's own instance).  @onConst@\/@onApply@ receive
-- the wanted-evidence the field needs.
data Roles r = Roles
  { forall r. Roles r -> r
onParam :: r                         -- ^ the field /is/ the parameter @a@
  , forall r. Roles r -> CtEvidence -> Type -> r
onConst :: CtEvidence -> Type -> r   -- ^ a constant field (own instance)
    -- | an @H a@ field (lifted instance of the /effective/ @H@): the evidence,
    -- the effective functor (the @Override1@ modifier @m@ when present, else the
    -- real @h@), and a coercion builder @\\t -> (h t ~R m t)@ ('Refl' when not
    -- overridden) so the caller can cast field values @h t@ to\/from @m t@.
  , forall r. Roles r -> CtEvidence -> Type -> (Type -> Coercion) -> r
onApply :: CtEvidence -> Type -> (Type -> Coercion) -> r
  }

-- | Classify a field and pick the matching role, emitting the wanted that role
-- needs (a @C H@ for a constant, the lifted @C1 H@ for an @H a@ field).  Under an
-- @Override1@ the @H a@ field is reshaped to @m a@: the wanted is the lifted @C1
-- m@ and 'onApply' receives @m@ plus the @h t ~R m t@ coercion builder.
-- 'Nothing' if the field shape is unsupported (e.g. contravariant, nested).
interpField :: Class       -- ^ the constant-field class (@Eq@\/@Ord@\/@Show@\/@Read@)
            -> Class       -- ^ the lifted class      (@Eq1@\/@Ord1@\/@Show1@\/@Read1@)
            -> TyVar -> Type -> CtLoc
            -> Maybe Type  -- ^ @Override1@ modifier for this field, if any
            -> Roles r -> Type -> TcPluginM (Maybe (r, [Ct]))
interpField :: forall r.
Class
-> Class
-> Id
-> Type
-> CtLoc
-> Maybe Type
-> Roles r
-> Type
-> TcPluginM (Maybe (r, [Ct]))
interpField Class
constCls Class
liftCls Id
atv Type
aTy CtLoc
loc Maybe Type
mMod Roles r
roles Type
ftA =
  case Id -> Type -> Type -> Maybe FieldKind
classifyField Id
atv Type
aTy Type
ftA of
    Maybe FieldKind
Nothing       -> Maybe (r, [Ct]) -> TcPluginM (Maybe (r, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (r, [Ct])
forall a. Maybe a
Nothing
    Just FieldKind
FParam   -> Maybe (r, [Ct]) -> TcPluginM (Maybe (r, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((r, [Ct]) -> Maybe (r, [Ct])
forall a. a -> Maybe a
Just (Roles r -> r
forall r. Roles r -> r
onParam Roles r
roles, []))
    Just FieldKind
FConst   -> do
      CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
constCls [Type
ftA])
      Maybe (r, [Ct]) -> TcPluginM (Maybe (r, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((r, [Ct]) -> Maybe (r, [Ct])
forall a. a -> Maybe a
Just (Roles r -> CtEvidence -> Type -> r
forall r. Roles r -> CtEvidence -> Type -> r
onConst Roles r
roles CtEvidence
ev Type
ftA, [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))
    Just (FApp Type
h) -> do
      let m :: Type
m       = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
h Maybe Type
mMod
          coB :: Type -> Coercion
coB Type
t   = case Maybe Type
mMod of
                      Maybe Type
Nothing -> Type -> Coercion
mkRepReflCo (Type -> Type -> Type
mkAppTy Type
h Type
t)
                      Just Type
_  -> UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo (String -> UnivCoProvenance
PluginProv String
"stock") Role
Representational
                                   (Type -> Type -> Type
mkAppTy Type
h Type
t) (Type -> Type -> Type
mkAppTy Type
m Type
t)
      CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
liftCls [Type
m])
      Maybe (r, [Ct]) -> TcPluginM (Maybe (r, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((r, [Ct]) -> Maybe (r, [Ct])
forall a. a -> Maybe a
Just (Roles r -> CtEvidence -> Type -> (Type -> Coercion) -> r
forall r. Roles r -> CtEvidence -> Type -> (Type -> Coercion) -> r
onApply Roles r
roles CtEvidence
ev Type
m Type -> Coercion
coB, [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev]))

-- | The field types of a constructor with the @Stock1@ parameter set to @ty@.
fieldsAt :: [Type] -> DataCon -> Type -> [Type]
fieldsAt :: [Type] -> DataCon -> Type -> [Type]
fieldsAt [Type]
fixed DataCon
dc Type
ty = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing (DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
dc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
ty]))

-- | The two-scrutinee SOP walk — the @Stock1@ counterpart to 'matchSOP'
-- (which is single-scrutinee, in "Stock.Derive").  Walk two values of the same
-- @Stock1 F@ shape in lock-step: matching constructors combine their per-field
-- results, mismatched constructors give a fixed answer.  This is the skeleton
-- shared by @liftEq@ (combine = short-circuit @&&@, mismatch = @False@) and
-- @liftCompare@ (combine = lexicographic, mismatch = tag order).  @fieldOp@
-- produces one field-pair's result (via 'interpField'); @combine@ folds a
-- constructor's field results.
zipLift2 :: TyCon -> [Type] -> (Type -> Coercion)
         -> Type -> Type -> Type             -- a, b, result type
         -> Id -> Id                         -- the two scrutinees (fa, fb)
         -> (Int -> Int -> CoreExpr)         -- mismatched-constructor result
         -> ([CoreExpr] -> TcPluginM CoreExpr)            -- combine field results
         -> (Int -> Type -> Id -> Id -> TcPluginM (Maybe (CoreExpr, [Ct])))  -- per field pair (with index)
         -> TcPluginM (Maybe (CoreExpr, [Ct]))
zipLift2 :: TyCon
-> [Type]
-> (Type -> Coercion)
-> Type
-> Type
-> Type
-> Id
-> Id
-> (Int -> Int -> CoreExpr)
-> ([CoreExpr] -> TcPluginM CoreExpr)
-> (Int -> Type -> Id -> Id -> TcPluginM (Maybe (CoreExpr, [Ct])))
-> TcPluginM (Maybe (CoreExpr, [Ct]))
zipLift2 TyCon
fTc [Type]
fixed Type -> Coercion
coAt Type
aTy Type
bTy Type
resTy Id
faId Id
fbId Int -> Int -> CoreExpr
mismatch [CoreExpr] -> TcPluginM CoreExpr
combine Int -> Type -> Id -> Id -> TcPluginM (Maybe (CoreExpr, [Ct]))
fieldOp = do
  let dcons :: [DataCon]
dcons   = TyCon -> [DataCon]
tyConDataCons TyCon
fTc
      innerA :: Type
innerA  = TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy])
      innerB :: Type
innerB  = TyCon -> [Type] -> Type
mkTyConApp TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
bTy])
      indexed :: [(Int, DataCon)]
indexed = [Int] -> [DataCon] -> [(Int, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [DataCon]
dcons
      freshFields :: DataCon -> Type -> TcPluginM [Id]
freshFields DataCon
dc Type
ty = (Int -> Type -> TcPluginM Id) -> [Int] -> [Type] -> TcPluginM [Id]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\Int
n Type
ft -> Type -> String -> TcPluginM Id
freshId Type
ft (String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0 :: Int ..]
                                   ([Type] -> DataCon -> Type -> [Type]
fieldsAt [Type]
fixed DataCon
dc Type
ty)
  [Maybe (Alt Id, [Ct])]
mInner <- [(Int, DataCon)]
-> ((Int, DataCon) -> TcPluginM (Maybe (Alt Id, [Ct])))
-> TcPluginM [Maybe (Alt Id, [Ct])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Int, DataCon)]
indexed \(Int
i, DataCon
dci) -> do
    [Id]
xs <- DataCon -> Type -> TcPluginM [Id]
freshFields DataCon
dci Type
aTy
    [Maybe (Alt Id, [Ct])]
mAlts <- [(Int, DataCon)]
-> ((Int, DataCon) -> TcPluginM (Maybe (Alt Id, [Ct])))
-> TcPluginM [Maybe (Alt Id, [Ct])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Int, DataCon)]
indexed \(Int
j, DataCon
dcj) -> do
      [Id]
ys <- DataCon -> Type -> TcPluginM [Id]
freshFields DataCon
dcj Type
bTy
      if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j
        then Maybe (Alt Id, [Ct]) -> TcPluginM (Maybe (Alt Id, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Alt Id, [Ct]) -> Maybe (Alt Id, [Ct])
forall a. a -> Maybe a
Just (AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dcj) [Id]
ys (Int -> Int -> CoreExpr
mismatch Int
i Int
j), []))
        else do
          [Maybe (CoreExpr, [Ct])]
mops <- [TcPluginM (Maybe (CoreExpr, [Ct]))]
-> TcPluginM [Maybe (CoreExpr, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((Int -> Type -> Id -> Id -> TcPluginM (Maybe (CoreExpr, [Ct])))
-> [Int]
-> [Type]
-> [Id]
-> [Id]
-> [TcPluginM (Maybe (CoreExpr, [Ct]))]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 Int -> Type -> Id -> Id -> TcPluginM (Maybe (CoreExpr, [Ct]))
fieldOp [Int
0 :: Int ..] ([Type] -> DataCon -> Type -> [Type]
fieldsAt [Type]
fixed DataCon
dci Type
aTy) [Id]
xs [Id]
ys)
          case [Maybe (CoreExpr, [Ct])] -> Maybe [(CoreExpr, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (CoreExpr, [Ct])]
mops of
            Maybe [(CoreExpr, [Ct])]
Nothing  -> Maybe (Alt Id, [Ct]) -> TcPluginM (Maybe (Alt Id, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Alt Id, [Ct])
forall a. Maybe a
Nothing
            Just [(CoreExpr, [Ct])]
ows -> do
              CoreExpr
body <- [CoreExpr] -> TcPluginM CoreExpr
combine (((CoreExpr, [Ct]) -> CoreExpr) -> [(CoreExpr, [Ct])] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreExpr, [Ct]) -> CoreExpr
forall a b. (a, b) -> a
fst [(CoreExpr, [Ct])]
ows)
              Maybe (Alt Id, [Ct]) -> TcPluginM (Maybe (Alt Id, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Alt Id, [Ct]) -> Maybe (Alt Id, [Ct])
forall a. a -> Maybe a
Just (AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dcj) [Id]
ys CoreExpr
body, ((CoreExpr, [Ct]) -> [Ct]) -> [(CoreExpr, [Ct])] -> [Ct]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CoreExpr, [Ct]) -> [Ct]
forall a b. (a, b) -> b
snd [(CoreExpr, [Ct])]
ows))
    case [Maybe (Alt Id, [Ct])] -> Maybe [(Alt Id, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Alt Id, [Ct])]
mAlts of
      Maybe [(Alt Id, [Ct])]
Nothing     -> Maybe (Alt Id, [Ct]) -> TcPluginM (Maybe (Alt Id, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Alt Id, [Ct])
forall a. Maybe a
Nothing
      Just [(Alt Id, [Ct])]
altWss -> do
        let ([Alt Id]
alts, [[Ct]]
wss) = [(Alt Id, [Ct])] -> ([Alt Id], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt Id, [Ct])]
altWss
        Id
cbB <- Type -> String -> TcPluginM Id
freshId Type
innerB String
"cbb"
        Maybe (Alt Id, [Ct]) -> TcPluginM (Maybe (Alt Id, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Alt Id, [Ct]) -> Maybe (Alt Id, [Ct])
forall a. a -> Maybe a
Just ( AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dci) [Id]
xs
                       (TyCon -> [Type] -> CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
destructInner TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
bTy]) (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
fbId) (Type -> Coercion
coAt Type
bTy)) Id
cbB Type
resTy [Alt Id]
alts)
                   , [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss ))
  case [Maybe (Alt Id, [Ct])] -> Maybe [(Alt Id, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Alt Id, [Ct])]
mInner of
    Maybe [(Alt Id, [Ct])]
Nothing     -> Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CoreExpr, [Ct])
forall a. Maybe a
Nothing
    Just [(Alt Id, [Ct])]
altWss -> do
      let ([Alt Id]
alts, [[Ct]]
wss) = [(Alt Id, [Ct])] -> ([Alt Id], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt Id, [Ct])]
altWss
      Id
cbA <- Type -> String -> TcPluginM Id
freshId Type
innerA String
"cba"
      Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CoreExpr, [Ct]) -> Maybe (CoreExpr, [Ct])
forall a. a -> Maybe a
Just ( TyCon -> [Type] -> CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
destructInner TyCon
fTc ([Type]
fixed [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
aTy]) (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
faId) (Type -> Coercion
coAt Type
aTy)) Id
cbA Type
resTy [Alt Id]
alts
                 , [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss ))

-- | Solve @C (Stock Inner)@ by building the dictionary from @Inner@'s
-- constructors.  We only act on the @Stock@ newtype, so unrelated code is
-- never affected.  @Eq@ handles any single-level algebraic type; @Ord@ is
-- limited to enumerations; anything else gets a clear "not implemented" error.
-- | A solver for one wrapper: 'Just' the 'Attempt' if it owns the wrapper (even
-- an error it reports), or 'Nothing' to defer to the next.  The Monoid is
-- first-success, so dispatch is a composition @stockSolver \<\> …@ — and a
-- companion solver would be just one more element.
-- The first-success Monoid is exactly @Alt (MaybeT m)@ (the Alternative-as-
-- Monoid that stops at the first solver returning a result), under the reader
-- arrows — so we derive it rather than hand-write it.
newtype Solver = Solver
  { Solver
-> PluginState -> Ct -> Class -> Type -> TcPluginM (Maybe Attempt)
runSolver :: PluginState -> Ct -> Class -> Type -> TcPluginM (Maybe Attempt) }
  deriving (NonEmpty Solver -> Solver
Solver -> Solver -> Solver
(Solver -> Solver -> Solver)
-> (NonEmpty Solver -> Solver)
-> (forall b. Integral b => b -> Solver -> Solver)
-> Semigroup Solver
forall b. Integral b => b -> Solver -> Solver
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Solver -> Solver -> Solver
<> :: Solver -> Solver -> Solver
$csconcat :: NonEmpty Solver -> Solver
sconcat :: NonEmpty Solver -> Solver
$cstimes :: forall b. Integral b => b -> Solver -> Solver
stimes :: forall b. Integral b => b -> Solver -> Solver
Semigroup, Semigroup Solver
Solver
Semigroup Solver =>
Solver
-> (Solver -> Solver -> Solver)
-> ([Solver] -> Solver)
-> Monoid Solver
[Solver] -> Solver
Solver -> Solver -> Solver
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Solver
mempty :: Solver
$cmappend :: Solver -> Solver -> Solver
mappend :: Solver -> Solver -> Solver
$cmconcat :: [Solver] -> Solver
mconcat :: [Solver] -> Solver
Monoid)
    via (PluginState -> Ct -> Class -> Type -> Mon.Alt (MaybeT TcPluginM) Attempt)

notImplemented :: PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented :: PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct SDoc
doc = do
  let key :: String
key = SDoc -> String
showSDocUnsafe SDoc
doc
  [String]
seen <- IO [String] -> TcPluginM [String]
forall a. IO a -> TcPluginM a
tcPluginIO (IORef [String] -> IO [String]
forall a. IORef a -> IO a
readIORef (PluginState -> IORef [String]
psSeen PluginState
st))
  Bool -> TcPluginM () -> TcPluginM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
key String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
seen) (TcPluginM () -> TcPluginM ()) -> TcPluginM () -> TcPluginM ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> TcPluginM ()
forall a. IO a -> TcPluginM a
tcPluginIO (IORef [String] -> ([String] -> [String]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PluginState -> IORef [String]
psSeen PluginState
st) (String
key :))
    TcM () -> TcPluginM ()
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcRnMessage -> TcM ()
addErrTc (DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
mkTcRnUnknownMessage ([GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints SDoc
doc)))
  Attempt -> TcPluginM Attempt
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EvTerm, Ct)
forall a. Maybe a
Nothing, [], [Ct
ct])

-- | A fresh local binder of the given type.
freshId :: Type -> String -> TcPluginM Id
freshId :: Type -> String -> TcPluginM Id
freshId Type
ty String
s = do
  Unique
u <- TcM Unique -> TcPluginM Unique
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM TcM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
  Id -> TcPluginM Id
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HasDebugCallStack => Name -> Type -> Type -> Id
Name -> Type -> Type -> Id
mkLocalId (Unique -> OccName -> Name
mkSystemName Unique
u (String -> OccName
mkVarOcc String
s)) Type
manyDataConTy Type
ty)

-- | Build @compare :: wrapped -> wrapped -> Ordering@ for any single-level
-- algebraic type, matching derived @Ord@: compare constructor tags first, and
-- for the same constructor compare the fields lexicographically.  Field
-- comparisons use each field type's own @Ord@ (requested as wanted
-- constraints); the wanteds are returned alongside the expression.
toDatatype :: Type -> Repr -> Datatype
toDatatype :: Type -> Repr -> Datatype
toDatatype Type
via Repr
repr = Datatype
  { dtVia :: Type
dtVia    = Type
via
  , dtUnwrap :: Coercion
dtUnwrap = Repr -> Coercion
rCo Repr
repr
  , dtType :: Type
dtType   = Repr -> Type
rInner Repr
repr
  , dtCons :: [Constructor]
dtCons   = [ DataCon
-> [Type]
-> Fixity
-> Maybe [FieldLabel]
-> [Coercion]
-> Constructor
Constructor DataCon
dc (ConInfo -> [Type]
ciFields ConInfo
ci) Fixity
defaultFixity Maybe [FieldLabel]
labels (ConInfo -> [Coercion]
ciFieldCos ConInfo
ci)
               | ConInfo
ci <- Repr -> [ConInfo]
rCons Repr
repr
               , let dc :: DataCon
dc  = ConInfo -> DataCon
ciCon ConInfo
ci
                     fls :: [FieldLabel]
fls = DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc
                     labels :: Maybe [FieldLabel]
labels = if [FieldLabel] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
fls then Maybe [FieldLabel]
forall a. Maybe a
Nothing else [FieldLabel] -> Maybe [FieldLabel]
forall a. a -> Maybe a
Just [FieldLabel]
fls ]
  }

-- | Run a @Deriver@ (built-in or discovered) as a solve attempt.
runDeriverAttempt :: Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt :: Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt Deriver
drv Ct
ct Class
cls Datatype
dt = do
  (EvTerm
ev, [Ct]
ws) <- CtLoc -> Synth EvTerm -> TcPluginM (EvTerm, [Ct])
forall a. CtLoc -> Synth a -> TcPluginM (a, [Ct])
runSynth (Ct -> CtLoc
ctLoc Ct
ct) (Deriver -> Class -> Datatype -> Synth EvTerm
runDeriver Deriver
drv Class
cls Datatype
dt)
  Attempt -> TcPluginM Attempt
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, Ct) -> Maybe (EvTerm, Ct)
forall a. a -> Maybe a
Just (EvTerm
ev, Ct
ct), [Ct]
ws, [])

-- | Discovery + dynamic loading (the extension mechanism): if a companion
-- package provides @instance DeriveStock C@, find it in the instance
-- environment, load its @Deriver@ value with GHC's plugin loader, and run it —
-- so a new class becomes derivable @via Stock@ just by depending on the
-- companion, with no change to the user's @-fplugin@ line.
tryWitness :: PluginState -> Ct -> Class -> Datatype -> TcPluginM (Maybe Attempt)
tryWitness :: PluginState -> Ct -> Class -> Datatype -> TcPluginM (Maybe Attempt)
tryWitness PluginState
st Ct
ct Class
cls Datatype
dt =
  case GenEnv -> Maybe Class
geWitness (PluginState -> GenEnv
psGen PluginState
st) of
    Maybe Class
Nothing     -> Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Attempt
forall a. Maybe a
Nothing
    Just Class
witCls -> do
      InstEnvs
instEnvs <- TcPluginM InstEnvs
getInstEnvs
      let clsTy :: Type
clsTy   = TyCon -> Type
mkTyConTy (Class -> TyCon
classTyCon Class
cls)
          matches :: [ClsInst]
matches = [ ClsInst
inst | ClsInst
inst <- InstEnvs -> Class -> [ClsInst]
classInstances InstEnvs
instEnvs Class
witCls
                           , [Type
headTy] <- [ClsInst -> [Type]
is_tys ClsInst
inst], Type
headTy Type -> Type -> Bool
`eqType` Type
clsTy ]
      case [ClsInst]
matches of
        []         -> Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Attempt
forall a. Maybe a
Nothing
        (ClsInst
inst : [ClsInst]
_) -> do
          let dfun :: Id
dfun = ClsInst -> Id
is_dfun ClsInst
inst
          HscEnv
hsc <- TcPluginM HscEnv
getTopEnv
          -- @DeriveStock@ is single-method with no superclass, so its dictionary
          -- is represented exactly as a @Deriver@; load the dfun at its own type
          -- and treat it as one.
          Either Type (Deriver, [Linkable], PkgsLoaded)
r <- TcM (Either Type (Deriver, [Linkable], PkgsLoaded))
-> TcPluginM (Either Type (Deriver, [Linkable], PkgsLoaded))
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM (Either Type (Deriver, [Linkable], PkgsLoaded))
 -> TcPluginM (Either Type (Deriver, [Linkable], PkgsLoaded)))
-> TcM (Either Type (Deriver, [Linkable], PkgsLoaded))
-> TcPluginM (Either Type (Deriver, [Linkable], PkgsLoaded))
forall a b. (a -> b) -> a -> b
$ IO (Either Type (Deriver, [Linkable], PkgsLoaded))
-> TcM (Either Type (Deriver, [Linkable], PkgsLoaded))
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Type (Deriver, [Linkable], PkgsLoaded))
 -> TcM (Either Type (Deriver, [Linkable], PkgsLoaded)))
-> IO (Either Type (Deriver, [Linkable], PkgsLoaded))
-> TcM (Either Type (Deriver, [Linkable], PkgsLoaded))
forall a b. (a -> b) -> a -> b
$
                 HscEnv
-> Name
-> Type
-> IO (Either Type (Deriver, [Linkable], PkgsLoaded))
forall a.
HscEnv
-> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))
getValueSafely HscEnv
hsc (Id -> Name
idName Id
dfun) (Id -> Type
idType Id
dfun)
          case Either Type (Deriver, [Linkable], PkgsLoaded)
r of
            Right (Deriver
drv, [Linkable]
_, PkgsLoaded
_) -> Attempt -> Maybe Attempt
forall a. a -> Maybe a
Just (Attempt -> Maybe Attempt)
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt Deriver
drv Ct
ct Class
cls Datatype
dt
            Left Type
_            -> Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Attempt
forall a. Maybe a
Nothing

-- | The @Stock1@ counterpart of 'tryWitness': discover a companion
-- @instance DeriveStock1 C@, load its 'Deriver1', and run it on the inner
-- type constructor @f@.  (@deriving C via Stock1 F@ for a lifted @C@.)
tryWitness1 :: PluginState -> Ct -> Class -> Type -> Type -> TcPluginM (Maybe Attempt)
tryWitness1 :: PluginState
-> Ct -> Class -> Type -> Type -> TcPluginM (Maybe Attempt)
tryWitness1 PluginState
st Ct
ct Class
cls Type
wrappedTy Type
f =
  case GenEnv -> Maybe Class
geWitness1 (PluginState -> GenEnv
psGen PluginState
st) of
    Maybe Class
Nothing     -> Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Attempt
forall a. Maybe a
Nothing
    Just Class
witCls -> do
      InstEnvs
instEnvs <- TcPluginM InstEnvs
getInstEnvs
      let clsTy :: Type
clsTy   = TyCon -> Type
mkTyConTy (Class -> TyCon
classTyCon Class
cls)
          matches :: [ClsInst]
matches = [ ClsInst
inst | ClsInst
inst <- InstEnvs -> Class -> [ClsInst]
classInstances InstEnvs
instEnvs Class
witCls
                           , [Type
headTy] <- [ClsInst -> [Type]
is_tys ClsInst
inst], Type
headTy Type -> Type -> Bool
`eqType` Type
clsTy ]
      case [ClsInst]
matches of
        []         -> Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Attempt
forall a. Maybe a
Nothing
        (ClsInst
inst : [ClsInst]
_) -> do
          let dfun :: Id
dfun = ClsInst -> Id
is_dfun ClsInst
inst
          HscEnv
hsc <- TcPluginM HscEnv
getTopEnv
          Either Type (Deriver1, [Linkable], PkgsLoaded)
r <- TcM (Either Type (Deriver1, [Linkable], PkgsLoaded))
-> TcPluginM (Either Type (Deriver1, [Linkable], PkgsLoaded))
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM (Either Type (Deriver1, [Linkable], PkgsLoaded))
 -> TcPluginM (Either Type (Deriver1, [Linkable], PkgsLoaded)))
-> TcM (Either Type (Deriver1, [Linkable], PkgsLoaded))
-> TcPluginM (Either Type (Deriver1, [Linkable], PkgsLoaded))
forall a b. (a -> b) -> a -> b
$ IO (Either Type (Deriver1, [Linkable], PkgsLoaded))
-> TcM (Either Type (Deriver1, [Linkable], PkgsLoaded))
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Type (Deriver1, [Linkable], PkgsLoaded))
 -> TcM (Either Type (Deriver1, [Linkable], PkgsLoaded)))
-> IO (Either Type (Deriver1, [Linkable], PkgsLoaded))
-> TcM (Either Type (Deriver1, [Linkable], PkgsLoaded))
forall a b. (a -> b) -> a -> b
$
                 HscEnv
-> Name
-> Type
-> IO (Either Type (Deriver1, [Linkable], PkgsLoaded))
forall a.
HscEnv
-> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))
getValueSafely HscEnv
hsc (Id -> Name
idName Id
dfun) (Id -> Type
idType Id
dfun)
          case Either Type (Deriver1, [Linkable], PkgsLoaded)
r of
            Right (Deriver1 Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synth, [Linkable]
_, PkgsLoaded
_) -> do
              Maybe (EvTerm, [Ct])
m <- Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synth Class
cls (Ct -> CtLoc
ctLoc Ct
ct) Type
wrappedTy Type
f
              Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Attempt -> TcPluginM (Maybe Attempt))
-> Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> a -> b
$ case Maybe (EvTerm, [Ct])
m of
                Just (EvTerm
ev, [Ct]
ws) -> Attempt -> Maybe Attempt
forall a. a -> Maybe a
Just ((EvTerm, Ct) -> Maybe (EvTerm, Ct)
forall a. a -> Maybe a
Just (EvTerm
ev, Ct
ct), [Ct]
ws, [])
                Maybe (EvTerm, [Ct])
Nothing       -> Maybe Attempt
forall a. Maybe a
Nothing
            Left Type
_ -> Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Attempt
forall a. Maybe a
Nothing

-- | The @Stock2@ counterpart of 'tryWitness1': discover @instance DeriveStock2
-- C@ and run its 'Deriver2' on the inner two-parameter constructor @p@.
tryWitness2 :: PluginState -> Ct -> Class -> Type -> Type -> TcPluginM (Maybe Attempt)
tryWitness2 :: PluginState
-> Ct -> Class -> Type -> Type -> TcPluginM (Maybe Attempt)
tryWitness2 PluginState
st Ct
ct Class
cls Type
wrappedTy Type
p =
  case GenEnv -> Maybe Class
geWitness2 (PluginState -> GenEnv
psGen PluginState
st) of
    Maybe Class
Nothing     -> Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Attempt
forall a. Maybe a
Nothing
    Just Class
witCls -> do
      InstEnvs
instEnvs <- TcPluginM InstEnvs
getInstEnvs
      let clsTy :: Type
clsTy   = TyCon -> Type
mkTyConTy (Class -> TyCon
classTyCon Class
cls)
          matches :: [ClsInst]
matches = [ ClsInst
inst | ClsInst
inst <- InstEnvs -> Class -> [ClsInst]
classInstances InstEnvs
instEnvs Class
witCls
                           , [Type
headTy] <- [ClsInst -> [Type]
is_tys ClsInst
inst], Type
headTy Type -> Type -> Bool
`eqType` Type
clsTy ]
      case [ClsInst]
matches of
        []         -> Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Attempt
forall a. Maybe a
Nothing
        (ClsInst
inst : [ClsInst]
_) -> do
          let dfun :: Id
dfun = ClsInst -> Id
is_dfun ClsInst
inst
          HscEnv
hsc <- TcPluginM HscEnv
getTopEnv
          Either Type (Deriver2, [Linkable], PkgsLoaded)
r <- TcM (Either Type (Deriver2, [Linkable], PkgsLoaded))
-> TcPluginM (Either Type (Deriver2, [Linkable], PkgsLoaded))
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (TcM (Either Type (Deriver2, [Linkable], PkgsLoaded))
 -> TcPluginM (Either Type (Deriver2, [Linkable], PkgsLoaded)))
-> TcM (Either Type (Deriver2, [Linkable], PkgsLoaded))
-> TcPluginM (Either Type (Deriver2, [Linkable], PkgsLoaded))
forall a b. (a -> b) -> a -> b
$ IO (Either Type (Deriver2, [Linkable], PkgsLoaded))
-> TcM (Either Type (Deriver2, [Linkable], PkgsLoaded))
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Type (Deriver2, [Linkable], PkgsLoaded))
 -> TcM (Either Type (Deriver2, [Linkable], PkgsLoaded)))
-> IO (Either Type (Deriver2, [Linkable], PkgsLoaded))
-> TcM (Either Type (Deriver2, [Linkable], PkgsLoaded))
forall a b. (a -> b) -> a -> b
$
                 HscEnv
-> Name
-> Type
-> IO (Either Type (Deriver2, [Linkable], PkgsLoaded))
forall a.
HscEnv
-> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))
getValueSafely HscEnv
hsc (Id -> Name
idName Id
dfun) (Id -> Type
idType Id
dfun)
          case Either Type (Deriver2, [Linkable], PkgsLoaded)
r of
            Right (Deriver2 Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synth, [Linkable]
_, PkgsLoaded
_) -> do
              Maybe (EvTerm, [Ct])
m <- Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synth Class
cls (Ct -> CtLoc
ctLoc Ct
ct) Type
wrappedTy Type
p
              Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Attempt -> TcPluginM (Maybe Attempt))
-> Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> a -> b
$ case Maybe (EvTerm, [Ct])
m of
                Just (EvTerm
ev, [Ct]
ws) -> Attempt -> Maybe Attempt
forall a. a -> Maybe a
Just ((EvTerm, Ct) -> Maybe (EvTerm, Ct)
forall a. a -> Maybe a
Just (EvTerm
ev, Ct
ct), [Ct]
ws, [])
                Maybe (EvTerm, [Ct])
Nothing       -> Maybe Attempt
forall a. Maybe a
Nothing
            Left Type
_ -> Maybe Attempt -> TcPluginM (Maybe Attempt)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Attempt
forall a. Maybe a
Nothing

-- | @Eq@, re-expressed through the public SDK (@Datatype@ \/ @Synth@ \/ 'field')
-- rather than the bespoke @synthEq@ — a proof that the extension interface is
-- expressive enough to host a real, field-recursive synthesizer.  Produces the
-- same Core as @synthEq@.
conPrec :: DataCon -> TcPluginM Integer
conPrec :: DataCon -> TcPluginM Integer
conPrec DataCon
dc = do
#if MIN_VERSION_ghc(9,12,0)
  Fixity p _ <- unsafeTcPluginTcM (lookupFixityRn (dataConName dc))
#else
  Fixity SourceText
_ Int
p FixityDirection
_ <- TcM Fixity -> TcPluginM Fixity
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (Name -> TcM Fixity
lookupFixityRn (DataCon -> Name
dataConName DataCon
dc))
#endif
  Integer -> TcPluginM Integer
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p)

-- | The default-method Id for the i-th method of a class (for filling
-- dictionary fields we don't override, via a recursive dictionary).
defMethId :: Class -> Int -> TcPluginM Id
defMethId :: Class -> Int -> TcPluginM Id
defMethId Class
cls Int
i =
  case (Id, DefMethInfo) -> DefMethInfo
forall a b. (a, b) -> b
snd (Class -> [(Id, DefMethInfo)]
classOpItems Class
cls [(Id, DefMethInfo)] -> Int -> (Id, DefMethInfo)
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) of
    Just (Name
nm, DefMethSpec Type
_) -> Name -> TcPluginM Id
tcLookupId Name
nm
    DefMethInfo
Nothing      -> String -> TcPluginM Id
forall a. HasCallStack => String -> a
error String
"stock: expected a default method"

-- | Synthesize an @Enum@ dictionary for an enumeration, mirroring GHC's
-- derived @Enum@: @fromEnum@ is the constructor tag, @toEnum@ uses
-- @tagToEnum#@.  @succ@/@pred@/@enumFromTo@/@enumFromThenTo@ come from the
-- class default methods (correct and bounded); @enumFrom@/@enumFromThen@ are
-- overridden to stop at the last constructor (the defaults would run to
-- @maxBound::Int@ and crash).
data Variance = Cov | Con

flipV :: Variance -> Variance
flipV :: Variance -> Variance
flipV Variance
Cov = Variance
Con
flipV Variance
Con = Variance
Cov

-- | Build a variance-correct mapper for a field type @t@ between @t[pv:=src]@
-- and @t[pv:=tgt]@ (where @src@\/@tgt@ are the actual @a@\/@b@ types).  This is
-- GHC's @DeriveFunctor@ algorithm: recurse through function arrows flipping
-- variance, and through covariant functor (or contravariant) applications.
--
--   * @Cov t@ yields @t[src] -> t[tgt]@; @Con t@ yields @t[tgt] -> t[src]@.
--   * the bare parameter maps via @covFwd@ (resp. @conFwd@); the unavailable
--     direction is 'Nothing', so a parameter in the wrong position fails
--     cleanly (e.g. a bare @a@ in a negative position is not a 'Functor').
--   * @fmapCls@ supplies @fmap@ for covariant subfields; @mContraCls@, if given,
--     supplies @contramap@ for contravariant subfields.
varMap :: Class -> Maybe Class -> CtLoc -> TyVar -> Type
       -> Maybe CoreExpr -> Maybe CoreExpr
       -> Variance -> Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
varMap :: Class
-> Maybe Class
-> CtLoc
-> Id
-> Type
-> Maybe CoreExpr
-> Maybe CoreExpr
-> Variance
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
varMap Class
fmapCls Maybe Class
mContraCls CtLoc
loc Id
pv Type
tgt Maybe CoreExpr
covFwd Maybe CoreExpr
conFwd =
  Class
-> Maybe Class
-> CtLoc
-> [(Id, Type, Maybe CoreExpr, Maybe CoreExpr)]
-> Maybe (Type -> TcPluginM (Maybe (CoreExpr, [Ct])))
-> Variance
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
varMapN Class
fmapCls Maybe Class
mContraCls CtLoc
loc [(Id
pv, Type
tgt, Maybe CoreExpr
covFwd, Maybe CoreExpr
conFwd)] Maybe (Type -> TcPluginM (Maybe (CoreExpr, [Ct])))
forall a. Maybe a
Nothing

-- | The n-ary variance engine behind 'varMap' (and so behind @Functor@,
-- @Contravariant@, @Bifunctor@, @Profunctor@, @Invariant@, …, which are this
-- one recursion at different /variance vectors/).  Each parameter carries its
-- own detection tyvar (the source instantiation it appears as in the field),
-- its target type, and the two directional mappers — @covFwd@ for a covariant
-- occurrence (a @src -> tgt@), @conFwd@ for a contravariant one (a @tgt ->
-- src@); the unavailable direction is 'Nothing', so a parameter used against
-- its declared variance fails cleanly.  A covariant slot populates @covFwd@
-- only, a contravariant slot @conFwd@ only, an invariant slot both.  The
-- recursion is GHC's @DeriveFunctor@ algorithm (arrows flip variance,
-- last-argument functor\/contravariant applications recurse), now substituting
-- /all/ parameters at once.
varMapN :: Class -> Maybe Class -> CtLoc
        -> [(TyVar, Type, Maybe CoreExpr, Maybe CoreExpr)]
        -> Maybe (Type -> TcPluginM (Maybe (CoreExpr, [Ct])))
        -> Variance -> Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
varMapN :: Class
-> Maybe Class
-> CtLoc
-> [(Id, Type, Maybe CoreExpr, Maybe CoreExpr)]
-> Maybe (Type -> TcPluginM (Maybe (CoreExpr, [Ct])))
-> Variance
-> Type
-> TcPluginM (Maybe (CoreExpr, [Ct]))
varMapN Class
fmapCls Maybe Class
mContraCls CtLoc
loc [(Id, Type, Maybe CoreExpr, Maybe CoreExpr)]
params Maybe (Type -> TcPluginM (Maybe (CoreExpr, [Ct])))
mSelf = Variance -> Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
go
  where
    fmapSel :: Id
fmapSel = String -> Class -> Id
classMethod String
"fmap" Class
fmapCls
    pvs :: [Id]
pvs     = [ Id
pv  | (Id
pv, Type
_, Maybe CoreExpr
_, Maybe CoreExpr
_)  <- [(Id, Type, Maybe CoreExpr, Maybe CoreExpr)]
params ]
    tgts :: [Type]
tgts    = [ Type
tgt | (Id
_, Type
tgt, Maybe CoreExpr
_, Maybe CoreExpr
_) <- [(Id, Type, Maybe CoreExpr, Maybe CoreExpr)]
params ]
    sub :: Type -> Type
sub Type
t   = [Id] -> [Type] -> Type -> Type
HasDebugCallStack => [Id] -> [Type] -> Type -> Type
substTyWith [Id]
pvs [Type]
tgts Type
t            -- t[srcs:=tgts]
    inA :: Type -> Bool
inA Type
t   = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> VarSet -> Bool
`elemVarSet` Type -> VarSet
tyCoVarsOfType Type
t) [Id]
pvs
    -- if @t@ is exactly one parameter's source tyvar, its directional mapper
    bareFwd :: Type -> Variance -> Maybe (Maybe CoreExpr)
bareFwd Type
t Variance
v = case [ (Maybe CoreExpr
cf, Maybe CoreExpr
conf) | (Id
p, Type
_, Maybe CoreExpr
cf, Maybe CoreExpr
conf) <- [(Id, Type, Maybe CoreExpr, Maybe CoreExpr)]
params, Type
t Type -> Type -> Bool
`eqType` Id -> Type
mkTyVarTy Id
p ] of
      ((Maybe CoreExpr
cf, Maybe CoreExpr
conf) : [(Maybe CoreExpr, Maybe CoreExpr)]
_) -> Maybe CoreExpr -> Maybe (Maybe CoreExpr)
forall a. a -> Maybe a
Just (case Variance
v of Variance
Cov -> Maybe CoreExpr
cf; Variance
Con -> Maybe CoreExpr
conf)
      []               -> Maybe (Maybe CoreExpr)
forall a. Maybe a
Nothing
    -- the spine of an application: @(head, [arg₁ .. argₖ])@
    spine :: Type -> (Type, [Type])
spine Type
ty = case Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ty of
      Just (Type
f, Type
a) -> let (Type
h, [Type]
as) = Type -> (Type, [Type])
spine Type
f in (Type
h, [Type]
as [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
a])
      Maybe (Type, Type)
Nothing     -> (Type
ty, [])
    -- a self-application @q src₁ .. srcₙ@: @q@ (the head applied to any leading
    -- fixed args) is parameter-free and the trailing @n@ args are exactly our
    -- @n@ source tyvars in order, so @q@'s own n-ary map (the same class we are
    -- deriving) carries it — e.g. a @pro a b@ field under @Profunctor@.
    matchSelf :: Type -> Maybe Type
matchSelf Type
ty =
      let (Type
h, [Type]
args) = Type -> (Type, [Type])
spine Type
ty
          n :: Int
n         = [(Id, Type, Maybe CoreExpr, Maybe CoreExpr)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Id, Type, Maybe CoreExpr, Maybe CoreExpr)]
params
      in if [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
           then let ([Type]
pre, [Type]
tl) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) [Type]
args
                    qhead :: Type
qhead     = Type -> [Type] -> Type
mkAppTys Type
h [Type]
pre
                in if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Type -> Type -> Bool) -> [Type] -> [Type] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Type -> Bool
eqType [Type]
tl ((Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
mkTyVarTy [Id]
pvs)) Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
inA Type
qhead)
                     then Type -> Maybe Type
forall a. a -> Maybe a
Just Type
qhead else Maybe Type
forall a. Maybe a
Nothing
           else Maybe Type
forall a. Maybe a
Nothing
    go :: Variance -> Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
go Variance
v Type
t
      | Bool -> Bool
not (Type -> Bool
inA Type
t) = do Id
x <- Type -> String -> TcPluginM Id
freshId Type
t String
"x"; Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CoreExpr, [Ct]) -> Maybe (CoreExpr, [Ct])
forall a. a -> Maybe a
Just (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
x (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x), []))  -- id
      | Just Maybe CoreExpr
mfwd <- Type -> Variance -> Maybe (Maybe CoreExpr)
bareFwd Type
t Variance
v = Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CoreExpr -> (CoreExpr, [Ct]))
-> Maybe CoreExpr -> Maybe (CoreExpr, [Ct])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\CoreExpr
e -> (CoreExpr
e, [])) Maybe CoreExpr
mfwd)
      | Just (FunTyFlag
_, Type
_, Type
s, Type
r) <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
t = do
          Maybe (CoreExpr, [Ct])
ms <- Variance -> Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
go (Variance -> Variance
flipV Variance
v) Type
s                  -- argument flips variance
          Maybe (CoreExpr, [Ct])
mr <- Variance -> Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
go Variance
v Type
r
          case (Maybe (CoreExpr, [Ct])
ms, Maybe (CoreExpr, [Ct])
mr) of
            (Just (CoreExpr
es, [Ct]
w1), Just (CoreExpr
er, [Ct]
w2)) -> do
              let (Type
sf, Type
rf) = case Variance
v of Variance
Cov -> (Type
s, Type
r); Variance
Con -> (Type -> Type
sub Type
s, Type -> Type
sub Type
r)
                  xTy :: Type
xTy      = case Variance
v of Variance
Cov -> Type -> Type
sub Type
s; Variance
Con -> Type
s
              Id
g <- Type -> String -> TcPluginM Id
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
sf Type
rf) String
"g"
              Id
x <- Type -> String -> TcPluginM Id
freshId Type
xTy String
"x"
              Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CoreExpr, [Ct]) -> Maybe (CoreExpr, [Ct])
forall a. a -> Maybe a
Just ([Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id
g, Id
x] (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
er (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
g) (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
es (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x)))), [Ct]
w1 [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
w2))
            (Maybe (CoreExpr, [Ct]), Maybe (CoreExpr, [Ct]))
_ -> Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CoreExpr, [Ct])
forall a. Maybe a
Nothing
      -- tuple: the one place the parameter may appear in several arguments —
      -- GHC's @ft_tup@ maps every component pointwise (not via @Bifunctor@):
      -- @\\(x1,..,xn) -> (m1 x1, .., mn xn)@.
      | Variance
Cov <- Variance
v, Just (TyCon
tc, [Type]
args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t
      , TyCon -> Bool
isTupleTyCon TyCon
tc, [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 = do
          [Maybe (CoreExpr, [Ct])]
ms <- (Type -> TcPluginM (Maybe (CoreExpr, [Ct])))
-> [Type] -> TcPluginM [Maybe (CoreExpr, [Ct])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Variance -> Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
go Variance
Cov) [Type]
args
          case [Maybe (CoreExpr, [Ct])] -> Maybe [(CoreExpr, [Ct])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (CoreExpr, [Ct])]
ms of
            Maybe [(CoreExpr, [Ct])]
Nothing    -> Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CoreExpr, [Ct])
forall a. Maybe a
Nothing
            Just [(CoreExpr, [Ct])]
pairs -> do
              let ([CoreExpr]
mappers, [[Ct]]
wss) = [(CoreExpr, [Ct])] -> ([CoreExpr], [[Ct]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CoreExpr, [Ct])]
pairs
                  dc :: DataCon
dc   = Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args)
              [Id]
xs  <- (Type -> TcPluginM Id) -> [Type] -> TcPluginM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type -> String -> TcPluginM Id
`freshId` String
"u") [Type]
args
              Id
tup <- Type -> String -> TcPluginM Id
freshId Type
t String
"tup" ; Id
cb <- Type -> String -> TcPluginM Id
freshId Type
t String
"cb"
              let body :: CoreExpr
body = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
dc ((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> CoreExpr
forall b. Type -> Expr b
Type (Type -> CoreExpr) -> (Type -> Type) -> Type -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
sub) [Type]
args [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ (CoreExpr -> CoreExpr -> CoreExpr)
-> [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App [CoreExpr]
mappers ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
xs))
              Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CoreExpr, [Ct]) -> Maybe (CoreExpr, [Ct])
forall a. a -> Maybe a
Just (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
tup (CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
tup) Id
cb (Type -> Type
sub Type
t) [AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
dc) [Id]
xs CoreExpr
body]), [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Ct]]
wss))
      | Just Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
self <- Maybe (Type -> TcPluginM (Maybe (CoreExpr, [Ct])))
mSelf, Variance
Cov <- Variance
v, Just Type
q <- Type -> Maybe Type
matchSelf Type
t = Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
self Type
q
      | Just (Type
h, Type
larg) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
t, Bool -> Bool
not (Type -> Bool
inA Type
h) = do
          Maybe (CoreExpr, [Ct])
mf <- Variance -> Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
go Variance
v Type
larg                       -- try H as a covariant functor
          case Maybe (CoreExpr, [Ct])
mf of
            Just (CoreExpr
e, [Ct]
w) -> do
              CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
fmapCls [Type
h])
              let (Type
ft, Type
tt) = case Variance
v of Variance
Cov -> (Type
larg, Type -> Type
sub Type
larg); Variance
Con -> (Type -> Type
sub Type
larg, Type
larg)
              Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CoreExpr, [Ct]) -> Maybe (CoreExpr, [Ct])
forall a. a -> Maybe a
Just ( CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
fmapSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
h, HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ft, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
tt, CoreExpr
e]
                         , CtEvidence -> Ct
mkNonCanonical CtEvidence
ev Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
w ))
            Maybe (CoreExpr, [Ct])
Nothing -> case Maybe Class
mContraCls of        -- else try H as a contravariant functor
              Maybe Class
Nothing -> Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CoreExpr, [Ct])
forall a. Maybe a
Nothing
              Just Class
contraCls -> do
                Maybe (CoreExpr, [Ct])
mc <- Variance -> Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
go (Variance -> Variance
flipV Variance
v) Type
larg
                case Maybe (CoreExpr, [Ct])
mc of
                  Maybe (CoreExpr, [Ct])
Nothing       -> Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CoreExpr, [Ct])
forall a. Maybe a
Nothing
                  Just (CoreExpr
e, [Ct]
w) -> do
                    CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
contraCls [Type
h])
                    -- contramap :: (x->y) -> f y -> f x
                    let (Type
xT, Type
yT) = case Variance
v of Variance
Cov -> (Type -> Type
sub Type
larg, Type
larg); Variance
Con -> (Type
larg, Type -> Type
sub Type
larg)
                    Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CoreExpr, [Ct]) -> Maybe (CoreExpr, [Ct])
forall a. a -> Maybe a
Just ( CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var (String -> Class -> Id
classMethod String
"contramap" Class
contraCls))
                                   [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
h, HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
ev, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
xT, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
yT, CoreExpr
e]
                               , CtEvidence -> Ct
mkNonCanonical CtEvidence
ev Ct -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
: [Ct]
w ))
      | Bool
otherwise = Maybe (CoreExpr, [Ct]) -> TcPluginM (Maybe (CoreExpr, [Ct]))
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CoreExpr, [Ct])
forall a. Maybe a
Nothing

-- | Destructure a scrutinee of inner type @F instTys@ (already coerced to
-- @F instTys@) into per-constructor alternatives.  A @data@ type becomes a real
-- @Case@; a @newtype@ has no runtime constructor — its single \"constructor\" is
-- a zero-cost coercion — so we unwrap the one field with a cast instead (a
-- @DataAlt@ on a newtype is rejected by Core Lint).
destructInner :: TyCon -> [Type] -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
destructInner :: TyCon -> [Type] -> CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
destructInner TyCon
fTc [Type]
instTys CoreExpr
scrut Id
cb Type
resTy [Alt Id]
alts
  | TyCon -> Bool
isNewTyCon TyCon
fTc
  , [Alt AltCon
_ [Id
x] CoreExpr
body] <- [Alt Id]
alts
  = Bind Id -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
x (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
scrut (Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational
                                 (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
fTc) [Type]
instTys []))) CoreExpr
body
  | Bool
otherwise = CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut Id
cb Type
resTy [Alt Id]
alts

-- | Synthesize @Functor (Stock1 F)@ — the covariant instance of the shared
-- @synthMap1@ engine.
freshTyVar :: String -> TcPluginM TyVar
freshTyVar :: String -> TcPluginM Id
freshTyVar = Type -> String -> TcPluginM Id
freshTyVarK Type
liftedTypeKind

-- | A fresh type variable of the given kind.
freshTyVarK :: Kind -> String -> TcPluginM TyVar
freshTyVarK :: Type -> String -> TcPluginM Id
freshTyVarK Type
k String
s = do
  Unique
u <- TcM Unique -> TcPluginM Unique
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM TcM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
  Id -> TcPluginM Id
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type -> Id
mkTyVar (Unique -> OccName -> Name
mkSystemName Unique
u (String -> OccName
mkTyVarOcc String
s)) Type
k)

-- | Extract the 'CoreExpr' from the @EvExpr@ forms we build.
unwrapEv :: EvTerm -> CoreExpr
unwrapEv :: EvTerm -> CoreExpr
unwrapEv (EvExpr CoreExpr
e) = CoreExpr
e
unwrapEv EvTerm
_          = String -> CoreExpr
forall a. HasCallStack => String -> a
error String
"stock: expected EvExpr"

-- ----- shared ReadPrec assembler (GHC-faithful Read / Read1 / Read2) -------
--
-- GHC's derived @Read@ defines @readPrec@ (not @readsPrec@); @readsPrec@ comes
-- from the class default @readPrec_to_S readPrec@.  Building the very same
-- @readPrec@ (same combinators, same @+++@ order) makes the synthesized
-- instance byte-faithful, including the order of ambiguous infix parses.

-- | Every combinator GHC's derived @readPrec@ uses, looked up once.
data ReadPrecEnv = ReadPrecEnv
  { ReadPrecEnv -> TyCon
rpReadPrecTc :: TyCon
  , ReadPrecEnv -> CoreExpr
rpMonadDict  :: CoreExpr
  , ReadPrecEnv -> Id
rpBindSel, ReadPrecEnv -> Id
rpThenSel, ReadPrecEnv -> Id
rpReturnSel :: Id
  , ReadPrecEnv -> Id
rpParens, ReadPrecEnv -> Id
rpChoose, ReadPrecEnv -> Id
rpExpectP, ReadPrecEnv -> Id
rpReadField :: Id
  , ReadPrecEnv -> Id
rpPrec, ReadPrecEnv -> Id
rpStep, ReadPrecEnv -> Id
rpReset, ReadPrecEnv -> Id
rpPlus, ReadPrecEnv -> Id
rpPfail :: Id
  , ReadPrecEnv -> DataCon
rpIdentCon, ReadPrecEnv -> DataCon
rpSymbolCon, ReadPrecEnv -> DataCon
rpPuncCon :: DataCon
  }

-- | Look up the @ReadPrec@ combinators and request a @Monad ReadPrec@ wanted
-- (returned as the second component, to be emitted alongside the synthesized
-- instance's other wanteds).
lookupReadPrecEnv :: CtLoc -> TcPluginM (ReadPrecEnv, Ct)
lookupReadPrecEnv :: CtLoc -> TcPluginM (ReadPrecEnv, Ct)
lookupReadPrecEnv CtLoc
loc = do
  Class
monadCls    <- Name -> TcPluginM Class
tcLookupClass Name
monadClassName
  TyCon
readPrecTc  <- Module -> OccName -> TcPluginM Name
lookupOrig Module
tEXT_READPREC (String -> OccName
mkTcOcc String
"ReadPrec") TcPluginM Name -> (Name -> TcPluginM TyCon) -> TcPluginM TyCon
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM TyCon
tcLookupTyCon
  Id
parensId    <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_READ (String -> OccName
mkVarOcc String
"parens")    TcPluginM Name -> (Name -> TcPluginM Id) -> TcPluginM Id
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Id
tcLookupId
  Id
chooseId    <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_READ (String -> OccName
mkVarOcc String
"choose")    TcPluginM Name -> (Name -> TcPluginM Id) -> TcPluginM Id
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Id
tcLookupId
  Id
expectPId   <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_READ (String -> OccName
mkVarOcc String
"expectP")   TcPluginM Name -> (Name -> TcPluginM Id) -> TcPluginM Id
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Id
tcLookupId
  Id
readFieldId <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_READ (String -> OccName
mkVarOcc String
"readField") TcPluginM Name -> (Name -> TcPluginM Id) -> TcPluginM Id
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Id
tcLookupId
  Id
precId      <- Module -> OccName -> TcPluginM Name
lookupOrig Module
tEXT_READPREC (String -> OccName
mkVarOcc String
"prec")  TcPluginM Name -> (Name -> TcPluginM Id) -> TcPluginM Id
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Id
tcLookupId
  Id
stepId      <- Module -> OccName -> TcPluginM Name
lookupOrig Module
tEXT_READPREC (String -> OccName
mkVarOcc String
"step")  TcPluginM Name -> (Name -> TcPluginM Id) -> TcPluginM Id
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Id
tcLookupId
  Id
resetId     <- Module -> OccName -> TcPluginM Name
lookupOrig Module
tEXT_READPREC (String -> OccName
mkVarOcc String
"reset") TcPluginM Name -> (Name -> TcPluginM Id) -> TcPluginM Id
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Id
tcLookupId
  Id
plusId      <- Module -> OccName -> TcPluginM Name
lookupOrig Module
tEXT_READPREC (String -> OccName
mkVarOcc String
"+++")   TcPluginM Name -> (Name -> TcPluginM Id) -> TcPluginM Id
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Id
tcLookupId
  Id
pfailId     <- Module -> OccName -> TcPluginM Name
lookupOrig Module
tEXT_READPREC (String -> OccName
mkVarOcc String
"pfail") TcPluginM Name -> (Name -> TcPluginM Id) -> TcPluginM Id
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM Id
tcLookupId
  DataCon
identCon    <- Module -> OccName -> TcPluginM Name
lookupOrig Module
tEXT_READ_LEX (String -> OccName
mkDataOcc String
"Ident")  TcPluginM Name -> (Name -> TcPluginM DataCon) -> TcPluginM DataCon
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM DataCon
tcLookupDataCon
  DataCon
symbolCon   <- Module -> OccName -> TcPluginM Name
lookupOrig Module
tEXT_READ_LEX (String -> OccName
mkDataOcc String
"Symbol") TcPluginM Name -> (Name -> TcPluginM DataCon) -> TcPluginM DataCon
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM DataCon
tcLookupDataCon
  DataCon
puncCon     <- Module -> OccName -> TcPluginM Name
lookupOrig Module
tEXT_READ_LEX (String -> OccName
mkDataOcc String
"Punc")   TcPluginM Name -> (Name -> TcPluginM DataCon) -> TcPluginM DataCon
forall a b. TcPluginM a -> (a -> TcPluginM b) -> TcPluginM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> TcPluginM DataCon
tcLookupDataCon
  CtEvidence
monadEv <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
monadCls [TyCon -> Type
mkTyConTy TyCon
readPrecTc])
  (ReadPrecEnv, Ct) -> TcPluginM (ReadPrecEnv, Ct)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( TyCon
-> CoreExpr
-> Id
-> Id
-> Id
-> Id
-> Id
-> Id
-> Id
-> Id
-> Id
-> Id
-> Id
-> Id
-> DataCon
-> DataCon
-> DataCon
-> ReadPrecEnv
ReadPrecEnv TyCon
readPrecTc (HasDebugCallStack => CtEvidence -> CoreExpr
CtEvidence -> CoreExpr
ctEvExpr CtEvidence
monadEv)
           (String -> Class -> Id
classMethod String
">>=" Class
monadCls) (String -> Class -> Id
classMethod String
">>" Class
monadCls) (String -> Class -> Id
classMethod String
"return" Class
monadCls)
           Id
parensId Id
chooseId Id
expectPId Id
readFieldId Id
precId Id
stepId Id
resetId Id
plusId Id
pfailId
           DataCon
identCon DataCon
symbolCon DataCon
puncCon
       , CtEvidence -> Ct
mkNonCanonical CtEvidence
monadEv )

-- | Assemble a @readPrec@-shaped body for element type @gTy@.  Each constructor
-- carries one /raw/ field reader (a @ReadPrec ft@) per field; this wraps them
-- exactly as GHC: nullary cons grouped into one leading @choose@, then prefix
-- (@prec 10@ + @step@) \/ infix (@prec fixity@ + @step@) \/ record (@prec 11@ +
-- @readField name (reset _)@) cons in declaration order, all under @parens@.
-- @mkConVal dc binders@ builds the (already wrapped\/cast) constructor value.
buildReadPrecBody :: ReadPrecEnv -> Type -> (DataCon -> [Id] -> CoreExpr)
                  -> [(DataCon, [(Type, CoreExpr)])] -> TcPluginM CoreExpr
buildReadPrecBody :: ReadPrecEnv
-> Type
-> (DataCon -> [Id] -> CoreExpr)
-> [(DataCon, [(Type, CoreExpr)])]
-> TcPluginM CoreExpr
buildReadPrecBody ReadPrecEnv
env Type
gTy DataCon -> [Id] -> CoreExpr
mkConVal [(DataCon, [(Type, CoreExpr)])]
cons = do
  let ReadPrecEnv TyCon
readPrecTc CoreExpr
monadDict Id
bindSel Id
thenSel Id
returnSel
        Id
parensId Id
chooseId Id
expectPId Id
readFieldId Id
precId Id
stepId Id
resetId Id
plusId Id
pfailId
        DataCon
identCon DataCon
symbolCon DataCon
puncCon = ReadPrecEnv
env
      readPrecTy :: Type
readPrecTy    = TyCon -> Type
mkTyConTy TyCon
readPrecTc
      strPairTy :: Type
strPairTy     = [Type] -> Type
mkBoxedTupleTy [Type
stringTy, TyCon -> [Type] -> Type
mkTyConApp TyCon
readPrecTc [Type
gTy]]
      bindP :: Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
bindP Type
a Type
b CoreExpr
m CoreExpr
k = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bindSel)   [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
readPrecTy, CoreExpr
monadDict, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
a, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
b, CoreExpr
m, CoreExpr
k]
      thenP :: Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
thenP Type
a Type
b CoreExpr
m CoreExpr
n = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
thenSel)   [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
readPrecTy, CoreExpr
monadDict, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
a, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
b, CoreExpr
m, CoreExpr
n]
      returnP :: Type -> CoreExpr -> CoreExpr
returnP Type
a CoreExpr
v   = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
returnSel) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
readPrecTy, CoreExpr
monadDict, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
a, CoreExpr
v]
      seqW :: CoreExpr -> CoreExpr -> CoreExpr
seqW CoreExpr
m CoreExpr
n      = Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
thenP Type
unitTy Type
gTy CoreExpr
m CoreExpr
n
      parensE :: Type -> Arg b -> Arg b
parensE Type
a Arg b
p   = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Arg b
forall b. Id -> Expr b
Var Id
parensId) [Type -> Arg b
forall b. Type -> Expr b
Type Type
a, Arg b
p]
      precE :: Type -> Integer -> CoreExpr -> CoreExpr
precE Type
a Integer
n CoreExpr
p   = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
precId)   [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
a, Integer -> CoreExpr
mkUncheckedIntExpr Integer
n, CoreExpr
p]
      stepE :: Type -> Arg b -> Arg b
stepE Type
a Arg b
p     = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Arg b
forall b. Id -> Expr b
Var Id
stepId)   [Type -> Arg b
forall b. Type -> Expr b
Type Type
a, Arg b
p]
      resetE :: Type -> Arg b -> Arg b
resetE Type
a Arg b
p    = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Arg b
forall b. Id -> Expr b
Var Id
resetId)  [Type -> Arg b
forall b. Type -> Expr b
Type Type
a, Arg b
p]
      plusE :: Type -> Arg b -> Arg b -> Arg b
plusE Type
a Arg b
p Arg b
q   = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Arg b
forall b. Id -> Expr b
Var Id
plusId)   [Type -> Arg b
forall b. Type -> Expr b
Type Type
a, Arg b
p, Arg b
q]
      chooseE :: Type -> Arg b -> Arg b
chooseE Type
a Arg b
xs  = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Arg b
forall b. Id -> Expr b
Var Id
chooseId) [Type -> Arg b
forall b. Type -> Expr b
Type Type
a, Arg b
xs]
      readFieldE :: Type -> Arg b -> Arg b -> Arg b
readFieldE Type
a Arg b
s Arg b
p = Arg b -> [Arg b] -> Arg b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Arg b
forall b. Id -> Expr b
Var Id
readFieldId) [Type -> Arg b
forall b. Type -> Expr b
Type Type
a, Arg b
s, Arg b
p]
      expectPE :: Arg b -> Arg b
expectPE Arg b
l    = Arg b -> Arg b -> Arg b
forall b. Expr b -> Expr b -> Expr b
App (Id -> Arg b
forall b. Id -> Expr b
Var Id
expectPId) Arg b
l
      identE :: CoreExpr -> CoreExpr
identE CoreExpr
s  = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
identCon  [CoreExpr
s]
      symbolE :: CoreExpr -> CoreExpr
symbolE CoreExpr
s = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
symbolCon [CoreExpr
s]
      puncE :: CoreExpr -> CoreExpr
puncE CoreExpr
s   = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
puncCon   [CoreExpr
s]
      str :: String -> TcPluginM CoreExpr
str String
s     = TcM CoreExpr -> TcPluginM CoreExpr
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (FastString -> TcM CoreExpr
forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS (String -> FastString
fsLit String
s))
  [Either (CoreExpr, CoreExpr) CoreExpr]
entries <- [(DataCon, [(Type, CoreExpr)])]
-> ((DataCon, [(Type, CoreExpr)])
    -> TcPluginM (Either (CoreExpr, CoreExpr) CoreExpr))
-> TcPluginM [Either (CoreExpr, CoreExpr) CoreExpr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(DataCon, [(Type, CoreExpr)])]
cons \(DataCon
dc, [(Type, CoreExpr)]
readers) -> do
    let name :: String
name   = OccName -> String
occNameString (DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
dc)
        labels :: [String]
labels = (FieldLabel -> String) -> [FieldLabel] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OccName -> String
occNameString (OccName -> String)
-> (FieldLabel -> OccName) -> FieldLabel -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (FieldLabel -> Name) -> FieldLabel -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> Name
flSelector) (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc)
    CoreExpr
nameE  <- String -> TcPluginM CoreExpr
str String
name
    [Id]
argIds <- ((Type, CoreExpr) -> Int -> TcPluginM Id)
-> [(Type, CoreExpr)] -> [Int] -> TcPluginM [Id]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (\(Type
ft, CoreExpr
_) Int
i -> Type -> String -> TcPluginM Id
freshId Type
ft (String
"a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
i :: Int))) [(Type, CoreExpr)]
readers [Int
0 ..]
    let ret :: CoreExpr
ret   = Type -> CoreExpr -> CoreExpr
returnP Type
gTy (DataCon -> [Id] -> CoreExpr
mkConVal DataCon
dc [Id]
argIds)
        items :: [(Id, Type, CoreExpr)]
items = [Id] -> [Type] -> [CoreExpr] -> [(Id, Type, CoreExpr)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Id]
argIds (((Type, CoreExpr) -> Type) -> [(Type, CoreExpr)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, CoreExpr) -> Type
forall a b. (a, b) -> a
fst [(Type, CoreExpr)]
readers) (((Type, CoreExpr) -> CoreExpr) -> [(Type, CoreExpr)] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Type, CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd [(Type, CoreExpr)]
readers)  -- (binder, ft, rawReader)
    if [(Type, CoreExpr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Type, CoreExpr)]
readers
      then Either (CoreExpr, CoreExpr) CoreExpr
-> TcPluginM (Either (CoreExpr, CoreExpr) CoreExpr)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CoreExpr, CoreExpr) -> Either (CoreExpr, CoreExpr) CoreExpr
forall a b. a -> Either a b
Left (CoreExpr
nameE, CoreExpr
ret))                              -- nullary -> choose entry
      else if DataCon -> Bool
dataConIsInfix DataCon
dc
        then do
          Integer
prec <- DataCon -> TcPluginM Integer
conPrec DataCon
dc
          let [(Id
a0, Type
ft0, CoreExpr
rd0), (Id
a1, Type
ft1, CoreExpr
rd1)] = [(Id, Type, CoreExpr)]
items
              inner :: CoreExpr
inner = Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
bindP Type
ft0 Type
gTy (Type -> CoreExpr -> CoreExpr
forall {b}. Type -> Arg b -> Arg b
stepE Type
ft0 CoreExpr
rd0) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
a0 (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                      CoreExpr -> CoreExpr -> CoreExpr
seqW (CoreExpr -> CoreExpr
forall {b}. Arg b -> Arg b
expectPE (CoreExpr -> CoreExpr
symbolE CoreExpr
nameE)) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                      Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
bindP Type
ft1 Type
gTy (Type -> CoreExpr -> CoreExpr
forall {b}. Type -> Arg b -> Arg b
stepE Type
ft1 CoreExpr
rd1) (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
a1 CoreExpr
ret)
          Either (CoreExpr, CoreExpr) CoreExpr
-> TcPluginM (Either (CoreExpr, CoreExpr) CoreExpr)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> Either (CoreExpr, CoreExpr) CoreExpr
forall a b. b -> Either a b
Right (Type -> Integer -> CoreExpr -> CoreExpr
precE Type
gTy Integer
prec CoreExpr
inner))
      else if Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
labels)
        then do
          CoreExpr
openCE <- String -> TcPluginM CoreExpr
str String
"{"; CoreExpr
closeCE <- String -> TcPluginM CoreExpr
str String
"}"; CoreExpr
commaCE <- String -> TcPluginM CoreExpr
str String
","
          [CoreExpr]
lblEs  <- (String -> TcPluginM CoreExpr) -> [String] -> TcPluginM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> TcPluginM CoreExpr
str [String]
labels
          let closeRet :: CoreExpr
closeRet = CoreExpr -> CoreExpr -> CoreExpr
seqW (CoreExpr -> CoreExpr
forall {b}. Arg b -> Arg b
expectPE (CoreExpr -> CoreExpr
puncE CoreExpr
closeCE)) CoreExpr
ret
              go :: [(Int, CoreExpr, (Id, Type, CoreExpr))] -> CoreExpr
go [] = CoreExpr
closeRet
              go ((Int
i, CoreExpr
lblE, (Id
aId, Type
ft, CoreExpr
rd)) : [(Int, CoreExpr, (Id, Type, CoreExpr))]
rest) =
                let bound :: CoreExpr
bound = Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
bindP Type
ft Type
gTy (Type -> CoreExpr -> CoreExpr -> CoreExpr
forall {b}. Type -> Arg b -> Arg b -> Arg b
readFieldE Type
ft CoreExpr
lblE (Type -> CoreExpr -> CoreExpr
forall {b}. Type -> Arg b -> Arg b
resetE Type
ft CoreExpr
rd)) (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
aId ([(Int, CoreExpr, (Id, Type, CoreExpr))] -> CoreExpr
go [(Int, CoreExpr, (Id, Type, CoreExpr))]
rest))
                in if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
0 :: Int) then CoreExpr
bound else CoreExpr -> CoreExpr -> CoreExpr
seqW (CoreExpr -> CoreExpr
forall {b}. Arg b -> Arg b
expectPE (CoreExpr -> CoreExpr
puncE CoreExpr
commaCE)) CoreExpr
bound
              inner :: CoreExpr
inner = CoreExpr -> CoreExpr -> CoreExpr
seqW (CoreExpr -> CoreExpr
forall {b}. Arg b -> Arg b
expectPE (CoreExpr -> CoreExpr
identE CoreExpr
nameE)) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                      CoreExpr -> CoreExpr -> CoreExpr
seqW (CoreExpr -> CoreExpr
forall {b}. Arg b -> Arg b
expectPE (CoreExpr -> CoreExpr
puncE CoreExpr
openCE)) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                      [(Int, CoreExpr, (Id, Type, CoreExpr))] -> CoreExpr
go ([Int]
-> [CoreExpr]
-> [(Id, Type, CoreExpr)]
-> [(Int, CoreExpr, (Id, Type, CoreExpr))]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
0 ..] [CoreExpr]
lblEs [(Id, Type, CoreExpr)]
items)
          Either (CoreExpr, CoreExpr) CoreExpr
-> TcPluginM (Either (CoreExpr, CoreExpr) CoreExpr)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> Either (CoreExpr, CoreExpr) CoreExpr
forall a b. b -> Either a b
Right (Type -> Integer -> CoreExpr -> CoreExpr
precE Type
gTy Integer
11 CoreExpr
inner))
      else do                                                    -- prefix with args
        let chain :: CoreExpr
chain = ((Id, Type, CoreExpr) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [(Id, Type, CoreExpr)] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Id
aId, Type
ft, CoreExpr
rd) CoreExpr
acc -> Type -> Type -> CoreExpr -> CoreExpr -> CoreExpr
bindP Type
ft Type
gTy (Type -> CoreExpr -> CoreExpr
forall {b}. Type -> Arg b -> Arg b
stepE Type
ft CoreExpr
rd) (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
aId CoreExpr
acc)) CoreExpr
ret [(Id, Type, CoreExpr)]
items
            inner :: CoreExpr
inner = CoreExpr -> CoreExpr -> CoreExpr
seqW (CoreExpr -> CoreExpr
forall {b}. Arg b -> Arg b
expectPE (CoreExpr -> CoreExpr
identE CoreExpr
nameE)) CoreExpr
chain
        Either (CoreExpr, CoreExpr) CoreExpr
-> TcPluginM (Either (CoreExpr, CoreExpr) CoreExpr)
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> Either (CoreExpr, CoreExpr) CoreExpr
forall a b. b -> Either a b
Right (Type -> Integer -> CoreExpr -> CoreExpr
precE Type
gTy Integer
10 CoreExpr
inner))
  let nullaries :: [(CoreExpr, CoreExpr)]
nullaries = [(CoreExpr, CoreExpr)
e | Left (CoreExpr, CoreExpr)
e  <- [Either (CoreExpr, CoreExpr) CoreExpr]
entries]
      others :: [CoreExpr]
others    = [CoreExpr
p | Right CoreExpr
p <- [Either (CoreExpr, CoreExpr) CoreExpr]
entries]
      chooseP :: CoreExpr
chooseP   = Type -> CoreExpr -> CoreExpr
forall {b}. Type -> Arg b -> Arg b
chooseE Type
gTy (Type -> [CoreExpr] -> CoreExpr
mkListExpr Type
strPairTy [ [CoreExpr] -> CoreExpr
mkCoreTup [CoreExpr
n, CoreExpr
p] | (CoreExpr
n, CoreExpr
p) <- [(CoreExpr, CoreExpr)]
nullaries ])
      allP :: [CoreExpr]
allP      = [CoreExpr
chooseP | Bool -> Bool
not ([(CoreExpr, CoreExpr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CoreExpr, CoreExpr)]
nullaries)] [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
others
      combined :: CoreExpr
combined  = case [CoreExpr]
allP of
                    []  -> CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
pfailId) [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
gTy]
                    [CoreExpr
p] -> CoreExpr
p
                    [CoreExpr]
ps  -> (CoreExpr -> CoreExpr -> CoreExpr) -> [CoreExpr] -> CoreExpr
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (Type -> CoreExpr -> CoreExpr -> CoreExpr
forall {b}. Type -> Arg b -> Arg b -> Arg b
plusE Type
gTy) [CoreExpr]
ps
  CoreExpr -> TcPluginM CoreExpr
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> CoreExpr -> CoreExpr
forall {b}. Type -> Arg b -> Arg b
parensE Type
gTy CoreExpr
combined)