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