stock-hashable (empty) → 0.1.0.0
raw patch · 5 files changed
+487/−0 lines, 5 filesdep +basedep +ghcdep +hashable
Dependencies added: base, ghc, hashable, inspection-testing, stock, stock-hashable
Files
- LICENSE +29/−0
- Stock/Hashable.hs +258/−0
- inspection/Inspection.hs +46/−0
- stock-hashable.cabal +71/−0
- test/Test.hs +83/−0
+ LICENSE view
@@ -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.
+ Stock/Hashable.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE InstanceSigs #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- the @DeriveStock(1)@ registrations are necessarily orphans++-- | A companion \"solver\" package teaching the @stock@ plugin to derive+-- @Hashable@ (and its higher order variant @Hashable1@), without being a plugin+-- itself. It depends only on the SDK ("Stock.Derive" \/ "Stock.Internal") ++-- @hashable@.+--+-- Downstream: @data T = … deriving (Eq, Hashable) via Stock T@ (or, for a type+-- constructor, @deriving (Eq1, Hashable1) via Stock1 T@ alongside the @Eq@ \/+-- @Hashable@ instances its superclasses need).+module Stock.Hashable+ ( hashableWitness+ , Hashable(..)+ , Hashable1(..)+ , Hashable2(..)+ ) where++import GHC.Plugins+import GHC.Builtin.Names (eqClassName)+import GHC.Core.Class (Class, classSCTheta, classTyVars)+import GHC.Tc.Plugin (TcPluginM, tcLookupClass, newWanted)+import GHC.Tc.Types.Constraint (ctEvExpr, mkNonCanonical)+import GHC.Core.Predicate (mkClassPred, classifyPredType, Pred(ClassPred, ForAllPred))+import GHC.Core.TyCo.Subst (substTy)+import GHC.Core.Multiplicity (scaledThing)+import Control.Monad (forM, zipWithM)+import Data.Maybe (listToMaybe, fromMaybe)+import GHC.Core.TyCo.Rep (UnivCoProvenance(PluginProv))+import Data.Hashable (Hashable(..))+import Data.Hashable.Lifted (Hashable1(..), Hashable2(..))+import Stock.Derive+import Stock.Internal+import Stock.Bifunctor (BiField(..), classifyBiField)++-- | A witness whose constraints name the three base classes. The plugin reads+-- them straight off this value's type, so the deriver can recover @Hashable@ \/+-- @Hashable1@ on @hashable < 1.5@ (where they are not reachable as quantified+-- superclasses, and the defining module @Data.Hashable.Class@ is hidden) —+-- version-independently, without any module-name lookup.+hashableWitness :: (Hashable a, Hashable1 f, Hashable2 g) => (a, f x, g y z) -> ()+hashableWitness _ = ()++-- | @hashWithSalt@ dispatches on the constructor ('matchSOP', mixing the tag in+-- for sums), folds each field's @hashWithSalt@ through the salt ('cfoldlFields'),+-- and 'classDictWith' fills @hash@ from its default and supplies the @Eq@+-- superclass (also derived @via Stock@).+instance DeriveStock Hashable where+ deriveStock :: Deriver+ deriveStock = Deriver \cls dt -> do+ let via = dtVia dt+ hwsSel = classMethod "hashWithSalt" cls -- hashWithSalt :: Int -> a -> Int+ nCons = length (dtCons dt)+ hws ft d salt e = mkApps (Var hwsSel) [Type ft, d, salt, e] -- hashWithSalt @ft d salt e+ eqCls <- liftTc (tcLookupClass eqClassName)+ eqDict <- field eqCls via -- Eq superclass (also via Stock)+ intHash <- field cls intTy -- Hashable Int (for the tag)+ saltId <- fresh intTy "salt"+ xId <- fresh via "x"+ body <- matchSOP dt intTy (Var xId) \i con fields -> do+ let s0 | nCons > 1 = hws intTy intHash (Var saltId) (mkUncheckedIntExpr (fromIntegral i))+ | otherwise = Var saltId+ case fields of+ [] -> do d <- field cls unitTy+ pure (hws unitTy d s0 (Var (dataConWorkId unitDataCon)))+ _ -> cfoldlFields cls (\salt ft d e -> pure (hws ft d salt e)) s0 con fields+ classDictWith cls via [eqDict] [(0, mkLams [saltId, xId] body)]++-- | @liftHashWithSalt g@ threads the salt through the fields: the parameter via+-- the supplied @g :: Int -> a -> Int@, a constant via its own @hashWithSalt@, an+-- @h a@ field via @liftHashWithSalt@ of @h@; sums mix in the constructor tag.+-- @Hashable1@'s superclasses (@Eq1 f@ and @forall a. Hashable a => Hashable (f+-- a)@) are requested as wanteds and discharged by the plugin (the @Eq1@ built-in,+-- and the @Stock1@-newtype passthrough from the user's own @Hashable@ instance).+instance DeriveStock1 Hashable1 where+ deriveStock1 :: Deriver1+ deriveStock1 = Deriver1 \h1Cls loc wrappedTy f ->+ -- hashable < 1.5 gives @Hashable1@ only an @Eq1@ superclass (the quantified+ -- @forall a. Hashable a => Hashable (f a)@ arrived in 1.5), so recover+ -- @Hashable@ by a direct lookup when the superclass scan comes up empty.+ baseOrWitness h1Cls "Hashable" >>= \mHash ->+ lookupOvTcs "Override1" >>= \tcs ->+ let mOv1 = ovWrap tcs ; mKeep = ovKeep tcs+ -- @f@ may be @Override1 cfg realF@ (positional or field-keyed): peel it.+ (realF, mMods) = peelOverride1With tcs f in+ case (tyConAppTyCon_maybe wrappedTy, tyConAppTyCon_maybe realF, mHash) of+ (Just st1Tc, Just fTc, Just hashCls) -> do+ let fixed = tyConAppArgs realF+ dcons = tyConDataCons fTc+ nCons = length dcons+ liftHwsSel = classMethod "liftHashWithSalt" h1Cls+ hwsSel = classMethod "hashWithSalt" hashCls+ coAt t = coDown1With mOv1 st1Tc wrappedTy f realF t+ atv <- freshTyVar "a"+ let aTy = mkTyVarTy atv+ innerA = mkTyConApp fTc (fixed ++ [aTy])+ gId <- freshId (mkVisFunTyMany intTy (mkVisFunTyMany aTy intTy)) "g"+ saltId <- freshId intTy "salt"+ faId <- freshId (mkAppTy wrappedTy aTy) "fa"+ cb <- freshId innerA "cb"+ mTagEv <- if nCons > 1 then Just <$> newWanted loc (mkClassPred hashCls [intTy])+ else pure Nothing+ let step i x ftA = case classifyField atv aTy ftA of+ Nothing -> pure Nothing+ Just FParam -> pure (Just (\s -> mkApps (Var gId) [s, Var x], []))+ Just FConst -> do ev <- newWanted loc (mkClassPred hashCls [ftA])+ pure (Just ( \s -> mkApps (Var hwsSel) [Type ftA, ctEvExpr ev, s, Var x]+ , [mkNonCanonical ev] ))+ Just (FApp h) -> hashApp i x h+ -- under @Override1@, hash the @h a@ field via the modifier @m@'s+ -- liftHashWithSalt, coercing the field value @h a ~R m a@ first.+ hashApp i x h = do+ let mMod = override1ModWith mKeep mMods i+ m = fromMaybe h mMod+ xv = maybe (Var x) (const (Cast (Var x) (mkStockCo (PluginProv "stock")+ Representational (mkAppTy h aTy) (mkAppTy m aTy)))) mMod+ ev <- newWanted loc (mkClassPred h1Cls [m])+ pure (Just ( \s -> mkApps (Var liftHwsSel) [Type m, ctEvExpr ev, Type aTy, Var gId, s, xv]+ , [mkNonCanonical ev] ))+ malts <- forM (zip [0 :: Int ..] dcons) \(i, dc) -> do+ let ftsA = fieldsAt fixed dc aTy+ xs <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] ftsA+ mss <- sequence (zipWith3 step [0 :: Int ..] xs ftsA)+ case sequence mss of+ Nothing -> pure Nothing+ Just steps -> do+ let (fns, wss) = unzip steps+ s0 = case mTagEv of+ Just ev -> mkApps (Var hwsSel)+ [Type intTy, ctEvExpr ev, Var saltId, mkUncheckedIntExpr (fromIntegral i)]+ Nothing -> Var saltId+ body = foldl (\s fn -> fn s) s0 fns+ pure (Just (Alt (DataAlt dc) xs body, concat wss))+ case sequence malts of+ Nothing -> pure Nothing+ Just altWss -> do+ let (alts, wss) = unzip altWss+ tagW = maybe [] (pure . mkNonCanonical) mTagEv+ impl = mkLams [atv, gId, saltId, faId]+ (destructInner fTc (fixed ++ [aTy]) (Cast (Var faId) (coAt aTy)) cb intTy alts)+ subst = case classTyVars h1Cls of+ (tv : _) -> zipTvSubst [tv] [wrappedTy]+ _ -> emptySubst+ scPreds = map (substTy subst) (classSCTheta h1Cls)+ scEvs <- forM scPreds (newWanted loc)+ pure (Just ( classDict h1Cls wrappedTy (map ctEvExpr scEvs ++ [impl])+ , map mkNonCanonical scEvs ++ tagW ++ concat wss ))+ _ -> pure Nothing++-- | Recover a base class @C@ from a lifted class @C1@'s quantified superclass+-- @forall a. C a => C (f a)@ (scanning all superclasses; @C1@ may have others+-- such as @Eq1@). Avoids depending on @C@'s defining module.+baseClassOf :: Class -> Maybe Class+baseClassOf c1 = listToMaybe+ [ c | sc <- classSCTheta c1+ , ForAllPred _ _ hd <- [classifyPredType sc]+ , ClassPred c _ <- [classifyPredType hd] ]++-- | The base classes (@Hashable@, @Hashable1@, @Hashable2@) read off the+-- constraints of 'hashableWitness' — version-independent, no module lookup.+witnessClasses :: TcPluginM [Class]+witnessClasses = do+ mw <- lookupIdMaybe "Stock.Hashable" "hashableWitness"+ pure $ case mw of+ Just wId -> [ c | p <- map scaledThing (fst (splitFunTys (snd (splitForAllTyCoVars (idType wId)))))+ , ClassPred c _ <- [classifyPredType p] ]+ Nothing -> []++-- | 'baseClassOf', falling back to the named class from 'witnessClasses' — for+-- older @hashable@ where the quantified @Hashable@\/@Hashable1@ superclass is+-- absent.+baseOrWitness :: Class -> String -> TcPluginM (Maybe Class)+baseOrWitness c nm = case baseClassOf c of+ Just b -> pure (Just b)+ Nothing -> do cs <- witnessClasses+ pure (listToMaybe [ k | k <- cs, occNameString (getOccName k) == nm ])++-- | @liftHashWithSalt2 gA gB@ threads the salt through the fields: first-param+-- fields via @gA@, second via @gB@, constants via their own @hashWithSalt@,+-- @h a@\/@h b@ fields via @liftHashWithSalt@ of @h@; sums mix in the tag.+-- Superclasses (@Eq2 t@, @forall a. Hashable a => Hashable1 (t a)@) are+-- requested and discharged by the plugin (the @Eq2@ built-in / the passthrough).+instance DeriveStock2 Hashable2 where+ deriveStock2 :: Deriver2+ deriveStock2 = Deriver2 \h2Cls loc wrappedTy p ->+ baseOrWitness h2Cls "Hashable1" >>= \mH1 ->+ (case mH1 of Just h1 -> baseOrWitness h1 "Hashable"+ Nothing -> pure Nothing) >>= \mHash ->+ lookupOvTcs "Override2" >>= \tcs ->+ let mOv2 = ovWrap tcs ; mKeep = ovKeep tcs+ (realP, mMods) = peelOverride2With tcs p in+ case (tyConAppTyCon_maybe wrappedTy, tyConAppTyCon_maybe realP, mH1, mHash) of+ (Just st2Tc, Just pTc, Just h1Cls, Just hashCls) -> do+ let fixed = tyConAppArgs realP+ dcons = tyConDataCons pTc+ nCons = length dcons+ liftHwsSel = classMethod "liftHashWithSalt" h1Cls+ hwsSel = classMethod "hashWithSalt" hashCls+ coAt2 t1 t2 = coDown2With mOv2 st2Tc wrappedTy p realP t1 t2+ atv <- freshTyVar "a" ; btv <- freshTyVar "b"+ let aTy = mkTyVarTy atv ; bTy = mkTyVarTy btv+ innerAB = mkTyConApp pTc (fixed ++ [aTy, bTy])+ gA <- freshId (mkVisFunTyMany intTy (mkVisFunTyMany aTy intTy)) "gA"+ gB <- freshId (mkVisFunTyMany intTy (mkVisFunTyMany bTy intTy)) "gB"+ saltId <- freshId intTy "salt"+ tId <- freshId (mkAppTy (mkAppTy wrappedTy aTy) bTy) "t"+ cb <- freshId innerAB "cb"+ mTagEv <- if nCons > 1 then Just <$> newWanted loc (mkClassPred hashCls [intTy])+ else pure Nothing+ let step i x ft = case classifyBiField atv btv aTy bTy ft of+ Nothing -> pure Nothing+ Just BFA -> pure (Just (\s -> mkApps (Var gA) [s, Var x], []))+ Just BFB -> pure (Just (\s -> mkApps (Var gB) [s, Var x], []))+ Just BFConst -> do ev <- newWanted loc (mkClassPred hashCls [ft])+ pure (Just ( \s -> mkApps (Var hwsSel) [Type ft, ctEvExpr ev, s, Var x]+ , [mkNonCanonical ev] ))+ Just (BFFoldA h) -> hashApp i x h aTy gA+ Just (BFFoldB h) -> hashApp i x h bTy gB+ -- under @Override2@, hash the @h pTy@ field via the modifier @m@'s+ -- liftHashWithSalt, coercing the field value @h pTy ~R m pTy@ first.+ hashApp i x h pTy g = do+ let mMod = override1ModWith mKeep mMods i+ m = fromMaybe h mMod+ xv = maybe (Var x) (const (Cast (Var x) (mkStockCo (PluginProv "stock")+ Representational (mkAppTy h pTy) (mkAppTy m pTy)))) mMod+ ev <- newWanted loc (mkClassPred h1Cls [m])+ pure (Just ( \s -> mkApps (Var liftHwsSel) [Type m, ctEvExpr ev, Type pTy, Var g, s, xv]+ , [mkNonCanonical ev] ))+ malts <- forM (zip [0 :: Int ..] dcons) \(i, dc) -> do+ let fts = map scaledThing (dataConInstOrigArgTys dc (fixed ++ [aTy, bTy]))+ xs <- zipWithM (\n ft -> freshId ft ("x" ++ show n)) [0 :: Int ..] fts+ mss <- sequence (zipWith3 step [0 :: Int ..] xs fts)+ case sequence mss of+ Nothing -> pure Nothing+ Just steps -> do+ let (fns, wss) = unzip steps+ s0 = case mTagEv of+ Just ev -> mkApps (Var hwsSel)+ [Type intTy, ctEvExpr ev, Var saltId, mkUncheckedIntExpr (fromIntegral i)]+ Nothing -> Var saltId+ body = foldl (\s fn -> fn s) s0 fns+ pure (Just (Alt (DataAlt dc) xs body, concat wss))+ case sequence malts of+ Nothing -> pure Nothing+ Just altWss -> do+ let (alts, wss) = unzip altWss+ tagW = maybe [] (pure . mkNonCanonical) mTagEv+ impl = mkLams [atv, btv, gA, gB, saltId, tId]+ (destructInner pTc (fixed ++ [aTy, bTy]) (Cast (Var tId) (coAt2 aTy bTy)) cb intTy alts)+ subst = case classTyVars h2Cls of+ (tv : _) -> zipTvSubst [tv] [wrappedTy]+ _ -> emptySubst+ scPreds = map (substTy subst) (classSCTheta h2Cls)+ scEvs <- forM scPreds (newWanted loc)+ pure (Just ( classDict h2Cls wrappedTy (map ctEvExpr scEvs ++ [impl])+ , map mkNonCanonical scEvs ++ tagW ++ concat wss ))+ _ -> pure Nothing
+ inspection/Inspection.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fplugin=Stock -fplugin=Test.Inspection.Plugin #-}++-- | Zero-cost proof for the @stock-hashable@ companion: @Hashable@\/+-- @Hashable1@\/@Hashable2@ are /consumers/ (@hashWithSalt :: Int -> a -> Int@),+-- so wrapping the argument with the @Stock@\/@Stock1@\/@Stock2@ constructor lets+-- the plugin's unwrap coercion cancel it; 'hasNoType' certifies no wrapper type+-- survives. See @inspection/Inspection.hs@ in @stock@ for the full rationale.+-- (The result is combined with the salt so GHC can't eta-reduce to a bare+-- dictionary cast — the wrapped value is otherwise the trailing argument.)+module Main (main) where++import Stock+import Stock.Hashable ()+import Data.Hashable (Hashable, hashWithSalt)+import Data.Hashable.Lifted (Hashable1, Hashable2, liftHashWithSalt, liftHashWithSalt2)+import Data.Functor.Classes (Eq1, Eq2)+import Test.Inspection++data T = T Int Bool deriving (Eq, Hashable) via Stock T++data G a = G Int a [a]+ deriving (Eq, Hashable) via Stock (G a)+ deriving (Eq1, Hashable1) via Stock1 G++data P a b = P a b [a]+ deriving (Eq, Hashable) via Stock (P a b)+ deriving (Eq1, Hashable1) via Stock1 (P a)+ deriving (Eq2, Hashable2) via Stock2 P++sHash :: Int -> T -> Int+sHash s t = s + hashWithSalt s (Stock t)++sLiftHash :: Int -> G Int -> Int+sLiftHash s x = s + liftHashWithSalt hashWithSalt s (Stock1 x)++sLiftHash2 :: Int -> P Int Int -> Int+sLiftHash2 s x = s + liftHashWithSalt2 hashWithSalt hashWithSalt s (Stock2 x)++inspect $ 'sHash `hasNoType` ''Stock+inspect $ 'sLiftHash `hasNoType` ''Stock1+inspect $ 'sLiftHash2 `hasNoType` ''Stock2++main :: IO ()+main = putStrLn "ok: Hashable/Hashable1/Hashable2 erase the Stock wrapper (zero cost)"
+ stock-hashable.cabal view
@@ -0,0 +1,71 @@+cabal-version: 3.0+name: stock-hashable+version: 0.1.0.0+synopsis: Derive Hashable via the stock plugin+description:+ The @stock@ plugin provides a datatype for deriving and synthesising+ instances at compile time. @stock-hashable@ extends the @stock@ with+ support for @Hashable@ and higher-kinded variants.++ > {-# options_ghc -fplugin Stock #-}+ > + > {-# language DerivingVia #-}+ > + > import Stock+ > import Stock.Hashable+ > + > data Pair a b = Pair a b+ > deriving (Eq, Hashable) via Stock (Pair a b)+ > deriving (Eq1, Hashable1) via Stock1 (Pair a)+ > deriving (Eq2, Hashable2) via Stock2 Pair++ @stock-hashable@ provides three instances, that signal to the plugin+ how to derive @Hashable@.++ > instance DeriveStock Hashable ..+ > instance DeriveStock1 Hashable1 ..+ > instance DeriveStock2 Hashable2 ..+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.8.1+ , GHC == 9.10.3+ , GHC == 9.12.4+ , GHC == 9.14.1+library+ exposed-modules: Stock.Hashable+ build-depends: base >=4.18 && <5+ , ghc >=9.6 && <9.16+ , stock >=0.1 && <0.2+ , hashable >=1.4 && <1.6+ hs-source-dirs: .+ default-language: GHC2021+ ghc-options: -Wall++test-suite test+ type: exitcode-stdio-1.0+ main-is: Test.hs+ build-depends: base, stock, stock-hashable, hashable+ ghc-options: -fplugin=Stock+ hs-source-dirs: test+ default-language: GHC2021++-- zero-cost proof: Stock wrapper is fully erased+test-suite inspection+ type: exitcode-stdio-1.0+ main-is: Inspection.hs+ build-depends: base, stock, stock-hashable, hashable, inspection-testing+ ghc-options: -fplugin=Stock+ hs-source-dirs: inspection+ default-language: GHC2021+ -- no inspection-testing support+ if impl(ghc >= 9.14)+ buildable: False++source-repository head+ type: git+ location: https://github.com/Icelandjack/stock.git+ subdir: hashable
+ test/Test.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fplugin Stock #-}+module Main (main) where+import Stock (Stock(..), Stock1(..), Stock2(..))+import Stock.Hashable (Hashable(..), Hashable1(..), Hashable2(..)) -- classes + registers DeriveStock(1,2)+import Stock.Override (Override(..), Overriding1, Overriding2, Override1(..), Override2(..), Keep, type (:=))+import Data.Functor.Classes (Eq1(..), Eq2)++data T = T Int Bool deriving (Eq, Hashable) via Stock T++data G a = G Int a [a]+ deriving (Eq, Hashable) via Stock (G a)+ deriving (Eq1, Hashable1) via Stock1 G++-- the full tower: Hashable2 P needs Eq2 P (built-in) and, via the quantified+-- superclass, Hashable1 (P a) (and so Eq1/Eq/Hashable down the chain).+data P a b = P a b [a]+ deriving (Eq, Hashable) via Stock (P a b)+ deriving (Eq1, Hashable1) via Stock1 (P a)+ deriving (Eq2, Hashable2) via Stock2 P++lhws :: Hashable a => G a -> Int+lhws = liftHashWithSalt hashWithSalt 0++lhws2 :: (Hashable a, Hashable b) => P a b -> Int+lhws2 = liftHashWithSalt2 hashWithSalt hashWithSalt 0++-- An observable modifier: @Blind@ is a newtype over @[a]@ (so coercible to the+-- real field) whose 'Hashable1' ignores the elements. Honoring Override is then+-- visible: lists of different contents hash equally.+-- @Blind@ is blind across the whole tower (Eq/Eq1/Hashable/Hashable1): deriving+-- @Hashable1@/@Hashable2@ via this override drags in the @Eq1@/@Eq2@ superclass+-- through the /same/ config, so the modifier must answer for those too.+newtype Blind a = Blind [a]+instance Eq (Blind a) where _ == _ = True+instance Eq1 Blind where liftEq _ _ _ = True+instance Hashable (Blind a) where hashWithSalt s _ = s+instance Hashable1 Blind where liftHashWithSalt _ s _ = s++-- Hashable1 via Override1: the @[a]@ field hashed through @Blind@ (content blind).+data HB a = HB [a]+ deriving (Eq, Hashable) via Stock (HB a)+ deriving (Eq1, Hashable1) via Overriding1 HB '[ '[Blind] ]++-- Hashable2 via Override2: first parameter's @[a]@ hashed through @Blind@; @b@ kept.+data HB2 a b = HB2 [a] b+ deriving (Eq, Hashable) via Stock (HB2 a b)+ deriving (Eq1, Hashable1) via Stock1 (HB2 a)+ deriving (Eq2, Hashable2) via Overriding2 HB2 '[ '[Blind, Keep] ]++hb :: Hashable a => HB a -> Int+hb = liftHashWithSalt hashWithSalt 0++hb2 :: (Hashable a, Hashable b) => HB2 a b -> Int+hb2 = liftHashWithSalt2 hashWithSalt hashWithSalt 0++-- value-level Hashable via Override: @Blind0@ (newtype over Int) hashes blind,+-- so field 0's contents do not affect the hash.+newtype Blind0 = Blind0 Int deriving Eq+instance Hashable Blind0 where hashWithSalt s _ = s+-- complex config (type-keyed): every @Int@ field hashed blind.+data HV = HV Int Bool deriving Eq+ deriving Hashable via Stock (Override HV '[ Int := Blind0 ])++main :: IO ()+main | hash (T 1 True) == hash (T 1 True)+ , hash (T 1 True) /= hash (T 2 True)+ , lhws (G 1 (2 :: Int) [3]) == lhws (G 1 (2 :: Int) [3])+ , lhws (G 1 (2 :: Int) [3]) /= lhws (G 1 (9 :: Int) [3])+ , lhws2 (P (1 :: Int) 'c' [2]) == lhws2 (P (1 :: Int) 'c' [2])+ , lhws2 (P (1 :: Int) 'c' [2]) /= lhws2 (P (1 :: Int) 'd' [2])+ -- Override1: @Blind@ ignores contents, so differing lists hash equally.+ , hb (HB [1, 2, 3 :: Int]) == hb (HB [9 :: Int])+ -- Override2: list blind, but the kept @b@ still distinguishes.+ , hb2 (HB2 [1, 2 :: Int] 'c') == hb2 (HB2 [7, 8, 9 :: Int] 'c')+ , hb2 (HB2 [1, 2 :: Int] 'c') /= hb2 (HB2 [1, 2 :: Int] 'd')+ -- value Override: HV's Int field hashed blind, so its contents don't matter.+ , hash (HV 1 True) == hash (HV 999 True)+ , hash (HV 1 True) /= hash (HV 1 False)+ = putStrLn "ok: Hashable + Hashable1 + Hashable2 (incl. Override + Override1/2) via stock-hashable"+ | otherwise = error "hashable mismatch"