Hash.hs

-- | Generic hashing on trees. We recursively compute hashes of all subtrees,
-- giving fast inequality testing, and a fast, but meaningless (more-or-less random)
-- ordering on the set of trees (so that we can put them into Map-s).
--
-- The way it works is that when we compute the hash of a node, we use the hashes of the 
-- children directly; this way, you can also incrementally build up a hashed tree.
--
module Data.Generics.Fixplate.Hash
  ( -- * Type classes for different hash functions
    module Data.Generics.Fixplate.Hash.Class
    -- * Hashed tree type
  , HashAnn(..) , getHash , unHashAnn
  , HashMu , topHash
  , forgetHash
    -- * Hashing tres
  , hashTree , hashTreeWith
  , hashNode , hashNodeWith
  ) where

--------------------------------------------------------------------------------

import Data.Generics.Fixplate.Hash.Class

import Control.Monad ( liftM )
import Control.Applicative ( (<$>) )

import Data.Generics.Fixplate
import Data.Foldable    as F
import Data.Traversable as T

import Text.Show

--------------------------------------------------------------------------------

-- | Hash annotation (question: should the Hash field be strict? everything else in the library is lazy...)
--
-- This is custom datatype instead of reusing 'Ann' because of the different Eq\/Ord instances we need.
--
data HashAnn hash f a = HashAnn hash (f a) deriving Show

getHash :: HashAnn hash f a -> hash
getHash (HashAnn hash _) = hash

unHashAnn :: HashAnn hash f a -> f a
unHashAnn (HashAnn _ x) = x

--------------------------------------------------------------------------------

-- | A tree annotated with hashes of all subtrees. This gives us fast inequality testing,
-- and fast (but meaningless!) ordering for 'Map'-s.
type HashMu hash f = Mu (HashAnn hash f) 

-- | The hash of the complete tree.
topHash :: HashMu hash f -> hash
topHash (Fix (HashAnn hash _)) = hash

--------------------------------------------------------------------------------

{-
-- | This is a newtype so that we can define the 'Hashable' instance in Haskell98.
-- With the @FlexibleInstances@ extensions, this is not necessary.
newtype HashableHashMu hash f = HHMu { unHHMu :: HashMu hash f } deriving (Eq,Ord,Show)

-- | This is a rather tricky instance, in the sense that
-- 
-- > computeHash tree /= topHash tree
--
-- Actually, the above does not even type-checks... 
-- But in practice, we would use the same type for both sides, so be careful.
--
instance HashValue hash => Hashable (HashableHashMu hash f) where
  hashDigest t = hashDigest (topHash (unHHMu t))
-}

--------------------------------------------------------------------------------

instance Functor f => Functor (HashAnn hash f) where
  fmap f (HashAnn attr t) = HashAnn attr (fmap f t)

instance Foldable f => Foldable (HashAnn hash f) where
  foldl f x (HashAnn _ t) = F.foldl f x t
  foldr f x (HashAnn _ t) = F.foldr f x t

instance Traversable f => Traversable (HashAnn hash f) where
  traverse f (HashAnn x t) = HashAnn x <$> T.traverse f t
  mapM f (HashAnn x t) = liftM (HashAnn x) (T.mapM f t)

--------------------------------------------------------------------------------

instance (Eq hash, EqF f) => EqF (HashAnn hash f) where
  equalF (HashAnn h1 x1) (HashAnn h2 x2) = if h1 /= h2 then False else equalF x1 x2 

instance (Ord hash, OrdF f) => OrdF (HashAnn hash f) where
  compareF (HashAnn h1 x1) (HashAnn h2 x2) = case compare h1 h2 of
    LT -> LT
    GT -> GT
    EQ -> compareF x1 x2

instance (Eq hash, ShowF f, Show hash) => ShowF (HashAnn hash f) where
  showsPrecF d (HashAnn hash x) = showParen (d>app_prec) 
    $ showString "HashAnn " 
    . showsPrec  (app_prec+1) hash 
    . showChar ' '
    . showsPrecF (app_prec+1) x
    where
      app_prec = 10

--------------------------------------------------------------------------------

forgetHash :: Functor f => HashMu hash f -> Mu f
forgetHash = go where
  go = Fix . fmap go . unHashAnn . unFix 

--------------------------------------------------------------------------------

data Void = Void ; instance Show Void where show _ = "_"

{-# INLINE showDigest #-}
showDigest :: (Functor f, ShowF f, HashValue hash) => f a -> hash -> hash
showDigest t = hashDigest $ showF (fmap (const Void) t) 

--------------------------------------------------------------------------------

-- | This function uses the 'ShowF' instance to compute
-- the hash of a node; this way you always have a working
-- version without writing any additional code.
--
-- However, you can also supply your own hash implementation 
-- (which can be more efficient, for example), if you use 'hashTreeWith' instead.
hashTree :: (Foldable f, Functor f, ShowF f, HashValue hash) => Mu f -> HashMu hash f 
hashTree = hashTreeWith showDigest

hashTreeWith :: (Foldable f, Functor f, HashValue hash) => (f Hole -> hash -> hash) -> Mu f -> HashMu hash f 
hashTreeWith user = go where
  go (Fix x) = hashNodeWith user (fmap go x)

--------------------------------------------------------------------------------

-- | Build a hashed node from the children.
hashNode :: (Foldable f, Functor f, ShowF f, HashValue hash) => f (HashMu hash f) -> HashMu hash f 
hashNode = hashNodeWith showDigest

hashNodeWith :: (Foldable f, Functor f, HashValue hash) => (f Hole -> hash -> hash) -> f (HashMu hash f) -> HashMu hash f 
hashNodeWith user x = Fix (HashAnn h x) where
  h  = user (fmap (const Hole) x) h0
  h0 = computeHash $ toList $ fmap (getHash . unFix) x
--  h0 = foldl' (flip hashHash) emptyHash $ toList $ fmap (getHash . unFix) x

--------------------------------------------------------------------------------