large-hashable (empty) → 0.1.0.0
raw patch · 23 files changed
+2478/−0 lines, 23 filesdep +HTFdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HTF, QuickCheck, aeson, base, base16-bytestring, byteable, bytes, bytestring, cereal, containers, cryptohash, deepseq, hashable, large-hashable, safecopy, scientific, strict, template-haskell, text, time, transformers, unordered-containers, utf8-light, vector, void
Files
- LICENSE +30/−0
- README.md +13/−0
- Setup.hs +2/−0
- benchmark/Data/LargeHashable/Benchmarks/CryptoHash.hs +77/−0
- benchmark/Data/LargeHashable/Benchmarks/Main.hs +110/−0
- benchmark/Data/LargeHashable/Benchmarks/Serial.hs +30/−0
- benchmark/Main.hs +6/−0
- cbits/md5.c +218/−0
- cbits/md5.h +51/−0
- large-hashable.cabal +106/−0
- shell.nix +43/−0
- src/Data/LargeHashable.hs +26/−0
- src/Data/LargeHashable/Class.hs +505/−0
- src/Data/LargeHashable/Intern.hs +150/−0
- src/Data/LargeHashable/LargeWord.hs +78/−0
- src/Data/LargeHashable/MD5.hs +116/−0
- src/Data/LargeHashable/TH.hs +202/−0
- stack.yaml +32/−0
- test/Data/LargeHashable/Tests/Class.hs +360/−0
- test/Data/LargeHashable/Tests/Helper.hs +228/−0
- test/Data/LargeHashable/Tests/LargeWord.hs +24/−0
- test/Data/LargeHashable/Tests/TH.hs +56/−0
- test/Main.hs +15/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015 - 2016 factis research GmbH++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,13 @@+# LargeHashable++[](https://travis-ci.org/factisresearch/large-hashable)++Efficiently hash Haskell values with MD5, SHA256, SHA512 and other+hashing algorithms.++## Build instructions++- Install the stack tool (http://haskellstack.org)+- `stack build` builds the code+- `stack test` builds the code and runs the tests+- `run-benchmarks.sh` runs the benchmark suite
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark/Data/LargeHashable/Benchmarks/CryptoHash.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MagicHash #-}+module Data.LargeHashable.Benchmarks.CryptoHash where++-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines")+import Data.Bits+import Data.Byteable+import Data.List (foldl')+import Data.Word+import qualified Crypto.Hash as H+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as Base16+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++data HashAlgorithm+ = MD5+ | SHA256+ | SHA512+ deriving (Eq, Show)++data HashCtx = forall h . H.HashAlgorithm h => HashCtx !(H.Context h)++newtype Hash = Hash { unHash :: BS.ByteString }+ deriving (Eq)++instance Show Hash where+ show (Hash bs) =+ BSC.unpack (Base16.encode bs)++hashMd5 :: LargeHashable h => h -> Hash+hashMd5 h =+ let ctx = hashInit MD5+ in hashFinish (hashUpdate ctx h)++hashInit :: HashAlgorithm -> HashCtx+hashInit alg =+ case alg of+ MD5 -> HashCtx (H.hashInit :: H.Context H.MD5)+ SHA256 -> HashCtx (H.hashInit :: H.Context H.SHA256)+ SHA512 -> HashCtx (H.hashInit :: H.Context H.SHA512)++hashFinish :: HashCtx -> Hash+hashFinish (HashCtx x) = Hash (toBytes $ H.hashFinalize x)++updateFromBuilder :: HashCtx -> B.Builder -> HashCtx+updateFromBuilder (HashCtx ctx) builder =+ HashCtx (H.hashUpdates ctx (BSL.toChunks (B.toLazyByteString builder)))++class LargeHashable a where+ hashUpdate :: HashCtx -> a -> HashCtx++instance LargeHashable BS.ByteString where+ hashUpdate (HashCtx x) bs = HashCtx (H.hashUpdate x bs)++instance LargeHashable Int where+ hashUpdate (HashCtx ctx) i =+ -- we can make this faster by accessing the machine represenation of an int+ let w = (fromIntegral (toInteger i)) :: Word64+ in HashCtx (H.hashUpdate ctx (BS.pack [(fromIntegral (shiftR w 56) :: Word8)+ ,(fromIntegral (shiftR w 48) :: Word8)+ ,(fromIntegral (shiftR w 40) :: Word8)+ ,(fromIntegral (shiftR w 32) :: Word8)+ ,(fromIntegral (shiftR w 24) :: Word8)+ ,(fromIntegral (shiftR w 16) :: Word8)+ ,(fromIntegral (shiftR w 8) :: Word8)+ ,(fromIntegral (w) :: Word8)]))++instance LargeHashable T.Text where+ hashUpdate (HashCtx ctx) t = HashCtx (H.hashUpdate ctx (T.encodeUtf8 t))++instance LargeHashable a => LargeHashable [a] where+ hashUpdate ctx l =+ foldl' hashUpdate ctx l
+ benchmark/Data/LargeHashable/Benchmarks/Main.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Data.LargeHashable.Benchmarks.Main (main) where++import qualified Data.Text as T+import Data.SafeCopy+import Control.DeepSeq+import GHC.Generics+import Data.Serialize.Put+import System.Environment+import qualified Data.LargeHashable.Benchmarks.CryptoHash as CH+import qualified Data.LargeHashable.Benchmarks.Serial as Serial+import qualified Data.LargeHashable as LH+import qualified Data.Bytes.Serial as S++data Patient+ = Patient+ { p_firstName :: !T.Text+ , p_lastName :: !T.Text+ , p_note :: !T.Text+ , p_age :: !Int+ }+ deriving (Eq, Show, NFData, Generic)++$(deriveSafeCopy 0 'base ''Patient)++instance S.Serial Patient++instance CH.LargeHashable Patient where+ hashUpdate ctx0 p =+ let !ctx1 = CH.hashUpdate ctx0 (p_firstName p)+ !ctx2 = CH.hashUpdate ctx1 (p_lastName p)+ !ctx3 = CH.hashUpdate ctx2 (p_note p)+ !ctx4 = CH.hashUpdate ctx3 (p_age p)+ in ctx4++instance LH.LargeHashable Patient where+ updateHash p =+ {-# SCC "updateHash/LargHashable" #-}+ do {-# SCC "updateHash/firstName" #-} LH.updateHash (p_firstName p)+ {-# SCC "updateHash/lastName" #-} LH.updateHash (p_lastName p)+ {-# SCC "updateHash/note" #-} LH.updateHash (p_note p)+ {-# SCC "updateHash/age" #-} LH.updateHash (p_age p)++mkPatList :: Int -> [Patient]+mkPatList n =+ let l = map mkPat [1..n]+ in l `deepseq` l+ where+ mkPat i =+ Patient+ { p_firstName = "Stefan"+ , p_lastName = "Wehr"+ , p_note = "Dies ist ein bißchen mehr Text, aber auch nicht richtig lang"+ , p_age = i+ }++_NUM_ :: Int+_NUM_ = 1000000++patList :: [Patient]+patList = mkPatList _NUM_++genOnly :: IO ()+genOnly =+ do let !l = patList+ putStrLn ("Generated " ++ show (length l) ++ " patients")++hashSafeCopy :: IO ()+hashSafeCopy =+ do let !l = patList+ putStrLn ("Generated " ++ show (length l) ++ " patients")+ let !bs = runPut (safePut l)+ !hash = CH.hashMd5 bs+ putStrLn ("Hash: " ++ show hash)++hashCryptoHash :: IO ()+hashCryptoHash =+ do let !l = patList+ putStrLn ("Generated " ++ show (length l) ++ " patients")+ let !hash = CH.hashMd5 l+ putStrLn ("Hash: " ++ show hash)++hashLargeHashable :: IO ()+hashLargeHashable =+ do let !l = patList+ putStrLn ("Generated " ++ show (length l) ++ " patients")+ let !hash = LH.largeHash LH.md5HashAlgorithm l+ putStrLn ("Hash: " ++ show hash)++hashSerial :: IO ()+hashSerial =+ do let !l = patList+ putStrLn ("Generated " ++ show (length l) ++ " patients")+ let !hash = Serial.serialLargeHash LH.md5HashAlgorithm l+ putStrLn ("Hash: " ++ show hash)++main :: IO ()+main =+ do args <- getArgs+ case args of+ ["dry"] -> genOnly+ ["safecopy"] -> hashSafeCopy+ ["cryptohash"] -> hashCryptoHash+ ["large-hashable"] -> hashLargeHashable+ ["large-hashable-serial"] -> hashSerial+ _ -> hashLargeHashable
+ benchmark/Data/LargeHashable/Benchmarks/Serial.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.LargeHashable.Benchmarks.Serial (serialLargeHash) where++import Data.LargeHashable.Intern+import Data.LargeHashable.Class+import Data.Bytes.Put+import Data.Bytes.Serial++serialLargeHash :: Serial a => HashAlgorithm h -> a -> h+serialLargeHash algo a = runLH algo $ serialize a++instance MonadPut LH where+ flush = return ()++ putWord8 = updateHash+ putWord16host = updateHash+ putWord32host = updateHash+ putWord64host = updateHash+ putWordhost = updateHash++ putWord16le = updateHash+ putWord32le = updateHash+ putWord64le = updateHash++ putWord16be = updateHash+ putWord32be = updateHash+ putWord64be = updateHash++ putByteString = updateHash+ putLazyByteString = updateHash
+ benchmark/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified Data.LargeHashable.Benchmarks.Main as M++main :: IO ()+main = M.main
+ cbits/md5.c view
@@ -0,0 +1,218 @@+/*+ * Copyright (C) 2006-2009 Vincent Hanquez <vincent@snarc.org>+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions+ * are met:+ * 1. Redistributions of source code must retain the above copyright+ * notice, this list of conditions and the following disclaimer.+ * 2. Redistributions in binary form must reproduce the above copyright+ * notice, this list of conditions and the following disclaimer in the+ * documentation and/or other materials provided with the distribution.+ *+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR+ * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+ * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+ * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+ * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+ * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ */++#include <string.h>+#include <stdio.h>+#include "bitfn.h"+#include "md5.h"++void md5_init(struct md5_ctx *ctx)+{+ memset(ctx, 0, sizeof(*ctx));++ ctx->sz = 0ULL;+ ctx->h[0] = 0x67452301;+ ctx->h[1] = 0xefcdab89;+ ctx->h[2] = 0x98badcfe;+ ctx->h[3] = 0x10325476;+}++#define f1(x, y, z) (z ^ (x & (y ^ z)))+#define f2(x, y, z) f1(z, x, y)+#define f3(x, y, z) (x ^ y ^ z)+#define f4(x, y, z) (y ^ (x | ~z))+#define R(f, a, b, c, d, i, k, s) a += f(b, c, d) + w[i] + k; a = rol32(a, s); a += b++static void md5_do_chunk(struct md5_ctx *ctx, uint32_t *buf)+{+ uint32_t a, b, c, d;+#ifdef ARCH_IS_BIG_ENDIAN+ uint32_t w[16];+ cpu_to_le32_array(w, buf, 16);+#else+ uint32_t *w = buf;+#endif+ a = ctx->h[0]; b = ctx->h[1]; c = ctx->h[2]; d = ctx->h[3];++ R(f1, a, b, c, d, 0, 0xd76aa478, 7);+ R(f1, d, a, b, c, 1, 0xe8c7b756, 12);+ R(f1, c, d, a, b, 2, 0x242070db, 17);+ R(f1, b, c, d, a, 3, 0xc1bdceee, 22);+ R(f1, a, b, c, d, 4, 0xf57c0faf, 7);+ R(f1, d, a, b, c, 5, 0x4787c62a, 12);+ R(f1, c, d, a, b, 6, 0xa8304613, 17);+ R(f1, b, c, d, a, 7, 0xfd469501, 22);+ R(f1, a, b, c, d, 8, 0x698098d8, 7);+ R(f1, d, a, b, c, 9, 0x8b44f7af, 12);+ R(f1, c, d, a, b, 10, 0xffff5bb1, 17);+ R(f1, b, c, d, a, 11, 0x895cd7be, 22);+ R(f1, a, b, c, d, 12, 0x6b901122, 7);+ R(f1, d, a, b, c, 13, 0xfd987193, 12);+ R(f1, c, d, a, b, 14, 0xa679438e, 17);+ R(f1, b, c, d, a, 15, 0x49b40821, 22);++ R(f2, a, b, c, d, 1, 0xf61e2562, 5);+ R(f2, d, a, b, c, 6, 0xc040b340, 9);+ R(f2, c, d, a, b, 11, 0x265e5a51, 14);+ R(f2, b, c, d, a, 0, 0xe9b6c7aa, 20);+ R(f2, a, b, c, d, 5, 0xd62f105d, 5);+ R(f2, d, a, b, c, 10, 0x02441453, 9);+ R(f2, c, d, a, b, 15, 0xd8a1e681, 14);+ R(f2, b, c, d, a, 4, 0xe7d3fbc8, 20);+ R(f2, a, b, c, d, 9, 0x21e1cde6, 5);+ R(f2, d, a, b, c, 14, 0xc33707d6, 9);+ R(f2, c, d, a, b, 3, 0xf4d50d87, 14);+ R(f2, b, c, d, a, 8, 0x455a14ed, 20);+ R(f2, a, b, c, d, 13, 0xa9e3e905, 5);+ R(f2, d, a, b, c, 2, 0xfcefa3f8, 9);+ R(f2, c, d, a, b, 7, 0x676f02d9, 14);+ R(f2, b, c, d, a, 12, 0x8d2a4c8a, 20);++ R(f3, a, b, c, d, 5, 0xfffa3942, 4);+ R(f3, d, a, b, c, 8, 0x8771f681, 11);+ R(f3, c, d, a, b, 11, 0x6d9d6122, 16);+ R(f3, b, c, d, a, 14, 0xfde5380c, 23);+ R(f3, a, b, c, d, 1, 0xa4beea44, 4);+ R(f3, d, a, b, c, 4, 0x4bdecfa9, 11);+ R(f3, c, d, a, b, 7, 0xf6bb4b60, 16);+ R(f3, b, c, d, a, 10, 0xbebfbc70, 23);+ R(f3, a, b, c, d, 13, 0x289b7ec6, 4);+ R(f3, d, a, b, c, 0, 0xeaa127fa, 11);+ R(f3, c, d, a, b, 3, 0xd4ef3085, 16);+ R(f3, b, c, d, a, 6, 0x04881d05, 23);+ R(f3, a, b, c, d, 9, 0xd9d4d039, 4);+ R(f3, d, a, b, c, 12, 0xe6db99e5, 11);+ R(f3, c, d, a, b, 15, 0x1fa27cf8, 16);+ R(f3, b, c, d, a, 2, 0xc4ac5665, 23);++ R(f4, a, b, c, d, 0, 0xf4292244, 6);+ R(f4, d, a, b, c, 7, 0x432aff97, 10);+ R(f4, c, d, a, b, 14, 0xab9423a7, 15);+ R(f4, b, c, d, a, 5, 0xfc93a039, 21);+ R(f4, a, b, c, d, 12, 0x655b59c3, 6);+ R(f4, d, a, b, c, 3, 0x8f0ccc92, 10);+ R(f4, c, d, a, b, 10, 0xffeff47d, 15);+ R(f4, b, c, d, a, 1, 0x85845dd1, 21);+ R(f4, a, b, c, d, 8, 0x6fa87e4f, 6);+ R(f4, d, a, b, c, 15, 0xfe2ce6e0, 10);+ R(f4, c, d, a, b, 6, 0xa3014314, 15);+ R(f4, b, c, d, a, 13, 0x4e0811a1, 21);+ R(f4, a, b, c, d, 4, 0xf7537e82, 6);+ R(f4, d, a, b, c, 11, 0xbd3af235, 10);+ R(f4, c, d, a, b, 2, 0x2ad7d2bb, 15);+ R(f4, b, c, d, a, 9, 0xeb86d391, 21);++ ctx->h[0] += a; ctx->h[1] += b; ctx->h[2] += c; ctx->h[3] += d;+}++void md5_update(struct md5_ctx *ctx, uint8_t *data, uint32_t len)+{+ uint32_t index, to_fill;++ index = (uint32_t) (ctx->sz & 0x3f);+ to_fill = 64 - index;++ ctx->sz += len;++ if (index && len >= to_fill) {+ memcpy(ctx->buf + index, data, to_fill);+ md5_do_chunk(ctx, (uint32_t *) ctx->buf);+ len -= to_fill;+ data += to_fill;+ index = 0;+ }++ /* process as much 64-block as possible */+ for (; len >= 64; len -= 64, data += 64)+ md5_do_chunk(ctx, (uint32_t *) data);++ /* append data into buf */+ if (len)+ memcpy(ctx->buf + index, data, len);+}++void md5_update_char(struct md5_ctx *ctx, char data)+{+ md5_update(ctx, (uint8_t *)&data, sizeof(data));+}++void md5_update_uchar(struct md5_ctx *ctx, unsigned char data)+{+ md5_update(ctx, (uint8_t *)&data, sizeof(data));+}++void md5_update_short(struct md5_ctx *ctx, short data)+{+ md5_update(ctx, (uint8_t *)&data, sizeof(data));+}++void md5_update_ushort(struct md5_ctx *ctx, unsigned short data)+{+ md5_update(ctx, (uint8_t *)&data, sizeof(data));+}++void md5_update_int(struct md5_ctx *ctx, int data)+{+ md5_update(ctx, (uint8_t *)&data, sizeof(data));+}++void md5_update_uint(struct md5_ctx *ctx, unsigned int data)+{+ md5_update(ctx, (uint8_t *)&data, sizeof(data));+}++void md5_update_long(struct md5_ctx *ctx, long data)+{+ md5_update(ctx, (uint8_t *)&data, sizeof(data));+}++void md5_update_ulong(struct md5_ctx *ctx, unsigned long data)+{+ md5_update(ctx, (uint8_t *)&data, sizeof(data));+}++void md5_finalize(struct md5_ctx *ctx, uint8_t *out)+{+ static uint8_t padding[64] = { 0x80, };+ uint64_t bits;+ uint32_t index, padlen;+ uint32_t *p = (uint32_t *) out;++ /* add padding and update data with it */+ bits = cpu_to_le64(ctx->sz << 3);++ /* pad out to 56 */+ index = (uint32_t) (ctx->sz & 0x3f);+ padlen = (index < 56) ? (56 - index) : ((64 + 56) - index);+ md5_update(ctx, padding, padlen);++ /* append length */+ md5_update(ctx, (uint8_t *) &bits, sizeof(bits));++ /* output hash */+ p[0] = cpu_to_le32(ctx->h[0]);+ p[1] = cpu_to_le32(ctx->h[1]);+ p[2] = cpu_to_le32(ctx->h[2]);+ p[3] = cpu_to_le32(ctx->h[3]);+}
+ cbits/md5.h view
@@ -0,0 +1,51 @@+/*+ * Copyright (C) 2006-2009 Vincent Hanquez <vincent@snarc.org>+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions+ * are met:+ * 1. Redistributions of source code must retain the above copyright+ * notice, this list of conditions and the following disclaimer.+ * 2. Redistributions in binary form must reproduce the above copyright+ * notice, this list of conditions and the following disclaimer in the+ * documentation and/or other materials provided with the distribution.+ *+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR+ * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+ * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+ * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,+ * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+ * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+ * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+ * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+ * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ */+#ifndef CRYPTOHASH_MD5_H+#define CRYPTOHASH_MD5_H++#include <stdint.h>++struct md5_ctx+{+ uint64_t sz;+ uint8_t buf[64];+ uint32_t h[4];+};++#define MD5_DIGEST_SIZE 16+#define MD5_CTX_SIZE sizeof(struct md5_ctx)++void md5_init(struct md5_ctx *ctx);+void md5_update(struct md5_ctx *ctx, uint8_t *data, uint32_t len);+void md5_update_char(struct md5_ctx *ctx, char data);+void md5_update_uchar(struct md5_ctx *ctx, unsigned char data);+void md5_update_short(struct md5_ctx *ctx, short data);+void md5_update_ushort(struct md5_ctx *ctx, unsigned short data);+void md5_update_int(struct md5_ctx *ctx, int data);+void md5_update_uint(struct md5_ctx *ctx, unsigned int data);+void md5_update_long(struct md5_ctx *ctx, long data);+void md5_update_ulong(struct md5_ctx *ctx, unsigned long data);+void md5_finalize(struct md5_ctx *ctx, uint8_t *out);++#endif
+ large-hashable.cabal view
@@ -0,0 +1,106 @@+name: large-hashable+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: 2015 - 2016 factis research GmbH+maintainer: Stefan Wehr <wehr@cp-med.com>+homepage: https://github.com/factisresearch/large-hashable+synopsis: Efficiently hash (large) Haskell values+description:+ Please see README.md+category: Web+author: Stefan Wehr, Lukas Epple+extra-source-files:+ cbits/md5.h+ README.md+ shell.nix+ stack.yaml++source-repository head+ type: git+ location: https://github.com/factisresearch/large-hashable++library+ exposed-modules:+ Data.LargeHashable+ Data.LargeHashable.Class+ Data.LargeHashable.MD5+ Data.LargeHashable.Intern+ Data.LargeHashable.LargeWord+ Data.LargeHashable.TH+ build-depends:+ aeson >=0.11.2.0,+ base >=4.8 && <5,+ text >=1.2.2.1,+ bytestring >=0.10.6.0,+ transformers >=0.4.2.0,+ base16-bytestring >=0.1.1.6,+ bytes >=0.15.2,+ containers >=0.5.6.2,+ unordered-containers >=0.2.7.0,+ scientific >=0.3.4.6,+ strict >=0.3.2,+ time >=1.5.0.1,+ template-haskell >=2.10.0.0,+ utf8-light >=0.4.2,+ vector >=0.11.0.0,+ void >=0.7.1+ c-sources:+ cbits/md5.c+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -optc -O3 -fno-cse -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind -pgmPcpphs -optP--cpp -fno-warn-name-shadowing -fwarn-missing-signatures -O2++test-suite large-hashable-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ build-depends:+ aeson >=0.11.2.0,+ HTF >=0.13.1.0,+ QuickCheck >=2.8.2,+ base >=4.8 && <5,+ bytes >=0.15.2,+ bytestring >=0.10.6.0,+ containers >=0.5.6.2,+ hashable >=1.2.4.0,+ large-hashable >=0.1.0.0,+ scientific >=0.3.4.6,+ strict >=0.3.2,+ text >=1.2.2.1,+ time >=1.5.0.1,+ unordered-containers >=0.2.7.0,+ vector >=0.11.0.0+ default-language: Haskell2010+ hs-source-dirs: test+ other-modules:+ Data.LargeHashable.Tests.Class+ Data.LargeHashable.Tests.Helper+ Data.LargeHashable.Tests.TH+ Data.LargeHashable.Tests.LargeWord+ ghc-options: -optc -O3 -fno-cse -threaded -rtsopts -with-rtsopts=-N -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind -pgmPcpphs -optP--cpp -rtsopts -threaded -funbox-strict-fields -fwarn-missing-signatures -fno-warn-name-shadowing++benchmark large-hashable-benchmark+ type: exitcode-stdio-1.0+ main-is: Main.hs+ build-depends:+ base >=4.8 && <5,+ base16-bytestring >=0.1.1.6,+ large-hashable >=0.1.0.0,+ safecopy >=0.9.0.1,+ text >=1.2.2.1,+ deepseq >=1.4.1.1,+ cryptohash >=0.11.9,+ bytestring >=0.10.6.0,+ cereal >=0.5.1.0,+ byteable >=0.1.1,+ transformers >=0.4.2.0,+ bytes >=0.15.2+ default-language: Haskell2010+ hs-source-dirs: benchmark+ other-modules:+ Data.LargeHashable.Benchmarks.CryptoHash+ Data.LargeHashable.Benchmarks.Main+ Data.LargeHashable.Benchmarks.Serial+ ghc-options: -optc -O3 -fno-cse -threaded -rtsopts -with-rtsopts=-N -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind -pgmPcpphs -optP--cpp -rtsopts -threaded -funbox-strict-fields -fwarn-missing-signatures -fno-warn-name-shadowing -O2
+ shell.nix view
@@ -0,0 +1,43 @@+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:++let++ inherit (nixpkgs) pkgs;++ f = { mkDerivation, base, base16-bytestring, byteable, bytes+ , bytestring, cereal, containers, cryptohash, deepseq, hashable+ , HTF, QuickCheck, safecopy, stdenv, template-haskell, text, time+ , transformers, unordered-containers+ }:+ mkDerivation {+ pname = "large-hashable";+ version = "0.1.0.0";+ src = ./.;+ isLibrary = true;+ isExecutable = true;+ libraryHaskellDepends = [+ base base16-bytestring bytes bytestring containers template-haskell+ text time transformers unordered-containers+ ];+ executableHaskellDepends = [+ base byteable bytes bytestring cereal cryptohash deepseq safecopy+ text transformers+ ];+ testHaskellDepends = [+ base bytes bytestring containers hashable HTF QuickCheck text+ unordered-containers+ ];+ homepage = "http://github.com/githubuser/large-hashable#readme";+ description = "Initial project template from stack";+ license = stdenv.lib.licenses.bsd3;+ };++ haskellPackages = if compiler == "default"+ then pkgs.haskellPackages+ else pkgs.haskell.packages.${compiler};++ drv = haskellPackages.callPackage f {};++in++ if pkgs.lib.inNixShell then drv.env else drv
+ src/Data/LargeHashable.hs view
@@ -0,0 +1,26 @@+-- | This is the top-level module of LargeHashable, a library+-- for efficiently hashing any Haskell data type using a+-- hash algorithm like MD5, SHA256 etc.+--+-- Normal users shoud import this module.+module Data.LargeHashable (+ LargeHashable(..)+ , LargeHashable'(..)+ , LH+ , HashAlgorithm+ , largeHash+ , deriveLargeHashable+ , deriveLargeHashableNoCtx+ , deriveLargeHashableCtx+ , deriveLargeHashableCustomCtx+ , MD5Hash(..)+ , md5HashAlgorithm+ , runMD5+ , module Data.LargeHashable.LargeWord+) where++import Data.LargeHashable.Class+import Data.LargeHashable.Intern+import Data.LargeHashable.LargeWord+import Data.LargeHashable.MD5+import Data.LargeHashable.TH
+ src/Data/LargeHashable/Class.hs view
@@ -0,0 +1,505 @@+-- | This module defines the central type class `LargeHashable` of this package.+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+module Data.LargeHashable.Class (++ LargeHashable(..), largeHash, LargeHashable'(..)++) where++-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines")+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++-- | A type class for computing hashes (i.e. MD5, SHA256, ...) from+-- haskell values.+--+-- The laws of this typeclass are the following:+--+-- (1) If two values are equal+-- according to '==', then the finally computed hashes must also be equal+-- according to '=='. However it is not required that the hashes of inequal+-- values have to be inequal. Also note that an instance of 'LargeHashable'+-- does not require a instance of 'Eq'. Using any sane algorithm the chance+-- of a collision should be 1 / n where n is the number of different hashes+-- possible.+--+-- (2) If two values are inequal+-- according to '==', then the probability of a hash collision is 1/n,+-- where n is the number of possible hashes produced by the+-- underlying hash algorithm.+--+-- A rule of thumb: hash all information that you would also need for+-- serializing/deserializing values of your datatype. For instance, when+-- hashing lists, you would not only hash the list elements but also the+-- length of the list. Consider the following datatype+--+-- > data Foo = Foo [Int] [Int]+--+-- We now write an instance for LargeHashable like this+--+-- > instance LargeHashable Foo where+-- > updateHash (Foo l1 l2) = updateHash l1 >> updateHash l2+--+-- If we did not hash the length of a list, then the following two values+-- of @Foo@ would produce identical hashes:+--+-- > Foo [1,2,3] []+-- > Foo [1] [2,3]+--+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' is the central function of this package.+-- For a given value it computes a 'Hash' using the given+-- 'HashAlgorithm'.+largeHash :: LargeHashable a => HashAlgorithm h -> a -> h+largeHash algo x = runLH algo (updateHash x)++{-# INLINE updateHashTextData #-}+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 ()++{-# INLINE updateHashText #-}+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++{-# INLINE updateHashLazyText #-}+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++{-# INLINE updateHashByteStringData #-}+updateHashByteStringData :: B.ByteString -> LH ()+updateHashByteStringData !b = do+ updates <- hashUpdates+ ioInLH $ do+ ptr <- B.useAsCString b return+ hu_updatePtr updates (castPtr ptr) (B.length b)++{-# INLINE updateHashByteString #-}+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++{-# INLINE updateHashLazyByteString #-}+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++{-# INLINE updateHashWithFun #-}+updateHashWithFun :: (HashUpdates -> a -> IO ()) -> a -> LH ()+updateHashWithFun f x =+ do updates <- hashUpdates+ ioInLH $ f updates x++instance LargeHashable Int where+ updateHash i = updateHashWithFun hu_updateLong (fromIntegral i)++instance LargeHashable Int8 where+ updateHash = updateHashWithFun hu_updateChar . CChar++instance LargeHashable Int16 where+ updateHash = updateHashWithFun hu_updateShort . CShort++instance LargeHashable Int32 where+ updateHash = updateHashWithFun hu_updateInt . CInt++instance LargeHashable Int64 where+ updateHash = updateHashWithFun hu_updateLong . CLong++instance LargeHashable Word where+ updateHash i = updateHashWithFun hu_updateLong (fromIntegral i)++instance LargeHashable Word8 where+ updateHash = updateHashWithFun hu_updateUChar . CUChar++instance LargeHashable Word16 where+ updateHash = updateHashWithFun hu_updateUShort . CUShort++instance LargeHashable Word32 where+ updateHash = updateHashWithFun hu_updateUInt . CUInt++instance LargeHashable Word64 where+ updateHash = updateHashWithFun hu_updateULong . CULong++instance LargeHashable CChar where+ updateHash = updateHashWithFun hu_updateChar++instance LargeHashable CShort where+ updateHash = updateHashWithFun hu_updateShort++instance LargeHashable CInt where+ updateHash = updateHashWithFun hu_updateInt++instance LargeHashable CLong where+ updateHash = updateHashWithFun hu_updateLong++instance LargeHashable CUChar where+ updateHash = updateHashWithFun hu_updateUChar++instance LargeHashable CUShort where+ updateHash = updateHashWithFun hu_updateUShort++instance LargeHashable CUInt where+ updateHash = updateHashWithFun hu_updateUInt++instance LargeHashable CULong where+ updateHash = updateHashWithFun hu_updateULong++instance LargeHashable Char where+ updateHash = updateHashWithFun hu_updateUInt . CUInt . Utf8.c2w++{-# INLINE updateHashInteger #-}+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) -- prepend 0 to show it is negative+ 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++{-# INLINE updateHashFixed #-}+updateHashFixed :: HasResolution a => Fixed a -> LH ()+updateHashFixed f = updateHash (truncate . (* f) . fromInteger $ resolution f :: Integer)++instance HasResolution a => LargeHashable (Fixed a) where+ updateHash = updateHashFixed++{-# INLINE updateHashBool #-}+updateHashBool :: Bool -> LH ()+updateHashBool True = updateHash (1 :: CUChar)+updateHashBool False = updateHash (0 :: CUChar)++instance LargeHashable Bool where+ updateHash = updateHashBool++{-# INLINE updateHashList #-}+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++{-# INLINE setFoldFun #-}+setFoldFun :: LargeHashable a => LH () -> a -> LH ()+setFoldFun action value = action >> updateHash value++{-# INLINE updateHashSet #-}+updateHashSet :: LargeHashable a => S.Set a -> LH ()+updateHashSet !set = do+ foldl' setFoldFun (return ()) set -- Note: foldl' for sets traverses the elements in asc order+ updateHash (S.size set)++instance LargeHashable a => LargeHashable (S.Set a) where+ updateHash = updateHashSet++{-# INLINE updateHashIntSet #-}+updateHashIntSet :: IntSet.IntSet -> LH ()+updateHashIntSet !set = do+ IntSet.foldl' setFoldFun (return ()) set+ updateHash (IntSet.size set)++-- Lazy and Strict IntSet share the same definition+instance LargeHashable IntSet.IntSet where+ updateHash = updateHashIntSet++{-# INLINE updateHashHashSet #-}+updateHashHashSet :: LargeHashable a => HashSet.HashSet a -> LH ()+updateHashHashSet !set =+ -- The ordering of elements in a set does not matter. A HashSet does not+ -- offer an efficient way of exctracting its elements in some specific+ -- ordering. So we use the auxiliary function 'hashListModuloOrdering'.+ hashListModuloOrdering (HashSet.size set) (HashSet.toList set)++-- | Hashes a list of values such the two permutations of the same list+-- yields the same hash.+hashListModuloOrdering :: LargeHashable a => Int -> [a] -> LH ()+hashListModuloOrdering len list =+ do updateXorHash (map updateHash list)+ updateHash len++-- Lazy and Strict HashSet share the same definition+instance LargeHashable a => LargeHashable (HashSet.HashSet a) where+ updateHash = updateHashHashSet++{-# INLINE mapFoldFun #-}+mapFoldFun :: (LargeHashable k, LargeHashable a) => LH () -> k -> a -> LH ()+mapFoldFun action key value = action >> updateHash key >> updateHash value++{-# INLINE updateHashMap #-}+updateHashMap :: (LargeHashable k, LargeHashable a) => M.Map k a -> LH ()+updateHashMap !m = do+ M.foldlWithKey' mapFoldFun (return ()) m+ updateHash (M.size m)++-- Lazy and Strict Map share the same definition+instance (LargeHashable k, LargeHashable a) => LargeHashable (M.Map k a) where+ updateHash = updateHashMap++{-# INLINE updateHashIntMap #-}+updateHashIntMap :: LargeHashable a => IntMap.IntMap a -> LH ()+updateHashIntMap !m = do+ IntMap.foldlWithKey' mapFoldFun (return ()) m+ updateHash (IntMap.size m)++-- Lazy and Strict IntMap share the same definition+instance LargeHashable a => LargeHashable (IntMap.IntMap a) where+ updateHash = updateHashIntMap++updateHashHashMap :: (LargeHashable k, LargeHashable v) => HashMap.HashMap k v -> LH ()+updateHashHashMap !m =+ -- The ordering of elements in a map do not matter. A HashMap does not+ -- offer an efficient way of exctracting its elements in some specific+ -- ordering. So we use the auxiliary function 'hashListModuloOrdering'.+ hashListModuloOrdering (HashMap.size m) (HashMap.toList m)++-- Lazy and Strict HashMap share the same definition+instance (LargeHashable k, LargeHashable v) => LargeHashable (HashMap.HashMap k v) where+ updateHash = updateHashHashMap++{-# INLINE updateHashTuple #-}+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++{-# INLINE updateHashTriple #-}+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++{-# INLINE updateHashQuadruple #-}+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++{-# INLINE updateHashQuintuple #-}+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+ -- could be replaced by diffTimeToPicoseconds as soon as+ -- time 1.6 becomes more common+ 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++-- | Support for generically deriving 'LargeHashable' instances.+-- Any instance of the type class 'GHC.Generics.Generic' can be made+-- an instance of 'LargeHashable' by an empty instance declaration.+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) -- is left+ updateHashGeneric x+ updateHashGeneric (R1 x) = do+ updateHash (1 :: CULong) -- is right+ 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++-- ignore meta-info (for now)+instance (GenericLargeHashable f) => GenericLargeHashable (M1 i t f) where+ updateHashGeneric (M1 x) = updateHashGeneric x
+ src/Data/LargeHashable/Intern.hs view
@@ -0,0 +1,150 @@+-- | Generic, low-level data types for hashing. This is an internal module.+--+-- You should only import this module if you write your own hash algorithm+-- or if you need access to low-level hashing functions when defining+-- instances of 'LargeHash'.+--+-- Regular users should not import this module. Import 'Data.LargeHashable'+-- instead.+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.LargeHashable.Intern (++ HashUpdates(..), HashAlgorithm(..), LH+ , hashUpdates, ioInLH, runLH, updateXorHash++) where++-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines")+import Control.Monad+import Data.Word+import Foreign.C.Types+import Foreign.Ptr+import System.IO.Unsafe (unsafePerformIO)++-- | Functions for updating an intermediate hash value. The functions live+-- in the 'IO' monad because they are typically implemented via FFI.+data HashUpdates+ = HashUpdates+ { hu_updatePtr :: {-# NOUNPACK #-} !(Ptr Word8 -> Int -> IO ()) -- ^ adds a byte array to the hash+ , hu_updateChar :: {-# NOUNPACK #-} !(CChar -> IO ()) -- Int8+ , hu_updateUChar :: {-# NOUNPACK #-} !(CUChar -> IO ()) -- Word8+ , hu_updateShort :: {-# NOUNPACK #-} !(CShort -> IO ()) -- Int16+ , hu_updateUShort :: {-# NOUNPACK #-} !(CUShort -> IO ()) -- Word16+ , hu_updateInt :: {-# NOUNPACK #-} !(CInt -> IO ()) -- Int32+ , hu_updateUInt :: {-# NOUNPACK #-} !(CUInt -> IO ()) -- Word32+ , hu_updateLong :: {-# NOUNPACK #-} !(CLong -> IO ()) -- Int64+ , hu_updateULong :: {-# NOUNPACK #-} !(CULong -> IO ()) -- Word64+ }++-- | The interface for a hashing algorithm. The interface contains a simple run+-- function, which is used to update the hash with all values needed, and the+-- outputs the resulting hash.+data HashAlgorithm h+ = HashAlgorithm+ { ha_run :: {-# NOUNPACK #-} !((HashUpdates -> IO ()) -> IO h)+ , ha_xor :: {-# NOUNPACK #-} !(h -> h -> h)+ , ha_updateHash :: {-# NOUNPACK #-} !(HashUpdates -> h -> IO ())+ }++data LHEnv+ = LHEnv+ { lh_updates :: {-# NOUNPACK #-} !HashUpdates+ , lh_updateXorHash :: {-# NOUNPACK #-} !([LH ()] -> IO ())+ }++-- | The 'LH' monad (`LH` stands for "large hash") is used in the definition of+-- hashing functions for arbitrary data types.+newtype LH a = LH (LHEnv -> IO a)++{-# INLINE lhFmap #-}+lhFmap :: (a -> b) -> LH a -> LH b+lhFmap f (LH x) =+ LH $ \env ->+ do y <- x env+ return (f y)++{-# INLINE lhReturn #-}+lhReturn :: a -> LH a+lhReturn x = LH $ \_env -> return x++{-# INLINE lhApp #-}+lhApp :: LH (a -> b) -> LH a -> LH b+lhApp (LH f) (LH x) =+ LH $ \env -> f env <*> x env++{-# INLINE lhBind #-}+lhBind :: LH a -> (a -> LH b) -> LH b+lhBind (LH x) f =+ LH $ \env ->+ do y <- x env+ let (LH g) = f y+ g env++{-# INLINE lhBind' #-}+lhBind' :: LH a -> LH b -> LH b+lhBind' (LH x) (LH y) =+ LH $ \env ->+ do _ <- x env+ y env++instance Functor LH where+ fmap = lhFmap++instance Applicative LH where+ pure = lhReturn+ (<*>) = lhApp++instance Monad LH where+ return = lhReturn+ (>>=) = lhBind+ (>>) = lhBind'++{-# INLINE hashUpdates #-}+hashUpdates :: LH HashUpdates+hashUpdates =+ LH $ \env -> return (lh_updates env)++{-# INLINE getUpdateXorHash #-}+getUpdateXorHash :: LH ([LH ()] -> IO ())+getUpdateXorHash =+ LH $ \env -> return (lh_updateXorHash env)++-- | Perform an 'IO' action in the 'LH' monad. Use with care, do not perform+-- arbitrary 'IO' operation with this function! Only use it for calling+-- functions of the 'HashUpdates' datatype.+{-# INLINE ioInLH #-}+ioInLH :: IO a -> LH a+ioInLH io =+ LH $ \_env -> io++-- | Runs a 'LH' computation and returns the resulting hash.+{-# NOINLINE runLH #-}+runLH :: HashAlgorithm h -> LH () -> h+runLH alg lh =+ unsafePerformIO (runLH' alg lh)++runLH' :: HashAlgorithm h -> LH () -> IO h+runLH' alg (LH lh) =+ ha_run alg fun+ where+ fun updates =+ lh (LHEnv updates (updateXor updates))+ updateXor updates actions =+ do mh <- foldM foldFun Nothing actions+ case mh of+ Just h -> ha_updateHash alg updates h+ Nothing -> return ()+ foldFun mh action =+ do h2 <- runLH' alg action+ case mh of+ Nothing -> return (Just h2)+ Just h1 ->+ let !h = ha_xor alg h1 h2+ in return (Just h)++updateXorHash :: [LH ()] -> LH ()+updateXorHash actions =+ do f <- getUpdateXorHash+ ioInLH (f actions)
+ src/Data/LargeHashable/LargeWord.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+-- | Efficient representation for small bytearrays with 128 or 256 bits.+module Data.LargeHashable.LargeWord+ ( Word128(..), Word256(..)+ , bsToW128, w128ToBs+ , bsToW256, w256ToBs+ , xorW128, xorW256+ )+where++-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines")+import Data.Bits+import Data.Data (Data)+import Data.Typeable+import Data.Word+import GHC.Generics (Generic)+import qualified Data.ByteString as BS++data Word128+ = Word128+ { w128_first :: !Word64+ , w128_second :: !Word64+ }+ deriving (Show, Read, Eq, Ord, Typeable, Generic, Data)++data Word256+ = Word256+ { w256_first :: !Word128+ , w256_second :: !Word128+ }+ deriving (Show, Read, Eq, Ord, Typeable, Generic, Data)++-- | Converts a 'ByteString' into a 'Word256'. Only the first 32 bytes+-- are taken into account, the rest is ignored.+bsToW256 :: BS.ByteString -> Word256+bsToW256 bs = Word256 first128 next128+ where+ first128 = bsToW128 bs+ next128 = bsToW128 (BS.drop 16 bs)++w256ToBs :: Word256 -> BS.ByteString+w256ToBs (Word256 first128 next128) =+ w128ToBs first128 `BS.append` w128ToBs next128++-- | Converts a 'ByteString' into a 'Word128'. Only the first 16 bytes+-- are taken into account, the rest is ignored.+bsToW128 :: BS.ByteString -> Word128+bsToW128 bs = Word128 first64 next64+ where+ first64 = bsToW64 bs+ next64 = bsToW64 (BS.drop 8 bs)++w128ToBs :: Word128 -> BS.ByteString+w128ToBs (Word128 first64 next64) =+ w64ToBs first64 `BS.append` w64ToBs next64++w64ToBs :: Word64 -> BS.ByteString+w64ToBs w64 =+ BS.pack+ [ fromIntegral (w64 `shiftR` 56 .&. 255)+ , fromIntegral (w64 `shiftR` 48 .&. 255)+ , fromIntegral (w64 `shiftR` 40 .&. 255)+ , fromIntegral (w64 `shiftR` 32 .&. 255)+ , fromIntegral (w64 `shiftR` 24 .&. 255)+ , fromIntegral (w64 `shiftR` 16 .&. 255)+ , fromIntegral (w64 `shiftR` 8 .&. 255)+ , fromIntegral (w64 .&. 255)+ ]++bsToW64 :: BS.ByteString -> Word64+bsToW64 = BS.foldl' (\x w8 -> (x `shiftL` 8) + fromIntegral w8) 0 . BS.take 8++xorW128 :: Word128 -> Word128 -> Word128+xorW128 (Word128 w11 w12) (Word128 w21 w22) = Word128 (w11 `xor` w21) (w12 `xor` w22)++xorW256 :: Word256 -> Word256 -> Word256+xorW256 (Word256 w11 w12) (Word256 w21 w22) = Word256 (w11 `xorW128` w21) (w12 `xorW128` w22)
+ src/Data/LargeHashable/MD5.hs view
@@ -0,0 +1,116 @@+-- | An implementation of 'HashAlgorithm' for MD5 (https://www.ietf.org/rfc/rfc1321.txt).+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.LargeHashable.MD5 (++ MD5Hash(..), md5HashAlgorithm, runMD5++) where++-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines")+import Data.LargeHashable.Intern+import Data.LargeHashable.LargeWord+import Data.Word+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import qualified Data.ByteString.Base16 as Base16+import qualified Data.ByteString.Char8 as BSC++newtype MD5Hash = MD5Hash { unMD5Hash :: Word128 }+ deriving (Eq, Ord)++instance Show MD5Hash where+ show (MD5Hash w) =+ BSC.unpack (Base16.encode (w128ToBs w))++foreign import ccall unsafe "md5.h md5_init"+ c_md5_init :: Ptr RawCtx -> IO ()++foreign import ccall unsafe "md5.h md5_update"+ c_md5_update :: Ptr RawCtx -> Ptr Word8 -> Int -> IO ()++foreign import ccall unsafe "md5.h md5_update_char"+ c_md5_update_char :: Ptr RawCtx -> CChar -> IO ()++foreign import ccall unsafe "md5.h md5_update_uchar"+ c_md5_update_uchar :: Ptr RawCtx -> CUChar -> IO ()++foreign import ccall unsafe "md5.h md5_update_short"+ c_md5_update_short :: Ptr RawCtx -> CShort -> IO ()++foreign import ccall unsafe "md5.h md5_update_ushort"+ c_md5_update_ushort :: Ptr RawCtx -> CUShort -> IO ()++foreign import ccall unsafe "md5.h md5_update_int"+ c_md5_update_int :: Ptr RawCtx -> CInt -> IO ()++foreign import ccall unsafe "md5.h md5_update_uint"+ c_md5_update_uint :: Ptr RawCtx -> CUInt -> IO ()++foreign import ccall unsafe "md5.h md5_update_long"+ c_md5_update_long :: Ptr RawCtx -> CLong -> IO ()++foreign import ccall unsafe "md5.h md5_update_ulong"+ c_md5_update_ulong :: Ptr RawCtx -> CULong -> IO ()++foreign import ccall unsafe "md5.h md5_finalize"+ c_md5_finalize :: Ptr RawCtx -> Ptr Word8 -> IO ()++{-# INLINE digestSize #-}+digestSize :: Int+digestSize = 16++{-# INLINE sizeCtx #-}+sizeCtx :: Int+sizeCtx = 96++data RawCtx -- phantom type argument++newtype Ctx = Ctx { _unCtx :: Ptr RawCtx }++withCtx :: (Ctx -> IO ()) -> IO MD5Hash+withCtx f =+ allocaBytes sizeCtx $ \(ptr :: Ptr RawCtx) ->+ do c_md5_init ptr+ f (Ctx ptr)+ allocaBytes digestSize $ \(resPtr :: Ptr Word8) ->+ do c_md5_finalize ptr resPtr+ let first = castPtr resPtr :: Ptr Word64+ w1 <- peek first+ let second = castPtr (plusPtr resPtr (sizeOf w1)) :: Ptr Word64+ w2 <- peek second+ return (MD5Hash (Word128 w1 w2))++md5HashAlgorithm :: HashAlgorithm MD5Hash+md5HashAlgorithm =+ HashAlgorithm+ { ha_run = run+ , ha_xor = xorMD5+ , ha_updateHash = updateHash+ }+ where+ xorMD5 (MD5Hash h1) (MD5Hash h2) = MD5Hash (h1 `xorW128` h2)+ updateHash updates (MD5Hash h) =+ let f = hu_updateULong updates . CULong+ in do f (w128_first h)+ f (w128_second h)+ run f =+ withCtx $ \(Ctx ctxPtr) ->+ let !updates =+ HashUpdates+ { hu_updatePtr = c_md5_update ctxPtr+ , hu_updateChar = c_md5_update_char ctxPtr+ , hu_updateUChar = c_md5_update_uchar ctxPtr+ , hu_updateShort = c_md5_update_short ctxPtr+ , hu_updateUShort = c_md5_update_ushort ctxPtr+ , hu_updateInt = c_md5_update_int ctxPtr+ , hu_updateUInt = c_md5_update_uint ctxPtr+ , hu_updateLong = c_md5_update_long ctxPtr+ , hu_updateULong = c_md5_update_ulong ctxPtr+ }+ in f updates++runMD5 :: LH () -> MD5Hash+runMD5 = runLH md5HashAlgorithm
+ src/Data/LargeHashable/TH.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module Data.LargeHashable.TH (++ deriveLargeHashable, deriveLargeHashableCtx, deriveLargeHashableNoCtx+ , deriveLargeHashableCustomCtx++) where++import Data.LargeHashable.Class+import Language.Haskell.TH+import Foreign.C.Types (CULong (..))+import Control.Monad (forM)++-- | Template Haskell function to automatically derive+-- instances of 'LargeHashable'. The derived instances first+-- calls 'updateHash' with an unique identifier number for+-- every constructor, followed by 'updateHash' calls for every+-- field of the constructor (if existent). It also works for+-- type families.+--+-- E. g. for the following code+--+-- @+--+-- data BlaFoo a = Foo+-- | Bar Int a+-- | Baz a a+--+-- $(deriveLargeHashable ''BlaFoo)+-- @+--+-- The following instance gets generated:+--+-- @+-- instance LargeHashable a_apg8 =>+-- LargeHashable (BlaFoo a_apg8) where+-- updateHash Foo = updateHash (0 :: Foreign.C.Types.CULong)+-- updateHash (Bar a b)+-- = (((updateHash (1 :: Foreign.C.Types.CULong)) >> (updateHash a))+-- >> (updateHash b))+-- updateHash (XY a b)+-- = (((updateHash (2 :: Foreign.C.Types.CULong)) >> (updateHash a))+-- >> (updateHash b))+-- @+deriveLargeHashable :: Name -> Q [Dec]+deriveLargeHashable n = reify n >>= \info ->+ case info of+ TyConI dec ->+ case dec of+ DataD context name tyvars cons _ ->+ buildInstance (ConT name) context tyvars cons+ NewtypeD context name tyvars con _ ->+ buildInstance (ConT name) context tyvars [con]+ _ -> fail $ notDeriveAbleErrorMsg n info+ FamilyI _ instDecs -> fmap concat $ forM instDecs $ \instDec ->+ case instDec of+ DataInstD context name types cons _ ->+ buildInstance (foldl AppT (ConT name) types) context [] cons+ NewtypeInstD context name types con _ ->+ buildInstance (foldl AppT (ConT name) types) context [] [con]+ _ -> fail $ notDeriveAbleErrorMsg n info+ _ -> fail $ notDeriveAbleErrorMsg n info++-- | Derive a 'LargeHashable' instance with extra constraints in the+-- context of the instance.+deriveLargeHashableCtx ::+ Name+ -> ([TypeQ] -> [PredQ])+ -- ^ Function mapping the type variables in the instance head to the additional constraints+ -> Q [Dec]+deriveLargeHashableCtx tyName extraPreds =+ deriveLargeHashableCustomCtx tyName mkCtx+ where+ mkCtx args oldCtx =+ oldCtx ++ extraPreds args++-- | Derive a 'LargeHashable' instance with no constraints in the context of the instance.+deriveLargeHashableNoCtx ::+ Name+ -> (Q [Dec])+deriveLargeHashableNoCtx tyName =+ deriveLargeHashableCustomCtx tyName (\_ _ -> [])++-- | Derive a 'LargeHashable' instance with a completely custom instance context.+deriveLargeHashableCustomCtx ::+ Name+ -> ([TypeQ] -> [PredQ] -> [PredQ])+ -- ^ Function mapping the type variables in the instance head and the+ -- constraints that would normally be generated to the constraints+ -- that should be generated.+ -> (Q [Dec])+deriveLargeHashableCustomCtx tyName extraPreds =+ do decs <- deriveLargeHashable tyName+ case decs of+ (InstanceD ctx ty body : _) ->+ do let args = reverse (collectArgs ty)+ newCtx <- sequence (extraPreds (map return args) (map return ctx))+ -- _ <- fail ("args: " ++ show args ++", ty: " ++ show ty)+ return [InstanceD newCtx ty body]+ _ ->+ error $+ "Unexpected declarations returned by deriveLargeHashable: " ++ show (ppr decs)+ where+ collectArgs :: Type -> [Type]+ collectArgs outerTy =+ let loop ty =+ case ty of+ (AppT l r) ->+ case l of+ AppT _ _ -> r : loop l+ _ -> [r]+ _ -> []+ in case outerTy of+ AppT _ r -> loop r+ _ -> []++-- | Generates the error message displayed when somebody tries to let us+-- derive impossible instances!+notDeriveAbleErrorMsg :: Name -> Info -> String+notDeriveAbleErrorMsg name info = "Could not derive LargeHashable instance for "+ ++ (show name) ++ "(" ++ (show info) ++ "). If you think this should be possible, file an issue."++-- | After 'deriveLargeHashable' has matched all the important information+-- this function gets called to build the instance declaration.+buildInstance :: Type -> Cxt -> [TyVarBndr] -> [Con] -> Q [Dec]+buildInstance basicType context vars cons =+ let consWithIds = zip [0..] cons+ constraints = makeConstraints context vars+ typeWithVars = foldl appT (return basicType) $ map (varT . varName) vars+ in (:[]) <$> instanceD constraints (conT ''LargeHashable `appT` typeWithVars)+ [updateHashDeclaration consWithIds]++-- | This function generates the declaration for the 'updateHash' function+-- of the 'LargeHashable' typeclass. By taking the constructors with there+-- selected IDs and calling 'updateHashClause' for everyone of them to generate+-- the corresponding clause.+updateHashDeclaration :: [(Integer, Con)] -> Q Dec+updateHashDeclaration consWIds = funD 'updateHash (map (uncurry updateHashClause) consWIds)++-- | 'updateHashClause' generates a clause of the 'updateHash' function.+-- It makes sure all the fields are matched correctly and updates the hash+-- with the neccessary information about the constructor (its ID) and all+-- of its fields.+updateHashClause :: Integer -> Con -> Q Clause+updateHashClause i con =+ clause [return patOfClause]+ (normalB $+ foldl sequenceExps+ [| updateHash ($(litE . IntegerL $ i) :: CULong) |]+ hashUpdatesOfConFields)+ []+ where hashUpdatesOfConFields = map (\name -> [| updateHash $(varE name) |]) patVarNames+ -- Extract the names of all the+ -- pattern variables from usedPat.+ patVarNames = case patOfClause of+ ConP _ vars -> map (\(VarP v) -> v) vars+ InfixP (VarP v1) _ (VarP v2) -> [v1, v2]+ _ -> error "Pattern in patVarNames not matched!"+ patOfClause = patternForCon con++-- | Generate a Pattern that matches the supplied constructor+-- and all of its fields.+patternForCon :: Con -> Pat+patternForCon con = case con of+ NormalC n types -> ConP n $ uniqueVarPats (length types)+ RecC n varTypes -> ConP n $ uniqueVarPats (length varTypes)+ InfixC _ n _ -> InfixP (VarP . mkName $ "x") n (VarP . mkName $ "y")+ ForallC _ _ c -> patternForCon c+ where uniqueVarPats n = take n . map (VarP . mkName) $ names++-- | Sequences two Expressions using the '(>>)' operator.+sequenceExps :: Q Exp -> Q Exp -> Q Exp+sequenceExps first second = infixE (Just first) (varE '(>>)) (Just second)++-- | Generates the constraints needed for the declaration of+-- the 'LargeHashable' class. This means that the constraint+-- @LargeHashable $TypeVar$@ is added for every type variable+-- the type has.+makeConstraints :: Cxt -> [TyVarBndr] -> Q Cxt+makeConstraints context vars = return $ context +++ map (\v -> (ConT (toLargeHashableClass v)) `AppT` (VarT . varName $ v)) vars+ where+ toLargeHashableClass :: TyVarBndr -> Name+ toLargeHashableClass var =+ case var of+ (PlainTV _) -> ''LargeHashable+ (KindedTV _ (AppT (AppT ArrowT StarT) StarT)) -> ''LargeHashable'+ (KindedTV _ _) -> ''LargeHashable++-- | Returns the 'Name' for a type variable.+varName :: TyVarBndr -> Name+varName (PlainTV n) = n+varName (KindedTV n _) = n++-- | An infinite list of unique names that+-- are used in the generations of patterns.+names :: [String]+names = concat $ map (gen (map (:[]) ['a'..'z'])) [0..]+ where gen :: [String] -> Integer -> [String]+ gen acc 0 = acc+ gen acc n = gen (concat $ map (\q -> map (\c -> c : q) ['a'..'z']) acc) (n - 1)
+ stack.yaml view
@@ -0,0 +1,32 @@+# For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md++# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)+resolver: lts-6.0+compiler-check: newer-minor+compiler: ghc-7.10.3+require-stack-version: ">= 1.0.0"++# Local packages, usually specified by relative directory name+packages:+- '.'++# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)+extra-deps: []++# Override default flag values for local packages and extra-deps+flags: {}++# Control whether we use the GHC we find on the path+# system-ghc: true++# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: >= 0.1.4.0++# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64++# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]
+ test/Data/LargeHashable/Tests/Class.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Data.LargeHashable.Tests.Class where++-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines")+import Data.Fixed+import Data.Hashable+import Data.Int+import Data.LargeHashable+import Data.LargeHashable.Tests.Helper+import Data.Map (Map ())+import Data.Ratio+import Data.Set (Set ())+import Data.Time.Calendar+import Data.Time.Clock+import Data.Time.Clock.TAI+import Data.Time.LocalTime+import Data.Word+import Test.Framework hiding (Fixed (..))+import qualified Data.Aeson as J+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Short as BS+import qualified Data.HashMap.Lazy as HML+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import qualified Data.Map as Map+import qualified Data.Scientific as Sci+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Strict.Tuple as Tuple+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Vector as V++-- of course we can't fully prove uniqueness using+-- properties and there is a small chance of collisions+generic_uniquenessProp :: (Eq a, LargeHashable a) => a -> a -> Bool+generic_uniquenessProp a b = (a == b) == (largeHash md5HashAlgorithm a == largeHash md5HashAlgorithm b)++prop_integerUniqueness :: Integer -> Integer -> Bool+prop_integerUniqueness = generic_uniquenessProp++test_hashInteger :: IO ()+test_hashInteger =+ do subAssert $ assertHashes 0+ subAssert $ assertHashes (toInteger (maxBound::Int))+ subAssert $ assertHashes (toInteger (minBound::Int))+ where+ assertHashes :: Integer -> IO ()+ assertHashes n =+ do let list = [(n-100)..(n+100)]+ hashes = map (largeHash md5HashAlgorithm) list+ hashesSet = Set.fromList hashes+ assertEqual (length list) (Set.size hashesSet)++test_hashBool :: IO ()+test_hashBool =+ assertBool (largeHash md5HashAlgorithm True /= largeHash md5HashAlgorithm False)++prop_genericUniqueness :: TestA -> TestA -> Bool+prop_genericUniqueness = generic_uniquenessProp++prop_intUniqueness :: Int -> Int -> Bool+prop_intUniqueness = generic_uniquenessProp++prop_int8Uniqueness :: Int8 -> Int8 -> Bool+prop_int8Uniqueness = generic_uniquenessProp++prop_int16Uniqueness :: Int16 -> Int16 -> Bool+prop_int16Uniqueness = generic_uniquenessProp++prop_int32Uniqueness :: Int32 -> Int32 -> Bool+prop_int32Uniqueness = generic_uniquenessProp++prop_int64Uniqueness :: Int64 -> Int64 -> Bool+prop_int64Uniqueness = generic_uniquenessProp++prop_wordUniqueness :: Word -> Word -> Bool+prop_wordUniqueness = generic_uniquenessProp++prop_word8Uniqueness :: Word8 -> Word8 -> Bool+prop_word8Uniqueness = generic_uniquenessProp++prop_word16Uniqueness :: Word16 -> Word16 -> Bool+prop_word16Uniqueness = generic_uniquenessProp++prop_word32Uniqueness :: Word32 -> Word32 -> Bool+prop_word32Uniqueness = generic_uniquenessProp++prop_word64Uniqueness :: Word64 -> Word64 -> Bool+prop_word64Uniqueness = generic_uniquenessProp++prop_charUniqueness :: Char -> Char -> Bool+prop_charUniqueness = generic_uniquenessProp++prop_bytestringUniqueness :: B.ByteString -> B.ByteString -> Bool+prop_bytestringUniqueness = generic_uniquenessProp++prop_appendByteStringOk :: B.ByteString -> B.ByteString -> Bool+prop_appendByteStringOk b1 b2 =+ runMD5 (updateHash (b1 `B.append` b2)) /=+ runMD5 (updateHash b1 >> updateHash b2)++test_irrelevantByteStringChunking :: IO ()+test_irrelevantByteStringChunking = do+ assertEqual (largeHash md5HashAlgorithm (BL.fromChunks ["foo", "ba", "r"]))+ (largeHash md5HashAlgorithm (BL.fromChunks ["foob", "ar"]))++prop_lazyBytestringUniqueness :: BL.ByteString -> BL.ByteString -> Bool+prop_lazyBytestringUniqueness = generic_uniquenessProp++prop_appendLazyByteStringOk :: BL.ByteString -> BL.ByteString -> Bool+prop_appendLazyByteStringOk b1 b2 =+ runMD5 (updateHash (b1 `BL.append` b2)) /=+ runMD5 (updateHash b1 >> updateHash b2)++prop_shortBytestringUniqueness :: BS.ShortByteString -> BS.ShortByteString -> Bool+prop_shortBytestringUniqueness = generic_uniquenessProp++prop_textUniqueness :: T.Text -> T.Text -> Bool+prop_textUniqueness = generic_uniquenessProp++prop_appendTextOk :: T.Text -> T.Text -> Bool+prop_appendTextOk t1 t2 =+ runMD5 (updateHash (t1 `T.append` t2)) /=+ runMD5 (updateHash t1 >> updateHash t2)++test_irrelevantTextChunking :: IO ()+test_irrelevantTextChunking = do+ assertEqual (largeHash md5HashAlgorithm (TL.fromChunks ["don't", " pa", "nic"]))+ (largeHash md5HashAlgorithm (TL.fromChunks ["don", "'t p", "an", "ic"]))++prop_lazyTextUniqueness :: TL.Text -> TL.Text -> Bool+prop_lazyTextUniqueness = generic_uniquenessProp++prop_appendLazyTextOk :: TL.Text -> TL.Text -> Bool+prop_appendLazyTextOk t1 t2 =+ runMD5 (updateHash (t1 `TL.append` t2)) /=+ runMD5 (updateHash t1 >> updateHash t2)++prop_listUniqueness :: [Bool] -> [Bool] -> Bool+prop_listUniqueness = generic_uniquenessProp++prop_appendListOk :: [Int] -> [Int] -> Bool+prop_appendListOk l1 l2 =+ runMD5 (updateHash (l1 ++ l2)) /=+ runMD5 (updateHash l1 >> updateHash l2)++prop_DoubleUniqueness :: Double -> Double -> Bool+prop_DoubleUniqueness = generic_uniquenessProp++prop_FloatUniqueness :: Float -> Float -> Bool+prop_FloatUniqueness = generic_uniquenessProp++prop_setUniqueness :: Set Int -> Set Int -> Bool+prop_setUniqueness = generic_uniquenessProp++test_hashSet :: IO ()+test_hashSet =+ do let s1 = Set.fromList [1::Int, 2, 3]+ s2 = Set.fromList [3::Int, 2, 1]+ s3 = Set.fromList [2::Int, 1, 3]+ assertEqual (largeHash md5HashAlgorithm s1) (largeHash md5HashAlgorithm s2)+ assertEqual (largeHash md5HashAlgorithm s1) (largeHash md5HashAlgorithm s3)+ assertEqual (largeHash md5HashAlgorithm s2) (largeHash md5HashAlgorithm s3)++prop_unionSetOk :: Set Int -> Set Int -> Bool+prop_unionSetOk s1 s2 =+ runMD5 (updateHash (s1 `Set.union` s2)) /= runMD5 (updateHash s1 >> updateHash s2)++prop_intSetUniqueness :: IS.IntSet -> IS.IntSet -> Bool+prop_intSetUniqueness = generic_uniquenessProp++test_hashIntSet :: IO ()+test_hashIntSet =+ do let s1 = IS.fromList [1::Int, 2, 3]+ s2 = IS.fromList [3::Int, 2, 1]+ s3 = IS.fromList [2::Int, 1, 3]+ assertEqual (largeHash md5HashAlgorithm s1) (largeHash md5HashAlgorithm s2)+ assertEqual (largeHash md5HashAlgorithm s1) (largeHash md5HashAlgorithm s3)+ assertEqual (largeHash md5HashAlgorithm s2) (largeHash md5HashAlgorithm s3)++prop_unionIntSetOk :: IS.IntSet -> IS.IntSet -> Bool+prop_unionIntSetOk s1 s2 =+ runMD5 (updateHash (s1 `IS.union` s2)) /=+ runMD5 (updateHash s1 >> updateHash s2)++prop_hashSetUniqueness :: HS.HashSet Int -> HS.HashSet Int -> Bool+prop_hashSetUniqueness = generic_uniquenessProp++data ConstHash+ = ConstHash Int+ deriving (Eq)++instance Hashable ConstHash where+ hashWithSalt _ _ = 0++instance LargeHashable ConstHash where+ updateHash (ConstHash i) = updateHash i++test_hashHashSet :: IO ()+test_hashHashSet =+ do let s1 = HS.fromList [ConstHash 1, ConstHash 2, ConstHash 3]+ s2 = HS.fromList [ConstHash 3, ConstHash 2, ConstHash 1]+ s3 = HS.fromList [ConstHash 2, ConstHash 1, ConstHash 3]+ assertEqual (largeHash md5HashAlgorithm s1) (largeHash md5HashAlgorithm s2)+ assertEqual (largeHash md5HashAlgorithm s1) (largeHash md5HashAlgorithm s3)+ assertEqual (largeHash md5HashAlgorithm s2) (largeHash md5HashAlgorithm s3)++prop_unionHashSetOk :: HS.HashSet Int -> HS.HashSet Int -> Bool+prop_unionHashSetOk s1 s2 =+ runMD5 (updateHash (s1 `HS.union` s2)) /=+ runMD5 (updateHash s1 >> updateHash s2)++prop_mapUniqueness :: Map Int String -> Map Int String -> Bool+prop_mapUniqueness = generic_uniquenessProp++test_hashMap :: IO ()+test_hashMap =+ do let m1 = Map.fromList [(1::Int, "1"::String), (2, "2"), (3, "3")]+ m2 = Set.fromList [(3::Int, "3"::String), (2, "2"), (1, "1")]+ m3 = Set.fromList [(2::Int, "2"::String), (1, "1"), (3, "3")]+ assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m2)+ assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m3)+ assertEqual (largeHash md5HashAlgorithm m2) (largeHash md5HashAlgorithm m3)++prop_unionMapOk :: Map Int Bool -> Map Int Bool -> Bool+prop_unionMapOk m1 m2 =+ runMD5 (updateHash (m1 `Map.union` m2)) /= runMD5 (updateHash m1 >> updateHash m2)++prop_intMapUniqueness :: IM.IntMap String -> IM.IntMap String -> Bool+prop_intMapUniqueness = generic_uniquenessProp++test_hashIntMap :: IO ()+test_hashIntMap =+ do let m1 = IM.fromList [(1::Int, "1"::String), (2, "2"), (3, "3")]+ m2 = IM.fromList [(3::Int, "3"::String), (2, "2"), (1, "1")]+ m3 = IM.fromList [(2::Int, "2"::String), (1, "1"), (3, "3")]+ assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m2)+ assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m3)+ assertEqual (largeHash md5HashAlgorithm m2) (largeHash md5HashAlgorithm m3)++prop_unionIntMapOk :: IM.IntMap Bool -> IM.IntMap Bool -> Bool+prop_unionIntMapOk m1 m2 =+ runMD5 (updateHash (m1 `IM.union` m2)) /= runMD5 (updateHash m1 >> updateHash m2)++prop_hashMapUniqueness :: HM.HashMap Int Bool -> HM.HashMap Int Bool -> Bool+prop_hashMapUniqueness = generic_uniquenessProp++test_hashHashMap :: IO ()+test_hashHashMap =+ do let val = "foo" :: String+ m1 = HM.fromList [(ConstHash 1, val), (ConstHash 2, val), (ConstHash 3, val)]+ m2 = HM.fromList [(ConstHash 3, val), (ConstHash 2, val), (ConstHash 1, val)]+ m3 = HM.fromList [(ConstHash 2, val), (ConstHash 1, val), (ConstHash 3, val)]+ assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m2)+ assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m3)+ assertEqual (largeHash md5HashAlgorithm m2) (largeHash md5HashAlgorithm m3)++prop_unionHashMapOk :: HM.HashMap Int Bool -> HM.HashMap Int Bool -> Bool+prop_unionHashMapOk m1 m2 =+ runMD5 (updateHash (m1 `HM.union` m2)) /= runMD5 (updateHash m1 >> updateHash m2)++prop_hashMapLazyUniqueness :: HML.HashMap Int Bool -> HML.HashMap Int Bool -> Bool+prop_hashMapLazyUniqueness = generic_uniquenessProp++test_hashHashMapLazy :: IO ()+test_hashHashMapLazy =+ do let val = "foo" :: String+ m1 = HML.fromList [(ConstHash 1, val), (ConstHash 2, val), (ConstHash 3, val)]+ m2 = HML.fromList [(ConstHash 3, val), (ConstHash 2, val), (ConstHash 1, val)]+ m3 = HML.fromList [(ConstHash 2, val), (ConstHash 1, val), (ConstHash 3, val)]+ assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m2)+ assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m3)+ assertEqual (largeHash md5HashAlgorithm m2) (largeHash md5HashAlgorithm m3)++prop_hashPairUniqueness :: (Int, Int) -> (Int, Int) -> Bool+prop_hashPairUniqueness = generic_uniquenessProp++prop_hashTripleUniqueness :: (Int, Int, Int) -> (Int, Int, Int) -> Bool+prop_hashTripleUniqueness = generic_uniquenessProp++prop_hashQuadrupleUniqueness :: (Int, Int, Int, Int) -> (Int, Int, Int, Int) -> Bool+prop_hashQuadrupleUniqueness = generic_uniquenessProp++prop_hashQuintupleUniqueness :: (Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int) -> Bool+prop_hashQuintupleUniqueness = generic_uniquenessProp++prop_hashStrictPairUniqueness :: Tuple.Pair Int Int -> Tuple.Pair Int Int -> Bool+prop_hashStrictPairUniqueness = generic_uniquenessProp++prop_hashMaybeUniqueness :: Maybe Int -> Maybe Int -> Bool+prop_hashMaybeUniqueness = generic_uniquenessProp++prop_hashEitherUniqueness :: Either Int Bool -> Either Int Bool -> Bool+prop_hashEitherUniqueness = generic_uniquenessProp++prop_hashOrderingUniqueness :: Ordering -> Ordering -> Bool+prop_hashOrderingUniqueness = generic_uniquenessProp++prop_ratioUniqueness :: Ratio Int -> Ratio Int -> Bool+prop_ratioUniqueness = generic_uniquenessProp++test_ratio :: IO ()+test_ratio =+ do let r1 = (1::Int) % 2+ r2 = (2::Int) % 4+ assertEqual (largeHash md5HashAlgorithm r1) (largeHash md5HashAlgorithm r2)++prop_dayUniqueness :: Day -> Day -> Bool+prop_dayUniqueness = generic_uniquenessProp++prop_diffTimeUniqueness :: DiffTime -> DiffTime -> Bool+prop_diffTimeUniqueness = generic_uniquenessProp++prop_utcTimeUniqueness :: UTCTime -> UTCTime -> Bool+prop_utcTimeUniqueness = generic_uniquenessProp++prop_absoluteTimeUniqueness :: AbsoluteTime -> AbsoluteTime -> Bool+prop_absoluteTimeUniqueness = generic_uniquenessProp++prop_nominalDiffTimeUniqueness :: NominalDiffTime -> NominalDiffTime -> Bool+prop_nominalDiffTimeUniqueness = generic_uniquenessProp++prop_timeZoneUniqueness :: TimeZone -> TimeZone -> Bool+prop_timeZoneUniqueness = generic_uniquenessProp++prop_timeOfDayUniqueness :: TimeOfDay -> TimeOfDay -> Bool+prop_timeOfDayUniqueness = generic_uniquenessProp++prop_localTimeUniqueness :: LocalTime -> LocalTime -> Bool+prop_localTimeUniqueness = generic_uniquenessProp++prop_fixedUniqueness :: Fixed E1 -> Fixed E1 -> Bool+prop_fixedUniqueness = generic_uniquenessProp++prop_scientificUniqueness :: Sci.Scientific -> Sci.Scientific -> Bool+prop_scientificUniqueness = generic_uniquenessProp++prop_aesonValueUniqueness :: J.Value -> J.Value -> Bool+prop_aesonValueUniqueness = generic_uniquenessProp++prop_vectorUniqueness :: V.Vector Int -> V.Vector Int -> Bool+prop_vectorUniqueness = generic_uniquenessProp++prop_appendVectorOk :: V.Vector Int -> V.Vector Int -> Bool+prop_appendVectorOk v1 v2 =+ runMD5 (updateHash (v1 V.++ v2)) /=+ runMD5 (updateHash v1 >> updateHash v2)++prop_seqUniqueness :: Seq.Seq Int -> Seq.Seq Int -> Bool+prop_seqUniqueness = generic_uniquenessProp++prop_appendSeqOk :: Seq.Seq Int -> Seq.Seq Int -> Bool+prop_appendSeqOk s1 s2 =+ runMD5 (updateHash (s1 Seq.>< s2)) /=+ runMD5 (updateHash s1 >> updateHash s2)
+ test/Data/LargeHashable/Tests/Helper.hs view
@@ -0,0 +1,228 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.LargeHashable.Tests.Helper where++-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines")+import Control.Monad+import Data.Bytes.Serial+import Data.Hashable+import Data.LargeHashable+import Data.Time.Calendar+import Data.Time.Clock+import Data.Time.Clock.TAI+import Data.Time.LocalTime+import GHC.Generics+import Test.QuickCheck+import qualified Data.Aeson as J+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Short as BS+import qualified Data.HashMap.Lazy as HML+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Scientific as Sci+import qualified Data.Strict.Tuple as Tuple+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Vector as V++#if !MIN_VERSION_QuickCheck(2,8,2)+-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines")+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import qualified Data.Map as M+import qualified Data.Set as S+#endif++instance Arbitrary T.Text where+ arbitrary = fmap T.pack arbitrary+ shrink = map T.pack . shrink . T.unpack++instance Arbitrary B.ByteString where+ arbitrary = fmap B.pack arbitrary+ shrink = map B.pack . shrink . B.unpack++instance Arbitrary BL.ByteString where+ arbitrary = fmap BL.fromChunks arbitrary+ shrink = map BL.fromChunks . shrink . BL.toChunks++instance Arbitrary TL.Text where+ arbitrary = fmap TL.fromChunks arbitrary+ shrink = map TL.fromChunks . shrink . TL.toChunks++instance Arbitrary a => Arbitrary (V.Vector a) where+ arbitrary = liftM V.fromList arbitrary+ shrink = map V.fromList . shrink . V.toList++instance Arbitrary Sci.Scientific where+ arbitrary =+ liftM2 Sci.scientific arbitrary arbitrary+ shrink = shrinkRealFrac++instance Arbitrary J.Value where+ arbitrary = sized arbitraryJsonValue+ where+ arbitraryJsonValue n =+ if n <= 0+ then oneof simpleGens+ else frequency $+ (map (\g -> (1, g)) simpleGens) +++ [(3, arbitraryObject (n `div` 2))+ ,(3, arbitraryArray (n `div` 2))]+ arbitraryObject n =+ do l <- arbitraryListOfJsonValues n+ elems <- forM l $ \v ->+ do k <-+ elements+ ["key", "foo", "bar", "baz", "spam", "egg", "chicken", "dog"+ ,"any", "what", "santa", "mark", "wardrobe", "baseball"]+ return (k, v)+ return (J.Object (HM.fromList elems))+ arbitraryArray n =+ do l <- arbitraryListOfJsonValues n+ return (J.Array (V.fromList l))+ arbitraryListOfJsonValues n =+ do size <- elements [(0::Int)..10]+ forM [1..(size::Int)] $ \_ -> arbitraryJsonValue n+ simpleGens =+ [liftM J.String arbitrary+ ,liftM J.Number arbitrary+ ,liftM J.Bool arbitrary+ ,return J.Null]+ shrink v =+ case v of+ J.Object obj ->+ map J.Object (shrink obj)+ J.Array arr ->+ map J.Array (shrink arr)+ J.String t ->+ map J.String (shrink t)+ J.Number n ->+ map J.Number (shrink n)+ J.Bool _ -> []+ J.Null -> []++instance (Eq k, Hashable k, Arbitrary k, Arbitrary a) => Arbitrary (HML.HashMap k a) where+ arbitrary = fmap HML.fromList arbitrary+ shrink = map HML.fromList . shrink . HML.toList++instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HS.HashSet a) where+ arbitrary = fmap HS.fromList arbitrary+ shrink = map HS.fromList . shrink . HS.toList++#if !MIN_VERSION_QuickCheck(2,8,2)+instance (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (M.Map k a) where+ arbitrary = fmap M.fromList arbitrary+ shrink = map M.fromList . shrink . M.toList++instance Arbitrary a => Arbitrary (IM.IntMap a) where+ arbitrary = fmap IM.fromList arbitrary+ shrink = map IM.fromList . shrink . IM.toList++instance (Ord a, Arbitrary a) => Arbitrary (S.Set a) where+ arbitrary = fmap S.fromList arbitrary+ shrink = map S.fromList . shrink . S.toList++instance Arbitrary IS.IntSet where+ arbitrary = fmap IS.fromList arbitrary+ shrink = map IS.fromList . shrink . IS.toList++#endif++data TestA+ = TestA+ { age :: Int+ , wealth :: Integer+ , isStudent :: Bool+ , name :: T.Text+ , initials :: [Char]+ , legLength :: (Int, Int)+ } deriving (Generic, Eq, Show)++instance LargeHashable TestA+instance Serial TestA++instance Arbitrary TestA where+ arbitrary =+ TestA <$> arbitrary <*> arbitrary <*> arbitrary <*>+ arbitrary <*> arbitrary <*> arbitrary++instance Arbitrary BS.ShortByteString where+ arbitrary = liftM BS.pack arbitrary+ shrink x =+ map BS.pack (shrink (BS.unpack x))++instance Arbitrary Day where+ arbitrary =+ do n <- arbitrary+ return (ModifiedJulianDay (n `mod` 1000))+ shrink (ModifiedJulianDay n) =+ map ModifiedJulianDay (shrink n)++instance Arbitrary DiffTime where+ arbitrary =+ liftM picosecondsToDiffTime arbitrary+ shrink delta =+ let n = toRational delta+ in map fromRational (shrink n)++instance Arbitrary UTCTime where+ arbitrary =+ do day <- arbitrary+ picos <- arbitrary+ return (UTCTime day (picosecondsToDiffTime (picos `mod` 86401)))++instance Arbitrary AbsoluteTime where+ arbitrary =+ do diff <- arbitrary+ return (addAbsoluteTime diff taiEpoch)++instance Arbitrary NominalDiffTime where+ arbitrary =+ do r <- arbitrary+ return (fromRational r)++instance Arbitrary TimeZone where+ arbitrary =+ do n <- arbitrary+ s <- arbitrary+ b <- arbitrary+ return (TimeZone (n `mod` (60*24)) b s)++instance Arbitrary TimeOfDay where+ arbitrary =+ do h <- arbitrary+ m <- arbitrary+ s <- arbitrary+ return (TimeOfDay (h `mod` 24) (m `mod` 60) (fromInteger (s `mod` 61)))++instance Arbitrary LocalTime where+ arbitrary =+ do d <- arbitrary+ t <- arbitrary+ return (LocalTime d t)++instance Arbitrary ZonedTime where+ arbitrary =+ do t <- arbitrary+ z <- arbitrary+ return (ZonedTime t z)++instance Arbitrary UniversalTime where+ arbitrary =+ do r <- arbitrary+ return (ModJulianDate r)++instance (Arbitrary a, Arbitrary b) => Arbitrary (Tuple.Pair a b) where+ arbitrary =+ do x <- arbitrary+ y <- arbitrary+ return (x Tuple.:!: y)++instance Arbitrary Word128 where+ arbitrary = Word128 <$> arbitrary <*> arbitrary++instance Arbitrary Word256 where+ arbitrary = Word256 <$> arbitrary <*> arbitrary
+ test/Data/LargeHashable/Tests/LargeWord.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Data.LargeHashable.Tests.LargeWord where++-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines")+import Data.LargeHashable.LargeWord+import Data.LargeHashable.Tests.Helper ()+import Test.Framework+import qualified Data.ByteString as BS++prop_w128BsHasLength16 :: Word128 -> Bool+prop_w128BsHasLength16 x = BS.length (w128ToBs x) == 16++prop_conversionFromAndToWord128 :: Word128 -> Bool+prop_conversionFromAndToWord128 h128 = h128 == bsToW128 (w128ToBs h128)++prop_conversionFromAndToWord256 :: Word256 -> Bool+prop_conversionFromAndToWord256 h256 = h256 == bsToW256 (w256ToBs h256)++test_bsToW128 :: IO ()+test_bsToW128 =+ do assertEqual (Word128 0 0) (bsToW128 BS.empty)+ assertEqual (bsToW128 (BS.pack ([0,0,0,0,0,0,0,1] ++ replicate 8 0))) (bsToW128 (BS.pack [1]))+ assertEqual (bsToW128 (BS.pack ([1,2,3,4,5,6,7,8,0,0,0,0,0,0,0,9])))+ (bsToW128 (BS.pack [1,2,3,4,5,6,7,8,9]))
+ test/Data/LargeHashable/Tests/TH.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -F -pgmF htfpp #-}+{-# OPTIONS_GHC -ddump-splices #-}+module Data.LargeHashable.Tests.TH where++import Test.Framework++import Data.LargeHashable++-- | Simple test data structure that embodies most+-- of the diferrent features of a type +-- the TH deriver can encounter.+data BlaFoo a+ = Foo+ | Bar Int a+ | Baz a a a+ deriving (Eq, Show)++$(deriveLargeHashable ''BlaFoo)++instance Arbitrary a => Arbitrary (BlaFoo a) where+ arbitrary = oneof [ pure Foo+ , Bar <$> arbitrary <*> arbitrary+ , Baz <$> arbitrary <*> arbitrary <*> arbitrary+ ]++-- | Simple property that tries to find hash collisions.+prop_thDerivedHashUnique :: BlaFoo Char -> BlaFoo Char -> Bool+prop_thDerivedHashUnique x y = (x == y) == (largeHash md5HashAlgorithm x == largeHash md5HashAlgorithm y)+ +newtype Fool = Fool { unFool :: Bool }++$(deriveLargeHashable ''Fool)++-- | Simple sanity check for TH derived instances for newtypes.+test_newtypeTHHashSane :: IO ()+test_newtypeTHHashSane = assertNotEqual (largeHash md5HashAlgorithm (Fool True))+ (largeHash md5HashAlgorithm (Fool False))++data HigherKinded t = HigherKinded (t String)+data HigherKindedContainer t = HigherKindedContainer (HigherKinded t)++instance LargeHashable' BlaFoo where+ updateHash' = updateHash++instance LargeHashable' t => LargeHashable (HigherKinded t) where+ updateHash (HigherKinded x) =+ updateHash' x++$(deriveLargeHashable ''HigherKindedContainer)++test_higherKinded :: IO ()+test_higherKinded =+ assertNotEqual+ (largeHash md5HashAlgorithm (HigherKinded (Bar 42 "Stefan")))+ (largeHash md5HashAlgorithm (HigherKinded (Bar 5 "Stefan")))
+ test/Main.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main where++import Test.Framework++-- In Emacs sort block with M-x sort-lines+import {-@ HTF_TESTS @-} Data.LargeHashable.Tests.Class+import {-@ HTF_TESTS @-} Data.LargeHashable.Tests.LargeWord+import {-@ HTF_TESTS @-} Data.LargeHashable.Tests.TH++allTests :: [TestSuite]+allTests = htf_importedTests++main :: IO ()+main = htfMain allTests