1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
{-# LANGUAGE BangPatterns, FlexibleInstances, KindSignatures,
ScopedTypeVariables, TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
------------------------------------------------------------------------
-- |
-- Module : Data.Hashable.Generic
-- Copyright : (c) Bryan O'Sullivan 2012
-- License : BSD-style
-- Maintainer : bos@serpentine.com
-- Stability : provisional
-- Portability : GHC >= 7.2
--
-- Hashable support for GHC generics.
module Data.Hashable.Generic
(
) where
import Data.Bits (Bits, shiftR)
import Data.Hashable.Class
import GHC.Generics
-- Type without constructors
instance GHashable V1 where
ghashWithSalt salt _ = hashWithSalt salt ()
-- Constructor without arguments
instance GHashable U1 where
ghashWithSalt salt U1 = hashWithSalt salt ()
instance (GHashable a, GHashable b) => GHashable (a :*: b) where
ghashWithSalt salt (x :*: y) = salt `ghashWithSalt` x `ghashWithSalt` y
-- Metadata (constructor name, etc)
instance GHashable a => GHashable (M1 i c a) where
ghashWithSalt salt = ghashWithSalt salt . unM1
-- Constants, additional parameters, and rank-1 recursion
instance Hashable a => GHashable (K1 i a) where
ghashWithSalt = hashUsing unK1
class GSum f where
hashSum :: Int -> Int -> Int -> f a -> Int
instance (GSum a, GSum b, GHashable a, GHashable b,
SumSize a, SumSize b) => GHashable (a :+: b) where
ghashWithSalt salt = hashSum salt 0 size
where size = unTagged (sumSize :: Tagged (a :+: b))
instance (GSum a, GSum b, GHashable a, GHashable b) => GSum (a :+: b) where
hashSum !salt !code !size s = case s of
L1 x -> hashSum salt code sizeL x
R1 x -> hashSum salt (code + sizeL) sizeR x
where
sizeL = size `shiftR` 1
sizeR = size - sizeL
{-# INLINE hashSum #-}
instance GHashable a => GSum (C1 c a) where
hashSum !salt !code _ x = salt `hashWithSalt` code `ghashWithSalt` x
{-# INLINE hashSum #-}
class SumSize f where
sumSize :: Tagged f
newtype Tagged (s :: * -> *) = Tagged {unTagged :: Int}
instance (SumSize a, SumSize b) => SumSize (a :+: b) where
sumSize = Tagged $ unTagged (sumSize :: Tagged a) +
unTagged (sumSize :: Tagged b)
instance SumSize (C1 c a) where
sumSize = Tagged 1
|
