{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
--------------------------------------------------------------------
-- |
-- Module    :  Ermine.Syntax.Digest
-- Copyright :  (c) Edward Kmett 2011-12
-- License   :  BSD3
-- Maintainer:  Edward Kmett <ekmett@gmail.com>
-- Stability :  experimental
-- Portability: non-portable
--
--------------------------------------------------------------------
module Ermine.Syntax.Digest
  (
  -- * Constructing Digests
    Digestable(..)
  , Digestable1(..)
  ) where

import Bound
import Crypto.Hash.MD5
import Data.Binary
import Data.Binary.Builder
import Data.Binary.Put
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Text as SText
import qualified Data.Text.Encoding as SText
import qualified Data.Text.Lazy as LText
import Data.Int
import Data.Void
import GHC.Generics
import Prelude.Extras

nullBS :: Strict.ByteString
nullBS = Strict.pack [0]


--------------------------------------------------------------------
-- MD5
--------------------------------------------------------------------

class Digestable t where
  -- | update a hash. This will default to updating using 'show' if not specified
  digest :: Ctx -> t -> Ctx
#ifndef HLINT
  default digest :: (Generic t, GDigestable (Rep t)) => Ctx -> t -> Ctx
  digest c = gdigest c . from
#endif

  digestList :: Ctx -> [t] -> Ctx
  digestList = Prelude.foldr (\e c -> update (digest c e) nullBS)

class Digestable1 t where
  digest1 :: Digestable a => Ctx -> t a -> Ctx
#ifndef HLINT
  default digest1 :: Digestable (t a) => Ctx -> t a -> Ctx
  digest1 = digest
#endif

instance Digestable1 Maybe
instance Digestable a => Digestable (Maybe a)

instance (Digestable b, Digestable v) => Digestable (Var b v) where

instance (Digestable1 f, Digestable a) => Digestable (Lift1 f a) where
  digest c (Lift1 x) = digest1 c x

instance (Digestable b, Digestable1 f, Functor f, Digestable v) => Digestable (Scope b f v) where
  digest c (Scope e) = digest1 c $ (fmap . fmap) Lift1 e

instance Digestable t => Digestable [t] where
  digest = digestList

instance Digestable Lazy.ByteString where
  digest c = Prelude.foldr (flip update) c . Lazy.toChunks

instance Digestable LText.Text where
  digest c = Prelude.foldr (flip update . SText.encodeUtf8) c
           . LText.toChunks

instance Digestable ()

instance Digestable a => Digestable1 ((,) a)
instance (Digestable a, Digestable b) => Digestable (a,b)

digestBinary :: Binary b => Ctx -> b -> Ctx
digestBinary c = digest c . runPut . put

instance Digestable Int where digest = digestBinary
instance Digestable Int8 where digest = digestBinary
instance Digestable Int16 where digest = digestBinary
instance Digestable Int32 where digest = digestBinary
instance Digestable Int64 where digest = digestBinary
instance Digestable Word where digest = digestBinary
instance Digestable Word8 where digest = digestBinary
instance Digestable Word16 where digest = digestBinary
instance Digestable Word32 where digest = digestBinary
instance Digestable Word64 where digest = digestBinary
instance Digestable Float where digest = digestBinary
instance Digestable Double where digest = digestBinary
instance Digestable Integer where digest = digestBinary
instance Digestable Char where
  digest = digestBinary
  digestList c xs = update c (UTF8.fromString xs)

instance Digestable Strict.ByteString where
  digest = update

instance Digestable SText.Text where
  digest c = update c . SText.encodeUtf8

instance Digestable Builder where
  digest c = digest c . toLazyByteString

instance Digestable Void

class GDigestable f where
  gdigest :: Ctx -> f a -> Ctx

instance GDigestable V1 where
  gdigest _ = error "Digesting void"

instance GDigestable U1 where
  gdigest c _ = c

instance (GDigestable f, GDigestable g) => GDigestable (f :*: g) where
  gdigest c (x :*: y) = c `gdigest` x `gdigest` y

instance (GDigestable f, GDigestable g) => GDigestable (f :+: g) where
  gdigest c (L1 x) = c `digest` Strict.singleton 1 `gdigest` x
  gdigest c (R1 y) = c `digest` Strict.singleton 2 `gdigest` y

instance GDigestable f => GDigestable (M1 i c f) where
  gdigest c (M1 x) = c `gdigest` x

instance Digestable a => GDigestable (K1 i a) where
  gdigest c (K1 x) = c `digest` x