module Data.LargeHashable.Class (
LargeHashable(..), largeHash, LargeHashable'(..)
) where
import Data.Bits
import Data.Fixed
import Data.Foldable
import Data.Int
import Data.LargeHashable.Intern
import Data.Ratio
import Data.Time
import Data.Time.Clock.TAI
import Data.Void (Void)
import Data.Word
import Foreign.C.Types
import Foreign.Ptr
import GHC.Generics
import qualified Codec.Binary.UTF8.Light as Utf8
import qualified Data.Aeson as J
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Internal as BLI
import qualified Data.ByteString.Short as BS
import qualified Data.Foldable as F
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.HashSet as HashSet
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Map as M
import qualified Data.Scientific as Sci
import qualified Data.Sequence as Seq
import qualified Data.Set as S
import qualified Data.Strict.Tuple as Tuple
import qualified Data.Text as T
import qualified Data.Text.Foreign as TF
import qualified Data.Text.Internal.Lazy as TLI
import qualified Data.Text.Lazy as TL
import qualified Data.Vector as V
class LargeHashable a where
updateHash :: a -> LH ()
default updateHash :: (GenericLargeHashable (Rep a), Generic a) => a -> LH ()
updateHash = updateHashGeneric . from
class LargeHashable' t where
updateHash' :: LargeHashable a => t a -> LH ()
largeHash :: LargeHashable a => HashAlgorithm h -> a -> h
largeHash algo x = runLH algo (updateHash x)
updateHashTextData :: T.Text -> LH ()
updateHashTextData !t = do
updates <- hashUpdates
ioInLH $ do
TF.useAsPtr t $ \valPtr units ->
hu_updatePtr updates (castPtr valPtr) (fromIntegral (2 * units))
return ()
updateHashText :: T.Text -> LH ()
updateHashText !t = do
updateHashTextData t
updates <- hashUpdates
ioInLH $ hu_updateULong updates (fromIntegral (T.length t))
instance LargeHashable T.Text where
updateHash = updateHashText
updateHashLazyText :: Int -> TL.Text -> LH ()
updateHashLazyText !len (TLI.Chunk !t !next) = do
updateHashTextData t
updateHashLazyText (len + T.length t) next
updateHashLazyText !len TLI.Empty = updateHash len
instance LargeHashable TL.Text where
updateHash = updateHashLazyText 0
updateHashByteStringData :: B.ByteString -> LH ()
updateHashByteStringData !b = do
updates <- hashUpdates
ioInLH $ do
ptr <- B.useAsCString b return
hu_updatePtr updates (castPtr ptr) (B.length b)
updateHashByteString :: B.ByteString -> LH ()
updateHashByteString !b = do
updateHashByteStringData b
updates <- hashUpdates
ioInLH $ hu_updateULong updates (fromIntegral (B.length b))
instance LargeHashable B.ByteString where
updateHash = updateHashByteString
updateHashLazyByteString :: Int -> BL.ByteString -> LH ()
updateHashLazyByteString !len (BLI.Chunk !bs !next) = do
updateHashByteStringData bs
updateHashLazyByteString (len + B.length bs) next
updateHashLazyByteString !len BLI.Empty = updateHash len
instance LargeHashable BL.ByteString where
updateHash = updateHashLazyByteString 0
instance LargeHashable BS.ShortByteString where
updateHash = updateHash . BS.fromShort
updateHashWithFun :: (HashUpdates -> a -> IO ()) -> a -> LH ()
updateHashWithFun f x =
do updates <- hashUpdates
ioInLH $ f updates x
instance LargeHashable Int where
updateHash = updateHashWithFun hu_updateLong . fromIntegral
instance LargeHashable Int8 where
updateHash = updateHashWithFun hu_updateChar
instance LargeHashable Int16 where
updateHash = updateHashWithFun hu_updateShort
instance LargeHashable Int32 where
updateHash = updateHashWithFun hu_updateInt
instance LargeHashable Int64 where
updateHash = updateHashWithFun hu_updateLong
instance LargeHashable Word where
updateHash = updateHashWithFun hu_updateLong . fromIntegral
instance LargeHashable Word8 where
updateHash = updateHashWithFun hu_updateUChar
instance LargeHashable Word16 where
updateHash = updateHashWithFun hu_updateUShort
instance LargeHashable Word32 where
updateHash = updateHashWithFun hu_updateUInt
instance LargeHashable Word64 where
updateHash = updateHashWithFun hu_updateULong . fromIntegral
instance LargeHashable CChar where
updateHash (CChar i) = updateHashWithFun hu_updateChar i
instance LargeHashable CShort where
updateHash (CShort i) = updateHashWithFun hu_updateShort i
instance LargeHashable CInt where
updateHash (CInt i) = updateHashWithFun hu_updateInt i
instance LargeHashable CLong where
updateHash (CLong i) = updateHashWithFun hu_updateLong (fromIntegral i)
instance LargeHashable CUChar where
updateHash (CUChar w) = updateHashWithFun hu_updateUChar w
instance LargeHashable CUShort where
updateHash (CUShort w) = updateHashWithFun hu_updateUShort w
instance LargeHashable CUInt where
updateHash (CUInt w) = updateHashWithFun hu_updateUInt w
instance LargeHashable CULong where
updateHash (CULong w) = updateHashWithFun hu_updateULong (fromIntegral w)
instance LargeHashable Char where
updateHash = updateHashWithFun hu_updateUInt . Utf8.c2w
updateHashInteger :: Integer -> LH ()
updateHashInteger !i
| i == 0 = updateHash (0 :: CUChar)
| i > 0 = do
updateHash (fromIntegral (i .&. 0xffffffffffffffff) :: CULong)
updateHashInteger (shift i (64))
| otherwise = do
updateHash (0 :: CUChar)
updateHashInteger (abs i)
instance LargeHashable Integer where
updateHash = updateHashInteger
foreign import ccall doubleToWord64 :: Double -> Word64
instance LargeHashable Double where
updateHash = updateHash . doubleToWord64
foreign import ccall floatToWord32 :: Float -> Word32
instance LargeHashable Float where
updateHash = updateHash . floatToWord32
updateHashFixed :: HasResolution a => Fixed a -> LH ()
updateHashFixed f = updateHash (truncate . (* f) . fromInteger $ resolution f :: Integer)
instance HasResolution a => LargeHashable (Fixed a) where
updateHash = updateHashFixed
updateHashBool :: Bool -> LH ()
updateHashBool True = updateHash (1 :: CUChar)
updateHashBool False = updateHash (0 :: CUChar)
instance LargeHashable Bool where
updateHash = updateHashBool
updateHashList :: LargeHashable a => [a] -> LH ()
updateHashList = loop 0
where
loop :: LargeHashable a => Int -> [a] -> LH ()
loop !i [] =
updateHash i
loop !i (x:xs) = do
updateHash x
loop (i + 1) xs
instance LargeHashable a => LargeHashable [a] where
updateHash = updateHashList
setFoldFun :: LargeHashable a => LH () -> a -> LH ()
setFoldFun action value = action >> updateHash value
updateHashSet :: LargeHashable a => S.Set a -> LH ()
updateHashSet !set = do
foldl' setFoldFun (return ()) set
updateHash (S.size set)
instance LargeHashable a => LargeHashable (S.Set a) where
updateHash = updateHashSet
updateHashIntSet :: IntSet.IntSet -> LH ()
updateHashIntSet !set = do
IntSet.foldl' setFoldFun (return ()) set
updateHash (IntSet.size set)
instance LargeHashable IntSet.IntSet where
updateHash = updateHashIntSet
updateHashHashSet :: LargeHashable a => HashSet.HashSet a -> LH ()
updateHashHashSet !set =
hashListModuloOrdering (HashSet.size set) (HashSet.toList set)
hashListModuloOrdering :: LargeHashable a => Int -> [a] -> LH ()
hashListModuloOrdering len list =
do updateXorHash (map updateHash list)
updateHash len
instance LargeHashable a => LargeHashable (HashSet.HashSet a) where
updateHash = updateHashHashSet
mapFoldFun :: (LargeHashable k, LargeHashable a) => LH () -> k -> a -> LH ()
mapFoldFun action key value = action >> updateHash key >> updateHash value
updateHashMap :: (LargeHashable k, LargeHashable a) => M.Map k a -> LH ()
updateHashMap !m = do
M.foldlWithKey' mapFoldFun (return ()) m
updateHash (M.size m)
instance (LargeHashable k, LargeHashable a) => LargeHashable (M.Map k a) where
updateHash = updateHashMap
updateHashIntMap :: LargeHashable a => IntMap.IntMap a -> LH ()
updateHashIntMap !m = do
IntMap.foldlWithKey' mapFoldFun (return ()) m
updateHash (IntMap.size m)
instance LargeHashable a => LargeHashable (IntMap.IntMap a) where
updateHash = updateHashIntMap
updateHashHashMap :: (LargeHashable k, LargeHashable v) => HashMap.HashMap k v -> LH ()
updateHashHashMap !m =
hashListModuloOrdering (HashMap.size m) (HashMap.toList m)
instance (LargeHashable k, LargeHashable v) => LargeHashable (HashMap.HashMap k v) where
updateHash = updateHashHashMap
updateHashTuple :: (LargeHashable a, LargeHashable b) => (a, b) -> LH ()
updateHashTuple (!a, !b) = updateHash a >> updateHash b
instance (LargeHashable a, LargeHashable b) => LargeHashable (a, b) where
updateHash = updateHashTuple
updateHashTriple :: (LargeHashable a, LargeHashable b, LargeHashable c) => (a, b, c) -> LH ()
updateHashTriple (a, b, c) = updateHash a >> updateHash b >> updateHash c
instance (LargeHashable a, LargeHashable b, LargeHashable c) => LargeHashable (a, b, c) where
updateHash = updateHashTriple
updateHashQuadruple :: (LargeHashable a, LargeHashable b, LargeHashable c, LargeHashable d) => (a, b, c, d) -> LH ()
updateHashQuadruple (a, b, c, d) = updateHash a >> updateHash b >> updateHash c >> updateHash d
instance (LargeHashable a, LargeHashable b, LargeHashable c, LargeHashable d) => LargeHashable (a, b, c, d) where
updateHash = updateHashQuadruple
updateHashQuintuple :: (LargeHashable a, LargeHashable b, LargeHashable c, LargeHashable d, LargeHashable e) => (a, b, c, d, e) -> LH ()
updateHashQuintuple (a, b, c, d, e) = updateHash a >> updateHash b >> updateHash c >> updateHash d >> updateHash e
instance (LargeHashable a, LargeHashable b, LargeHashable c, LargeHashable d, LargeHashable e) => LargeHashable (a, b, c, d, e) where
updateHash = updateHashQuintuple
updateHashMaybe :: LargeHashable a => Maybe a -> LH ()
updateHashMaybe Nothing = updateHash (0 :: CULong)
updateHashMaybe (Just !x) = updateHash (1 :: CULong) >> updateHash x
instance LargeHashable a => LargeHashable (Maybe a) where
updateHash = updateHashMaybe
instance (LargeHashable a, LargeHashable b) => LargeHashable (Either a b) where
updateHash (Left !l) = updateHash (0 :: CULong) >> updateHash l
updateHash (Right !r) = updateHash (1 :: CULong) >> updateHash r
instance LargeHashable () where
updateHash () = updateHash (0 :: CULong)
instance LargeHashable Ordering where
updateHash EQ = updateHash (0 :: CULong)
updateHash GT = updateHash (1 :: CULong)
updateHash LT = updateHash (1 :: CULong)
instance (Integral a, LargeHashable a) => LargeHashable (Ratio a) where
updateHash !i = do
updateHash $ numerator i
updateHash $ denominator i
instance LargeHashable AbsoluteTime where
updateHash t = updateHash $ diffAbsoluteTime t taiEpoch
instance LargeHashable DiffTime where
updateHash = updateHash . (fromRational . toRational :: DiffTime -> Pico)
instance LargeHashable NominalDiffTime where
updateHash = updateHash . (fromRational . toRational :: NominalDiffTime -> Pico)
instance LargeHashable LocalTime where
updateHash (LocalTime d tod) = updateHash d >> updateHash tod
instance LargeHashable ZonedTime where
updateHash (ZonedTime lt tz) = updateHash lt >> updateHash tz
instance LargeHashable TimeOfDay where
updateHash (TimeOfDay h m s) = updateHash h >> updateHash m >> updateHash s
instance LargeHashable TimeZone where
updateHash (TimeZone mintz summerOnly name) =
updateHash mintz >> updateHash summerOnly >> updateHash name
instance LargeHashable UTCTime where
updateHash (UTCTime d dt) = updateHash d >> updateHash dt
instance LargeHashable Day where
updateHash (ModifiedJulianDay d) = updateHash d
instance LargeHashable UniversalTime where
updateHash (ModJulianDate d) = updateHash d
instance LargeHashable a => LargeHashable (V.Vector a) where
updateHash = updateHash . V.toList
instance (LargeHashable a, LargeHashable b) => LargeHashable (Tuple.Pair a b) where
updateHash (x Tuple.:!: y) =
do updateHash x
updateHash y
instance LargeHashable Sci.Scientific where
updateHash notNormalized =
do let n = Sci.normalize notNormalized
updateHash (Sci.coefficient n)
updateHash (Sci.base10Exponent n)
instance LargeHashable J.Value where
updateHash v =
case v of
J.Object obj ->
do updateHash (0::Int)
updateHash obj
J.Array arr ->
do updateHash (1::Int)
updateHash arr
J.String t ->
do updateHash (2::Int)
updateHash t
J.Number n ->
do updateHash (3::Int)
updateHash n
J.Bool b ->
do updateHash (4::Int)
updateHash b
J.Null ->
updateHash (5::Int)
instance LargeHashable Void where
updateHash _ = error "I'm void"
instance LargeHashable a => LargeHashable (Seq.Seq a) where
updateHash = updateHash . F.toList
class GenericLargeHashable f where
updateHashGeneric :: f p -> LH ()
instance GenericLargeHashable V1 where
updateHashGeneric = undefined
instance GenericLargeHashable U1 where
updateHashGeneric _ = updateHash ()
instance (GenericLargeHashable f, GenericLargeHashable g) => GenericLargeHashable (f :+: g) where
updateHashGeneric (L1 x) = do
updateHash (0 :: CULong)
updateHashGeneric x
updateHashGeneric (R1 x) = do
updateHash (1 :: CULong)
updateHashGeneric x
instance (GenericLargeHashable f, GenericLargeHashable g) => GenericLargeHashable (f :*: g) where
updateHashGeneric (x :*: y) = updateHashGeneric x >> updateHashGeneric y
instance LargeHashable c => GenericLargeHashable (K1 i c) where
updateHashGeneric (K1 x) = updateHash x
instance (GenericLargeHashable f) => GenericLargeHashable (M1 i t f) where
updateHashGeneric (M1 x) = updateHashGeneric x