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/Stock/Hashable.hs b/Stock/Hashable.hs new file mode 100644 --- /dev/null +++ b/Stock/Hashable.hs @@ -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 diff --git a/inspection/Inspection.hs b/inspection/Inspection.hs new file mode 100644 --- /dev/null +++ b/inspection/Inspection.hs @@ -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)" diff --git a/stock-hashable.cabal b/stock-hashable.cabal new file mode 100644 --- /dev/null +++ b/stock-hashable.cabal @@ -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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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"