1{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, 2 ScopedTypeVariables, TypeOperators, 3 MultiParamTypeClasses, GADTs, FlexibleContexts #-} 4{-# OPTIONS_GHC -fno-warn-orphans #-} 5 6------------------------------------------------------------------------ 7-- | 8-- Module : Data.Hashable.Generic.Instances 9-- Copyright : (c) Bryan O'Sullivan 2012 10-- SPDX-License-Identifier : BSD-3-Clause 11-- Maintainer : bos@serpentine.com 12-- Stability : provisional 13-- Portability : GHC >= 7.4 14-- 15-- Internal module defining orphan instances for "GHC.Generics" 16-- 17module Data.Hashable.Generic.Instances () where 18 19import Data.Hashable.Class 20import GHC.Generics 21 22#if MIN_VERSION_base(4,9,0) 23import Data.Kind (Type) 24#else 25#define Type * 26#endif 27 28 29-- Type without constructors 30instance GHashable arity V1 where 31 ghashWithSalt _ salt _ = hashWithSalt salt () 32 33-- Constructor without arguments 34instance GHashable arity U1 where 35 ghashWithSalt _ salt U1 = hashWithSalt salt () 36 37instance (GHashable arity a, GHashable arity b) => GHashable arity (a :*: b) where 38 ghashWithSalt toHash salt (x :*: y) = 39 (ghashWithSalt toHash (ghashWithSalt toHash salt x) y) 40 41-- Metadata (constructor name, etc) 42instance GHashable arity a => GHashable arity (M1 i c a) where 43 ghashWithSalt targs salt = ghashWithSalt targs salt . unM1 44 45-- Constants, additional parameters, and rank-1 recursion 46instance Hashable a => GHashable arity (K1 i a) where 47 ghashWithSalt _ = hashUsing unK1 48 49instance GHashable One Par1 where 50 ghashWithSalt (HashArgs1 h) salt = h salt . unPar1 51 52instance Hashable1 f => GHashable One (Rec1 f) where 53 ghashWithSalt (HashArgs1 h) salt = liftHashWithSalt h salt . unRec1 54 55instance (Hashable1 f, GHashable One g) => GHashable One (f :.: g) where 56 ghashWithSalt targs salt = liftHashWithSalt (ghashWithSalt targs) salt . unComp1 57 58class SumSize f => GSum arity f where 59 hashSum :: HashArgs arity a -> Int -> Int -> f a -> Int 60 -- hashSum args salt index value = ... 61 62-- [Note: Hashing a sum type] 63-- 64-- The tree structure is used in GHC.Generics to represent the sum (and 65-- product) part of the generic represention of the type, e.g.: 66-- 67-- (C0 ... :+: C1 ...) :+: (C2 ... :+: (C3 ... :+: C4 ...)) 68-- 69-- The value constructed with C2 constructor is represented as (R1 (L1 ...)). 70-- Yet, if we think that this tree is a flat (heterogenous) list: 71-- 72-- [C0 ..., C1 ..., C2 ..., C3 ..., C4... ] 73-- 74-- then the value constructed with C2 is a (dependent) pair (2, ...), and 75-- hashing it is simple: 76-- 77-- salt `hashWithSalt` (2 :: Int) `hashWithSalt` ... 78-- 79-- This is what we do below. When drilling down the tree, we count how many 80-- leafs are to the left (`index` variable). At the leaf case C1, we'll have an 81-- actual index into the sum. 82-- 83-- This works well for balanced data. However for recursive types like: 84-- 85-- data Nat = Z | S Nat 86-- 87-- the `hashWithSalt salt (S (S (S Z)))` is 88-- 89-- salt `hashWithSalt` (1 :: Int) -- first S 90-- `hashWithSalt` (1 :: Int) -- second S 91-- `hashWithSalt` (1 :: Int) -- third S 92-- `hashWithSalt` (0 :: Int) -- Z 93-- `hashWithSalt` () -- U1 94-- 95-- For that type the manual implementation: 96-- 97-- instance Hashable Nat where 98-- hashWithSalt salt n = hashWithSalt salt (natToInteger n) 99-- 100-- would be better performing CPU and hash-quality wise (assuming that 101-- Integer's Hashable is of high quality). 102-- 103instance (GSum arity a, GSum arity b) => GHashable arity (a :+: b) where 104 ghashWithSalt toHash salt = hashSum toHash salt 0 105 106instance (GSum arity a, GSum arity b) => GSum arity (a :+: b) where 107 hashSum toHash !salt !index s = case s of 108 L1 x -> hashSum toHash salt index x 109 R1 x -> hashSum toHash salt (index + sizeL) x 110 where 111 sizeL = unTagged (sumSize :: Tagged a) 112 {-# INLINE hashSum #-} 113 114instance GHashable arity a => GSum arity (C1 c a) where 115 hashSum toHash !salt !index (M1 x) = ghashWithSalt toHash (hashWithSalt salt index) x 116 {-# INLINE hashSum #-} 117 118class SumSize f where 119 sumSize :: Tagged f 120 121newtype Tagged (s :: Type -> Type) = Tagged {unTagged :: Int} 122 123instance (SumSize a, SumSize b) => SumSize (a :+: b) where 124 sumSize = Tagged $ unTagged (sumSize :: Tagged a) + 125 unTagged (sumSize :: Tagged b) 126 127instance SumSize (C1 c a) where 128 sumSize = Tagged 1 129