diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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+). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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 ] ]) diff --git a/bench/Configs.hs b/bench/Configs.hs new file mode 100644 --- /dev/null +++ b/bench/Configs.hs @@ -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 diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -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 diff --git a/examples/QualOverride.hs b/examples/QualOverride.hs new file mode 100644 --- /dev/null +++ b/examples/QualOverride.hs @@ -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]) + ] diff --git a/inspection/Inspection.hs b/inspection/Inspection.hs new file mode 100644 --- /dev/null +++ b/inspection/Inspection.hs @@ -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" diff --git a/plugin/Stock.hs b/plugin/Stock.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock.hs @@ -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). diff --git a/plugin/Stock/Applicative.hs b/plugin/Stock/Applicative.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Applicative.hs @@ -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 diff --git a/plugin/Stock/Bifunctor.hs b/plugin/Stock/Bifunctor.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Bifunctor.hs @@ -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 ..) |> 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 diff --git a/plugin/Stock/Bounded.hs b/plugin/Stock/Bounded.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Bounded.hs @@ -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 ] ]) diff --git a/plugin/Stock/Classes1.hs b/plugin/Stock/Classes1.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Classes1.hs @@ -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)) + diff --git a/plugin/Stock/Compat.hs b/plugin/Stock/Compat.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Compat.hs @@ -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 diff --git a/plugin/Stock/Derive.hs b/plugin/Stock/Derive.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Derive.hs @@ -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 diff --git a/plugin/Stock/Enum.hs b/plugin/Stock/Enum.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Enum.hs @@ -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 = + 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. diff --git a/plugin/Stock/Eq.hs b/plugin/Stock/Eq.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Eq.hs @@ -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. diff --git a/plugin/Stock/Functor.hs b/plugin/Stock/Functor.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Functor.hs @@ -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). diff --git a/plugin/Stock/Generic.hs b/plugin/Stock/Generic.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Generic.hs @@ -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ᵢ |> 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 -> 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. diff --git a/plugin/Stock/Internal.hs b/plugin/Stock/Internal.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Internal.hs @@ -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 :.: + | 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) diff --git a/plugin/Stock/Ord.hs b/plugin/Stock/Ord.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Ord.hs @@ -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. diff --git a/plugin/Stock/Override.hs b/plugin/Stock/Override.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Override.hs @@ -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 --> diff --git a/plugin/Stock/Read.hs b/plugin/Stock/Read.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Read.hs @@ -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). diff --git a/plugin/Stock/Semigroup.hs b/plugin/Stock/Semigroup.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Semigroup.hs @@ -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) + diff --git a/plugin/Stock/Show.hs b/plugin/Stock/Show.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Show.hs @@ -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@. diff --git a/plugin/Stock/Surface.hs b/plugin/Stock/Surface.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Surface.hs @@ -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 diff --git a/plugin/Stock/TestEquality.hs b/plugin/Stock/TestEquality.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/TestEquality.hs @@ -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) diff --git a/plugin/Stock/Trans.hs b/plugin/Stock/Trans.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Trans.hs @@ -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 diff --git a/plugin/Stock/Traversable.hs b/plugin/Stock/Traversable.hs new file mode 100644 --- /dev/null +++ b/plugin/Stock/Traversable.hs @@ -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 diff --git a/src/Stock/Type.hs b/src/Stock/Type.hs new file mode 100644 --- /dev/null +++ b/src/Stock/Type.hs @@ -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 } diff --git a/stock.cabal b/stock.cabal new file mode 100644 --- /dev/null +++ b/stock.cabal @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + + + diff --git a/test/Twin.hs b/test/Twin.hs new file mode 100644 --- /dev/null +++ b/test/Twin.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +-- | GHC-stock-derived twins with IDENTICAL constructor names, so the very same +-- input string can be fed to both the plugin's @Read@ and GHC's own derived +-- @Read@. This is the oracle for the Read-parity checks in "Main". +module Twin where + +import GHC.Generics (Generic) + +-- mixed: nullary / prefix / record +data Sum = A | B Int | C Int Bool | Rec { rf :: Int, rg :: Bool } + deriving (Eq, Show, Read) + +-- infix with distinct fixities (must match the plugin-side type exactly) +infixr 5 :+: +infixl 6 :*: +data Expr = Lit Int | Expr :+: Expr | Expr :*: Expr + deriving (Eq, Show, Read) + +-- parameterised, for the Read1 oracle (instantiated at a concrete type) +data Trio a = Trio Int a [a] + deriving (Eq, Show, Read) + +-- parameterised record, for the Read1 record path +data Recd a = Recd { rx :: a, ry :: [a] } + deriving (Eq, Show, Read) + +-- parameterised INFIX, for the Read1 ambiguous-order oracle +infixr 5 :++ +data InfF a = ILit a | InfF a :++ InfF a + deriving (Eq, Show, Read) + +-- two parameters, for the Read2 oracle +data Bi a b = Bi a b | OnlyA a | Bs b [b] | Tag Int + deriving (Eq, Show, Read) + +-- two-parameter INFIX (non-recursive: Read2's flat classifier can't take a +-- self-applied field), a sanity oracle for Read2's infix-constructor path +infixr 5 :** +data InfB a b = IB a b | a :** b + deriving (Eq, Show, Read) + +-- GHC-stock Generic twins (identical names/fixity/strictness), so the whole +-- Rep below D1 can be statically compared against the via-Stock version. +infixr 7 :*:. +data MOp = Int :*:. Int deriving (Eq, Show, Generic) +data MStr = MStr ![Int] Int deriving (Eq, Show, Generic) +data MSum = MN | MP Int Bool | MR { mrf :: Int, mrg :: Bool } + deriving (Eq, Show, Generic)