stock (empty) → 0.1.0.0

raw patch · 33 files changed

+8536/−0 lines, 33 filesdep +basedep +ghcdep +inspection-testing

Dependencies added: base, ghc, inspection-testing, stock, transformers

Files

• CHANGELOG.md +38/−0
• LICENSE +29/−0
• README.md +183/−0
• bench/Bench.hs +87/−0
• bench/Configs.hs +68/−0
• examples/Main.hs +62/−0
• examples/QualOverride.hs +32/−0
• inspection/Inspection.hs +207/−0
• plugin/Stock.hs +488/−0
• plugin/Stock/Applicative.hs +188/−0
• plugin/Stock/Bifunctor.hs +992/−0
• plugin/Stock/Bounded.hs +35/−0
• plugin/Stock/Classes1.hs +436/−0
• plugin/Stock/Compat.hs +44/−0
• plugin/Stock/Derive.hs +369/−0
• plugin/Stock/Enum.hs +343/−0
• plugin/Stock/Eq.hs +154/−0
• plugin/Stock/Functor.hs +323/−0
• plugin/Stock/Generic.hs +387/−0
• plugin/Stock/Internal.hs +1463/−0
• plugin/Stock/Ord.hs +230/−0
• plugin/Stock/Override.hs +143/−0
• plugin/Stock/Read.hs +92/−0
• plugin/Stock/Semigroup.hs +85/−0
• plugin/Stock/Show.hs +164/−0
• plugin/Stock/Surface.hs +164/−0
• plugin/Stock/TestEquality.hs +122/−0
• plugin/Stock/Trans.hs +88/−0
• plugin/Stock/Traversable.hs +166/−0
• src/Stock/Type.hs +34/−0
• stock.cabal +196/−0
• test/Spec.hs +1076/−0
• test/Twin.hs +48/−0

@@ -0,0 +1,38 @@+# Changelog++## 0.1.0.0++Initial release.++* A GHC type-checker plugin that synthesizes class instances for the+  `Stock` / `Stock1` / `Stock2` newtype wrappers, used through `DerivingVia`+  — no `Generic`, no hand-written boilerplate.+* Built-in classes — `Stock`: `Eq`, `Ord`, `Show`, `Read`, `Semigroup`,+  `Monoid`, `Enum`, `Bounded`, `Ix`, `Generic`; `Stock1`: `Functor`,+  `Contravariant`, `Foldable`, `Applicative`, `Generic1`, `Eq1`, `Ord1`,+  `Show1`, `Read1`, `Traversable`, `TestEquality`, `TestCoercion`;+  `Stock2`: `Bifunctor`, `Bifoldable`,+  `Eq2`, `Ord2`, `Show2`, `Read2`, `Category`, `Bitraversable`.+  `Traversable`/`Bitraversable` are synthesized at the wrapper and used+  directly or via the one-liner `traverse g = fmap unStock1 . traverse g+  . Stock1` (a bare `deriving via` can't coerce them onto your type — the+  result `f (t b)` puts the wrapper under an abstract applicative).+* Extensible: satellite packages add new classes with no configuration+  change, via `DeriveStock` instances on the `Stock.Derive` SDK.+* Per-field deriving modifiers via `Stock.Override`: `deriving C via Stock+  (Override T cfg)` (or the type-first synonym `Overriding T cfg`) rewrites+  individual fields' types during synthesis (per-field `DerivingVia`,+  zero-cost). Fields are addressed by name, type, or position (`At`); each+  modifier is pinned (`Sum Int`) or broadcast to the field's own type (`Sum`).+  The same `-fplugin Stock` also lowers a lowercase surface —+  `Override T [ x via Sum, C at 0 via Product ]` — to that marker form at+  parse time.+* Synthesized instances verified against GHC's stock-derived twins and+  benchmarked to identical performance; all evidence passes `-dcore-lint`.+  `Eq`/`Ord`/`Enum`/`Functor`/`Bounded`/`Foldable` optimise to+  byte-identical Core (machine-checked with `inspection-testing`);+  `Traversable`/`Bitraversable` are byte-identical to the natural+  hand-written definition. `Read` (and `Read1`) build `readPrec` as GHC's+  derived `Read` does, so they are byte-faithful including the order of+  ambiguous infix parses.+* Tested on GHC 9.6, 9.8, 9.10, 9.12 and 9.14 (`stock-deepseq`: 9.8+).

@@ -0,0 +1,29 @@+Copyright (c) 2026, Baldur Blondal++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.++    * Neither the name of Baldur Blondal nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,183 @@+# stock++Constraint solving plugin that enables extensible, composable deriving+without `GHC.Generics`.++It enables deriving through a `Stock(1,2)` newtype that the plugin+generates instances for at compile-time: `Cls (Stock A)`. This+synthesises class instances directly in GHC Core, same as+hand-written, with no `Generic` deriving.++The classes each wrapper synthesises:+++ `Stock`: `Eq`, `Ord`, `Show`, `Read`, `Semigroup`, `Monoid`, `Enum`, `Bounded`, `Ix`, `Generic` (that's right)++ `Stock1`: `Functor` / `Contravariant`, `Foldable`, `Applicative`, `Generic1`, `Eq1`, `Ord1`, `Show1`, `Read1`, `Traversable`†++ `Stock2`: `Bifunctor`, `Bifoldable`, `Eq2`, `Ord2`, `Show2`, `Read2`, `Category`, `Bitraversable`†++(`unpack` / unboxed-strict fields are rejected, with a clear error)++† `Traversable` / `Bitraversable` are synthesized at the wrapper (`Stock1+F` / `Stock2 P`) and usable directly, or put on your own type with a+one-liner:++```haskell+instance Traversable F where+  traverse g = fmap unStock1 . traverse g . Stock1+```++A bare `deriving via Stock1 F` can't reach them: `traverse`'s result `f+(t b)` puts the wrapper under an *abstract* applicative `f`, and+coercing under an abstract `f` (nominal role) is unsound — the same wall+that stops `GeneralizedNewtypeDeriving`. The instance itself is perfectly+ordinary (it's what GHC's own `DeriveTraversable` builds), so the+one-liner — which re-wraps with a real `fmap`, not a coercion — gives you+the instance, and it honours `Override1` / `Override2` (which+`deriving stock Traversable` can't).++```haskell+{-# options_ghc -fplugin Stock #-}++{-# language DerivingVia #-}++import Stock++data Colour = Red | Green | Blue+  deriving (Eq, Ord, Show, Read, Enum, Bounded, Ix) via +    Stock Colour++data Tree a = Leaf | Node (Tree a) a (Tree a)+  deriving (Eq, Ord, Show) via +    Stock (Tree a)++data Trio a = Trio Int a [a]+  deriving (Functor, Foldable) via +    Stock1 Trio+```++The plugin must be enabled (`-fplugin Stock`, in `ghc-options` or a+per-file `options_ghc`). ++## How it works++For a wanted `Cls (Stock T)` the plugin unwraps the newtype with its+coercion, matches `T`'s constructors and builds the _Cls_-class+dictionary directly as Core, requesting each field's own instance as a+fresh wanted (GHC solves `Eq Int` etc. itself). It's direct synthesis+of the wrapped constraint, not delegation.++## Per-field modifiers++```haskell+newtype Override a config = Override a+```++`Override` reshapes individual fields during synthesis by specifying+their behaviour (zero-cost).++```haskell+data One = One { x :: Int, y :: Int }+  deriving (Semigroup, Monoid)+  via Overriding One+    [ x via Sum, y via Product ]+```++combines `x` additively and `y` multiplicatively.++There are a few methods of addressing a field, the plugin allows minor+notational conveniences.+++ `x via F` (`"x" := F`), modifies the field with the `F` wrapper++ `Int via F` (`Int := F`), modifies every `Int` field++ `Con at 0 via F` (`At Con 0 := F`), modifies field 0 of constructor++ `'Con --> F`, a path: modifies every field of `Con`; `'Con --> 0 --> F`+  only its field 0. Each non-terminal hop is a constructor, a position+  (`Nat`) or a label (`Symbol`); the terminal hop is the modifier++ `'[ [F, _] ]` (`'[ [F, Keep] ]`), modifies field 0 only, `_` keeps field++Each modifier is either particular via field `F Int`, a constructor to+modify `F` or a blank `_` (or `Keep`) which leaves a field untouched.+A function-typed modifier needs no parentheses: `x via a -> f b` reads as+`x := (a -> f b)`, since `via` binds looser than `->`.++**The surface plugin.** The lowercase, quote-free surface (`x via Sum`,+`Con at 0`, the `_` blank) is lowered to the honest marker form the+solver reads (`"x" := Sum`, `At Con 0`, `Keep`) by the same `-fplugin+Stock` at parse time (`Stock.Surface`). The generated markers (`:=`,+`At`, `Keep`) are qualified to match however you imported+`Stock.Override`, so `import Stock.Override qualified as O` with+`O.Override … '[ … via Sum, _ ]` resolves too.++### Higher-order++`Override1` / `Override2` lift the same idea over type constructors+instead of types.++```haskell+data Zip a = Zip [a]+  deriving +    (Functor, Applicative, Foldable) +  via+  Overriding1 Zip '[ '[ZipList] ]+```++## Adding a class++A companion package introduces a new class _Cls_ for synthesis by+writing a `DeriveStock Cls` instance.++The `-fplugin Stock` plugin discovers it: looks up the instance, loads+the deriver with GHC's own plugin loader, and runs it for `deriving+Cls via Stock T`.++```haskell+instance DeriveStock Semigroup where +  deriveStock :: Deriver+  deriveStock = Deriver \cls datatype -> do+    let (<+>) = head (classMethods cls)+    a <- fresh (dtVia datatype) "a"+    b <- fresh (dtVia datatype) "b"+    body <- fromProduct datatype (dtVia datatype) (Var a) \xs ->    -- (match)  a = C x..+            fromProduct datatype (dtVia datatype) (Var b) \ys ->    -- (match)  b = C y..+            toProduct datatype <$> czipFields cls                   -- (build)  C (x <> y)..+              (\ft d x y -> mkApps (Var (<+>)) [Type ft, d, x, y]) (productCon datatype) xs ys+    EvExpr <$> classDictWith cls (dtVia datatype) [] [(0, mkLams [a, b] body)]+```++The deriver must live in a different module from where it's used.  The+plugin loads it as *compiled* code, same-module instances won't+work. A normal dependency (separate package, or just a separate module+built with `-dynamic-too`) works.++## Performance++`cabal bench bench` runs identical workloads against a type defined three ways:+`via Stock`, GHC's stock `deriving`, and hand-written. All three give matching+checksums and run within noise of each other — verified by rebuilding and+re-running on GHC 9.8 – 9.14:++```+Ord: sort 100000 3-field records      via Stock 0.075s  stock 0.074s  hand 0.073s+Functor: fmap (+1) x50 over 100000    via Stock 0.136s  stock 0.136s  hand 0.137s+```++## Conclusions / realizations++Using _inspection-testing_ shows that the code we generate is+byte-identical to stock (`==-`). `Eq`, `Ord`, `Enum`, `Functor`+optimise to the *same Core* as GHC's own `deriving` on a twin type.++`Read` (and `Read1`) build `readPrec` exactly as GHC's derived `Read`+does — the same `ReadPrec` combinators — and let `readsPrec` come from+the class default, so the result is byte-faithful *including* the order+of ambiguous infix parses. A parity harness (`test/Twin.hs`) checks the+full `readsPrec` output against GHC's own derived `Read` on a+name-identical twin, over valid / whitespace / parenthesised / negative+/ garbage inputs at several precedences.++## Acknowledgments++Developed with substantial assistance from Claude (Anthropic).++## License++BSD-3-Clause.

@@ -0,0 +1,87 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | A like-for-like benchmark: the same datatype defined three ways — instances+-- synthesized by the plugin (@via Stock@), GHC's stock @deriving@, and+-- hand-written — running identical workloads.  The expectation is that all+-- three are within noise of each other (the plugin synthesizes the same+-- operations, so the optimized Core is essentially identical).+module Main (main) where++import qualified Stock as Stock+import Data.List (sort, foldl')+import System.CPUTime (getCPUTime)+import System.Mem (performGC)+import System.Environment (getArgs)+import Control.Exception (evaluate)+import Text.Printf (printf)+import System.IO (hSetBuffering, stdout, BufferMode(LineBuffering))++----------------------------------------------------------------------+-- A 3-field record, three ways (for Eq/Ord)+----------------------------------------------------------------------++data RV = RV Int Int Int deriving (Eq, Ord) via Stock.Stock RV      -- plugin+data RS = RS Int Int Int deriving (Eq, Ord)                         -- stock+data RH = RH Int Int Int                                            -- hand-written+instance Eq RH  where RH a b c == RH x y z = a == x && b == y && c == z+instance Ord RH where compare (RH a b c) (RH x y z) =+                        compare a x <> compare b y <> compare c z++----------------------------------------------------------------------+-- A parameterised type, three ways (for Functor)+----------------------------------------------------------------------++data FV a = FV a a a deriving Functor via Stock.Stock1 FV           -- plugin+data FS a = FS a a a deriving Functor                              -- stock+data FH a = FH a a a                                               -- hand-written+instance Functor FH where fmap f (FH a b c) = FH (f a) (f b) (f c)++----------------------------------------------------------------------++n :: Int+n = 100000++-- strict sum (avoid building a giant thunk)+ssum :: [Int] -> Int+ssum = foldl' (+) 0++-- Time a strict Int-producing workload, best-of-5 with a full GC before each+-- run.  @work@ must be a function of a dummy argument so each repetition+-- rebuilds its thunk from scratch (otherwise the result is shared and only the+-- first run does any work).  Best-of-N + per-run GC removes the ordering/GC+-- artefacts that otherwise inflate whichever workload happens to run first.+time :: String -> (Int -> Int) -> IO ()+time label work = do+  -- @d0@ is a genuinely runtime-unknown 0 (no args ⇒ length [] = 0); adding the+  -- repetition index gives each run a distinct argument, so GHC can neither+  -- constant-fold the workload nor share it across the 5 repetitions.+  d0 <- length <$> getArgs+  let once i = do performGC+                  t0 <- getCPUTime+                  !r <- evaluate (work (d0 + i))+                  t1 <- getCPUTime+                  pure (fromIntegral (t1 - t0) / (1e12 :: Double), r)+  samples <- mapM once [0 .. 4]+  let best = minimum (map fst samples)+      r    = case samples of (s:_) -> snd s; [] -> 0+  printf "  %-12s  %.3f s   (checksum %d)\n" label (best :: Double) r++main :: IO ()+main = do+  hSetBuffering stdout LineBuffering+  -- @d@ is always 0 at run time, but since it is a function argument GHC cannot+  -- treat the workload as a constant and share it — each repetition rebuilds.+  let seeds d = [ (i `mod` 97, i `mod` 31, i + d) | i <- [1 .. n] ]+  putStrLn ("Ord: sort " ++ show n ++ " 3-field records, then checksum")+  time "via Stock"   (\d -> ssum [ a + b + c | RV a b c <- sort [ RV x y z | (x,y,z) <- seeds d ] ])+  time "stock"       (\d -> ssum [ a + b + c | RS a b c <- sort [ RS x y z | (x,y,z) <- seeds d ] ])+  time "handwritten" (\d -> ssum [ a + b + c | RH a b c <- sort [ RH x y z | (x,y,z) <- seeds d ] ])+  let reps = 50 :: Int        -- compose fmap enough times to be measurable+      bump g = iterate (fmap (+1)) g !! reps+  putStrLn ("Functor: fmap (+1) x" ++ show reps ++ " over " ++ show n ++ " values, then checksum")+  time "via Stock"   (\d -> ssum [ a + b + c | FV a b c <- map bump [ FV x y z | (x,y,z) <- seeds d ] ])+  time "stock"       (\d -> ssum [ a + b + c | FS a b c <- map bump [ FS x y z | (x,y,z) <- seeds d ] ])+  time "handwritten" (\d -> ssum [ a + b + c | FH a b c <- map bump [ FH x y z | (x,y,z) <- seeds d ] ])

@@ -0,0 +1,68 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fplugin Stock #-}+-- | The same @Semigroup@ instance reached FOUR ways, on a 2-list product.+-- All must agree (same code); we time each.  The point of the project: the+-- @via Stock@ route is a /faster Generically/ — static synthesis, no @Rep@.+module Main (main) where++import qualified Stock as Stock+import GHC.Generics (Generic, Generically(..))+import System.CPUTime (getCPUTime)+import System.Mem (performGC)+import System.Environment (getArgs)+import Control.Exception (evaluate)+import Text.Printf (printf)+import System.IO (hSetBuffering, stdout, BufferMode(LineBuffering))++-- (1) our direct pointwise synthesis+data SVia = SVia [Int] [Int] deriving (Eq, Show)+  deriving Semigroup via Stock.Stock SVia+-- (2) our synthesized Generic, then base's Generically+data SGen = SGen [Int] [Int] deriving (Eq, Show)+  deriving Generic    via Stock.Stock SGen+  deriving Semigroup  via Generically SGen+-- (3) GHC stock Generic, then base's Generically+data SGenS = SGenS [Int] [Int] deriving (Eq, Show, Generic)+  deriving Semigroup via Generically SGenS+-- (4) hand-written+data SHand = SHand [Int] [Int] deriving (Eq, Show)+instance Semigroup SHand where SHand a b <> SHand x y = SHand (a <> x) (b <> y)++n :: Int+n = 200000++-- fold (<>) over n small products, return a checksum (total element count)+runVia, runGen, runGenS, runHand :: Int -> Int+runVia  d = csum (foldr1 (<>) [ SVia  [i+d] [i] | i <- [1..n] ]) where csum (SVia  a b) = length a + length b+runGen  d = csum (foldr1 (<>) [ SGen  [i+d] [i] | i <- [1..n] ]) where csum (SGen  a b) = length a + length b+runGenS d = csum (foldr1 (<>) [ SGenS [i+d] [i] | i <- [1..n] ]) where csum (SGenS a b) = length a + length b+runHand d = csum (foldr1 (<>) [ SHand [i+d] [i] | i <- [1..n] ]) where csum (SHand a b) = length a + length b++time :: String -> (Int -> Int) -> IO ()+time label work = do+  d0 <- length <$> getArgs+  let once i = do performGC; t0 <- getCPUTime; !r <- evaluate (work (d0+i)); t1 <- getCPUTime+                  pure (fromIntegral (t1-t0) / (1e12 :: Double), r)+  ss <- mapM once [0 .. 4]+  let r = case ss of ((_, x) : _) -> x ; [] -> 0+  printf "  %-22s  %.3f s   (checksum %d)\n" label (minimum (map fst ss)) r++-- each config's @(<>)@ on the same inputs, projected to a comparable shape+viaPair, genPair, genSPair, handPair :: ([Int], [Int])+viaPair  = case SVia  [1,3] [2] <> SVia  [4] [5,6] of SVia  a b -> (a, b)+genPair  = case SGen  [1,3] [2] <> SGen  [4] [5,6] of SGen  a b -> (a, b)+genSPair = case SGenS [1,3] [2] <> SGenS [4] [5,6] of SGenS a b -> (a, b)+handPair = case SHand [1,3] [2] <> SHand [4] [5,6] of SHand a b -> (a, b)++main :: IO ()+main = do+  hSetBuffering stdout LineBuffering+  putStrLn ("all four configs agree: " ++ show+    (all (== handPair) [viaPair, genPair, genSPair] && handPair == ([1,3,4], [2,5,6])))+  putStrLn ("Semigroup <> fold over " ++ show n ++ " products (best-of-5):")+  time "via Stock (direct)"          runVia+  time "via Generically (Stock)"     runGen+  time "via Generically (stock Gen)" runGenS+  time "hand-written"                runHand

@@ -0,0 +1,62 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+-- record selectors below are illustrative and intentionally unused+{-# OPTIONS_GHC -fplugin Stock -Wno-unused-top-binds #-}++-- | Stock supplies the /structural/ instance; the standard @DerivingVia@+-- modifier newtypes then reshape it.  Each type below derives through+-- @Modifier (Stock … )@, so the modifier delegates to the instance the plugin+-- synthesizes:+--+--   * 'Down'      — structural 'Ord', reversed.+--   * 'Reverse'   — structural 'Foldable', folded back-to-front.+--   * 'Backwards' — the structural 'Applicative', effects sequenced right-to-left.+module Main (main) where++import Stock (Stock(..), Stock1(..))+import Stock.Override (Override(..), type (:=))+import QualOverride (qualCheck)+import Data.Ord (Down(..))+import Data.Monoid (Sum(..), Product(..))+import Data.Functor.Reverse (Reverse(..))+import Control.Applicative.Backwards (Backwards(..))+import Data.Foldable (toList)+import Control.Monad (unless)+import System.Exit (exitFailure)++-- @Ord@ as the reverse of the structural order: @Gold < Silver < Bronze@.+data Medal = Bronze | Silver | Gold+  deriving (Eq, Show) via Stock Medal+  deriving Ord        via Down (Stock Medal)++-- @Foldable@ that visits fields back-to-front.+data Triple a = Triple a a a+  deriving Show     via Stock (Triple a)+  deriving Foldable via Reverse (Stock1 Triple)++-- The structural (position-wise) @Applicative@, run backwards.+data Two a = Two a a+  deriving (Eq, Show)  via Stock (Two a)+  deriving Functor     via Stock1 Two+  deriving Applicative via Backwards (Stock1 Two)++-- Per-field @Override@ (lowered from the lowercase surface by the same+-- @-fplugin Stock@): combine @vx@ additively (@Sum@) and @vy@ multiplicatively+-- (@Product@) — a @Semigroup@ you cannot get from plain @Stock V@ without+-- rewriting @V@'s field types.+data V = V { vx :: Int, vy :: Int }+  deriving (Eq, Show) via Stock V+  deriving Semigroup  via Stock (Override V [ vx via Sum, vy via Product ])++main :: IO ()+main = do+  let checks =+        [ ("Down reverses Ord",     compare Bronze Gold == GT+                                    && maximum [Bronze, Silver, Gold] == Bronze)+        , ("Reverse reverses fold", toList (Triple 1 2 (3 :: Int)) == [3, 2, 1])+        , ("Backwards Applicative", (Two (+1) (+10) <*> Two 100 (200 :: Int)) == Two 101 210)+        , ("Override per-field <>", V 2 3 <> V 5 7 == V 7 21)+        ] ++ qualCheck+  mapM_ (\(name, ok) -> putStrLn ((if ok then "ok   " else "FAIL ") ++ name)) checks+  unless (all snd checks) exitFailure

@@ -0,0 +1,32 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fplugin Stock -Wno-unused-top-binds #-}++-- | Regression: the @-fplugin Stock@ surface pass must qualify the markers it+-- generates (@:=@, @At@, @Keep@) the /same way @Override@ itself was imported/.+-- Here "Stock.Override" is imported __only qualified__ (as @O@), so an+-- unqualified @Keep@ or @:=@ in the lowered config would be out of scope.  The+-- modifiers themselves (@Sum@, @Product@) keep whatever scope the user gave them.+module QualOverride (qualCheck) where++import Stock (Stock(..))+import Stock.Override qualified as O+import Data.Monoid (Sum(..), Product(..))++-- entry surface: @via@ lowers to @O.:=@ (mirrors the @O.Override@ qualifier).+data A = A { ax :: Int, ay :: Int }+  deriving (Eq, Show) via Stock A+  deriving Semigroup  via Stock (O.Override A '[ ax via Sum, ay via Product ])++-- positional surface: @_@ lowers to @O.Keep@.  Field 0 (@Int@) via @Sum@; field+-- 1 (@[Int]@) kept at its own list 'Semigroup'.+data B = B Int [Int]+  deriving (Eq, Show) via Stock B+  deriving Semigroup  via Stock (O.Override B '[ [ Sum, _ ] ])++qualCheck :: [(String, Bool)]+qualCheck =+  [ ("qualified Override, via ⇒ O.:=", A 2 3 <> A 5 7 == A 7 21)+  , ("qualified Override, _ ⇒ O.Keep", B 1 [2] <> B 3 [4] == B 4 [2, 4])+  ]

@@ -0,0 +1,207 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin=Stock -fplugin=Test.Inspection.Plugin #-}++-- | Compile-time zero-cost proof.  @inspection-testing@ is a TEST-ONLY+-- dependency; the @stock@ library never depends on it, so users pay nothing.+-- Two complementary pins, each of which FAILS the build if violated:+--+-- (1) Byte-identical to stock (@(==-)@, equality up to types and coercions):+--     the Stock-derived method optimises to the /same Core/ as GHC's own+--     @deriving@ on a twin type.  This needs a stock twin and Core that does+--     not mention the datatype's own names, so it fits @Eq@\/@Ord@\/@Enum@\/+--     @Functor@ — pinned byte-identical here.+--+-- (2) Wrapper fully erased ('hasNoType'): for the classes without a usable+--     twin (@Show@; the lifted @Eq1@\/@Ord1@\/@Show1@\/@Foldable@ and+--     @Eq2@\/@Ord2@\/@Show2@\/@Bifoldable@ — GHC has no stock @deriving@ for+--     these, so there is nothing to @(==-)@ against).  Trick: wrap the argument+--     with the @Stock@\/@Stock1@\/@Stock2@ constructor so the plugin's own+--     unwrap coercion cancels it (@(Stock t) |> rCo = t@); fully applied, the+--     method worker inlines and NO wrapper type survives.  @hasNoType@ proves+--     the newtype and its @coerce@ are gone — i.e. zero cost.+--+-- Pin (2) needs the obligation to /consume/ its result (return @Int@\/@()@\/+-- @String@…) so GHC can't eta-reduce it back to a bare dictionary cast.  Given+-- that, even single-value \"producers\" — @<>@, @mempty@, @minBound@\/+-- @maxBound@ — pin fine: wrap the inputs and consume\/@unStock@ the output, and+-- every wrapper cancels.  The sole holdout is @Read@ (and @Read1@\/@Read2@): it+-- builds a @[(Stock T, String)]@ through opaque combinators (@readParen@\/@lex@+-- at @Stock T@), so the wrapper is baked into intermediate types that can't be+-- consumed away.  @Read@ is covered behaviourally by the @spec@ suite.+module Main (main) where++import Stock+import Test.Inspection+import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..), Eq2(..), Ord2(..), Show2(..))+import Data.Bifoldable (Bifoldable(..))+import Data.Bitraversable (Bitraversable(..))++-- product: Eq / Ord  (name-free Core — twin-comparable)+data P  = P Int Bool deriving (Eq, Ord) via Stock P+data P' = P' Int Bool deriving stock (Eq, Ord)++-- Show: pinned by newtype erasure (see below)+data S = MkS Int Bool deriving Show via Stock S+++-- enumeration: Enum+data E  = E0 | E1 | E2 deriving Enum via Stock E+data E' = F0 | F1 | F2 deriving stock Enum++-- single-value producers: Semigroup/Monoid (mempty, <>) and Bounded+-- (minBound/maxBound).  Unlike Read, the result is one value, so @unStock@+-- cancels the plugin's output wrap pointwise — no wrapper survives.+data Sg = Sg [Int] [Int] deriving (Semigroup, Monoid) via Stock Sg+data Bd = Bd Bool Ordering deriving Bounded via Stock Bd+data Bd' = Bd' Bool Ordering deriving stock Bounded   -- twin for the (==-) pin++-- type constructor: Functor (==-) + Foldable/Eq1/Ord1/Show1 (newtype erasure)+data T  a = T Int a [a]+  deriving stock (Eq, Ord, Show)            -- satisfy the lifted classes' superclasses+  deriving Functor                      via Stock1 T+  deriving (Foldable, Eq1, Ord1, Show1) via Stock1 T+data T' a = T' Int a [a] deriving stock (Functor, Foldable)++-- two-parameter constructor: Bifoldable/Eq2/Ord2/Show2 (newtype erasure)+data B a b = B a b [b]+  deriving stock (Eq, Ord, Show)               -- base of the superclass tower+  deriving (Eq1, Ord1, Show1)              via Stock1 (B a)   -- Eq2/Ord2/Show2 superclasses+  deriving (Bifoldable, Eq2, Ord2, Show2)  via Stock2 B++sEq, tEq :: P -> P -> Bool+sEq = (==)+tEq = \(P a b) (P c d) -> P' a b == P' c d++sCmp, tCmp :: P -> P -> Ordering+sCmp = compare+tCmp = \(P a b) (P c d) -> compare (P' a b) (P' c d)++sFromE, tFromE :: E -> Int+sFromE = fromEnum+tFromE = \e -> fromEnum (toEnum (fromEnum e) :: E')   -- structural twin++sFmap, tFmap :: (a -> b) -> T a -> T b+sFmap = fmap+tFmap = \f (T n x xs) -> T n (f x) (map f xs)++-- Bounded: route the twin through case-of-known-con so its cons cancel,+-- leaving identical name-free Core (same trick as Eq/Ord/Enum/Functor).+sMinB, tMinB, sMaxB, tMaxB :: Bd+sMinB = minBound+tMinB = case (minBound :: Bd') of Bd' a b -> Bd a b+sMaxB = maxBound+tMaxB = case (maxBound :: Bd') of Bd' a b -> Bd a b++-- Foldable: toList; twin routed through T' (its cons cancel).  Pins the+-- explicitly-synthesized foldr against GHC's stock foldr.+sToList, tToList :: T Int -> [Int]+sToList = foldr (:) []+tToList = \(T n x xs) -> foldr (:) [] (T' n x xs)++-- Traversable via the one-liner, pinned against the natural applicative walk.+sTr, tTr :: (Int -> Maybe Int) -> T Int -> Maybe (T Int)+sTr g = fmap unStock1 . traverse g . Stock1+tTr g = \x -> case x of T n y ys -> pure (T n) <*> g y <*> traverse g ys++-- @Show@ can't be twin-pinned with @(==-)@ (it embeds the constructor name, so+-- a same-named twin must live in another module and its worker is a distinct+-- top-level id).  Instead we certify the property that matters for zero cost:+-- /manually/ wrapping the argument with the @Stock@ constructor makes the+-- plugin's own unwrap coercion cancel it — @(Stock t) |> rCo = t@ — and, fully+-- applied (to @""@), the method worker inlines, so NO @Stock@ survives+-- optimisation.  'hasNoType' proves the wrapper and its @coerce@ are erased.+sShow :: Int -> S -> String+sShow d t = showsPrec d (Stock t) ""             -- wrap; plugin unwraps; cancels++-- @Read@ is the exception we cannot pin: it /produces/ the value, so+-- @readsPrec@ at @Stock S@ has result type @[(Stock S, String)]@ — @Stock@ is in+-- the parse result itself, not a cancellable input wrapper.  So neither+-- @(==-)@ (stock uses @ReadPrec@, the plugin the Report's @ReadS@) nor+-- 'hasNoType' applies; @Read@ is covered behaviourally by the @spec@ suite.++-- Lifted classes (no stock twin to @(==-)@ against): pin them the same way as+-- Show — wrap with the @Stock1@ constructor (the plugin's unwrap cancels it),+-- fully apply, and certify no @Stock1@ survives.  All are /consumers/ here.+sFold :: T Int -> Int+sFold t = sum (Stock1 t)++sLiftEq :: T Int -> T Int -> Bool+sLiftEq x y = liftEq (==) (Stock1 x) (Stock1 y)++sLiftCmp :: T Int -> T Int -> Ordering+sLiftCmp x y = liftCompare compare (Stock1 x) (Stock1 y)++sLiftShow :: Int -> T Int -> String+sLiftShow d t = liftShowsPrec showsPrec showList d (Stock1 t) ""++sBifold :: B Int Int -> Int+sBifold x = bifoldr (+) (+) 0 (Stock2 x)++-- @bifoldr@: GHC has no stock @Bifoldable@, so we pin against the natural+-- hand-written /direct/ recursion (the twin routes through @B@'s fields).  This+-- passes only because @bifoldr@ is synthesized directly; the @Endo@-based class+-- default would not match.+sBiFr, tBiFr :: (Int -> [Int] -> [Int]) -> (Int -> [Int] -> [Int]) -> [Int] -> B Int Int -> [Int]+sBiFr = bifoldr+tBiFr = \f g z x -> case x of B a b bs -> f a (g b (foldr g z bs))++-- @bitraverse@ via the one-liner (@fmap unStock2 . bitraverse . Stock2@) pinned+-- against the natural hand-written applicative walk @pure Con <*> .. <*> ..@.+-- Verifies the Stock2 wrapper cancels and the structure matches.+sBiTr, tBiTr :: (Int -> Maybe Int) -> (Int -> Maybe Int) -> B Int Int -> Maybe (B Int Int)+sBiTr f g = fmap unStock2 . bitraverse f g . Stock2+tBiTr f g = \x -> case x of B a b bs -> pure B <*> f a <*> g b <*> traverse g bs++sLiftEq2 :: B Int Int -> B Int Int -> Bool+sLiftEq2 x y = liftEq2 (==) (==) (Stock2 x) (Stock2 y)++sLiftCmp2 :: B Int Int -> B Int Int -> Ordering+sLiftCmp2 x y = liftCompare2 compare compare (Stock2 x) (Stock2 y)++sLiftShow2 :: Int -> B Int Int -> String+sLiftShow2 d x = liftShowsPrec2 showsPrec showList showsPrec showList d (Stock2 x) ""++-- single-value producers: wrap inputs and unwrap the result; both cancel.+-- /consume/ the @<>@ result (return Int) so GHC can't eta-reduce to a bare+-- producer dictionary cast (the same reason 'sShow' returns a String): the+-- @<>@ worker inlines, inputs and output wrappers cancel, no Stock survives.+sMappend :: Sg -> Sg -> Int+sMappend x y = case unStock (Stock x <> Stock y) of Sg p q -> sum p + sum q++sMempty :: Sg+sMempty = unStock (mempty :: Stock Sg)++sMinBound :: Bd+sMinBound = unStock (minBound :: Stock Bd)++sMaxBound :: Bd+sMaxBound = unStock (maxBound :: Stock Bd)++inspect $ 'sEq    ==- 'tEq+inspect $ 'sCmp   ==- 'tCmp+inspect $ 'sFromE ==- 'tFromE+inspect $ 'sFmap  ==- 'tFmap+inspect $ 'sMinB  ==- 'tMinB+inspect $ 'sMaxB  ==- 'tMaxB+inspect $ 'sToList ==- 'tToList+inspect $ 'sTr     ==- 'tTr+inspect $ 'sShow     `hasNoType` ''Stock+inspect $ 'sFold     `hasNoType` ''Stock1+inspect $ 'sLiftEq   `hasNoType` ''Stock1+inspect $ 'sLiftCmp  `hasNoType` ''Stock1+inspect $ 'sLiftShow `hasNoType` ''Stock1+inspect $ 'sBifold   `hasNoType` ''Stock2+inspect $ 'sBiFr     ==- 'tBiFr+inspect $ 'sBiTr     ==- 'tBiTr+inspect $ 'sLiftEq2  `hasNoType` ''Stock2+inspect $ 'sLiftCmp2 `hasNoType` ''Stock2+inspect $ 'sLiftShow2 `hasNoType` ''Stock2+inspect $ 'sMappend  `hasNoType` ''Stock+inspect $ 'sMempty   `hasNoType` ''Stock+inspect $ 'sMinBound `hasNoType` ''Stock+inspect $ 'sMaxBound `hasNoType` ''Stock++main :: IO ()+main = putStrLn "ok: Eq/Ord/Enum/Functor/Bounded/Foldable Core-identical (bifoldr = hand-written); Show/Semigroup/Monoid + lifted consumers erase the wrapper"

@@ -0,0 +1,488 @@+{-# 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 = defaultPlugin+  { tcPlugin           = \_ -> Just stockPlugin+    -- same @-fplugin Stock@ also lowers the @Override@ surface sugar at parse time+  , parsedResultAction = \_ _ -> pure . 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 f = Deriver \cls dt -> synthTc \loc ->+  f cls loc (dtVia dt) (dtType dt) (dtUnwrap dt)+    (map (\c -> (conDataCon c, conFieldCos c)) (dtCons dt))++stockPlugin :: TcPlugin+stockPlugin = TcPlugin+  { tcPluginInit = do+      seen   <- tcPluginIO (newIORef [])+      stock  <- lookupTyConMaybe "Stock.Type" "Stock"+      stock1 <- lookupTyConMaybe "Stock.Type" "Stock1"+      stock2 <- lookupTyConMaybe "Stock.Type" "Stock2"+      witCls <- lookupClassMaybe "Stock.Derive" "DeriveStock"+      k1Tc   <- tcLookupTyCon k1TyConName+      prodTc <- tcLookupTyCon prodTyConName+      rTc    <- lookupOrig gHC_INTERNAL_GENERICS (mkTcOcc "R") >>= tcLookupTyCon+      gen    <- GenEnv stock stock1 stock2 witCls+                       <$> tcLookupClass genClassName+                       <*> tcLookupTyCon repTyConName+                       <*> tcLookupTyCon u1TyConName+                       <*> pure k1Tc+                       <*> pure prodTc <*> pure (head (tyConDataCons prodTc))+                       <*> tcLookupTyCon sumTyConName+                       <*> lookupMetaEnv+                       <*> lookupGen1Env+                       <*> pure (mkTyConTy rTc)+                       <*> lookupTyConMaybe "Stock.Override" "Override"+                       <*> lookupTyConMaybe "Stock.Override" ":="+                       <*> lookupTyConMaybe "Stock.Override" "At"+                       <*> lookupTyConMaybe "Stock.Override" "Keep"+                       <*> lookupTyConMaybe "Stock.Override" "-->"+                       <*> lookupClassMaybe "Stock.Derive" "DeriveStock1"+                       <*> lookupClassMaybe "Stock.Derive" "DeriveStock2"+                       <*> lookupTyConMaybe "Stock.Override" "Override2"+                       <*> lookupTyConMaybe "Stock.Override" "Override1"+      pure (PluginState seen gen)+  , tcPluginSolve = solveStock+  , tcPluginRewrite = \st -> listToUFM+      [ (geRepTc (psGen st),          rewriteRep  (psGen st))+      , (g1RepTc (geGen1 (psGen st)), rewriteRep1 (psGen st)) ]+  , tcPluginStop = \_ -> 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 st _ev _given wanted = do+  results <- for wanted (trySolve st)+  let solutions  = catMaybes [ s | (s, _, _) <- results ]+      newWanteds = concat    [ w | (_, w, _) <- results ]+      insolubles = concat    [ i | (_, _, i) <- results ]+  pure TcPluginSolveResult+    { tcPluginInsolubleCts = insolubles+    , tcPluginSolvedCts    = solutions+    , tcPluginNewCts       = 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 st ct =+  case classifyPredType (ctPred 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 cls (reverse -> (wrappedTy : _)) ->+      fromMaybe (Nothing, [], [])+        <$> runSolver (mconcat [stockSolver, stock1Solver, stock2Solver]) st ct cls wrappedTy+    _ -> pure (Nothing, [], [])++-- | @Cls (Stock T)@ — build the dictionary from @T@'s constructors.+stockSolver :: Solver+stockSolver = Solver \st ct cls wrappedTy -> do+  -- @Stock (Override T cfg)@ takes priority; its decode emits per-cell coercion+  -- wanteds (@extraCts@) that ride alongside the deriver's own.+  mOver <- mkOverrideRepr (psGen st) (ctLoc ct) wrappedTy+  case mOver of+    Just (Left err)               -> Just <$> notImplemented st ct err+    Just (Right (repr, extraCts)) -> Just . addCts extraCts <$> dispatchStock st ct cls wrappedTy repr+    Nothing -> case mkRepr (geStock (psGen st)) wrappedTy of+      Nothing   -> pure Nothing+      Just repr -> Just <$> dispatchStock st ct cls wrappedTy repr++-- | Append extra wanted constraints to a solve attempt.+addCts :: [Ct] -> Attempt -> Attempt+addCts extra (sol, ws, ins) = (sol, extra ++ ws, 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 st ct cls wrappedTy repr+      | reprUnpacked repr =+          notImplemented st ct $+            text "stock: cannot derive via Stock for a type whose"+            <+> text "constructors have UNPACKed or unboxed strict fields"+            <+> text "(their runtime representation differs from their source type)"+            $$ nest 2 (text "in the derived instance for"+                       <+> quotes (ppr (className cls) <+> ppr wrappedTy))+      | otherwise = do+          let innerTy = rInner repr+              co      = rCo repr+          case occNameString (nameOccName (className cls)) of+            "Eq" -> runDeriverAttempt eqDeriver ct cls (toDatatype wrappedTy repr)+            "Ord"  -> runDeriverAttempt (viaSynth synthOrd)  ct cls (toDatatype wrappedTy repr)+            "Show" -> runDeriverAttempt (viaSynth synthShow) ct cls (toDatatype wrappedTy repr)+            "Read" -> runDeriverAttempt (viaSynth synthRead) ct cls (toDatatype wrappedTy repr)+            "Enum"+              | reprIsEnum repr -> runDeriverAttempt (viaSynth synthEnum) ct cls (toDatatype wrappedTy repr)+              | otherwise ->+                  notImplemented st ct $+                    text "stock: deriving Enum via Stock requires an"+                    <+> text "enumeration (constructors without fields)"+                    $$ nest 2 (text "in the derived instance for"+                               <+> quotes (ppr (className cls) <+> ppr wrappedTy))+            "Ix"+              | reprIsEnum repr -> runDeriverAttempt (viaSynth synthIx) ct cls (toDatatype wrappedTy repr)+              | reprSingleCon repr -> runDeriverAttempt (viaSynth synthIxProduct) ct cls (toDatatype wrappedTy repr)+              | otherwise ->+                  notImplemented st ct $+                    text "stock: deriving Ix via Stock requires an enumeration"+                    <+> text "or a single-constructor product"+                    $$ nest 2 (text "in the derived instance for"+                               <+> quotes (ppr (className cls) <+> ppr wrappedTy))+            "Bounded"+              | reprIsEnum repr || reprSingleCon repr ->+                  runDeriverAttempt boundedDeriver ct cls (toDatatype wrappedTy repr)+              | otherwise ->+                  notImplemented st ct $+                    text "stock: deriving Bounded via Stock requires an"+                    <+> text "enumeration or a single-constructor type"+                    $$ nest 2 (text "in the derived instance for"+                               <+> quotes (ppr (className cls) <+> ppr wrappedTy))+            "Generic" -> do+              ev <- synthGeneric (psGen st) wrappedTy innerTy co (rCons repr)+              pure (Just (ev, ct), [], [])+            "Semigroup"+              | reprSingleCon repr -> runDeriverAttempt semigroupDeriver ct cls (toDatatype wrappedTy repr)+              | otherwise -> notImplemented st ct $+                  text "stock: Semigroup via Stock requires a single-constructor"+                  <+> text "(product) type" $$ nest 2 (text "in the derived instance for"+                  <+> quotes (ppr (className cls) <+> ppr wrappedTy))+            "Monoid"+              | reprSingleCon repr -> runDeriverAttempt monoidDeriver ct cls (toDatatype wrappedTy repr)+              | otherwise -> notImplemented st ct $+                  text "stock: Monoid via Stock requires a single-constructor"+                  <+> text "(product) type" $$ nest 2 (text "in the derived instance for"+                  <+> quotes (ppr (className cls) <+> ppr wrappedTy))+            other -> do+              -- not a built-in: try a companion-provided @instance DeriveStock Cls@+              mw <- tryWitness st ct cls (toDatatype wrappedTy repr)+              case mw of+                Just attempt -> pure attempt+                Nothing ->+                  notImplemented st ct $+                    text "stock: deriving" <+> quotes (text other)+                    <+> text "via Stock is not supported, and no"+                    <+> text "'instance DeriveStock' was found for it"+                    $$ nest 2 (text "in the derived instance for"+                               <+> quotes (ppr (className cls) <+> ppr wrappedTy))+-- | @Cls (Stock1 F)@ — a class over a (poly-kinded) type constructor.+stock1Solver :: Solver+stock1Solver = Solver \st ct cls wrappedTy ->+  case (geStock1 (psGen st), tyConAppTyCon_maybe wrappedTy) of+    (Just ourTc, Just stTc) | stTc == ourTc+      , [_, f] <- tyConAppArgs wrappedTy+      -- TestEquality/TestCoercion handle GADTs directly (whose constructors+      -- carry coercion fields that trip 'dcUnpacked'); let them through.+      , occNameString (nameOccName (className cls)) `notElem` ["TestEquality", "TestCoercion"]+      , maybe False (any dcUnpacked . tyConDataCons) (tyConAppTyCon_maybe f) ->+          fmap Just $ notImplemented st ct $+            text "stock: cannot derive via Stock1 for a type whose"+            <+> text "constructors have UNPACKed or unboxed strict fields"+            <+> text "(their runtime representation differs from their source type)"+            $$ nest 2 (text "in the derived instance for"+                       <+> quotes (ppr (className cls) <+> ppr wrappedTy))+    (Just ourTc, Just stTc) | stTc == ourTc+      , [_, f] <- tyConAppArgs wrappedTy ->+          fmap Just $+          let runStock1 synth = do+                m <- synth (psGen st) cls (ctLoc ct) wrappedTy f+                case m of+                  Just (ev, ws) -> pure (Just (ev, ct), ws, [])+                  Nothing ->+                    notImplemented st ct $+                      text "stock: deriving" <+> ppr (className cls)+                      <+> text "via Stock1 supports only covariant fields (the"+                      <+> text "parameter, constants, or a functor applied to it)"+                      $$ nest 2 (text "in the derived instance for"+                                 <+> quotes (ppr (className cls) <+> ppr wrappedTy))+          in case occNameString (nameOccName (className cls)) of+               "Functor"       -> runStock1 synthFunctor+               "Applicative"   -> runStock1 synthApplicative+               "Foldable"      -> runStock1 synthFoldable+               "Contravariant" -> runStock1 synthContravariant+               "Generic1"      -> runStock1 synthGeneric1+               "Eq1"           -> runStock1 synthEq1+               "Ord1"          -> runStock1 synthOrd1+               "Show1"         -> runStock1 synthShow1+               "Read1"         -> runStock1 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.+               "Traversable"   -> runStock1 synthTraversable+               "TestEquality"  -> runStock1 synthTestEquality+               "TestCoercion"  -> runStock1 synthTestCoercion+               _ -> do+                 -- not a built-in: try a companion @instance DeriveStock1 Cls@+                 mw <- tryWitness1 st ct cls wrappedTy f+                 case mw of+                   Just attempt -> pure attempt+                   Nothing -> notImplemented st ct $+                     text "stock: deriving" <+> quotes (ppr (className cls))+                     <+> text "via Stock1 is not supported, and no"+                     <+> text "'instance DeriveStock1' was found for it"+                     $$ nest 2 (text "in the derived instance for"+                                <+> quotes (ppr (className cls) <+> ppr 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 ourTc, Just stTc) | stTc == ourTc+      , (_ : f : rest@(_ : _)) <- tyConAppArgs wrappedTy ->+          fmap Just $ 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   = fst (peelOverride1With (ovTcsGen "Override1" (psGen st)) f)+                innerTy = mkAppTys realF 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 = mkStockCo (PluginProv "stock") Representational+                           (mkClassPred cls [innerTy]) (mkClassPred cls [wrappedTy])+            ev <- newWanted (ctLoc ct) (mkClassPred cls [innerTy])+            pure (Just (EvExpr (Cast (ctEvExpr ev) dictCo), ct), [mkNonCanonical ev], [])+    _ -> pure Nothing++-- | @Cls (Stock2 P)@ — a class over a (poly-kinded) two-parameter constructor.+stock2Solver :: Solver+stock2Solver = Solver \st ct cls wrappedTy ->+  case (geStock2 (psGen st), tyConAppTyCon_maybe wrappedTy) of+    (Just ourTc, Just stTc) | stTc == ourTc+      , [_, _, p] <- tyConAppArgs wrappedTy+      , maybe False (any dcUnpacked . tyConDataCons) (tyConAppTyCon_maybe p) ->+          fmap Just $ notImplemented st ct $+            text "stock: cannot derive via Stock2 for a type whose"+            <+> text "constructors have UNPACKed or unboxed strict fields"+            $$ nest 2 (text "in the derived instance for"+                       <+> quotes (ppr (className cls) <+> ppr wrappedTy))+    (Just ourTc, Just stTc) | stTc == ourTc+      , [_, _, p] <- tyConAppArgs wrappedTy ->+          fmap Just $+          let runStock2 synth = do+                m <- synth (psGen st) cls (ctLoc ct) wrappedTy p+                case m of+                  Just (ev, ws) -> pure (Just (ev, ct), ws, [])+                  Nothing ->+                    notImplemented st ct $+                      text "stock: deriving" <+> ppr (className cls)+                      <+> text "via Stock2 supports only covariant fields in the last"+                      <+> text "two parameters (each parameter, constants, or a functor"+                      <+> text "applied to one)"+                      $$ nest 2 (text "in the derived instance for"+                                 <+> quotes (ppr (className cls) <+> ppr wrappedTy))+          in case occNameString (nameOccName (className cls)) of+               "Bifunctor"  -> runStock2 synthBifunctor+               "Bifoldable" -> runStock2 synthBifoldable+               "Eq2"        -> runStock2 synthEq2+               "Ord2"       -> runStock2 synthOrd2+               "Show2"      -> runStock2 synthShow2+               "Read2"      -> runStock2 synthRead2+               "Category"   -> runStock2 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.+               "Bitraversable" -> runStock2 synthBitraversable+               _ -> do+                 -- not a built-in: try a companion @instance DeriveStock2 Cls@+                 mw <- tryWitness2 st ct cls wrappedTy p+                 case mw of+                   Just attempt -> pure attempt+                   Nothing -> notImplemented st ct $+                     text "stock: deriving" <+> quotes (ppr (className cls))+                     <+> text "via Stock2 is not supported, and no"+                     <+> text "'instance DeriveStock2' was found for it"+                     $$ nest 2 (text "in the derived instance for"+                                <+> quotes (ppr (className cls) <+> ppr 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 ourTc, Just stTc) | stTc == ourTc+      , (_ : _ : p : rest@(_ : _)) <- tyConAppArgs wrappedTy ->+          fmap Just $ 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   = fst (peelOverride2With (ovTcsGen "Override2" (psGen st)) p)+                innerTy = mkAppTys realP 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 = mkStockCo (PluginProv "stock") Representational+                           (mkClassPred cls [innerTy]) (mkClassPred cls [wrappedTy])+            ev <- newWanted (ctLoc ct) (mkClassPred cls [innerTy])+            pure (Just (EvExpr (Cast (ctEvExpr ev) dictCo), ct), [mkNonCanonical ev], [])+    _ -> pure 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).

@@ -0,0 +1,188 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}++-- | Pointwise @Applicative@ via @Stock1@, for single-constructor (product)+-- types — a faster @Generically1@: @pure@ replicates into every field and+-- @(\<*\>)@ applies field-wise.  Each field must be the parameter (applied+-- directly), an @Applicative@ functor of it (delegating to that functor), or a+-- constant — which, Const-style (exactly as @Generically1@), is fine given a+-- @Monoid@: @pure@ fills it with @mempty@ and @(\<*\>)@\/@liftA2@ combine with+-- @(\<>)@.  (Any sum type is still rejected.)  The @Functor@ superclass+-- dictionary comes from 'synthFunctor'.+module Stock.Applicative where++import GHC.Plugins hiding (TcPlugin)+import GHC.Tc.Plugin+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.Core.Class (Class)+import GHC.Core.Predicate (mkClassPred)+import GHC.Core.Multiplicity (scaledThing)+import GHC.Core.TyCo.Rep (UnivCoProvenance(PluginProv))+import GHC.Builtin.Names (functorClassName, monoidClassName)+import Control.Monad (forM, zipWithM)+import Stock.Derive (classMethod)+import Stock.Internal+import Stock.Functor (synthFunctor)++-- | How one field of the product is handled by @pure@\/@(\<*\>)@\/@liftA2@: it+-- /is/ the parameter; an @Applicative@ functor @m@ of it (with @m@'s dict, and a+-- @Just@ @h t ~R m t@ coercion builder when reshaped by an @Override1@, else+-- @Nothing@); or a constant of type @ft@ handled Const-style via its @Monoid@.+data FldSpec = FsParam+             | FsApp Type CoreExpr (Maybe (Type -> Coercion))+             | FsConst Type CoreExpr++-- | Coerce a field value /into/ the modifier functor (@h t ~R m t@); identity+-- when the field is not reshaped.+castInOv :: Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr+castInOv Nothing       _ e = e+castInOv (Just coFn)   t e = Cast e (coFn t)++-- | Coerce a result /back/ from the modifier functor to the real field type.+castBackOv :: Maybe (Type -> Coercion) -> Type -> CoreExpr -> CoreExpr+castBackOv Nothing     _ e = e+castBackOv (Just coFn) t e = Cast e (mkSymCo (coFn t))++synthApplicative :: GenEnv -> Class -> CtLoc -> Type -> Type+                 -> TcPluginM (Maybe (EvTerm, [Ct]))+synthApplicative gen applicativeCls loc wrappedTy f =+  case geStock1 gen of+    Just st1Tc+      -- peel an optional @Override1 cfg F@ (functor reshape, e.g. @[] -> ZipList@)+      | let (realF, mMods) = peelOverride1 gen f+      , Just fTc <- tyConAppTyCon_maybe realF+      , [dc] <- tyConDataCons fTc -> do          -- products only: one constructor+          functorCls <- tcLookupClass functorClassName+          monoidCls  <- tcLookupClass monoidClassName+          let fixed     = tyConAppArgs realF+              pureSel   = classMethod "pure"    applicativeCls    -- index 0: pure+              apSel     = classMethod "<*>"     applicativeCls    -- index 1: (<*>)+              laSel     = classMethod "liftA2"  applicativeCls    -- index 2: liftA2+              memptySel = classMethod "mempty"  monoidCls+              mappendSel= classMethod "mappend" monoidCls+              coAt t  = coDown1 gen st1Tc wrappedTy f realF t   -- Stock1 (Override1? F) t ~R F t++          -- Classify each field once: parameter, an @Applicative@ functor of it,+          -- or a constant — which (Const-style, as @Generically1@ does) is fine+          -- given a @Monoid@: @pure@ uses @mempty@, @(\<*\>)@ uses @(\<>)@.+          ctv <- freshTyVar "p"+          let ctvTy  = mkTyVarTy ctv+              fldTys = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [ctvTy]))+              kinds  = map (classifyField ctv ctvTy) fldTys++          -- @FsParam@ | @FsApp h dApplicative@ | @FsConst ft dMonoid@; an arrow or+          -- other unsupported shape still bails with 'Nothing'.+          specsW <- forM (zip3 [0 :: Int ..] kinds fldTys) \(i, k, ft) -> case k of+            Just FParam   -> pure (Just (FsParam, []))+            Just (FApp h) -> case override1Mod gen mMods i of+              -- Override1: reshape the field functor @h a -> m a@ (e.g. ZipList),+              -- with a @h t ~R m t@ coercion threaded through pure/<*>/liftA2.+              Just m  -> do ev <- newWanted loc (mkClassPred applicativeCls [m])+                            let coFn t = mkStockCo (PluginProv "stock") Representational+                                                   (mkAppTy h t) (mkAppTy m t)+                            pure (Just (FsApp m (ctEvExpr ev) (Just coFn), [mkNonCanonical ev]))+              Nothing -> do ev <- newWanted loc (mkClassPred applicativeCls [h])+                            pure (Just (FsApp h (ctEvExpr ev) Nothing, [mkNonCanonical ev]))+            Just FConst   -> do ev <- newWanted loc (mkClassPred monoidCls [ft])+                                pure (Just (FsConst ft (ctEvExpr ev), [mkNonCanonical ev]))+            _             -> pure Nothing++          case sequence specsW of+            Nothing  -> pure Nothing+            Just sw  -> do+              let fieldSpec = map fst sw+                  appWs     = concatMap snd sw++              -- pure :: forall a. a -> Stock1 F a+              aP  <- freshTyVar "a"+              let aPt = mkTyVarTy aP+              xId <- freshId aPt "x"+              let pureVal FsParam          = Var xId+                  pureVal (FsApp m d mco)  = castBackOv mco aPt (mkApps (Var pureSel) [Type m, d, Type aPt, Var xId])+                  pureVal (FsConst ft d)   = mkApps (Var memptySel) [Type ft, d]+                  pureImpl = mkLams [aP, xId] $+                    Cast (mkCoreConApps dc (map Type (fixed ++ [aPt]) ++ map pureVal fieldSpec))+                         (mkSymCo (coAt aPt))++              -- (<*>) :: forall a b. Stock1 F (a -> b) -> Stock1 F a -> Stock1 F b+              aS <- freshTyVar "a" ; bS <- freshTyVar "b"+              let aSt = mkTyVarTy aS ; bSt = mkTyVarTy bS ; fnTy = mkVisFunTyMany aSt bSt+              sffId <- freshId (mkAppTy wrappedTy fnTy) "sff"+              sfaId <- freshId (mkAppTy wrappedTy aSt)  "sfa"+              ffs <- zipWithM (\n t -> freshId t ("ff" ++ show n)) [0 :: Int ..]+                       (map scaledThing (dataConInstOrigArgTys dc (fixed ++ [fnTy])))+              xas <- zipWithM (\n t -> freshId t ("xa" ++ show n)) [0 :: Int ..]+                       (map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aSt])))+              cbF <- freshId (mkTyConApp fTc (fixed ++ [fnTy])) "cbf"+              cbA <- freshId (mkTyConApp fTc (fixed ++ [aSt]))  "cba"+              let apVal FsParam         ff xa = App (Var ff) (Var xa)+                  apVal (FsApp m d mco) ff xa =+                    castBackOv mco bSt (mkApps (Var apSel)+                      [ Type m, d, Type aSt, Type bSt+                      , castInOv mco fnTy (Var ff), castInOv mco aSt (Var xa) ])+                  apVal (FsConst ft d) ff xa =        -- combine the constants with (<>)+                    mkApps (Var mappendSel) [Type ft, d, Var ff, Var xa]+                  apImpl = mkLams [aS, bS, sffId, sfaId] $+                    destructInner fTc (fixed ++ [fnTy]) (Cast (Var sffId) (coAt fnTy))+                                  cbF (mkAppTy wrappedTy bSt)+                      [ Alt (DataAlt dc) ffs $+                          destructInner fTc (fixed ++ [aSt]) (Cast (Var sfaId) (coAt aSt))+                                        cbA (mkAppTy wrappedTy bSt)+                            [ Alt (DataAlt dc) xas $+                                Cast (mkCoreConApps dc (map Type (fixed ++ [bSt])+                                                         ++ zipWith3 apVal fieldSpec ffs xas))+                                     (mkSymCo (coAt bSt)) ] ]++              -- liftA2 :: forall a b c. (a -> b -> c) -> Stock1 F a -> Stock1 F b -> Stock1 F c+              -- Given DIRECTLY (one structural pass) rather than via the class+              -- default @liftA2 g x = (g \<$\> x) \<*\> y@, which would @fmap@ then+              -- @\<*\>@ (two passes).  Each field: @g p q@ for the parameter, or+              -- @liftA2 \@h g p q@ for an Applicative-functor field.+              laA <- freshTyVar "a" ; laB <- freshTyVar "b" ; laC <- freshTyVar "c"+              let laAt = mkTyVarTy laA ; laBt = mkTyVarTy laB ; laCt = mkTyVarTy laC+                  gTy  = mkVisFunTyMany laAt (mkVisFunTyMany laBt laCt)+              gId  <- freshId gTy "g"+              ls1  <- freshId (mkAppTy wrappedTy laAt) "s1"+              ls2  <- freshId (mkAppTy wrappedTy laBt) "s2"+              ps   <- zipWithM (\n t -> freshId t ("p" ++ show n)) [0 :: Int ..]+                        (map scaledThing (dataConInstOrigArgTys dc (fixed ++ [laAt])))+              qs   <- zipWithM (\n t -> freshId t ("q" ++ show n)) [0 :: Int ..]+                        (map scaledThing (dataConInstOrigArgTys dc (fixed ++ [laBt])))+              cb1  <- freshId (mkTyConApp fTc (fixed ++ [laAt])) "cb1"+              cb2  <- freshId (mkTyConApp fTc (fixed ++ [laBt])) "cb2"+              let laVal FsParam         p q = mkApps (Var gId) [Var p, Var q]+                  laVal (FsApp m d mco) p q =+                    castBackOv mco laCt (mkApps (Var laSel)+                      [ Type m, d, Type laAt, Type laBt, Type laCt, Var gId+                      , castInOv mco laAt (Var p), castInOv mco laBt (Var q) ])+                  laVal (FsConst ft d) p q =          -- constants ignore g, combine with (<>)+                    mkApps (Var mappendSel) [Type ft, d, Var p, Var q]+                  liftA2Impl = mkLams [laA, laB, laC, gId, ls1, ls2] $+                    destructInner fTc (fixed ++ [laAt]) (Cast (Var ls1) (coAt laAt))+                                  cb1 (mkAppTy wrappedTy laCt)+                      [ Alt (DataAlt dc) ps $+                          destructInner fTc (fixed ++ [laBt]) (Cast (Var ls2) (coAt laBt))+                                        cb2 (mkAppTy wrappedTy laCt)+                            [ Alt (DataAlt dc) qs $+                                Cast (mkCoreConApps dc (map Type (fixed ++ [laCt])+                                                         ++ zipWith3 laVal fieldSpec ps qs))+                                     (mkSymCo (coAt laCt)) ] ]++              -- the @Functor@ superclass dictionary is the first dict-con field+              synthFunctor gen functorCls loc wrappedTy f >>= \case+                Nothing         -> pure Nothing+                Just (fEv, fWs) -> do+                  dict <- recDictWith applicativeCls wrappedTy [unwrapEv fEv]+                                      [(0, pureImpl), (1, apImpl), (2, liftA2Impl)]+                  pure (Just (EvExpr dict, fWs ++ appWs))+    _ -> pure Nothing

@@ -0,0 +1,992 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}+-- | All @Stock2@ synthesizers (classes over a two-parameter type @P@):+--+--   * @Bifunctor@ \/ @Bifoldable@ — map\/fold the last two parameters.+--   * @Eq2@ \/ @Ord2@ \/ @Show2@ \/ @Read2@ — the lifted "two-parameter"+--     'Data.Functor.Classes' (mirroring "Stock.Classes1" one level up).+--   * @Bitraversable@ — synthesized directly (usable at the wrapper \/ via the+--     one-liner; a bare @deriving via@ can't, abstract-applicative role).+--   * @Category@ — pointwise @id@\/@(.)@ for a single-constructor product+--     whose fields are each a 'Control.Category.Category' in the two params.+--+-- Field shapes: each of the two parameters, constants, or a (covariant) functor+-- applied to one (the flat 'classifyBiField'); @Bifunctor@ also goes through the+-- n-ary variance engine for nested\/self-applied fields like @Either a b@.+module Stock.Bifunctor 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, classTyVars, classSCTheta)+import GHC.Core.Predicate (classifyPredType, Pred(ClassPred), mkClassPred)+import GHC.Core.TyCo.Subst (substTy, emptySubst)+import GHC.Builtin.Types (orderingTyCon)+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, applicativeClassName, traversableClassName )+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 Data.Maybe (catMaybes, fromJust, isJust, fromMaybe)+import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'+import Stock.Trans (MaybeT(..))+import Control.Monad (forM, zipWithM, unless, guard)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef')+import Control.Monad (zipWithM)+import Data.List (zip4, zip5, zipWith4)+import Data.Maybe (listToMaybe)+import Stock.Internal+-- field reshape: 'reshapeCo' (@h t ~R m t@) + 'castReshape' live in "Stock.Internal".++data BiField+  = BFA | BFB                 -- ^ the field /is/ @a@ resp. @b@+  | BFConst                   -- ^ mentions neither+  | BFFoldA Type | BFFoldB Type   -- ^ @h a@ / @h b@ (covariant, @h@ over one param)++classifyBiField :: TyVar -> TyVar -> Type -> Type -> Type -> Maybe BiField+classifyBiField atv btv aTy bTy ft+  | ft `eqType` aTy                            = Just BFA+  | ft `eqType` bTy                            = Just BFB+  | not (inFt atv) && not (inFt btv)           = Just BFConst+  | Just (h, larg) <- splitAppTy_maybe ft+  , larg `eqType` bTy, clean h                 = Just (BFFoldB h)+  | Just (h, larg) <- splitAppTy_maybe ft+  , larg `eqType` aTy, clean h                 = Just (BFFoldA h)+  | otherwise                                  = Nothing+  where inFt v = v `elemVarSet` tyCoVarsOfType ft+        clean h = not (atv `elemVarSet` tyCoVarsOfType h)+               && not (btv `elemVarSet` tyCoVarsOfType h)++-- | For @Category@: a field must be exactly @h a b@ — a (poly-kinded)+-- two-parameter constructor @h@ applied to /both/ datatype parameters, in+-- order.  @h@ is the per-field @Category@ (e.g. @(->)@, @(:~:)@, @Kleisli m@,+-- or a @Basic m@ from an @Override@).  Returns @h@ (which must not mention the+-- parameters).  Constants and one-parameter shapes have no @id@\/@(.)@, so they+-- yield 'Nothing' and the whole synthesis bails.+classifyCatField :: TyVar -> TyVar -> Type -> Maybe Type+classifyCatField atv btv ft+  | Just (hp, qarg) <- splitAppTy_maybe ft+  , qarg `eqType` mkTyVarTy btv+  , Just (h, parg)  <- splitAppTy_maybe hp+  , parg `eqType` mkTyVarTy atv+  , not (atv `elemVarSet` tyCoVarsOfType h)+  , not (btv `elemVarSet` tyCoVarsOfType h)  = Just h+  | otherwise                                = Nothing++-- | How one field of a @Category@ product is handled: it is a @Category@ @h@+-- (with a @realFt(t1,t2) ~R h t1 t2@ coercion builder — 'Refl' unless reshaped+-- by an @Override2@), or a /constant/ @m@ handled Const-style via its @Monoid@+-- (@id = mempty@, @(.) = (\<>)@) — the automatic, @Basic@-free version.+data CatFld = CatF Type (Type -> Type -> Coercion) | MonF Type++-- | Synthesize @Category (Stock2 P)@ for a single-constructor product whose+-- every field is a @Category@ in the two parameters (shape @h a b@).  @id@ and+-- @(.)@ are pointwise — @id = P id .. id@, @P g.. . P h.. = P (g.h)..@ — exactly+-- the @Semigroup@ pattern lifted to two parameters.  @Category@ is poly-kinded+-- (@cat :: k -> k -> Type@), so the kind @k@ (here always @Type@) is threaded+-- through the dictionary and through every @id@\/@(.)@ at the field categories.+--+-- @P@ may be wrapped in @Override2 cfg P@: then each positional modifier @m@+-- reshapes its field to @m a b@ (the modifier applied to both parameters), with+-- a per-field @realFt ~R m a b@ coercion, so fields that are not yet categories+-- (an @Int@, an @a -> Maybe b@) become ones (@Basic (Sum Int)@, @Kleisli Maybe@).+synthCategory :: GenEnv -> Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))+synthCategory gen catCls loc wrappedTy p0 =+  case geStock2 gen of+    Just st2Tc+      -- peel an optional @Override2 cfg P@: @realP@ is the genuine constructor,+      -- @mMods@ the per-field positional modifiers (single inner list — one ctor).+      | let (realP, mMods) = case geOverride2 gen of+              Just ov2Tc+                | Just (tc, [_, rp, cfg]) <- splitTyConApp_maybe p0, tc == ov2Tc+                -> (rp, listToMaybe =<< decodePositional cfg)+              _ -> (p0, Nothing)+      , Just pTc <- tyConAppTyCon_maybe realP+      , [dc] <- tyConDataCons pTc, not (isNewTyCon pTc) -> do+          monoidCls <- tcLookupClass monoidClassName+          let fixed   = tyConAppArgs realP+              idSel   = classMethod "id" catCls+              compSel = classMethod "." catCls+              memptySel  = classMethod "mempty"  monoidCls+              mappendSel = classMethod "mappend" monoidCls+              wargs   = tyConAppArgs wrappedTy          -- [k, k, P]  (P may be Override2 …)+              kTy     = head wargs                      -- the kind k (Type here)+              dictCon = dataConWorkId (classDataCon catCls)+              app2 m t1 t2 = mkAppTy (mkAppTy m t1) t2+              instAt t1 t2 = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [t1, t2]))+              isKeep m = maybe False (\k -> tyConAppTyCon_maybe m == Just k) (geKeep gen)+              -- @Stock2 P a b ~R P a b@, then (if present) @Override2 cfg rp a b ~R rp a b@+              coDown t1 t2 = mkTransCo+                (mkUnbranchedAxInstCo Representational (newTyConCo st2Tc) (wargs ++ [t1, t2]) [])+                (case geOverride2 gen of+                   Just ov2Tc | tyConAppTyCon_maybe p0 == Just ov2Tc ->+                     mkUnbranchedAxInstCo Representational (newTyConCo ov2Tc)+                                          (tyConAppArgs p0 ++ [t1, t2]) []+                   _ -> mkRepReflCo (app2 realP t1 t2))+              cast' e co = if isReflCo co then e else Cast e co+          pTv <- freshTyVar "p" ; qTv <- freshTyVar "q"+          let realFtsPQ = instAt (mkTyVarTy pTv) (mkTyVarTy qTv)+              inPQ t = pTv `elemVarSet` tyCoVarsOfType t || qTv `elemVarSet` tyCoVarsOfType t+              -- per field: a Category @h@ (+ coercion), or a constant @m@ handled+              -- Const-style via its Monoid (the automatic, @Basic@-free path).+              resolve i ftPQ = case mMods of+                Just mods | Just m <- safeIdx mods i, not (isKeep m) ->+                  Just (CatF m (\t1 t2 -> mkStockCo (PluginProv "stock") Representational+                                                    (instAt t1 t2 !! i) (app2 m t1 t2)))+                _ -> case classifyCatField pTv qTv ftPQ of+                       Just h                    -> Just (CatF h (\t1 t2 -> mkRepReflCo (instAt t1 t2 !! i)))+                       Nothing | not (inPQ ftPQ) -> Just (MonF ftPQ)   -- constant ⇒ Monoid+                               | otherwise        -> Nothing           -- mentions a/b but not @h a b@+              badLen = maybe False ((/= length realFtsPQ) . length) mMods+          case if badLen then Nothing+               else traverse (uncurry resolve) (zip [0 :: Int ..] realFtsPQ) of+            Nothing   -> pure Nothing+            Just flds -> do+              -- per-field dictionary: @Category h@, or @Monoid m@ for a constant+              dws <- traverse (\fld -> case fld of+                       CatF h _ -> do ev <- newWanted loc (mkClassPred catCls [kTy, h])+                                      pure (ctEvExpr ev, mkNonCanonical ev)+                       MonF m   -> do ev <- newWanted loc (mkClassPred monoidCls [m])+                                      pure (ctEvExpr ev, mkNonCanonical ev)) flds+              let (dEs, dWs) = unzip dws+              -- id = /\a. (P <id of each field>..) |> sym (Stock2(..) a a ~ P a a)+              aTv <- freshTyVar "a"+              let aTy = mkTyVarTy aTv+                  idVal (CatF h coFn) dE = cast' (mkApps (Var idSel) [Type kTy, Type h, dE, Type aTy])+                                                 (mkSymCo (coFn aTy aTy))+                  idVal (MonF m)      dE = mkApps (Var memptySel) [Type m, dE]   -- id = mempty+                  idImpl = Lam aTv (Cast (mkCoreConApps dc (map Type (fixed ++ [aTy, aTy])+                                                            ++ zipWith idVal flds dEs))+                                         (mkSymCo (coDown aTy aTy)))+              -- (.) = /\b c a. \g h. case g|>co of P g.. -> case h|>co of P h.. -> (P (g.h)..)|>sym+              bTv <- freshTyVar "b" ; cTv <- freshTyVar "c" ; a2Tv <- freshTyVar "a"+              let bTy = mkTyVarTy bTv ; cTy = mkTyVarTy cTv ; a2Ty = mkTyVarTy a2Tv+                  resTy = mkAppTy (mkAppTy wrappedTy a2Ty) cTy   -- Stock2(..) a c+              gId <- freshId (mkAppTy (mkAppTy wrappedTy bTy) cTy) "g"+              hId <- freshId (mkAppTy (mkAppTy wrappedTy a2Ty) bTy) "h"+              gIds <- zipWithM (\n t -> freshId t ("g" ++ show n)) [0 :: Int ..] (instAt bTy cTy)+              hIds <- zipWithM (\n t -> freshId t ("h" ++ show n)) [0 :: Int ..] (instAt a2Ty bTy)+              gCb <- freshId (mkTyConApp pTc (fixed ++ [bTy, cTy]))  "gcb"+              hCb <- freshId (mkTyConApp pTc (fixed ++ [a2Ty, bTy])) "hcb"+              let compVal (CatF h coFn) dE gi hi =+                    cast' (mkApps (Var compSel)+                             [ Type kTy, Type h, dE, Type bTy, Type cTy, Type a2Ty+                             , cast' (Var gi) (coFn bTy cTy), cast' (Var hi) (coFn a2Ty bTy) ])+                          (mkSymCo (coFn a2Ty cTy))+                  compVal (MonF m)      dE gi hi =+                    mkApps (Var mappendSel) [Type m, dE, Var gi, Var hi]   -- g . h = g <> h+                  comps = zipWith4 compVal flds dEs gIds hIds+                  resCast = Cast (mkCoreConApps dc (map Type (fixed ++ [a2Ty, cTy]) ++ comps))+                                 (mkSymCo (coDown a2Ty cTy))+                  inner = Case (Cast (Var hId) (coDown a2Ty bTy)) hCb resTy [Alt (DataAlt dc) hIds resCast]+                  body  = Case (Cast (Var gId) (coDown bTy cTy))  gCb resTy [Alt (DataAlt dc) gIds inner]+                  compImpl = mkLams [bTv, cTv, a2Tv, gId, hId] body+                  dict = mkApps (Var dictCon) [Type kTy, Type wrappedTy, idImpl, compImpl]+              pure (Just (EvExpr dict, dWs))+    _ -> pure Nothing++-- | Total list indexing.+safeIdx :: [a] -> Int -> Maybe a+safeIdx xs i = if i >= 0 && i < length xs then Just (xs !! i) else Nothing+++-- | Synthesize @Bifoldable (Stock2 P)@.  @bifoldMap@ maps @a@-fields with the+-- first function, @b@-fields with the second, folds @h a@/@h b@ fields with+-- @h@'s own @foldMap@, drops constants, and combines with @(<>)@; all other+-- methods come from the class defaults.  No superclass (unlike @Bifunctor@).+synthBifoldable :: GenEnv -> Class -> CtLoc -> Type -> Type+                -> TcPluginM (Maybe (EvTerm, [Ct]))+synthBifoldable gen cls loc wrappedTy p =+  case (geStock2 gen, tyConAppTyCon_maybe realP) of+    (Just st2Tc, Just pTc) -> do+      monoidCls   <- tcLookupClass monoidClassName+      foldableCls <- tcLookupClass foldableClassName+      let fixed       = tyConAppArgs realP+          dcons       = tyConDataCons pTc+          foldMapSel   = classMethod "foldMap" foldableCls+          memptySel    = classMethod "mempty" monoidCls+          mappendSel   = classMethod "mappend" monoidCls+          coAt t1 t2   = coDown2With (geOverride2 gen) st2Tc wrappedTy p realP t1 t2+      mtv <- freshTyVar "m" ; atv <- freshTyVar "a" ; btv <- freshTyVar "b"+      let mTy = mkTyVarTy mtv ; aTy = mkTyVarTy atv ; bTy = mkTyVarTy btv+          innerAB = mkTyConApp pTc (fixed ++ [aTy, bTy])+      dM  <- freshId (mkClassPred monoidCls [mTy]) "dM"+      gA  <- freshId (mkVisFunTyMany aTy mTy) "gA"+      gB  <- freshId (mkVisFunTyMany bTy mTy) "gB"+      tId <- freshId (mkAppTy (mkAppTy wrappedTy aTy) bTy) "t"+      cb  <- freshId innerAB "cb"+      let memptyE      = mkApps (Var memptySel) [Type mTy, Var dM]+          mappendE x y = mkApps (Var mappendSel) [Type mTy, Var dM, x, y]+          -- fold an @h pTy@ field via the modifier @m@'s @foldMap@, casting the+          -- field value @h pTy ~R m pTy@ first.+          foldOver i h g pTy x = do+            let m = fromMaybe h (override1Mod gen mMods i)+            ev <- newWanted loc (mkClassPred foldableCls [m])+            pure (Just (Just ( mkApps (Var foldMapSel)+                                 [Type m, ctEvExpr ev, Type mTy, Type pTy, Var dM, Var g+                                 , castReshape (Var x) (reshapeCo h m pTy)]+                             , [mkNonCanonical ev] )))+          contrib i x ft = case classifyBiField atv btv aTy bTy ft of+            Nothing          -> pure Nothing+            Just BFConst     -> pure (Just Nothing)+            Just BFA         -> pure (Just (Just (App (Var gA) (Var x), [])))+            Just BFB         -> pure (Just (Just (App (Var gB) (Var x), [])))+            Just (BFFoldA h) -> foldOver i h gA aTy x+            Just (BFFoldB h) -> foldOver i h gB bTy x+      malts <- forM dcons \dc -> do+        let fts = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aTy, bTy]))+        xs  <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] fts+        mcs <- sequence (zipWith3 contrib [0 :: Int ..] xs fts)+        case sequence mcs of+          Nothing       -> pure Nothing+          Just contribs ->+            let (es, wss) = unzip (catMaybes contribs)+                body = if null es then memptyE else foldr1 mappendE es+            in pure (Just (Alt (DataAlt dc) xs body, concat wss))+      -- @bifoldr@ (so a lazy bi-fold does not fall back to the @Endo@ default,+      -- which drags the @Stock2@ coercion along).  @bifoldr f g z (Con .. xi ..)@+      -- nests a contribution per field around @z@: a constant passes the+      -- accumulator through; an @a@\/@b@ field is @f xi rest@\/@g xi rest@; an+      -- @h a@\/@h b@ field is @(\\b1 b2 -> foldr f b2 b1) xi rest@ (GHC's flip+      -- shape).  @bifoldr@'s forall order is @a c b@.  Skipped under @Override2@.+      let foldrSel = classMethod "foldr" foldableCls+          bidxOf nm = head [ i | (i, m) <- zip [0 :: Int ..] (classMethods cls)+                               , occNameString (occName m) == nm ]+      rcTv <- freshTyVar "c" ; raTv <- freshTyVar "a" ; rbTv <- freshTyVar "b"+      let rcTy = mkTyVarTy rcTv ; raTy = mkTyVarTy raTv ; rbTy = mkTyVarTy rbTv+      rfId <- freshId (mkVisFunTyMany raTy (mkVisFunTyMany rcTy rcTy)) "f"+      rgId <- freshId (mkVisFunTyMany rbTy (mkVisFunTyMany rcTy rcTy)) "g"+      rzId <- freshId rcTy "z"+      rtId <- freshId (mkAppTy (mkAppTy wrappedTy raTy) rbTy) "t"+      rcb  <- freshId (mkTyConApp pTc (fixed ++ [raTy, rbTy])) "cb"+      let foldrField h fn elemTy x k = do+            ev <- newWanted loc (mkClassPred foldableCls [h])+            b1 <- freshId (mkAppTy h elemTy) "b1" ; b2 <- freshId rcTy "b2"+            let flipLam = mkLams [b1, b2] (mkApps (Var foldrSel)+                  [Type h, ctEvExpr ev, Type elemTy, Type rcTy, Var fn, Var b2, Var b1])+            pure (Just (mkApps flipLam [Var x, k], [mkNonCanonical ev]))+          contribBR x ft k = case classifyBiField raTv rbTv raTy rbTy ft of+            Nothing          -> pure Nothing+            Just BFConst     -> pure (Just (k, []))+            Just BFA         -> pure (Just (mkApps (Var rfId) [Var x, k], []))+            Just BFB         -> pure (Just (mkApps (Var rgId) [Var x, k], []))+            Just (BFFoldA h) -> foldrField h rfId raTy x k+            Just (BFFoldB h) -> foldrField h rgId rbTy x k+          combineBR []            k = pure (Just (k, []))+          combineBR ((ft, x) : r) k = do+            mr <- combineBR r k+            case mr of+              Nothing       -> pure Nothing+              Just (k', w') -> do mc <- contribBR x ft k'+                                  pure (fmap (\(e, w) -> (e, w ++ w')) mc)+      mBiFoldrAlts <- if isJust mMods then pure Nothing else fmap sequence $ forM dcons \dc -> do+        let fts = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [raTy, rbTy]))+        xs <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] fts+        mb <- combineBR (zip fts xs) (Var rzId)+        pure (fmap (\(body, w) -> (Alt (DataAlt dc) xs body, w)) mb)+      case sequence malts of+        Nothing     -> pure Nothing+        Just altWss -> do+          let (alts, wss) = unzip altWss+              biFoldMapImpl = mkLams [mtv, atv, btv, dM, gA, gB, tId]+                (destructInner pTc (fixed ++ [aTy, bTy])+                               (Cast (Var tId) (coAt aTy bTy)) cb mTy alts)+              (biFoldrMethods, biFoldrWs) = case mBiFoldrAlts of+                Just altWs ->+                  let (rAlts, rWss) = unzip altWs+                      biFoldrImpl = mkLams [raTv, rcTv, rbTv, rfId, rgId, rzId, rtId]+                        (destructInner pTc (fixed ++ [raTy, rbTy])+                                       (Cast (Var rtId) (coAt raTy rbTy)) rcb rcTy rAlts)+                  in ([(bidxOf "bifoldr", biFoldrImpl)], concat rWss)+                Nothing -> ([], [])+          dict <- recDictWith cls wrappedTy []+                    ((bidxOf "bifoldMap", biFoldMapImpl) : biFoldrMethods)+          pure (Just (EvExpr dict, concat wss ++ biFoldrWs))+    _ -> pure Nothing+  where (realP, mMods) = peelOverride2With (ovTcsGen "Override2" gen) p++-- | Synthesize @Bitraversable (Stock2 P)@, directly (not by coercion — like+-- @Traversable@, @bitraverse@'s result @f (t c d)@ puts the wrapper under an+-- abstract applicative, so DerivingVia can't coerce it onto @P@; the instance+-- is usable at @Stock2 P@ / via the one-liner).  Per constructor,+-- @pure mkCon \<*\> f1 \<*\> …@: an @a@\/@b@ field uses the supplied function,+-- a constant uses @pure@, and an @h a@\/@h b@ field uses @traverse \@h@ (an+-- @Override2@-reshaped functor goes through the modifier, re-wrapped with+-- @pure coerce \<*\> _@).  @Bifunctor@ and @Bifoldable@ superclasses come from+-- their own synthesizers.+synthBitraversable :: GenEnv -> Class -> CtLoc -> Type -> Type+                   -> TcPluginM (Maybe (EvTerm, [Ct]))+synthBitraversable gen bitravCls loc wrappedTy p =+  case (geStock2 gen, tyConAppTyCon_maybe realP) of+    (Just st2Tc, Just pTc) -> do+      appCls  <- tcLookupClass applicativeClassName+      travCls <- tcLookupClass traversableClassName+      let fixed = tyConAppArgs realP+          dcons = tyConDataCons pTc+          traverseSel = classMethod "traverse" travCls+          pureSel     = classMethod "pure" appCls+          apSel       = classMethod "<*>"  appCls+          coAt t1 t2  = coDown2With (geOverride2 gen) st2Tc wrappedTy p realP t1 t2+      fTv <- freshTyVarK (mkVisFunTyMany liftedTypeKind liftedTypeKind) "f"   -- f :: Type -> Type+      aTv <- freshTyVar "a" ; cTv <- freshTyVar "c"+      bTv <- freshTyVar "b" ; dTv <- freshTyVar "d"           -- bitraverse: forall f a c b d+      let fTy = mkTyVarTy fTv+          aTy = mkTyVarTy aTv ; cTy = mkTyVarTy cTv+          bTy = mkTyVarTy bTv ; dTy = mkTyVarTy dTv+          fOf t   = mkAppTy fTy t+          innerAB = mkTyConApp pTc (fixed ++ [aTy, bTy])+          stcdTy  = mkAppTy (mkAppTy wrappedTy cTy) dTy        -- Stock2 P c d+      dApp <- freshId (mkClassPred appCls [fTy]) "dApp"+      gA   <- freshId (mkVisFunTyMany aTy (fOf cTy)) "gA"      -- a -> f c+      gB   <- freshId (mkVisFunTyMany bTy (fOf dTy)) "gB"      -- b -> f d+      tId  <- freshId (mkAppTy (mkAppTy wrappedTy aTy) bTy) "t"+      cb   <- freshId innerAB "cb"+      let pureE ty e        = mkApps (Var pureSel) [Type fTy, Var dApp, Type ty, e]+          apE tyA tyB ac fe = mkApps (Var apSel)   [Type fTy, Var dApp, Type tyA, Type tyB, ac, fe]+          -- traverse a sub-functor @h@ field at (inParam → outParam) with @g@;+          -- under Override2 reshape @h → m@, re-wrap @m out -> h out@.+          travField i h g inTy outTy x = case override1Mod gen mMods i of+            Nothing -> do+              ev <- newWanted loc (mkClassPred travCls [h])+              pure (Just ( mkApps (Var traverseSel)+                             [Type h, ctEvExpr ev, Type fTy, Type inTy, Type outTy+                             , Var dApp, Var g, Var x]                       -- :: f (h out)+                         , [mkNonCanonical ev] ))+            Just m -> do+              ev <- newWanted loc (mkClassPred travCls [m])+              let trav = mkApps (Var traverseSel)+                           [Type m, ctEvExpr ev, Type fTy, Type inTy, Type outTy+                           , Var dApp, Var g, castReshape (Var x) (reshapeCo h m inTy)]  -- f (m out)+                  hOut = mkAppTy h outTy ; mOut = mkAppTy m outTy+              mo <- freshId mOut "mo"+              let coerceFn = Lam mo (castReshape (Var mo) (reshapeCo m h outTy))          -- m out -> h out+              pure (Just ( apE mOut hOut (pureE (mkVisFunTyMany mOut hOut) coerceFn) trav+                         , [mkNonCanonical ev] ))+          fieldOf i x ftA = case classifyBiField aTv bTv aTy bTy ftA of+            Nothing          -> pure Nothing+            Just BFConst     -> pure (Just (pureE ftA (Var x), []))+            Just BFA         -> pure (Just (App (Var gA) (Var x), []))+            Just BFB         -> pure (Just (App (Var gB) (Var x), []))+            Just (BFFoldA h) -> travField i h gA aTy cTy x+            Just (BFFoldB h) -> travField i h gB bTy dTy x+      malts <- forM dcons \dc -> do+        let fts   = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aTy, bTy]))+            rvFts = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [cTy, dTy]))+        xs   <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] fts+        mfes <- sequence (zipWith3 fieldOf [0 :: Int ..] xs fts)+        case sequence mfes of+          Nothing  -> pure Nothing+          Just fes -> do+            let (fieldExprs, wss) = unzip fes+            ys <- zipWithM (\n ft -> freshId ft ("y" ++ show n)) [0 :: Int ..] rvFts+            let mkCon = mkLams ys (Cast (mkCoreConApps dc (map Type (fixed ++ [cTy, dTy]) ++ map Var ys))+                                        (mkSymCo (coAt cTy dTy)))+                rs    = scanr mkVisFunTyMany stcdTy rvFts+                body  = foldl (\ac (k, fe, rvFt) -> apE rvFt (rs !! (k + 1)) ac fe)+                              (pureE (head rs) mkCon)+                              (zip3 [0 :: Int ..] fieldExprs rvFts)+            pure (Just (Alt (DataAlt dc) xs body, concat wss))+      case sequence malts of+        Nothing     -> pure Nothing+        Just altWss -> do+          let (alts, wss) = unzip altWss+              bitraverseImpl = mkLams [fTv, aTv, cTv, bTv, dTv, dApp, gA, gB, tId]+                (destructInner pTc (fixed ++ [aTy, bTy]) (Cast (Var tId) (coAt aTy bTy)) cb (fOf stcdTy) alts)+              -- superclasses (Bifunctor, Bifoldable) in classSCTheta order+              superClss = [ c | pr <- classSCTheta bitravCls, ClassPred c _ <- [classifyPredType pr] ]+          superDictsM <- forM superClss \c ->+            case occNameString (nameOccName (className c)) of+              "Bifunctor"  -> synthBifunctor  gen c loc wrappedTy p+              "Bifoldable" -> synthBifoldable gen c loc wrappedTy p+              _            -> pure Nothing+          case sequence superDictsM of+            Nothing  -> pure Nothing+            Just sds -> do+              dict <- recDictWith bitravCls wrappedTy (map (unwrapEv . fst) sds) [(0, bitraverseImpl)]+              pure (Just (EvExpr dict, concatMap snd sds ++ concat wss))+    _ -> pure Nothing+  where (realP, mMods) = peelOverride2With (ovTcsGen "Override2" gen) p++-- | Synthesize @Bifunctor (Stock2 P)@.  @bimap@ maps @a@-fields with the first+-- function and @b@-fields with the second; @first@/@second@ come from the class+-- defaults.  @Bifunctor@ has a quantified superclass @forall a. Functor (p a)@,+-- which we supply by synthesizing the @Functor (Stock2 P a)@ dictionary under a+-- type-lambda (the @Functor@ maps the second parameter).+synthBifunctor :: GenEnv -> Class -> CtLoc -> Type -> Type+               -> TcPluginM (Maybe (EvTerm, [Ct]))+synthBifunctor gen cls loc wrappedTy p =+  case (geStock2 gen, tyConAppTyCon_maybe realP) of+    (Just st2Tc, Just pTc) -> do+      functorCls <- tcLookupClass functorClassName+      let fixed     = tyConAppArgs realP+          dcons     = tyConDataCons pTc+          bimapSel  = classMethod "bimap" cls             -- bimap+          coAt t1 t2 = coDown2With (geOverride2 gen) st2Tc wrappedTy p realP t1 t2+      apTv <- freshTyVar "a'" ; aTv <- freshTyVar "a"+      bpTv <- freshTyVar "b'" ; bTv <- freshTyVar "b"+      let apTy = mkTyVarTy apTv ; aTy = mkTyVarTy aTv+          bpTy = mkTyVarTy bpTv ; bTy = mkTyVarTy bTv+          innerAB = mkTyConApp pTc (fixed ++ [aTy, bTy])+      gA  <- freshId (mkVisFunTyMany aTy apTy) "gA"        -- a -> a'+      gB  <- freshId (mkVisFunTyMany bTy bpTy) "gB"        -- b -> b'+      sf  <- freshId (mkAppTy (mkAppTy wrappedTy aTy) bTy) "sf"+      cb  <- freshId innerAB "cb"+      -- map one field (instantiated at [a,b]) to its [a',b'] image — the+      -- n-ary variance engine at [Co, Co], so it also descends through arrows+      -- and nested functors (e.g. @[Either Int b]@) that the flat+      -- 'classifyBiField' cannot.  Contravariant occurrences of a (covariant)+      -- parameter have no mapper, so they fail cleanly (no @mContra@).+      let bimapParams = [ (aTv, apTy, Just (Var gA), Nothing)+                        , (bTv, bpTy, Just (Var gB), Nothing) ]+          -- a nested @q a b@ field: recurse via @q@'s own @bimap@ (so e.g.+          -- @Either a b@ / @(a, b)@ fields work, beyond the flat classifier).+          selfBi q = do+            ev <- newWanted loc (mkClassPred cls [q])+            pure (Just ( mkApps (Var bimapSel)+                           [ Type q, ctEvExpr ev, Type aTy, Type apTy, Type bTy, Type bpTy+                           , Var gA, Var gB ]+                       , [mkNonCanonical ev] ))+          -- a plain field: map it pointwise with the n-ary engine.+          mapPlain x ft = do+            m <- varMapN functorCls Nothing loc bimapParams (Just selfBi) Cov ft+            pure (fmap (\(e, ws) -> (App e (Var x), ws)) m)+          -- under @Override2@, an @h a@/@h b@ field is reshaped to @mod a@/@mod b@:+          -- map via @mod@'s @fmap@ on the coerced value, then coerce the result back.+          mapField i x ft = case (override1Mod gen mMods i, classifyBiField aTv bTv aTy bTy ft) of+            (Just mod_, Just (BFFoldA h)) -> mapVia mod_ h x aTy apTy+            (Just mod_, Just (BFFoldB h)) -> mapVia mod_ h x bTy bpTy+            _                             -> mapPlain x ft+          mapVia mod_ h x inTy outTy = do+            m <- varMapN functorCls Nothing loc bimapParams (Just selfBi) Cov (mkAppTy mod_ inTy)+            pure $ flip fmap m \(e, ws) ->+              ( Cast (App e (castReshape (Var x) (reshapeCo h mod_ inTy))) (mkSymCo (reshapeCo h mod_ outTy)), ws )+      malts <- forM dcons \dc -> do+        let fts = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aTy, bTy]))+        xs  <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] fts+        mfs <- sequence (zipWith3 mapField [0 :: Int ..] xs fts)+        case sequence mfs of+          Nothing    -> pure Nothing+          Just pairs ->+            let (vals, wss) = unzip pairs+                body = Cast (mkCoreConApps dc (map Type (fixed ++ [apTy, bpTy]) ++ vals))+                            (mkSymCo (coAt apTy bpTy))+            in pure (Just (Alt (DataAlt dc) xs body, concat wss))+      case sequence malts of+        Nothing     -> pure Nothing+        Just altWss -> do+          let (alts, wss) = unzip altWss+              -- bimap quantifies @forall a b c d@: (a->b) maps the first param,+              -- (c->d) the second.  So the binder order is input1,output1,input2,output2.+              bimapImpl = mkLams [aTv, apTv, bTv, bpTv, gA, gB, sf]+                (destructInner pTc (fixed ++ [aTy, bTy]) (Cast (Var sf) (coAt aTy bTy))+                               cb (mkAppTy (mkAppTy wrappedTy apTy) bpTy) alts)+          dmFirst  <- defMethId cls 1                       -- first+          dmSecond <- defMethId cls 2                       -- second+          fdmConst <- defMethId functorCls 1                -- Functor's (<$)+          -- The superclass  forall a. Functor (Stock2 P a)  is just @fmap = bimap+          -- id@ (a Bifunctor law): under @/\sc@ we build a @Functor (Stock2 P sc)@+          -- dictionary whose @fmap g = bimap id g@, reusing the Bifunctor dict.+          sctv  <- freshTyVar "sc"+          b2tv  <- freshTyVar "b" ; b2ptv <- freshTyVar "b'"+          zId   <- freshId (mkTyVarTy sctv) "z"+          g2Id  <- freshId (mkVisFunTyMany (mkTyVarTy b2tv) (mkTyVarTy b2ptv)) "g2"+          x2Id  <- freshId (mkAppTy wrappedTy (mkTyVarTy sctv) `mkAppTy` mkTyVarTy b2tv) "x2"+          dict <- recClassDict cls wrappedTy \dvar -> do+            let scTy   = mkTyVarTy sctv+                idA    = Lam zId (Var zId)                  -- id @sc+                -- fmap g x = bimap @(Stock2 P) dvar @sc @sc @b @b' id g x+                fmapSC = mkLams [b2tv, b2ptv, g2Id, x2Id] $+                  mkApps (Var bimapSel)+                    [ Type wrappedTy, Var dvar+                    , Type scTy, Type scTy, Type (mkTyVarTy b2tv), Type (mkTyVarTy b2ptv)+                    , idA, Var g2Id, Var x2Id ]+            supDict <- recClassDict functorCls (mkAppTy wrappedTy scTy) \fdvar ->+                         pure [ fmapSC+                              , mkApps (Var fdmConst) [Type (mkAppTy wrappedTy scTy), Var fdvar] ]+            pure [ Lam sctv supDict+                 , bimapImpl+                 , mkApps (Var dmFirst)  [Type wrappedTy, Var dvar]+                 , mkApps (Var dmSecond) [Type wrappedTy, Var dvar] ]+          pure (Just (EvExpr dict, concat wss))+    _ -> pure Nothing+  where (realP, mMods) = peelOverride2With (ovTcsGen "Override2" gen) p++-- | A fresh kind-@Type@ type variable (for the @forall a b@ in @fmap@).++-- | The @Stock2@ counterpart of 'zipLift2': walk two values of the same+-- @Stock2 P@ shape (@fa :: P a c@, @fb :: P b d@) in lock-step, combining the+-- per-field-pair results of matching constructors.  Shared by @liftEq2@+-- (short-circuit conjunction) and @liftCompare2@ (lexicographic).+zipLiftBi :: TyCon -> [Type] -> (Type -> Type -> Coercion)+          -> (Type, Type) -> (Type, Type) -> Type   -- (a,c) for fa, (b,d) for fb, result+          -> Id -> Id                                -- the two scrutinees+          -> (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]))+zipLiftBi pTc fixed coAt2 (aTy, cTy) (bTy, dTy) resTy faId fbId mismatch combine fieldOp = do+  let dcons         = tyConDataCons pTc+      fieldsBi dc t1 t2 = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [t1, t2]))+      freshF dc t1 t2   = zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] (fieldsBi dc t1 t2)+      indexed       = zip [0 :: Int ..] dcons+  mInner <- forM indexed \(i, dci) -> do+    xs    <- freshF dci aTy cTy+    mAlts <- forM indexed \(j, dcj) -> do+      ys <- freshF dcj bTy dTy+      if i /= j+        then pure (Just (Alt (DataAlt dcj) ys (mismatch i j), []))+        else do+          mops <- sequence (zipWith4 fieldOp [0 :: Int ..] (fieldsBi dci aTy cTy) xs ys)+          case sequence mops of+            Nothing  -> pure Nothing+            Just ows -> do body <- combine (map fst ows)+                           pure (Just (Alt (DataAlt dcj) ys body, concatMap snd ows))+    case sequence mAlts of+      Nothing     -> pure Nothing+      Just altWss -> do+        let (alts, wss) = unzip altWss+        cbB <- freshId (mkTyConApp pTc (fixed ++ [bTy, dTy])) "cbb"+        pure (Just ( Alt (DataAlt dci) xs+                       (destructInner pTc (fixed ++ [bTy, dTy]) (Cast (Var fbId) (coAt2 bTy dTy)) cbB resTy alts)+                   , concat wss ))+  case sequence mInner of+    Nothing     -> pure Nothing+    Just altWss -> do+      let (alts, wss) = unzip altWss+      cbA <- freshId (mkTyConApp pTc (fixed ++ [aTy, cTy])) "cba"+      pure (Just ( destructInner pTc (fixed ++ [aTy, cTy]) (Cast (Var faId) (coAt2 aTy cTy)) cbA resTy alts+                 , concat wss ))++-- | The superclass evidence for @C2 (Stock2 P)@: each entry of @C2@'s+-- @classSCTheta@ instantiated at the via-target and requested as a wanted+-- (discharged by the plugin: lifted built-ins, or the @Stock2@ passthrough).+stock2Supers :: Class -> Type -> CtLoc -> TcPluginM ([CoreExpr], [Ct])+stock2Supers cls wrappedTy loc = do+  let subst = case classTyVars cls of+                (tv : _) -> zipTvSubst [tv] [wrappedTy]+                _        -> emptySubst+  evs <- forM (map (substTy subst) (classSCTheta cls)) (newWanted loc)+  pure (map ctEvExpr evs, map mkNonCanonical evs)++-- | Synthesize @Eq2 (Stock2 P)@: @liftEq2@ is same-constructor-and-all-fields,+-- with @a@-fields compared by the first function, @b@-fields by the second,+-- @h a@\/@h b@ fields by @liftEq@, constants by @(==)@.+-- Override2 is transparent for Eq2: a hashing/forcing modifier does not change+-- structural equality, so peel the wrapper and compare the real fields.  (This+-- makes @deriving Hashable2 via Overriding2 …@ work: its @Eq2@ superclass is+-- dragged through the same config.)+synthEq2 :: GenEnv -> Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))+synthEq2 gen eq2Cls loc wrappedTy p0 =+  case (geStock2 gen, tyConAppTyCon_maybe realP) of+    (Just st2Tc, Just pTc) -> do+      eqCls <- tcLookupClass eqClassName+      mEq1  <- lookupClassMaybe "Data.Functor.Classes" "Eq1"+      case mEq1 of+        Nothing     -> pure Nothing+        Just eq1Cls -> do+          let fixed      = tyConAppArgs realP+              liftEqSel  = classMethod "liftEq" eq1Cls+              eqSel      = classMethod "==" eqCls+              true_      = Var (dataConWorkId trueDataCon)+              false_     = Var (dataConWorkId falseDataCon)+              coAt2 t1 t2 = coDown2With (geOverride2 gen) st2Tc wrappedTy p0 realP t1 t2+          aTv <- freshTyVar "a" ; bTv <- freshTyVar "b" ; cTv <- freshTyVar "c" ; dTv <- freshTyVar "d"+          let aTy = mkTyVarTy aTv ; bTy = mkTyVarTy bTv ; cTy = mkTyVarTy cTv ; dTy = mkTyVarTy dTv+          eqAB <- freshId (mkVisFunTyMany aTy (mkVisFunTyMany bTy boolTy)) "eqAB"+          eqCD <- freshId (mkVisFunTyMany cTy (mkVisFunTyMany dTy boolTy)) "eqCD"+          faId <- freshId (mkAppTy (mkAppTy wrappedTy aTy) cTy) "fa"+          fbId <- freshId (mkAppTy (mkAppTy wrappedTy bTy) dTy) "fb"+          let conj []         = pure true_+              conj (e : more)  = do rest <- conj more+                                    scr  <- freshId boolTy "c"+                                    pure (Case e scr boolTy [ Alt (DataAlt falseDataCon) [] false_+                                                            , Alt (DataAlt trueDataCon)  [] rest ])+              fieldOp i ft x y = case classifyBiField aTv cTv aTy cTy ft of+                Nothing          -> pure Nothing+                Just BFA         -> pure (Just (mkApps (Var eqAB) [Var x, Var y], []))+                Just BFB         -> pure (Just (mkApps (Var eqCD) [Var x, Var y], []))+                Just BFConst     -> do ev <- newWanted loc (mkClassPred eqCls [ft])+                                       pure (Just (mkApps (Var eqSel) [Type ft, ctEvExpr ev, Var x, Var y], [mkNonCanonical ev]))+                Just (BFFoldA h) -> do let m = fromMaybe h (override1Mod gen mMods i)+                                       ev <- newWanted loc (mkClassPred eq1Cls [m])+                                       pure (Just (mkApps (Var liftEqSel) [Type m, ctEvExpr ev, Type aTy, Type bTy, Var eqAB, castReshape (Var x) (reshapeCo h m aTy), castReshape (Var y) (reshapeCo h m bTy)], [mkNonCanonical ev]))+                Just (BFFoldB h) -> do let m = fromMaybe h (override1Mod gen mMods i)+                                       ev <- newWanted loc (mkClassPred eq1Cls [m])+                                       pure (Just (mkApps (Var liftEqSel) [Type m, ctEvExpr ev, Type cTy, Type dTy, Var eqCD, castReshape (Var x) (reshapeCo h m cTy), castReshape (Var y) (reshapeCo h m dTy)], [mkNonCanonical ev]))+          mBody <- zipLiftBi pTc fixed coAt2 (aTy, cTy) (bTy, dTy) boolTy faId fbId (\_ _ -> false_) conj fieldOp+          case mBody of+            Nothing        -> pure Nothing+            Just (body, ws) -> do+              (supers, scWs) <- stock2Supers eq2Cls wrappedTy loc+              let impl = mkLams [aTv, bTv, cTv, dTv, eqAB, eqCD, faId, fbId] body+              pure (Just (EvExpr (mkClassDict eq2Cls wrappedTy (supers ++ [impl])), scWs ++ ws))+    _ -> pure Nothing+  where (realP, mMods) = peelOverride2With (ovTcsGen "Override2" gen) p0++-- | Synthesize @Ord2 (Stock2 P)@: @liftCompare2@ orders by constructor tag,+-- then lexicographically by fields (first-param fields by the first function,+-- second by the second, @h a@\/@h b@ by @liftCompare@, constants by @compare@).+synthOrd2 :: GenEnv -> Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))+synthOrd2 gen ord2Cls loc wrappedTy p =+  case (geStock2 gen, tyConAppTyCon_maybe realP) of+    (Just st2Tc, Just pTc) -> do+      ordCls <- tcLookupClass ordClassName+      mOrd1  <- lookupClassMaybe "Data.Functor.Classes" "Ord1"+      case mOrd1 of+        Nothing      -> pure Nothing+        Just ord1Cls -> do+          let fixed       = tyConAppArgs realP+              liftCmpSel  = classMethod "liftCompare" ord1Cls+              cmpSel      = classMethod "compare" ordCls+              ordTy       = mkTyConTy orderingTyCon+              [ltC, eqC, gtC] = tyConDataCons orderingTyCon+              ltE = Var (dataConWorkId ltC) ; eqE = Var (dataConWorkId eqC) ; gtE = Var (dataConWorkId gtC)+              coAt2 t1 t2 = coDown2With (geOverride2 gen) st2Tc wrappedTy p realP t1 t2+          aTv <- freshTyVar "a" ; bTv <- freshTyVar "b" ; cTv <- freshTyVar "c" ; dTv <- freshTyVar "d"+          let aTy = mkTyVarTy aTv ; bTy = mkTyVarTy bTv ; cTy = mkTyVarTy cTv ; dTy = mkTyVarTy dTv+          cmpAB <- freshId (mkVisFunTyMany aTy (mkVisFunTyMany bTy ordTy)) "cmpAB"+          cmpCD <- freshId (mkVisFunTyMany cTy (mkVisFunTyMany dTy ordTy)) "cmpCD"+          faId  <- freshId (mkAppTy (mkAppTy wrappedTy aTy) cTy) "fa"+          fbId  <- freshId (mkAppTy (mkAppTy wrappedTy bTy) dTy) "fb"+          let lexCmp []         = pure eqE+              lexCmp (e : more)  = do rest <- lexCmp more+                                      scr  <- freshId ordTy "o"+                                      pure (Case e scr ordTy [ Alt (DataAlt ltC) [] ltE+                                                             , Alt (DataAlt eqC) [] rest+                                                             , Alt (DataAlt gtC) [] gtE ])+              fieldOp i ft x y = case classifyBiField aTv cTv aTy cTy ft of+                Nothing          -> pure Nothing+                Just BFA         -> pure (Just (mkApps (Var cmpAB) [Var x, Var y], []))+                Just BFB         -> pure (Just (mkApps (Var cmpCD) [Var x, Var y], []))+                Just BFConst     -> do ev <- newWanted loc (mkClassPred ordCls [ft])+                                       pure (Just (mkApps (Var cmpSel) [Type ft, ctEvExpr ev, Var x, Var y], [mkNonCanonical ev]))+                Just (BFFoldA h) -> do let m = fromMaybe h (override1Mod gen mMods i)+                                       ev <- newWanted loc (mkClassPred ord1Cls [m])+                                       pure (Just (mkApps (Var liftCmpSel) [Type m, ctEvExpr ev, Type aTy, Type bTy, Var cmpAB, castReshape (Var x) (reshapeCo h m aTy), castReshape (Var y) (reshapeCo h m bTy)], [mkNonCanonical ev]))+                Just (BFFoldB h) -> do let m = fromMaybe h (override1Mod gen mMods i)+                                       ev <- newWanted loc (mkClassPred ord1Cls [m])+                                       pure (Just (mkApps (Var liftCmpSel) [Type m, ctEvExpr ev, Type cTy, Type dTy, Var cmpCD, castReshape (Var x) (reshapeCo h m cTy), castReshape (Var y) (reshapeCo h m dTy)], [mkNonCanonical ev]))+          mBody <- zipLiftBi pTc fixed coAt2 (aTy, cTy) (bTy, dTy) ordTy faId fbId+                             (\i j -> if i < j then ltE else gtE) lexCmp fieldOp+          case mBody of+            Nothing        -> pure Nothing+            Just (body, ws) -> do+              (supers, scWs) <- stock2Supers ord2Cls wrappedTy loc+              let impl = mkLams [aTv, bTv, cTv, dTv, cmpAB, cmpCD, faId, fbId] body+              pure (Just (EvExpr (mkClassDict ord2Cls wrappedTy (supers ++ [impl])), scWs ++ ws))+    _ -> pure Nothing+  where (realP, mMods) = peelOverride2With (ovTcsGen "Override2" gen) p++-- | Synthesize @Show2 (Stock2 P)@: @liftShowsPrec2@ renders like derived @Show@+-- (prefix / infix / record, precedence-parenthesised) but shows a first-param+-- field with @spA@, a second with @spB@, an @h a@\/@h b@ field with+-- @liftShowsPrec@, a constant with its own @showsPrec@.+synthShow2 :: GenEnv -> Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))+synthShow2 gen show2Cls loc wrappedTy p =+  case (geStock2 gen, tyConAppTyCon_maybe realP) of+    (Just st2Tc, Just pTc) -> do+      mShow1 <- lookupClassMaybe "Data.Functor.Classes" "Show1"+      case mShow1 of+        Nothing       -> pure Nothing+        Just show1Cls -> do+          showCls  <- lookupOrig gHC_INTERNAL_SHOW (mkTcOcc "Show") >>= tcLookupClass+          ordCls   <- tcLookupClass ordClassName+          appendId <- tcLookupId appendName+          let fixed       = tyConAppArgs realP+              dcons       = tyConDataCons pTc+              showSTy     = mkVisFunTyMany stringTy stringTy+              liftSpSel   = classMethod "liftShowsPrec" show1Cls+              showsPrecSel = classMethod "showsPrec" showCls+              gtSel       = classMethod ">" ordCls+              coAt2 t1 t2 = coDown2With (geOverride2 gen) st2Tc wrappedTy p realP t1 t2+              cons c t    = mkCoreConApps consDataCon [Type charTy, c, t]+              append s t  = mkApps (Var appendId) [Type charTy, s, t]+              str s       = unsafeTcPluginTcM (mkStringExprFS (fsLit s))+          ordIntEv <- newWanted loc (mkClassPred ordCls [intTy])+          let ordIntDict = ctEvExpr ordIntEv+          aTv <- freshTyVar "a" ; bTv <- freshTyVar "b"+          let aTy = mkTyVarTy aTv ; bTy = mkTyVarTy bTv+              spTyOf t = mkVisFunTyMany intTy (mkVisFunTyMany t showSTy)+              slTyOf t = mkVisFunTyMany (mkListTy t) showSTy+          spA <- freshId (spTyOf aTy) "spA" ; slA <- freshId (slTyOf aTy) "slA"+          spB <- freshId (spTyOf bTy) "spB" ; slB <- freshId (slTyOf bTy) "slB"+          dId <- freshId intTy "d" ; vId <- freshId (mkAppTy (mkAppTy wrappedTy aTy) bTy) "v"+          let mkRenderer i ft xi = case classifyBiField aTv bTv aTy bTy ft of+                Nothing          -> pure Nothing+                Just BFA         -> pure (Just (\pr -> mkApps (Var spA) [mkUncheckedIntExpr pr, Var xi], []))+                Just BFB         -> pure (Just (\pr -> mkApps (Var spB) [mkUncheckedIntExpr pr, Var xi], []))+                Just BFConst     -> do ev <- newWanted loc (mkClassPred showCls [ft])+                                       pure (Just (\pr -> mkApps (Var showsPrecSel) [Type ft, ctEvExpr ev, mkUncheckedIntExpr pr, Var xi], [mkNonCanonical ev]))+                Just (BFFoldA h) -> do let m = fromMaybe h (override1Mod gen mMods i)+                                       ev <- newWanted loc (mkClassPred show1Cls [m])+                                       pure (Just (\pr -> mkApps (Var liftSpSel) [Type m, ctEvExpr ev, Type aTy, Var spA, Var slA, mkUncheckedIntExpr pr, castReshape (Var xi) (reshapeCo h m aTy)], [mkNonCanonical ev]))+                Just (BFFoldB h) -> do let m = fromMaybe h (override1Mod gen mMods i)+                                       ev <- newWanted loc (mkClassPred show1Cls [m])+                                       pure (Just (\pr -> mkApps (Var liftSpSel) [Type m, ctEvExpr ev, Type bTy, Var spB, Var slB, mkUncheckedIntExpr pr, castReshape (Var xi) (reshapeCo h m bTy)], [mkNonCanonical ev]))+          mAltWss <- forM dcons \dc -> do+            let fts    = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aTy, bTy]))+                name   = occNameString (getOccName dc)+                labels = map (occNameString . nameOccName . flSelector) (dataConFieldLabels dc)+            nameStr <- str name+            xs      <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] fts+            rest    <- freshId stringTy "r"+            gtBndr  <- freshId boolTy "pb"+            prec    <- conPrec dc+            mRends  <- sequence (zipWith3 mkRenderer [0 :: Int ..] fts xs)+            case sequence mRends of+              Nothing    -> pure Nothing+              Just rends -> do+                let (renderers, wss) = unzip rends+                    parenAt thr mk t =+                      Case (mkApps (Var gtSel) [Type intTy, ordIntDict, Var dId, mkUncheckedIntExpr thr])+                           gtBndr stringTy+                        [ Alt (DataAlt falseDataCon) [] (mk t)+                        , Alt (DataAlt trueDataCon)  [] (cons (mkCharExpr '(') (mk (cons (mkCharExpr ')') t))) ]+                    goPrefix t   = foldr (\r acc -> cons (mkCharExpr ' ') (App (r 11) acc)) t renderers+                    prefixBody t = append nameStr (goPrefix t)+                body <-+                  if dataConIsInfix dc+                    then do opStr <- str (" " ++ name ++ " ")+                            let [l, r] = renderers+                                mk t = App (l (prec + 1)) (append opStr (App (r (prec + 1)) t))+                            pure (parenAt prec mk (Var rest))+                    else if not (null labels)+                      then do openB <- str " {" ; eqB <- str " = " ; commaB <- str ", " ; closeB <- str "}"+                              lblStrs <- mapM str labels+                              let recF = zip lblStrs renderers+                                  goRec [(lbl, r)] c     = append lbl (append eqB (App (r 0) (append closeB c)))+                                  goRec ((lbl, r) : m) c = append lbl (append eqB (App (r 0) (append commaB (goRec m c))))+                                  goRec [] c             = append closeB c+                                  recBody t = append nameStr (append openB (goRec recF t))+                              pure (parenAt 10 recBody (Var rest))+                      else if null xs then pure (append nameStr (Var rest))+                                      else pure (parenAt 10 prefixBody (Var rest))+                pure (Just (Alt (DataAlt dc) xs (Lam rest body), concat wss))+          case sequence mAltWss of+            Nothing     -> pure Nothing+            Just altWss -> do+              let (alts, wss) = unzip altWss+              cb <- freshId (mkTyConApp pTc (fixed ++ [aTy, bTy])) "cb"+              let impl = mkLams [aTv, bTv, spA, slA, spB, slB, dId, vId]+                           (destructInner pTc (fixed ++ [aTy, bTy]) (Cast (Var vId) (coAt2 aTy bTy)) cb showSTy alts)+              (supers, scWs) <- stock2Supers show2Cls wrappedTy loc+              dict <- recDictWith show2Cls wrappedTy supers [(0, impl)]+              pure (Just (EvExpr dict, mkNonCanonical ordIntEv : scWs ++ concat wss))+    _ -> pure Nothing+  where (realP, mMods) = peelOverride2With (ovTcsGen "Override2" gen) p++-- | Synthesize @Read2 (Stock2 P)@: @liftReadsPrec2@ parses like derived @Read@+-- (prefix / infix / record, precedence-aware) but reads a first-param field+-- with @rp1@, a second with @rp2@, an @h a@\/@h b@ field with @liftReadsPrec@,+-- a constant with its own @readsPrec@.  The bivariate counterpart of+-- 'Stock.Classes1.synthRead1'; quantified superclasses come via 'stock2Supers'.+synthRead2 :: GenEnv -> Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))+synthRead2 gen read2Cls loc wrappedTy p =+  case (geStock2 gen, tyConAppTyCon_maybe realP) of+    (Just st2Tc, Just pTc) -> do+      mRead1 <- lookupClassMaybe "Data.Functor.Classes" "Read1"+      case mRead1 of+        Nothing       -> pure Nothing+        Just read1Cls -> do+          readCls     <- lookupOrig gHC_INTERNAL_READ (mkTcOcc "Read") >>= tcLookupClass+          ordCls      <- tcLookupClass ordClassName+          appendId    <- tcLookupId appendName+          eqStringId  <- tcLookupId eqStringName+          lexId       <- lookupOrig gHC_INTERNAL_READ (mkVarOcc "lex")       >>= tcLookupId+          readParenId <- lookupOrig gHC_INTERNAL_READ (mkVarOcc "readParen") >>= tcLookupId+          concatMapId <- lookupOrig gHC_INTERNAL_LIST (mkVarOcc "concatMap") >>= tcLookupId+          let liftRpSel    = classMethod "liftReadsPrec" read1Cls+              readsPrecSel = classMethod "readsPrec" readCls+              gtSel        = classMethod ">" ordCls+              fixed        = tyConAppArgs realP+              dcons        = tyConDataCons pTc+              coAt2 t1 t2  = coDown2With (geOverride2 gen) st2Tc wrappedTy p realP t1 t2+          ordIntEv <- newWanted loc (mkClassPred ordCls [intTy])+          let ordIntDict = ctEvExpr ordIntEv+          aTv <- freshTyVar "a" ; bTv <- freshTyVar "b"+          let aTy = mkTyVarTy aTv ; bTy = mkTyVarTy bTv+              innerAB   = mkTyConApp pTc (fixed ++ [aTy, bTy])+              gabTy     = mkAppTy (mkAppTy wrappedTy aTy) bTy+              readSOf t = mkVisFunTyMany stringTy (mkListTy (mkBoxedTupleTy [t, stringTy]))+              rpTyOf t  = mkVisFunTyMany intTy (readSOf t)       -- Int -> ReadS t+              rlTyOf t  = readSOf (mkListTy t)                   -- ReadS [t]+              pairTy    = mkBoxedTupleTy [gabTy, stringTy]+              strPairTy = mkBoxedTupleTy [stringTy, stringTy]+              listPair  = mkListTy pairTy+              tup2      = tupleDataCon Boxed 2+              nilPair   = mkNilExpr pairTy+              false_    = Var (dataConWorkId falseDataCon)+              toWrapped e = Cast e (mkSymCo (coAt2 aTy bTy))+              mkPairW v r = mkCoreConApps tup2 [Type gabTy, Type stringTy, v, r]+              concatMapTo srcElem fn src = mkApps (Var concatMapId) [Type srcElem, Type pairTy, fn, src]+              str s = unsafeTcPluginTcM (mkStringExprFS (fsLit s))+          rp1Id <- freshId (rpTyOf aTy) "rp1" ; rl1Id <- freshId (rlTyOf aTy) "rl1"+          rp2Id <- freshId (rpTyOf bTy) "rp2" ; rl2Id <- freshId (rlTyOf bTy) "rl2"+          dId   <- freshId intTy "d" ; rId <- freshId stringTy "r"++          -- one field's reader @prec -> restString -> [(ft, String)]@.+          let resOf t = mkListTy (mkBoxedTupleTy [t, stringTy])   -- [(t, String)]+              -- read an @h a@/@h b@ field via the modifier @m@, then cast the+              -- parsed @[(m a,String)]@ back to the real @[(h a,String)]@.+              readFold tArg rpI rlI i h = do+                let mMod = override1Mod gen mMods i+                    m    = fromMaybe h mMod+                ev <- newWanted loc (mkClassPred read1Cls [m])+                let rdr prec rest =+                      let parsed = mkApps (Var liftRpSel)+                            [Type m, ctEvExpr ev, Type tArg, Var rpI, Var rlI+                            , mkUncheckedIntExpr prec, rest]+                      in case mMod of+                           Nothing -> parsed+                           Just _  -> Cast parsed (mkStockCo (PluginProv "stock") Representational+                                        (resOf (mkAppTy m tArg)) (resOf (mkAppTy h tArg)))+                pure (Just (rdr, [mkNonCanonical ev]))+              mkFieldReader i ft = case classifyBiField aTv bTv aTy bTy ft of+                Nothing          -> pure Nothing+                Just BFA         -> pure (Just ((\prec rest -> mkApps (Var rp1Id) [mkUncheckedIntExpr prec, rest]), []))+                Just BFB         -> pure (Just ((\prec rest -> mkApps (Var rp2Id) [mkUncheckedIntExpr prec, rest]), []))+                Just BFConst     -> do ev <- newWanted loc (mkClassPred readCls [ft])+                                       pure (Just ((\prec rest -> mkApps (Var readsPrecSel)+                                              [Type ft, ctEvExpr ev, mkUncheckedIntExpr prec, rest]), [mkNonCanonical ev]))+                Just (BFFoldA h) -> readFold aTy rp1Id rl1Id i h+                Just (BFFoldB h) -> readFold bTy rp2Id rl2Id i h++          let buildChain dc [] accRev restE =+                pure $ mkCoreConApps consDataCon+                  [ Type pairTy+                  , mkPairW (toWrapped (conAppAt innerAB dc (map Var (reverse accRev)))) restE+                  , nilPair ]+              buildChain dc ((ft, rdr) : more) accRev restE = do+                a  <- freshId ft "a" ; r' <- freshId stringTy "r"+                pc <- freshId (mkBoxedTupleTy [ft, stringTy]) "p"+                cb <- freshId (mkBoxedTupleTy [ft, stringTy]) "pc"+                rest <- buildChain dc more (a : accRev) (Var r')+                let parsed = rdr (11 :: Integer) restE+                    lam = Lam pc (Case (Var pc) cb listPair [Alt (DataAlt tup2) [a, r'] rest])+                pure (concatMapTo (mkBoxedTupleTy [ft, stringTy]) lam parsed)++              expectTok expStr restE k = do+                pp <- freshId strPairTy "p"; cb <- freshId strPairTy "pc"+                tk <- freshId stringTy "t"; r' <- freshId stringTy "r"; ecb <- freshId boolTy "b"+                body <- k (Var r')+                let lam = Lam pp (Case (Var pp) cb listPair+                      [Alt (DataAlt tup2) [tk, r']+                         (Case (mkApps (Var eqStringId) [Var tk, expStr]) ecb listPair+                            [ Alt (DataAlt falseDataCon) [] nilPair+                            , Alt (DataAlt trueDataCon)  [] body ])])+                pure (concatMapTo strPairTy lam (App (Var lexId) restE))++              parseFieldP prec ft rdr restE k = do+                pp <- freshId (mkBoxedTupleTy [ft, stringTy]) "p"+                cb <- freshId (mkBoxedTupleTy [ft, stringTy]) "pc"+                v <- freshId ft "v"; r' <- freshId stringTy "r"+                body <- k (Var v) (Var r')+                let lam = Lam pp (Case (Var pp) cb listPair [Alt (DataAlt tup2) [v, r'] body])+                pure (concatMapTo (mkBoxedTupleTy [ft, stringTy]) lam (rdr prec restE))++              recChain dc fields restAfterName = do+                openB <- str "{"; closeB <- str "}"; eqB <- str "="; commaB <- str ","+                let result accRev rEnd = mkCoreConApps consDataCon+                      [ Type pairTy+                      , mkPairW (toWrapped (conAppAt innerAB dc (reverse accRev))) rEnd+                      , nilPair ]+                    go restE accRev [] _ = expectTok closeB restE (\rEnd -> pure (result accRev rEnd))+                    go restE accRev ((lbl, ft, rdr) : more) isFirst = do+                      lblStr <- str lbl+                      let after rr = expectTok lblStr rr \r1 ->+                                     expectTok eqB r1 \r2 ->+                                     parseFieldP (0 :: Integer) ft rdr r2 \v r3 ->+                                     go r3 (v : accRev) more False+                      if isFirst then after restE else expectTok commaB restE after+                expectTok openB restAfterName (\r0 -> go r0 [] fields True)++          mParserWss <- forM dcons \dc -> do+            let fts    = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aTy, bTy]))+                name   = occNameString (getOccName dc)+                labels = map (occNameString . nameOccName . flSelector) (dataConFieldLabels dc)+            nameStr <- str name+            mRdrs   <- zipWithM mkFieldReader [0 :: Int ..] fts+            case sequence mRdrs of+              Nothing      -> pure Nothing+              Just rdrPrs  -> do+                let (rdrs, wss) = unzip rdrPrs+                    gtThr thr = mkApps (Var gtSel) [Type intTy, ordIntDict, Var dId, mkUncheckedIntExpr thr]+                    mkParser flag inner =+                      App (mkApps (Var readParenId) [Type gabTy, flag, inner]) (Var rId)+                parserApp <-+                  if dataConIsInfix dc+                    then do+                      prec <- conPrec dc+                      let [(ft0, rdr0), (ft1, rdr1)] = zip fts rdrs+                      r0 <- freshId stringTy "r0"+                      body <- parseFieldP (prec + 1) ft0 rdr0 (Var r0) \x rA ->+                              expectTok nameStr rA \rB ->+                              parseFieldP (prec + 1) ft1 rdr1 rB \y rC ->+                              pure $ mkCoreConApps consDataCon+                                [ Type pairTy+                                , mkPairW (toWrapped (conAppAt innerAB dc [x, y])) rC+                                , nilPair ]+                      pure (mkParser (gtThr prec) (Lam r0 body))+                    else do+                      r0   <- freshId stringTy "r0"+                      ptok <- freshId strPairTy "pt"; tcb <- freshId strPairTy "ptc"+                      tok  <- freshId stringTy "tok"; r1 <- freshId stringTy "r1"; ecb <- freshId boolTy "bc"+                      chain <- if null labels+                                 then buildChain dc (zip fts rdrs) [] (Var r1)+                                 else recChain dc (zip3 labels fts rdrs) (Var r1)+                      let tokBody = Case (mkApps (Var eqStringId) [Var tok, nameStr]) ecb listPair+                            [ Alt (DataAlt falseDataCon) [] nilPair+                            , Alt (DataAlt trueDataCon)  [] chain ]+                          tokLam = Lam ptok (Case (Var ptok) tcb listPair+                            [Alt (DataAlt tup2) [tok, r1] tokBody])+                          inner = Lam r0 (concatMapTo strPairTy tokLam (App (Var lexId) (Var r0)))+                          -- record syntax never needs surrounding parens (see Stock.Read)+                          flag  = if null fts || not (null labels) then false_ else gtThr (10 :: Integer)+                      pure (mkParser flag inner)+                pure (Just (parserApp, concat wss))++          case sequence mParserWss of+            Nothing        -> pure Nothing+            Just parserWss -> do+              let (parserApps, wss) = unzip parserWss+                  liftRp2Impl = mkLams [aTv, bTv, rp1Id, rl1Id, rp2Id, rl2Id, dId, rId] $+                    foldr (\e acc -> mkApps (Var appendId) [Type pairTy, e, acc]) nilPair parserApps+              (supers, scWs) <- stock2Supers read2Cls wrappedTy loc+              dict <- recDictWith read2Cls wrappedTy supers [(0, liftRp2Impl)]+              pure (Just (EvExpr dict, mkNonCanonical ordIntEv : scWs ++ concat wss))+    _ -> pure Nothing+  where (realP, mMods) = peelOverride2With (ovTcsGen "Override2" gen) p

@@ -0,0 +1,35 @@+{-# LANGUAGE BlockArguments #-}+-- @head@/@last cons@ are guarded by the caller's+-- enum-or-single-constructor contract and the class always having its methods.+{-# OPTIONS_GHC -Wno-x-partial -Wno-unused-imports #-}++-- | @Bounded@ via the SOP-EDSL.  @minBound@\/@maxBound@ are values, so this is+-- pure 'injectSOP' (no @matchSOP@): an enumeration injects its first\/last+-- (nullary) constructor; a single-constructor product injects that constructor+-- with each field set to its own @minBound@\/@maxBound@ ('pureFields' ++-- 'field').  A clean demonstration that the SDK alone expresses a real+-- synthesizer — this module needs nothing from the plugin substrate.+module Stock.Bounded (boundedDeriver) where++import GHC.Plugins+import GHC.Core.Class (classMethods)+import Stock.Derive++-- | The caller guarantees the type is an enumeration or a single constructor+-- (GHC's @Bounded@ deriving has the same restriction).+boundedDeriver :: Deriver+boundedDeriver = Deriver \cls dt -> do+  let cons   = dtCons dt+      minSel = classMethod "minBound" cls+      maxSel = classMethod "maxBound" cls+      bound sel ft d = mkApps (Var sel) [Type ft, d]+  if all (null . conFields) cons+    then                                     -- enumeration: first / last constructor+      pure (classDict cls (dtVia dt) [ injectSOP dt (head cons) []+                                     , injectSOP dt (last cons) [] ])+    else do                                  -- single product: each field at its bound+      let con = productCon dt+      fds <- pureFields (\ft -> do d <- field cls ft; pure (ft, d)) con+      pure (classDict cls (dtVia dt)+              [ injectSOP dt con [ bound minSel ft d | (ft, d) <- fds ]+              , injectSOP dt con [ bound maxSel ft d | (ft, d) <- fds ] ])

@@ -0,0 +1,436 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}++-- | The lifted @Data.Functor.Classes@ hierarchy over @Stock1 F@: @Eq1@,+-- @Ord1@, @Show1@, @Read1@.  Each is the structural synthesizer of its unlifted twin+-- (@Eq@\/@Ord@) with one change: a field that /is/ the functor parameter @a@+-- is handled by the supplied function argument (@liftEq@'s @eq@,+-- @liftCompare@'s @cmp@) instead of the field's own instance, and a field of+-- shape @H a@ recurses through @H@'s own lifted method.+--+-- Since base-4.18 these classes carry a /quantified/ superclass — @Eq1 f@+-- requires @forall a. Eq a => Eq (f a)@ and @Ord1 f@ likewise for @Ord@ — so+-- we synthesize those superclass dictionaries too (from the same lifted+-- method, instantiated at @eq = (==)@ \/ @cmp = compare@).+module Stock.Classes1 (synthEq1, synthOrd1, synthShow1, synthRead1) where++import GHC.Plugins hiding (TcPlugin)+import GHC.Tc.Plugin+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.Core.Class (Class, className, classSCTheta, classSCSelId)+import GHC.Core.Predicate (mkClassPred, isClassPred)+import GHC.Builtin.Names (eqClassName, ordClassName, appendName, eqStringName)+import GHC.Core.Multiplicity (scaledThing)+import GHC.Core.TyCo.Rep (UnivCoProvenance(PluginProv))+import Stock.Compat (gHC_INTERNAL_SHOW, gHC_INTERNAL_READ, gHC_INTERNAL_LIST)+import Control.Monad (forM, zipWithM)+import Stock.Derive (classMethod, castInto)+import Stock.Internal  -- 'castReshape' (skip-Refl cast) comes from here+import Data.Maybe (fromJust)++-- ----- the structural lifted methods --------------------------------------++-- | Build the @liftEq@ method body @\\\@a \@b eq fa fb -> …@ for @Stock1 F@,+-- or 'Nothing' if some field shape is unsupported.  Returns the field-instance+-- wanteds (@Eq H@ for constant fields, @Eq1 H@ for @H a@ fields).+buildLiftEq :: GenEnv -> Class -> Class -> CtLoc -> Type -> Type+            -> TcPluginM (Maybe (CoreExpr, [Ct]))+buildLiftEq gen eq1Cls eqCls loc wrappedTy f =+  case (geStock1 gen, tyConAppTyCon_maybe realF) of+    (Just st1Tc, Just fTc) -> do+      let liftEqSel = classMethod "liftEq" eq1Cls+          eqSel     = classMethod "==" eqCls+          fixed     = tyConAppArgs realF+          true_     = Var (dataConWorkId trueDataCon)+          false_    = Var (dataConWorkId falseDataCon)+          coAt t    = coDown1 gen st1Tc wrappedTy f realF t+      aTv <- freshTyVar "a" ; bTv <- freshTyVar "b"+      let aTy = mkTyVarTy aTv ; bTy = mkTyVarTy bTv+          eqFnTy = mkVisFunTyMany aTy (mkVisFunTyMany bTy boolTy)+      eqId <- freshId eqFnTy "eq"+      faId <- freshId (mkAppTy wrappedTy aTy) "fa"+      fbId <- freshId (mkAppTy wrappedTy bTy) "fb"++      -- one field-pair becomes a Bool: the parameter via @eq@, a constant via+      -- its own @(==)@, an @H a@ field via @liftEq \@m eq@ (the @Override1@+      -- modifier @m@; the field values cast @h ~R m@ via @coB@).+      let fieldEq i ft x y = interpField eqCls eq1Cls aTv aTy loc (override1Mod gen mMods i) Roles+            { onParam = mkApps (Var eqId)     [Var x, Var y]+            , onConst = \ev t -> mkApps (Var eqSel) [Type t, ctEvExpr ev, Var x, Var y]+            , onApply = \ev m coB -> mkApps (Var liftEqSel)+                [ Type m, ctEvExpr ev, Type aTy, Type bTy, Var eqId+                , castReshape (Var x) (coB aTy), castReshape (Var y) (coB bTy) ]+            } ft+          -- conjunction with short-circuit: @case e of False -> False; True -> …@+          conj []         = pure true_+          conj (e : more) = do+            rest <- conj more+            scr  <- freshId boolTy "c"+            pure (Case e scr boolTy [ Alt (DataAlt falseDataCon) [] false_+                                    , Alt (DataAlt trueDataCon)  [] rest ])++      mBody <- zipLift2 fTc fixed coAt aTy bTy boolTy faId fbId+                        (\_ _ -> false_) conj fieldEq+      pure (fmap (\(body, ws) -> (mkLams [aTv, bTv, eqId, faId, fbId] body, ws)) mBody)+    _ -> pure Nothing+  where (realF, mMods) = peelOverride1 gen f++-- | Build the @liftCompare@ method body for @Stock1 F@: tag order between+-- constructors, lexicographic within.  Wanteds: @Ord H@ \/ @Ord1 H@ per field.+buildLiftCompare :: GenEnv -> Class -> Class -> CtLoc -> Type -> Type+                 -> TcPluginM (Maybe (CoreExpr, [Ct]))+buildLiftCompare gen ord1Cls ordCls loc wrappedTy f =+  case (geStock1 gen, tyConAppTyCon_maybe realF) of+    (Just st1Tc, Just fTc) -> do+      let liftCmpSel = classMethod "liftCompare" ord1Cls+          cmpSel     = classMethod "compare" ordCls+          fixed      = tyConAppArgs realF+          ordTy      = mkTyConTy orderingTyCon+          [ltC, eqC, gtC] = tyConDataCons orderingTyCon+          ltE = Var (dataConWorkId ltC)+          eqE = Var (dataConWorkId eqC)+          gtE = Var (dataConWorkId gtC)+          coAt t = coDown1 gen st1Tc wrappedTy f realF t+      aTv <- freshTyVar "a" ; bTv <- freshTyVar "b"+      let aTy = mkTyVarTy aTv ; bTy = mkTyVarTy bTv+          cmpFnTy = mkVisFunTyMany aTy (mkVisFunTyMany bTy ordTy)+      cmpId <- freshId cmpFnTy "cmp"+      faId  <- freshId (mkAppTy wrappedTy aTy) "fa"+      fbId  <- freshId (mkAppTy wrappedTy bTy) "fb"++      -- one field-pair becomes an Ordering: the parameter via @cmp@, a constant+      -- via its own @compare@, an @H a@ field via @liftCompare \@m cmp@.+      let fieldCmp i ft x y = interpField ordCls ord1Cls aTv aTy loc (override1Mod gen mMods i) Roles+            { onParam = mkApps (Var cmpId)      [Var x, Var y]+            , onConst = \ev t -> mkApps (Var cmpSel) [Type t, ctEvExpr ev, Var x, Var y]+            , onApply = \ev m coB -> mkApps (Var liftCmpSel)+                [ Type m, ctEvExpr ev, Type aTy, Type bTy, Var cmpId+                , castReshape (Var x) (coB aTy), castReshape (Var y) (coB bTy) ]+            } ft+          -- lexicographic: @case e of LT -> LT; GT -> GT; EQ -> …@+          lexCmp []         = pure eqE+          lexCmp (e : more) = do+            rest <- lexCmp more+            scr  <- freshId ordTy "o"+            pure (Case e scr ordTy [ Alt (DataAlt ltC) [] ltE+                                   , Alt (DataAlt eqC) [] rest+                                   , Alt (DataAlt gtC) [] gtE ])++      mBody <- zipLift2 fTc fixed coAt aTy bTy ordTy faId fbId+                        (\i j -> if i < j then ltE else gtE) lexCmp fieldCmp+      pure (fmap (\(body, ws) -> (mkLams [aTv, bTv, cmpId, faId, fbId] body, ws)) mBody)+    _ -> pure Nothing+  where (realF, mMods) = peelOverride1 gen f++-- ----- quantified-superclass dictionaries ---------------------------------++-- | A quantified superclass @forall a. C a => D (g a)@ as evidence: bind @a@+-- and its @C a@ dictionary, then build the @D (g a)@ dictionary.  The callback+-- receives @a@, @g a@, and the @C a@ dictionary binder.  This is the shape+-- shared by every @Eq1@\/@Ord1@\/@Show1@\/@Read1@ superclass.+buildQuantSuper :: Class -> Type+                -> (Type -> Type -> Id -> TcPluginM CoreExpr)+                -> TcPluginM CoreExpr+buildQuantSuper baseCls gTy mk = do+  aTv <- freshTyVar "a"+  let aTy = mkTyVarTy aTv ; gaTy = mkAppTy gTy aTy+  dA <- freshId (mkClassPred baseCls [aTy]) "d"+  inner <- mk aTy gaTy dA+  pure (mkLams [aTv, dA] inner)++-- | @Eq T@ dictionary from an equality test @eqImpl :: T -> T -> Bool@.+mkEqDict :: Class -> Type -> CoreExpr -> TcPluginM CoreExpr+mkEqDict eqCls tT eqImpl = do+  x <- freshId tT "x" ; y <- freshId tT "y" ; s <- freshId boolTy "c"+  let neq = mkLams [x, y] (Case (mkApps eqImpl [Var x, Var y]) s boolTy+              [ Alt (DataAlt falseDataCon) [] (Var (dataConWorkId trueDataCon))+              , Alt (DataAlt trueDataCon)  [] (Var (dataConWorkId falseDataCon)) ])+  pure (mkClassDict eqCls tT [eqImpl, neq])++-- | The quantified @Eq@ superclass @forall a. Eq a => Eq (g a)@, built from+-- the @liftEq@ method instantiated at @eq = (==) \@a@.+buildQuantEq :: Class -> Type -> CoreExpr -> TcPluginM CoreExpr+buildQuantEq eqCls gTy liftEqImpl =+  buildQuantSuper eqCls gTy \aTy gaTy dEqA -> do+    let eqA  = mkApps (Var (classMethod "==" eqCls)) [Type aTy, Var dEqA]+        eqGA = mkApps liftEqImpl [Type aTy, Type aTy, eqA]+    mkEqDict eqCls gaTy eqGA++-- | The quantified @Ord@ superclass @forall a. Ord a => Ord (g a)@, built from+-- @liftCompare@ (instantiated at @compare \@a@) plus the @Eq (g a)@ it needs as+-- its own superclass (from @liftEq@ instantiated at the @Eq a@ inside @Ord a@).+buildQuantOrd :: Class -> Class -> Type -> CoreExpr -> CoreExpr -> TcPluginM CoreExpr+buildQuantOrd ordCls eqCls gTy liftCmpImpl liftEqImpl =+  buildQuantSuper ordCls gTy \aTy gaTy dOrdA -> do+    let cmpA  = mkApps (Var (classMethod "compare" ordCls)) [Type aTy, Var dOrdA]+        cmpGA = mkApps liftCmpImpl [Type aTy, Type aTy, cmpA]+        dEqA  = mkApps (Var (classSCSelId ordCls 0)) [Type aTy, Var dOrdA]  -- Eq a from Ord a+        eqA   = mkApps (Var (classMethod "==" eqCls)) [Type aTy, dEqA]+        eqGA  = mkApps liftEqImpl [Type aTy, Type aTy, eqA]+    eqDictGa <- mkEqDict eqCls gaTy eqGA+    recDictWith ordCls gaTy [eqDictGa] [(0, cmpGA)]++-- ----- the two entry points -----------------------------------------------++synthEq1 :: GenEnv -> Class -> CtLoc -> Type -> Type+         -> TcPluginM (Maybe (EvTerm, [Ct]))+synthEq1 gen eq1Cls loc wrappedTy f = do+  eqCls <- tcLookupClass eqClassName+  m <- buildLiftEq gen eq1Cls eqCls loc wrappedTy f+  case m of+    Nothing -> pure Nothing+    Just (liftEqImpl, ws) -> do+      supers <- forM (classSCTheta eq1Cls) \_ -> buildQuantEq eqCls wrappedTy liftEqImpl+      pure (Just (EvExpr (mkClassDict eq1Cls wrappedTy (supers ++ [liftEqImpl])), ws))++-- ----- Show1 --------------------------------------------------------------++-- | Build @liftShowsPrec@'s body @\\\@a sp sl d v -> …@ for @Stock1 F@,+-- mirroring derived @showsPrec@ (prefix / infix / record / nullary, with the+-- @d > prec@ parenthesisation) but rendering the parameter field with the+-- supplied @sp@, an @H a@ field with @liftShowsPrec \@H sp sl@ (a @Show1 H@+-- wanted), and any other field with its own @showsPrec@ (a @Show H@ wanted).+buildLiftShowsPrec :: GenEnv -> Class -> Class -> Class -> Id -> CtLoc -> Type -> Type+                   -> TcPluginM (Maybe (CoreExpr, [Ct]))+buildLiftShowsPrec gen show1Cls showCls ordCls appendId loc wrappedTy f =+  case (geStock1 gen, tyConAppTyCon_maybe realF) of+    (Just st1Tc, Just fTc) -> do+      let liftSpSel    = classMethod "liftShowsPrec" show1Cls+          showsPrecSel = classMethod "showsPrec" showCls+          gtSel        = classMethod ">" ordCls+          fixed        = tyConAppArgs realF+          dcons        = tyConDataCons fTc+          showSTy      = mkVisFunTyMany stringTy stringTy+          coAt t       = coDown1 gen st1Tc wrappedTy f realF t+          cons c t     = mkCoreConApps consDataCon [Type charTy, c, t]+          append s t   = mkApps (Var appendId) [Type charTy, s, t]+          str s        = unsafeTcPluginTcM (mkStringExprFS (fsLit s))+      ordIntEv <- newWanted loc (mkClassPred ordCls [intTy])+      let ordIntDict = ctEvExpr ordIntEv+      aTv <- freshTyVar "a"+      let aTy    = mkTyVarTy aTv+          innerA = mkTyConApp fTc (fixed ++ [aTy])+          spTy   = mkVisFunTyMany intTy (mkVisFunTyMany aTy showSTy)+          slTy   = mkVisFunTyMany (mkListTy aTy) showSTy+      spId <- freshId spTy "sp" ; slId <- freshId slTy "sl"+      dId  <- freshId intTy "d" ; vId  <- freshId (mkAppTy wrappedTy aTy) "v"++      -- one field becomes a precedence-parameterised ShowS renderer (@p -> ShowS@):+      -- the parameter via @sp@, a constant via its own @showsPrec@, an @H a@+      -- field via @liftShowsPrec \@H sp sl@.+      let mkRenderer i ftA xi = interpField showCls show1Cls aTv aTy loc (override1Mod gen mMods i) Roles+            { onParam     = \p -> mkApps (Var spId) [mkUncheckedIntExpr p, Var xi]+            , onConst = \ev t -> \p -> mkApps (Var showsPrecSel)+                                    [Type t, ctEvExpr ev, mkUncheckedIntExpr p, Var xi]+            , onApply = \ev m coB -> \p -> mkApps (Var liftSpSel)+                                    [ Type m, ctEvExpr ev, Type aTy, Var spId, Var slId+                                    , mkUncheckedIntExpr p, castReshape (Var xi) (coB aTy) ]+            } ftA++      mAltWss <- forM dcons \dc -> do+        let fts    = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aTy]))+            name   = occNameString (getOccName dc)+            labels = map (occNameString . nameOccName . flSelector) (dataConFieldLabels dc)+        nameStr <- str name+        xs      <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] fts+        rest    <- freshId stringTy "r"+        gtBndr  <- freshId boolTy "p"+        prec    <- conPrec dc+        mRends  <- sequence (zipWith3 mkRenderer [0 :: Int ..] fts xs)+        case sequence mRends of+          Nothing    -> pure Nothing+          Just rends -> do+            let (renderers, wss) = unzip rends+                parenAt thr mk t =+                  Case (mkApps (Var gtSel) [Type intTy, ordIntDict, Var dId, mkUncheckedIntExpr thr])+                       gtBndr stringTy+                    [ Alt (DataAlt falseDataCon) [] (mk t)+                    , Alt (DataAlt trueDataCon)  []+                        (cons (mkCharExpr '(') (mk (cons (mkCharExpr ')') t))) ]+                goPrefix t = foldr (\r acc -> cons (mkCharExpr ' ') (App (r 11) acc)) t renderers+                prefixBody t = append nameStr (goPrefix t)+            body <-+              if dataConIsInfix dc+                then do+                  opStr <- str (" " ++ name ++ " ")+                  let [l, r] = renderers+                      mk t = App (l (prec + 1)) (append opStr (App (r (prec + 1)) t))+                  pure (parenAt prec mk (Var rest))+                else if not (null labels)+                  then do+                    openB <- str " {"; eqB <- str " = "; commaB <- str ", "; closeB <- str "}"+                    lblStrs <- mapM str labels+                    let recF = zip lblStrs renderers+                        goRec [(lbl, r)] c    = append lbl (append eqB (App (r 0) (append closeB c)))+                        goRec ((lbl, r) : m) c = append lbl (append eqB (App (r 0) (append commaB (goRec m c))))+                        goRec [] c            = append closeB c+                        recBody t = append nameStr (append openB (goRec recF t))+                    pure (parenAt 10 recBody (Var rest))+                  else if null xs+                    then pure (append nameStr (Var rest))+                    else pure (parenAt 10 prefixBody (Var rest))+            pure (Just (Alt (DataAlt dc) xs (Lam rest body), concat wss))++      case sequence mAltWss of+        Nothing     -> pure Nothing+        Just altWss -> do+          let (alts, wss) = unzip altWss+          cb <- freshId innerA "cb"+          let spImpl = mkLams [aTv, spId, slId, dId, vId]+                (destructInner fTc (fixed ++ [aTy]) (Cast (Var vId) (coAt aTy)) cb showSTy alts)+          pure (Just (spImpl, mkNonCanonical ordIntEv : concat wss))+    _ -> pure Nothing+  where (realF, mMods) = peelOverride1 gen f++-- | A @Show T@ dictionary from a @showsPrec@ implementation.+mkShowDict :: Class -> Id -> Type -> CoreExpr -> TcPluginM CoreExpr+mkShowDict showCls showList__Id tT spImpl = do+  vS <- freshId tT "v" ; vL <- freshId tT "v"+  let showImpl     = Lam vS (mkApps spImpl [mkUncheckedIntExpr 0, Var vS, mkNilExpr charTy])+      sp0          = Lam vL (mkApps spImpl [mkUncheckedIntExpr 0, Var vL])+      showListImpl = mkApps (Var showList__Id) [Type tT, sp0]+  pure (mkClassDict showCls tT [spImpl, showImpl, showListImpl])++-- | The quantified @Show@ superclass @forall a. Show a => Show (g a)@, from+-- @liftShowsPrec@ instantiated at @sp = showsPrec \@a@, @sl = showList \@a@.+buildQuantShow :: Class -> Id -> Type -> CoreExpr -> TcPluginM CoreExpr+buildQuantShow showCls showList__Id gTy liftSpImpl =+  buildQuantSuper showCls gTy \aTy gaTy dShowA -> do+    let spA  = mkApps (Var (classMethod "showsPrec" showCls))   [Type aTy, Var dShowA]+        slA  = mkApps (Var (classMethod "showList" showCls))     [Type aTy, Var dShowA]+        spGA = mkApps liftSpImpl [Type aTy, spA, slA]+    mkShowDict showCls showList__Id gaTy spGA++synthShow1 :: GenEnv -> Class -> CtLoc -> Type -> Type+           -> TcPluginM (Maybe (EvTerm, [Ct]))+synthShow1 gen show1Cls loc wrappedTy f = do+  showCls      <- lookupOrig gHC_INTERNAL_SHOW (mkTcOcc "Show") >>= tcLookupClass+  ordCls       <- tcLookupClass ordClassName+  appendId     <- tcLookupId appendName+  showList__Id <- lookupOrig gHC_INTERNAL_SHOW (mkVarOcc "showList__") >>= tcLookupId+  m <- buildLiftShowsPrec gen show1Cls showCls ordCls appendId loc wrappedTy f+  case m of+    Nothing -> pure Nothing+    Just (liftSpImpl, ws) -> do+      supers <- forM (classSCTheta show1Cls) \_ ->+                  buildQuantShow showCls showList__Id wrappedTy liftSpImpl+      dict <- recDictWith show1Cls wrappedTy supers [(0, liftSpImpl)]+      pure (Just (EvExpr dict, ws))++synthOrd1 :: GenEnv -> Class -> CtLoc -> Type -> Type+          -> TcPluginM (Maybe (EvTerm, [Ct]))+synthOrd1 gen ord1Cls loc wrappedTy f = do+  ordCls  <- tcLookupClass ordClassName+  eqCls   <- tcLookupClass eqClassName+  mEq1Cls <- lookupClassMaybe "Data.Functor.Classes" "Eq1"+  case mEq1Cls of+    Nothing -> pure Nothing+    Just eq1Cls -> do+      mCmp <- buildLiftCompare gen ord1Cls ordCls loc wrappedTy f+      mEq  <- buildLiftEq gen eq1Cls eqCls loc wrappedTy f+      case (mCmp, mEq) of+        (Just (liftCmpImpl, wsC), Just (liftEqImpl, wsE)) -> do+          -- the full Eq1 superclass dictionary (with its own quantified Eq super)+          eqSupers <- forM (classSCTheta eq1Cls) \_ -> buildQuantEq eqCls wrappedTy liftEqImpl+          let eq1Dict = mkClassDict eq1Cls wrappedTy (eqSupers ++ [liftEqImpl])+          -- Ord1's superclasses, in declaration order: the plain @Eq1 f@ and the+          -- quantified @forall a. Ord a => Ord (f a)@.+          supers <- forM (classSCTheta ord1Cls) \p ->+            if isClassPred p+              then pure eq1Dict+              else buildQuantOrd ordCls eqCls wrappedTy liftCmpImpl liftEqImpl+          dict <- recDictWith ord1Cls wrappedTy supers [(0, liftCmpImpl)]+          pure (Just (EvExpr dict, wsC ++ wsE))+        _ -> pure Nothing++-- ----- Read1 --------------------------------------------------------------++-- | Build @liftReadPrec@'s body @\@a rp rl -> ...@ for @Stock1 F@, by reusing+-- the shared GHC-faithful @readPrec@ assembler ('buildReadPrecBody'): the+-- parameter field reads with the supplied @rp@, a constant field with its own+-- @readPrec@, and an @H a@ field with @liftReadPrec \@H rp rl@ (cast back to the+-- real field type when @Override1@ reshapes the functor).+buildLiftReadPrec :: GenEnv -> Class -> Class -> CtLoc -> Type -> Type+                  -> TcPluginM (Maybe (CoreExpr, [Ct]))+buildLiftReadPrec gen read1Cls readCls loc wrappedTy f =+  case (geStock1 gen, tyConAppTyCon_maybe realF) of+    (Just st1Tc, Just fTc) -> do+      (env, monadCt) <- lookupReadPrecEnv loc+      let liftRpSel   = classMethod "liftReadPrec" read1Cls+          readPrecSel = classMethod "readPrec" readCls+          fixed       = tyConAppArgs realF+          dcons       = tyConDataCons fTc+          coAt t      = coDown1 gen st1Tc wrappedTy f realF t+          rpcOf t     = mkTyConApp (rpReadPrecTc env) [t]+      aTv <- freshTyVar "a"+      let aTy    = mkTyVarTy aTv+          innerA = mkTyConApp fTc (fixed ++ [aTy])+          gaTy   = mkAppTy wrappedTy aTy+          toWrapped e = Cast e (mkSymCo (coAt aTy))+      rpId <- freshId (rpcOf aTy) "rp"+      rlId <- freshId (rpcOf (mkListTy aTy)) "rl"+      -- each field's raw reader, plus the coercion casting the read type back to+      -- the real field type (Refl unless Override1 reshaped an @H a@ field).+      let mkFieldReader i ftA = interpField readCls read1Cls aTv aTy loc (override1Mod gen mMods i) Roles+            { onParam = (aTy, Var rpId, mkReflCo Representational aTy)+            , onConst = \ev t -> (t, mkApps (Var readPrecSel) [Type t, ctEvExpr ev], mkReflCo Representational t)+            , onApply = \ev m coB ->+                ( mkAppTy m aTy+                , mkApps (Var liftRpSel) [Type m, ctEvExpr ev, Type aTy, Var rpId, Var rlId]+                , if isReflCo (coB aTy) then mkReflCo Representational ftA else mkSymCo (coB aTy) )+            } ftA+      mConsWss <- forM dcons \dc -> do+        let fts = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aTy]))+        mRdrs <- zipWithM mkFieldReader [0 :: Int ..] fts+        case sequence mRdrs of+          Nothing    -> pure Nothing+          Just trips -> let (rdrs, wss) = unzip trips in pure (Just (dc, rdrs, concat wss))+      case sequence mConsWss of+        Nothing   -> pure Nothing+        Just cons -> do+          let consForAsm = [ (dc, [ (ty, rd) | (ty, rd, _) <- rdrs ]) | (dc, rdrs, _) <- cons ]+              castMap    = [ (getUnique dc, [ co | (_, _, co) <- rdrs ]) | (dc, rdrs, _) <- cons ]+              mkConVal dc argIds =+                let castCos = fromJust (lookup (getUnique dc) castMap)+                in toWrapped (conAppAt innerA dc (zipWith (\a c -> castInto (Var a) c) argIds castCos))+          body <- buildReadPrecBody env gaTy mkConVal consForAsm+          let liftRpImpl = mkLams [aTv, rpId, rlId] body+          pure (Just (liftRpImpl, monadCt : concatMap (\(_, _, w) -> w) cons))+    _ -> pure Nothing+  where (realF, mMods) = peelOverride1 gen f++-- | A @Read T@ dictionary from a @readPrec@ implementation (other methods come+-- from the class defaults via a recursive dictionary).+mkReadDict :: Class -> Type -> CoreExpr -> TcPluginM CoreExpr+mkReadDict readCls tT rpImpl = recDictWith readCls tT [] [(2, rpImpl)]++-- | The quantified @Read@ superclass @forall a. Read a => Read (g a)@, from+-- @liftReadPrec@ instantiated at @rp = readPrec \@a@, @rl = readListPrec \@a@.+buildQuantRead :: Class -> Type -> CoreExpr -> TcPluginM CoreExpr+buildQuantRead readCls gTy liftRpImpl =+  buildQuantSuper readCls gTy \aTy gaTy dReadA -> do+    let rpA  = mkApps (Var (classMethod "readPrec" readCls))     [Type aTy, Var dReadA]+        rlpA = mkApps (Var (classMethod "readListPrec" readCls)) [Type aTy, Var dReadA]+        rpGA = mkApps liftRpImpl [Type aTy, rpA, rlpA]+    mkReadDict readCls gaTy rpGA++synthRead1 :: GenEnv -> Class -> CtLoc -> Type -> Type+           -> TcPluginM (Maybe (EvTerm, [Ct]))+synthRead1 gen read1Cls loc wrappedTy f = do+  readCls <- lookupOrig gHC_INTERNAL_READ (mkTcOcc "Read") >>= tcLookupClass+  m <- buildLiftReadPrec gen read1Cls readCls loc wrappedTy f+  case m of+    Nothing -> pure Nothing+    Just (liftRpImpl, ws) -> do+      supers <- forM (classSCTheta read1Cls) \_ -> buildQuantRead readCls wrappedTy liftRpImpl+      dict <- recDictWith read1Cls wrappedTy supers [(2, liftRpImpl)]+      pure (Just (EvExpr dict, ws))+

@@ -0,0 +1,44 @@+{-# LANGUAGE CPP #-}++-- | Cross-version shims for GHC API names that moved or were renamed.+--+-- GHC 9.10 split @base@ into @ghc-internal@, renaming the wired-in module+-- constants from @gHC_*@ to @gHC_INTERNAL_*@.  We expose the 9.10+ spelling+-- everywhere and map it back to the old names on 9.8.+module Stock.Compat+  ( gHC_INTERNAL_SHOW+  , gHC_INTERNAL_READ+  , gHC_INTERNAL_LIST+  , gHC_INTERNAL_GENERICS+  , tEXT_READPREC+  , tEXT_READ_LEX+  ) where++import GHC.Unit.Types (Module, mkModule, moduleUnit)+import GHC.Unit.Module (mkModuleName)++#if MIN_VERSION_ghc(9,10,0)+import GHC.Builtin.Names+  ( gHC_INTERNAL_SHOW, gHC_INTERNAL_READ+  , gHC_INTERNAL_LIST, gHC_INTERNAL_GENERICS )+#else+import GHC.Builtin.Names (gHC_SHOW, gHC_READ, gHC_LIST, gHC_GENERICS)++gHC_INTERNAL_SHOW, gHC_INTERNAL_READ, gHC_INTERNAL_LIST, gHC_INTERNAL_GENERICS :: Module+gHC_INTERNAL_SHOW     = gHC_SHOW+gHC_INTERNAL_READ     = gHC_READ+gHC_INTERNAL_LIST     = gHC_LIST+gHC_INTERNAL_GENERICS = gHC_GENERICS+#endif++-- @Text.ParserCombinators.ReadPrec@ and @Text.Read.Lex@ are not wired in; build+-- them in the same unit as @GHC.Read@ (base on <9.10, ghc-internal after), where+-- they moved under the @GHC.Internal.@ prefix alongside it.+tEXT_READPREC, tEXT_READ_LEX :: Module+#if MIN_VERSION_ghc(9,10,0)+tEXT_READPREC = mkModule (moduleUnit gHC_INTERNAL_READ) (mkModuleName "GHC.Internal.Text.ParserCombinators.ReadPrec")+tEXT_READ_LEX = mkModule (moduleUnit gHC_INTERNAL_READ) (mkModuleName "GHC.Internal.Text.Read.Lex")+#else+tEXT_READPREC = mkModule (moduleUnit gHC_INTERNAL_READ) (mkModuleName "Text.ParserCombinators.ReadPrec")+tEXT_READ_LEX = mkModule (moduleUnit gHC_INTERNAL_READ) (mkModuleName "Text.Read.Lex")+#endif

@@ -0,0 +1,369 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_GHC -Wno-x-partial #-}              -- 'prodCon' head: guarded by the product contract+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- 'classDict' always returns @EvExpr@++-- | The Stock extension SDK.+--+-- A /synthesizer/ for a class @Cls@ is a function @Class -> Datatype+-- -> Synth EvTerm@: given a structural view of the wrapped type,+-- build the class dictionary as Core — the same static, zero-cost+-- evidence the built-in synthesizers produce (no @Generic@, no+-- runtime @Rep@).+--+-- The only non-trivial primitive a synthesizer needs beyond the+-- structure is 'field': request the dictionary for a field's type and+-- continue with its evidence.  This is the \"continuation\" that lets+-- a synthesizer pause, have GHC solve a sub-constraint, and resume —+-- so @Eq@ (consumer), @Functor@ (transformer) and @Arbitrary@+-- (producer) are all just monadic programs over the same structure.+--+-- Companion packages register support for a new class by writing an+-- instance of 'DeriveStock'; the plugin discovers and runs it.  This+-- module deliberately depends only on @ghc@ + @base@, so companions+-- stay light.+module Stock.Derive+  ( -- * Structural view+    Datatype(..)+  , Constructor(..)+    -- * The synthesis monad+  , Synth+  , runSynth+  , synthTc+  , liftTc+  , field+  , fresh+  , castInto+  , classDict+  , classDictWith+  , classMethod+    -- * SOP-style sum-of-products combinators (generics-sop flavour)+  , productCon+  , matchSOP+  , injectSOP+  , fromProduct+  , toProduct+  , pureFields+  , cpureFields+  , mapFields+  , cmapFields+  , zipFields+  , czipFields+  , foldlFields+  , cfoldlFields+  , traverseFields+  , ctraverseFields+    -- * The witness interface+  , Deriver(..)+  , DeriveStock(..)+  , Deriver1(..)+  , DeriveStock1(..)+  , Deriver2(..)+  , DeriveStock2(..)+  ) where++import GHC.Plugins+import GHC.Tc.Plugin (TcPluginM, newWanted, unsafeTcPluginTcM, tcLookupId)+import GHC.Tc.Types.Constraint (Ct, mkNonCanonical, ctEvExpr)+#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 (EvTerm(EvExpr))+import GHC.Core.Predicate (mkClassPred)+import GHC.Core.Class (Class, classMethods, classOpItems)+import GHC.Types.Fixity (Fixity)+import Control.Monad (forM, foldM)+import Stock.Trans (ReaderT(..), WriterT(..))+-- The kinds for the witness-class indices.  (GHC.Plugins' unqualified @Type@ is+-- the compiler's AST type; here we need the /kind/ @Data.Kind.Type@.)+import qualified Data.Kind as K++-- ---------------------------------------------------------------------------+-- Structural view of the wrapped type+-- ---------------------------------------------------------------------------++-- | What a synthesizer sees when solving @C (Stock T)@: the via-target it is+-- building the instance for (@Stock T@), the underlying analysed type (@T@),+-- the newtype-unwrap coercion between them, and @T@'s constructors.  Field+-- types are already instantiated at @T@'s actual arguments.+data Datatype = Datatype+  { dtVia    :: Type            -- ^ the via-target, e.g. @Stock T@ — what the instance is /for/+  , dtUnwrap :: Coercion        -- ^ @dtVia ~R dtType@ (newtype unwrap)+  , dtType   :: Type            -- ^ the underlying type, e.g. @T@ (or @T a@)+  , dtCons   :: [Constructor]+  }++-- | One constructor of the analysed type: its 'DataCon', field types+-- (instantiated at @T@'s arguments), fixity, and record labels if any.+data Constructor = Constructor+  { conDataCon :: DataCon+  , conFields  :: [Type]        -- ^ field types the synthesizer sees, instantiated at+                                --   @T@'s arguments — the /modifier/ types where a field+                                --   is overridden (see "Stock.Override"), else the real ones+  , conFixity  :: Fixity        -- ^ for infix constructors (default @defaultFixity@)+  , conLabels  :: Maybe [FieldLabel]  -- ^ record selectors, if a record+  , conFieldCos :: [Coercion]   -- ^ per field, @realFieldType ~R conFields!!i@; 'Refl' when+                                --   the field is not overridden.  'matchSOP'\/'injectSOP'+                                --   apply these so synthesizers see only 'conFields'.+  }++-- ---------------------------------------------------------------------------+-- The synthesis monad: a writer of emitted wanteds over a reader of the CtLoc+-- ---------------------------------------------------------------------------++-- | A Core-building computation that may request sub-instances (emitting+-- wanted constraints) and allocate fresh binders.  Structurally this is a+-- reader of the 'CtLoc' over a writer of emitted 'Ct's over 'TcPluginM', so we+-- derive the monad instances straight from that stack (the representations are+-- coercible).+newtype Synth a = Synth (CtLoc -> TcPluginM (a, [Ct]))+  deriving (Functor, Applicative, Monad)+    via ReaderT CtLoc (WriterT [Ct] TcPluginM)++-- | Run a synthesizer at a constraint location, collecting the wanteds it+-- emitted (to be returned to GHC alongside the solution).+runSynth :: CtLoc -> Synth a -> TcPluginM (a, [Ct])+runSynth loc (Synth g) = g loc++-- | Build a @Synth@ from a location-dependent, wanted-emitting action — the+-- inverse of 'runSynth'.  Lets a raw @CtLoc -> TcPluginM (EvTerm, [Ct])@+-- synthesizer be presented as a @Deriver@ (see @viaSynth@ in the plugin).+synthTc :: (CtLoc -> TcPluginM (a, [Ct])) -> Synth a+synthTc = Synth++-- | Lift a plugin action.+liftTc :: TcPluginM a -> Synth a+liftTc m = Synth \_ -> do a <- m; pure (a, [])++-- | The continuation: request the dictionary for @C ty@ and resume with its+-- evidence.  Emits the wanted so GHC solves it (possibly via this very plugin,+-- enabling recursion into the field's own instance).+field :: Class -> Type -> Synth CoreExpr+field cls ty = Synth \loc -> do+  ev <- newWanted loc (mkClassPred cls [ty])+  pure (ctEvExpr ev, [mkNonCanonical ev])++-- | A fresh local binder of the given type.+fresh :: Type -> String -> Synth Id+fresh ty s = liftTc $ do+  u <- unsafeTcPluginTcM getUniqueM+  pure (mkLocalId (mkSystemName u (mkVarOcc s)) manyDataConTy ty)++-- | A class method selected by its source name — order-independent, unlike+-- indexing @classMethods@ positionally (whose order can differ across GHC+-- versions).  Panics if the class has no such method (a plugin bug).+classMethod :: String -> Class -> Id+classMethod name cls =+  case filter ((== name) . occNameString . occName) (classMethods cls) of+    (m : _) -> m+    []      -> pprPanic "stock: classMethod: no method" (text name <+> ppr cls)++-- | Apply a class's dictionary constructor: @C:Cls \@ty m1 .. mn@.+classDict :: Class -> Type -> [CoreExpr] -> EvTerm+classDict cls ty methods =+  EvExpr (mkApps (Var (dataConWorkId (classDataCon cls))) (Type ty : methods))++-- | Build a (recursive) dictionary giving explicit superclass dictionaries and+-- implementations for the listed method indices; every other method is taken+-- from the class's own default (applied to the recursive dictionary).  Lets a+-- synthesizer fill a many-method class from a few key methods — e.g.+-- @Hashable@ from just @hashWithSalt@ (its @hash@ has a default), with its+-- @Eq@ superclass supplied as @[field eqCls ty]@.+classDictWith :: Class -> Type -> [CoreExpr] -> [(Int, CoreExpr)] -> Synth EvTerm+classDictWith cls ty supers overrides = do+  dvar    <- fresh (mkClassPred cls [ty]) "dict"+  methods <- forM (zip [0 ..] (classMethods cls)) \(i, _) ->+    case lookup i overrides of+      Just e  -> pure e+      Nothing -> case snd (classOpItems cls !! i) of+        Just (nm, _) -> do dm <- liftTc (tcLookupId nm)+                           pure (mkApps (Var dm) [Type ty, Var dvar])+        Nothing      -> error "stock: classDictWith: method has no default and no override"+  let EvExpr con = classDict cls ty (supers ++ methods)+  pure (EvExpr (Let (Rec [(dvar, con)]) (Var dvar)))++-- ---------------------------------------------------------------------------+-- SOP-style sum-of-products combinators+-- ---------------------------------------------------------------------------+--+-- A thin @generics-sop@ flavour over the structural view.  The correspondence:+--+-- @+--   generics-sop          role             Stock.Derive+--   ────────────          ────             ────────────+--   from x  (NS elim, ∃)  sum   dispatch    matchSOP   dt r x (\\i con fs -> …)+--   to . inj (NS intro)   sum   build       injectSOP  dt con fs+--   cpure_NP  (NP, Π)     field tabulate    cpureFields C k con+--   hcmap     (NP)        field map          cmapFields  C k con xs+--   cliftA2_NP (NP)       field zip          czipFields  C k con xs ys+--   hcfoldl   (NP)        field collapse     cfoldlFields C step z con xs+-- @+--+-- The split mirrors @SOP f = NS (NP f)@: 'matchSOP'\/'injectSOP' handle the+-- /sum/ (the @NS@, an existential over constructors); the @cpure@\/@cmap@\/+-- @czip@\/@cfoldl@ family handle one constructor's /product/ (its @NP@, the+-- representable @Fin n -> f@).  Because the @NP@ combinators take a+-- @Constructor@, they compose inside 'matchSOP' for any constructor of a sum,+-- not just the sole product one.  The @All c xs@ constraint is implicit: the+-- @c@-prefixed combinators call 'field' per field for the @cls@ dictionary.+-- So @eqDeriver@ (sum), @semigroupDeriver@\/@monoidDeriver@ (product) and+-- companions like @stock-hashable@\/@NFData@ read like their generic kin.++-- | The constructor of a product (the sole one).  Exported so product+-- synthesizers can feed it to the per-@Constructor@ NP combinators below.+productCon :: Datatype -> Constructor+productCon = head . dtCons++-- | The SOP eliminator (@from@ + @case@): scrutinise a value of the via-type+-- and dispatch on its constructor.  @k idx con fields@ builds the @resTy@-typed+-- branch body for constructor @con@ (index @idx@ in 'dtCons') with its bound+-- field expressions.  One alternative per constructor — so this is the+-- sum-of-products generalisation of 'fromProduct'.+matchSOP :: Datatype -> Type -> CoreExpr+         -> (Int -> Constructor -> [CoreExpr] -> Synth CoreExpr) -> Synth CoreExpr+matchSOP dt resTy v k = do+  cb   <- fresh (dtType dt) "s"+  alts <- forM (zip [0 ..] (dtCons dt)) \(i, c) -> do+    -- bind each pattern var at the /real/ field type (the coercion's LHS),+    -- then present the continuation the value coerced to the modifier type.+    xs   <- mapM (\co -> fresh (coercionLKind co) "x") (conFieldCos c)+    body <- k i c (zipWith castInto (map Var xs) (conFieldCos c))+    pure (Alt (DataAlt (conDataCon c)) xs body)+  pure (Case (Cast v (dtUnwrap dt)) cb resTy alts)++-- | @x |> co@, skipping the cast entirely when @co@ is reflexive (the+-- not-overridden case) so the generated Core stays byte-identical.+castInto :: CoreExpr -> Coercion -> CoreExpr+castInto e co = if isReflCo co then e else Cast e co++-- | The SOP introducer (@inj@ + @to@): build a value of the via-type from a+-- chosen constructor and one expression per its fields.+injectSOP :: Datatype -> Constructor -> [CoreExpr] -> CoreExpr+injectSOP dt c es =+  Cast (mkCoreConApps (conDataCon c) (map Type (tyConAppArgs (dtType dt)) ++ es'))+       (mkSymCo (dtUnwrap dt))+  where -- each result comes back at the modifier type; coerce it to the real+        -- field type before reapplying the constructor (no-op when reflexive).+        es' = zipWith (\e co -> castInto e (mkSymCo co)) es (conFieldCos c)++-- | @productTypeFrom@ + a continuation: the single-constructor case of+-- 'matchSOP'.+fromProduct :: Datatype -> Type -> CoreExpr -> ([CoreExpr] -> Synth CoreExpr)+            -> Synth CoreExpr+fromProduct dt resTy v k = matchSOP dt resTy v \_ _ fields -> k fields++-- | @productTypeTo@: the single-constructor case of 'injectSOP'.+toProduct :: Datatype -> [CoreExpr] -> CoreExpr+toProduct dt = injectSOP dt (productCon dt)++-- The NP combinators below all operate on ONE @Constructor@ (≅ one @NP@), so+-- they compose directly inside 'matchSOP' for /any/ constructor of a sum — not+-- just the sole product one.  An @NP@ is the representable functor @Fin n ->+-- f@: 'pureFields' tabulates it, 'mapFields'\/'zipFields' act positionwise, and+-- 'foldlFields' collapses it.  Each has a @c@onstrained sibling that requests+-- the field's @cls@ dictionary (the implicit @All c xs@).++-- | @pure_NP@ \/ @cpure_NP@: one result per field, produced from its type+-- (@cpure@ also from its @cls@ dictionary, e.g. @k ft d = mempty \@ft d@).+pureFields :: (Type -> Synth a) -> Constructor -> Synth [a]+pureFields k con = mapM k (conFields con)++-- | 'pureFields' that also hands each field its own @cls@ dictionary.+cpureFields :: Class -> (Type -> CoreExpr -> CoreExpr) -> Constructor -> Synth [CoreExpr]+cpureFields cls k = pureFields \ft -> do d <- field cls ft; pure (k ft d)++-- | @hmap@ \/ @hcmap@: map over the fields positionwise (the basic @NP@ action;+-- @cmap@ also hands each field's @cls@ dictionary to the step).+mapFields :: (Type -> CoreExpr -> Synth a) -> Constructor -> [CoreExpr] -> Synth [a]+mapFields k con xs = sequence (zipWith k (conFields con) xs)++-- | 'mapFields' that also hands each field its own @cls@ dictionary.+cmapFields :: Class -> (Type -> CoreExpr -> CoreExpr -> CoreExpr) -> Constructor -> [CoreExpr] -> Synth [CoreExpr]+cmapFields cls k = mapFields \ft x -> do d <- field cls ft; pure (k ft d x)++-- | @liftA2_NP@ \/ @cliftA2_NP@: combine two field-lists positionwise (@czip@+-- via each field's @cls@ dictionary, e.g. @k ft d x y = (\<>) \@ft d x y@).+zipFields :: (Type -> CoreExpr -> CoreExpr -> Synth a)+          -> Constructor -> [CoreExpr] -> [CoreExpr] -> Synth [a]+zipFields k con xs ys = sequence (zipWith3 k (conFields con) xs ys)++-- | 'zipFields' that also hands each field its own @cls@ dictionary.+czipFields :: Class -> (Type -> CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr)+           -> Constructor -> [CoreExpr] -> [CoreExpr] -> Synth [CoreExpr]+czipFields cls k = zipFields \ft x y -> do d <- field cls ft; pure (k ft d x y)++-- | @hfoldl@ \/ @cfoldl_NP@: collapse the fields left-to-right through an+-- accumulator @a@ (any host value — a 'CoreExpr', a list, …).  The step of the+-- unconstrained 'foldlFields' has full @Synth@ access (request any/no/several+-- dictionaries); 'cfoldlFields' hands it each field's @cls@ dictionary.  Needed+-- by accumulating classes, e.g. @Hashable@'s @hashWithSalt@ threading the salt.+foldlFields :: (a -> Type -> CoreExpr -> Synth a) -> a -> Constructor -> [CoreExpr] -> Synth a+foldlFields step z con fields =+  foldM (\acc (ft, e) -> step acc ft e) z (zip (conFields con) fields)++-- | 'foldlFields' that also hands each field its own @cls@ dictionary.+cfoldlFields :: Class+             -> (CoreExpr -> Type -> CoreExpr -> CoreExpr -> Synth CoreExpr)  -- ^ @acc ft dict field@+             -> CoreExpr            -- ^ initial accumulator+             -> Constructor -> [CoreExpr] -> Synth CoreExpr+cfoldlFields cls step =+  foldlFields \acc ft e -> do d <- field cls ft; step acc ft d e++-- | @htraverse@ over a list of fields: produce one @a@ per field in @Synth@.+-- The most general traversal-shaped combinator — used for applicative-effectful+-- work like generating `Gen a` values (for @Arbitrary@).  'traverseFields' has+-- full @Synth@ access; 'ctraverseFields' hands each field's @cls@ dictionary+-- to the step.+traverseFields :: (Type -> CoreExpr -> Synth a) -> Constructor -> [CoreExpr] -> Synth [a]+traverseFields k con xs = sequence (zipWith k (conFields con) xs)++-- | @hctraverse@: the @c@onstrained 'traverseFields' — requests each field's+-- @cls@ dictionary and hands it to the step (alongside the field value).+-- Used by @Arbitrary@ (request `Arbitrary ft` per field, emit `Gen ft`),+-- @CoArbitrary@ (request `CoArbitrary ft`, emit function generator),+-- and @Shrink@ (request `Shrink ft`, emit shrink list).+ctraverseFields :: Class+                -> (Type -> CoreExpr -> CoreExpr -> Synth CoreExpr)  -- ^ @ft dict field@+                -> Constructor -> [CoreExpr] -> Synth [CoreExpr]+ctraverseFields cls k = traverseFields \ft e -> do d <- field cls ft; k ft d e++-- ---------------------------------------------------------------------------+-- The witness interface+-- ---------------------------------------------------------------------------++-- | A class's synthesizer, keyed by the wrapper arity it works through.+newtype Deriver = Deriver { runDeriver :: Class -> Datatype -> Synth EvTerm }++-- | Register synthesis of a class @cls@ derived @via Stock@.  The method does+-- not mention @cls@, so the plugin selects the instance by looking it up in the+-- instance environment rather than by ordinary dispatch.+class DeriveStock (cls :: K.Type -> K.Constraint) where+  deriveStock :: Deriver++-- | A @Stock1@ synthesizer for a @(Type -> Type)@ class: given the class, the+-- constraint location, the via-target @Stock1 F@ and the inner @F@, build the+-- dictionary — or 'Nothing' if a field shape is unsupported.  (Lifted classes+-- need the parameter-variance walk, so they get the raw form rather than the+-- 'Datatype'-based 'Deriver'; the @Stock1@ 'TyCon' is recoverable as+-- @tyConAppTyCon@ of the via-target.)+newtype Deriver1 = Deriver1+  { runDeriver1 :: Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct])) }++-- | Register synthesis of a @(Type -> Type)@ class derived @via Stock1@ (the+-- lifted counterpart of 'DeriveStock' — e.g. @NFData1@, @Hashable1@).+class DeriveStock1 (cls :: (K.Type -> K.Type) -> K.Constraint) where+  deriveStock1 :: Deriver1++-- | The @Stock2@ analogue of 'Deriver1': given the class, the location, the+-- via-target @Stock2 P@ and the inner @P@, build the dictionary.+newtype Deriver2 = Deriver2+  { runDeriver2 :: Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct])) }++-- | Register synthesis of a @(Type -> Type -> Type)@ class derived @via Stock2@+-- (e.g. @NFData2@).+class DeriveStock2 (cls :: (K.Type -> K.Type -> K.Type) -> K.Constraint) where+  deriveStock2 :: Deriver2

@@ -0,0 +1,343 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}+-- | @Enum@ and @Ix@ synthesizers.  @Enum@ is for enumerations (all-nullary+-- constructors); its @toEnum@ range-checks like GHC.  @Ix@ covers both+-- enumerations ('synthIx') and single-constructor products ('synthIxProduct',+-- Cartesian range \/ mixed-radix index).  (@Bounded@ lives in "Stock.Bounded".)+module Stock.Enum 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)+import GHC.Builtin.Types.Prim (intPrimTy)+import GHC.Builtin.PrimOps (PrimOp(TagToEnumOp))+import GHC.Core.Make (mkRuntimeErrorApp, pAT_ERROR_ID)+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 Data.Maybe (catMaybes, fromJust, isJust, fromMaybe)+import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'+import Stock.Trans (MaybeT(..))+import Control.Monad (forM, zipWithM, unless, guard)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef')+import Stock.Internal+import Stock.Ord++-- | A constructor's fixity precedence (default 9), used for @Show@/@Read@ of+-- infix constructors (@showParen (d > prec)@, args at @prec+1@).+synthEnum :: Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]+          -> TcPluginM (EvTerm, [Ct])+synthEnum cls loc wrappedTy innerTy co dcons0 = do+  ordCls <- tcLookupClass ordClassName+  mapId  <- tcLookupId mapName+  eftId  <- tcLookupId enumFromToName        -- enumFromTo  (class method)+  efttId <- tcLookupId enumFromThenToName    -- enumFromThenTo (class method)+  let dcons       = map fst dcons0           -- enumerations have no fields to override+      tagToEnumId = primOpId TagToEnumOp+      geSel       = classMethod ">=" ordCls   -- (>=)+      maxTag      = mkUncheckedIntExpr (fromIntegral (length dcons - 1))+      toWrapped e = Cast e (mkSymCo co)+      fromInner v = Cast (Var v) co++  enumIntEv <- newWanted loc (mkClassPred cls    [intTy])+  ordIntEv  <- newWanted loc (mkClassPred ordCls [intTy])+  let enumIntDict = ctEvExpr enumIntEv+      ordIntDict  = ctEvExpr ordIntEv++  -- fromEnum v = <tag of v>+  fv  <- freshId wrappedTy "v"+  fcb <- freshId innerTy "cb"+  let fromEnumImpl = mkLams [fv] $+        Case (fromInner fv) fcb intTy+          [ Alt (DataAlt dc) [] (mkUncheckedIntExpr (fromIntegral i))+          | (i, dc) <- zip [0 :: Int ..] dcons ]++  -- toEnum i: GHC's derived toEnum RANGE-CHECKS and errors when out of range.+  -- Without the check, @tagToEnum#@ on a bad tag is undefined behaviour (it+  -- segfaults), so we replicate the guard: @if 0 <= i && i <= maxTag then+  -- tagToEnum# i else error@.+  ti  <- freshId intTy "i"+  tcb <- freshId intTy "ib"+  tip <- freshId intPrimTy "i#"+  bLo <- freshId boolTy "blo"+  bHi <- freshId boolTy "bhi"+  let leSel  = classMethod "<=" ordCls+      okCon  = Case (Var ti) tcb wrappedTy+                 [ Alt (DataAlt intDataCon) [tip]+                     (toWrapped (mkApps (Var tagToEnumId) [Type innerTy, Var tip])) ]+      errOut = mkRuntimeErrorApp pAT_ERROR_ID wrappedTy+                 "toEnum: argument out of range (derived via Stock)"+      toEnumImpl = mkLams [ti] $+        Case (mkApps (Var geSel) [Type intTy, ordIntDict, Var ti, mkUncheckedIntExpr 0]) bLo wrappedTy+          [ Alt (DataAlt falseDataCon) [] errOut+          , Alt (DataAlt trueDataCon)  []+              (Case (mkApps (Var leSel) [Type intTy, ordIntDict, Var ti, maxTag]) bHi wrappedTy+                 [ Alt (DataAlt falseDataCon) [] errOut+                 , Alt (DataAlt trueDataCon)  [] okCon ]) ]++  -- enumFrom x = map toEnum (enumFromTo (fromEnum x) maxTag)+  ex <- freshId wrappedTy "x"+  let mapToCon es = mkApps (Var mapId) [Type intTy, Type wrappedTy, toEnumImpl, es]+      enumFromImpl = mkLams [ex] $ mapToCon $+        mkApps (Var eftId) [Type intTy, enumIntDict, mkApps fromEnumImpl [Var ex], maxTag]++  -- enumFromThen x y = map toEnum (enumFromThenTo (fromEnum x) (fromEnum y) lim)+  --   where lim = if fromEnum y >= fromEnum x then maxTag else 0+  etx <- freshId wrappedTy "x"+  ety <- freshId wrappedTy "y"+  lbn <- freshId boolTy "b"+  let fx = mkApps fromEnumImpl [Var etx]+      fy = mkApps fromEnumImpl [Var ety]+      lim = Case (mkApps (Var geSel) [Type intTy, ordIntDict, fy, fx]) lbn intTy+              [ Alt (DataAlt falseDataCon) [] (mkUncheckedIntExpr 0)+              , Alt (DataAlt trueDataCon)  [] maxTag ]+      enumFromThenImpl = mkLams [etx, ety] $ mapToCon $+        mkApps (Var efttId) [Type intTy, enumIntDict, fx, fy, lim]++  -- succ / pred / enumFromTo / enumFromThenTo via class defaults (recursive dict)+  dmSucc <- defMethId cls 0+  dmPred <- defMethId cls 1+  dmEFT  <- defMethId cls 6+  dmEFTT <- defMethId cls 7+  dict <- recClassDict cls wrappedTy \dvar ->+    let useDef dm = mkApps (Var dm) [Type wrappedTy, Var dvar]+    in pure [ useDef dmSucc, useDef dmPred+            , toEnumImpl, fromEnumImpl+            , enumFromImpl, enumFromThenImpl+            , useDef dmEFT, useDef dmEFTT ]+  pure (EvExpr dict, [mkNonCanonical enumIntEv, mkNonCanonical ordIntEv])++-- | Synthesize an @Ix@ dictionary for an enumeration.  @range@/@unsafeIndex@/+-- @inRange@ work on constructor tags; @index@/@rangeSize@/@unsafeRangeSize@+-- come from the class defaults; the @Ord@ superclass is synthesized too.+synthIx :: Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]+        -> TcPluginM (EvTerm, [Ct])+synthIx cls loc wrappedTy innerTy co dcons0 = do+  ordCls  <- tcLookupClass ordClassName+  numCls  <- tcLookupClass numClassName+  enumCls <- tcLookupClass enumClassName+  mapId   <- tcLookupId mapName+  eftId   <- tcLookupId enumFromToName+  let dcons       = map fst dcons0           -- enumerations have no fields to override+      tagToEnumId = primOpId TagToEnumOp+      leSel  = classMethod "<=" ordCls          -- (<=)+      subSel = classMethod "-" numCls          -- (-)+      pairTy = mkBoxedTupleTy [wrappedTy, wrappedTy]+      tupCon = tupleDataCon Boxed 2+      toWrapped e = Cast e (mkSymCo co)+      fromInner v = Cast (Var v) co++  enumIntEv <- newWanted loc (mkClassPred enumCls [intTy])+  ordIntEv  <- newWanted loc (mkClassPred ordCls  [intTy])+  numIntEv  <- newWanted loc (mkClassPred numCls  [intTy])+  let enumIntDict = ctEvExpr enumIntEv+      ordIntDict  = ctEvExpr ordIntEv+      numIntDict  = ctEvExpr numIntEv++  -- tag function (fromEnum) and tagToEnum (toEnum), as in synthEnum+  fv <- freshId wrappedTy "v"; fcb <- freshId innerTy "cb"+  let fromEnumImpl = mkLams [fv] $ Case (fromInner fv) fcb intTy+        [ Alt (DataAlt dc) [] (mkUncheckedIntExpr (fromIntegral i))+        | (i, dc) <- zip [0 :: Int ..] dcons ]+      tagOf e = mkApps fromEnumImpl [e]+  ti <- freshId intTy "i"; tcb <- freshId intTy "ib"; tip <- freshId intPrimTy "i#"+  let toEnumImpl = mkLams [ti] $ Case (Var ti) tcb wrappedTy+        [ Alt (DataAlt intDataCon) [tip]+            (toWrapped (mkApps (Var tagToEnumId) [Type innerTy, Var tip])) ]++  -- range (l,u) = map toEnum (enumFromTo (tag l) (tag u))+  rlu <- freshId pairTy "lu"; rcb <- freshId pairTy "cb"+  rl  <- freshId wrappedTy "l"; ru <- freshId wrappedTy "u"+  let rangeImpl = mkLams [rlu] $ Case (Var rlu) rcb (mkListTy wrappedTy)+        [ Alt (DataAlt tupCon) [rl, ru]+            (mkApps (Var mapId) [Type intTy, Type wrappedTy, toEnumImpl,+               mkApps (Var eftId) [Type intTy, enumIntDict, tagOf (Var rl), tagOf (Var ru)]]) ]++  -- unsafeIndex (l,u) i = tag i - tag l+  ulu <- freshId pairTy "lu"; ucb <- freshId pairTy "cb"+  ul  <- freshId wrappedTy "l"; uu <- freshId wrappedTy "u"; ui <- freshId wrappedTy "i"+  let unsafeIndexImpl = mkLams [ulu, ui] $ Case (Var ulu) ucb intTy+        [ Alt (DataAlt tupCon) [ul, uu]+            (mkApps (Var subSel) [Type intTy, numIntDict, tagOf (Var ui), tagOf (Var ul)]) ]++  -- inRange (l,u) i = tag l <= tag i && tag i <= tag u+  ilu <- freshId pairTy "lu"; icb <- freshId pairTy "cb"+  il  <- freshId wrappedTy "l"; iu <- freshId wrappedTy "u"; ii <- freshId wrappedTy "i"+  ib  <- freshId boolTy "b"+  let le a b = mkApps (Var leSel) [Type intTy, ordIntDict, a, b]+      inRangeImpl = mkLams [ilu, ii] $ Case (Var ilu) icb boolTy+        [ Alt (DataAlt tupCon) [il, iu]+            (Case (le (tagOf (Var il)) (tagOf (Var ii))) ib boolTy+               [ Alt (DataAlt falseDataCon) [] (Var (dataConWorkId falseDataCon))+               , Alt (DataAlt trueDataCon)  [] (le (tagOf (Var ii)) (tagOf (Var iu))) ]) ]++  ordSuper <- unwrapEv . fst <$> synthOrd ordCls loc wrappedTy innerTy co dcons0+  dmIndex  <- defMethId cls 1+  dmRSize  <- defMethId cls 4+  dmURSize <- defMethId cls 5+  dict <- recClassDict cls wrappedTy \dvar ->+    let useDef dm = mkApps (Var dm) [Type wrappedTy, Var dvar]+    in pure [ ordSuper+            , rangeImpl, useDef dmIndex, unsafeIndexImpl, inRangeImpl+            , useDef dmRSize, useDef dmURSize ]+  pure (EvExpr dict, map mkNonCanonical [enumIntEv, ordIntEv, numIntEv])++-- | Synthesize @Ix (Stock P)@ for a single-constructor PRODUCT (like GHC):+-- @range@ is the Cartesian product of the per-field ranges (row-major nested+-- @concatMap@\/@map@), @unsafeIndex@ the mixed-radix index+-- (@acc * unsafeRangeSize fj + unsafeIndex fj@), @inRange@ the conjunction of+-- per-field @inRange@.  @index@\/@rangeSize@\/@unsafeRangeSize@ come from the+-- class defaults; the @Ord@ superclass is synthesized.+synthIxProduct :: Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]+               -> TcPluginM (EvTerm, [Ct])+synthIxProduct cls loc wrappedTy innerTy co dcons0 = do+  ordCls      <- tcLookupClass ordClassName+  numCls      <- tcLookupClass numClassName+  mapId       <- tcLookupId mapName+  concatMapId <- lookupOrig gHC_INTERNAL_LIST (mkVarOcc "concatMap") >>= tcLookupId+  let dc  = fst (head dcons0)+      fts = fieldTysAt innerTy dc+      rangeSel   = classMethod "range"           cls+      uIndexSel  = classMethod "unsafeIndex"     cls+      inRangeSel = classMethod "inRange"         cls+      uRSizeSel  = classMethod "unsafeRangeSize" cls+      mulSel     = classMethod "*" numCls+      addSel     = classMethod "+" numCls+      pairW      = mkBoxedTupleTy [wrappedTy, wrappedTy]+      tup2       = tupleDataCon Boxed 2+      listW      = mkListTy wrappedTy+      toWrapped e = Cast e (mkSymCo co)+      fromInner e = Cast e co+      conApp args = toWrapped (conAppAt innerTy dc args)+  fieldEvs <- mapM (\ft -> newWanted loc (mkClassPred cls [ft])) fts+  numIntEv <- newWanted loc (mkClassPred numCls [intTy])+  let dicts      = map ctEvExpr fieldEvs+      numIntDict = ctEvExpr numIntEv+      pairOf ft l u    = mkCoreConApps tup2 [Type ft, Type ft, l, u]      -- (l,u)::(ft,ft)+      rangeFE  ft d l u   = mkApps (Var rangeSel)   [Type ft, d, pairOf ft l u]+      uIdxFE   ft d l u i = mkApps (Var uIndexSel)  [Type ft, d, pairOf ft l u, i]+      inRngFE  ft d l u i = mkApps (Var inRangeSel) [Type ft, d, pairOf ft l u, i]+      uRSzFE   ft d l u   = mkApps (Var uRSizeSel)  [Type ft, d, pairOf ft l u]+      mul a b = mkApps (Var mulSel) [Type intTy, numIntDict, a, b]+      add a b = mkApps (Var addSel) [Type intTy, numIntDict, a, b]++  -- destructure a @wrappedTy@ bound into its field binders, wrapping a body+  let destr v binders resTy body = do+        cb <- freshId innerTy "cb"+        pure (Case (fromInner (Var v)) cb resTy [Alt (DataAlt dc) binders body])++  -- range (lo,hi) = [ P x.. | xj <- range (lj,uj) ]  (nested concatMap/map)+  luR <- freshId pairW "lu"; lcb <- freshId pairW "lcb"+  loR <- freshId wrappedTy "lo"; hiR <- freshId wrappedTy "hi"+  lsR <- mapM (`freshId` "l") fts; usR <- mapM (`freshId` "u") fts+  let mkRange []                 chosen = pure (mkListExpr wrappedTy [conApp (map Var chosen)])+      mkRange [(ft, d, l, u)]    chosen = do+        x <- freshId ft "x"+        pure (mkApps (Var mapId) [Type ft, Type wrappedTy+               , Lam x (conApp (map Var (chosen ++ [x]))), rangeFE ft d (Var l) (Var u)])+      mkRange ((ft, d, l, u) : r) chosen = do+        x  <- freshId ft "x"+        bd <- mkRange r (chosen ++ [x])+        pure (mkApps (Var concatMapId) [Type ft, Type wrappedTy, Lam x bd, rangeFE ft d (Var l) (Var u)])+  rangeInner <- mkRange (zip4 fts dicts lsR usR) []+  rangeUs    <- destr hiR usR listW rangeInner+  rangeLs    <- destr loR lsR listW rangeUs+  let rangeImpl = mkLams [luR] $ Case (Var luR) lcb listW+        [ Alt (DataAlt tup2) [loR, hiR] rangeLs ]++  -- unsafeIndex (lo,hi) i = mixed-radix: foldl (\a (l,u,i) -> a*urs(l,u) + uidx(l,u) i) 0+  luI <- freshId pairW "lu"; icb <- freshId pairW "icb"; iV <- freshId wrappedTy "i"+  loI <- freshId wrappedTy "lo"; hiI <- freshId wrappedTy "hi"+  lsI <- mapM (`freshId` "l") fts; usI <- mapM (`freshId` "u") fts; isI <- mapM (`freshId` "i") fts+  let idxBody = foldl (\acc (ft, d, l, u, i) -> add (mul acc (uRSzFE ft d (Var l) (Var u)))+                                                    (uIdxFE ft d (Var l) (Var u) (Var i)))+                      (mkUncheckedIntExpr 0) (zipWith5q fts dicts lsI usI isI)+  idxIs <- destr iV  isI intTy idxBody+  idxUs <- destr hiI usI intTy idxIs+  idxLs <- destr loI lsI intTy idxUs+  let uIndexImpl = mkLams [luI, iV] $ Case (Var luI) icb intTy+        [ Alt (DataAlt tup2) [loI, hiI] idxLs ]+        -- note: iV is the second lambda arg; destr on iV is inside (uses iV bound above)++  -- inRange (lo,hi) i = and [ inRange (lj,uj) ij ]+  luN <- freshId pairW "lu"; ncb <- freshId pairW "ncb"; nV <- freshId wrappedTy "i"+  loN <- freshId wrappedTy "lo"; hiN <- freshId wrappedTy "hi"+  lsN <- mapM (`freshId` "l") fts; usN <- mapM (`freshId` "u") fts; isN <- mapM (`freshId` "i") fts+  let conj []                  = pure (Var (dataConWorkId trueDataCon))+      conj ((ft, d, l, u, i) : more) = do+        b    <- freshId boolTy "b"+        rest <- conj more+        pure (Case (inRngFE ft d (Var l) (Var u) (Var i)) b boolTy+               [ Alt (DataAlt falseDataCon) [] (Var (dataConWorkId falseDataCon))+               , Alt (DataAlt trueDataCon)  [] rest ])+  inRBody <- conj (zipWith5q fts dicts lsN usN isN)+  inRIs   <- destr nV  isN boolTy inRBody+  inRUs   <- destr hiN usN boolTy inRIs+  inRLs   <- destr loN lsN boolTy inRUs+  let inRangeImpl = mkLams [luN, nV] $ Case (Var luN) ncb boolTy+        [ Alt (DataAlt tup2) [loN, hiN] inRLs ]++  (ordEv, ordWs) <- synthOrd ordCls loc wrappedTy innerTy co dcons0+  let ordSuper = unwrapEv ordEv+  dmIndex  <- defMethId cls 1+  dmRSize  <- defMethId cls 4+  dmURSize <- defMethId cls 5+  dict <- recClassDict cls wrappedTy \dvar ->+    let useDef dm = mkApps (Var dm) [Type wrappedTy, Var dvar]+    in pure [ ordSuper, rangeImpl, useDef dmIndex, uIndexImpl, inRangeImpl+            , useDef dmRSize, useDef dmURSize ]+  pure (EvExpr dict, map mkNonCanonical (fieldEvs ++ [numIntEv]) ++ ordWs)++-- 4-/5-way zips into tuples (local; avoid Data.List name clutter)+zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]+zip4 (a:as) (b:bs) (c:cs) (d:ds) = (a,b,c,d) : zip4 as bs cs ds+zip4 _ _ _ _ = []+zipWith5q :: [Type] -> [CoreExpr] -> [Id] -> [Id] -> [Id] -> [(Type, CoreExpr, Id, Id, Id)]+zipWith5q (a:as) (b:bs) (c:cs) (d:ds) (e:es) = (a,b,c,d,e) : zipWith5q as bs cs ds es+zipWith5q _ _ _ _ _ = []++-- | Synthesize a @Read@ dictionary for prefix (non-record, non-infix)+-- constructors, mirroring the Report's derived @readsPrec@:+--+--   readsPrec d = foldr (++) [] [ readParen (paren K) (parse K) | K <- cons ]+--   parse K r = [ (K a1..an, rn) | (tok,r1) <- lex r, tok == "K"+--                                , (a1,r2) <- readsPrec 11 r1, ... ]+--+-- @readList@/@readPrec@/@readListPrec@ come from the class default methods via+-- a recursive dictionary, so @read@ (which goes through @readPrec@) works too.

@@ -0,0 +1,154 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}+-- | @Eq@ synthesizer: two values are equal iff same constructor and all fields equal.+module Stock.Eq 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)+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 Data.Maybe (catMaybes, fromJust, isJust, fromMaybe)+import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'+import Stock.Trans (MaybeT(..))+import Control.Monad (forM, zipWithM, unless, guard)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef')+import Stock.Internal++-- @(==)@ is the SOP eliminator twice over: dispatch @a@, then @b@; equal+-- constructors conjoin their per-field @(==)@s (each field's @Eq@ a wanted),+-- mismatched constructors are @False@.  @(/=)@ negates @(==)@.+eqDeriver :: Deriver+eqDeriver = Deriver \cls dt -> do+  let via    = dtVia dt+      eqSel  = classMethod "==" cls+      true_  = Var (dataConWorkId trueDataCon)+      false_ = Var (dataConWorkId falseDataCon)+      -- x0==y0 && x1==y1 && … , short-circuiting via nested case; the last+      -- field is the bare comparison (as @&&@ and stock @deriving@ produce).+      eqField (ft, x, y) = do d <- field cls ft   -- the continuation: get Eq ft+                              pure (mkApps (Var eqSel) [Type ft, d, x, y])+      conjEq []     = pure true_+      conjEq [t]    = eqField t+      conjEq (t : rest) = do+        e     <- eqField t+        restE <- conjEq rest+        scr   <- fresh boolTy "c"+        pure (Case e scr boolTy+                [ Alt (DataAlt falseDataCon) [] false_+                , Alt (DataAlt trueDataCon)  [] restE ])+  aId <- fresh via "a"+  bId <- fresh via "b"+  body <- matchSOP dt boolTy (Var aId) \i ci xs ->+          matchSOP dt boolTy (Var bId) \j _  ys ->+            if i == j then conjEq (zip3 (conFields ci) xs ys) else pure false_+  let eqImpl = mkLams [aId, bId] body+  na <- fresh via "a" ; nb <- fresh via "b" ; ns <- fresh boolTy "c"+  let neqImpl = mkLams [na, nb] $+        Case (mkApps eqImpl [Var na, Var nb]) ns boolTy+          [ Alt (DataAlt falseDataCon) [] true_+          , Alt (DataAlt trueDataCon)  [] false_ ]+  pure (classDict cls via [eqImpl, neqImpl])++-- | Pointwise @Semigroup@ for a single-constructor product: @C x.. \<\> C y.. =+-- C (x \<\> y)..@, each field combined with its own @(\<\>)@ (a wanted).  Same+-- result as @Generically@, synthesized statically (a \"faster Generically\").+-- @sconcat@\/@stimes@ come from the class defaults.+synthEq :: Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]+        -> TcPluginM (EvTerm, [Ct])+synthEq cls loc wrappedTy innerTy co dcons = do+  let true_   = Var (dataConWorkId trueDataCon)+      false_  = Var (dataConWorkId falseDataCon)+      scrut v = Cast (Var v) co               -- (v |> co) :: innerTy+      indexed = zip [0 :: Int ..] dcons+      realFts dc = fieldTysAt innerTy dc       -- field's real (bind) type++  aId <- freshId wrappedTy "a"+  bId <- freshId wrappedTy "b"++  -- case (a|>co) of { Ci x.. -> case (b|>co) of { Cj y.. -> body i j } }+  outer <- forM indexed \(i, (dci, cosI)) -> do+    xs <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] (realFts dci)+    inner <- forM indexed \(j, (dcj, _)) -> do+      ys <- zipWithM (\n ft -> freshId ft ("y" ++ show n)) [0 :: Int ..] (realFts dcj)+      if i == j+        then do+          (body, ws) <- conj loc (zip3 xs ys cosI)+          pure (Alt (DataAlt dcj) ys body, ws)+        else pure (Alt (DataAlt dcj) ys false_, [])+    innerBndr <- freshId innerTy "cb"+    let (ialts, iws) = unzip inner+    pure (Alt (DataAlt dci) xs (Case (scrut bId) innerBndr boolTy ialts), concat iws)++  outerBndr <- freshId innerTy "ca"+  let (oalts, ows) = unzip outer+      eqImpl = mkLams [aId, bId] (Case (scrut aId) outerBndr boolTy oalts)++  -- (/=) = \a b -> case (==) a b of { False -> True; True -> False }+  na <- freshId wrappedTy "a"+  nb <- freshId wrappedTy "b"+  ns <- freshId boolTy "c"+  let neqImpl = mkLams [na, nb] $+        Case (mkApps eqImpl [Var na, Var nb]) ns boolTy+          [ Alt (DataAlt falseDataCon) [] true_+          , Alt (DataAlt trueDataCon)  [] false_ ]+      dict = mkClassDict cls wrappedTy [eqImpl, neqImpl]+  pure (EvExpr dict, concat ows)++-- | Conjoin per-field equalities — @and [x0 == y0, x1 == y1, …]@ — via 'andE'+-- (the short-circuiting @&&@ chain).  Each field's @Eq@ dictionary is a wanted.+-- Each triple is @(x, y, fieldCo)@; the field is compared at its modifier type+-- (@coercionRKind fieldCo@, the real type when 'Refl'), the bound values coerced.+conj :: CtLoc -> [(Id, Id, Coercion)] -> TcPluginM (CoreExpr, [Ct])+conj loc triples = do+  eqCls <- tcLookupClass eqClassName+  let eqSel = classMethod "==" eqCls              -- (==)+  evs <- mapM (\(_, _, fco) -> newWanted loc (mkClassPred eqCls [coercionRKind fco])) triples+  let cmp ((x, y, fco), ev) = mkApps (Var eqSel)+        [Type (coercionRKind fco), ctEvExpr ev, castInto (Var x) fco, castInto (Var y) fco]+  body <- andE (map cmp (zip triples evs))+  pure (body, map mkNonCanonical evs)++-- | Synthesize a full @Ord (Stock Inner)@ dictionary for any single-level+-- algebraic type: tag order between constructors, lexicographic within.  Every+-- comparison is derived from a single @compare@.  Returns the field @Ord@ and+-- @Eq@-superclass wanteds.

@@ -0,0 +1,323 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}+-- | @Functor@ \/ @Contravariant@ and @Foldable@ synthesizers over @Stock1@ (the variance walk).+module Stock.Functor 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)+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 Data.Maybe (catMaybes, fromJust, isJust, fromMaybe)+import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'+import Stock.Trans (MaybeT(..))+import Control.Monad (forM, zipWithM, unless, guard)+import Data.List (zipWith4)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef')+import Stock.Internal++synthFunctor :: GenEnv -> Class -> CtLoc -> Type -> Type+             -> TcPluginM (Maybe (EvTerm, [Ct]))+synthFunctor = synthMap1 Cov++-- | Synthesize @Contravariant (Stock1 F)@ — the contravariant instance of+-- @synthMap1@.+synthContravariant :: GenEnv -> Class -> CtLoc -> Type -> Type+                   -> TcPluginM (Maybe (EvTerm, [Ct]))+synthContravariant = synthMap1 Con++-- | The shared engine for the two single-parameter map-like classes over+-- @Stock1 F@.  @fmap@ and @contramap@ differ only in: the order of the two type+-- variables in the method (@forall a b@ vs @forall a' a@), the direction of the+-- supplied function (@a -> b@ vs @a' -> a@), and which 'varMap' base case it+-- feeds — so both are this one definition.  The non-overridden method (@(\<$)@+-- resp. @(>$)@, both at class-method index 1) comes from the class default; the+-- field walk is the full variance recursion in 'varMap'.+synthMap1 :: Variance -> GenEnv -> Class -> CtLoc -> Type -> Type+          -> TcPluginM (Maybe (EvTerm, [Ct]))+synthMap1 dir gen cls loc wrappedTy f =+  case geStock1 gen of+    Just st1Tc+      -- peel an optional @Override1 cfg F@: @realF@ is the genuine constructor,+      -- @mMods@ the per-field functor modifiers (e.g. @[] -> ZipList@).+      | let (realF, mMods) = peelOverride1 gen f+      , Just fTc <- tyConAppTyCon_maybe realF -> do+      functorCls <- tcLookupClass functorClassName+      let isCov   = case dir of Cov -> True; Con -> False+          fixed   = tyConAppArgs realF+          dcons   = tyConDataCons fTc+          coAt t  = coDown1 gen st1Tc wrappedTy f realF t   -- Stock1 (Override1? F) t ~R F t+      svTv <- freshTyVar "a"                                 -- scrutinee param (input @f@ is at it)+      rvTv <- freshTyVar (if isCov then "b" else "a'")       -- result param+      let svTy = mkTyVarTy svTv ; rvTy = mkTyVarTy rvTv+          innerS = mkTyConApp fTc (fixed ++ [svTy])+          gTy    = if isCov then mkVisFunTyMany svTy rvTy     -- fmap:      a  -> b+                            else mkVisFunTyMany rvTy svTy     -- contramap: a' -> a+      gId  <- freshId gTy "g"+      sfId <- freshId (mkAppTy wrappedTy svTy) "sf"+      cb   <- freshId innerS "cb"++      -- the only per-direction knobs: where the bare parameter maps, and whether+      -- contravariant subfields (@Pred a@) are allowed.  The variance walk then+      -- handles constants, covariant functor fields, and arbitrary arrow nesting.+      let (covFwd, conFwd, mContra)+            | isCov     = (Just (Var gId), Nothing,          Nothing)+            | otherwise = (Nothing,        Just (Var gId),   Just cls)+          -- @i@/@rvFt@ let an @Override1@ modifier reshape this field's functor+          -- (@h a -> m a@), feeding @varMap@ the modifier type and bridging the+          -- field value with @realFt ~R m a@ coercions.+          mapField i x ftA rvFt = case override1Mod gen mMods i of+            Nothing -> do+              m <- varMap functorCls mContra loc svTv rvTy covFwd conFwd Cov ftA+              pure (fmap (\(e, ws) -> (App e (Var x), ws)) m)+            Just modf -> do+              let effFt = mkAppTy modf svTy                                     -- m a+                  coS   = mkStockCo (PluginProv "stock") Representational ftA  effFt+                  coR   = mkStockCo (PluginProv "stock") Representational rvFt (mkAppTy modf rvTy)+              m <- varMap functorCls mContra loc svTv rvTy covFwd conFwd Cov effFt+              pure (fmap (\(e, ws) -> (Cast (App e (Cast (Var x) coS)) (mkSymCo coR), ws)) m)+          binders = if isCov then [svTv, rvTv] else [rvTv, svTv]++      malts <- forM dcons \dc -> do+        let fts   = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [svTy]))+            rvFts = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [rvTy]))+        xs <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] fts+        mfs <- sequence (zipWith4 mapField [0 :: Int ..] xs fts rvFts)+        case sequence mfs of+          Nothing    -> pure Nothing+          Just pairs ->+            let (vals, wss) = unzip pairs+                body = Cast (mkCoreConApps dc (map Type (fixed ++ [rvTy]) ++ vals))+                            (mkSymCo (coAt rvTy))            -- F rv -> Stock1 F rv+            in pure (Just (Alt (DataAlt dc) xs body, concat wss))++      case sequence malts of+        Nothing     -> pure Nothing+        Just altWss -> do+          let (alts, wss) = unzip altWss+              methodImpl = mkLams (binders ++ [gId, sfId])+                (destructInner fTc (fixed ++ [svTy]) (Cast (Var sfId) (coAt svTy))+                               cb (mkAppTy wrappedTy rvTy) alts)+          dmExtra <- defMethId cls 1                         -- (<$) / (>$)+          dict <- recClassDict cls wrappedTy \dvar ->+                    pure [ methodImpl, mkApps (Var dmExtra) [Type wrappedTy, Var dvar] ]+          pure (Just (EvExpr dict, concat wss))+    _ -> pure Nothing++-- | Synthesize @Foldable (Stock1 F)@.  @foldMap@ maps the parameter fields and+-- folds @H a@ fields with their own @foldMap@, combining contributions with+-- @(<>)@ (constant fields contribute nothing); all other @Foldable@ methods+-- come from the class defaults.  'Nothing' for unsupported field shapes.+synthFoldable :: GenEnv -> Class -> CtLoc -> Type -> Type+              -> TcPluginM (Maybe (EvTerm, [Ct]))+synthFoldable gen foldableCls loc wrappedTy f =+  case geStock1 gen of+    Just st1Tc+      | let (realF, mMods) = peelOverride1 gen f   -- @Override1@: reshape h-a fields+      , Just fTc <- tyConAppTyCon_maybe realF -> do+      monoidCls <- tcLookupClass monoidClassName+      let fixed      = tyConAppArgs realF+          dcons      = tyConDataCons fTc+          foldMapSel = classMethod "foldMap" foldableCls+          memptySel  = classMethod "mempty" monoidCls+          mappendSel = classMethod "mappend" monoidCls+          coAt t     = coDown1 gen st1Tc wrappedTy f realF t+      atv <- freshTyVar "a" ; mtv <- freshTyVar "m"+      let aTy = mkTyVarTy atv ; mTy = mkTyVarTy mtv+          innerA = mkTyConApp fTc (fixed ++ [aTy])+      dM  <- freshId (mkClassPred monoidCls [mTy]) "dM"+      gId <- freshId (mkVisFunTyMany aTy mTy) "g"+      tId <- freshId (mkAppTy wrappedTy aTy) "t"+      cb  <- freshId innerA "cb"+      let memptyE      = mkApps (Var memptySel) [Type mTy, Var dM]+          mappendE x y = mkApps (Var mappendSel) [Type mTy, Var dM, x, y]+          -- field contribution: Nothing = unsupported; Just Nothing = omitted+          -- foldMap :: forall m a. Monoid m => ...  (m is quantified first)+          foldMapOf h ev x = mkApps (Var foldMapSel)+                               [Type h, ev, Type mTy, Type aTy, Var dM, Var gId, x]+          -- GHC's @ft_*@ fold over a field's structure: a constant contributes+          -- nothing; the parameter contributes @g x@; a tuple folds every+          -- component and combines with @(<>)@; a covariant @H larg@ folds via+          -- @H@'s @foldMap@ (nested @[[a]]@ ⇒ @foldMap (foldMap g)@); a function+          -- field is rejected.  'Nothing' unsupported / @Just Nothing@ no+          -- contribution / @Just (Just (e,ws))@ contributes @e@.+          foldField ft xe+            | not (atv `elemVarSet` tyCoVarsOfType ft) = pure (Just Nothing)+            | ft `eqType` aTy                          = pure (Just (Just (App (Var gId) xe, [])))+            | Just _ <- splitFunTy_maybe ft            = pure Nothing+            | Just (tc, args) <- splitTyConApp_maybe ft+            , isTupleTyCon tc, length args >= 2 = do+                xs <- mapM (`freshId` "u") args+                rs <- zipWithM foldField args (map Var xs)+                case sequence rs of+                  Nothing  -> pure Nothing+                  Just mcs -> do+                    cb <- freshId ft "cb"+                    let (es, wss) = unzip (catMaybes mcs)+                        body = if null es then memptyE else foldr1 mappendE es+                    pure (Just (Just ( Case xe cb mTy+                           [Alt (DataAlt (tupleDataCon Boxed (length args))) xs body]+                           , concat wss )))+            | Just (h, larg) <- splitAppTy_maybe ft+            , not (atv `elemVarSet` tyCoVarsOfType h) = do+                y  <- freshId larg "y"+                mi <- foldField larg (Var y)+                case mi of+                  Just (Just (e, w)) -> do+                    ev <- newWanted loc (mkClassPred foldableCls [h])+                    pure (Just (Just ( mkApps (Var foldMapSel)+                           [Type h, ctEvExpr ev, Type mTy, Type larg, Var dM, Lam y e, xe]+                           , mkNonCanonical ev : w )))+                  _ -> pure Nothing+            | otherwise = pure Nothing+          contrib i x ftA = case override1Mod gen mMods i of+            -- Override1 reshapes the field's (one-level) functor @h a -> m a@.+            Just m  -> do ev <- newWanted loc (mkClassPred foldableCls [m])+                          let co = mkStockCo (PluginProv "stock") Representational ftA (mkAppTy m aTy)+                          pure (Just (Just (foldMapOf m (ctEvExpr ev) (Cast (Var x) co), [mkNonCanonical ev])))+            Nothing -> foldField ftA (Var x)+      malts <- forM dcons \dc -> do+        let ftsA = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aTy]))+        xs  <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] ftsA+        mcs <- sequence (zipWith3 contrib [0 :: Int ..] xs ftsA)+        case sequence mcs of+          Nothing       -> pure Nothing+          Just contribs ->+            let (es, wss) = unzip (catMaybes contribs)+                body = if null es then memptyE else foldr1 mappendE es+            in pure (Just (Alt (DataAlt dc) xs body, concat wss))+      -- @foldr@ (so @toList@\/@foldr@ do not fall back to the @Endo@-based+      -- default, which drags the @Stock1@ coercion along): synthesized to match+      -- GHC's stock derivation byte-for-byte.  @foldr f z (Con .. xi ..)@ nests+      -- a contribution per field around @z@: a constant passes the accumulator+      -- through; the parameter is @f xi rest@; a covariant @H a@ field is+      -- @(\\b1 b2 -> foldr (elemFn) b2 b1) xi rest@ (GHC's flip shape), where+      -- @elemFn@ recurses for nested structure.  Skipped under @Override1@+      -- (which reshapes fields and is handled only by @foldMap@).+      let foldrSel = classMethod "foldr" foldableCls+      faTv <- freshTyVar "a" ; fbTv <- freshTyVar "b"+      let faTy = mkTyVarTy faTv ; fbTy = mkTyVarTy fbTv+      ffId <- freshId (mkVisFunTyMany faTy (mkVisFunTyMany fbTy fbTy)) "f"+      fzId <- freshId fbTy "z"+      ftId <- freshId (mkAppTy wrappedTy faTy) "t"+      fcb  <- freshId (mkTyConApp fTc (fixed ++ [faTy])) "cb"+      let -- element-combine function for values of type @t@ (leaves are @faTy@,+          -- folded by @ffId@): @t -> b -> b@.+          mkElemFn :: Type -> TcPluginM (Maybe (CoreExpr, [Ct]))+          mkElemFn t+            | t `eqType` faTy = pure (Just (Var ffId, []))+            | Just (h, larg) <- splitAppTy_maybe t+            , not (faTv `elemVarSet` tyCoVarsOfType h) = do+                mfn <- mkElemFn larg+                case mfn of+                  Nothing        -> pure Nothing+                  Just (efn, w0) -> do+                    ev  <- newWanted loc (mkClassPred foldableCls [h])+                    p   <- freshId t "p" ; acc <- freshId fbTy "acc"+                    let e = mkLams [p, acc] (mkApps (Var foldrSel)+                              [Type h, ctEvExpr ev, Type larg, Type fbTy, efn, Var acc, Var p])+                    pure (Just (e, mkNonCanonical ev : w0))+            | otherwise = pure Nothing+          -- one field's contribution wrapped around continuation @k :: b@.+          contribR :: Type -> Id -> CoreExpr -> TcPluginM (Maybe (CoreExpr, [Ct]))+          contribR ft x k+            | not (faTv `elemVarSet` tyCoVarsOfType ft) = pure (Just (k, []))+            | ft `eqType` faTy = pure (Just (mkApps (Var ffId) [Var x, k], []))+            | Just _ <- splitFunTy_maybe ft = pure Nothing+            | Just (tc, args) <- splitTyConApp_maybe ft+            , isTupleTyCon tc, length args >= 2 = do+                us  <- mapM (`freshId` "u") args+                cbt <- freshId ft "ct"+                mb  <- combineR (zip args us) k+                pure $ flip fmap mb \(body, w) ->+                  ( Case (Var x) cbt fbTy+                      [Alt (DataAlt (tupleDataCon Boxed (length args))) us body], w )+            | Just (h, larg) <- splitAppTy_maybe ft+            , not (faTv `elemVarSet` tyCoVarsOfType h) = do+                mfn <- mkElemFn larg+                case mfn of+                  Nothing        -> pure Nothing+                  Just (efn, w0) -> do+                    ev <- newWanted loc (mkClassPred foldableCls [h])+                    b1 <- freshId ft "b1" ; b2 <- freshId fbTy "b2"+                    let flipLam = mkLams [b1, b2] (mkApps (Var foldrSel)+                          [Type h, ctEvExpr ev, Type larg, Type fbTy, efn, Var b2, Var b1])+                    pure (Just (mkApps flipLam [Var x, k], mkNonCanonical ev : w0))+            | otherwise = pure Nothing+          -- nest contributions right-to-left around @z@ (= leftmost field outermost).+          combineR :: [(Type, Id)] -> CoreExpr -> TcPluginM (Maybe (CoreExpr, [Ct]))+          combineR []            k = pure (Just (k, []))+          combineR ((ft, x) : r) k = do+            mr <- combineR r k+            case mr of+              Nothing       -> pure Nothing+              Just (k', w') -> do mc <- contribR ft x k'+                                  pure (fmap (\(e, w) -> (e, w ++ w')) mc)+      mFoldrAlts <- if isJust mMods then pure Nothing else fmap sequence $ forM dcons \dc -> do+        let ftsA = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [faTy]))+        xs <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] ftsA+        mb <- combineR (zip ftsA xs) (Var fzId)+        pure (fmap (\(body, w) -> (Alt (DataAlt dc) xs body, w)) mb)+      case sequence malts of+        Nothing     -> pure Nothing+        Just altWss -> do+          let (alts, wss) = unzip altWss+              foldMapImpl = mkLams [mtv, atv, dM, gId, tId]   -- forall m a. Monoid m => ...+                (destructInner fTc (fixed ++ [aTy]) (Cast (Var tId) (coAt aTy))+                               cb mTy alts)+              idxOf nm = head [ i | (i, m) <- zip [0 :: Int ..] (classMethods foldableCls)+                                  , occNameString (occName m) == nm ]+              (foldrMethods, foldrWs) = case mFoldrAlts of+                Just altWs ->+                  let (fAlts, fWss) = unzip altWs+                      foldrImpl = mkLams [faTv, fbTv, ffId, fzId, ftId]+                        (destructInner fTc (fixed ++ [faTy]) (Cast (Var ftId) (coAt faTy))+                                       fcb fbTy fAlts)+                  in ([(idxOf "foldr", foldrImpl)], concat fWss)+                Nothing -> ([], [])+          dict <- recDictWith foldableCls wrappedTy []+                    ((idxOf "foldMap", foldMapImpl) : foldrMethods)+          pure (Just (EvExpr dict, concat wss ++ foldrWs))+    _ -> pure Nothing++-- | Classify a field of a two-parameter type against the last two parameters+-- @a@ (first) and @b@ (second).

@@ -0,0 +1,387 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}+-- | @Generic@ \/ @Generic1@ synthesizers: @Rep@ as a balanced @:+:@ \/ @:*:@ tree.+module Stock.Generic 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)+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 Data.Maybe (catMaybes, fromJust, isJust, fromMaybe)+import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'+import Stock.Trans (MaybeT(..))+import Control.Monad (forM, zipWithM, unless, guard)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef')+import Stock.Internal++-- | Field types with @Override1@ modifiers applied: an @h a@ field whose config+-- names a modifier @m@ becomes @m a@ (so its @Rep1@ leaf is @Rec1 m@); all other+-- fields are unchanged.  Used by /both/ 'rewriteRep1' (the @Rep1@ type) and+-- 'synthGeneric1' (the @from1@\/@to1@ values), keeping them in lock-step.+reshape1Ftys :: GenEnv -> Maybe [Type] -> TyVar -> Type -> [Type] -> [Type]+reshape1Ftys gen mMods atv aTy fts =+  [ case (classifyField atv aTy ft, override1Mod gen mMods i) of+      (Just (FApp _), Just m) -> mkAppTy m aTy   -- @h a@ field → @m a@+      _                       -> ft+  | (i, ft) <- zip [0 :: Int ..] fts ]++rewriteRep :: GenEnv -> RewriteEnv -> [Ct] -> [Type] -> TcPluginM TcPluginRewriteResult+rewriteRep gen _env _given [arg]+  -- @Rep (Stock (Override T cfg))@: the leaves carry the /modifier/ types, so+  -- @Generically (Stock (Override T cfg))@ derives over the overridden fields.+  -- (Checked first; the plain branch would otherwise treat @Override@ as a data+  -- type.)  @synthGeneric@'s @from@\/@to@ coerce to match.+  | Just (realInner, cons) <- overrideFieldTypes gen arg = do+      fixOf <- mkFixOf (geMeta gen) (map fst cons)+      let struct = repMetaFts gen fixOf realInner cons+          lhs    = mkTyConApp (geRepTc gen) [arg]+          co     = mkStockCo (PluginProv "stock") Nominal lhs struct+      pure (TcPluginRewriteTo (mkReduction co struct) [])+  | Just repr <- mkRepr (geStock gen) arg, not (null (rCons repr)) = do+      fixOf <- mkFixOf (geMeta gen) (map ciCon (rCons repr))+      let struct = repMeta gen fixOf (rInner repr) (map ciCon (rCons repr))+          lhs    = mkTyConApp (geRepTc gen) [arg]+          co     = mkStockCo (PluginProv "stock") Nominal lhs struct+      pure (TcPluginRewriteTo (mkReduction co struct) [])+rewriteRep _ _ _ _ = pure TcPluginNoRewrite++-- | Rewrite @Rep1 (Stock1 F)@ to the parameter-aware structure (@Par1@\/@Rec1@\/+-- @Rec0@ leaves under the @M1@ metadata).  No rewrite if any field is an+-- unsupported shape (composition etc.).+rewriteRep1 :: GenEnv -> RewriteEnv -> [Ct] -> [Type] -> TcPluginM TcPluginRewriteResult+rewriteRep1 gen _env _given args+  | (arg : _)  <- reverse args             -- @Rep1@ is poly-kinded: drop the kind arg+  , Just st1Tc <- geStock1 gen+  , Just stTc  <- tyConAppTyCon_maybe arg, stTc == st1Tc+  , (_ : f : _) <- tyConAppArgs arg+    -- @f@ may be @Override1 cfg realF@: peel it, then reshape @h a@ fields to+    -- @m a@ so the @Rep1@ leaves use the modifier (in lock-step with 'synthGeneric1').+  , let (realF, mMods) = peelOverride1 gen f+  , Just fTc   <- tyConAppTyCon_maybe realF = do+      a0 <- freshTyVar "a"+      let aT0   = mkTyVarTy a0+          fixed = tyConAppArgs realF+          dcons = tyConDataCons fTc+          innerF = mkTyConApp fTc (fixed ++ [aT0])+          ftysOf dc = reshape1Ftys gen mMods a0 aT0+                        (map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aT0])))+          ok = all (all (isJust . rep1Field gen a0) . ftysOf) dcons+      if not ok then pure TcPluginNoRewrite else do+        fixOf <- mkFixOf (geMeta gen) dcons+        let struct = repMetaWith gen fixOf (fromJust . rep1Field gen a0) innerF+                       [ (dc, ftysOf dc) | dc <- dcons ]+            lhs    = mkTyConApp (g1RepTc (geGen1 gen)) args+            co     = mkStockCo (PluginProv "stock") Nominal lhs struct+        pure (TcPluginRewriteTo (mkReduction co struct) [])+rewriteRep1 _ _ _ _ = pure TcPluginNoRewrite++-- | The structural @Rep@ for a whole datatype: a single constructor is just its+-- product 'repStruct'; several constructors form a /balanced/ @:+:@ tree of+-- their product structs (mirroring GHC's @foldBal@).+-- @cons@ carries each constructor's /modifier/ field types ('ciFields') and the+-- per-cell coercions ('ciFieldCos', @realFieldType ~R modifierType@; 'Refl'+-- without an @Override@).  The @Rep@ leaves use the modifier types (matching+-- 'rewriteRep'); @from@ coerces the real field /into/ the leaf, @to@ coerces+-- /back/ before rebuilding.  Refl everywhere ⇒ byte-identical Core to plain.+synthGeneric :: GenEnv -> Type -> Type -> Coercion -> [ConInfo] -> TcPluginM EvTerm+synthGeneric gen wrappedTy innerTy co cons = do+  fixOf <- mkFixOf (geMeta gen) (map ciCon cons)+  let genCls = geGen gen+      k1Tc   = geK1Tc gen+      prodTc = geProdTc gen ; prodDc = geProdDc gen+      sumTc  = geSumTc gen+      [l1Dc, r1Dc] = tyConDataCons sumTc+      u1Dc   = head (tyConDataCons (geU1Tc gen))+      rTy    = geRTy gen+      kTy    = liftedTypeKind+      dcons    = map ciCon cons+      modFtss  = map ciFields cons                    -- Rep leaves (modifier types)+      cosss    = map ciFieldCos cons                  -- realFt ~R modFt per field+      realFtss = map (fieldTysAt innerTy) dcons        -- bound (pattern) types+      mfcss    = zipWith zip modFtss cosss             -- per con: [(modFt, fco)]+      structMeta = repMetaFts gen fixOf innerTy (zip dcons modFtss)   -- faithful (rewrite-target) Rep+      structBare = repData gen modFtss                          -- the un-M1 value structure+      lhs    = mkTyConApp (geRepTc gen) [wrappedTy]+      coRep  = mkStockCo (PluginProv "stock") Nominal lhs structMeta+      -- the M1 layers are newtypes, so structMeta ~R structBare (asserted, true)+      coStrip = mkStockCo (PluginProv "stock") Representational structMeta structBare++  ux <- unsafeTcPluginTcM getUniqueM+  let xtv = mkTyVar (mkSystemName ux (mkTyVarOcc "x")) liftedTypeKind+      xty = mkTyVarTy xtv+      prodTy f g = mkTyConApp prodTc [kTy, f, g]+      sumTy  f g = mkTyConApp sumTc  [kTy, f, g]+      -- Rep x ~R structMeta x ~R structBare x  (and back)+      castDn = mkSubCo (mkAppCo coRep (mkNomReflCo xty))             -- Rep x ~R structMeta x+                 `mkTransCo` mkAppCo coStrip (mkNomReflCo xty)       -- structMeta x ~R structBare x+      castUp = mkSymCo castDn                                        -- structBare x ~R Rep x+      k1Co ft     = mkUnbranchedAxInstCo Representational+                      (newTyConCo k1Tc) [kTy, rTy, ft, xty] []   -- K1 R ft x ~R ft+      -- from: real field value (fi :: realFt) coerced to its modifier type, into K1 modFt+      k1ValOv fco mft fi = Cast (castInto (Var fi) fco) (mkSymCo (k1Co mft))+      -- to: a K1 modFt projection back to the real field type+      unK1Ov  fco mft scr = castInto (Cast scr (k1Co mft)) (mkSymCo fco)+      -- balanced product VALUE (+ its type), mirroring 'repStruct'/'foldBal'+      buildV [(v, t)] = (v, t)+      buildV vs = let (l, r)  = splitAt (length vs `div` 2) vs+                      (lv, lt) = buildV l ; (rv, rt) = buildV r+                  in ( mkCoreConApps prodDc [Type kTy, Type lt, Type rt, Type xty, lv, rv]+                     , prodTy lt rt )+      -- product value for one constructor's fields (per field: its (modFt, fco) + binder)+      prodValOf mfcs fis+        | null mfcs = mkCoreConApps u1Dc [Type kTy, Type xty]+        | otherwise = fst (buildV [ (k1ValOv fco mft fi, mkTyConApp k1Tc [kTy, rTy, mft])+                                  | ((mft, fco), fi) <- zip mfcs fis ])+      -- balanced @:+:@ injectors (one per constructor) + the sum type+      injectors [fts] = ([id], repStruct gen fts)+      injectors fss   =+        let (l, r)   = splitAt (length fss `div` 2) fss+            (li, lt) = injectors l ; (ri, rt) = injectors r+            wrapL v  = mkCoreConApps l1Dc [Type kTy, Type lt, Type rt, Type xty, v]+            wrapR v  = mkCoreConApps r1Dc [Type kTy, Type lt, Type rt, Type xty, v]+        in (map (wrapL .) li ++ map (wrapR .) ri, sumTy lt rt)+      (injs, _) = injectors modFtss++  -- from = /\x. \v -> case (v |> co) of  Cᵢ f.. -> injᵢ <product> |> castUp+  vId <- freshId wrappedTy "v"+  cbV <- freshId innerTy "cb"+  fromAlts <- forM (zip dcons (zip3 realFtss mfcss injs)) \(dc, (realFts, mfcs, inj)) -> do+    fis <- zipWithM (\n ft -> freshId ft ("f" ++ show n)) [0 :: Int ..] realFts+    pure (Alt (DataAlt dc) fis (Cast (inj (prodValOf mfcs fis)) castUp))+  let fromImpl = Lam xtv (Lam vId+                   (Case (Cast (Var vId) co) cbV (mkAppTy lhs xty) fromAlts))++  -- to = /\x. \r -> <project (r |> castDn) through :+: / :*:, rebuild Cᵢ>+  rId <- freshId (mkAppTy lhs xty) "r"+  let -- take apart a balanced :*: product (typed by the modifier types), returning the+      -- real-typed field exprs (each projected then coerced back) + a case-nesting wrapper+      destruct scr [(mft, fco)] = pure ([unK1Ov fco mft scr], id)+      destruct scr mfs = do+        let (lT, rT) = splitAt (length mfs `div` 2) mfs+            lt = repStruct gen (map fst lT) ; rt = repStruct gen (map fst rT)+        lv <- freshId (mkAppTy lt xty) "l"+        rv <- freshId (mkAppTy rt xty) "rr"+        cb <- freshId (mkAppTy (prodTy lt rt) xty) "pc"+        (lfs, lwrap) <- destruct (Var lv) lT+        (rfs, rwrap) <- destruct (Var rv) rT+        let wrap body = Case scr cb wrappedTy+                          [Alt (DataAlt prodDc) [lv, rv] (lwrap (rwrap body))]+        pure (lfs ++ rfs, wrap)+      -- rebuild one constructor from its product struct+      rebuildCon scr mfs dc+        | null mfs  = pure (Cast (conAppAt innerTy dc []) (mkSymCo co))+        | otherwise = do (fields, wrap) <- destruct scr mfs+                         pure (wrap (Cast (conAppAt innerTy dc fields) (mkSymCo co)))+      -- project through the balanced :+: tree, rebuilding at each leaf+      destructSum scr [mfs] [dc] = rebuildCon scr mfs dc+      destructSum scr mfss  dcs  = do+        let h          = length mfss `div` 2+            (lfs, rfs) = splitAt h mfss ; (ldc, rdc) = splitAt h dcs+            lt = repData gen (map (map fst) lfs) ; rt = repData gen (map (map fst) rfs)+        lv <- freshId (mkAppTy lt xty) "sl"+        rv <- freshId (mkAppTy rt xty) "sr"+        cb <- freshId (mkAppTy (sumTy lt rt) xty) "sc"+        lbody <- destructSum (Var lv) lfs ldc+        rbody <- destructSum (Var rv) rfs rdc+        pure (Case scr cb wrappedTy+                [ Alt (DataAlt l1Dc) [lv] lbody, Alt (DataAlt r1Dc) [rv] rbody ])+  toBody <- destructSum (Cast (Var rId) castDn) mfcss dcons+  let toImpl = Lam xtv (Lam rId toBody)++  pure $ EvExpr $ mkClassDict genCls wrappedTy [fromImpl, toImpl]++-- | Synthesize @Generic1 (Stock1 F)@: like 'synthGeneric' but the field+-- representation is parameter-aware — the last type variable @a@ becomes+-- @Par1@, @g a@ becomes @Rec1 g@, a constant becomes @Rec0@ (see 'rep1Field').+-- @from1@\/@to1@ wrap\/unwrap each field through the corresponding newtype.+-- 'Nothing' for shapes 'rep1Field' rejects (e.g. composition @f (g a)@).+synthGeneric1 :: GenEnv -> Class -> CtLoc -> Type -> Type+              -> TcPluginM (Maybe (EvTerm, [Ct]))+synthGeneric1 gen cls loc wrappedTy f =+  case (geStock1 gen, tyConAppTyCon_maybe realF) of+    (Just st1Tc, Just fTc) -> do+      functorCls <- tcLookupClass functorClassName+      let g1     = geGen1 gen+          fixed  = tyConAppArgs realF+          dcons  = tyConDataCons fTc+          k1Tc   = geK1Tc gen ; rTy = geRTy gen ; kTy = liftedTypeKind+          par1Tc = g1Par1Tc g1 ; rec1Tc = g1Rec1Tc g1 ; compTc = g1CompTc g1+          fmapSel = classMethod "fmap" functorCls+          prodTc = geProdTc gen ; prodDc = geProdDc gen+          sumTc  = geSumTc gen ; [l1Dc, r1Dc] = tyConDataCons sumTc+          u1Dc   = head (tyConDataCons (geU1Tc gen))+          coAt t = coDown1 gen st1Tc wrappedTy f realF t+      atv <- freshTyVar "a"+      let aTy    = mkTyVarTy atv+          innerA = mkTyConApp fTc (fixed ++ [aTy])+          prodTy a b = mkTyConApp prodTc [kTy, a, b]+          sumTy  a b = mkTyConApp sumTc  [kTy, a, b]+          u1Ty   = mkTyConApp (geU1Tc gen) [kTy]+          par1Co   = mkUnbranchedAxInstCo Representational (newTyConCo par1Tc) [aTy] []+          rec1Co h = mkUnbranchedAxInstCo Representational (newTyConCo rec1Tc) [kTy, h, aTy] []+          k1Co t   = mkUnbranchedAxInstCo Representational (newTyConCo k1Tc) [kTy, rTy, t, aTy] []+          fieldsOf dc = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aTy]))+          -- classify a field → (bare leaf type, wrap, unwrap, emitted wanteds).+          -- wrap\/unwrap are value transforms; composition emits a @Functor@+          -- wanted and uses @Comp1 . fmap innerWrap@ (matching GHC's DeriveGeneric1).+          classify1 mMod ft+            | ft `eqType` aTy =+                pure (Just (mkTyConTy par1Tc, \e -> Cast e (mkSymCo par1Co), \e -> Cast e par1Co, []))+            | not (atv `elemVarSet` tyCoVarsOfType ft) =+                pure (Just (mkTyConApp k1Tc [kTy, rTy, ft], \e -> Cast e (mkSymCo (k1Co ft)), \e -> Cast e (k1Co ft), []))+            | Just (h, larg) <- splitAppTy_maybe ft+            , not (atv `elemVarSet` tyCoVarsOfType h) =+                if larg `eqType` aTy+                  -- @h a@ leaf, reshaped to @Rec1 m@ under @Override1@: wrap coerces+                  -- the field value @h a ~R m a@ then into @Rec1 m a@; unwrap reverses.+                  then let m  = fromMaybe h mMod+                           co = reshapeCo h m aTy+                       in pure (Just ( mkTyConApp rec1Tc [kTy, m]+                                     , \e -> Cast e (co `mkTransCo` mkSymCo (rec1Co m))+                                     , \e -> Cast e (rec1Co m `mkTransCo` mkSymCo co), [] ))+                  else do+                    minner <- classify1 Nothing larg+                    case minner of+                      Nothing -> pure Nothing+                      Just (innerRep, innerWrap, innerUnwrap, iws) -> do+                        ev  <- newWanted loc (mkClassPred functorCls [h])+                        yId <- freshId larg "y"+                        zId <- freshId (mkAppTy innerRep aTy) "z"+                        let dict      = ctEvExpr ev+                            compTy    = mkTyConApp compTc [kTy, kTy, h, innerRep]+                            comp1Co   = mkUnbranchedAxInstCo Representational+                                          (newTyConCo compTc) [kTy, kTy, h, innerRep, aTy] []+                            innerAppA = mkAppTy innerRep aTy+                            fmapAt aT bT fn x = mkApps (Var fmapSel) [Type h, dict, Type aT, Type bT, fn, x]+                            -- Comp1 (fmap innerWrap e)        :: (h :.: innerRep) a+                            wrapE e   = Cast (fmapAt larg innerAppA (mkLams [yId] (innerWrap (Var yId))) e)+                                             (mkSymCo comp1Co)+                            -- fmap innerUnwrap (unComp1 e)    :: h larg+                            unwrapE e = fmapAt innerAppA larg (mkLams [zId] (innerUnwrap (Var zId))) (Cast e comp1Co)+                        pure (Just (compTy, wrapE, unwrapE, mkNonCanonical ev : iws))+            | otherwise = pure Nothing+      classifiedM <- forM dcons \dc ->+        zipWithM (\i ft -> classify1 (override1Mod gen mMods i) ft) [0 :: Int ..] (fieldsOf dc)+      case traverse sequence classifiedM of+        Nothing -> pure Nothing+        Just classified -> do+          fixOf <- mkFixOf (geMeta gen) dcons+          let fieldWanteds = concatMap (concatMap (\(_, _, _, ws) -> ws)) classified+              leafTys con = [ lt | (lt, _, _, _) <- con ]+              bareCon con = case leafTys con of { [] -> u1Ty; lts -> foldBal prodTy lts }+              structBare  = case map bareCon classified of { [s] -> s; ss -> foldBal sumTy ss }+              structMeta  = repMetaWith gen fixOf (fromJust . rep1Field gen atv) innerA+                              [ (dc, reshape1Ftys gen mMods atv aTy (fieldTysAt innerA dc)) | dc <- dcons ]+              lhs1   = mkTyConApp (g1RepTc g1) [liftedTypeKind, wrappedTy]+              coRep  = mkStockCo (PluginProv "stock") Nominal lhs1 structMeta+              coStrip = mkStockCo (PluginProv "stock") Representational structMeta structBare+              castDn = mkSubCo (mkAppCo coRep (mkNomReflCo aTy))+                         `mkTransCo` mkAppCo coStrip (mkNomReflCo aTy)   -- Rep1..a ~R structBare a+              castUp = mkSymCo castDn+              -- balanced :*: VALUE for one constructor (over the leaf values/types)+              buildV [(v, t)] = (v, t)+              buildV vs = let (l, r) = splitAt (length vs `div` 2) vs+                              (lv, lt) = buildV l ; (rv, rt) = buildV r+                          in ( mkCoreConApps prodDc [Type kTy, Type lt, Type rt, Type aTy, lv, rv]+                             , prodTy lt rt )+              prodValOf con fis+                | null con  = mkCoreConApps u1Dc [Type kTy, Type aTy]+                | otherwise = fst (buildV [ (wrap (Var fi), lt) | ((lt, wrap, _, _), fi) <- zip con fis ])+              -- balanced :+: injectors, by the bare struct types+              injectors [con] = ([id], bareCon con)+              injectors cs =+                let (l, r) = splitAt (length cs `div` 2) cs+                    (li, lt) = injectors l ; (ri, rt) = injectors r+                    wrapL v = mkCoreConApps l1Dc [Type kTy, Type lt, Type rt, Type aTy, v]+                    wrapR v = mkCoreConApps r1Dc [Type kTy, Type lt, Type rt, Type aTy, v]+                in (map (wrapL .) li ++ map (wrapR .) ri, sumTy lt rt)+              (injs, _) = injectors classified++          vId <- freshId (mkAppTy wrappedTy aTy) "v"+          cbV <- freshId innerA "cb"+          fromAlts <- forM (zip3 dcons classified injs) \(dc, con, inj) -> do+            fis <- zipWithM (\n ft -> freshId ft ("f" ++ show n)) [0 :: Int ..] (fieldsOf dc)+            pure (Alt (DataAlt dc) fis (Cast (inj (prodValOf con fis)) castUp))+          let fromImpl = Lam atv (Lam vId+                           (Case (Cast (Var vId) (coAt aTy)) cbV (mkAppTy lhs1 aTy) fromAlts))++          rId <- freshId (mkAppTy lhs1 aTy) "r"+          let destruct scr [(_, _, unwrap, _)] = pure ([unwrap scr], id)+              destruct scr con = do+                let (lc, rc) = splitAt (length con `div` 2) con+                    lt = bareCon lc ; rt = bareCon rc+                lv <- freshId (mkAppTy lt aTy) "l"+                rv <- freshId (mkAppTy rt aTy) "rr"+                cb <- freshId (mkAppTy (prodTy lt rt) aTy) "pc"+                (lfs, lw) <- destruct (Var lv) lc+                (rfs, rw) <- destruct (Var rv) rc+                pure (lfs ++ rfs, \body -> Case scr cb (mkAppTy wrappedTy aTy)+                        [Alt (DataAlt prodDc) [lv, rv] (lw (rw body))])+              rebuildCon scr con dc+                | null con  = pure (Cast (conAppAt innerA dc []) (mkSymCo (coAt aTy)))+                | otherwise = do (fields, wrap) <- destruct scr con+                                 pure (wrap (Cast (conAppAt innerA dc fields) (mkSymCo (coAt aTy))))+              destructSum scr [con] [dc] = rebuildCon scr con dc+              destructSum scr cs    dcs  = do+                let h = length cs `div` 2+                    (lc, rc) = splitAt h cs ; (ldc, rdc) = splitAt h dcs+                    lt = case lc of { [c] -> bareCon c; _ -> foldBal sumTy (map bareCon lc) }+                    rt = case rc of { [c] -> bareCon c; _ -> foldBal sumTy (map bareCon rc) }+                lv <- freshId (mkAppTy lt aTy) "sl"+                rv <- freshId (mkAppTy rt aTy) "sr"+                cb <- freshId (mkAppTy (sumTy lt rt) aTy) "sc"+                lb <- destructSum (Var lv) lc ldc+                rb <- destructSum (Var rv) rc rdc+                pure (Case scr cb (mkAppTy wrappedTy aTy)+                        [Alt (DataAlt l1Dc) [lv] lb, Alt (DataAlt r1Dc) [rv] rb])+          toBody <- destructSum (Cast (Var rId) castDn) classified dcons+          let toImpl = Lam atv (Lam rId toBody)+              -- Generic1 is poly-kinded: its dictionary constructor takes the+              -- kind argument before the type argument.+              dict = mkApps (Var (dataConWorkId (classDataCon cls)))+                       [Type liftedTypeKind, Type wrappedTy, fromImpl, toImpl]+          pure (Just (EvExpr dict, fieldWanteds))+    _ -> pure Nothing+  where (realF, mMods) = peelOverride1 gen f++-- | Variance of an occurrence of the type parameter.

@@ -0,0 +1,1463 @@+{-# 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+  { geStock   :: Maybe TyCon  -- ^ our @Stock.Stock@ ('Nothing' if not in scope)+  , geStock1  :: Maybe TyCon  -- ^ our @Stock.Stock1@+  , geStock2  :: Maybe TyCon  -- ^ our @Stock.Stock2@+  , geWitness :: Maybe Class -- ^ @Stock.Derive.DeriveStock@ (for discovered derivers)+  , geGen     :: Class+  , geRepTc   :: TyCon+  , geU1Tc    :: TyCon+  , geK1Tc    :: TyCon+  , geProdTc  :: TyCon+  , geProdDc  :: DataCon+  , geSumTc   :: TyCon       -- ^ @:+:@ (for sum-type @Rep@s)+  , geMeta    :: MetaEnv     -- ^ @M1@ + promoted @Meta@ pieces (for metadata layers)+  , geGen1    :: Gen1Env     -- ^ @Generic1@ / @Rep1@ pieces+  , geRTy     :: Type     -- ^ the @R@ tag (for @Rec0 = K1 R@)+  , geOverride :: Maybe TyCon  -- ^ @Stock.Override.Override@ ('Nothing' if not in scope)+  , geAssign   :: Maybe TyCon  -- ^ @Stock.Override.(:=)@ — the config-entry marker+  , geAt       :: Maybe TyCon  -- ^ @Stock.Override.At@ — the positional selector marker+  , geKeep     :: Maybe TyCon  -- ^ @Stock.Override.Keep@ — the positional no-op (@_@) marker+  , geArrow    :: Maybe TyCon  -- ^ @Stock.Override.(-->)@ — the path-addressing marker+  , geWitness1 :: Maybe Class  -- ^ @Stock.Derive.DeriveStock1@ (lifted discovered derivers)+  , geWitness2 :: Maybe Class  -- ^ @Stock.Derive.DeriveStock2@ (bi-lifted discovered derivers)+  , geOverride2 :: Maybe TyCon -- ^ @Stock.Override.Override2@ — per-field override at the @Stock2@ level+  , 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+  { meM1          :: TyCon        -- ^ @M1@+  , meD, meC, meS :: Type        -- ^ the @D@\/@C@\/@S@ tags (kind @Type@)+  , meMetaData    :: TyCon        -- ^ promoted @'MetaData@+  , meMetaCons    :: TyCon        -- ^ promoted @'MetaCons@+  , meMetaSel     :: TyCon        -- ^ promoted @'MetaSel@+  , mePrefixI     :: Type         -- ^ @'PrefixI@+  , meInfixI      :: TyCon        -- ^ promoted @'InfixI@ (assoc → nat → FixityI)+  , meLeftAssoc, meRightAssoc, meNotAssoc :: Type  -- ^ promoted @Associativity@+  , meNoUnpack, meSrcNoUnpack, meSrcUnpack :: Type -- ^ promoted @SourceUnpackedness@+  , meNoStrict, meSrcLazy, meSrcStrict     :: Type -- ^ promoted @SourceStrictness@+  , meDecidedLazy, meDecidedStrict, meDecidedUnpack :: Type -- ^ promoted @DecidedStrictness@+  , meJustSym     :: TyCon        -- ^ promoted @'Just@ \@Symbol+  , meNothingSym  :: Type         -- ^ @'Nothing \@Symbol@+  }++-- | @Generic1@ entities: the class, the @Rep1@ family, and the parameter-aware+-- representation pieces @Par1@\/@Rec1@\/@(:.:)@.+data Gen1Env = Gen1Env+  { g1RepTc  :: TyCon   -- ^ @Rep1@+  , g1Par1Tc :: TyCon   -- ^ @Par1@ (the bare parameter)+  , g1Rec1Tc :: TyCon   -- ^ @Rec1@ (@g a@)+  , g1CompTc :: TyCon   -- ^ @(:.:)@ (composition, @f (g a)@)+  }++-- | Plugin state: error-message dedup set + the @Generic@ entities.+data PluginState = PluginState+  { psSeen :: IORef [String]+  , 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 []     = pure (Var (dataConWorkId trueDataCon))+andE [a]    = pure a+andE (a:as) = do+  r   <- andE 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 modName occ = do+  res <- findImportedModule (mkModuleName modName) NoPkgQual+  case res of+    Found _ m -> Just <$> (lookupOrig m (mkTcOcc occ) >>= tcLookupTyCon)+    _         -> pure Nothing++-- | Look up the @M1@ + promoted @Meta@ entities for metadata layers.+lookupMetaEnv :: TcPluginM MetaEnv+lookupMetaEnv = do+  let gTc occ = lookupOrig gHC_INTERNAL_GENERICS (mkTcOcc occ)   >>= tcLookupTyCon+      gDc occ = lookupOrig gHC_INTERNAL_GENERICS (mkDataOcc occ) >>= tcLookupDataCon+      promTy  = fmap (mkTyConTy . promoteDataCon) . gDc+  m1  <- gTc "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 = do+  let gTc occ = lookupOrig gHC_INTERNAL_GENERICS (mkTcOcc occ) >>= tcLookupTyCon+  Gen1Env <$> gTc "Rep1" <*> gTc "Par1" <*> gTc "Rec1" <*> gTc ":.:"++-- | Look up a class by module + name, 'Nothing' if its module isn't available.+lookupClassMaybe :: String -> String -> TcPluginM (Maybe Class)+lookupClassMaybe modName occ = do+  res <- findImportedModule (mkModuleName modName) NoPkgQual+  case res of+    Found _ m -> Just <$> (lookupOrig m (mkTcOcc occ) >>= tcLookupClass)+    _         -> pure 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 modName occ = do+  res <- findImportedModule (mkModuleName modName) NoPkgQual+  case res of+    Found _ m -> Just <$> (lookupOrig m (mkVarOcc occ) >>= tcLookupId)+    _         -> pure 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 gen [fts] = repStruct gen fts+repData gen ftss  = foldBal sumOf (map (repStruct gen) ftss) where +  sumOf :: Type -> Type -> Type+  sumOf f g = mkTyConApp (geSumTc gen) [liftedTypeKind, f, 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 gen t = mkTyConApp (geK1Tc gen) [liftedTypeKind, geRTy gen, t]++repMeta :: GenEnv -> (DataCon -> Type) -> Type -> [DataCon] -> Type+repMeta gen fixOf innerTy dcons =+  repMetaWith gen fixOf (rec0Of gen) innerTy [ (dc, fieldTysAt innerTy dc) | dc <- 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 gen fixOf = repMetaWith gen fixOf (rec0Of 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 gen fixOf leaf innerTy cons =+  d1 (metaData innerTc) (foldBal sumTy (map conRep cons)) where+  me      = geMeta gen+  innerTc = tyConAppTyCon innerTy+  kTy     = liftedTypeKind+  m1 i c f = mkTyConApp (meM1 me) [kTy, i, c, f]+  d1 = m1 (meD me) ; c1 = m1 (meC me) ; s1 = m1 (meS me)+  sumTy  a b = mkTyConApp (geSumTc gen)  [kTy, a, b]+  prodTy a b = mkTyConApp (geProdTc gen) [kTy, a, b]+  u1     = mkTyConApp (geU1Tc gen) [kTy]+  strLit = mkStrLitTy . fsLit+  boolT b = mkTyConTy (if b then promotedTrueDataCon else promotedFalseDataCon)+  metaData tc = mkTyConApp (meMetaData me)+                  [ strLit (occNameString (nameOccName (tyConName tc)))+                  , strLit (moduleNameString (moduleName modu))+                  , strLit (unitString (moduleUnit modu))+                  , boolT (isNewTyCon tc) ]+    where modu = nameModule (tyConName tc)+  -- MetaCons carries the constructor's FIXITY ('Infix assoc prec for an infix+  -- constructor, else 'PrefixI) — supplied by the (monadic) 'mkFixOf'.+  metaCons dc = mkTyConApp (meMetaCons me)+                  [ strLit (occNameString (getOccName dc))+                  , fixOf dc+                  , boolT (not (null (dataConFieldLabels dc))) ]+  -- MetaSel carries the field's real source/decided strictness.+  metaSel mnm (suT, ssT, dsT) = mkTyConApp (meMetaSel me)+                  [ maybe (meNothingSym me)+                          (\nm -> mkTyConApp (meJustSym me) [typeSymbolKind, strLit nm]) mnm+                  , suT, ssT, 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 dc i = case if i < length implB then implB !! i else HsLazy of+      HsLazy     -> (meNoUnpack me,  meNoStrict me,  meDecidedLazy me)+      HsStrict _ -> (meNoUnpack me,  meSrcStrict me, meDecidedStrict me)+      HsUnpack _ -> (meSrcUnpack me, meSrcStrict me, meDecidedUnpack me)+    where implB = dataConImplBangs dc+  conRep (dc, fts) = c1 (metaCons dc) prod+    where labels = dataConFieldLabels dc+          nameAt i | null labels = Nothing+                   | otherwise   = Just (occNameString (nameOccName (flSelector (labels !! i))))+          prod = case fts of+                   [] -> u1+                   _  -> foldBal prodTy+                           [ s1 (metaSel (nameAt i) (selStr dc i)) (leaf ft)+                           | (i, ft) <- zip [0 :: Int ..] 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 _ p d) = (p, 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 me dc+  | dataConIsInfix dc = do+      fx <- unsafeTcPluginTcM (lookupFixityRn (dataConName dc))+      let (prec, dir) = fixityParts fx+          assoc = case dir of InfixL -> meLeftAssoc me; InfixR -> meRightAssoc me; InfixN -> meNotAssoc me+      pure (mkTyConApp (meInfixI me) [assoc, mkNumLitTy (fromIntegral prec)])+  | otherwise = pure (mePrefixI me)++-- | A pure fixity lookup over a fixed constructor set (for 'repMetaWith').+mkFixOf :: MetaEnv -> [DataCon] -> TcPluginM (DataCon -> Type)+mkFixOf me dcs = do+  tys <- mapM (conFixityTy me) dcs+  let m = zip (map getUnique dcs) tys+  pure (\dc -> fromMaybe (mePrefixI me) (lookup (getUnique dc) 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 gen []  = mkTyConApp (geU1Tc gen) [liftedTypeKind]    -- U1 @Type+repStruct gen fts = foldBal prodOf (map rec0 fts) where++  rec0 t    = mkTyConApp (geK1Tc gen)   [liftedTypeKind, geRTy gen, t]  -- K1 @Type R t+  prodOf f g = mkTyConApp (geProdTc gen) [liftedTypeKind, f, 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 gen aTv ft+  | ft `eqType` aTy                          = Just par1+  | not (aTv `elemVarSet` tyCoVarsOfType ft) = Just (rec0Of gen ft)+  | Just (h, larg) <- splitAppTy_maybe ft+  , not (aTv `elemVarSet` tyCoVarsOfType h)  =+      if larg `eqType` aTy then Just (rec1 h)             -- @h a@      ⇒ Rec1 h+      else comp h <$> rep1Field gen aTv larg              -- @h (g..a)@ ⇒ h :.: <inner>+  | otherwise                                = Nothing+  where+    g1   = geGen1 gen ; kTy = liftedTypeKind ; aTy = mkTyVarTy aTv+    par1 = mkTyConTy (g1Par1Tc g1)+    rec1 h     = mkTyConApp (g1Rec1Tc g1) [kTy, h]+    comp h inr = mkTyConApp (g1CompTc g1) [kTy, kTy, h, 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 _  [x] = x+foldBal op xs  = let (l, r) = splitAt (length xs `div` 2) xs+                 in op (foldBal op l) (foldBal op 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+  { ciCon      :: DataCon+  , ciFields   :: [Type]        -- ^ field types the synthesizer sees (modifier types if overridden)+  , 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+  { rInner :: Type+  , rCo    :: Coercion+  , 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 ourStock wrappedTy = do+  ourTc   <- ourStock+  stockTc <- tyConAppTyCon_maybe wrappedTy+  guard (stockTc == ourTc)+  innerTy <- case tyConAppArgs wrappedTy of { (a:_) -> Just a; _ -> Nothing }+  innerTc <- tyConAppTyCon_maybe innerTy+  let dcons = tyConDataCons innerTc+  guard (not (null dcons))+  let co = mkUnbranchedAxInstCo Representational+             (newTyConCo stockTc) (tyConAppArgs wrappedTy) []+      cons = [ ConInfo dc fts (map mkRepReflCo fts)+             | dc <- dcons, let fts = fieldTysAt innerTy 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 = 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 h m t+  | h `eqType` m = mkRepReflCo (mkAppTy h t)+  | otherwise    = mkStockCo (PluginProv "stock") Representational (mkAppTy h t) (mkAppTy m 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 e co = if isReflCo co then e else Cast e 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 gen = peelOverride1With (ovTcsGen "Override1" 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+  { ovWrap   :: Maybe TyCon   -- ^ @Override1@ \/ @Override2@+  , ovKeep   :: Maybe TyCon   -- ^ @Keep@+  , ovArrow  :: Maybe TyCon   -- ^ @-->@+  , ovAssign :: Maybe TyCon   -- ^ @:=@+  , ovAt     :: Maybe TyCon   -- ^ @At@+  }++-- | The bundle, from a 'GenEnv' (for the built-in synthesizers).+ovTcsGen :: String -> GenEnv -> OvTcs+ovTcsGen wrap gen = OvTcs+  (if wrap == "Override2" then geOverride2 gen else geOverride1 gen)+  (geKeep gen) (geArrow gen) (geAssign gen) (geAt gen)++-- | The bundle, looked up by name (for the satellite 'Deriver1'\/'Deriver2's).+lookupOvTcs :: String -> TcPluginM OvTcs+lookupOvTcs wrap = OvTcs+  <$> lookupTyConMaybe "Stock.Override" wrap+  <*> lookupTyConMaybe "Stock.Override" "Keep"+  <*> lookupTyConMaybe "Stock.Override" "-->"+  <*> lookupTyConMaybe "Stock.Override" ":="+  <*> lookupTyConMaybe "Stock.Override" "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 tcs f = case ovWrap tcs of+  Just ov1Tc | Just (tc, [_, _, realF, cfg]) <- splitTyConApp_maybe f, tc == ov1Tc+             -> (realF, decodeOvCfg tcs realF cfg)+  _          -> (f, 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 tcs realInner cfg =+  case decodePositional cfg of+    Just perCon -> listToMaybe perCon                -- positional [[..]] form+    Nothing -> do                                    -- field-keyed entry list+      arrowTc <- ovArrow tcs ; assignTc <- ovAssign tcs+      atTc    <- ovAt tcs    ; keepTc   <- ovKeep tcs+      fTc     <- tyConAppTyCon_maybe realInner+      let dcons = tyConDataCons 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 gen = override1ModWith (geKeep gen)++-- | As 'override1Mod', but taking the @Keep@ 'TyCon' directly (for 'Deriver1's).+override1ModWith :: Maybe TyCon -> Maybe [Type] -> Int -> Maybe Type+override1ModWith mKeep mMods i = case mMods of+  Just mods | i < length mods+            , let m = mods !! i+            , not (maybe False (\k -> tyConAppTyCon_maybe m == Just k) mKeep)+            -> Just m+  _ -> 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 gen = coDown1With (geOverride1 gen)++-- | As 'coDown1', but taking the @Override1@ 'TyCon' directly (for 'Deriver1's).+coDown1With :: Maybe TyCon -> TyCon -> Type -> Type -> Type -> Type -> Coercion+coDown1With mOv1 st1Tc wrappedTy f0 realF t = mkTransCo+  (mkUnbranchedAxInstCo Representational (newTyConCo st1Tc) (tyConAppArgs wrappedTy ++ [t]) [])+  (case mOv1 of+     Just ov1Tc | tyConAppTyCon_maybe f0 == Just ov1Tc ->+       mkUnbranchedAxInstCo Representational (newTyConCo ov1Tc) (tyConAppArgs f0 ++ [t]) []+     _ -> mkRepReflCo (mkAppTy realF 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 tcs p = case ovWrap tcs of+  Just ov2Tc | Just (tc, [_, rp, cfg]) <- splitTyConApp_maybe p, tc == ov2Tc+             -> (rp, decodeOvCfg tcs rp cfg)+  _          -> (p, 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 mOv2 st2Tc wrappedTy p0 realP t1 t2 = mkTransCo+  (mkUnbranchedAxInstCo Representational (newTyConCo st2Tc) (tyConAppArgs wrappedTy ++ [t1, t2]) [])+  (case mOv2 of+     Just ov2Tc | tyConAppTyCon_maybe p0 == Just ov2Tc ->+       mkUnbranchedAxInstCo Representational (newTyConCo ov2Tc) (tyConAppArgs p0 ++ [t1, t2]) []+     _ -> mkRepReflCo (mkAppTy (mkAppTy realP t1) 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 = 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 gen arg = do+  ourStock <- geStock 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 = tyConDataCons innerTc+  guard (not (null dcons))+  perCon <-+    case decodePositional cfg of+      Just perCon                           -- positional [[..]] form+        | length perCon == length dcons ->+            sequence (zipWith (posCon keepTc realInner) dcons perCon)+        | otherwise -> Nothing+      Nothing -> do                          -- entry-list / --> path form+        entries <- promotedListElems cfg >>= traverse (decodeEntry arrowTc assignTc atTc)+        case resolveCells dcons realInner entries of+          Left _      -> Nothing+          Right cells -> Just [ [ fromMaybe rft (lookup (ci, fi) cells)+                                | (fi, rft) <- zip [0 ..] (fieldTysAt realInner dc) ]+                              | (ci, dc) <- zip [0 :: Int ..] dcons ]+  pure (realInner, zip dcons perCon)+  where+    -- one positional constructor: each slot a modifier type or @Keep@ (no change)+    posCon keepTc realInner dc mods+      | length mods /= length rfts = Nothing+      | otherwise = sequence (zipWith cell rfts mods)+      where rfts = fieldTysAt realInner dc+            cell rft m+              | tyConAppTyCon_maybe m == Just keepTc = Just rft+              | otherwise = either (const Nothing) Just (modifierType m rft)++mkOverrideRepr :: GenEnv -> CtLoc -> Type -> TcPluginM (Maybe (Either SDoc (Repr, [Ct])))+mkOverrideRepr gen loc wrappedTy+  | Just ourStock <- geStock gen+  , Just overTc   <- geOverride gen+  , Just assignTc <- geAssign gen+  , Just (stockTc, [innerOver]) <- splitTyConApp_maybe wrappedTy+  , stockTc == ourStock+  , Just (oTc, oArgs) <- splitTyConApp_maybe innerOver+  , oTc == overTc+  , (cfg : realInner : _) <- reverse oArgs  -- last two visible args (drop the invisible cfg kind)+  , Just atTc    <- geAt gen+  , Just keepTc  <- geKeep gen+  , Just arrowTc <- geArrow gen+  = Just <$> buildOverride loc ourStock overTc assignTc atTc keepTc arrowTc innerOver cfg realInner+  | otherwise = pure 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 loc ourStock overTc assignTc atTc keepTc arrowTc innerOver cfg realInner =+  case tyConAppTyCon_maybe realInner of+    Nothing -> bad (text "Override target is not a concrete algebraic type:" <+> ppr realInner)+    Just innerTc -> case tyConDataCons innerTc of+      [] -> bad (text "Override: type has no constructors:" <+> ppr realInner)+      dcons+        | any dcUnpacked dcons -> bad (text "Override: a constructor has UNPACKed/strict-unboxed"+                                       <+> text "or existential fields, unsupported")+        -- positional [[..]] form: one inner list per constructor+        | Just perCon <- decodePositional cfg ->+            buildPositional loc ourStock overTc keepTc innerOver cfg realInner dcons perCon+        -- entry-list form ( := / At / --> paths ), multi-constructor+        | otherwise ->+            case promotedListElems cfg >>= traverse (decodeEntry arrowTc assignTc atTc) of+              Nothing      -> bad (text "Override config is not a concrete list of"+                                   <+> text "selector := modifier / path --> modifier entries:" <+> ppr cfg)+              Just entries -> resolveOverride loc ourStock overTc innerOver cfg realInner dcons entries+  where bad = pure . 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 cfg = case promotedListElems cfg of+  Just es@(_ : _) -> traverse promotedListElems es   -- one inner list per constructor+  _               -> 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 loc ourStock overTc keepTc innerOver cfg realInner dcons perCon+  | length perCon /= length dcons =+      pure (Left (text "Override: positional config has" <+> int (length perCon)+                  <+> text "constructor list(s) but" <+> ppr realInner <+> text "has"+                  <+> int (length dcons)))+  | otherwise = do+      let co = mkTransCo (mkUnbranchedAxInstCo Representational (newTyConCo ourStock) [innerOver] [])+                         (mkUnbranchedAxInstCo Representational (newTyConCo overTc) [typeKind cfg, realInner, cfg] [])+      results <- traverse (uncurry conInfo) (zip dcons perCon)+      pure $ case sequence results of+        Left err   -> Left err+        Right cws  -> Right (Repr realInner co (map fst cws), concatMap snd cws)+  where+    conInfo :: DataCon -> [Type] -> TcPluginM (Either SDoc (ConInfo, [Ct]))+    conInfo dc mods+      | length mods /= length realFts =+          pure (Left (text "Override: constructor" <+> ppr dc <+> text "has" <+> int (length realFts)+                      <+> text "field(s) but its positional list has" <+> int (length mods)))+      | otherwise = do+          cells <- traverse cell (zip realFts mods)+          pure $ case sequence cells of+            Left err -> Left err+            Right fs -> Right (ConInfo dc (map (fst . fst) fs) (map (snd . fst) fs)+                              , concatMap snd fs)+      where realFts = fieldTysAt realInner dc+    -- one field: Keep ⇒ (realτ, Refl); modifier m ⇒ (modτ, evidence coercion + wanted)+    cell :: (Type, Type) -> TcPluginM (Either SDoc ((Type, Coercion), [Ct]))+    cell (ft, m)+      | tyConAppTyCon_maybe m == Just keepTc = pure (Right ((ft, mkRepReflCo ft), []))+      | otherwise = case modifierType m ft of+          Left err    -> pure (Left err)+          Right modTy -> do+            ev <- newWanted loc (mkStockReprEq ft 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 loc ourStock overTc innerOver cfg realInner dcons entries =+  case resolveCells dcons realInner entries of+    Left err    -> pure (Left err)+    Right cells -> do+      tagged <- for cells \((ci, fi), modTy) -> do+        let realFt = fieldTysAt realInner (dcons !! ci) !! fi+        ev <- newWanted loc (mkStockReprEq realFt modTy)+        pure (((ci, fi), (modTy, ctEvCoercion ev)), mkNonCanonical ev)+      let cellMap = map fst tagged+          wanteds = map snd tagged+          -- Stock (Override T cfg) ~R Override T cfg ~R T+          co = mkTransCo (mkUnbranchedAxInstCo Representational (newTyConCo ourStock) [innerOver] [])+                         (mkUnbranchedAxInstCo Representational (newTyConCo overTc) [typeKind cfg, realInner, cfg] [])+          cons = [ ConInfo dc (map fst fields) (map snd fields)+                 | (ci, dc) <- zip [0 :: Int ..] dcons+                 , let fields = [ fromMaybe (ft, mkRepReflCo ft) (lookup (ci, fi) cellMap)+                                | (fi, ft) <- zip [0 :: Int ..] (fieldTysAt realInner 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 dcons targetTy = go []+  where+    go _       []                 = Right []+    go claimed ((addr, m) : rest) = do+      cells <- resolveAddr dcons targetTy addr+      case filter (`elem` claimed) cells of+        clash@(_ : _) -> Left (text "Override: cell(s)" <+> ppr clash+                               <+> text "claimed by more than one entry (make them disjoint)")+        [] -> ((map (\c -> (c, m)) cells) ++) <$> go (cells ++ claimed) 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 dcons targetTy = go []+  where+    go _       []                 = Right []+    go claimed ((addr, m) : rest) = do+      cells <- resolveAddr dcons targetTy addr+      case filter (`elem` claimed) cells of+        clash@(_ : _) -> Left (text "Override: cell(s)" <+> ppr clash+                               <+> text "claimed by more than one entry (make them disjoint)")+        [] -> do+          here <- for cells \(ci, fi) ->+                    (,) (ci, fi) <$> modifierType m (fieldTysAt targetTy (dcons !! ci) !! fi)+          (here ++) <$> go (cells ++ claimed) rest++-- | Resolve one address to its @(ctorIndex, fieldIndex)@ cell set.+resolveAddr :: [DataCon] -> Type -> Addr -> Either SDoc [(Int, Int)]+resolveAddr dcons targetTy addr = case addr of+  AddrType t+    | t `eqType` targetTy -> Right (allCells dcons targetTy)+    | otherwise -> case [ (ci, fi) | (ci, dc) <- zip [0 ..] dcons+                                   , (fi, ft) <- zip [0 ..] (fieldTysAt targetTy dc)+                                   , ft `eqType` t ] of+        [] -> Left (text "Override: no field of type" <+> quotes (ppr t))+        cs -> Right cs+  AddrPath hops -> foldHops dcons targetTy (allCells dcons targetTy) hops++-- | Narrow the cell scope by each hop in turn.+foldHops :: [DataCon] -> Type -> [(Int, Int)] -> [Hop] -> Either SDoc [(Int, Int)]+foldHops _     _        scope []               = Right scope+foldHops dcons targetTy scope (HopCon nm : hs) =+  case [ ci | (ci, dc) <- zip [0 ..] dcons, occNameFS (getOccName dc) == nm ] of+    []  -> Left (text "Override: unknown constructor" <+> quotes (ftext nm))+    cis -> foldHops dcons targetTy (filter ((`elem` cis) . fst) scope) hs+foldHops dcons targetTy scope (HopPos n : hs) =+  case filter ((== fromInteger n) . snd) scope of+    []  -> Left (text "Override: no field at position" <+> integer n <+> text "in the addressed scope")+    sc' -> foldHops dcons targetTy sc' hs+foldHops dcons targetTy scope (HopLabel l : hs) =+  case [ (ci, fi) | (ci, fi) <- scope, labelAt (dcons !! ci) fi == Just (unpackFS l) ] of+    []  -> Left (text "Override: no field labelled" <+> quotes (ftext l) <+> text "in the addressed scope")+    sc' -> foldHops dcons targetTy sc' 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 dcons _ =+  [ (ci, fi) | (ci, dc) <- zip [0 ..] dcons, fi <- [0 .. dataConSourceArity dc - 1] ]++-- | The record label of a constructor's @i@-th field, if it has one.+labelAt :: DataCon -> Int -> Maybe String+labelAt dc i =+  let ls = map (occNameString . nameOccName . flSelector) (dataConFieldLabels dc)+  in if i < length ls then Just (ls !! i) else 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 m fieldTy+  | k `eqType` liftedTypeKind                              = Right m+  | k `eqType` mkVisFunTyMany liftedTypeKind liftedTypeKind = Right (mkAppTy m fieldTy)+  | otherwise = Left (text "Override: modifier" <+> ppr m <+> text "has unsupported kind"+                      <+> ppr k <+> text "(expected Type or Type -> Type)")+  where k = typeKind 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 ty = do+  (tc, args) <- splitTyConApp_maybe ty+  if | tc == promotedNilDataCon  -> Just []+     | tc == promotedConsDataCon -> case args of+         [_k, x, rest] -> (x :) <$> promotedListElems rest+         _             -> 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 arrowTc assignTc atTc e+  | Just (hops, m) <- decodeArrow arrowTc e =+      (\hs -> (AddrPath hs, m)) <$> traverse decodeHop hops+  | Just (tc, args) <- splitTyConApp_maybe e, tc == assignTc+  , (m : sel : _) <- reverse args = (, m) <$> decodeSel atTc sel+  | otherwise = 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 arrowTc e = do+  (tc, args) <- splitTyConApp_maybe e+  guard (tc == arrowTc)+  case reverse args of+    (rhs : lhs : _) -> case decodeArrow arrowTc rhs of+      Just (hs, m) -> Just (lhs : hs, m)   -- rhs continues the path+      Nothing      -> Just ([lhs], rhs)    -- rhs is the terminal modifier+    _ -> 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 h+  | Just fs <- isStrLitTy h          = Just (HopLabel fs)+  | Just n  <- isNumLitTy h          = Just (HopPos n)+  | Just tc <- tyConAppTyCon_maybe h = Just (HopCon (occNameFS (getOccName tc)))+  | otherwise                        = 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 atTc sel+  | Just fs <- isStrLitTy sel = Just (AddrPath [HopLabel fs])+  | Just (tc, args) <- splitTyConApp_maybe sel, tc == atTc+  , (pos : con : _) <- reverse args, Just n <- isNumLitTy pos+  , Just ctc <- tyConAppTyCon_maybe con =+      Just (AddrPath [HopCon (occNameFS (getOccName ctc)), HopPos n])+  | otherwise = Just (AddrType 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 = any (any (not . isReflCo) . ciFieldCos) . rCons++-- Representation predicates ("checking the datatype representation").+reprHasFields, reprIsEnum, reprSingleCon, reprEmpty :: Repr -> Bool+reprHasFields = any (not . null . ciFields) . 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    r = not (reprEmpty r) && not (reprHasFields r)+reprSingleCon = (== 1) . length . rCons+reprEmpty     = null . 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 = any (dcUnpacked . ciCon) . 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 dc =+  let rep  = map scaledThing (dataConRepArgTys dc)+      orig = map scaledThing (dataConOrigArgTys dc)+  in length rep /= length orig || not (and (zipWith eqType rep orig))++-- | Apply a class's dictionary constructor: @C:Cls \@ty m1 .. mn@.+mkClassDict :: Class -> Type -> [CoreExpr] -> CoreExpr+mkClassDict cls ty methods =+  mkApps (Var (dataConWorkId (classDataCon cls))) (Type ty : 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 innerTy dc = map scaledThing (dataConInstOrigArgTys dc (tyConAppArgs 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 innerTy dc args = mkCoreConApps dc (map Type (tyConAppArgs innerTy) ++ 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 cls ty mk = do+  dvar   <- freshId (mkClassPred cls [ty]) "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 cls ty supers overrides = do+  dvar <- freshId (mkClassPred cls [ty]) "dict"+  methodFields <- for (zip [0 ..] (classMethods cls)) \(i, _) ->+    case lookup i overrides of+      Just e  -> pure e+      Nothing -> do dm <- defMethId cls 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 atv aTy ft+  | ft `eqType` aTy                              = Just FParam+  | not (atv `elemVarSet` tyCoVarsOfType ft)     = Just FConst+  | Just (h, larg) <- splitAppTy_maybe ft+  , larg `eqType` aTy+  , not (atv `elemVarSet` tyCoVarsOfType h)      = Just (FApp h)+  | otherwise                                    = 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+  { onParam :: r                         -- ^ the field /is/ the parameter @a@+  , 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@.+  , 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 constCls liftCls atv aTy loc mMod roles ftA =+  case classifyField atv aTy ftA of+    Nothing       -> pure Nothing+    Just FParam   -> pure (Just (onParam roles, []))+    Just FConst   -> do+      ev <- newWanted loc (mkClassPred constCls [ftA])+      pure (Just (onConst roles ev ftA, [mkNonCanonical ev]))+    Just (FApp h) -> do+      let m       = fromMaybe h mMod+          coB t   = case mMod of+                      Nothing -> mkRepReflCo (mkAppTy h t)+                      Just _  -> mkStockCo (PluginProv "stock") Representational+                                   (mkAppTy h t) (mkAppTy m t)+      ev <- newWanted loc (mkClassPred liftCls [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 fixed dc ty = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [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 fTc fixed coAt aTy bTy resTy faId fbId mismatch combine fieldOp = do+  let dcons   = tyConDataCons fTc+      innerA  = mkTyConApp fTc (fixed ++ [aTy])+      innerB  = mkTyConApp fTc (fixed ++ [bTy])+      indexed = zip [0 :: Int ..] dcons+      freshFields dc ty = zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..]+                                   (fieldsAt fixed dc ty)+  mInner <- for indexed \(i, dci) -> do+    xs <- freshFields dci aTy+    mAlts <- for indexed \(j, dcj) -> do+      ys <- freshFields dcj 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+            Nothing  -> pure Nothing+            Just ows -> do+              body <- combine (map fst ows)+              pure (Just (Alt (DataAlt dcj) ys body, concatMap snd ows))+    case sequence mAlts of+      Nothing     -> pure Nothing+      Just altWss -> do+        let (alts, wss) = unzip altWss+        cbB <- freshId innerB "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+    Nothing     -> pure Nothing+    Just altWss -> do+      let (alts, wss) = unzip altWss+      cbA <- freshId innerA "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+  { runSolver :: PluginState -> Ct -> Class -> Type -> TcPluginM (Maybe Attempt) }+  deriving (Semigroup, Monoid)+    via (PluginState -> Ct -> Class -> Type -> Mon.Alt (MaybeT TcPluginM) Attempt)++notImplemented :: PluginState -> Ct -> SDoc -> TcPluginM Attempt+notImplemented st ct doc = do+  let key = showSDocUnsafe doc+  seen <- tcPluginIO (readIORef (psSeen 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 ty s = do+  u <- unsafeTcPluginTcM 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 via repr = Datatype+  { dtVia    = via+  , dtUnwrap = rCo repr+  , dtType   = rInner repr+  , dtCons   = [ Constructor dc (ciFields ci) defaultFixity labels (ciFieldCos ci)+               | ci <- rCons repr+               , let dc  = ciCon ci+                     fls = dataConFieldLabels dc+                     labels = if null fls then Nothing else Just fls ]+  }++-- | Run a @Deriver@ (built-in or discovered) as a solve attempt.+runDeriverAttempt :: Deriver -> Ct -> Class -> Datatype -> TcPluginM Attempt+runDeriverAttempt drv ct cls dt = do+  (ev, ws) <- runSynth (ctLoc ct) (runDeriver drv cls 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 st ct cls dt =+  case geWitness (psGen st) of+    Nothing     -> pure Nothing+    Just witCls -> do+      instEnvs <- getInstEnvs+      let clsTy   = mkTyConTy (classTyCon cls)+          matches = [ inst | inst <- classInstances instEnvs witCls+                           , [headTy] <- [is_tys inst], headTy `eqType` clsTy ]+      case matches of+        []         -> pure Nothing+        (inst : _) -> do+          let dfun = is_dfun inst+          hsc <- 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 (drv, _, _) -> Just <$> runDeriverAttempt drv ct cls dt+            Left _            -> pure 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 st ct cls wrappedTy f =+  case geWitness1 (psGen st) of+    Nothing     -> pure Nothing+    Just witCls -> do+      instEnvs <- getInstEnvs+      let clsTy   = mkTyConTy (classTyCon cls)+          matches = [ inst | inst <- classInstances instEnvs witCls+                           , [headTy] <- [is_tys inst], headTy `eqType` clsTy ]+      case matches of+        []         -> pure Nothing+        (inst : _) -> do+          let dfun = is_dfun inst+          hsc <- getTopEnv+          r <- unsafeTcPluginTcM $ liftIO $+                 getValueSafely hsc (idName dfun) (idType dfun)+          case r of+            Right (Deriver1 synth, _, _) -> do+              m <- synth cls (ctLoc ct) wrappedTy f+              pure $ case m of+                Just (ev, ws) -> Just (Just (ev, ct), ws, [])+                Nothing       -> Nothing+            Left _ -> pure 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 st ct cls wrappedTy p =+  case geWitness2 (psGen st) of+    Nothing     -> pure Nothing+    Just witCls -> do+      instEnvs <- getInstEnvs+      let clsTy   = mkTyConTy (classTyCon cls)+          matches = [ inst | inst <- classInstances instEnvs witCls+                           , [headTy] <- [is_tys inst], headTy `eqType` clsTy ]+      case matches of+        []         -> pure Nothing+        (inst : _) -> do+          let dfun = is_dfun inst+          hsc <- getTopEnv+          r <- unsafeTcPluginTcM $ liftIO $+                 getValueSafely hsc (idName dfun) (idType dfun)+          case r of+            Right (Deriver2 synth, _, _) -> do+              m <- synth cls (ctLoc ct) wrappedTy p+              pure $ case m of+                Just (ev, ws) -> Just (Just (ev, ct), ws, [])+                Nothing       -> Nothing+            Left _ -> pure 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 dc = do+#if MIN_VERSION_ghc(9,12,0)+  Fixity p _ <- unsafeTcPluginTcM (lookupFixityRn (dataConName dc))+#else+  Fixity _ p _ <- unsafeTcPluginTcM (lookupFixityRn (dataConName 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 cls i =+  case snd (classOpItems cls !! i) of+    Just (nm, _) -> tcLookupId nm+    Nothing      -> error "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 Cov = Con+flipV Con = 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 fmapCls mContraCls loc pv tgt covFwd conFwd =+  varMapN fmapCls mContraCls loc [(pv, tgt, covFwd, conFwd)] 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 fmapCls mContraCls loc params mSelf = go+  where+    fmapSel = classMethod "fmap" fmapCls+    pvs     = [ pv  | (pv, _, _, _)  <- params ]+    tgts    = [ tgt | (_, tgt, _, _) <- params ]+    sub t   = substTyWith pvs tgts t            -- t[srcs:=tgts]+    inA t   = any (`elemVarSet` tyCoVarsOfType t) pvs+    -- if @t@ is exactly one parameter's source tyvar, its directional mapper+    bareFwd t v = case [ (cf, conf) | (p, _, cf, conf) <- params, t `eqType` mkTyVarTy p ] of+      ((cf, conf) : _) -> Just (case v of Cov -> cf; Con -> conf)+      []               -> Nothing+    -- the spine of an application: @(head, [arg₁ .. argₖ])@+    spine ty = case splitAppTy_maybe ty of+      Just (f, a) -> let (h, as) = spine f in (h, as ++ [a])+      Nothing     -> (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 ty =+      let (h, args) = spine ty+          n         = length params+      in if length args >= n+           then let (pre, tl) = splitAt (length args - n) args+                    qhead     = mkAppTys h pre+                in if and (zipWith eqType tl (map mkTyVarTy pvs)) && not (inA qhead)+                     then Just qhead else Nothing+           else Nothing+    go v t+      | not (inA t) = do x <- freshId t "x"; pure (Just (Lam x (Var x), []))  -- id+      | Just mfwd <- bareFwd t v = pure (fmap (\e -> (e, [])) mfwd)+      | Just (_, _, s, r) <- splitFunTy_maybe t = do+          ms <- go (flipV v) s                  -- argument flips variance+          mr <- go v r+          case (ms, mr) of+            (Just (es, w1), Just (er, w2)) -> do+              let (sf, rf) = case v of Cov -> (s, r); Con -> (sub s, sub r)+                  xTy      = case v of Cov -> sub s; Con -> s+              g <- freshId (mkVisFunTyMany sf rf) "g"+              x <- freshId xTy "x"+              pure (Just (mkLams [g, x] (App er (App (Var g) (App es (Var x)))), w1 ++ w2))+            _ -> pure 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)@.+      | Cov <- v, Just (tc, args) <- splitTyConApp_maybe t+      , isTupleTyCon tc, length args >= 2 = do+          ms <- mapM (go Cov) args+          case sequence ms of+            Nothing    -> pure Nothing+            Just pairs -> do+              let (mappers, wss) = unzip pairs+                  dc   = tupleDataCon Boxed (length args)+              xs  <- mapM (`freshId` "u") args+              tup <- freshId t "tup" ; cb <- freshId t "cb"+              let body = mkCoreConApps dc (map (Type . sub) args ++ zipWith App mappers (map Var xs))+              pure (Just (Lam tup (Case (Var tup) cb (sub t) [Alt (DataAlt dc) xs body]), concat wss))+      | Just self <- mSelf, Cov <- v, Just q <- matchSelf t = self q+      | Just (h, larg) <- splitAppTy_maybe t, not (inA h) = do+          mf <- go v larg                       -- try H as a covariant functor+          case mf of+            Just (e, w) -> do+              ev <- newWanted loc (mkClassPred fmapCls [h])+              let (ft, tt) = case v of Cov -> (larg, sub larg); Con -> (sub larg, larg)+              pure (Just ( mkApps (Var fmapSel) [Type h, ctEvExpr ev, Type ft, Type tt, e]+                         , mkNonCanonical ev : w ))+            Nothing -> case mContraCls of        -- else try H as a contravariant functor+              Nothing -> pure Nothing+              Just contraCls -> do+                mc <- go (flipV v) larg+                case mc of+                  Nothing       -> pure Nothing+                  Just (e, w) -> do+                    ev <- newWanted loc (mkClassPred contraCls [h])+                    -- contramap :: (x->y) -> f y -> f x+                    let (xT, yT) = case v of Cov -> (sub larg, larg); Con -> (larg, sub larg)+                    pure (Just ( mkApps (Var (classMethod "contramap" contraCls))+                                   [Type h, ctEvExpr ev, Type xT, Type yT, e]+                               , mkNonCanonical ev : w ))+      | otherwise = pure 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 fTc instTys scrut cb resTy alts+  | isNewTyCon fTc+  , [Alt _ [x] body] <- alts+  = Let (NonRec x (Cast scrut (mkUnbranchedAxInstCo Representational+                                 (newTyConCo fTc) instTys []))) body+  | otherwise = Case scrut cb resTy alts++-- | Synthesize @Functor (Stock1 F)@ — the covariant instance of the shared+-- @synthMap1@ engine.+freshTyVar :: String -> TcPluginM TyVar+freshTyVar = freshTyVarK liftedTypeKind++-- | A fresh type variable of the given kind.+freshTyVarK :: Kind -> String -> TcPluginM TyVar+freshTyVarK k s = do+  u <- unsafeTcPluginTcM getUniqueM+  pure (mkTyVar (mkSystemName u (mkTyVarOcc s)) k)++-- | Extract the 'CoreExpr' from the @EvExpr@ forms we build.+unwrapEv :: EvTerm -> CoreExpr+unwrapEv (EvExpr e) = e+unwrapEv _          = error "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+  { rpReadPrecTc :: TyCon+  , rpMonadDict  :: CoreExpr+  , rpBindSel, rpThenSel, rpReturnSel :: Id+  , rpParens, rpChoose, rpExpectP, rpReadField :: Id+  , rpPrec, rpStep, rpReset, rpPlus, rpPfail :: Id+  , rpIdentCon, rpSymbolCon, 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 loc = do+  monadCls    <- tcLookupClass 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 env gTy mkConVal cons = do+  let ReadPrecEnv readPrecTc monadDict bindSel thenSel returnSel+        parensId chooseId expectPId readFieldId precId stepId resetId plusId pfailId+        identCon symbolCon puncCon = env+      readPrecTy    = mkTyConTy readPrecTc+      strPairTy     = mkBoxedTupleTy [stringTy, mkTyConApp readPrecTc [gTy]]+      bindP a b m k = mkApps (Var bindSel)   [Type readPrecTy, monadDict, Type a, Type b, m, k]+      thenP a b m n = mkApps (Var thenSel)   [Type readPrecTy, monadDict, Type a, Type b, m, n]+      returnP a v   = mkApps (Var returnSel) [Type readPrecTy, monadDict, Type a, v]+      seqW m n      = thenP unitTy gTy m n+      parensE a p   = mkApps (Var parensId) [Type a, p]+      precE a n p   = mkApps (Var precId)   [Type a, mkUncheckedIntExpr n, p]+      stepE a p     = mkApps (Var stepId)   [Type a, p]+      resetE a p    = mkApps (Var resetId)  [Type a, p]+      plusE a p q   = mkApps (Var plusId)   [Type a, p, q]+      chooseE a xs  = mkApps (Var chooseId) [Type a, xs]+      readFieldE a s p = mkApps (Var readFieldId) [Type a, s, p]+      expectPE l    = App (Var expectPId) l+      identE s  = mkCoreConApps identCon  [s]+      symbolE s = mkCoreConApps symbolCon [s]+      puncE s   = mkCoreConApps puncCon   [s]+      str s     = unsafeTcPluginTcM (mkStringExprFS (fsLit s))+  entries <- for cons \(dc, readers) -> do+    let name   = occNameString (getOccName dc)+        labels = map (occNameString . nameOccName . flSelector) (dataConFieldLabels dc)+    nameE  <- str name+    argIds <- zipWithM (\(ft, _) i -> freshId ft ("a" ++ show (i :: Int))) readers [0 ..]+    let ret   = returnP gTy (mkConVal dc argIds)+        items = zip3 argIds (map fst readers) (map snd 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 = bindP ft0 gTy (stepE ft0 rd0) $ Lam a0 $+                      seqW (expectPE (symbolE nameE)) $+                      bindP ft1 gTy (stepE ft1 rd1) (Lam a1 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 = seqW (expectPE (puncE closeCE)) ret+              go [] = closeRet+              go ((i, lblE, (aId, ft, rd)) : rest) =+                let bound = bindP ft gTy (readFieldE ft lblE (resetE ft rd)) (Lam aId (go rest))+                in if i == (0 :: Int) then bound else seqW (expectPE (puncE commaCE)) bound+              inner = seqW (expectPE (identE nameE)) $+                      seqW (expectPE (puncE openCE)) $+                      go (zip3 [0 ..] lblEs items)+          pure (Right (precE gTy 11 inner))+      else do                                                    -- prefix with args+        let chain = foldr (\(aId, ft, rd) acc -> bindP ft gTy (stepE ft rd) (Lam aId acc)) ret items+            inner = seqW (expectPE (identE nameE)) chain+        pure (Right (precE gTy 10 inner))+  let nullaries = [e | Left e  <- entries]+      others    = [p | Right p <- entries]+      chooseP   = chooseE gTy (mkListExpr strPairTy [ mkCoreTup [n, p] | (n, p) <- nullaries ])+      allP      = [chooseP | not (null nullaries)] ++ others+      combined  = case allP of+                    []  -> mkApps (Var pfailId) [Type gTy]+                    [p] -> p+                    ps  -> foldr1 (plusE gTy) ps+  pure (parensE gTy combined)

@@ -0,0 +1,230 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}+-- | @Ord@ synthesizer: tag order between constructors, lexicographic within.+module Stock.Ord 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)+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 Data.Maybe (catMaybes, fromJust, isJust, fromMaybe)+import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'+import Stock.Trans (MaybeT(..))+import Control.Monad (forM, zipWithM, unless, guard)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef')+import Stock.Internal+import Stock.Eq++buildCompare :: CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]+             -> TcPluginM (CoreExpr, [Ct])+buildCompare loc wrappedTy innerTy co dcons = do+  ordCls <- tcLookupClass ordClassName+  let ordTy = mkTyConTy orderingTyCon+      [ltC, eqC, gtC] = tyConDataCons orderingTyCon+      ltE = Var (dataConWorkId ltC); eqE = Var (dataConWorkId eqC); gtE = Var (dataConWorkId gtC)+      cmpSel = classMethod "compare" ordCls            -- compare+      scrut v = Cast (Var v) co+      indexed = zip [0 :: Int ..] dcons+      -- bind the field at its real type; compare it at the (override) modifier+      -- type, coercing the value — 'Refl' (no override) makes this a no-op.+      realFts dc = fieldTysAt innerTy dc++      -- lexicographic compare of equally-tagged fields (per field: its+      -- override coercion + the two bound field ids)+      lexCmp [] = pure (eqE, [])+      lexCmp ((fco, x, y) : more) = do+        let ft = coercionRKind fco                     -- modifier type (real type if Refl)+        ev          <- newWanted loc (mkClassPred ordCls [ft])+        (restE, ws) <- lexCmp more+        scr         <- freshId ordTy "o"+        let cmp = mkApps (Var cmpSel) [Type ft, ctEvExpr ev, castInto (Var x) fco, castInto (Var y) fco]+            e   = Case cmp scr ordTy+                    [ Alt (DataAlt ltC) [] ltE+                    , Alt (DataAlt eqC) [] restE+                    , Alt (DataAlt gtC) [] gtE ]+        pure (e, mkNonCanonical ev : ws)++  aId <- freshId wrappedTy "a"+  bId <- freshId wrappedTy "b"+  (outerAlts, wss) <- fmap unzip $ forM indexed \(i, (dci, cosI)) -> do+    xs <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] (realFts dci)+    (innerAlts, iwss) <- fmap unzip $ forM indexed \(j, (dcj, _)) -> do+      ys <- zipWithM (\n ft -> freshId ft ("y" ++ show n)) [0 :: Int ..] (realFts dcj)+      (body, ws) <- if i == j+                      then lexCmp (zip3 cosI xs ys)+                      else pure (if i < j then ltE else gtE, [])+      pure (Alt (DataAlt dcj) ys body, ws)+    innerBndr <- freshId innerTy "cb"+    pure (Alt (DataAlt dci) xs (Case (scrut bId) innerBndr ordTy innerAlts), concat iwss)+  outerBndr <- freshId innerTy "ca"+  let cmpImpl = mkLams [aId, bId] (Case (scrut aId) outerBndr ordTy outerAlts)+  pure (cmpImpl, concat wss)++-- | A direct relational op @a -> b -> Bool@, matching GHC's derived+-- @\<@\/@\<=@\/@\>@\/@\>=@ for small types (it does NOT build an @Ordering@):+-- different constructors compare by tag, equal constructors lexicographically+-- @x1 \`fop\` y1 || (x1 == y1 && rest)@.  @asc@ = ascending (@\<@\/@\<=@); @refl@+-- = reflexive (@\<=@\/@\>=@, so the final field and the nullary case include+-- equality).  The non-final fields use the strict op (@\<@\/@\>@) + @==@; the+-- final field uses the actual op.+buildRel :: Class -> Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]+         -> Bool -> Bool -> TcPluginM (CoreExpr, [Ct])+buildRel ordCls eqCls loc wrappedTy innerTy co dcons asc refl = do+  let boolE b   = Var (dataConWorkId (if b then trueDataCon else falseDataCon))+      ltName    = if asc then "<" else ">"+      lastName  | asc && not refl = "<" | asc = "<=" | not refl = ">" | otherwise = ">="+      scrut v   = Cast (Var v) co+      realFts dc = fieldTysAt innerTy dc+      indexed   = zip [0 :: Int ..] dcons+      fieldRel nm fco x y = do+        let ft = coercionRKind fco+        ev <- newWanted loc (mkClassPred ordCls [ft])+        pure ( mkApps (Var (classMethod nm ordCls))+                 [Type ft, ctEvExpr ev, castInto (Var x) fco, castInto (Var y) fco]+             , [mkNonCanonical ev] )+      fieldEq fco x y = do+        let ft = coercionRKind fco+        ev <- newWanted loc (mkClassPred eqCls [ft])+        pure ( mkApps (Var (classMethod "==" eqCls))+                 [Type ft, ctEvExpr ev, castInto (Var x) fco, castInto (Var y) fco]+             , [mkNonCanonical ev] )+      orE p q  = do s <- freshId boolTy "o"+                    pure (Case p s boolTy [ Alt (DataAlt falseDataCon) [] q+                                          , Alt (DataAlt trueDataCon)  [] (boolE True) ])+      andE2 p q = do s <- freshId boolTy "n"+                     pure (Case p s boolTy [ Alt (DataAlt falseDataCon) [] (boolE False)+                                           , Alt (DataAlt trueDataCon)  [] q ])+      lexRel []              = pure (boolE refl, [])+      lexRel [(fco, x, y)]   = fieldRel lastName fco x y+      lexRel ((fco, x, y) : more) = do+        (ltE, w1) <- fieldRel ltName fco x y+        (eqE, w2) <- fieldEq fco x y+        (rest, w3) <- lexRel more+        ae <- andE2 eqE rest+        oe <- orE ltE ae+        pure (oe, w1 ++ w2 ++ w3)+  aId <- freshId wrappedTy "a" ; bId <- freshId wrappedTy "b"+  (outerAlts, wss) <- fmap unzip $ forM indexed \(i, (dci, cosI)) -> do+    xs <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] (realFts dci)+    (innerAlts, iwss) <- fmap unzip $ forM indexed \(j, (dcj, _)) -> do+      ys <- zipWithM (\n ft -> freshId ft ("y" ++ show n)) [0 :: Int ..] (realFts dcj)+      (body, ws) <- if i == j then lexRel (zip3 cosI xs ys)+                              else pure (boolE (if asc then i < j else i > j), [])+      pure (Alt (DataAlt dcj) ys body, ws)+    cb <- freshId innerTy "cb"+    pure (Alt (DataAlt dci) xs (Case (scrut bId) cb boolTy innerAlts), concat iwss)+  cb2 <- freshId innerTy "ca"+  pure (mkLams [aId, bId] (Case (scrut aId) cb2 boolTy outerAlts), concat wss)++-- | Synthesize a structural @Eq (Stock Inner)@ dictionary for any single-level+-- algebraic @Inner@.  Two values are equal iff they share a constructor and all+-- corresponding fields are equal; field equality uses each field type's own+-- @Eq@ dictionary, requested as a fresh wanted constraint.+-- | Bridge the internal @Repr@ EDSL to the public @Datatype@ view handed to+-- SDK derivers.+synthOrd :: Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]+         -> TcPluginM (EvTerm, [Ct])+synthOrd ordCls loc wrappedTy innerTy co dcons = do+  (cmpImpl, cmpWs) <- buildCompare loc wrappedTy innerTy co dcons++  -- Eq superclass dictionary (also field-aware).+  eqCls         <- tcLookupClass eqClassName+  (eqDict0, eqWs) <- synthEq eqCls loc wrappedTy innerTy co dcons+  let eqDict = unwrapEv eqDict0++  -- Override only @compare@ (the minimal complete definition) and let the+  -- class default methods supply @(<)@, @(<=)@, @(>)@, @(>=)@, @max@, @min@ —+  -- exactly as a hand-written @instance Ord T where compare = …@ would.  We+  -- give @compare@ an INLINE (stable) unfolding so GHC can inline it into the+  -- derived operators (and into specialising consumers), matching how it treats+  -- a source-written instance method.+  --+  -- Note on performance: when the consumer can specialise to the type (the+  -- common case, and everything that inlines — @map (fmap …)@, a user+  -- @sortBy@, etc.) this is byte-for-byte identical to stock @deriving@.  A+  -- residual ~15-20% remains only when feeding comparisons to a *pre-compiled,+  -- non-specialising* consumer such as @Data.List.sort@, which calls the @Ord@+  -- method indirectly; that overhead is inherent to GHC's dictionary handling,+  -- not to the synthesized comparison (its worker is identical to stock's).+  -- With an Override the field coercions are still-unsolved holes; running the+  -- simple optimiser (inside 'mkInlineUnfoldingWithArity') over Core that+  -- mentions them panics @optCoercion@.  So give @compare@ the INLINE unfolding+  -- only in the (common) non-override case — there the Core is identical to+  -- before; overridden types get the plain inlined method (no eager opt).+  let overridden = any (not . isReflCo) (concatMap snd dcons)+      -- GHC's "game plan": for small types (<=3 constructors, or an+      -- enumeration) define <,<=,>,>= DIRECTLY (not via compare), closing the+      -- ~15-20% residual on non-specialising consumers like Data.List.sort.+      small = length dcons <= 3 || all (null . snd) dcons+      idxOf nm = head [ i | (i, m) <- zip [0 :: Int ..] (classMethods ordCls)+                          , occNameString (occName m) == nm ]+  (relOverrides, relWs) <-+    if not small then pure ([], [])+    else do+      let mk asc refl = buildRel ordCls eqCls loc wrappedTy innerTy co dcons asc refl+      (ltI, w1) <- mk True  False ; (leI, w2) <- mk True  True+      (gtI, w3) <- mk False False ; (geI, w4) <- mk False True+      pure ( [(idxOf "<", ltI), (idxOf "<=", leI), (idxOf ">", gtI), (idxOf ">=", geI)]+           , w1 ++ w2 ++ w3 ++ w4 )+  if overridden+    then do+      dict <- recDictWith ordCls wrappedTy [eqDict] ([(0, cmpImpl)] ++ relOverrides)+      pure (EvExpr dict, cmpWs ++ eqWs ++ relWs)+    else do+      let cmpTy  = mkVisFunTyMany wrappedTy (mkVisFunTyMany wrappedTy (mkTyConTy orderingTyCon))+          cmpUnf = mkInlineUnfoldingWithArity defaultSimpleOpts StableSystemSrc 2 cmpImpl+      cmpId0 <- freshId cmpTy "vvCompare"+      let cmpId = cmpId0 `setIdUnfolding` cmpUnf+      dictInner <- recDictWith ordCls wrappedTy [eqDict] ([(0, Var cmpId)] ++ relOverrides)+      let dict = Let (NonRec cmpId cmpImpl) dictInner+      pure (EvExpr dict, cmpWs ++ eqWs ++ relWs)++-- | Synthesize a @Show@ dictionary matching GHC's derived @Show@, for prefix+-- (non-record, non-infix) constructors.  Per the Haskell Report algorithm:+--+--   nullary:  showsPrec _ K       = showString "K"+--   n-ary:    showsPrec d (K a..) = showParen (d > 10)+--                ( showString "K" . showSpace . showsPrec 11 a . showSpace . ... )+--+-- Field rendering is delegated to each field's own @showsPrec@ at precedence+-- 11, so nesting, negative numbers, etc. match exactly.

@@ -0,0 +1,143 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE StandaloneKindSignatures #-}+-- | Per-field deriving modifiers for the Stock plugin.+--+-- @Override a cfg@ wraps @a@ with a type-level configuration @cfg@ that the+-- plugin reads while it synthesizes the instance: each entry names a field and+-- the modifier to run on it (per-field @DerivingVia@).  At runtime @Override@ is+-- just @a@ (a newtype), so there is no cost.+--+-- > data Coord = Coord { x :: Int, y :: Int }+-- >   deriving Semigroup+-- >     via Stock (Override Coord '[ "x" ':= Sum, "y" ':= Product ])+--+-- The config is an uninterpreted, poly-kinded marker the solver decodes off the+-- type — never reduced.  See @docs\/override-design.md@.+--+-- == Addressing a field+--+-- A field is addressed by name (@\"x\" ':= m@), by type (@Int ':= m@, every+-- @Int@ field), or by position (@'At' Coord 0 ':= m@).  A modifier is /pinned/+-- (@Sum Int@) or /broadcast/ to the field's own type (@Sum@).  A whole entry+-- may instead be positional — one inner list per constructor, one cell per+-- field — where 'Keep' (written @_@) leaves a field untouched:+--+-- > deriving Semigroup via Stock (Override Coord '[ [Sum, Keep] ])  -- field 0 via Sum+--+-- == Surface sugar (the @-fplugin Stock@ source pass, "Stock.Surface")+--+-- The honest marker form is verbose, so the same plugin lowers a quote-free+-- surface at parse time, /scoped to @Override@ applications/:+--+-- > Override Coord [ x via Sum, Coord at 0 via Sum, _ ]     -- what you write+-- > Override Coord '[ "x" := Sum, At Coord 0 := Sum, Keep ] -- what the solver reads+--+-- namely: a bare lowercase selector becomes a @Symbol@ (@x@ ⟶ @\"x\"@), @via@+-- becomes ':=', @at@ becomes 'At', and a wildcard @_@ becomes 'Keep'.+--+-- == Higher order+--+-- 'Override1' \/ 'Override2' reshape the /functor/ of a field rather than its+-- element type (an @h a@ field becomes @m a@), so the lifted instance+-- (@Functor@, @Eq1@, @Applicative@, …) uses @m@'s method.  See 'Override1'.+module Stock.Override+  ( Override(..)+  , Overriding+  , Override1(..)+  , Overriding1+  , Override2(..)+  , Overriding2+  , type (:=)+  , type (-->)+  , At+  , Keep+  ) where++import Data.Kind (Type)+import GHC.TypeLits (Nat)+import Stock.Type (Stock, Stock1, Stock2)++-- | @Overriding a cfg = Stock (Override a cfg)@ — the per-field wrapper read+-- through @Generically@.  Because the plugin makes @Generic@ honour @Override@+-- (the @Rep@ carries the modifier field types), @deriving C via Generically+-- (Overriding A cfg)@ derives /any/ @Generic@-based class over @A@ with the+-- per-field modifiers applied.  The Generic-facing twin of using 'Stock' ++-- 'Override' directly with the built-in synthesizers.+type Overriding :: forall k. Type -> k -> Type+type Overriding a cfg = Stock (Override a cfg)++-- | The one-parameter analogue of 'Override': @Override1 f cfg@ wraps a+-- one-parameter constructor @f@ for use through @Stock1@.  Each positional+-- modifier @m@ (a @k -> Type@) reshapes the /functor/ of an @h a@ field to+-- @m a@ — so e.g. a @[a]@ field becomes @ZipList a@ and the derived+-- @Applicative@ zips instead of taking the cartesian product.  A newtype, so+-- @Coercible (Override1 f cfg a) (f a)@.+type Override1 :: forall k j. (j -> Type) -> k -> (j -> Type)+newtype Override1 f cfg a = Override1 (f a)++-- | @Overriding1 f cfg = Stock1 (Override1 f cfg)@ — the @Stock1@-facing+-- per-field wrapper.  @deriving Applicative via Overriding1 F '[ '[ZipList] ]@+-- reshapes @F@'s @[a]@ field into @ZipList a@ before deriving.+type Overriding1 :: forall k j. (j -> Type) -> k -> (j -> Type)+type Overriding1 f cfg = Stock1 (Override1 f cfg)++-- | The two-parameter analogue of 'Override': @Override2 p cfg@ wraps a+-- two-parameter constructor @p@ for use through @Stock2@.  Each positional+-- modifier @m@ (a @Type -> Type -> Type@) reshapes its field to @m a b@ — the+-- modifier applied to /both/ datatype parameters — turning the field into a+-- per-field @Category@.  A newtype, so @Coercible (Override2 p cfg a b) (p a b)@.+type Override2 :: forall k. (Type -> Type -> Type) -> k -> (Type -> Type -> Type)+newtype Override2 p cfg a b = Override2 (p a b)++-- | @Overriding2 p cfg = Stock2 (Override2 p cfg)@ — the @Stock2@-facing+-- per-field wrapper.  @deriving Category via Overriding2 '[ '[Basic (Sum Int),+-- Basic String, Kleisli Maybe] ] Foo@ reshapes each field of @Foo a b@ into a+-- @Category@ and derives @Category@ pointwise over them.+type Overriding2 :: forall k. (Type -> Type -> Type) -> k -> (Type -> Type -> Type)+type Overriding2 p cfg = Stock2 (Override2 p cfg)++-- | @a@ with a per-field override configuration @cfg@.  A newtype, so+-- @Coercible (Override a cfg) a@; @cfg@ is phantom (read by the plugin only).+-- Poly-kinded in @cfg@ so it accepts both config shapes (see+-- @docs\/override-design.md@ §5a): the /entry list/ @'[ "x" ':= Sum, … ]@+-- (@cfg :: [Type]@) and the /positional/ @'[ '[Sum Int, Keep, Keep] ]@ — one+-- inner list per constructor, one element per field (@cfg :: [[Type]]@).+type Override :: forall k. Type -> k -> Type+newtype Override a cfg = Override a++-- | The positional no-op modifier: a field whose slot is @Keep@ is left at its+-- own type.  Written @_@ in source (the @-fplugin Stock@ surface pass lowers the+-- type wildcard to @Keep@), so @'[ '[Sum Int, _, _] ]@ overrides only the first+-- field.  Poly-kinded (a free-result-kind 'data family') so it sits in a list+-- beside modifiers of /any/ kind — @Sum Int :: Type@ or @Sum :: Type -> Type@ —+-- without breaking the list's kind homogeneity.  An uninterpreted marker the+-- plugin reads; never reduced.+type Keep :: forall k. k+data family Keep++-- | A single config entry: the field @name@ (a 'Symbol') gets modifier @m@.+-- Poly-kinded in @m@, so a saturated modifier (@Sum Int :: Type@) and an+-- unsaturated one (@Sum :: Type -> Type@) both fit; the plugin dispatches on+-- @m@'s kind (pin vs. broadcast).  An uninterpreted 'data family' — generative,+-- injective, never reduced — so the solver reads it back verbatim.+type (:=) :: forall sel k. sel -> k -> Type+data family (:=) sel m++-- | A positional selector: field @pos@ of constructor @con@.  Used /prefix/ on+-- the left of @(:=)@ — @At Con 0 := m@ — so the surface keeps a single infix+-- operator.  Like '(:=)' it is an uninterpreted, poly-kinded marker.+type At :: forall kc sel. kc -> Nat -> sel+data family At con pos++-- | A path hop: @h '--> rest@.  Each non-terminal hop selects a node — a+-- promoted constructor (that constructor), a 'Nat' (field by position) or a+-- 'Symbol' (field by label) — and the terminal hop is the modifier; the+-- modifier applies to every field under the prefix.  So @'P '--> m@ overrides+-- every field of @P@ and @'P '--> 0 '--> m@ overrides only its first field+-- (design §4).  Poly-kinded, uninterpreted, never reduced.+type (-->) :: forall k1 k2 j. k1 -> k2 -> j+data family (-->) a b+infixr 5 -->

@@ -0,0 +1,92 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}+-- | @Read@ synthesizer: builds @readPrec@ exactly as GHC's derived @Read@ does+-- (the @ReadPrec@ combinators via "Stock.Internal"'s 'buildReadPrecBody'), so+-- @readsPrec@ — from the class default — is byte-faithful, including the order+-- of ambiguous infix parses.+module Stock.Read 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)+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)+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)+import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'+import Stock.Trans (MaybeT(..))+import Control.Monad (forM, zipWithM, unless, guard)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef')+import Stock.Internal++synthRead :: Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]+          -> TcPluginM (EvTerm, [Ct])+synthRead cls loc wrappedTy innerTy co dcons = do+  (env, monadCt) <- lookupReadPrecEnv loc+  let readPrecSel = classMethod "readPrec" cls+      toWrapped e = Cast e (mkSymCo co)+  -- each field is read at its modifier type @ft@ (= coercionRKind of its+  -- coercion) via that type's own @readPrec@, then coerced back to the real+  -- field type when the constructor is built.+  (cons, evss) <- fmap unzip $ forM dcons \(dc, cosI) -> do+    let fts = map coercionRKind cosI+    fieldEvs <- mapM (\ft -> newWanted loc (mkClassPred cls [ft])) fts+    let readers = [ (ft, mkApps (Var readPrecSel) [Type ft, ctEvExpr ev])+                  | (ft, ev) <- zip fts fieldEvs ]+    pure ((dc, readers, cosI), fieldEvs)+  let cosMap = [ (getUnique dc, cosI) | (dc, _, cosI) <- cons ]+      mkConVal dc argIds =+        let cosI = fromJust (lookup (getUnique dc) cosMap)+        in toWrapped (conAppAt innerTy dc+             (zipWith (\a c -> castInto (Var a) (mkSymCo c)) argIds cosI))+  body <- buildReadPrecBody env wrappedTy mkConVal [ (dc, rs) | (dc, rs, _) <- cons ]+  dict <- recDictWith cls wrappedTy [] [(2, body)]+  pure (EvExpr dict, monadCt : map mkNonCanonical (concat evss))++-- | Synthesize @Generic (Stock T)@ for any single-level ADT.  @Rep@ is a+-- balanced @:+:@ tree of constructors (one constructor ⇒ no @:+:@), each a+-- balanced @:*:@ tree of @Rec0 field@ (or @U1@ if no fields).  @from@ matches+-- the real constructor, builds its product value and injects it into the sum+-- with @L1@\/@R1@; @to@ projects through the @:+:@\/@:*:@ structure and+-- rebuilds.  All casts go through the same plugin coercion the rewriter+-- asserts.  @K1@\/@:+:@\/@:*:@ layers: @K1@ is a newtype (coercion), @:+:@ and+-- @:*:@ are real data (constructed/matched).

@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}+-- | @Semigroup@ \/ @Monoid@ synthesizers: pointwise over a single-constructor product.+module Stock.Semigroup 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)+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 Data.Maybe (catMaybes, fromJust, isJust, fromMaybe)+import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'+import Stock.Trans (MaybeT(..))+import Control.Monad (forM, zipWithM, unless, guard)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef')+import Stock.Internal+-- @gmappend x y = productTypeTo (cliftA2_NP (Proxy \@Semigroup) (mapIII (<>))+--                                            (productTypeFrom x) (productTypeFrom y))@+semigroupDeriver :: Deriver+semigroupDeriver = Deriver \cls dt -> do+  let via       = dtVia dt+      sappSel   = classMethod "<>" cls                 -- (<>)+      mapSapp ft d x y = mkApps (Var sappSel) [Type ft, d, x, y]+  aId <- fresh via "a" ; bId <- fresh via "b"+  body <- fromProduct dt via (Var aId) \xs ->+          fromProduct dt via (Var bId) \ys ->+          toProduct dt <$> czipFields cls mapSapp (productCon dt) xs ys+  dict <- liftTc (recDictWith cls via [] [(0, mkLams [aId, bId] body)])+  pure (EvExpr dict)++-- | Pointwise @Monoid@ for a single-constructor product: @mempty = C mempty..@.+-- Its @Semigroup@ superclass is the 'semigroupDeriver' dictionary;+-- @mappend@\/@mconcat@ come from the class defaults.+--+-- @gmempty = productTypeTo (cpure_NP (Proxy \@Monoid) (I mempty))@+monoidDeriver :: Deriver+monoidDeriver = Deriver \cls dt -> do+  semigroupCls <- liftTc (tcLookupClass semigroupClassName)+  superEv      <- runDeriver semigroupDeriver semigroupCls dt+  let via       = dtVia dt+      memptySel = classMethod "mempty" cls                 -- mempty+      mapMempty ft d = mkApps (Var memptySel) [Type ft, d]+  memptyVal <- toProduct dt <$> cpureFields cls mapMempty (productCon dt)+  dict <- liftTc (recDictWith cls via [unwrapEv superEv] [(0, memptyVal)])+  pure (EvExpr dict)+

@@ -0,0 +1,164 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}+-- | @Show@ synthesizer: GHC-faithful @showsPrec@ (prefix \/ infix \/ record, with parens).+module Stock.Show 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)+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 Data.Maybe (catMaybes, fromJust, isJust, fromMaybe)+import qualified Data.Monoid as Mon (Alt(..))  -- 'Alt' clashes with GHC.Core's case-alt 'Alt'+import Stock.Trans (MaybeT(..))+import Control.Monad (forM, zipWithM, unless, guard)+import Data.IORef (IORef, newIORef, readIORef, modifyIORef')+import Stock.Internal++synthShow :: Class -> CtLoc -> Type -> Type -> Coercion -> [(DataCon, [Coercion])]+          -> TcPluginM (EvTerm, [Ct])+synthShow showCls loc wrappedTy innerTy co dcons = do+  appendId     <- tcLookupId appendName+  showListName <- lookupOrig gHC_INTERNAL_SHOW (mkVarOcc "showList__")+  showList__Id <- tcLookupId showListName+  ordCls       <- tcLookupClass ordClassName++  let showsPrecSel = classMethod "showsPrec" showCls         -- showsPrec+      geSel        = classMethod ">=" ordCls           -- (>=) — GHC parenthesises with @d >= prec+1@+      showSTy      = mkVisFunTyMany stringTy stringTy     -- ShowS+      scrut v      = Cast (Var v) co+      cons c t     = mkCoreConApps consDataCon [Type charTy, c, t]   -- c : t+      append s t   = mkApps (Var appendId) [Type charTy, s, t]       -- s ++ t+      str s        = unsafeTcPluginTcM (mkStringExprFS (fsLit s))     -- string literal++  ordIntEv <- newWanted loc (mkClassPred ordCls [intTy])+  let ordIntDict = ctEvExpr ordIntEv++  dId <- freshId intTy "d"+  vId <- freshId wrappedTy "v"++  (alts, fieldWss) <- fmap unzip $ forM dcons \(dc, cosI) -> do+    let realFts = fieldTysAt innerTy dc           -- real (bind) types+        modFts  = map coercionRKind cosI          -- modifier (show-at) types; real when Refl+        name   = occNameString (getOccName dc)+        labels = map (occNameString . nameOccName . flSelector) (dataConFieldLabels dc)+    nameStr  <- str name+    nameSp   <- str (name ++ " ")   -- name + the separating space, baked into one literal (as GHC does)+    xs       <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] realFts+    fieldEvs <- mapM (\ft -> newWanted loc (mkClassPred showCls [ft])) modFts+    rest     <- freshId stringTy "r"+    gtBndr   <- freshId boolTy "p"+    prec     <- conPrec dc++    -- each field shown at its modifier type, with its bound value coerced+    let triples = zip3 modFts fieldEvs (zipWith castInto (map Var xs) cosI)+        spField p (ft, ev, v) =+          mkApps (Var showsPrecSel) [Type ft, ctEvExpr ev, mkUncheckedIntExpr p, v]+        -- prefix: "K " ++ sp 11 x0 (' ' : sp 11 x1 (… t)) — GHC bakes the first+        -- space into the constructor-name literal, then separates the rest.+        goPrefix :: CoreExpr -> CoreExpr+        goPrefix t = case triples of+          []          -> t+          (f0 : more) -> App (spField 11 f0)+                             (foldr (\fld acc -> cons (mkCharExpr ' ') (App (spField 11 fld) acc)) t more)+        -- parenthesise the body when @d >= thr+1@ (i.e. @d > thr@), matching the+        -- @showParen (d >= appPrec1) p@ that GHC's stock @deriving@ emits.  The+        -- shared continuation @g = \\s -> mk s@ is built once (a single join+        -- point, not duplicated inline); an optional @lead@ literal (the+        -- constructor name) is prepended /outside/ @g@ in each branch, exactly+        -- as GHC floats @showString name@ out of the shared part.+        parenAt :: Integer -> Maybe CoreExpr -> (CoreExpr -> CoreExpr) -> CoreExpr -> TcPluginM CoreExpr+        parenAt thr lead mk t = do+          pId <- freshId showSTy "p"+          sId <- freshId stringTy "s"+          let test :: CoreExpr+              test = mkApps (Var geSel) [Type intTy, ordIntDict, Var dId, mkUncheckedIntExpr (thr + 1)]+              p :: CoreExpr -> CoreExpr   -- lead ++ g t' (lead prepended outside the shared g)+              p t' = maybe id append lead (App (Var pId) t')+          pure $ Let (NonRec pId (Lam sId (mk (Var sId)))) $+            Case test gtBndr stringTy+              [ Alt (DataAlt falseDataCon) [] (p t)+              , Alt (DataAlt trueDataCon)  []+                  (cons (mkCharExpr '(') (p (cons (mkCharExpr ')') t))) ]++    showsBody <-+      if dataConIsInfix dc                                 -- infix: x `op` y at prec+        then do+          opStr <- str (" " ++ name ++ " ")+          let [l, r] = triples+              body t = App (spField (prec + 1) l) (append opStr (App (spField (prec + 1) r) t))+          parenAt prec Nothing body (Var rest)+        else if not (null labels)+          then do                                          -- record: K {l1 = v1, l2 = v2}+            openB  <- str " {"; eqB <- str " = "; commaB <- str ", "; closeB <- str "}"+            lblStrs <- mapM str labels+            let recF = zip lblStrs triples+                goRec [(lbl, fld)] c = append lbl (append eqB (App (spField 0 fld) (append closeB c)))+                goRec ((lbl, fld) : more) c =+                  append lbl (append eqB (App (spField 0 fld) (append commaB (goRec more c))))+                goRec [] c = append closeB c               -- unreachable (record has fields)+                recBody t = append nameStr (append openB (goRec recF t))+            parenAt 10 Nothing recBody (Var rest)+          else if null xs+            then pure (append nameStr (Var rest))          -- nullary: never parenthesised+            else parenAt 10 (Just nameSp) goPrefix (Var rest)  -- prefix: share fields, prepend name++    pure (Alt (DataAlt dc) xs (Lam rest showsBody), fieldEvs)++  caseBndr <- freshId innerTy "cb"+  let spImpl = mkLams [dId, vId] (Case (scrut vId) caseBndr showSTy alts)++  -- show x      = showsPrec 0 x ""+  -- showList    = showList__ (showsPrec 0)+  vShow <- freshId wrappedTy "v"+  vList <- freshId wrappedTy "v"+  let showImpl = Lam vShow (mkApps spImpl [mkUncheckedIntExpr 0, Var vShow, mkNilExpr charTy])+      sp0      = Lam vList (mkApps spImpl [mkUncheckedIntExpr 0, Var vList])+      showListImpl = mkApps (Var showList__Id) [Type wrappedTy, sp0]+      dict = mkClassDict showCls wrappedTy [spImpl, showImpl, showListImpl]+      wanteds = mkNonCanonical ordIntEv+              : map mkNonCanonical (concat fieldWss)+  pure (EvExpr dict, wanteds)++-- | Synthesize a @Bounded@ dictionary.  For an enumeration, @minBound@/@maxBound@+-- are the first/last constructors.  For a single-constructor product, they are+-- that constructor applied to the field types' own @minBound@/@maxBound@.

@@ -0,0 +1,164 @@+{-# LANGUAGE RankNTypes #-}+-- | Source-level sugar for "Stock.Override": a @parsedResultAction@ that lowers+-- the lowercase, no-backtick surface+--+-- > Override [ x via Sum, Coord at 0 via Sum ] T+--+-- into the honest marker form the type-checker plugin reads+--+-- > Override [ "x" := Sum, At Coord 0 := Sum ] T+--+-- keeping a single infix operator (@:=@); @at@ becomes the prefix marker @At@,+-- and a bare lowercase selector becomes a 'Symbol' literal.  The rewrite is+-- /scoped to @Override@ applications/, runs before renaming, and reuses the+-- original sub-trees (so spans survive); @via@\/@at@ elsewhere are untouched.+-- Enabled by the same @-fplugin Stock@ as the solver.+module Stock.Surface (lowerOverrides) where++import GHC.Plugins+import GHC.Hs+import GHC.Types.SourceText (SourceText(NoSourceText))+import Data.Char (isLower)+import Data.Data (Data, gmapT)+import Data.Typeable (Typeable, cast)+import Data.Maybe (fromMaybe)++-- A two-line slice of @syb@ over @base@'s 'Data'/'Typeable' (the GHC AST derives+-- 'Data'), so we depend on no extra package.++-- | Apply @f@ at every subterm, bottom-up.  An endofunction on the type of+-- type-preserving polymorphic transformations.+everywhere :: (forall x. Data x => x -> x) -> (forall x. Data x => x -> x)+everywhere f = f . gmapT (everywhere f)++-- | Lift a single-type transformation to act only where the type matches.+mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a+mkT f = fromMaybe id (cast f)++-- | Rewrite every @Override [ … ]@ config in the parsed module.+lowerOverrides :: ParsedResult -> ParsedResult+lowerOverrides pr =+  pr { parsedResultModule =+         let m = parsedResultModule pr+         in m { hpm_module = everywhere (mkT rewriteTy) (hpm_module m) } }++-- | If this type is @Override T CFG@ (or the @Overriding@\/@Overriding1@\/+-- @Overriding2@ synonyms — all type-first), lower the entries of @CFG@.  @CFG@+-- is the /last/ argument here (the wrappers are type-first: @Overriding T cfg@).+rewriteTy :: HsType GhcPs -> HsType GhcPs+rewriteTy ty+  | HsAppTy x f cfg <- ty            -- (hd T) cfg+  , L _ (HsAppTy _ hd _) <- f        -- f = hd T+  , Just mq <- overrideHeadQual (unLoc hd)+  , Just cfg' <- lowerConfig mq cfg+  = HsAppTy x f cfg'                 -- keep @hd T@, lower the config+  | otherwise = ty++-- | If this is an @Override@-family head, report /how it was qualified/ — the+-- module alias if written @S.Override@ (@import Stock.Override qualified as S@),+-- or 'Nothing' if unqualified.  The generated markers (@:=@, @At@, @Keep@) mirror+-- this, so they resolve no matter how the user imported "Stock.Override".+overrideHeadQual :: HsType GhcPs -> Maybe (Maybe ModuleName)+overrideHeadQual (HsTyVar _ _ (L _ rdr))+  | occNameString (rdrNameOcc rdr) `elem`+      ["Override", "Overriding", "Overriding1", "Overriding2"]+  = Just (fst <$> isQual_maybe rdr)+overrideHeadQual _ = Nothing++-- | Build a marker constructor name (@:=@, @At@, @Keep@), qualified the same way+-- the @Override@ head was, so it is in scope under any import style.+mkMarker :: Maybe ModuleName -> String -> RdrName+mkMarker Nothing  nm = mkRdrUnqual (mkTcOcc nm)+mkMarker (Just m) nm = mkRdrQual m  (mkTcOcc nm)++-- | Lower a config list by rewriting each element.  The config is assumed to be+-- an actual type-level list ('HsExplicitListTy') — i.e. @'[ … ]@, or @[ … ]@+-- under @NoListTuplePuns@.  A single-element @[a]@ that parses as the /list+-- type/ is deliberately /not/ reinterpreted (write @'[a]@ instead).+--+-- Two surfaces share this pass: the entry-list form (each element lowered by+-- 'lowerEntry'), and the positional @'[ '[m, _, …] ]@ form whose inner lists+-- carry the @_@ no-op — every type wildcard anywhere in the config is lowered+-- to the @Keep@ marker that the solver reads.+lowerConfig :: Maybe ModuleName -> LHsType GhcPs -> Maybe (LHsType GhcPs)+lowerConfig mq (L l (HsExplicitListTy x p es)) =+  Just (everywhere (mkT (wildToKeep mq)) (L l (HsExplicitListTy x p (map (lowerEntry mq) es))))+lowerConfig _ _ = Nothing++-- | The positional no-op: a type wildcard @_@ ('HsWildCardTy') becomes the+-- @Keep@ marker, qualified to match the @Override@ head.  (Bare @Keep@ written by+-- hand is left as-is.)+wildToKeep :: Maybe ModuleName -> HsType GhcPs -> HsType GhcPs+wildToKeep mq (HsWildCardTy _) =+  unLoc (nlHsTyVar NotPromoted (mkMarker mq "Keep"))+wildToKeep _ t = t++-- | Lower one entry.  Surfaces:+--+--   * @sel via modifier@ — split the application spine on @via@, rebuild as+--     @(:=) selector modifier@.+--   * @sel via a -> f b@ — @via@ binds looser than @->@: GHC parses this as+--     @(sel via a) -> f b@, so we peel @via@ off the /domain/ and rebuild the+--     modifier as @a -> f b@ (i.e. @sel via (a -> f b)@ without the parens).+--   * @sel := modifier@  — written with the operator directly; lower only the+--     /selector/ (the LHS).+--+-- Anything else is left untouched.+lowerEntry :: Maybe ModuleName -> LHsType GhcPs -> LHsType GhcPs+lowerEntry mq (L l (HsOpTy x prom lhs op rhs))+  | isVarRdr ":=" (unLoc op) =+      L l (HsOpTy x prom (lowerSelector mq (spine lhs)) op rhs)+lowerEntry mq (L l (HsFunTy x arr dom cod))+  | (sel@(_ : _), _via : modAtoms@(_ : _)) <- break (isVar "via") (spine dom) =+      mkPrefix mq ":=" [lowerSelector mq sel, L l (HsFunTy x arr (reassemble modAtoms) cod)]+lowerEntry mq e =+  case break (isVar "via") (spine e) of+    (sel@(_ : _), _via : modAtoms@(_ : _)) ->+      mkPrefix mq ":=" [lowerSelector mq sel, reassemble modAtoms]+    _ -> e++-- | The selector left of @via@: @con at pos@ ⇒ @At con pos@; a bare lowercase+-- head ⇒ a 'Symbol' literal; otherwise reassembled as a type (type-keyed).+lowerSelector :: Maybe ModuleName -> [LHsType GhcPs] -> LHsType GhcPs+lowerSelector mq atoms =+  case break (isVar "at") atoms of+    (con@(_ : _), _at : pos@(_ : _)) ->+      mkPrefix mq "At" [nameOrType con, reassemble pos]+    _ -> nameOrType atoms++-- | A single bare lowercase variable ⇒ field-name 'Symbol' literal; else a type.+nameOrType :: [LHsType GhcPs] -> LHsType GhcPs+nameOrType [L l (HsTyVar _ NotPromoted (L _ rdr))]+  | isLowerName rdr =+      L l (HsTyLit noExtField (HsStrTy NoSourceText (occNameFS (rdrNameOcc rdr))))+nameOrType atoms = reassemble atoms++-- ----- application-spine helpers -------------------------------------------++-- | Flatten a left-nested @HsAppTy@ into its atoms (head first).+spine :: LHsType GhcPs -> [LHsType GhcPs]+spine (L _ (HsAppTy _ f a)) = spine f ++ [a]+spine t                     = [t]++-- | Re-nest a non-empty atom list into a left-associated application.+reassemble :: [LHsType GhcPs] -> LHsType GhcPs+reassemble = foldl1 mkHsAppTy++-- | Prefix application of a marker type constructor named @nm@ to @args@,+-- qualified to match the @Override@ head (see 'mkMarker').+mkPrefix :: Maybe ModuleName -> String -> [LHsType GhcPs] -> LHsType GhcPs+mkPrefix mq nm = foldl mkHsAppTy (nlHsTyVar NotPromoted (mkMarker mq nm))++-- ----- predicates ----------------------------------------------------------++isVar :: String -> LHsType GhcPs -> Bool+isVar nm (L _ (HsTyVar _ _ (L _ rdr))) = isVarRdr nm rdr+isVar _  _                             = False++isVarRdr :: String -> RdrName -> Bool+isVarRdr nm rdr = occNameString (rdrNameOcc rdr) == nm++isLowerName :: RdrName -> Bool+isLowerName rdr = case occNameString (rdrNameOcc rdr) of+  (c : _) -> isLower c+  _       -> False

@@ -0,0 +1,122 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+-- | A deliberately /minimal, forward-safe/ 'Data.Type.Equality.TestEquality'+-- (and 'Data.Type.Coercion.TestCoercion') synthesizer.+--+-- It handles exactly the unambiguous "finite singleton" GADT: a one-parameter+-- type whose every constructor is nullary, has no existentials, and pins the+-- parameter to a /ground/ type:+--+-- > data T a where { TInt :: T Int; TBool :: T Bool }+--+-- For these the lawful behaviour is forced: @testEquality x y@ is @Just Refl@+-- exactly when the type /indices/ of @x@ and @y@ coincide (NOT when they are+-- the same constructor: two constructors pinning the same type are equal), and+-- @Nothing@ otherwise.  Because that is the only law-abiding implementation, it+-- can never disagree with a future, more general design, so it commits us to+-- nothing.  Anything outside the subset is refused.+module Stock.TestEquality (synthTestEquality, synthTestCoercion) where++import GHC.Plugins hiding (TcPlugin)+import GHC.Tc.Plugin (TcPluginM, unsafeTcPluginTcM)+import GHC.Tc.Types.Constraint (Ct)+#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 (EvTerm(EvExpr))+import GHC.Core.Class (Class, classMethods)+import GHC.Core.TyCo.Compare (eqType)+import Stock.Internal++-- | A datacon's GADT equality refinements (no public accessor; via the sig).+dcEqSpec :: DataCon -> [EqSpec]+dcEqSpec dc = let (_, _, eqs, _, _, _) = dataConFullSig dc in eqs++-- | A constructor in the supported subset; returns its pinned ground index.+pinnedGround :: DataCon -> Maybe Type+pinnedGround dc = case dcEqSpec dc of+  [es] | null (dataConExTyCoVars dc)               -- no existentials+       , null (dataConOrigArgTys dc)               -- nullary (no value fields)+       , let ty = snd (eqSpecPair es)+       , isEmptyVarSet (tyCoVarsOfType ty)         -- ground (closed) index+       -> Just ty+  _    -> Nothing++synthTestEquality, synthTestCoercion+  :: GenEnv -> Class -> CtLoc -> Type -> Type -> TcPluginM (Maybe (EvTerm, [Ct]))+synthTestEquality = synthEqLike True+synthTestCoercion = synthEqLike False++-- | @useRefl = True@ ⇒ 'TestEquality' (@(:~:)@ \/ @Refl@); @False@ ⇒+-- 'TestCoercion' (@Coercion@).+synthEqLike :: Bool -> GenEnv -> Class -> CtLoc -> Type -> Type+            -> TcPluginM (Maybe (EvTerm, [Ct]))+synthEqLike useRefl gen cls _loc wrappedTy f =+  case (geStock1 gen, tyConAppTyCon_maybe f) of+    (Just st1Tc, Just fTc)+      | null (tyConAppArgs f)                       -- F is a bare one-param tycon+      , dcons@(dc0 : _) <- tyConDataCons fTc+      , Just pins <- traverse pinnedGround dcons+      , (es0 : _) <- dcEqSpec dc0+      -- the witness type (@(:~:)@ \/ @Coercion@) straight from the method's+      -- signature, so we never have to name a (re-exported) module.+      , (meth : _) <- classMethods cls+      , (witTc : _) <- [ tc | tc <- nonDetEltsUniqSet (tyConsOfType (varType meth))+                            , nameOccName (tyConName tc)+                                == mkTcOcc (if useRefl then ":~:" else "Coercion") ] -> do+          let witCon = tyConSingleDataCon witTc+              kK     = tyVarKind (fst (eqSpecPair es0))+              coAt   = coDown1 gen st1Tc wrappedTy f f+          aTv <- freshTyVarK kK "a"+          bTv <- freshTyVarK kK "b"+          xId <- freshId (mkAppTy wrappedTy (mkTyVarTy aTv)) "x"+          yId <- freshId (mkAppTy wrappedTy (mkTyVarTy bTv)) "y"+          wbX <- freshId (mkTyConApp fTc [mkTyVarTy aTv]) "wx"+          wbY <- freshId (mkTyConApp fTc [mkTyVarTy bTv]) "wy"+          let aTy = mkTyVarTy aTv ; bTy = mkTyVarTy bTv+              witOf x y = mkTyConApp witTc [kK, x, y]+              resTy     = mkTyConApp maybeTyCon [witOf aTy bTy]+              nothingE  = mkCoreConApps nothingDataCon [Type (witOf aTy bTy)]+              -- same index: cox : a~#t, coy : b~#t  ⇒  abCo : a~#b.+              --   Refl     :: forall k (a b). (b ~# a)     => a :~: b    (eqSpec)+              --   Coercion :: forall k (a b). Coercible a b => Coercion a b+              -- so we feed the proof directly; for Coercion we first box the+              -- representational coercion into a Coercible dictionary with the+              -- wired-in 'coercibleDataCon' (@MkCoercible :: (a ~R# b) ->+              -- Coercible a b@).  No Cast, no constraint solving.+              same cox coy =+                let abCo  = mkTransCo (mkCoVarCo cox) (mkSymCo (mkCoVarCo coy))+                    proof | useRefl   = Coercion (mkSymCo abCo)   -- b ~# a (nominal)+                          | otherwise = mkCoreConApps coercibleDataCon+                                          [Type kK, Type aTy, Type bTy+                                          , Coercion (mkSubCo abCo)]   -- a ~R# b boxed+                    wit = mkCoreConApps witCon [Type kK, Type aTy, Type bTy, proof]+                in mkCoreConApps justDataCon [Type (witOf aTy bTy), wit]+          -- testEquality compares the type /indices/, not constructor tags:+          -- two constructors pinning the same ground type ⇒ Just Refl.+          let innerAlts ti cox = mapM mkInner (zip dcons pins)+                where mkInner (dcj, tj) = do+                        coy <- freshCoVar (mkPrimEqPred bTy tj)+                        let rhs = if eqType ti tj then same cox coy else nothingE+                        pure (Alt (DataAlt dcj) [coy] rhs)+          outerAlts <- mapM+            (\(dci, ti) -> do+                cox <- freshCoVar (mkPrimEqPred aTy ti)+                ialts <- innerAlts ti cox+                let inner = Case (Cast (Var yId) (coAt bTy)) wbY resTy ialts+                pure (Alt (DataAlt dci) [cox] inner))+            (zip dcons pins)+          let impl = mkCoreLams [aTv, bTv, xId, yId] $+                       Case (Cast (Var xId) (coAt aTy)) wbX resTy outerAlts+              -- TestEquality/TestCoercion are poly-kinded (@class C (f :: k ->+              -- Type)@), so the dictionary takes the kind @k@ first.+              dict = mkCoreConApps (classDataCon cls) [Type kK, Type wrappedTy, impl]+          pure (Just (EvExpr dict, []))+    _ -> pure Nothing++freshCoVar :: Type -> TcPluginM CoVar+freshCoVar ty = do+  u <- unsafeTcPluginTcM getUniqueM+  pure (mkCoVar (mkSystemName u (mkVarOccFS (fsLit "co"))) ty)

@@ -0,0 +1,88 @@+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE BlockArguments #-}+-- | A two-screen slice of @transformers@: the three monad transformers the+-- plugin uses (@ReaderT@, strict @WriterT@, @MaybeT@), inlined so the library+-- depends only on @base@ and @ghc@.  They are used /only/ as @DerivingVia@+-- targets (the synthesis monad in "Stock.Derive", the first-success 'Monoid' in+-- "Stock.Internal"), so the representations match @transformers@ exactly — that+-- is what lets the @via@ coercions go through — and none of the combinators+-- (@lift@, @ask@, @tell@, @runReaderT@, …) are needed beyond the constructors.+module Stock.Trans+  ( ReaderT(..)+  , WriterT(..)+  , MaybeT(..)+  ) where++import Control.Applicative (Alternative(..))+import Control.Monad (ap)+-- liftA2 comes from Prelude (base >= 4.18 / GHC >= 9.6)++-- | @r -> m a@, exactly as in @Control.Monad.Trans.Reader@.+newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }++-- | @m (a, w)@ — the /strict/ writer (value first), as in+-- @Control.Monad.Trans.Writer.Strict@.+newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }++-- | @m (Maybe a)@, exactly as in @Control.Monad.Trans.Maybe@.+newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }++instance Functor m => Functor (ReaderT r m) where+  fmap :: (a -> b) -> ReaderT r m a -> ReaderT r m b+  fmap f (ReaderT g) = ReaderT (fmap f . g)++instance Applicative m => Applicative (ReaderT r m) where+  pure :: a -> ReaderT r m a+  pure = ReaderT . const . pure+  (<*>) :: ReaderT r m (a -> b) -> ReaderT r m a -> ReaderT r m b+  ReaderT f <*> ReaderT x = ReaderT \r -> f r <*> x r++instance Monad m => Monad (ReaderT r m) where+  (>>=) :: ReaderT r m a -> (a -> ReaderT r m b) -> ReaderT r m b+  ReaderT x >>= k = ReaderT \r -> x r >>= \a -> runReaderT (k a) r++instance Functor m => Functor (WriterT w m) where+  fmap :: (a -> b) -> WriterT w m a -> WriterT w m b+  fmap f (WriterT m) = WriterT (fmap (\(a, w) -> (f a, w)) m)++instance (Monoid w, Applicative m) => Applicative (WriterT w m) where+  pure :: a -> WriterT w m a+  pure a = WriterT (pure (a, mempty))+  (<*>) :: WriterT w m (a -> b) -> WriterT w m a -> WriterT w m b+  WriterT mf <*> WriterT mx = WriterT (liftA2 k mf mx)+    where k (f, w) (x, w') = (f x, w <> w')++instance (Monoid w, Monad m) => Monad (WriterT w m) where+  (>>=) :: WriterT w m a -> (a -> WriterT w m b) -> WriterT w m b+  WriterT m >>= k = WriterT do+    (a, w)  <- m+    (b, w') <- runWriterT (k a)+    pure (b, w <> w')++instance Functor m => Functor (MaybeT m) where+  fmap :: (a -> b) -> MaybeT m a -> MaybeT m b+  fmap f (MaybeT m) = MaybeT (fmap (fmap f) m)++instance Monad m => Applicative (MaybeT m) where+  pure :: a -> MaybeT m a+  pure = MaybeT . pure . Just+  (<*>) :: MaybeT m (a -> b) -> MaybeT m a -> MaybeT m b+  (<*>) = ap++instance Monad m => Monad (MaybeT m) where+  (>>=) :: MaybeT m a -> (a -> MaybeT m b) -> MaybeT m b+  MaybeT m >>= k = MaybeT do+    ma <- m+    case ma of+      Nothing -> pure Nothing+      Just a  -> runMaybeT (k a)++instance Monad m => Alternative (MaybeT m) where+  empty :: MaybeT m a+  empty = MaybeT (pure Nothing)+  (<|>) :: MaybeT m a -> MaybeT m a -> MaybeT m a+  MaybeT a <|> MaybeT b = MaybeT do+    ma <- a+    case ma of+      Nothing -> b+      Just _  -> pure ma

@@ -0,0 +1,166 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns -Wno-unused-imports #-}+-- | @Traversable (Stock1 F)@, synthesized directly (DeriveTraversable-style+-- Core), NOT by coercion.  @traverse@'s result @f (t b)@ places the wrapper+-- under an /abstract/ applicative @f@ (nominal role), so DerivingVia cannot+-- coerce @Traversable (Stock1 F)@ onto @F@ — but the instance itself is+-- perfectly definable and usable at the wrapper.  Put it on your own type with+-- the one-liner (which works with @Override1@ too):+--+-- > instance Traversable F where+-- >   traverse g = fmap unStock1 . traverse g . Stock1+module Stock.Traversable (synthTraversable) where++import GHC.Plugins hiding (TcPlugin)+import GHC.Tc.Plugin+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.Core.Class (Class)+import GHC.Core.Predicate (mkClassPred)+import GHC.Core.Multiplicity (scaledThing)+import GHC.Core.TyCo.Compare (eqType)+import GHC.Core.TyCo.Subst (substTyWith)+import GHC.Core.TyCo.Rep (UnivCoProvenance(PluginProv))+import GHC.Builtin.Names (applicativeClassName, functorClassName, foldableClassName)+import Control.Monad (forM, zipWithM)+import Data.List (zipWith4)+import Stock.Derive (classMethod)+import Stock.Internal+import Stock.Functor (synthFunctor, synthFoldable)++-- | Synthesize @Traversable (Stock1 F)@: per constructor, @pure mkCon \<*\> f1+-- \<*\> … \<*\> fn@ where the parameter field uses the supplied @g@, a constant+-- uses @pure@, and a sub-functor @H a@ field uses @traverse \@H g@ (an+-- @Override1@-reshaped functor traverses through the modifier, re-wrapped with+-- @pure coerce \<*\> _@ — never a cast under the abstract @f@).  @Functor@ and+-- @Foldable@ superclasses come from their own synthesizers.+synthTraversable :: GenEnv -> Class -> CtLoc -> Type -> Type+                 -> TcPluginM (Maybe (EvTerm, [Ct]))+synthTraversable gen travCls loc wrappedTy f =+  case geStock1 gen of+    Just st1Tc+      | let (realF, mMods) = peelOverride1 gen f+      , Just fTc <- tyConAppTyCon_maybe realF -> do+      appCls  <- tcLookupClass applicativeClassName+      funcCls <- tcLookupClass functorClassName+      foldCls <- tcLookupClass foldableClassName+      let fixed = tyConAppArgs realF+          dcons = tyConDataCons fTc+          traverseSel = classMethod "traverse" travCls+          pureSel     = classMethod "pure" appCls+          apSel       = classMethod "<*>"  appCls+          coAt t      = coDown1 gen st1Tc wrappedTy f realF t   -- Stock1 (Override1? F) t ~R F t+      fTv <- freshTyVarK (mkVisFunTyMany liftedTypeKind liftedTypeKind) "f"  -- f :: Type -> Type+      aTv <- freshTyVar "a" ; bTv <- freshTyVar "b"+      let fTy = mkTyVarTy fTv ; aTy = mkTyVarTy aTv ; bTy = mkTyVarTy bTv+          fOf t  = mkAppTy fTy t+          innerA = mkTyConApp fTc (fixed ++ [aTy])+          gTy    = mkVisFunTyMany aTy (fOf bTy)              -- a -> f b+          stbTy  = mkAppTy wrappedTy bTy                     -- Stock1 F b+      dApp <- freshId (mkClassPred appCls [fTy]) "dApp"+      gId  <- freshId gTy "g"+      xId  <- freshId (mkAppTy wrappedTy aTy) "x"+      cb   <- freshId innerA "cb"+      let pureE ty e        = mkApps (Var pureSel) [Type fTy, Var dApp, Type ty, e]+          apE tyA tyB ac fe = mkApps (Var apSel)   [Type fTy, Var dApp, Type tyA, Type tyB, ac, fe]+          subB t = substTyWith [aTv] [bTy] t                  -- t[a := b]+          -- GHC's @ft_*@ traversal of a field: a constant ⇒ @pure x@; the+          -- parameter ⇒ @g x@; a tuple ⇒ @pure (,..) \<*\> t1 \<*\> …@ (every+          -- component); a covariant @H larg@ ⇒ @traverse \@H@ (nested @[[a]]@ ⇒+          -- @traverse (traverse g)@); a function field rejected.  Result is+          -- @f (subB ft)@.+          traverseField ft xe+            | not (aTv `elemVarSet` tyCoVarsOfType ft) = pure (Just (pureE ft xe, []))+            | ft `eqType` aTy                          = pure (Just (App (Var gId) xe, []))+            | Just _ <- splitFunTy_maybe ft            = pure Nothing+            | Just (tc, args) <- splitTyConApp_maybe ft+            , isTupleTyCon tc, length args >= 2 = do+                xs <- mapM (`freshId` "u") args+                rs <- zipWithM traverseField args (map Var xs)+                case sequence rs of+                  Nothing    -> pure Nothing+                  Just travs -> do+                    let subArgs = map subB args+                        dc      = tupleDataCon Boxed (length args)+                        subTup  = subB ft+                        rs'     = scanr mkVisFunTyMany subTup subArgs+                    ys <- mapM (`freshId` "v") subArgs+                    cb <- freshId ft "cb"+                    let mkTup = mkLams ys (mkCoreConApps dc (map Type subArgs ++ map Var ys))+                        built = foldl (\ac (k, te, sa) -> apE sa (rs' !! (k + 1)) ac te)+                                      (pureE (head rs') mkTup)+                                      (zip3 [0 :: Int ..] (map fst travs) subArgs)+                    pure (Just ( Case xe cb (fOf subTup) [Alt (DataAlt dc) xs built]+                               , concatMap snd travs ))+            | Just (h, larg) <- splitAppTy_maybe ft+            , not (aTv `elemVarSet` tyCoVarsOfType h) =+                if larg `eqType` aTy+                  then do ev <- newWanted loc (mkClassPred travCls [h])+                          pure (Just ( mkApps (Var traverseSel)+                                 [Type h, ctEvExpr ev, Type fTy, Type aTy, Type bTy, Var dApp, Var gId, xe]+                                 , [mkNonCanonical ev] ))+                  else do y     <- freshId larg "y"+                          inner <- traverseField larg (Var y)+                          case inner of+                            Nothing     -> pure Nothing+                            Just (e, w) -> do+                              ev <- newWanted loc (mkClassPred travCls [h])+                              pure (Just ( mkApps (Var traverseSel)+                                     [Type h, ctEvExpr ev, Type fTy, Type larg, Type (subB larg)+                                     , Var dApp, Lam y e, xe]+                                     , mkNonCanonical ev : w ))+            | otherwise = pure Nothing+          -- one field's effect @f rvFt@; Override1 reshapes the (one-level)+          -- functor @h a -> m a@, otherwise the full structural walk.+          fieldOf i x ftA rvFt = case override1Mod gen mMods i of+            Just m -> do        -- Override1: traverse through @m@, re-wrap @m b -> h b@+              ev <- newWanted loc (mkClassPred travCls [m])+              let coS  = mkStockCo (PluginProv "stock") Representational ftA (mkAppTy m aTy)+                  coRb = mkStockCo (PluginProv "stock") Representational (mkAppTy m bTy) rvFt+                  trav = mkApps (Var traverseSel)+                           [Type m, ctEvExpr ev, Type fTy, Type aTy, Type bTy+                           , Var dApp, Var gId, Cast (Var x) coS]          -- :: f (m b)+              mb <- freshId (mkAppTy m bTy) "mb"+              let coerceFn = Lam mb (Cast (Var mb) coRb)                   -- m b -> h b+              pure (Just ( apE (mkAppTy m bTy) rvFt+                             (pureE (mkVisFunTyMany (mkAppTy m bTy) rvFt) coerceFn) trav+                         , [mkNonCanonical ev] ))+            Nothing -> traverseField ftA (Var x)+      malts <- forM dcons \dc -> do+        let fts   = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aTy]))+            rvFts = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [bTy]))+        xs   <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] fts+        mfes <- sequence (zipWith4 fieldOf [0 :: Int ..] xs fts rvFts)+        case sequence mfes of+          Nothing  -> pure Nothing+          Just fes -> do+            let (fieldExprs, wss) = unzip fes+            ys <- zipWithM (\n ft -> freshId ft ("y" ++ show n)) [0 :: Int ..] rvFts+            let mkCon = mkLams ys (Cast (mkCoreConApps dc (map Type (fixed ++ [bTy]) ++ map Var ys))+                                        (mkSymCo (coAt bTy)))                -- rvFt.. -> Stock1 F b+                rs    = scanr mkVisFunTyMany stbTy rvFts                     -- R_0 … R_n(=Stock1 F b)+                body  = foldl (\ac (k, fe, rvFt) -> apE rvFt (rs !! (k + 1)) ac fe)+                              (pureE (head rs) mkCon)+                              (zip3 [0 :: Int ..] fieldExprs rvFts)+            pure (Just (Alt (DataAlt dc) xs body, concat wss))+      case sequence malts of+        Nothing     -> pure Nothing+        Just altWss -> do+          let (alts, wss) = unzip altWss+              traverseImpl = mkLams [fTv, aTv, bTv, dApp, gId, xId]+                (destructInner fTc (fixed ++ [aTy]) (Cast (Var xId) (coAt aTy)) cb (fOf stbTy) alts)+          mFunc <- synthFunctor  gen funcCls loc wrappedTy f+          mFold <- synthFoldable gen foldCls loc wrappedTy f+          case (mFunc, mFold) of+            (Just (fEv, fWs), Just (foEv, foWs)) -> do+              dict <- recDictWith travCls wrappedTy [unwrapEv fEv, unwrapEv foEv] [(0, traverseImpl)]+              pure (Just (EvExpr dict, fWs ++ foWs ++ concat wss))+            _ -> pure Nothing+    _ -> pure Nothing

@@ -0,0 +1,34 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE StandaloneKindSignatures #-}++-- | Newtype wrappers that drive the Stock plugin.  Writing+-- @deriving C via Stock T@ (or @via Stock1 F@ for a class over a type+-- constructor) asks the plugin to synthesize the instance from @T@'s+-- structure — no @Generic@, no hand-written instances.+module Stock.Type+  ( Stock(Stock, unStock)+  , Stock1(Stock1, unStock1)+  , Stock2(Stock2, unStock2)+  ) where++import Data.Kind (Type)++-- | Wrap a type @a@ so that @deriving C via Stock a@ synthesizes @C a@.+type    Stock :: Type -> Type+newtype Stock a = Stock { unStock :: a }++-- | Wrap a type constructor @f@ so that @deriving C via Stock1 f@ synthesizes+-- a @C f@ instance (for classes over type constructors, e.g. @Functor@).+-- Poly-kinded in the index (@f :: k -> Type@) so it works for classes over+-- non-@Type@ indices too (e.g. @TestEquality@) — maximally polymorphic.+type    Stock1 :: forall k. (k -> Type) -> (k -> Type)+newtype Stock1 f a = Stock1 { unStock1 :: f a }++-- | Wrap a two-parameter type constructor @p@ so that @deriving C via Stock2 p@+-- synthesizes a @C p@ instance (for classes over two-parameter type+-- constructors, e.g. @Bifunctor@, @Bifoldable@, @Eq2@, @Ord2@, @Show2@,+-- @Read2@, @Category@).+type    Stock2 :: forall k j. (k -> j -> Type) -> (k -> j -> Type)+newtype Stock2 bi a b = Stock2 { unStock2 :: bi a b }

@@ -0,0 +1,196 @@+cabal-version:       3.0+name:                stock+version:             0.1.0.0+synopsis:            Stock-style deriving via coercion, with no Generic+description:+  A GHC type-checker plugin that derives class instances for @Stock T@+  and higher-kinded variants at /compile time/, straight from the+  structure of /T/ without a @Generic@ representation or runtime cost.+  .+  Supported classes:+  .+  * @Stock@:  Eq, Ord, Show, Read, Semigroup, Monoid, Enum, Bounded, Ix, Generic+  * @Stock1@: Functor, Foldable, Traversable, Contravariant, Applicative, Eq1, Ord1, Show1, Read1, Generic1, TestEquality, TestCoercion+  * @Stock2@: Bifunctor, Bifoldable, Bitraversable, Eq2, Ord2, Show2, Read2, Category+  .+  Every claim below is machine-checked with @inspection-testing@ (it+  compares optimised Core, not behaviour):+  .+  * For @Eq@, @Ord@, @Enum@, @Functor@, @Bounded@ and @Foldable@ the+    emitted Core is /byte-identical/ to GHC's own stock deriving.+  * @Traversable@ and @Bitraversable@ — which GHC cannot stock-derive+    at all — produce a @traverse@\/@bitraverse@ /byte-identical/ to the+    natural hand-written definition.+  * Every remaining class is proven to erase the @Stock@ wrapper and+    its coercions /completely/, so the instance is exactly as fast as a+    hand-written one and behaves identically to stock deriving wherever+    GHC has it.+  .+  In short: where GHC derives the class, the result is the same Core+  GHC emits; where it does not, the result is the Core you would have+  written by hand.+  .+  @Traversable@\/@Bitraversable@ are synthesised as genuine instances+  but cannot be reached by a bare @deriving via@ (the coercion is+  blocked by the abstract applicative's nominal role; see @"Stock"@).+  .+  Companion packages add more classes through @DeriveStock@ instances+  (see @"Stock.Derive"@), discovered automatically without an extra+  @-fplugin@ flag :+  .+  * @stock-deepseq@:     NFData, NFData1, NFData2+  * @stock-hashable@:    Hashable, Hashable1, Hashable2+  * @stock-aeson@:       ToJSON, ToJSON1, ToJSON2; FromJSON, FromJSON1, FromJSON2+  * @stock-quickcheck@:  Arbitrary, Arbitrary1, Arbitrary2; CoArbitrary+  * @stock-profunctors@: Profunctor+  .+  Ordinary @DerivingVia@ modifiers compose with @Stock@:+  @Down (Stock T)@ reverses ordering, enumeration and bounds;+  @Backwards (Stock1 F)@ reverses @Applicative@ effects; @Reverse+  (Stock1 F)@ reverses @Foldable@\/@Traversable@.+  .+  > {-# options_ghc -fplugin Stock #-}+  > {-# language DerivingVia #-}+  > +  > import Stock+  > import Data.Ord (Down(..))+  >+  > -- >>> sort [Bronze, Silver, Gold]+  > -- [Gold,Silver,Bronze]+  > data Place = Bronze | Silver | Gold+  >   deriving (Eq, Show)           via Stock Place+  >   deriving (Ord, Bounded, Enum) via Down (Stock Place)+  .+  Per-field modifiers (@Override@, @"Stock.Override"@, re-exported by+  @"Stock"@) customise individual fields by name, type, or position; @_@+  leaves a field unchanged. A modifier is any newtype with the relevant+  instance.+  . +  Hit points and coins accumulate with addition, poisoning+  contaminates by disjunction (or), @items@, and @weapons@ union with+  addition to product a multiset.+  .+  > import Data.Map.Monoidal (MonoidalMap(..))+  > ..+  > type MultiSet key = MonoidalMap key (Sum Int)+  > +  > data Inventory = Inventory+  >   { hp       :: Int+  >   , coins    :: Int+  >   , poisoned :: Bool+  >   , items    :: Map Item   Int    -- these unfortunately default+  >   , weapons  :: Map Weapon Int    -- to left-biased union+  >   }+  >   deriving (Eq, Ord, Show, Read) via+  >     Stock Inventory+  >   deriving (Semigroup, Monoid) via +  >     Overriding Inventory+  >    '[ hp       via Sum +  >     , coins    via Sum +  >     , poisoned via Any+  >     , items    via MultiSet Item+  >     , weapons  via MultiSet Weapon+  >     ]+  .+  Synthesis runs once per instance (not per use): @deriving Cls via Stock+  T@ produces a single shared @instance Cls T@ that every call reuses.+license:             BSD-3-Clause+license-file:        LICENSE+author:              Baldur Blöndal+maintainer:          baldur.blondal@iohk.io+category:            Type System+build-type:          Simple+tested-with:         GHC >= 9.6 && < 9.15+                   , GHC == 9.6.7+                   , GHC == 9.8.1,  GHC == 9.8.2,  GHC == 9.8.4+                   , GHC == 9.10.1, GHC == 9.10.2, GHC == 9.10.3+                   , GHC == 9.12.1, GHC == 9.12.2, GHC == 9.12.4+                   , GHC == 9.14.1+extra-doc-files:     README.md+                     CHANGELOG.md+extra-source-files:  LICENSE++common warnings+  ghc-options:       -Wall -Wcompat -Wincomplete-record-updates+                     -Wincomplete-uni-patterns -Wredundant-constraints+  default-language:  GHC2021++library+  import:           warnings+  exposed-modules:  Stock+                    Stock.Type+                    Stock.Derive+                    Stock.Override+                    Stock.Surface+                    Stock.Internal+                    Stock.Compat+                    Stock.Bounded+                    Stock.Eq+                    Stock.Ord+                    Stock.Semigroup+                    Stock.Show+                    Stock.Read+                    Stock.Enum+                    Stock.Functor+                    Stock.Applicative+                    Stock.Traversable+                    Stock.TestEquality+                    Stock.Bifunctor+                    Stock.Generic+                    Stock.Classes1+  other-modules:    Stock.Trans+  build-depends:    base >=4.18 && <5,+                    ghc >=9.6 && <9.16+  hs-source-dirs:   src plugin++test-suite examples+  import:           warnings+  type:             exitcode-stdio-1.0+  main-is:          Main.hs+  other-modules:    QualOverride+  build-depends:    base >=4.18 && <5,+                    transformers < 0.7,+                    stock+  ghc-options:      -fplugin=Stock+  hs-source-dirs:   examples++test-suite spec+  import:           warnings+  type:             exitcode-stdio-1.0+  main-is:          Spec.hs+  other-modules:    Twin+  build-depends:    base >=4.18 && <5,+                    stock+  ghc-options:      -fplugin=Stock+  hs-source-dirs:   test++benchmark bench+  import:           warnings+  type:             exitcode-stdio-1.0+  main-is:          Bench.hs+  build-depends:    base >=4.18 && <5,+                    stock+  ghc-options:      -O2 -rtsopts "-with-rtsopts=-K512m" -fplugin=Stock+  hs-source-dirs:   bench++benchmark configs+  import:           warnings+  type:             exitcode-stdio-1.0+  main-is:          Configs.hs+  build-depends:    base, stock+  ghc-options:      -O2 -fplugin=Stock+  hs-source-dirs:   bench++test-suite inspection+  type:             exitcode-stdio-1.0+  main-is:          Inspection.hs+  build-depends:    base, stock, inspection-testing+  ghc-options:      -fplugin=Stock+  hs-source-dirs:   inspection+  default-language: GHC2021+  if impl(ghc >= 9.14)+    buildable: False++source-repository head+  type:     git+  location: https://github.com/Icelandjack/stock.git

@@ -0,0 +1,1076 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+-- numeric literals default to Integer in a couple of checks, and the twin+-- types intentionally have unused selectors — both fine in a test module.+{-# OPTIONS_GHC -fplugin Stock -Wno-type-defaults -Wno-unused-top-binds #-}++-- | Test-suite for the Virtual-Via plugin.  Each synthesized instance is+-- checked against the corresponding @deriving@-derived "twin" type (so the+-- oracle is GHC's own stock deriving), plus round-trip properties.+module Main (main) where++import qualified Stock+import qualified Twin+import Stock.Override (Override(..), Overriding, Override1(..), Overriding1, Override2(..), Overriding2, type (:=), type (-->), At, Keep)+import Control.Applicative (ZipList(..))+import Data.Ord (Down(..))+import qualified Data.Monoid as Mon (Sum(..), Product(..))+import Data.Ix (Ix, range, index, inRange, rangeSize)+import Data.Functor.Contravariant (Contravariant(..), Predicate(..))+import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..), showsPrec1, Read1(..), readsPrec1, Eq2(..), Ord2(..), Show2(..), Read2(..))+import Text.Read (readPrec, readListPrec, readPrec_to_S)+import Data.Functor.Identity (Identity(..))+import Data.Bifunctor (Bifunctor(..))+import Data.Bifoldable (Bifoldable(..))+import Data.Bitraversable (Bitraversable(..))+import qualified Data.Foldable+import GHC.Generics+  ( Generic, Generically(..), Generically1(..), Rep, from, to, M1(..)+  , datatypeName, conName, conIsRecord, conFixity, selDecidedStrictness+  , Fixity(..), Associativity(..), DecidedStrictness(..), D1, Meta(..)+  , Generic1, from1, to1 )+import qualified GHC.Generics as G+import Data.Kind (Type)+import Data.Coerce (coerce)+import Control.Category (Category)+import qualified Control.Category as Cat+import Control.Arrow (Kleisli(..))+import Data.Type.Equality ((:~:)(Refl), TestEquality(..), castWith)+import Data.Type.Coercion (TestCoercion(..), coerceWith)+import System.Exit (exitFailure)+import Data.List (isInfixOf)+import qualified Data.List+import Control.Monad (unless)+import Control.Exception (try, evaluate, SomeException)++-- ----- types under test (instances synthesized by the plugin) -------------++data Color = Red | Green | Blue+  deriving (Eq, Ord, Show, Read, Enum, Bounded, Ix) via Stock.Stock Color++-- Bounded for a single-constructor product: each field takes its own bound.+data BB = BB Bool Ordering+  deriving (Eq, Show, Bounded) via Stock.Stock BB++-- A "finite singleton" GADT: TestEquality/TestCoercion via Stock1.+data TY a where+  TInt  :: TY Int+  TBool :: TY Bool+  TChar :: TY Char+deriving via Stock.Stock1 TY instance TestEquality TY+deriving via Stock.Stock1 TY instance TestCoercion TY++-- Two constructors share an index (both @TZ_ :: TZ Int@): testEquality compares+-- the type index, not the tag, so TZa\/TZb are mutually "equal".+data TZ a where+  TZa :: TZ Int+  TZb :: TZ Int+  TZc :: TZ Bool+deriving via Stock.Stock1 TZ instance TestEquality TZ++data Sum = A | B Int | C Int Bool | Rec { rf :: Int, rg :: Bool }+  deriving (Eq, Ord, Show, Read) via Stock.Stock Sum+  deriving Generic               via Stock.Stock Sum++data Pair a = Pair a a+  deriving (Eq, Ord, Show, Read) via Stock.Stock (Pair a)++-- infix constructors with distinct fixities+infixr 5 :+:+infixl 6 :*:+data Expr = Lit Int | Expr :+: Expr | Expr :*: Expr+  deriving (Eq, Show, Read) via Stock.Stock Expr++infixr 5 :+.+infixl 6 :*.+data Expr' = Lit' Int | Expr' :+. Expr' | Expr' :*. Expr'+  deriving (Eq, Show)++data Prod = Prod [Int] [Int]+  deriving (Eq, Show)              via Stock.Stock Prod+  deriving Generic                 via Stock.Stock Prod+  deriving (Semigroup, Monoid)     via Generically Prod++-- direct pointwise Semigroup/Monoid (a "faster Generically"), same result+data Sg = Sg [Int] [Int]+  deriving (Eq, Show)+  deriving (Semigroup, Monoid)     via Stock.Stock Sg++-- per-field Override: combine cx additively (Sum) and cy multiplicatively+-- (Product) — both unsaturated @Type -> Type@ modifiers, broadcast to the+-- field's own type.  A behaviour you cannot get from plain @Stock Coord@+-- without rewriting the datatype's field types.+data Coord = Coord { cx :: Int, cy :: Int }+  deriving (Eq, Show)+  deriving Semigroup+    -- lowercase surface sugar (lowered to "cx" := Sum, "cy" := Product by the+    -- same -fplugin Stock at parse time):+    via Stock.Stock (Override Coord [ cx via Mon.Sum, cy via Mon.Product ])++-- type-keyed Override: every Int field via Sum (no record labels needed)+data TK = TK Int Int+  deriving (Eq, Show)+  deriving Semigroup via Stock.Stock (Override TK '[ Int via Mon.Sum ])++-- position-keyed Override: field 0 via Sum, field 1 via Product+data PK = PK Int Int+  deriving (Eq, Show)+  deriving Semigroup+    via Stock.Stock (Override PK [ PK at 0 via Mon.Sum, PK at 1 via Mon.Product ])++-- positional [[..]] Override: one inner list per constructor, one element per+-- field.  @_@ (lowered to 'Keep' by the surface pass) leaves a field alone, so+-- this overrides only the first two fields and keeps the @[Int]@ as-is.+-- Outer list is ticked (single-element ⇒ would otherwise parse as the list type).+data Pos = Pos Int Int [Int]+  deriving (Eq, Show)+  deriving Semigroup+    via Stock.Stock (Override Pos '[ [Mon.Sum, Mon.Product, _] ])++-- the canonical example: @[[Sum Int, _, _]]@ changes only the first field of the+-- first constructor (a /saturated/ @Sum Int :: Type@ modifier, pinned to the+-- field's @Int@); the rest are kept.  'Keep' is poly-kinded, so it sits in a+-- @[Type]@ list here just as it sat in the @[Type -> Type]@ list above.+data PosS = PosS Int [Int] [Int]+  deriving (Eq, Show)+  deriving Semigroup+    via Stock.Stock (Override PosS '[ [Mon.Sum Int, _, _] ])++-- multi-constructor --> paths, observed through the (SDK-native) Eq: a field+-- overridden to 'Mod5' compares modulo 5.  @'MA --> 0 --> Mod5@ targets only+-- MA's first field; @'MB --> Mod5@ every field of MB.  Mod5 is a saturated+-- (pinned) modifier — Coercible Int Mod5.+newtype Mod5 = Mod5 Int+instance Eq Mod5 where Mod5 a == Mod5 b = a `mod` 5 == b `mod` 5+data Multi = MA Int Int | MB Int+  deriving Show+  deriving Eq+    via Stock.Stock (Override Multi '[ 'MA --> 0 --> Mod5, 'MB --> Mod5 ])++-- Ord now respects Override too (was a viaSynth holdout): field0 via Down+-- reverses its comparison, field1 stays normal.+data OrdOv = OrdOv Int Int+  deriving (Eq, Show)+  deriving Ord via Stock.Stock (Override OrdOv '[ [Down, _] ])++-- Show + Read both respect Override: showing field0 as a 'Sum' and reading it+-- back (coercing to Int) round-trips — proving both directions honour it.+data SR = SR Int Int+  deriving stock Eq+  deriving (Show, Read) via Stock.Stock (Override SR '[ [Mon.Sum, _] ])++-- The payoff: Generic respects Override, so @Generically (Override A cfg)@+-- derives /any/ Generically class over the overridden fields.  Here Semigroup+-- combines field0 additively (Sum) and field1 multiplicatively (Product) —+-- driven entirely through the Generic Rep, no Stock-Semigroup deriver.+data CoordG = CoordG Int Int+  deriving (Eq, Show)+  deriving Semigroup+    via Generically (Overriding CoordG '[ [Mon.Sum, Mon.Product] ])++-- ===== Override across the remaining classes that honour it =====++-- Monoid: mempty/mappend through Sum (additive) + Product (multiplicative); the+-- identities are 0 and 1, not Int's (which has no Monoid).+data MonOv = MonOv Int Int deriving (Eq, Show)+  deriving (Semigroup, Monoid)+    via Stock.Stock (Override MonOv '[ [Mon.Sum, Mon.Product] ])++-- Bounded over a product: field0's bounds come from Hi (100..200), not Int's.+newtype Hi = Hi Int deriving (Eq, Show)+instance Bounded Hi where { minBound = Hi 100 ; maxBound = Hi 200 }+data BdOv = BdOv Int Bool deriving (Eq, Show)+  deriving Bounded via Stock.Stock (Override BdOv '[ [Hi, _] ])++-- Enum / Ix are enum-only (no fields): an all-blank config is the identity,+-- so Override neither breaks nor changes them.+data EnOv = EnA | EnB | EnC deriving (Eq, Show)+  deriving (Enum, Ix, Ord) via Stock.Stock (Override EnOv '[ '[], '[], '[] ])++-- top-level empty config @'[]@ on a type WITH fields is the identity: exactly+-- like plain @Stock@ (regression: @'[]@ was mis-read as a 0-constructor+-- positional config and rejected).+data EmptyOv = EmptyOv Int Bool+  deriving (Eq, Show) via Stock.Stock (Override EmptyOv '[])++-- Functor via Override1 with an observable, law-breaking modifier: @Blah@ counts+-- each @fmap@ in its @Int@ slot.  The field @(Int, a)@ is reshaped to @Blah@, so+-- mapping bumps the counter — visibly proving the override is honoured.+newtype Blah a = Blah (Int, a)+instance Functor Blah where fmap f (Blah (n, a)) = Blah (1 + n, f a)+data WithCount a = WithCount (Int, a) deriving (Eq, Show)+  deriving Functor via Overriding1 WithCount '[ '[Blah] ]++-- Contravariant via Override1: the Predicate field reshaped to Neg, whose+-- contramap negates the result (the one observable tweak that stays well-typed).+newtype Neg a = Neg (Predicate a)+instance Contravariant Neg where+  contramap f (Neg (Predicate p)) = Neg (Predicate (not . p . f))+newtype CV a = CV (Predicate a)+  deriving Contravariant via Overriding1 CV '[ '[Neg] ]+runCV :: CV a -> a -> Bool+runCV (CV (Predicate p)) = p++-- Bifunctor via Override2: each list field reshaped to RevL, whose fmap reverses,+-- so bimap reverses both lists.+newtype RevL a = RevL [a]+instance Functor RevL where fmap f (RevL xs) = RevL (reverse (map f xs))+data B2 a b = B2 [a] [b] deriving (Eq, Show)+  deriving Functor   via Stock.Stock1 (B2 a)+  deriving Bifunctor via Overriding2 B2 '[ '[RevL, RevL] ]++-- Override1 / Override2 with the SAME field-keyed surface as value Override,+-- only at a different modifier kind (a functor here) — and in the bare-lowercase+-- plugin notation (@nkXs := m@ / @fld via m@), lowered by the source plugin.+data NK a = NK { nkXs :: [a] } deriving (Eq, Show)+  deriving Functor via Overriding1 NK '[ nkXs := RevL ]+data NK2 a b = NK2 { nk2a :: [a], nk2b :: [b] } deriving (Eq, Show)+  deriving Functor   via Stock.Stock1 (NK2 a)+  deriving Bifunctor via Overriding2 NK2 '[ nk2a via RevL, nk2b via RevL ]++-- A blind/reversing list modifier (coercible to [a]) for the lifted comparison+-- + folding classes: Eq1/Ord1 blind (all equal), Show1 fixed, Foldable reversed.+newtype BL a = BL [a]+instance Eq1   BL where liftEq _ _ _          = True+instance Ord1  BL where liftCompare _ _ _     = EQ+instance Show1 BL where liftShowsPrec _ _ _ _ = showString "BL"+instance Foldable BL where foldMap f (BL xs)  = foldMap f (reverse xs)+-- base instances (the quantified superclasses of BL's lifted instances), blind to match+instance Eq   (BL a) where _ == _       = True+instance Ord  (BL a) where compare _ _  = EQ+instance Show (BL a) where showsPrec _ _ = showString "BL"++-- Eq1 / Ord1 / Show1 via Override1 (the [a] field through BL).  The base+-- Eq/Ord/Show satisfy the lifted classes' quantified superclasses.+data Lc a = Lc [a] deriving (Eq, Ord, Show)+  deriving Eq1   via Overriding1 Lc '[ '[BL] ]+  deriving Ord1  via Overriding1 Lc '[ '[BL] ]+  deriving Show1 via Overriding1 Lc '[ '[BL] ]++-- Eq2 / Ord2 / Show2 / Bifoldable via Override2 (both fields through BL).  The+-- one-parameter lifted instances (superclasses of the two-parameter ones) are+-- plain Stock1.+data Bc a b = Bc [a] [b] deriving (Eq, Ord, Show)+  deriving (Eq1, Ord1, Show1) via Stock.Stock1 (Bc a)+  deriving Eq2        via Overriding2 Bc '[ '[BL, BL] ]+  deriving Ord2       via Overriding2 Bc '[ '[BL, BL] ]+  deriving Show2      via Overriding2 Bc '[ '[BL, BL] ]+  deriving Bifoldable via Overriding2 Bc '[ '[BL, BL] ]++-- Generic1 via Override1 → Applicative via Generically1: the [a] field reshaped+-- to ZipList, so the /generically/-derived Applicative ZIPS instead of the+-- cartesian []-product.  (Proves Generic1 honours Override1 at the Rep1 level.)+data Zg a = Zg [a]+  deriving (Eq, Show)+  deriving Generic1 via Overriding1 Zg '[ '[ZipList] ]+  deriving (Functor, Applicative) via Generically1 Zg+runZg :: Zg a -> [a]+runZg (Zg xs) = xs++-- `_` (Keep) sugar in an Override1 positional config: an identity reshape (the+-- field is left as []).  Confirms the source plugin lowers `_` for the+-- Overriding1 wrapper too, not just value Override.+data Kp a = Kp [a] deriving (Eq, Show)+  deriving Functor via Overriding1 Kp '[ '[_] ]++-- A reversing list modifier (coercible to [a]) whose Read1 reads a list then+-- /reverses/ it — observably different from []'s, so a parsed value reflects the+-- override.  Read1's quantified superclass needs a matching base Read (RL a).+newtype RL a = RL [a]+instance Read1 RL where+  liftReadsPrec rp rl d s = [ (RL (reverse ys), s') | (ys, s') <- liftReadsPrec rp rl d s ]+instance Read a => Read (RL a) where+  readsPrec d s = [ (RL (reverse ys), s') | (ys, s') <- readsPrec d s ]++-- Read1 via Override1: reading @"Lr [1,2,3]"@ parses the field through RL, so the+-- list comes back reversed — proof the modifier is honoured (plain [] would give+-- @Lr [1,2,3]@).+data Lr a = Lr [a] deriving (Eq, Show, Read)+  deriving Read1 via Overriding1 Lr '[ '[RL] ]++-- Read2 via Override2: both list fields parsed through RL ⇒ both come back+-- reversed.  Read2's superclass needs a plain Read1 (Br a).+data Br a b = Br [a] [b] deriving (Eq, Show, Read)+  deriving Read1 via Stock.Stock1 (Br a)+  deriving Read2 via Overriding2 Br '[ '[RL, RL] ]++++-- For the representational-fidelity check: 'Gen' has GHC's *stock* Generic+-- (giving the real @Rep Gen@), while the plugin provides @Generic (Stock Gen)@.+-- The two Reps differ only by newtype @M1@/@K1@ layers, so they are 'Coercible'.+data Gen = Gen [Int] [Int]+  deriving (Eq, Generic)++-- A SUM type with stock Generic, for the sum version of the cross-Rep round-trip.+data GenS = GA | GB Int | GC Int Bool+  deriving (Eq, Generic)++-- For metadata (M1) checks: a single-constructor record.+data MetaR = MetaR { mfield :: Int }+  deriving Generic via Stock.Stock MetaR++-- Cross-validation: stock @Generic Gen@ and the plugin's @Generic (Stock Gen)@+-- must drive the SAME @Generically@ algorithm to the SAME result.  We compute+-- @(<>)@ / @mempty@ both ways on the same value (bridging with 'coerce') and+-- compare — a behavioural proof that the synthesized Rep equals stock's.+viaGen, viaStockGen :: Gen -> Gen -> Gen+viaGen      a b = coerce ((coerce a :: Generically Gen)               <> coerce b)+viaStockGen a b = coerce ((coerce a :: Generically (Stock.Stock Gen)) <> coerce b)+memptyGen, memptyStockGen :: Gen+memptyGen      = coerce (mempty :: Generically Gen)+memptyStockGen = coerce (mempty :: Generically (Stock.Stock Gen))++-- Functor via Stock1 (parameter field, constant field, functor field)+data Trio a = Trio Int a [a]+  deriving (Eq, Ord, Show, Read) via Stock.Stock (Trio a)+  deriving Functor    via Stock.Stock1 Trio+  deriving Foldable   via Stock.Stock1 Trio+  -- Eq1/Ord1: Int field (own Eq/Ord), the parameter (supplied fn), [a] (lifted)+  deriving (Eq1, Ord1) via Stock.Stock1 Trio+  deriving Show1       via Stock.Stock1 Trio+  deriving Read1       via Stock.Stock1 Trio+data Trio' a = Trio' Int a [a] deriving (Eq, Show, Functor, Foldable)++-- Applicative via Stock1 handles a constant field Const-style (needs Monoid),+-- exactly as Generically1: pure fills it with mempty, <*> combines it with (<>).+data Ap a = Ap [Int] a+  deriving (Eq, Show)+  deriving (Functor, Applicative) via Stock.Stock1 Ap++-- Override1: the [a] field reshaped to ZipList, so Applicative ZIPS (instead of+-- the cartesian product []), and Functor is unchanged.+data Zl a = Zl [a]+  deriving (Eq, Show)+  deriving Functor     via Overriding1 Zl '[ '[ZipList] ]+  deriving Applicative via Overriding1 Zl '[ '[ZipList] ]+  deriving Foldable    via Overriding1 Zl '[ '[ZipList] ]++-- Traversable: the instance is SYNTHESIZED at @Stock1 _@ (DerivingVia can't+-- coerce it onto the type — abstract-applicative nominal role), and put on the+-- type with the one-liner.  Trav is recursive (param + recursive-functor + list+-- fields); Trav' is GHC's own stock-derived oracle.+data Trav a = TLeaf | TNode (Trav a) a [a]+  deriving (Eq, Show)+  deriving (Functor, Foldable) via Stock.Stock1 Trav+instance Traversable Trav where+  traverse g = fmap Stock.unStock1 . traverse g . Stock.Stock1+data Trav' a = TLeaf' | TNode' (Trav' a) a [a]+  deriving (Eq, Show, Functor, Foldable, Traversable)++-- Nested + tuple fields: Functor/Foldable/Traversable must match GHC's full+-- structural walk (nested [[a]], Maybe [a], tuple (a,a)). NestG is GHC's oracle.+data Nest a = Nest [[a]] (Maybe [a]) (a, a) a+  deriving (Eq, Show)+  deriving (Functor, Foldable) via Stock.Stock1 Nest+instance Traversable Nest where+  traverse g = fmap Stock.unStock1 . traverse g . Stock.Stock1+data NestG a = NestG [[a]] (Maybe [a]) (a, a) a+  deriving (Eq, Show, Functor, Foldable, Traversable)+nestVal :: ([[Int]], Maybe [Int], (Int, Int), Int)+nestVal = ([[1,2],[3]], Just [4,5], (6,7), 8)+cNe :: Nest Int -> ([[Int]], Maybe [Int], (Int, Int), Int)+cNe (Nest a b c d) = (a, b, c, d)+cNeG :: NestG Int -> ([[Int]], Maybe [Int], (Int, Int), Int)+cNeG (NestG a b c d) = (a, b, c, d)++-- Ix on a single-constructor PRODUCT (GHC derives it; we now match): range is+-- the Cartesian product, index mixed-radix. IxPG is GHC's stock twin.+data IxP = IxP Int Bool deriving (Eq, Ord, Show)+  deriving Ix via Stock.Stock IxP+data IxPG = IxPG Int Bool deriving (Eq, Ord, Show, Ix)+cIxP :: IxP -> (Int, Bool)+cIxP (IxP a b) = (a, b)+cIxPG :: IxPG -> (Int, Bool)+cIxPG (IxPG a b) = (a, b)++-- Generic META parity: infix constructor fixity (#1) and field strictness (#3)+-- must match GHC's derived Rep (phantom type-level meta, vs twins).+infixr 7 :*:.+data MOp  = Int :*:. Int  deriving (Eq, Show) ; deriving via Stock.Stock MOp instance Generic MOp+infixr 7 :*:~+data MOpG = Int :*:~ Int  deriving (Eq, Show, Generic)+data MStr  = MStr  ![Int] Int deriving (Eq, Show) ; deriving via Stock.Stock MStr instance Generic MStr+data MStrG = MStrG ![Int] Int deriving (Eq, Show, Generic)+data MSum = MN | MP Int Bool | MR { mrf :: Int, mrg :: Bool } deriving (Eq, Show)+deriving via Stock.Stock MSum instance Generic MSum++-- STATIC Rep parity: normalize only the module/package strings in the outer D1+-- (those legitimately differ Main vs Twin), then assert the ENTIRE Rep type —+-- datatype name + isNewtype, constructor fixity (#1), selector strictness (#3),+-- record/field meta, and the balanced sum/product shape — is IDENTICAL to GHC's+-- derived Rep.  Any divergence is a compile-time type error.+type family DummyMP (r :: Type -> Type) :: Type -> Type where+  DummyMP (D1 ('MetaData n _ _ nt) x) = D1 ('MetaData n "M" "P" nt) x+repParityMOp  :: DummyMP (Rep MOp)  () :~: DummyMP (Rep Twin.MOp)  ()+repParityMOp  = Refl+repParityMStr :: DummyMP (Rep MStr) () :~: DummyMP (Rep Twin.MStr) ()+repParityMStr = Refl+repParityMSum :: DummyMP (Rep MSum) () :~: DummyMP (Rep Twin.MSum) ()+repParityMSum = Refl++-- Ord relational ops (#6): a small (<=3-con) product gets direct <,<=,>,>= ;+-- they must agree with GHC's derived twin for every pair.+data OrdT  = OA  | OB  Int Bool+  deriving (Eq, Show) deriving Ord via Stock.Stock OrdT+data OrdTG = OAg | OBg Int Bool deriving (Eq, Show, Ord)+cOrdT :: OrdT -> OrdTG+cOrdT OA = OAg ; cOrdT (OB i b) = OBg i b+ordVals :: [OrdT]+ordVals = [OA, OB 1 True, OB 1 False, OB 2 False, OB 2 True]++data KTr = KLeaf | KNode KTr Int [Int] deriving (Eq, Show)+cTr :: Trav Int -> KTr+cTr TLeaf = KLeaf ; cTr (TNode l x xs) = KNode (cTr l) x xs+cTr' :: Trav' Int -> KTr+cTr' TLeaf' = KLeaf ; cTr' (TNode' l x xs) = KNode (cTr' l) x xs++-- Override1 + Traversable: the [a] field traverses through ZipList's Traversable.+instance Traversable Zl where+  traverse g = fmap Stock.unStock1 . traverse g . Stock.Stock1++-- Bitraversable: synthesized at @Stock2 _@ + the one-liner.  GHC has no+-- stock @deriving Bitraversable@, so we check the law @bitraverse (Just . f)+-- (Just . g) = Just . bimap f g@ (and identity / short-circuit).+data BT a b = BTNil | BTBoth a b | BTList a [b] Int+  deriving (Eq, Show)+  deriving (Functor, Foldable)     via Stock.Stock1 (BT a)+  deriving (Bifunctor, Bifoldable) via Stock.Stock2 BT+instance Bitraversable BT where+  bitraverse f g = fmap Stock.unStock2 . bitraverse f g . Stock.Stock2++runZl :: Zl a -> [a]+runZl (Zl xs) = xs++-- @f@ is abstract, so @Eq (f a)@ / @Ord (f a)@ / @Show (f a)@ can only come+-- from the quantified superclass of @Eq1 f@ / @Ord1 f@ / @Show1 f@.+eqViaEq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool+eqViaEq1 = (==)+cmpViaOrd1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering+cmpViaOrd1 = compare+showViaShow1 :: (Show1 f, Show a) => f a -> String+showViaShow1 x = show x++-- a parameterised record, to exercise Show1's record path (K {l = v, …})+data Recd a = Recd { rx :: a, ry :: [a] }+  deriving (Eq, Show, Read) via Stock.Stock (Recd a)+  deriving Show1  via Stock.Stock1 Recd+  deriving Read1  via Stock.Stock1 Recd++-- @f@ abstract ⇒ Read (f a) can only come from the quantified Read1 superclass+readViaRead1 :: (Read1 f, Read a) => String -> f a+readViaRead1 = read++-- Generic1 via Stock1: Par1 (@a@), Rec1 (@[a]@), Rec0 (@Int@), and @:.:@+-- composition (@[[a]]@ = @[] :.: Rec1 []@).+data G1 a = G1 Int a [a] [[a]] | G1' a+  deriving (Eq, Show)+  deriving Generic1 via Stock.Stock1 G1++-- Contravariant via Stock1: the parameter only in negative positions.  GHC has+-- no stock 'deriving Contravariant', so we check against the laws directly.+-- 'Sel' mixes a function field (negative), a constant, and a 'Pred' subfield+-- (itself contravariant) — and 'Pred' is a newtype (unwrapped by coercion).+newtype Pred a = Pred (a -> Bool)+  deriving Contravariant via Stock.Stock1 Pred+data Sel r a = Sel (a -> r) Int (Pred a)+  deriving Contravariant via Stock.Stock1 (Sel r)++runPred :: Pred a -> a -> Bool+runPred (Pred p) = p++-- Variance fidelity: the parameter under nested function arrows.  @(a -> Int)+-- -> Int@ is double-negative ⇒ covariant ⇒ a 'Functor' (GHC's stock+-- DeriveFunctor accepts it too); the triple-nested one is contravariant.+newtype Cps a = Cps ((a -> Int) -> Int)+  deriving Functor via Stock.Stock1 Cps+runCps :: Cps a -> (a -> Int) -> Int+runCps (Cps g) = g+newtype Cps3 a = Cps3 (((a -> Int) -> Int) -> Int)+  deriving Contravariant via Stock.Stock1 Cps3+forceCps3 :: Cps3 a -> ()+forceCps3 (Cps3 g) = g `seq` ()++-- multi-argument contravariant field (parameter in two negative positions)+newtype Foo2 a = Foo2 (a -> a -> Int)+  deriving Contravariant via Stock.Stock1 Foo2+runFoo2 :: Foo2 a -> a -> a -> Int+runFoo2 (Foo2 h) = h++-- Bifunctor / Bifoldable via Stock2 (mix of a-, b-, [b]- and constant fields).+-- Bifunctor's quantified superclass forall a. Functor (Bi a) needs Functor too.+data Bi a b = Bi a b | OnlyA a | Bs b [b] | Tag Int+  deriving (Eq, Ord, Show, Read)+  deriving (Functor, Eq1, Ord1, Show1, Read1)              via Stock.Stock1 (Bi a)+  deriving (Bifunctor, Bifoldable, Eq2, Ord2, Show2, Read2) via Stock.Stock2 Bi++-- Bifunctor with a NESTED bifunctor field (@Either a b@) and a nested covariant+-- field (@[b]@) — both reached by the n-ary variance engine (the self-app case+-- for @Either a b@; deep functor recursion for @[b]@), which the flat+-- 'classifyBiField' could not map.+data BiE a b = BiE (Either a b) [b]+  deriving (Eq, Show)+  deriving Functor   via Stock.Stock1 (BiE a)+  deriving Bifunctor via Stock.Stock2 BiE++-- Category via Stock2: pointwise id/(.) over a single-constructor product whose+-- fields are each a Category in the two params (here (:~:) and (->)).+data P2 a b = P2 (a :~: b) (a -> b)+  deriving Category via Stock.Stock2 P2++runP2 :: P2 a b -> (a -> b)+runP2 (P2 _ f) = f++-- Category with a CONSTANT field (Sum Int): handled Const-style via Monoid+-- (id = mempty, (.) = (<>)) — no Basic / Override2 needed.+data LC a b = LC (Mon.Sum Int) (a -> b)+  deriving Category via Stock.Stock2 LC++runLC :: LC a b -> (Mon.Sum Int, a -> b)+runLC (LC s f) = (s, f)++-- A trivial Category that ignores its parameters and just accumulates a monoid.+newtype Basic m a b = Basic m+instance Monoid m => Category (Basic m) where+  id :: Basic m a a+  id = Basic mempty+  (.) :: Basic m b c -> Basic m a b -> Basic m a c+  Basic x . Basic y = Basic (x <> y)++-- The payoff: fields that are NOT yet categories (an Int, a String, an+-- @a -> Maybe b@) are reshaped by Override2 into ones — Basic (Sum Int),+-- Basic String, Kleisli Maybe — and Category is then derived pointwise.+data Foo a b = Foo Int String (a -> Maybe b)+  deriving Category+    via Overriding2 Foo '[ '[ Basic (Mon.Sum Int), Basic String, Kleisli Maybe ] ]++runFoo :: Foo a b -> (Int, String, a -> Maybe b)+runFoo (Foo i s f) = (i, s, f)++-- Run a value through stock @from@, 'coerce' between the two (representationally+-- equal) Reps, then bring it back with the plugin's @to@.  Compiles only if+-- @Rep (Stock Gen) ~R Rep Gen@, and round-trips only if @to@ is correct.+repCrossRoundtrip :: Gen -> Gen+repCrossRoundtrip g =+  Stock.unStock (to (coerce (from g :: Rep Gen ()) :: Rep (Stock.Stock Gen) ()))++-- same, for a SUM type: exercises the @:+:@ structure across the two Reps+repCrossRoundtripS :: GenS -> GenS+repCrossRoundtripS g =+  Stock.unStock (to (coerce (from g :: Rep GenS ()) :: Rep (Stock.Stock GenS) ()))++-- parameterised INFIX types: exercise Read1/Read2 ambiguous-parse ORDER, which+-- only the ReadPrec-based synthesis matches (plain prefix/record can't show it).+infixr 5 :+++data InfF a = ILit a | InfF a :++ InfF a+  deriving (Eq, Show)+  deriving Read  via Stock.Stock (InfF a)     -- Read1's quantified superclass needs it+  deriving Read1 via Stock.Stock1 InfF+infixr 5 :**+data InfB a b = IB a b | a :** b+  deriving (Eq, Show)+  deriving Read  via Stock.Stock (InfB a b)+  deriving Read1 via Stock.Stock1 (InfB a)+  deriving Read2 via Stock.Stock2 InfB++-- ----- stock-derived twins (the oracle) -----------------------------------++data Color' = Red' | Green' | Blue'+  deriving (Eq, Ord, Show, Enum, Bounded)+data Sum' = A' | B' Int | C' Int Bool | Rec' { rf' :: Int, rg' :: Bool }+  deriving (Eq, Ord, Show)++-- drop the primes and map the twin operators (@:+.@/@:*.@) back to ours+-- (@:+:@/@:*:@) so a twin's `show` matches ours textually+norm :: String -> String+norm = map (\c -> if c == '.' then ':' else c) . filter (/= '\'')++-- ----- Read parity vs GHC stock (the strong check) -------------------------+--+-- Round-trips only prove @read . show = id@.  These compare the FULL @readsPrec@+-- ReadS result (parsed value + leftover string + list order/length) of the+-- plugin's instance against GHC's own derived @Read@ on a name-identical twin,+-- over valid / whitespaced / parenthesised / negative / garbage / trailing-junk+-- inputs at several precedences.  Equality of the lists == identical behaviour.++-- neutral canonical forms (so the two distinct twin types are comparable)+data KS = KA | KB Int | KC Int Bool | KRec Int Bool deriving (Eq, Show)+data KE = KLit Int | KAdd KE KE | KMul KE KE         deriving (Eq, Ord, Show)+data KBi = KBi Int Bool | KOnlyA Int | KBs Bool [Bool] | KTag Int deriving (Eq, Show)++cS :: Sum -> KS+cS A = KA; cS (B i) = KB i; cS (C i b) = KC i b; cS (Rec i b) = KRec i b+cST :: Twin.Sum -> KS+cST Twin.A = KA; cST (Twin.B i) = KB i; cST (Twin.C i b) = KC i b; cST (Twin.Rec i b) = KRec i b++cE :: Expr -> KE+cE (Lit i)  = KLit i; cE (a :+: b) = KAdd (cE a) (cE b); cE (a :*: b) = KMul (cE a) (cE b)+cET :: Twin.Expr -> KE+cET (Twin.Lit i)    = KLit i+cET (a Twin.:+: b)  = KAdd (cET a) (cET b)+cET (a Twin.:*: b)  = KMul (cET a) (cET b)++cT :: Trio Int -> (Int, Int, [Int])+cT (Trio i a xs) = (i, a, xs)+cTT :: Twin.Trio Int -> (Int, Int, [Int])+cTT (Twin.Trio i a xs) = (i, a, xs)++cR :: Recd Int -> (Int, [Int])+cR (Recd x ys) = (x, ys)+cRT :: Twin.Recd Int -> (Int, [Int])+cRT (Twin.Recd x ys) = (x, ys)++cB :: Bi Int Bool -> KBi+cB (Bi a b) = KBi a b; cB (OnlyA a) = KOnlyA a; cB (Bs b xs) = KBs b xs; cB (Tag i) = KTag i+cBT :: Twin.Bi Int Bool -> KBi+cBT (Twin.Bi a b) = KBi a b; cBT (Twin.OnlyA a) = KOnlyA a+cBT (Twin.Bs b xs) = KBs b xs; cBT (Twin.Tag i) = KTag i++data KInf = KIL Int | KIAdd KInf KInf deriving (Eq, Ord, Show)+cInf :: InfF Int -> KInf+cInf (ILit n) = KIL n; cInf (a :++ b) = KIAdd (cInf a) (cInf b)+cInfT :: Twin.InfF Int -> KInf+cInfT (Twin.ILit n) = KIL n; cInfT (a Twin.:++ b) = KIAdd (cInfT a) (cInfT b)++data KIB = KIB Int Bool | KIBop Int Bool deriving (Eq, Ord, Show)+cIB :: InfB Int Bool -> KIB+cIB (IB a b) = KIB a b; cIB (a :** b) = KIBop a b+cIBT :: Twin.InfB Int Bool -> KIB+cIBT (Twin.IB a b) = KIB a b; cIBT (a Twin.:** b) = KIBop a b++-- mismatches between plugin ReadS and twin ReadS over (precision, input) pairs+parityAt :: Eq k+         => [Int] -> (Int -> ReadS a) -> (Int -> ReadS b)+         -> (a -> k) -> (b -> k) -> [String] -> [(Int, String, [(k, String)], [(k, String)])]+parityAt precs rp rpT ca cb inputs =+  [ (p, s, l, r)+  | p <- precs, s <- inputs+  , let l = map (Data.Bifunctor.first ca) (rp p s)+        r = map (Data.Bifunctor.first cb) (rpT p s)+  , l /= r ]++parityCheck :: (Eq k, Show k)+            => String -> [Int] -> (Int -> ReadS a) -> (Int -> ReadS b)+            -> (a -> k) -> (b -> k) -> [String] -> IO Bool+parityCheck = parityCheckWith id++-- Read1/Read2 entry via the ReadPrec methods with NATIVE readPrec leaves (the+-- fair oracle: the default ReadS entry @liftReadsPrec readsPrec readList@ wraps+-- leaves with @readS_to_Prec@, which perturbs ReadP result order independently+-- of the synthesis).+rp1 :: (Read1 f, Read a) => Int -> ReadS (f a)+rp1 = readPrec_to_S (liftReadPrec readPrec readListPrec)+rp2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b)+rp2 = readPrec_to_S (liftReadPrec2 readPrec readListPrec readPrec readListPrec)++-- For ambiguous INFIX grammars the SET of parses is identical but the list+-- ORDER differs (GHC's 'ReadPrec' search vs our 'ReadS' append) — so we compare+-- as a multiset.  This is the one documented ReadS-vs-ReadPrec residual; @read@+-- and any unique-parse input are unaffected (a single result has no order).+parityCheckU :: (Ord k, Show k)+             => String -> [Int] -> (Int -> ReadS a) -> (Int -> ReadS b)+             -> (a -> k) -> (b -> k) -> [String] -> IO Bool+parityCheckU = parityCheckWith Data.List.sort++parityCheckWith :: (Eq k, Show k)+                => ([(k, String)] -> [(k, String)])+                -> String -> [Int] -> (Int -> ReadS a) -> (Int -> ReadS b)+                -> (a -> k) -> (b -> k) -> [String] -> IO Bool+parityCheckWith norm0 name precs rp rpT ca cb inputs = do+  let ms = [ m | m@(_, _, l, r) <- parityAt precs rp rpT ca cb inputs, norm0 l /= norm0 r ]+  mapM_ (\(p, s, l, r) -> putStrLn (unlines+           [ "   prec=" ++ show p ++ " input=" ++ show s+           , "     via Stock: " ++ show l+           , "     GHC stock: " ++ show r ])) ms+  check name (null ms)++sumInputs, exprInputs, trioInputs, recdInputs, biInputs :: [String]+sumInputs =+  [ "A", "B 5", "B (-5)", "C 1 True", "C 0 False"+  , "Rec {rf = 3, rg = False}", "Rec {rf=3,rg=True}", "Rec { rf = 1 , rg = True }"+  , "  A  ", " B 7 ", "(A)", "((B 9))", "(C 1 True)"+  , "", "B", "B x", "Zzz", "C 1", "A xyz", "B 5 rest"+  , "Rec {rf=1}", "Rec {rf=1, foo=2}", "B 5.0", "-3", "B 0x10" ]+exprInputs =+  [ "Lit 1", "Lit (-2)", "Lit 1 :+: Lit 2", "Lit 1 :+: Lit 2 :+: Lit 3"+  , "Lit 1 :*: Lit 2 :+: Lit 3", "Lit 1 :+: Lit 2 :*: Lit 3"+  , "(Lit 1 :+: Lit 2) :*: Lit 3", "Lit 1 :*: (Lit 2 :+: Lit 3)"+  , " Lit 1 :+: Lit 2 ", "((Lit 1))"+  , "", "Lit", "Lit 1 :+:", ":+: Lit 1", "Lit 1 :+: Lit 2 rest" ]+trioInputs =+  [ "Trio 1 2 [3,4]", "Trio (-1) (-2) [-3,-4]", " Trio 0 0 [] "+  , "(Trio 1 2 [3])", "", "Trio 1 2", "Trio 1 2 [3,4] rest", "Trio 1 2 3" ]+recdInputs =+  [ "Recd {rx = 1, ry = [2,3]}", "Recd {rx=0, ry=[]}", " Recd { rx = 5 , ry = [1] } "+  , "", "Recd {rx=1}", "Recd {rx=1, ry=[2], z=3}" ]+biInputs =+  [ "Bi 1 True", "OnlyA 5", "OnlyA (-5)", "Bs True [False,True]", "Tag 9", "Tag (-9)"+  , " Bi 1 True ", "(OnlyA 5)", "", "Bi 1", "Bs True", "Zzz", "Bi 1 True rest" ]+infInputs, ibInputs :: [String]+infInputs =+  [ "ILit 1", "ILit (-2)", "ILit 1 :++ ILit 2", "ILit 1 :++ ILit 2 :++ ILit 3"+  , "ILit 1 :++ (ILit 2 :++ ILit 3)", "(ILit 1 :++ ILit 2) :++ ILit 3"+  , " ILit 1 :++ ILit 2 ", "", "ILit", "ILit 1 :++", "ILit 1 :++ ILit 2 rest" ]+ibInputs =+  [ "IB 1 True", "1 :** True", "(IB 1 True)", "(1 :** True)", " 1 :** True "+  , "", "IB 1", "1 :**", "IB 1 True rest" ]++-- ----- tiny assertion harness ---------------------------------------------++check :: String -> Bool -> IO Bool+check name ok = do+  putStrLn ((if ok then "ok   " else "FAIL ") ++ name)+  pure ok++-- True if forcing @x@ throws (GHC's derived toEnum/succ/pred error out of range;+-- ours must too, not segfault).+throws :: a -> IO Bool+throws x = do+  r <- try (evaluate (x `seq` ())) :: IO (Either SomeException ())+  pure (either (const True) (const False) r)++main :: IO ()+main = do+  enumOOB  <- throws (toEnum 99 :: Color)+  enumSucc <- throws (succ Blue)+  enumPred <- throws (pred Red)+  rs <- sequence+    [ -- Eq / Ord against twins+      check "Eq enum"       (Red == Red && Red /= Blue)+    , check "Ord enum"      (compare Blue Red == compare Blue' Red')+    , check "Ord fields"    (compare (C 1 True) (C 1 False) == GT && B 1 < C 0 False)+    , check "Ord lexico"    ([minimum xs, maximum xs] == [A, Rec 9 True])+      -- #6: direct <,<=,>,>= for a small type agree with GHC's derived twin+    , check "Ord rel ops"   (and [ (x <  y) == (cOrdT x <  cOrdT y)+                                 && (x <= y) == (cOrdT x <= cOrdT y)+                                 && (x >  y) == (cOrdT x >  cOrdT y)+                                 && (x >= y) == (cOrdT x >= cOrdT y)+                                  | x <- ordVals, y <- ordVals ])+      -- Show against twins (record, prefix, nesting, negatives)+    , check "Show enum"     (show Green == norm (show Green'))+    , check "Show prefix"   (show (C 1 True) == norm (show (C' 1 True)))+    , check "Show neg"      (show (B (-5)) == norm (show (B' (-5))))+    , check "Show record"   (show (Rec 3 True) == norm (show (Rec' 3 True)))+    , check "Show nested"   (show (Just (B 7)) == norm (show (Just (B' 7))))+      -- Read round-trips+    , check "Read enum"     (read "Green" == Green)+    , check "Read rt prefix"(read (show (C 4 False)) == C 4 False)+    , check "Read rt record"(read (show (Rec 5 False)) == Rec 5 False)+    , check "Read paren/ws" (read "  (B (-2)) " == B (-2))+      -- Read PARITY: full readsPrec ReadS output == GHC's own derived Read+    , parityCheck "Read parity Sum"   [0,11] readsPrec readsPrec cS cST sumInputs+    , parityCheck "Read parity Expr"  [0,6,7,11] readsPrec readsPrec cE cET exprInputs+    , parityCheck "Read parity Trio"  [0,11] readsPrec readsPrec cT cTT trioInputs+    , parityCheck "Read parity Recd"  [0,11] readsPrec readsPrec cR cRT recdInputs+      -- Read1 PARITY: liftReadPrec (native readPrec leaves) at a concrete type+      -- == GHC's derived Read of the monomorphic twin+    , parityCheck "Read1 parity Trio" [0,11] rp1 readsPrec cT cTT trioInputs+    , parityCheck "Read1 parity Recd" [0,11] rp1 readsPrec cR cRT recdInputs+      -- Read2 PARITY: liftReadPrec2 at concrete types == derived Read of twin+    , parityCheck "Read2 parity Bi"   [0,11] rp2 readsPrec cB cBT biInputs+      -- INFIX parity: the ambiguous-parse ORDER (only ReadPrec synthesis matches)+    , parityCheck "Read parity InfF"  [0,5,6,11] readsPrec readsPrec cInf cInfT infInputs+    , parityCheck "Read1 parity InfF" [0,5,6,11] rp1 readsPrec cInf cInfT infInputs+    , parityCheck "Read2 parity InfB" [0,5,6,11] rp2 readsPrec cIB cIBT ibInputs+      -- Traversable: synthesized at Stock1, used via the one-liner; behaviour+      -- matches GHC's stock-derived twin (Maybe applicative: success + failure),+      -- and obeys the identity law.+    , check "Traversable rt"  (let t  = TNode (TNode TLeaf 1 [2,3]) 4 [5 :: Int]+                                   t' = TNode' (TNode' TLeaf' 1 [2,3]) 4 [5]+                               in fmap cTr (traverse (Just . (*10)) t)+                                  == fmap cTr' (traverse (Just . (*10)) t'))+    , check "Traversable fail"(traverse (\x -> if x == 4 then Nothing else Just x)+                                 (TNode TLeaf (4 :: Int) [5]) == Nothing)+    , check "Traversable id"  (let t = TNode (TNode TLeaf 1 [2,3]) 4 [5 :: Int]+                               in runIdentity (traverse Identity t) == t)+    , check "Traversable Ov1" (let z = Zl [1,2,3 :: Int]+                               in fmap runZl (traverse Just z) == Just [1,2,3])+      -- Bitraversable: no GHC stock oracle, so check the bimap law + id + failure+    , check "Bitraversable law"(let t = BTList 1 [True,False] 9 :: BT Int Bool+                                in bitraverse (Just . (+1)) (Just . not) t+                                   == Just (bimap (+1) not t))+    , check "Bitraversable id" (let t = BTBoth (7 :: Int) True+                                in bitraverse Just Just t == Just t)+    , check "Bitraversable fl" (bitraverse (\x -> if x > 0 then Just x else Nothing) Just+                                  (BTBoth (-1 :: Int) True) == Nothing)+      -- nested/tuple Functor+Foldable+Traversable must match GHC's full walk+    , check "FFT nest fmap" (let (a,b,c,d) = nestVal+                             in cNe (fmap (*10) (Nest a b c d))+                                == cNeG (fmap (*10) (NestG a b c d)))+    , check "FFT nest fold" (let (a,b,c,d) = nestVal+                             in Data.Foldable.toList (Nest a b c d)+                                == Data.Foldable.toList (NestG a b c d))+    , check "FFT nest trav" (let (a,b,c,d) = nestVal+                             in fmap cNe (traverse Just (Nest a b c d))+                                == fmap cNeG (traverse Just (NestG a b c d)))+      -- parameterised+    , check "param Eq"      (Pair (1::Int) 2 == Pair 1 2 && Pair 1 2 /= Pair 1 3)+    , check "param rt"      (read (show (Pair (1::Int) 2)) == Pair 1 2)+      -- Enum / Bounded+    , check "Enum from"     (map fromEnum [Red ..] == [0,1,2])+    , check "Enum to"       (toEnum 1 == Green)+      -- GHC's derived toEnum/succ/pred ERROR out of range; ours must too+    , check "Enum oob"      enumOOB+    , check "Enum succ max" enumSucc+    , check "Enum pred min" enumPred+    , check "Enum range"    ([Red ..] == [Red, Green, Blue])+    , check "Bounded"       ((minBound, maxBound) == (Red, Blue))+    , check "Bounded prod"  ((minBound, maxBound) == (BB False LT, BB True GT))+      -- Ix+    , check "Ix range"      (range (Red, Blue) == [Red, Green, Blue])+    , check "Ix index"      (index (Red, Blue) Green == 1)+    , check "Ix inRange"    (inRange (Red, Blue) Green && not (inRange (Green, Blue) Red))+    , check "Ix rangeSize"  (rangeSize (Red, Blue) == 3)+      -- Ix on a single-con product == GHC's derived twin (Cartesian range etc.)+    , check "Ix product"    (let (lp,up) = (IxP 1 False, IxP 2 True)+                                 (lg,ug) = (IxPG 1 False, IxPG 2 True)+                             in map cIxP (range (lp,up)) == map cIxPG (range (lg,ug))+                                && map (index (lp,up)) (range (lp,up))+                                   == map (index (lg,ug)) (range (lg,ug))+                                && rangeSize (lp,up) == rangeSize (lg,ug)+                                && and [ inRange (lp,up) (IxP i b) == inRange (lg,ug) (IxPG i b)+                                       | i <- [0..3], b <- [False,True] ])+      -- Generic META: infix-con fixity (#1) and field strictness (#3) match GHC+    , check "Generic fixity"(conFixity (unM1 (from (1 :*:. 2)))+                             == conFixity (unM1 (from (1 :*:~ 2)))+                             && conFixity (unM1 (from (1 :*:. 2))) == Infix RightAssociative 7)+    , check "Generic strict"(let sd x = case unM1 (unM1 (from x)) of l G.:*: _ -> selDecidedStrictness l+                             in sd (MStr [1] 2) == sd (MStrG [1] 2) && sd (MStr [1] 2) == DecidedStrict)+      -- Generic + Generically (the synthesized Rep bootstraps these)+    , check "Generic rt"    (to (from (Prod [1] [2])) == Prod [1] [2])+    , check "Generically <>"(Prod [1] [2] <> Prod [3] [4] == Prod [1,3] [2,4])+    , check "Generically me"(mempty == Prod [] [])+      -- direct pointwise Semigroup/Monoid via Stock (same result as Generically)+    , check "Semigroup <>"  (Sg [1] [2] <> Sg [3] [4] == Sg [1,3] [2,4])+    , check "Monoid mempty" (mempty == Sg [] [])+      -- empty config '[] is the identity (same as plain Stock), with fields+    , check "Override '[] id" (show (EmptyOv 1 True) == "EmptyOv 1 True"+                               && EmptyOv 1 True == EmptyOv 1 True+                               && EmptyOv 1 True /= EmptyOv 2 True)+      -- per-field Override: cx via Sum (additive), cy via Product (multiplicative)+    , check "Override <>"   (Coord 2 3 <> Coord 5 7 == Coord 7 21)+      -- positional [[..]]: field0 Sum (additive), field1 Product, field2 _ (kept, ++)+    , check "Override pos"  (Pos 2 3 [1] <> Pos 5 7 [2] == Pos 7 21 [1,2])+      -- [[Sum Int, _, _]]: only the first field changes (saturated/pinned)+    , check "Override pos1" (PosS 2 [1] [3] <> PosS 5 [2] [4] == PosS 7 [1,2] [3,4])+      -- multi-ctor --> paths via Eq: 'MA-->0-->Mod5 (field0 mod 5, field1 normal),+      -- 'MB-->Mod5 (MB's field mod 5)+    , check "Override -->"  (MA 1 7 == MA 6 7          -- field0 1≡6 (mod5), field1 7=7+                             && not (MA 1 7 == MA 1 8) -- field1 normal: 7≠8+                             && MB 1 == MB 6           -- MB field 1≡6 (mod5)+                             && not (MA 1 7 == MB 1))  -- different constructors+      -- Ord respects Override (viaSynth): field0 via Down reverses, field1 normal+    , check "Override Ord"  (compare (OrdOv 1 5) (OrdOv 2 5) == GT+                             && compare (OrdOv 5 1) (OrdOv 5 2) == LT)+      -- Show + Read respect Override: round-trip through a Sum-overridden field+    , check "Override S/R"  (read (show (SR 3 7)) == SR 3 7)+      -- Generic respects Override: Generically derives Semigroup over the+      -- overridden fields (field0 additive, field1 multiplicative)+    , check "Override Gen"  (CoordG 2 5 <> CoordG 3 4 == CoordG 5 20)+    , check "Override type" (TK 2 3 <> TK 5 7 == TK 7 10)     -- Int via Sum (both fields)+    , check "Override at"   (PK 2 3 <> PK 5 7 == PK 7 21)     -- at 0 via Sum, at 1 via Product+      -- Monoid respects Override: mempty = (Sum 0, Product 1), mappend additive/mult.+    , check "Override mempty"(mempty == MonOv 0 1)+    , check "Override <> M"  (MonOv 2 3 <> MonOv 5 7 == MonOv 7 21)+      -- Bounded respects Override: field0's bounds come from Hi (100..200)+    , check "Override Bnd"   ((minBound, maxBound) == (BdOv 100 False, BdOv 200 True))+      -- Enum / Ix: all-blank Override is the identity on a fieldless enum+    , check "Override Enum"  (map fromEnum [EnA ..] == [0,1,2] && toEnum 1 == EnB)+    , check "Override Ix"    (range (EnA, EnC) == [EnA, EnB, EnC] && index (EnA, EnC) EnB == 1)+      -- Functor respects Override1: Blah counts the fmap (0 -> 1) while mapping+    , check "Override Functor"(fmap (+ (10 :: Int)) (WithCount (0, 5)) == WithCount (1, 15))+      -- Contravariant respects Override1: Neg negates, so (5+1 > 6 = False) flips to True+    , check "Override Contra"(runCV (contramap (+ (1 :: Int)) (CV (Predicate (> 6)))) 5)+      -- Bifunctor respects Override2: each list field reshaped to RevL ⇒ reversed+    , check "Override Bifun" (bimap (+ (1 :: Int)) not (B2 [1, 2] [True, False])+                              == B2 [3, 2] [True, False])+      -- Eq1/Ord1/Show1 respect Override1: BL is blind/fixed+    , check "Override Eq1"   (liftEq (==) (Lc [1]) (Lc [9, 9 :: Int])+                              && liftCompare compare (Lc [1]) (Lc [9 :: Int]) == EQ)+    , check "Override Show1" (let s = liftShowsPrec showsPrec showList 0 (Lc [1, 2 :: Int]) ""+                              in "BL" `isInfixOf` s && not ('1' `elem` s))+      -- Bifoldable respects Override2: BL folds its list reversed+    , check "Override Bifold"(bifoldMap (: []) (: []) (Bc [1, 2] [3, 4 :: Int]) == [2, 1, 4, 3])+      -- Eq2 respects Override2: BL blind ⇒ all equal (same b-shape)+    , check "Override Eq2"   (liftEq2 (==) (==) (Bc [1] [3]) (Bc [9, 9] [8, 8 :: Int]))+      -- Generic1 honours Override1: Generically1 Applicative zips (ZipList), not cartesian+    , check "Override Gen1Ap"(runZg (Zg [(+ 1), (* 10)] <*> Zg [5, 6]) == ([6, 60] :: [Int]))+      -- Ord2 honours Override2: BL's blind liftCompare ⇒ EQ regardless of contents+    , check "Override Ord2"  (liftCompare2 compare compare (Bc [1] [3]) (Bc [9, 9] [8 :: Int]) == EQ+                              && liftCompare compare (Lc [1]) (Lc [9 :: Int]) == EQ)+      -- Show2 honours Override2: each field renders through BL ⇒ "BL", not the list+    , check "Override Show2" (let s = liftShowsPrec2 showsPrec showList showsPrec showList 0 (Bc [1] [2 :: Int]) ""+                              in "BL" `isInfixOf` s && not ('1' `elem` s))+      -- Read1 honours Override1: RL reverses on read, so the field comes back reversed+    , check "Override Read1" (case liftReadsPrec readsPrec readList 0 "Lr [1,2,3]" of+                                ((v, _) : _) -> v == Lr [3, 2, 1 :: Int] ; _ -> False)+      -- Read2 honours Override2: both fields parsed through RL ⇒ both reversed+    , check "Override Read2" (case liftReadsPrec2 readsPrec readList readsPrec readList 0 "Br [1,2] [3,4]" of+                                ((v, _) : _) -> v == Br [2, 1] [4, 3 :: Int] ; _ -> False)+      -- `_` (Keep) sugar lowered for Overriding1 too (identity reshape)+    , check "Override1 _ Keep" (fmap (+ (1 :: Int)) (Kp [1, 2, 3]) == Kp [2, 3, 4])+      -- field-keyed (name :=) Override1/Override2 — same surface as value Override+    , check "Override1 := name" (fmap (+ (1 :: Int)) (NK [1, 2, 3]) == NK [4, 3, 2])+    , check "Override2 := name" (bimap (+ (1 :: Int)) not (NK2 [1, 2] [True, False])+                                 == NK2 [3, 2] [True, False])+      -- Generic for a SUM type: from/to round-trips through the :+: structure+    , check "Generic sum rt"(all (\x -> to (from x) == x) [A, B 7, C 1 True, Rec 2 False])+      -- cross-validation: stock Generic Gen and plugin's Generic (Stock Gen)+      -- drive the same Generically algorithm to the same result+    , check "xval <>"       (let x = Gen [1] [2]; y = Gen [3] [4]+                             in viaGen x y == viaStockGen x y+                                && viaGen x y == Gen [1,3] [2,4])+    , check "xval mempty"   (memptyGen == memptyStockGen && memptyGen == Gen [] [])+      -- Rep (Stock T) ~R Rep T for a SUM type too+    , check "Rep ~R sum"    (all (\x -> repCrossRoundtripS x == x) [GA, GB 5, GC 2 True])+      -- M1 metadata layers carry the right names (datatype, constructor, record)+    , check "Meta datatype" (datatypeName (from (MetaR 1)) == "MetaR")+    , check "Meta con"      (conName (unM1 (from (MetaR 1))) == "MetaR")+    , check "Meta record"   (conIsRecord (unM1 (from (MetaR 1))))+      -- Generic1: from1/to1 round-trip (Par1 / Rec1 / Rec0, sum + product)+    , check "Generic1 rt"   (all (\x -> to1 (from1 x) == x)+                               [G1 7 (1::Int) [2,3] [[4],[5,6]], G1' 9, G1 0 5 [] []])+      -- Rep (Stock T) is *representationally* equal to stock's Rep T (the M1+      -- metadata layers are newtypes): coerce across them and round-trip.+    , check "Rep ~R Rep T"  (repCrossRoundtrip (Gen [1] [2]) == Gen [1] [2])+      -- infix constructors (fixity-aware Show/Read)+    , check "Show infix"    (show e1 == norm (show e1'))+    , check "Show infix ()" (show e2 == norm (show e2'))+    , check "Read infix rt" (read (show e1) == e1 && read (show e2) == e2)+      -- Functor via Stock1, against a stock DeriveFunctor twin+    , check "Functor fmap"  (fmap (+1) (Trio 1 2 [3,4]) == Trio 1 3 [4,5])+    , check "Functor vs twin"+        (show (fmap (*2) (Trio 1 2 [3])) == norm (show (fmap (*2) (Trio' 1 2 [3]))))+    , check "Functor <$"    ((9 <$ Trio 1 2 [3,4]) == Trio 1 9 [9,9])+      -- Foldable via Stock1, against the stock twin+      -- Applicative with a constant field (Const-style, via Monoid)+    , check "Applicative pure" (pure 'z' == (Ap [] 'z' :: Ap Char))+    , check "Applicative <*>"  ((Ap [1] (+1) <*> Ap [2] 10) == (Ap [1,2] 11 :: Ap Int))+      -- Override1: [] field → ZipList, so <*> zips (cartesian [] would give 4 elems)+    , check "Override1 zip <*>" (runZl (Zl [(+1),(*10)] <*> Zl [5,6]) == ([6,60] :: [Int]))+    , check "Override1 zip lA2" (runZl (liftA2 (+) (Zl [1,2,3]) (Zl [10,20,30])) == ([11,22,33] :: [Int]))+    , check "Override1 Foldable" (Data.Foldable.toList (Zl [4,5,6 :: Int]) == [4,5,6] && sum (Zl [1,2,3 :: Int]) == 6)+    , check "Foldable sum"  (sum (Trio 9 1 [2,3,4]) == sum (Trio' 9 1 [2,3,4]))+    , check "Foldable toL"  (Data.Foldable.toList (Trio 9 5 [6,7]) == [5,6,7])+    , check "Foldable len"  (length (Trio 9 1 [2,3]) == 3)+      -- Eq1 / Ord1 via Stock1, tied to the (verified) Eq / Ord on Trio:+      -- liftEq (==) must agree with (==); liftCompare compare with compare.+    , check "Eq1 vs Eq"     (let a = Trio 1 'x' "pq"; b = Trio 1 'x' "pq"; c = Trio 1 'y' "pr"+                             in liftEq (==) a b == (a == b)+                                && liftEq (==) a c == (a == c))+    , check "Eq1 param fn"  (-- a custom relation on the parameter is threaded to+                             -- both the bare field and the [a] field+                             liftEq (\_ _ -> True) (Trio 1 'x' "pq") (Trio 1 'z' "rs")+                             && not (liftEq (\_ _ -> False) (Trio 1 'x' "p") (Trio 1 'x' "p")))+    , check "Ord1 vs Ord"   (let a = Trio 1 'x' "pq"; c = Trio 1 'y' "pr"+                             in liftCompare compare a c == compare a c+                                && liftCompare compare a a == EQ)+      -- the quantified superclass: from (Eq1 f, Eq a) alone we must get Eq (f a),+      -- and from (Ord1 f, Ord a) we must get Ord (f a) — f is abstract in the+      -- helpers below, so this can only resolve through the synthesized super.+    , check "Eq1 superclass"  (eqViaEq1 (Trio 1 'x' "p") (Trio (1::Int) 'x' "p"))+    , check "Ord1 superclass" (cmpViaOrd1 (Trio 1 'x' "p") (Trio (1::Int) 'y' "p") == LT)+      -- Show1: showsPrec1 (which feeds liftShowsPrec the standard showsPrec/+      -- showList) must agree with the verified Show; a custom sp is threaded.+    , check "Show1 vs Show"  (showsPrec1 0 (Trio (1::Int) 'x' "pq") "" == show (Trio (1::Int) 'x' "pq"))+    , check "Show1 twin"     (showViaShow1 (Trio 9 (1::Int) [2,3]) == norm (show (Trio' 9 (1::Int) [2,3])))+    , check "Show1 param fn" (liftShowsPrec (\_ _ s -> 'Z':s) showList 0 (Trio (1::Int) 'x' "pq") ""+                              == "Trio 1 Z \"pq\"")+    , check "Show1 paren"    (showsPrec1 11 (Trio 9 (1::Int) [2]) "" == "(Trio 9 1 [2])")+    , check "Show1 record"   (showsPrec1 0 (Recd (1::Int) [2,3]) "" == show (Recd (1::Int) [2,3]))+      -- Read1: readsPrec1 (fed the standard readsPrec/readList) must invert+      -- Show; the quantified Read superclass gives Read (f a) from f abstract.+    , check "Read1 rt"       (let t = Trio (1::Int) (2::Int) [3,4]+                              in case readsPrec1 0 (show t) of ((x,_):_) -> x == t; _ -> False)+    , check "Read1 super"    (let t = Trio (9::Int) (1::Int) [2,3] in readViaRead1 (show t) == t)+    , check "Read1 record"   (let t = Recd (1::Int) [2,3] in readViaRead1 (show t) == t)+      -- Contravariant via Stock1 (newtype + function/constant/sub-Pred fields)+    , check "Contra pred"   (let p = contramap length (Pred even)+                             in runPred p "abcd" && not (runPred p "abc"))+    , check "Contra law id" (let p = contramap id (Pred (> (3::Int)))+                             in runPred p 4 && not (runPred p 3))+    , check "Contra mixed"  (let Sel f _ (Pred q) =+                                   contramap (length :: [a] -> Int)+                                             (Sel (> (10::Int)) 0 (Pred (> 5)))+                             in f "abcdefghijk" && not (f "abc")+                                && q "abcdef" && not (q "abc"))+    , check "Contra 2-arg"  (runFoo2 (contramap length (Foo2 (+))) "ab" "cde" == 5)+      -- variance through nested function arrows+    , check "Functor cps"   (runCps (fmap (*2) (Cps (\k -> k 5))) id == 10)+    , check "Contra cps3"   (forceCps3 (contramap (length :: String -> Int)+                                                  (Cps3 (const 0)) :: Cps3 String) == ())+      -- Category via Stock2: pointwise id and composition over the fields+    , check "Category id"   (runP2 (Cat.id :: P2 Int Int) 5 == (5 :: Int))+    , check "Category ."     (runP2 ((P2 Refl (+1) :: P2 Int Int) Cat.. P2 Refl (*2)) 5 == (11 :: Int))+      -- Category with a constant (Sum Int) field, handled via Monoid (no Basic)+    , check "Category const"+        (let (s, f) = runLC ((LC 1 (+1) :: LC Int Int) Cat.. LC 2 (*2)) in s == 3 && f 5 == 11)+      -- Category via Overriding2: each field reshaped into a Category, then+      -- derived pointwise (Sum adds, String appends, Kleisli composes monadically)+    , check "Category Ov id"+        (let (i, s, f) = runFoo (Cat.id :: Foo Int Int) in i == 0 && s == "" && f 9 == Just 9)+    , check "Category Ov ."+        (let (i, s, f) = runFoo ((Foo 3 "x" (\n -> Just (n+1)) :: Foo Int Int)+                                   Cat.. Foo 4 "y" (\n -> Just (n*2)))+         in i == 7 && s == "xy" && f 5 == Just 11)+      -- Bifunctor / Bifoldable via Stock2+    , check "Bifunctor bi"  (bimap (+(1::Int)) not (Bi 1 True) == Bi 2 False)+    , check "Bifunctor 1st" (first (+(1::Int)) (OnlyA 7 :: Bi Int Bool) == OnlyA 8)+    , check "Bifunctor 2nd" (second not (Bs True [False]) == (Bs False [True] :: Bi () Bool))+    , check "Bifunctor sup" (fmap not (Bs True [False,True]) == (Bs False [True,False] :: Bi () Bool))+      -- nested Either a b + [b] fields, via the n-ary self-application case+    , check "Bifunctor Either" (bimap (+(1::Int)) not (BiE (Left 5) [True])+                                  == (BiE (Left 6) [False] :: BiE Int Bool))+    , check "Bifunctor Either2" (bimap (+(1::Int)) not (BiE (Right True) [])+                                  == (BiE (Right False) [] :: BiE Int Bool))+      -- Eq2 / Ord2 via Stock2 (liftEq2 / liftCompare2 across both parameters)+    , check "Eq2"           (liftEq2 (==) (==) (Bi (1::Int) True) (Bi 1 True)+                             && not (liftEq2 (==) (==) (Bi (1::Int) True) (Bi 2 True)))+    , check "Show2"         (let p :: Bi Int Bool -> String+                                 p x = liftShowsPrec2 showsPrec showList showsPrec showList 0 x ""+                             in p (Bi 1 True) == show (Bi (1::Int) True)+                                && p (Bs True [False,True]) == show (Bs True [False,True] :: Bi Int Bool))+      -- Read2 via Stock2: read back what show produced (ties to verified Show+Eq)+    , check "Read2"         (let rd :: String -> Bi Int Bool+                                 rd s = case liftReadsPrec2 readsPrec readList readsPrec readList 0 s of+                                          [(v, "")] -> v+                                          _         -> error "Read2: no/ambiguous parse"+                             in rd (show (Bi (1::Int) True)) == Bi 1 True+                                && rd (show (Bs True [False,True] :: Bi Int Bool)) == Bs True [False,True])+    , check "Ord2"          (liftCompare2 compare compare (Bi (1::Int) True) (Bi 1 False)+                             == compare True False+                             && liftCompare2 compare compare (Bi (1::Int) (2::Int)) (OnlyA 1) == LT)+    , check "Bifoldable"    (bifoldMap (\a->[a]) (\b->[b]) (Bs 9 [1,2,3]) == [9,1,2,3::Int]+                             && bifoldMap (\a->[a]) (\b->[b]) (Bi 1 2) == [1,2::Int])+    -- TestEquality / TestCoercion on the singleton GADT+    , check "TestEq same"   (case testEquality TInt TInt of Just Refl -> True; _ -> False)+    , check "TestEq diff"   (case testEquality TInt TBool of Nothing -> True; _ -> False)+    , check "TestEq refl"   (case testEquality TBool TBool of+                               Just Refl -> True && (True :: Bool); _ -> False)+    , check "TestEq use"    (case testEquality TInt TInt of+                               Just r  -> castWith r (5 :: Int) == 5; Nothing -> False)+    , check "TestCo same"   (case testCoercion TChar TChar of+                               Just c  -> coerceWith c 'x' == 'x'; Nothing -> False)+    , check "TestCo diff"   (case testCoercion TInt TChar of Nothing -> True; _ -> False)+    -- same index, different constructors: compares the type, not the tag+    , check "TestEq sameIx" (case testEquality TZa TZb of Just Refl -> True; _ -> False)+    , check "TestEq sameIx'"(case testEquality TZb TZa of Just Refl -> True; _ -> False)+    , check "TestEq self"   (case testEquality TZb TZb of Just Refl -> True; _ -> False)+    , check "TestEq mixIx"  (case testEquality TZa TZc of Nothing   -> True; _ -> False)+    , check "TestEq useZ"   (case testEquality TZa TZb of+                               Just r  -> castWith r (7 :: Int) == 7; Nothing -> False)+    ]+  unless (and rs) exitFailure+  where+    xs = [C 1 True, A, B 1, Rec 9 True, A]+    e1  = Lit 1 :+: Lit 2 :*: Lit 3 ;  e1' = Lit' 1 :+. Lit' 2 :*. Lit' 3+    e2  = (Lit 1 :+: Lit 2) :*: Lit 3; e2' = (Lit' 1 :+. Lit' 2) :*. Lit' 3+++