1{-# LANGUAGE BangPatterns, 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-- Type without constructors 23instance GHashable arity V1 where 24 ghashWithSalt _ salt _ = hashWithSalt salt () 25 26-- Constructor without arguments 27instance GHashable arity U1 where 28 ghashWithSalt _ salt U1 = hashWithSalt salt () 29 30instance (GHashable arity a, GHashable arity b) => GHashable arity (a :*: b) where 31 ghashWithSalt toHash salt (x :*: y) = 32 (ghashWithSalt toHash (ghashWithSalt toHash salt x) y) 33 34-- Metadata (constructor name, etc) 35instance GHashable arity a => GHashable arity (M1 i c a) where 36 ghashWithSalt targs salt = ghashWithSalt targs salt . unM1 37 38-- Constants, additional parameters, and rank-1 recursion 39instance Hashable a => GHashable arity (K1 i a) where 40 ghashWithSalt _ = hashUsing unK1 41 42instance GHashable One Par1 where 43 ghashWithSalt (HashArgs1 h) salt = h salt . unPar1 44 45instance Hashable1 f => GHashable One (Rec1 f) where 46 ghashWithSalt (HashArgs1 h) salt = liftHashWithSalt h salt . unRec1 47 48instance (Hashable1 f, GHashable One g) => GHashable One (f :.: g) where 49 ghashWithSalt targs salt = liftHashWithSalt (ghashWithSalt targs) salt . unComp1 50 51class SumSize f => GSum arity f where 52 hashSum :: HashArgs arity a -> Int -> Int -> f a -> Int 53 -- hashSum args salt index value = ... 54 55-- [Note: Hashing a sum type] 56-- 57-- The tree structure is used in GHC.Generics to represent the sum (and 58-- product) part of the generic represention of the type, e.g.: 59-- 60-- (C0 ... :+: C1 ...) :+: (C2 ... :+: (C3 ... :+: C4 ...)) 61-- 62-- The value constructed with C2 constructor is represented as (R1 (L1 ...)). 63-- Yet, if we think that this tree is a flat (heterogenous) list: 64-- 65-- [C0 ..., C1 ..., C2 ..., C3 ..., C4... ] 66-- 67-- then the value constructed with C2 is a (dependent) pair (2, ...), and 68-- hashing it is simple: 69-- 70-- salt `hashWithSalt` (2 :: Int) `hashWithSalt` ... 71-- 72-- This is what we do below. When drilling down the tree, we count how many 73-- leafs are to the left (`index` variable). At the leaf case C1, we'll have an 74-- actual index into the sum. 75-- 76-- This works well for balanced data. However for recursive types like: 77-- 78-- data Nat = Z | S Nat 79-- 80-- the `hashWithSalt salt (S (S (S Z)))` is 81-- 82-- salt `hashWithSalt` (1 :: Int) -- first S 83-- `hashWithSalt` (1 :: Int) -- second S 84-- `hashWithSalt` (1 :: Int) -- third S 85-- `hashWithSalt` (0 :: Int) -- Z 86-- `hashWithSalt` () -- U1 87-- 88-- For that type the manual implementation: 89-- 90-- instance Hashable Nat where 91-- hashWithSalt salt n = hashWithSalt salt (natToInteger n) 92-- 93-- would be better performing CPU and hash-quality wise (assuming that 94-- Integer's Hashable is of high quality). 95-- 96instance (GSum arity a, GSum arity b) => GHashable arity (a :+: b) where 97 ghashWithSalt toHash salt = hashSum toHash salt 0 98 99instance (GSum arity a, GSum arity b) => GSum arity (a :+: b) where 100 hashSum toHash !salt !index s = case s of 101 L1 x -> hashSum toHash salt index x 102 R1 x -> hashSum toHash salt (index + sizeL) x 103 where 104 sizeL = unTagged (sumSize :: Tagged a) 105 {-# INLINE hashSum #-} 106 107instance GHashable arity a => GSum arity (C1 c a) where 108 hashSum toHash !salt !index (M1 x) = ghashWithSalt toHash (hashWithSalt salt index) x 109 {-# INLINE hashSum #-} 110 111class SumSize f where 112 sumSize :: Tagged f 113 114newtype Tagged (s :: * -> *) = Tagged {unTagged :: Int} 115 116instance (SumSize a, SumSize b) => SumSize (a :+: b) where 117 sumSize = Tagged $ unTagged (sumSize :: Tagged a) + 118 unTagged (sumSize :: Tagged b) 119 120instance SumSize (C1 c a) where 121 sumSize = Tagged 1 122