{-# LANGUAGE CPP #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingVia #-}
-- We use a few partial selectors on values whose shape is guaranteed by GHC
-- invariants — @head (classMethods c)@ (a class always has its methods),
-- @head (tyConDataCons tc)@ (guarded non-empty), and the @[lt,eq,gt]@ pattern
-- on @Ordering@'s three constructors — so we silence the corresponding noise.
{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}

-- | Synthesize class instances for the @Stock@ \/ @Stock1@ \/
-- @Stock2@ newtype wrappers directly from a datatype's structure,
-- same as hand-written without @Generic@. This one module both
-- provides the wrappers and /is/ the plugin, so a single name does
-- everything:
--
-- > {-# options_ghc -fplugin Stock #-}
-- >
-- > import Stock
-- > 
-- > data Colour = Red | Green | Blue 
-- >   deriving (Eq, Ord, Show) 
-- >   via Stock Colour
--
-- Supported classes:
--
-- * @Stock@: @Eq@, @Ord@, @Show@, @Read@, @Semigroup@, @Monoid@, @Enum@,
--   @Bounded@, @Ix@, @Generic@.
-- * @Stock1@: @Functor@ \/ @Contravariant@, @Foldable@, @Applicative@,
--   @Generic1@, @Eq1@, @Ord1@, @Show1@, @Read1@, @Traversable@.
-- * @Stock2@: @Bifunctor@, @Bifoldable@, @Eq2@, @Ord2@, @Show2@, @Read2@,
--   @Category@, @Bitraversable@.
--
-- @Traversable@\/@Bitraversable@ are synthesized at the wrapper (@Stock1
-- F@\/@Stock2 P@) and used directly, or put on your type with the one-liner
-- @traverse g = fmap unStock1 . traverse g . Stock1@.  A bare @deriving via@
-- can't coerce them onto your type: @traverse@'s result @f (t b)@ places the
-- wrapper under an abstract applicative (nominal role), which is unsound to
-- coerce — but the instance itself is ordinary, so the one-liner works.
--
-- The set is open: a satellite package adds a brand-new class with no
-- configuration change (just a dependency) by writing a @DeriveStock@
-- instance. See "Stock.Derive".
--
-- Individual fields can be reshaped during synthesis (per-field
-- @DerivingVia@) with @deriving Cls via Stock (Override T cfg)@; see
-- "Stock.Override".
--
-- /When does it run?/ All synthesis happens at __compile time__,
-- while the plugin type-checks your @deriving@ clause: it emits
-- ordinary Core — the same a hand-written instance would.  At runtime
-- there is no @Rep@, no reflection, no instance lookup; you pay
-- exactly the usual dictionary plumbing (including any dictionaries
-- that polymorphic or polymorphically-recursive code builds at
-- runtime), and never anything extra for having used @Stock@.

module Stock
  ( Stock(..), Stock1(..), Stock2(..), plugin
    -- Re-exported derivable classes that are /not/ already in Prelude, so
    -- @import Stock@ alone suffices for any @deriving C via Stock T@ clause.
    -- (Class names only: the methods live in their home modules, and
    -- re-exporting @Category@'s @id@\/@.@ would clash with Prelude.)
  , Contravariant
  , Eq1, Ord1, Show1, Read1
  , Eq2, Ord2, Show2, Read2
  , Bifunctor, Bifoldable
  , Category
  , Ix
  , Generic, Generic1
    -- The per-field modifier surface, so @import Stock@ alone suffices for
    -- @deriving C via Overriding T '[ field via M, … ]@ (the surface @via@ /
    -- @_@ lower to these @:=@ / @Keep@ markers).
  , module Stock.Override
  ) where

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)
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 )
import Stock.Compat ( gHC_INTERNAL_SHOW, gHC_INTERNAL_READ
                    , gHC_INTERNAL_LIST, gHC_INTERNAL_GENERICS )
import GHC.Core.Reduction (mkReduction)
import GHC.Core.TyCo.Rep (UnivCoProvenance(PluginProv))
import GHC.Rename.Fixity (lookupFixityRn)
import GHC.Types.Fixity (Fixity(..), defaultFixity)
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 Stock.Override
import Data.Maybe (catMaybes, fromJust, isJust, fromMaybe)
import Data.Traversable (for)
import qualified Data.Monoid as Mon (Alt(..))
import Stock.Trans (MaybeT(..))
import Control.Monad (zipWithM, unless, guard)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef')
import Stock.Type (Stock(..), Stock1(..), Stock2(..))
-- Re-exported (class names only) so @import Stock@ covers every derivable class.
import Data.Functor.Contravariant (Contravariant)
import Data.Functor.Classes (Eq1, Ord1, Show1, Read1, Eq2, Ord2, Show2, Read2)
import Data.Bifunctor (Bifunctor)
import Data.Bifoldable (Bifoldable)
import Control.Category (Category)
import Data.Ix (Ix)
import GHC.Generics (Generic, Generic1)
import Stock.Surface (lowerOverrides)
import Stock.Internal
import Stock.Bounded
import Stock.Eq
import Stock.Ord
import Stock.Semigroup
import Stock.Show
import Stock.Enum
import Stock.Read
import Stock.Functor
import Stock.Applicative
import Stock.Traversable (synthTraversable)
import Stock.TestEquality (synthTestEquality, synthTestCoercion)
import Stock.Bifunctor
import Stock.Generic
import Stock.Classes1

-- | The Stock type-checker plugin. Enable with @-fplugin Stock@.
-- 
-- > {-# options_ghc -fplugin Stock #-}
plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin
  { tcPlugin           = \[String]
_ -> TcPlugin -> Maybe TcPlugin
forall a. a -> Maybe a
Just TcPlugin
stockPlugin
    -- same @-fplugin Stock@ also lowers the @Override@ surface sugar at parse time
  , parsedResultAction = \[String]
_ ModSummary
_ -> ParsedResult -> Hsc ParsedResult
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParsedResult -> Hsc ParsedResult)
-> (ParsedResult -> ParsedResult)
-> ParsedResult
-> Hsc ParsedResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedResult -> ParsedResult
lowerOverrides
  , pluginRecompile    = purePlugin
  }

-- | Present a raw @CtLoc -> TcPluginM (EvTerm, [Ct])@ synthesizer (@Ord@,
-- @Show@, @Read@, @Enum@, @Ix@) as a @Deriver@, so every built-in @Stock@
-- class dispatches uniformly through 'runDeriverAttempt' — exactly like the
-- SDK-native ones (@Eq@, @Bounded@, @Semigroup@, …).
-- Each constructor is paired with its per-field override coercions
-- (@realFieldType ~R modifierType@, 'Refl' when not overridden) so the raw
-- synthesizers can honour @Override@ — using the modifier type for the field's
-- instance and coercing the bound value — exactly as 'matchSOP' does for the
-- SDK derivers.  'Refl' everywhere ⇒ byte-identical Core to before.
viaSynth :: (Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])] -> TcPluginM (EvTerm, [Ct]))
         -> Deriver
viaSynth :: (Class
 -> CtLoc
 -> Type
 -> Type
 -> Coercion
 -> [(DataCon, [Coercion])]
 -> TcPluginM (EvTerm, [Ct]))
-> Deriver
viaSynth Class
-> CtLoc
-> Type
-> Type
-> Coercion
-> [(DataCon, [Coercion])]
-> TcPluginM (EvTerm, [Ct])
f = (Class -> Datatype -> Synth EvTerm) -> Deriver
Deriver \Class
cls Datatype
dt -> (CtLoc -> TcPluginM (EvTerm, [Ct])) -> Synth EvTerm
forall a. (CtLoc -> TcPluginM (a, [Ct])) -> Synth a
synthTc \CtLoc
loc ->
  Class
-> CtLoc
-> Type
-> Type
-> Coercion
-> [(DataCon, [Coercion])]
-> TcPluginM (EvTerm, [Ct])
f Class
cls CtLoc
loc (Datatype -> Type
dtVia Datatype
dt) (Datatype -> Type
dtType Datatype
dt) (Datatype -> Coercion
dtUnwrap Datatype
dt)
    ((Constructor -> (DataCon, [Coercion]))
-> [Constructor] -> [(DataCon, [Coercion])]
forall a b. (a -> b) -> [a] -> [b]
map (\Constructor
c -> (Constructor -> DataCon
conDataCon Constructor
c, Constructor -> [Coercion]
conFieldCos Constructor
c)) (Datatype -> [Constructor]
dtCons Datatype
dt))

stockPlugin :: TcPlugin
stockPlugin :: TcPlugin
stockPlugin = TcPlugin
  { tcPluginInit :: TcPluginM PluginState
tcPluginInit = do
      IORef [String]
seen   <- IO (IORef [String]) -> TcPluginM (IORef [String])
forall a. IO a -> TcPluginM a
tcPluginIO ([String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
newIORef [])
      Maybe TyCon
stock  <- String -> String -> TcPluginM (Maybe TyCon)
lookupTyConMaybe String
"Stock.Type" String
"Stock"
      Maybe TyCon
stock1 <- String -> String -> TcPluginM (Maybe TyCon)
lookupTyConMaybe String
"Stock.Type" String
"Stock1"
      Maybe TyCon
stock2 <- String -> String -> TcPluginM (Maybe TyCon)
lookupTyConMaybe String
"Stock.Type" String
"Stock2"
      Maybe Class
witCls <- String -> String -> TcPluginM (Maybe Class)
lookupClassMaybe String
"Stock.Derive" String
"DeriveStock"
      TyCon
k1Tc   <- Name -> TcPluginM TyCon
tcLookupTyCon Name
k1TyConName
      TyCon
prodTc <- Name -> TcPluginM TyCon
tcLookupTyCon Name
prodTyConName
      TyCon
rTc    <- Module -> OccName -> TcPluginM Name
lookupOrig Module
gHC_INTERNAL_GENERICS (String -> OccName
mkTcOcc String
"R") 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
      GenEnv
gen    <- Maybe TyCon
-> Maybe TyCon
-> Maybe TyCon
-> Maybe Class
-> Class
-> TyCon
-> TyCon
-> TyCon
-> TyCon
-> DataCon
-> TyCon
-> MetaEnv
-> Gen1Env
-> Type
-> Maybe TyCon
-> Maybe TyCon
-> Maybe TyCon
-> Maybe TyCon
-> Maybe TyCon
-> Maybe Class
-> Maybe Class
-> Maybe TyCon
-> Maybe TyCon
-> GenEnv
GenEnv Maybe TyCon
stock Maybe TyCon
stock1 Maybe TyCon
stock2 Maybe Class
witCls
                       (Class
 -> TyCon
 -> TyCon
 -> TyCon
 -> TyCon
 -> DataCon
 -> TyCon
 -> MetaEnv
 -> Gen1Env
 -> Type
 -> Maybe TyCon
 -> Maybe TyCon
 -> Maybe TyCon
 -> Maybe TyCon
 -> Maybe TyCon
 -> Maybe Class
 -> Maybe Class
 -> Maybe TyCon
 -> Maybe TyCon
 -> GenEnv)
-> TcPluginM Class
-> TcPluginM
     (TyCon
      -> TyCon
      -> TyCon
      -> TyCon
      -> DataCon
      -> TyCon
      -> MetaEnv
      -> Gen1Env
      -> Type
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcPluginM Class
tcLookupClass Name
genClassName
                       TcPluginM
  (TyCon
   -> TyCon
   -> TyCon
   -> TyCon
   -> DataCon
   -> TyCon
   -> MetaEnv
   -> Gen1Env
   -> Type
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM TyCon
-> TcPluginM
     (TyCon
      -> TyCon
      -> TyCon
      -> DataCon
      -> TyCon
      -> MetaEnv
      -> Gen1Env
      -> Type
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> TcPluginM TyCon
tcLookupTyCon Name
repTyConName
                       TcPluginM
  (TyCon
   -> TyCon
   -> TyCon
   -> DataCon
   -> TyCon
   -> MetaEnv
   -> Gen1Env
   -> Type
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM TyCon
-> TcPluginM
     (TyCon
      -> TyCon
      -> DataCon
      -> TyCon
      -> MetaEnv
      -> Gen1Env
      -> Type
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> TcPluginM TyCon
tcLookupTyCon Name
u1TyConName
                       TcPluginM
  (TyCon
   -> TyCon
   -> DataCon
   -> TyCon
   -> MetaEnv
   -> Gen1Env
   -> Type
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM TyCon
-> TcPluginM
     (TyCon
      -> DataCon
      -> TyCon
      -> MetaEnv
      -> Gen1Env
      -> Type
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyCon -> TcPluginM TyCon
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyCon
k1Tc
                       TcPluginM
  (TyCon
   -> DataCon
   -> TyCon
   -> MetaEnv
   -> Gen1Env
   -> Type
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM TyCon
-> TcPluginM
     (DataCon
      -> TyCon
      -> MetaEnv
      -> Gen1Env
      -> Type
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyCon -> TcPluginM TyCon
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyCon
prodTc TcPluginM
  (DataCon
   -> TyCon
   -> MetaEnv
   -> Gen1Env
   -> Type
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM DataCon
-> TcPluginM
     (TyCon
      -> MetaEnv
      -> Gen1Env
      -> Type
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DataCon -> TcPluginM DataCon
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DataCon] -> DataCon
forall a. HasCallStack => [a] -> a
head (TyCon -> [DataCon]
tyConDataCons TyCon
prodTc))
                       TcPluginM
  (TyCon
   -> MetaEnv
   -> Gen1Env
   -> Type
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM TyCon
-> TcPluginM
     (MetaEnv
      -> Gen1Env
      -> Type
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> TcPluginM TyCon
tcLookupTyCon Name
sumTyConName
                       TcPluginM
  (MetaEnv
   -> Gen1Env
   -> Type
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM MetaEnv
-> TcPluginM
     (Gen1Env
      -> Type
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TcPluginM MetaEnv
lookupMetaEnv
                       TcPluginM
  (Gen1Env
   -> Type
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM Gen1Env
-> TcPluginM
     (Type
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TcPluginM Gen1Env
lookupGen1Env
                       TcPluginM
  (Type
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM Type
-> TcPluginM
     (Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
forall a b. TcPluginM (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> TcPluginM Type
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyCon -> Type
mkTyConTy TyCon
rTc)
                       TcPluginM
  (Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM (Maybe TyCon)
-> TcPluginM
     (Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
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
"Override"
                       TcPluginM
  (Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM (Maybe TyCon)
-> TcPluginM
     (Maybe TyCon
      -> Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
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
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM (Maybe TyCon)
-> TcPluginM
     (Maybe TyCon
      -> Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
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"
                       TcPluginM
  (Maybe TyCon
   -> Maybe TyCon
   -> Maybe Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM (Maybe TyCon)
-> TcPluginM
     (Maybe TyCon
      -> Maybe Class
      -> Maybe Class
      -> Maybe TyCon
      -> Maybe TyCon
      -> GenEnv)
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 Class
   -> Maybe Class
   -> Maybe TyCon
   -> Maybe TyCon
   -> GenEnv)
-> TcPluginM (Maybe TyCon)
-> TcPluginM
     (Maybe Class
      -> Maybe Class -> Maybe TyCon -> Maybe TyCon -> GenEnv)
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 Class
   -> Maybe Class -> Maybe TyCon -> Maybe TyCon -> GenEnv)
-> TcPluginM (Maybe Class)
-> TcPluginM (Maybe Class -> Maybe TyCon -> Maybe TyCon -> GenEnv)
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 Class)
lookupClassMaybe String
"Stock.Derive" String
"DeriveStock1"
                       TcPluginM (Maybe Class -> Maybe TyCon -> Maybe TyCon -> GenEnv)
-> TcPluginM (Maybe Class)
-> TcPluginM (Maybe TyCon -> Maybe TyCon -> GenEnv)
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 Class)
lookupClassMaybe String
"Stock.Derive" String
"DeriveStock2"
                       TcPluginM (Maybe TyCon -> Maybe TyCon -> GenEnv)
-> TcPluginM (Maybe TyCon) -> TcPluginM (Maybe TyCon -> GenEnv)
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
"Override2"
                       TcPluginM (Maybe TyCon -> GenEnv)
-> TcPluginM (Maybe TyCon) -> TcPluginM GenEnv
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
"Override1"
      PluginState -> TcPluginM PluginState
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IORef [String] -> GenEnv -> PluginState
PluginState IORef [String]
seen GenEnv
gen)
  , tcPluginSolve :: PluginState -> TcPluginSolver
tcPluginSolve = PluginState -> TcPluginSolver
solveStock
  , tcPluginRewrite :: PluginState -> UniqFM TyCon TcPluginRewriter
tcPluginRewrite = \PluginState
st -> [(TyCon, TcPluginRewriter)] -> UniqFM TyCon TcPluginRewriter
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM
      [ (GenEnv -> TyCon
geRepTc (PluginState -> GenEnv
psGen PluginState
st),          GenEnv -> TcPluginRewriter
rewriteRep  (PluginState -> GenEnv
psGen PluginState
st))
      , (Gen1Env -> TyCon
g1RepTc (GenEnv -> Gen1Env
geGen1 (PluginState -> GenEnv
psGen PluginState
st)), GenEnv -> TcPluginRewriter
rewriteRep1 (PluginState -> GenEnv
psGen PluginState
st)) ]
  , tcPluginStop :: PluginState -> TcPluginM ()
tcPluginStop = \PluginState
_ -> () -> TcPluginM ()
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  }

-- | Look up a 'TyCon' by module and name, returning 'Nothing' if the module
-- is not in scope — so the plugin stays inert instead of erroring when our
-- @Stock@ wrapper isn't imported.
solveStock :: PluginState -> EvBindsVar -> [Ct] -> [Ct] -> TcPluginM TcPluginSolveResult
solveStock :: PluginState -> TcPluginSolver
solveStock PluginState
st EvBindsVar
_ev [Ct]
_given [Ct]
wanted = do
  [Attempt]
results <- [Ct] -> (Ct -> TcPluginM Attempt) -> TcPluginM [Attempt]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Ct]
wanted (PluginState -> Ct -> TcPluginM Attempt
trySolve PluginState
st)
  let solutions :: [(EvTerm, Ct)]
solutions  = [Maybe (EvTerm, Ct)] -> [(EvTerm, Ct)]
forall a. [Maybe a] -> [a]
catMaybes [ Maybe (EvTerm, Ct)
s | (Maybe (EvTerm, Ct)
s, [Ct]
_, [Ct]
_) <- [Attempt]
results ]
      newWanteds :: [Ct]
newWanteds = [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat    [ [Ct]
w | (Maybe (EvTerm, Ct)
_, [Ct]
w, [Ct]
_) <- [Attempt]
results ]
      insolubles :: [Ct]
insolubles = [[Ct]] -> [Ct]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat    [ [Ct]
i | (Maybe (EvTerm, Ct)
_, [Ct]
_, [Ct]
i) <- [Attempt]
results ]
  TcPluginSolveResult -> TcPluginM TcPluginSolveResult
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TcPluginSolveResult
    { tcPluginInsolubleCts :: [Ct]
tcPluginInsolubleCts = [Ct]
insolubles
    , tcPluginSolvedCts :: [(EvTerm, Ct)]
tcPluginSolvedCts    = [(EvTerm, Ct)]
solutions
    , tcPluginNewCts :: [Ct]
tcPluginNewCts       = [Ct]
newWanteds
    }

-- | Result of attempting one constraint: an optional solution, any new wanted
-- constraints to emit, and any constraints we declare insoluble (after
-- reporting a custom error for them).
trySolve :: PluginState -> Ct -> TcPluginM Attempt
trySolve :: PluginState -> Ct -> TcPluginM Attempt
trySolve PluginState
st Ct
ct =
  case Type -> Pred
classifyPredType (Ct -> Type
ctPred Ct
ct) of
    -- unary class over a type/constructor; @clsArgs@ may carry a leading
    -- (invisible) kind argument (poly-kinded classes like @Generic1@), so the
    -- type we act on is the /last/ argument.
    ClassPred Class
cls ([Type] -> [Type]
forall a. [a] -> [a]
reverse -> (Type
wrappedTy : [Type]
_)) ->
      Attempt -> Maybe Attempt -> Attempt
forall a. a -> Maybe a -> a
fromMaybe (Maybe (EvTerm, Ct)
forall a. Maybe a
Nothing, [], [])
        (Maybe Attempt -> Attempt)
-> TcPluginM (Maybe Attempt) -> TcPluginM Attempt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Solver
-> PluginState -> Ct -> Class -> Type -> TcPluginM (Maybe Attempt)
runSolver ([Solver] -> Solver
forall a. Monoid a => [a] -> a
mconcat [Solver
stockSolver, Solver
stock1Solver, Solver
stock2Solver]) PluginState
st Ct
ct Class
cls Type
wrappedTy
    Pred
_ -> Attempt -> TcPluginM Attempt
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (EvTerm, Ct)
forall a. Maybe a
Nothing, [], [])

-- | @Cls (Stock T)@ — build the dictionary from @T@'s constructors.
stockSolver :: Solver
stockSolver :: Solver
stockSolver = (PluginState -> Ct -> Class -> Type -> TcPluginM (Maybe Attempt))
-> Solver
Solver \PluginState
st Ct
ct Class
cls Type
wrappedTy -> do
  -- @Stock (Override T cfg)@ takes priority; its decode emits per-cell coercion
  -- wanteds (@extraCts@) that ride alongside the deriver's own.
  Maybe (Either SDoc (Repr, [Ct]))
mOver <- GenEnv
-> CtLoc -> Type -> TcPluginM (Maybe (Either SDoc (Repr, [Ct])))
mkOverrideRepr (PluginState -> GenEnv
psGen PluginState
st) (Ct -> CtLoc
ctLoc Ct
ct) Type
wrappedTy
  case Maybe (Either SDoc (Repr, [Ct]))
mOver of
    Just (Left SDoc
err)               -> 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
<$> PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct SDoc
err
    Just (Right (Repr
repr, [Ct]
extraCts)) -> Attempt -> Maybe Attempt
forall a. a -> Maybe a
Just (Attempt -> Maybe Attempt)
-> (Attempt -> Attempt) -> Attempt -> Maybe Attempt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ct] -> Attempt -> Attempt
addCts [Ct]
extraCts (Attempt -> Maybe Attempt)
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PluginState -> Ct -> Class -> Type -> Repr -> TcPluginM Attempt
dispatchStock PluginState
st Ct
ct Class
cls Type
wrappedTy Repr
repr
    Maybe (Either SDoc (Repr, [Ct]))
Nothing -> case Maybe TyCon -> Type -> Maybe Repr
mkRepr (GenEnv -> Maybe TyCon
geStock (PluginState -> GenEnv
psGen PluginState
st)) Type
wrappedTy of
      Maybe Repr
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 Repr
repr -> 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
<$> PluginState -> Ct -> Class -> Type -> Repr -> TcPluginM Attempt
dispatchStock PluginState
st Ct
ct Class
cls Type
wrappedTy Repr
repr

-- | Append extra wanted constraints to a solve attempt.
addCts :: [Ct] -> Attempt -> Attempt
addCts :: [Ct] -> Attempt -> Attempt
addCts [Ct]
extra (Maybe (EvTerm, Ct)
sol, [Ct]
ws, [Ct]
ins) = (Maybe (EvTerm, Ct)
sol, [Ct]
extra [Ct] -> [Ct] -> [Ct]
forall a. [a] -> [a] -> [a]
++ [Ct]
ws, [Ct]
ins)

-- | Dispatch a recognised @Stock@(-@Override@) representation to the right
-- built-in deriver (or a discovered companion via 'tryWitness').
dispatchStock :: PluginState -> Ct -> Class -> Type -> Repr -> TcPluginM Attempt
dispatchStock :: PluginState -> Ct -> Class -> Type -> Repr -> TcPluginM Attempt
dispatchStock PluginState
st Ct
ct Class
cls Type
wrappedTy Repr
repr
      | Repr -> Bool
reprUnpacked Repr
repr =
          PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: cannot derive via Stock for a type whose"
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"constructors have UNPACKed or unboxed strict fields"
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(their runtime representation differs from their source type)"
            SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                       SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
      | Bool
otherwise = do
          let innerTy :: Type
innerTy = Repr -> Type
rInner Repr
repr
              co :: Coercion
co      = Repr -> Coercion
rCo Repr
repr
          case OccName -> String
occNameString (Name -> OccName
nameOccName (Class -> Name
className Class
cls)) of
            String
"Eq" -> Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt Deriver
eqDeriver Ct
ct Class
cls (Type -> Repr -> Datatype
toDatatype Type
wrappedTy Repr
repr)
            String
"Ord"  -> Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt ((Class
 -> CtLoc
 -> Type
 -> Type
 -> Coercion
 -> [(DataCon, [Coercion])]
 -> TcPluginM (EvTerm, [Ct]))
-> Deriver
viaSynth Class
-> CtLoc
-> Type
-> Type
-> Coercion
-> [(DataCon, [Coercion])]
-> TcPluginM (EvTerm, [Ct])
synthOrd)  Ct
ct Class
cls (Type -> Repr -> Datatype
toDatatype Type
wrappedTy Repr
repr)
            String
"Show" -> Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt ((Class
 -> CtLoc
 -> Type
 -> Type
 -> Coercion
 -> [(DataCon, [Coercion])]
 -> TcPluginM (EvTerm, [Ct]))
-> Deriver
viaSynth Class
-> CtLoc
-> Type
-> Type
-> Coercion
-> [(DataCon, [Coercion])]
-> TcPluginM (EvTerm, [Ct])
synthShow) Ct
ct Class
cls (Type -> Repr -> Datatype
toDatatype Type
wrappedTy Repr
repr)
            String
"Read" -> Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt ((Class
 -> CtLoc
 -> Type
 -> Type
 -> Coercion
 -> [(DataCon, [Coercion])]
 -> TcPluginM (EvTerm, [Ct]))
-> Deriver
viaSynth Class
-> CtLoc
-> Type
-> Type
-> Coercion
-> [(DataCon, [Coercion])]
-> TcPluginM (EvTerm, [Ct])
synthRead) Ct
ct Class
cls (Type -> Repr -> Datatype
toDatatype Type
wrappedTy Repr
repr)
            String
"Enum"
              | Repr -> Bool
reprIsEnum Repr
repr -> Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt ((Class
 -> CtLoc
 -> Type
 -> Type
 -> Coercion
 -> [(DataCon, [Coercion])]
 -> TcPluginM (EvTerm, [Ct]))
-> Deriver
viaSynth Class
-> CtLoc
-> Type
-> Type
-> Coercion
-> [(DataCon, [Coercion])]
-> TcPluginM (EvTerm, [Ct])
synthEnum) Ct
ct Class
cls (Type -> Repr -> Datatype
toDatatype Type
wrappedTy Repr
repr)
              | Bool
otherwise ->
                  PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
                    String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: deriving Enum via Stock requires an"
                    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"enumeration (constructors without fields)"
                    SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                               SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
            String
"Ix"
              | Repr -> Bool
reprIsEnum Repr
repr -> Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt ((Class
 -> CtLoc
 -> Type
 -> Type
 -> Coercion
 -> [(DataCon, [Coercion])]
 -> TcPluginM (EvTerm, [Ct]))
-> Deriver
viaSynth Class
-> CtLoc
-> Type
-> Type
-> Coercion
-> [(DataCon, [Coercion])]
-> TcPluginM (EvTerm, [Ct])
synthIx) Ct
ct Class
cls (Type -> Repr -> Datatype
toDatatype Type
wrappedTy Repr
repr)
              | Repr -> Bool
reprSingleCon Repr
repr -> Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt ((Class
 -> CtLoc
 -> Type
 -> Type
 -> Coercion
 -> [(DataCon, [Coercion])]
 -> TcPluginM (EvTerm, [Ct]))
-> Deriver
viaSynth Class
-> CtLoc
-> Type
-> Type
-> Coercion
-> [(DataCon, [Coercion])]
-> TcPluginM (EvTerm, [Ct])
synthIxProduct) Ct
ct Class
cls (Type -> Repr -> Datatype
toDatatype Type
wrappedTy Repr
repr)
              | Bool
otherwise ->
                  PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
                    String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: deriving Ix via Stock requires an enumeration"
                    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"or a single-constructor product"
                    SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                               SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
            String
"Bounded"
              | Repr -> Bool
reprIsEnum Repr
repr Bool -> Bool -> Bool
|| Repr -> Bool
reprSingleCon Repr
repr ->
                  Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt Deriver
boundedDeriver Ct
ct Class
cls (Type -> Repr -> Datatype
toDatatype Type
wrappedTy Repr
repr)
              | Bool
otherwise ->
                  PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
                    String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: deriving Bounded via Stock requires an"
                    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"enumeration or a single-constructor type"
                    SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                               SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
            String
"Generic" -> do
              EvTerm
ev <- GenEnv -> Type -> Type -> Coercion -> [ConInfo] -> TcPluginM EvTerm
synthGeneric (PluginState -> GenEnv
psGen PluginState
st) Type
wrappedTy Type
innerTy Coercion
co (Repr -> [ConInfo]
rCons Repr
repr)
              Attempt -> TcPluginM Attempt
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, Ct) -> Maybe (EvTerm, Ct)
forall a. a -> Maybe a
Just (EvTerm
ev, Ct
ct), [], [])
            String
"Semigroup"
              | Repr -> Bool
reprSingleCon Repr
repr -> Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt Deriver
semigroupDeriver Ct
ct Class
cls (Type -> Repr -> Datatype
toDatatype Type
wrappedTy Repr
repr)
              | Bool
otherwise -> PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: Semigroup via Stock requires a single-constructor"
                  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(product) type" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
            String
"Monoid"
              | Repr -> Bool
reprSingleCon Repr
repr -> Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt
runDeriverAttempt Deriver
monoidDeriver Ct
ct Class
cls (Type -> Repr -> Datatype
toDatatype Type
wrappedTy Repr
repr)
              | Bool
otherwise -> PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
                  String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: Monoid via Stock requires a single-constructor"
                  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(product) type" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
            String
other -> do
              -- not a built-in: try a companion-provided @instance DeriveStock Cls@
              Maybe Attempt
mw <- PluginState -> Ct -> Class -> Datatype -> TcPluginM (Maybe Attempt)
tryWitness PluginState
st Ct
ct Class
cls (Type -> Repr -> Datatype
toDatatype Type
wrappedTy Repr
repr)
              case Maybe Attempt
mw of
                Just Attempt
attempt -> Attempt -> TcPluginM Attempt
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attempt
attempt
                Maybe Attempt
Nothing ->
                  PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
                    String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: deriving" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
other)
                    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"via Stock is not supported, and no"
                    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"'instance DeriveStock' was found for it"
                    SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                               SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
-- | @Cls (Stock1 F)@ — a class over a (poly-kinded) type constructor.
stock1Solver :: Solver
stock1Solver :: Solver
stock1Solver = (PluginState -> Ct -> Class -> Type -> TcPluginM (Maybe Attempt))
-> Solver
Solver \PluginState
st Ct
ct Class
cls Type
wrappedTy ->
  case (GenEnv -> Maybe TyCon
geStock1 (PluginState -> GenEnv
psGen PluginState
st), Type -> Maybe TyCon
tyConAppTyCon_maybe Type
wrappedTy) of
    (Just TyCon
ourTc, Just TyCon
stTc) | TyCon
stTc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ourTc
      , [Type
_, Type
f] <- HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy
      -- TestEquality/TestCoercion handle GADTs directly (whose constructors
      -- carry coercion fields that trip 'dcUnpacked'); let them through.
      , OccName -> String
occNameString (Name -> OccName
nameOccName (Class -> Name
className Class
cls)) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"TestEquality", String
"TestCoercion"]
      , Bool -> (TyCon -> Bool) -> Maybe TyCon -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any DataCon -> Bool
dcUnpacked ([DataCon] -> Bool) -> (TyCon -> [DataCon]) -> TyCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> [DataCon]
tyConDataCons) (Type -> Maybe TyCon
tyConAppTyCon_maybe Type
f) ->
          (Attempt -> Maybe Attempt)
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attempt -> Maybe Attempt
forall a. a -> Maybe a
Just (TcPluginM Attempt -> TcPluginM (Maybe Attempt))
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> a -> b
$ PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: cannot derive via Stock1 for a type whose"
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"constructors have UNPACKed or unboxed strict fields"
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(their runtime representation differs from their source type)"
            SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                       SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
    (Just TyCon
ourTc, Just TyCon
stTc) | TyCon
stTc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ourTc
      , [Type
_, Type
f] <- HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy ->
          (Attempt -> Maybe Attempt)
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attempt -> Maybe Attempt
forall a. a -> Maybe a
Just (TcPluginM Attempt -> TcPluginM (Maybe Attempt))
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> a -> b
$
          let runStock1 :: (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synth = do
                Maybe (EvTerm, [Ct])
m <- GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synth (PluginState -> GenEnv
psGen PluginState
st) Class
cls (Ct -> CtLoc
ctLoc Ct
ct) Type
wrappedTy Type
f
                case Maybe (EvTerm, [Ct])
m of
                  Just (EvTerm
ev, [Ct]
ws) -> Attempt -> TcPluginM Attempt
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, Ct) -> Maybe (EvTerm, Ct)
forall a. a -> Maybe a
Just (EvTerm
ev, Ct
ct), [Ct]
ws, [])
                  Maybe (EvTerm, [Ct])
Nothing ->
                    PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
                      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: deriving" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls)
                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"via Stock1 supports only covariant fields (the"
                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"parameter, constants, or a functor applied to it)"
                      SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
          in case OccName -> String
occNameString (Name -> OccName
nameOccName (Class -> Name
className Class
cls)) of
               String
"Functor"       -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthFunctor
               String
"Applicative"   -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthApplicative
               String
"Foldable"      -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthFoldable
               String
"Contravariant" -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthContravariant
               String
"Generic1"      -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthGeneric1
               String
"Eq1"           -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthEq1
               String
"Ord1"          -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthOrd1
               String
"Show1"         -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthShow1
               String
"Read1"         -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthRead1
               -- The instance IS synthesized (and usable at @Stock1 F@, or on your
               -- type via @traverse g = fmap unStock1 . traverse g . Stock1@); only
               -- the DerivingVia coercion onto @F@ is impossible — @traverse@'s
               -- result @f (t b)@ puts the wrapper under an abstract applicative
               -- (nominal role), so a bare @deriving via Stock1@ still fails there.
               String
"Traversable"   -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthTraversable
               String
"TestEquality"  -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthTestEquality
               String
"TestCoercion"  -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock1 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthTestCoercion
               String
_ -> do
                 -- not a built-in: try a companion @instance DeriveStock1 Cls@
                 Maybe Attempt
mw <- PluginState
-> Ct -> Class -> Type -> Type -> TcPluginM (Maybe Attempt)
tryWitness1 PluginState
st Ct
ct Class
cls Type
wrappedTy Type
f
                 case Maybe Attempt
mw of
                   Just Attempt
attempt -> Attempt -> TcPluginM Attempt
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attempt
attempt
                   Maybe Attempt
Nothing -> PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
                     String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: deriving" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls))
                     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"via Stock1 is not supported, and no"
                     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"'instance DeriveStock1' was found for it"
                     SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
    -- @Cls (Stock1 F a..)@ /fully applied/ (kind Type): Stock1 is a
    -- transparent newtype, so solve from @Cls (F a..)@ and coerce.
    -- This discharges the quantified superclass @forall a. Cls a =>
    -- Cls (Stock1 F a)@ that lifted classes (Eq1, NFData1, Hashable1,
    -- …) carry, straight from the user's own @Cls (F a)@ instance,
    -- for any class.
    (Just TyCon
ourTc, Just TyCon
stTc) | TyCon
stTc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ourTc
      , (Type
_ : Type
f : rest :: [Type]
rest@(Type
_ : [Type]
_)) <- HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy ->
          (Attempt -> Maybe Attempt)
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attempt -> Maybe Attempt
forall a. a -> Maybe a
Just (TcPluginM Attempt -> TcPluginM (Maybe Attempt))
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> a -> b
$ do
            -- @f@ may itself be @Override1 cfg realF@; peel it so the sub-wanted
            -- lands on the user's real @Cls (realF a..)@ instance, not the
            -- instance-less @Override1@ wrapper.  (One univ coercion spans both hops.)
            let realF :: Type
realF   = (Type, Maybe [Type]) -> Type
forall a b. (a, b) -> a
fst (OvTcs -> Type -> (Type, Maybe [Type])
peelOverride1With (String -> GenEnv -> OvTcs
ovTcsGen String
"Override1" (PluginState -> GenEnv
psGen PluginState
st)) Type
f)
                innerTy :: Type
innerTy = Type -> [Type] -> Type
mkAppTys Type
realF [Type]
rest                      -- F a..
                -- @Cls (F a..) ~R Cls (Stock1 F a..)@, plugin-asserted: the dicts
                -- share a representation (Stock1 is a newtype).  We assert it
                -- directly rather than lift the newtype coercion through the class
                -- TyCon — whose parameter is /nominal/, so a representational arg
                -- coercion there is role-incorrect (-dcore-lint rejects it).
                dictCo :: Coercion
dictCo = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo (String -> UnivCoProvenance
PluginProv String
"stock") Role
Representational
                           (Class -> [Type] -> Type
mkClassPred Class
cls [Type
innerTy]) (Class -> [Type] -> Type
mkClassPred Class
cls [Type
wrappedTy])
            CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted (Ct -> CtLoc
ctLoc Ct
ct) (Class -> [Type] -> Type
mkClassPred Class
cls [Type
innerTy])
            Attempt -> TcPluginM Attempt
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, Ct) -> Maybe (EvTerm, Ct)
forall a. a -> Maybe a
Just (EvExpr -> EvTerm
EvExpr (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev) Coercion
dictCo), Ct
ct), [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev], [])
    (Maybe TyCon, Maybe TyCon)
_ -> 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

-- | @Cls (Stock2 P)@ — a class over a (poly-kinded) two-parameter constructor.
stock2Solver :: Solver
stock2Solver :: Solver
stock2Solver = (PluginState -> Ct -> Class -> Type -> TcPluginM (Maybe Attempt))
-> Solver
Solver \PluginState
st Ct
ct Class
cls Type
wrappedTy ->
  case (GenEnv -> Maybe TyCon
geStock2 (PluginState -> GenEnv
psGen PluginState
st), Type -> Maybe TyCon
tyConAppTyCon_maybe Type
wrappedTy) of
    (Just TyCon
ourTc, Just TyCon
stTc) | TyCon
stTc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ourTc
      , [Type
_, Type
_, Type
p] <- HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy
      , Bool -> (TyCon -> Bool) -> Maybe TyCon -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any DataCon -> Bool
dcUnpacked ([DataCon] -> Bool) -> (TyCon -> [DataCon]) -> TyCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> [DataCon]
tyConDataCons) (Type -> Maybe TyCon
tyConAppTyCon_maybe Type
p) ->
          (Attempt -> Maybe Attempt)
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attempt -> Maybe Attempt
forall a. a -> Maybe a
Just (TcPluginM Attempt -> TcPluginM (Maybe Attempt))
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> a -> b
$ PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: cannot derive via Stock2 for a type whose"
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"constructors have UNPACKed or unboxed strict fields"
            SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                       SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
    (Just TyCon
ourTc, Just TyCon
stTc) | TyCon
stTc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ourTc
      , [Type
_, Type
_, Type
p] <- HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy ->
          (Attempt -> Maybe Attempt)
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attempt -> Maybe Attempt
forall a. a -> Maybe a
Just (TcPluginM Attempt -> TcPluginM (Maybe Attempt))
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> a -> b
$
          let runStock2 :: (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock2 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synth = do
                Maybe (EvTerm, [Ct])
m <- GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synth (PluginState -> GenEnv
psGen PluginState
st) Class
cls (Ct -> CtLoc
ctLoc Ct
ct) Type
wrappedTy Type
p
                case Maybe (EvTerm, [Ct])
m of
                  Just (EvTerm
ev, [Ct]
ws) -> Attempt -> TcPluginM Attempt
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, Ct) -> Maybe (EvTerm, Ct)
forall a. a -> Maybe a
Just (EvTerm
ev, Ct
ct), [Ct]
ws, [])
                  Maybe (EvTerm, [Ct])
Nothing ->
                    PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
                      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: deriving" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls)
                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"via Stock2 supports only covariant fields in the last"
                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"two parameters (each parameter, constants, or a functor"
                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"applied to one)"
                      SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
          in case OccName -> String
occNameString (Name -> OccName
nameOccName (Class -> Name
className Class
cls)) of
               String
"Bifunctor"  -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock2 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthBifunctor
               String
"Bifoldable" -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock2 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthBifoldable
               String
"Eq2"        -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock2 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthEq2
               String
"Ord2"       -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock2 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthOrd2
               String
"Show2"      -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock2 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthShow2
               String
"Read2"      -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock2 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthRead2
               String
"Category"   -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock2 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthCategory
               -- synthesized at Stock2 (usable directly / via the one-liner
               -- @bitraverse f g = fmap unStock2 . bitraverse f g . Stock2@); a
               -- bare @deriving via Stock2@ still fails — bitraverse's result
               -- @f (t c d)@ puts the wrapper under an abstract applicative.
               String
"Bitraversable" -> (GenEnv
 -> Class
 -> CtLoc
 -> Type
 -> Type
 -> TcPluginM (Maybe (EvTerm, [Ct])))
-> TcPluginM Attempt
runStock2 GenEnv
-> Class
-> CtLoc
-> Type
-> Type
-> TcPluginM (Maybe (EvTerm, [Ct]))
synthBitraversable
               String
_ -> do
                 -- not a built-in: try a companion @instance DeriveStock2 Cls@
                 Maybe Attempt
mw <- PluginState
-> Ct -> Class -> Type -> Type -> TcPluginM (Maybe Attempt)
tryWitness2 PluginState
st Ct
ct Class
cls Type
wrappedTy Type
p
                 case Maybe Attempt
mw of
                   Just Attempt
attempt -> Attempt -> TcPluginM Attempt
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Attempt
attempt
                   Maybe Attempt
Nothing -> PluginState -> Ct -> SDoc -> TcPluginM Attempt
notImplemented PluginState
st Ct
ct (SDoc -> TcPluginM Attempt) -> SDoc -> TcPluginM Attempt
forall a b. (a -> b) -> a -> b
$
                     String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stock: deriving" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls))
                     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"via Stock2 is not supported, and no"
                     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"'instance DeriveStock2' was found for it"
                     SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in the derived instance for"
                                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
cls) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
wrappedTy))
    -- @Cls (Stock2 P a..)@ /further applied/: Stock2 is a transparent
    -- newtype, so solve from @Cls (P a..)@ and coerce (discharges the
    -- quantified superclass @forall a. Cls a => Cls1 (Stock2 P a)@ of
    -- bi-lifted classes from the user's own @Cls1 (P a)@ instance).
    (Just TyCon
ourTc, Just TyCon
stTc) | TyCon
stTc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
ourTc
      , (Type
_ : Type
_ : Type
p : rest :: [Type]
rest@(Type
_ : [Type]
_)) <- HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
wrappedTy ->
          (Attempt -> Maybe Attempt)
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> TcPluginM a -> TcPluginM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Attempt -> Maybe Attempt
forall a. a -> Maybe a
Just (TcPluginM Attempt -> TcPluginM (Maybe Attempt))
-> TcPluginM Attempt -> TcPluginM (Maybe Attempt)
forall a b. (a -> b) -> a -> b
$ do
            -- as in the Stock1 passthrough: peel an @Override2 cfg realP@ wrapper
            -- so the sub-wanted lands on the user's real @Cls (realP a..)@ instance.
            let realP :: Type
realP   = (Type, Maybe [Type]) -> Type
forall a b. (a, b) -> a
fst (OvTcs -> Type -> (Type, Maybe [Type])
peelOverride2With (String -> GenEnv -> OvTcs
ovTcsGen String
"Override2" (PluginState -> GenEnv
psGen PluginState
st)) Type
p)
                innerTy :: Type
innerTy = Type -> [Type] -> Type
mkAppTys Type
realP [Type]
rest                     -- P a..
                -- as in the Stock1 passthrough: assert @Cls (P a..) ~R
                -- Cls (Stock2 P a..)@ directly (role-correct under -dcore-lint),
                -- rather than lift the newtype coercion through the nominal class param.
                dictCo :: Coercion
dictCo = UnivCoProvenance -> Role -> Type -> Type -> Coercion
mkStockCo (String -> UnivCoProvenance
PluginProv String
"stock") Role
Representational
                           (Class -> [Type] -> Type
mkClassPred Class
cls [Type
innerTy]) (Class -> [Type] -> Type
mkClassPred Class
cls [Type
wrappedTy])
            CtEvidence
ev <- CtLoc -> Type -> TcPluginM CtEvidence
newWanted (Ct -> CtLoc
ctLoc Ct
ct) (Class -> [Type] -> Type
mkClassPred Class
cls [Type
innerTy])
            Attempt -> TcPluginM Attempt
forall a. a -> TcPluginM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((EvTerm, Ct) -> Maybe (EvTerm, Ct)
forall a. a -> Maybe a
Just (EvExpr -> EvTerm
EvExpr (EvExpr -> Coercion -> EvExpr
forall b. Expr b -> Coercion -> Expr b
Cast (HasDebugCallStack => CtEvidence -> EvExpr
CtEvidence -> EvExpr
ctEvExpr CtEvidence
ev) Coercion
dictCo), Ct
ct), [CtEvidence -> Ct
mkNonCanonical CtEvidence
ev], [])
    (Maybe TyCon, Maybe TyCon)
_ -> 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

-- | Report a custom error for a constraint and mark it insoluble, so the user
-- sees exactly why synthesis failed instead of a generic "No instance".  The
-- message is reported at most once (the solver may retry the same constraint).