{-# 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
  r   <- [CoreExpr] -> TcPluginM CoreExpr
andE [CoreExpr]
as
  scr <- freshId boolTy "c"
  pure (Case a scr boolTy [ Alt (DataAlt falseDataCon) [] (Var (dataConWorkId falseDataCon))
                          , Alt (DataAlt trueDataCon)  [] r ])

lookupTyConMaybe :: String -> String -> TcPluginM (Maybe TyCon)
lookupTyConMaybe :: String -> String -> TcPluginM (Maybe TyCon)
lookupTyConMaybe String
modName String
occ = do
  res <- ModuleName -> PkgQual -> TcPluginM FindResult
findImportedModule (String -> ModuleName
mkModuleName String
modName) PkgQual
NoPkgQual
  case 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
  m1  <- String -> TcPluginM TyCon
gTc String
"M1"
  dT  <- mkTyConTy <$> gTc "D" ; cT <- mkTyConTy <$> gTc "C" ; sT <- mkTyConTy <$> gTc "S"
  md  <- promoteDataCon <$> gDc "MetaData"
  mc  <- promoteDataCon <$> gDc "MetaCons"
  ms  <- promoteDataCon <$> gDc "MetaSel"
  pfx <- promTy "PrefixI"
  inI <- promoteDataCon <$> gDc "InfixI"
  la  <- promTy "LeftAssociative" ; ra <- promTy "RightAssociative" ; na <- promTy "NotAssociative"
  nu  <- promTy "NoSourceUnpackedness" ; snu <- promTy "SourceNoUnpack" ; su <- promTy "SourceUnpack"
  ns  <- promTy "NoSourceStrictness"   ; sl  <- promTy "SourceLazy"     ; ss <- promTy "SourceStrict"
  dl  <- promTy "DecidedLazy" ; ds <- promTy "DecidedStrict" ; du <- promTy "DecidedUnpack"
  pure MetaEnv { meM1 = m1, meD = dT, meC = cT, meS = sT
               , meMetaData = md, meMetaCons = mc, meMetaSel = ms
               , mePrefixI = pfx, meInfixI = inI
               , meLeftAssoc = la, meRightAssoc = ra, meNotAssoc = na
               , meNoUnpack = nu, meSrcNoUnpack = snu, meSrcUnpack = su
               , meNoStrict = ns, meSrcLazy = sl, meSrcStrict = ss
               , meDecidedLazy = dl, meDecidedStrict = ds, meDecidedUnpack = du
               , meJustSym = promotedJustDataCon
               , meNothingSym = mkTyConApp promotedNothingDataCon [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
  res <- ModuleName -> PkgQual -> TcPluginM FindResult
findImportedModule (String -> ModuleName
mkModuleName String
modName) PkgQual
NoPkgQual
  case 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
  res <- ModuleName -> PkgQual -> TcPluginM FindResult
findImportedModule (String -> ModuleName
mkModuleName String
modName) PkgQual
NoPkgQual
  case 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
      fx <- TcM Fixity -> TcPluginM Fixity
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (Name -> TcM Fixity
lookupFixityRn (DataCon -> Name
dataConName DataCon
dc))
      let (prec, dir) = fixityParts fx
          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
      pure (mkTyConApp (meInfixI me) [assoc, mkNumLitTy (fromIntegral 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
  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] -> [(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
  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
  ourTc   <- Maybe TyCon
ourStock
  stockTc <- tyConAppTyCon_maybe wrappedTy
  guard (stockTc == ourTc)
  innerTy <- case tyConAppArgs wrappedTy of { (Type
a:[Type]
_) -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
a; [Type]
_ -> Maybe Type
forall a. Maybe a
Nothing }
  innerTc <- tyConAppTyCon_maybe innerTy
  let dcons = TyCon -> [DataCon]
tyConDataCons TyCon
innerTc
  guard (not (null dcons))
  let co = Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion
mkUnbranchedAxInstCo Role
Representational
             (TyCon -> CoAxiom Unbranched
newTyConCo TyCon
stockTc) (HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy) []
      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 ]
  pure (Repr innerTy co 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
      arrowTc <- OvTcs -> Maybe TyCon
ovArrow OvTcs
tcs ; assignTc <- ovAssign tcs
      atTc    <- ovAt tcs    ; keepTc   <- ovKeep tcs
      fTc     <- tyConAppTyCon_maybe realInner
      let dcons = TyCon -> [DataCon]
tyConDataCons TyCon
fTc
      guard (not (null dcons))
      entries <- promotedListElems cfg >>= traverse (decodeEntry arrowTc assignTc atTc)
      cells   <- either (const Nothing) Just (resolveCellsRaw dcons realInner entries)
      -- @realInner@ is an unsaturated @j -> Type@ here, so use the source arity
      -- (not 'fieldTysAt', which would instantiate the datacon and panic).
      Just [ fromMaybe (mkTyConTy keepTc) (lookup (0, fi) cells)
           | fi <- [0 .. dataConSourceArity (head dcons) - 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) (HasCallStack => 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) (HasCallStack => 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) (HasCallStack => 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) (HasCallStack => 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
  ourStock <- GenEnv -> Maybe TyCon
geStock GenEnv
gen
  overTc   <- geOverride gen
  keepTc   <- geKeep gen ; arrowTc <- geArrow gen
  assignTc <- geAssign gen ; atTc <- geAt gen
  (stockTc, [innerOver]) <- splitTyConApp_maybe arg
  guard (stockTc == ourStock)
  (oTc, oArgs) <- splitTyConApp_maybe innerOver
  guard (oTc == overTc)
  (cfg : realInner : _) <- pure (reverse oArgs)
  innerTc <- tyConAppTyCon_maybe realInner
  let dcons = TyCon -> [DataCon]
tyConDataCons TyCon
innerTc
  guard (not (null dcons))
  perCon <-
    case decodePositional 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
        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 resolveCells dcons realInner 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 ]
  pure (realInner, zip dcons 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] [])
      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)
      pure $ case sequence 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
          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)
          pure $ case sequence 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
            ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Type -> Type -> Type
mkStockReprEq Type
ft Type
modTy)
            pure (Right ((modTy, ctEvCoercion ev), [mkNonCanonical 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
      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
        ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Type -> Type -> Type
mkStockReprEq Type
realFt Type
modTy)
        pure (((ci, fi), (modTy, ctEvCoercion ev)), mkNonCanonical ev)
      let 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 = ((((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 -> 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 = [ 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) ] ]
      pure (Right (Repr realInner co cons, 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
      cells <- [DataCon] -> Type -> Addr -> Either SDoc [(Int, Int)]
resolveAddr [DataCon]
dcons Type
targetTy Addr
addr
      case filter (`elem` claimed) 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)] -> [((Int, Int), b)]
forall a. [a] -> [a] -> [a]
++) ([((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
      cells <- [DataCon] -> Type -> Addr -> Either SDoc [(Int, Int)]
resolveAddr [DataCon]
dcons Type
targetTy Addr
addr
      case filter (`elem` claimed) 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
          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)
          (here ++) <$> go (cells ++ claimed) 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
  (tc, args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
  if | tc == promotedNilDataCon  -> Just []
     | tc == promotedConsDataCon -> case args of
         [Type
_k, Type
x, Type
rest] -> (Type
x Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:) ([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
     | otherwise -> 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
  (tc, args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
e
  guard (tc == arrowTc)
  case reverse 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 (HasCallStack => 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 (HasCallStack => 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
  dvar   <- Type -> String -> TcPluginM Id
freshId (Class -> [Type] -> Type
mkClassPred Class
cls [Type
ty]) String
"dict"
  fields <- mk dvar
  pure (Let (Rec [(dvar, mkClassDict cls ty fields)]) (Var 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
  dvar <- Type -> String -> TcPluginM Id
freshId (Class -> [Type] -> Type
mkClassPred Class
cls [Type
ty]) String
"dict"
  methodFields <- for (zip [0 ..] (classMethods 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 dm <- Class -> Int -> TcPluginM Id
defMethId Class
cls Int
i
                    pure (mkApps (Var dm) [Type ty, Var dvar])
  pure (Let (Rec [(dvar, mkClassDict cls ty (supers ++ methodFields))]) (Var 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
      ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
constCls [Type
ftA])
      pure (Just (onConst roles ev ftA, [mkNonCanonical 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)
      ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
liftCls [Type
m])
      pure (Just (onApply roles ev m coB, [mkNonCanonical 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)
  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
    xs <- DataCon -> Type -> TcPluginM [Id]
freshFields DataCon
dci Type
aTy
    mAlts <- for indexed \(Int
j, DataCon
dcj) -> do
      ys <- DataCon -> Type -> TcPluginM [Id]
freshFields DataCon
dcj Type
bTy
      if i /= j
        then pure (Just (Alt (DataAlt dcj) ys (mismatch i j), []))
        else do
          mops <- sequence (zipWith4 fieldOp [0 :: Int ..] (fieldsAt fixed dci aTy) xs ys)
          case sequence 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
              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)
              pure (Just (Alt (DataAlt dcj) ys body, concatMap snd ows))
    case sequence 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
        cbB <- Type -> String -> TcPluginM Id
freshId Type
innerB String
"cbb"
        pure (Just ( Alt (DataAlt dci) xs
                       (destructInner fTc (fixed ++ [bTy]) (Cast (Var fbId) (coAt bTy)) cbB resTy alts)
                   , concat wss ))
  case sequence 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
      cbA <- Type -> String -> TcPluginM Id
freshId Type
innerA String
"cba"
      pure (Just ( destructInner fTc (fixed ++ [aTy]) (Cast (Var faId) (coAt aTy)) cbA resTy alts
                 , concat 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
  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))
  unless (key `elem` seen) $ do
    tcPluginIO (modifyIORef' (psSeen st) (key :))
    unsafeTcPluginTcM (addErrTc (mkTcRnUnknownMessage (mkPlainError noHints doc)))
  pure (Nothing, [], [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
  u <- TcM Unique -> TcPluginM Unique
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM TcM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
  pure (mkLocalId (mkSystemName u (mkVarOcc s)) manyDataConTy 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
  (ev, 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)
  pure (Just (ev, 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 <- TcPluginM InstEnvs
getInstEnvs
      let clsTy   = TyCon -> Type
mkTyConTy (Class -> TyCon
classTyCon Class
cls)
          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 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
          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.
          r <- unsafeTcPluginTcM $ liftIO $
                 getValueSafely hsc (idName dfun) (idType dfun)
          case 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 <- TcPluginM InstEnvs
getInstEnvs
      let clsTy   = TyCon -> Type
mkTyConTy (Class -> TyCon
classTyCon Class
cls)
          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 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
          hsc <- TcPluginM HscEnv
getTopEnv
          r <- unsafeTcPluginTcM $ liftIO $
                 getValueSafely hsc (idName dfun) (idType dfun)
          case r of
            Right (Deriver1 Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synth, [Linkable]
_, PkgsLoaded
_) -> do
              m <- Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synth Class
cls (Ct -> CtLoc
ctLoc Ct
ct) Type
wrappedTy Type
f
              pure $ case 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 <- TcPluginM InstEnvs
getInstEnvs
      let clsTy   = TyCon -> Type
mkTyConTy (Class -> TyCon
classTyCon Class
cls)
          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 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
          hsc <- TcPluginM HscEnv
getTopEnv
          r <- unsafeTcPluginTcM $ liftIO $
                 getValueSafely hsc (idName dfun) (idType dfun)
          case r of
            Right (Deriver2 Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synth, [Linkable]
_, PkgsLoaded
_) -> do
              m <- Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))
synth Class
cls (Ct -> CtLoc
ctLoc Ct
ct) Type
wrappedTy Type
p
              pure $ case 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 _ p _ <- TcM Fixity -> TcPluginM Fixity
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM (Name -> TcM Fixity
lookupFixityRn (DataCon -> Name
dataConName DataCon
dc))
#endif
  pure (fromIntegral 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 x <- Type -> String -> TcPluginM Id
freshId Type
t String
"x"; pure (Just (Lam x (Var 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
          ms <- Variance -> Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
go (Variance -> Variance
flipV Variance
v) Type
s                  -- argument flips variance
          mr <- go v r
          case (ms, 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
              g <- Type -> String -> TcPluginM Id
freshId (HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
sf Type
rf) String
"g"
              x <- freshId xTy "x"
              pure (Just (mkLams [g, x] (App er (App (Var g) (App es (Var x)))), w1 ++ 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
          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 sequence 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)
              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
              tup <- freshId t "tup" ; cb <- freshId t "cb"
              let 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))
              pure (Just (Lam tup (Case (Var tup) cb (sub t) [Alt (DataAlt dc) xs body]), concat 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
          mf <- Variance -> Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
go Variance
v Type
larg                       -- try H as a covariant functor
          case mf of
            Just (CoreExpr
e, [Ct]
w) -> do
              ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
fmapCls [Type
h])
              let (ft, tt) = case v of Variance
Cov -> (Type
larg, Type -> Type
sub Type
larg); Variance
Con -> (Type -> Type
sub Type
larg, Type
larg)
              pure (Just ( mkApps (Var fmapSel) [Type h, ctEvExpr ev, Type ft, Type tt, e]
                         , mkNonCanonical ev : 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
                mc <- Variance -> Type -> TcPluginM (Maybe (CoreExpr, [Ct]))
go (Variance -> Variance
flipV Variance
v) Type
larg
                case 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
                    ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted CtLoc
loc (Class -> [Type] -> Type
mkClassPred Class
contraCls [Type
h])
                    -- contramap :: (x->y) -> f y -> f x
                    let (xT, yT) = case v of Variance
Cov -> (Type -> Type
sub Type
larg, Type
larg); Variance
Con -> (Type
larg, Type -> Type
sub Type
larg)
                    pure (Just ( mkApps (Var (classMethod "contramap" contraCls))
                                   [Type h, ctEvExpr ev, Type xT, Type yT, e]
                               , mkNonCanonical ev : 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
  u <- TcM Unique -> TcPluginM Unique
forall a. TcM a -> TcPluginM a
unsafeTcPluginTcM TcM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
  pure (mkTyVar (mkSystemName u (mkTyVarOcc s)) 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
  monadCls    <- Name -> TcPluginM Class
tcLookupClass Name
monadClassName
  readPrecTc  <- lookupOrig tEXT_READPREC (mkTcOcc "ReadPrec") >>= tcLookupTyCon
  parensId    <- lookupOrig gHC_INTERNAL_READ (mkVarOcc "parens")    >>= tcLookupId
  chooseId    <- lookupOrig gHC_INTERNAL_READ (mkVarOcc "choose")    >>= tcLookupId
  expectPId   <- lookupOrig gHC_INTERNAL_READ (mkVarOcc "expectP")   >>= tcLookupId
  readFieldId <- lookupOrig gHC_INTERNAL_READ (mkVarOcc "readField") >>= tcLookupId
  precId      <- lookupOrig tEXT_READPREC (mkVarOcc "prec")  >>= tcLookupId
  stepId      <- lookupOrig tEXT_READPREC (mkVarOcc "step")  >>= tcLookupId
  resetId     <- lookupOrig tEXT_READPREC (mkVarOcc "reset") >>= tcLookupId
  plusId      <- lookupOrig tEXT_READPREC (mkVarOcc "+++")   >>= tcLookupId
  pfailId     <- lookupOrig tEXT_READPREC (mkVarOcc "pfail") >>= tcLookupId
  identCon    <- lookupOrig tEXT_READ_LEX (mkDataOcc "Ident")  >>= tcLookupDataCon
  symbolCon   <- lookupOrig tEXT_READ_LEX (mkDataOcc "Symbol") >>= tcLookupDataCon
  puncCon     <- lookupOrig tEXT_READ_LEX (mkDataOcc "Punc")   >>= tcLookupDataCon
  monadEv <- newWanted loc (mkClassPred monadCls [mkTyConTy readPrecTc])
  pure ( ReadPrecEnv readPrecTc (ctEvExpr monadEv)
           (classMethod ">>=" monadCls) (classMethod ">>" monadCls) (classMethod "return" monadCls)
           parensId chooseId expectPId readFieldId precId stepId resetId plusId pfailId
           identCon symbolCon puncCon
       , mkNonCanonical 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))
  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)
    nameE  <- String -> TcPluginM CoreExpr
str String
name
    argIds <- 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))) readers [0 ..]
    let ret   = Type -> CoreExpr -> CoreExpr
returnP Type
gTy (DataCon -> [Id] -> CoreExpr
mkConVal DataCon
dc [Id]
argIds)
        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 null readers
      then pure (Left (nameE, ret))                              -- nullary -> choose entry
      else if dataConIsInfix dc
        then do
          prec <- conPrec dc
          let [(a0, ft0, rd0), (a1, ft1, rd1)] = items
              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)
          pure (Right (precE gTy prec inner))
      else if not (null labels)
        then do
          openCE <- str "{"; closeCE <- str "}"; commaCE <- str ","
          lblEs  <- mapM str labels
          let closeRet = CoreExpr -> CoreExpr -> CoreExpr
seqW (CoreExpr -> CoreExpr
forall {b}. Arg b -> Arg b
expectPE (CoreExpr -> CoreExpr
puncE CoreExpr
closeCE)) CoreExpr
ret
              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 -> 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)
          pure (Right (precE gTy 11 inner))
      else do                                                    -- prefix with args
        let 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 -> CoreExpr -> CoreExpr
seqW (CoreExpr -> CoreExpr
forall {b}. Arg b -> Arg b
expectPE (CoreExpr -> CoreExpr
identE CoreExpr
nameE)) CoreExpr
chain
        pure (Right (precE gTy 10 inner))
  let nullaries = [(CoreExpr, CoreExpr)
e | Left (CoreExpr, CoreExpr)
e  <- [Either (CoreExpr, CoreExpr) CoreExpr]
entries]
      others    = [CoreExpr
p | Right CoreExpr
p <- [Either (CoreExpr, CoreExpr) CoreExpr]
entries]
      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
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  = 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
  pure (parensE gTy combined)