{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,
             ScopedTypeVariables, TypeOperators,
             MultiParamTypeClasses, GADTs, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

------------------------------------------------------------------------
-- |
-- Module      :  Data.Hashable.Generic.Instances
-- Copyright   :  (c) Bryan O'Sullivan 2012
-- SPDX-License-Identifier : BSD-3-Clause
-- Maintainer  :  bos@serpentine.com
-- Stability   :  provisional
-- Portability :  GHC >= 7.4
--
-- Internal module defining orphan instances for "GHC.Generics"
--
module Data.Hashable.Generic.Instances () where

import Data.Hashable.Class
import GHC.Generics

#if MIN_VERSION_base(4,9,0)
import Data.Kind (Type)
#else
#define Type *
#endif


-- Type without constructors
instance GHashable arity V1 where
    ghashWithSalt :: HashArgs arity a -> Int -> V1 a -> Int
ghashWithSalt HashArgs arity a
_ Int
salt V1 a
_ = Int -> () -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt ()

-- Constructor without arguments
instance GHashable arity U1 where
    ghashWithSalt :: HashArgs arity a -> Int -> U1 a -> Int
ghashWithSalt HashArgs arity a
_ Int
salt U1 a
U1 = Int -> () -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt ()

instance (GHashable arity a, GHashable arity b) => GHashable arity (a :*: b) where
    ghashWithSalt :: HashArgs arity a -> Int -> (:*:) a b a -> Int
ghashWithSalt HashArgs arity a
toHash Int
salt (a a
x :*: b a
y) =
      (HashArgs arity a -> Int -> b a -> Int
forall arity (f :: * -> *) a.
GHashable arity f =>
HashArgs arity a -> Int -> f a -> Int
ghashWithSalt HashArgs arity a
toHash (HashArgs arity a -> Int -> a a -> Int
forall arity (f :: * -> *) a.
GHashable arity f =>
HashArgs arity a -> Int -> f a -> Int
ghashWithSalt HashArgs arity a
toHash Int
salt a a
x) b a
y)

-- Metadata (constructor name, etc)
instance GHashable arity a => GHashable arity (M1 i c a) where
    ghashWithSalt :: HashArgs arity a -> Int -> M1 i c a a -> Int
ghashWithSalt HashArgs arity a
targs Int
salt = HashArgs arity a -> Int -> a a -> Int
forall arity (f :: * -> *) a.
GHashable arity f =>
HashArgs arity a -> Int -> f a -> Int
ghashWithSalt HashArgs arity a
targs Int
salt (a a -> Int) -> (M1 i c a a -> a a) -> M1 i c a a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c a a -> a a
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

-- Constants, additional parameters, and rank-1 recursion
instance Hashable a => GHashable arity (K1 i a) where
    ghashWithSalt :: HashArgs arity a -> Int -> K1 i a a -> Int
ghashWithSalt HashArgs arity a
_ = (K1 i a a -> a) -> Int -> K1 i a a -> Int
forall b a. Hashable b => (a -> b) -> Int -> a -> Int
hashUsing K1 i a a -> a
forall i c k (p :: k). K1 i c p -> c
unK1

instance GHashable One Par1 where
    ghashWithSalt :: HashArgs One a -> Int -> Par1 a -> Int
ghashWithSalt (HashArgs1 h) Int
salt = Int -> a -> Int
h Int
salt (a -> Int) -> (Par1 a -> a) -> Par1 a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Par1 a -> a
forall p. Par1 p -> p
unPar1

instance Hashable1 f => GHashable One (Rec1 f) where
    ghashWithSalt :: HashArgs One a -> Int -> Rec1 f a -> Int
ghashWithSalt (HashArgs1 h) Int
salt = (Int -> a -> Int) -> Int -> f a -> Int
forall (t :: * -> *) a.
Hashable1 t =>
(Int -> a -> Int) -> Int -> t a -> Int
liftHashWithSalt Int -> a -> Int
h Int
salt (f a -> Int) -> (Rec1 f a -> f a) -> Rec1 f a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec1 f a -> f a
forall k (f :: k -> *) (p :: k). Rec1 f p -> f p
unRec1

instance (Hashable1 f, GHashable One g) => GHashable One (f :.: g) where
    ghashWithSalt :: HashArgs One a -> Int -> (:.:) f g a -> Int
ghashWithSalt HashArgs One a
targs Int
salt = (Int -> g a -> Int) -> Int -> f (g a) -> Int
forall (t :: * -> *) a.
Hashable1 t =>
(Int -> a -> Int) -> Int -> t a -> Int
liftHashWithSalt (HashArgs One a -> Int -> g a -> Int
forall arity (f :: * -> *) a.
GHashable arity f =>
HashArgs arity a -> Int -> f a -> Int
ghashWithSalt HashArgs One a
targs) Int
salt (f (g a) -> Int) -> ((:.:) f g a -> f (g a)) -> (:.:) f g a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.:) f g a -> f (g a)
forall k2 (f :: k2 -> *) k1 (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1

class SumSize f => GSum arity f where
    hashSum :: HashArgs arity a -> Int -> Int -> f a -> Int
    -- hashSum args salt index value = ...

-- [Note: Hashing a sum type]
--
-- The tree structure is used in GHC.Generics to represent the sum (and
-- product) part of the generic represention of the type, e.g.:
--
--   (C0 ... :+: C1 ...) :+: (C2 ... :+: (C3 ... :+: C4 ...))
--
-- The value constructed with C2 constructor is represented as (R1 (L1 ...)).
-- Yet, if we think that this tree is a flat (heterogenous) list:
--
--   [C0 ..., C1 ..., C2 ..., C3 ..., C4... ]
--
-- then the value constructed with C2 is a (dependent) pair (2, ...), and
-- hashing it is simple:
--
--   salt `hashWithSalt` (2 :: Int) `hashWithSalt` ...
--
-- This is what we do below. When drilling down the tree, we count how many
-- leafs are to the left (`index` variable). At the leaf case C1, we'll have an
-- actual index into the sum.
--
-- This works well for balanced data. However for recursive types like:
--
--   data Nat = Z | S Nat
--
-- the `hashWithSalt salt (S (S (S Z)))` is
--
--   salt `hashWithSalt` (1 :: Int) -- first S
--        `hashWithSalt` (1 :: Int) -- second S
--        `hashWithSalt` (1 :: Int) -- third S
--        `hashWithSalt` (0 :: Int) -- Z
--        `hashWithSalt` ()         -- U1
--
-- For that type the manual implementation:
--
--    instance Hashable Nat where
--        hashWithSalt salt n = hashWithSalt salt (natToInteger n)
--
-- would be better performing CPU and hash-quality wise (assuming that
-- Integer's Hashable is of high quality).
--
instance (GSum arity a, GSum arity b) => GHashable arity (a :+: b) where
    ghashWithSalt :: HashArgs arity a -> Int -> (:+:) a b a -> Int
ghashWithSalt HashArgs arity a
toHash Int
salt = HashArgs arity a -> Int -> Int -> (:+:) a b a -> Int
forall arity (f :: * -> *) a.
GSum arity f =>
HashArgs arity a -> Int -> Int -> f a -> Int
hashSum HashArgs arity a
toHash Int
salt Int
0

instance (GSum arity a, GSum arity b) => GSum arity (a :+: b) where
    hashSum :: HashArgs arity a -> Int -> Int -> (:+:) a b a -> Int
hashSum HashArgs arity a
toHash !Int
salt !Int
index (:+:) a b a
s = case (:+:) a b a
s of
        L1 a a
x -> HashArgs arity a -> Int -> Int -> a a -> Int
forall arity (f :: * -> *) a.
GSum arity f =>
HashArgs arity a -> Int -> Int -> f a -> Int
hashSum HashArgs arity a
toHash Int
salt Int
index a a
x
        R1 b a
x -> HashArgs arity a -> Int -> Int -> b a -> Int
forall arity (f :: * -> *) a.
GSum arity f =>
HashArgs arity a -> Int -> Int -> f a -> Int
hashSum HashArgs arity a
toHash Int
salt (Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sizeL) b a
x
      where
        sizeL :: Int
sizeL = Tagged a -> Int
forall (s :: * -> *). Tagged s -> Int
unTagged (Tagged a
forall (f :: * -> *). SumSize f => Tagged f
sumSize :: Tagged a)
    {-# INLINE hashSum #-}

instance GHashable arity a => GSum arity (C1 c a) where
    hashSum :: HashArgs arity a -> Int -> Int -> C1 c a a -> Int
hashSum HashArgs arity a
toHash !Int
salt !Int
index (M1 a a
x) = HashArgs arity a -> Int -> a a -> Int
forall arity (f :: * -> *) a.
GHashable arity f =>
HashArgs arity a -> Int -> f a -> Int
ghashWithSalt HashArgs arity a
toHash (Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt Int
index) a a
x
    {-# INLINE hashSum #-}

class SumSize f where
    sumSize :: Tagged f

newtype Tagged (s :: Type -> Type) = Tagged {Tagged s -> Int
unTagged :: Int}

instance (SumSize a, SumSize b) => SumSize (a :+: b) where
    sumSize :: Tagged (a :+: b)
sumSize = Int -> Tagged (a :+: b)
forall (s :: * -> *). Int -> Tagged s
Tagged (Int -> Tagged (a :+: b)) -> Int -> Tagged (a :+: b)
forall a b. (a -> b) -> a -> b
$ Tagged a -> Int
forall (s :: * -> *). Tagged s -> Int
unTagged (Tagged a
forall (f :: * -> *). SumSize f => Tagged f
sumSize :: Tagged a) Int -> Int -> Int
forall a. Num a => a -> a -> a
+
                       Tagged b -> Int
forall (s :: * -> *). Tagged s -> Int
unTagged (Tagged b
forall (f :: * -> *). SumSize f => Tagged f
sumSize :: Tagged b)

instance SumSize (C1 c a) where
    sumSize :: Tagged (C1 c a)
sumSize = Int -> Tagged (C1 c a)
forall (s :: * -> *). Int -> Tagged s
Tagged Int
1