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