hyperloglog 0.4.6 → 0.5
raw patch · 13 files changed
+899/−811 lines, 13 filesdep +entropydep +ghc-primdep ~basesetup-changed
Dependencies added: entropy, ghc-prim
Dependency ranges changed: base
Files
- .ghci +1/−1
- .gitignore +32/−32
- .vim.custom +31/−31
- AUTHORS.markdown +11/−11
- CHANGELOG.markdown +129/−110
- LICENSE +30/−30
- README.markdown +15/−15
- Setup.lhs +7/−7
- hyperloglog.cabal +92/−87
- src/Crypto/MAC/SipHash.hs +167/−166
- src/Data/HyperLogLog.hs +25/−25
- src/Data/HyperLogLog/Config.hs +84/−84
- src/Data/HyperLogLog/Type.hs +275/−212
.ghci view
@@ -1,1 +1,1 @@-:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h -optP-Iincludes+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h -optP-Iincludes
.gitignore view
@@ -1,32 +1,32 @@-dist-dist-newstyle-docs-wiki-TAGS-tags-wip-.DS_Store-.*.swp-.*.swo-*.o-*.hi-*~-*#-.stack-work/-cabal-dev-*.chi-*.chs.h-*.dyn_o-*.dyn_hi-.hpc-.hsenv-.cabal-sandbox/-cabal.sandbox.config-*.prof-*.aux-*.hp-*.eventlog-cabal.project.local-cabal.project.local~-.HTF/-.ghc.environment.*+dist +dist-newstyle +docs +wiki +TAGS +tags +wip +.DS_Store +.*.swp +.*.swo +*.o +*.hi +*~ +*# +.stack-work/ +cabal-dev +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.*
.vim.custom view
@@ -1,31 +1,31 @@-" Add the following to your .vimrc to automatically load this on startup--" if filereadable(".vim.custom")-" so .vim.custom-" endif--function StripTrailingWhitespace()- let myline=line(".")- let mycolumn = col(".")- silent %s/ *$//- call cursor(myline, mycolumn)-endfunction--" enable syntax highlighting-syntax on--" search for the tags file anywhere between here and /-set tags=TAGS;/--" highlight tabs and trailing spaces-set listchars=tab:‗‗,trail:‗-set list--" f2 runs hasktags-map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>--" strip trailing whitespace before saving-" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()--" rebuild hasktags after saving-au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"+" Add the following to your .vimrc to automatically load this on startup + +" if filereadable(".vim.custom") +" so .vim.custom +" endif + +function StripTrailingWhitespace() + let myline=line(".") + let mycolumn = col(".") + silent %s/ *$// + call cursor(myline, mycolumn) +endfunction + +" enable syntax highlighting +syntax on + +" search for the tags file anywhere between here and / +set tags=TAGS;/ + +" highlight tabs and trailing spaces +set listchars=tab:‗‗,trail:‗ +set list + +" f2 runs hasktags +map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR> + +" strip trailing whitespace before saving +" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() + +" rebuild hasktags after saving +au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
AUTHORS.markdown view
@@ -1,11 +1,11 @@-Analytics was started by [Edward Kmett](https://github.com/ekmett) in response to a question by [Alec Heller](https://github.com/deviant-logic) about if he should use `bound` to implement datalog. It has since somewhat expanded in scope.--`hyperloglog` was split out of the `analytics` repository, and borrows innovations from [Ozgun Ataman](https://github.com/soostone)'s implementation of `HyperLogLog` in Haskell as well as twitter's `algebird` project.--You can watch contributors carry on the quest for bragging rights in the [contributors graph](https://github.com/analytics/compensated/graphs/contributors).--Omission from this list is by no means an attempt to discount your contribution.--Thank you for all of your help!---Edward Kmett+Analytics was started by [Edward Kmett](https://github.com/ekmett) in response to a question by [Alec Heller](https://github.com/deviant-logic) about if he should use `bound` to implement datalog. It has since somewhat expanded in scope. + +`hyperloglog` was split out of the `analytics` repository, and borrows innovations from [Ozgun Ataman](https://github.com/soostone)'s implementation of `HyperLogLog` in Haskell as well as twitter's `algebird` project. + +You can watch contributors carry on the quest for bragging rights in the [contributors graph](https://github.com/analytics/compensated/graphs/contributors). + +Omission from this list is by no means an attempt to discount your contribution. + +Thank you for all of your help! + +-Edward Kmett
CHANGELOG.markdown view
@@ -1,110 +1,129 @@-0.4.6 [2022.04.18]--------------------* Remove the `siphash` dependency. Because `siphash` no longer builds on- GHC 9.2+, we instead bundle the code alongside `hyperloglog`. This allows- `hyperloglog` to build with 9.2.--0.4.5 [2021.11.16]--------------------* Drop support for pre-8.0 versions of GHC.-* Allow building with `hashable-1.4.*`.--0.4.4 [2021.02.17]--------------------* Allow building with `lens-5.*`.-* The build-type has been changed from `Custom` to `Simple`.- To achieve this, the `doctests` test suite has been removed in favor of using- [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec)- to run the doctests.--0.4.3 [2019.09.13]--------------------* Remove unused `safecopy` dependency.--0.4.2-------* Add a library dependency on the `doctests` test suite--0.4.1-------* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build- with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and- sandboxes.-* Drop (unused) `hashable-extras` dependency-* Add `NFData` instance for `HyperLogLog`-* Require GHC 7.8 or later--0.4.0.4---------* Support `cereal` 0.5 and `safecopy` 0.9.--0.4.0.3---------* Fixed doctest issues caused by `vector` 0.11-* Unfortunately the `herbie` changes turned out to be flawed (due to issue mikeizbicki/HerbiePlugin#8). Rolling them back for now.--0.4.0.2---------* Fixed a haddock issue caused by the comments in the herbie code.--0.4.0.1---------* Added `vector` 0.11 support.-* Incorporated some changes suggested by the HerbiePlugin.--0.3.4-------* Support `generic-deriving` 1.8. We no longer incur a `generic-deriving` requirement at all except on GHC < 7.6.--0.3.3.1---------* Support `reflection` 2--0.3.3-------* Added `bytes` and `binary` instances.-* Compiles warning-free on GHC 7.10.--0.3.2-------* Simplified `reifyConfig` internals.--0.3.1-------* Added `insertHash`. This enables users of the 0.2- era version of `hyperloglog` to manually pick the- hash used and load their old data.-* Builds warning-free on GHC 7.10--0.3.0.1-----* Constraint bumps for `lens` and `generic-deriving`--0.3-----* Switched to `SipHash`, so the package actually works.--0.2.3.2---------* More `#ifdef` bugfixes--0.2.3.1---------* `#ifdef` bugfix--0.2.3-------* GHC 7.8 compatibility-* Bumped `cereal` dependency.--0.2.1-------* Exported `insert` from `Data.HyperLogLog`.--0.2-----* Made compatible with `lens` 4--0.1-----* Ported `Data.Analytics.Approximate.HyperLogLog` from [analytics](http://github.com/analytics) into a separate package.+0.5 [2025.01.25] +---------------- +* Add a `generateHyperLogLog` function that randomly generates a `HyperLogLog` + value using system entropy. This function is suitable for scenarios where + cryptographic security is a primary consideration. +* Add an additional `s` type parameter to `HyperLogLog` that encodes the + `SipKey` used to configure the hash function when `insert`ing new values. + (Previously, inserting a new value would always use a fixed `SipKey`.) + + In order to continue using the old behavior of the `insert` function, one + can instantiate `s` to the newly added `DefaultSipKey` type. Note that this + is *not* cryptographically secure, however. (In contrast, the + `generateHyperLogLog` function instantiates `s` with a randomly generated + `SipKey`.) +* Export the `SipKey` data type and define a `reifySipKey` function to promote + a `SipKey` value to the type level. +* Define a `type DefaultHyperLogLog = HyperLogLog DefaultSipKey` type synonym. +* Drop support for GHC 8.0. + +0.4.6 [2022.04.18] +------------------ +* Remove the `siphash` dependency. Because `siphash` no longer builds on + GHC 9.2+, we instead bundle the code alongside `hyperloglog`. This allows + `hyperloglog` to build with 9.2. + +0.4.5 [2021.11.16] +------------------ +* Drop support for pre-8.0 versions of GHC. +* Allow building with `hashable-1.4.*`. + +0.4.4 [2021.02.17] +------------------ +* Allow building with `lens-5.*`. +* The build-type has been changed from `Custom` to `Simple`. + To achieve this, the `doctests` test suite has been removed in favor of using + [`cabal-docspec`](https://github.com/phadej/cabal-extras/tree/master/cabal-docspec) + to run the doctests. + +0.4.3 [2019.09.13] +------------------ +* Remove unused `safecopy` dependency. + +0.4.2 +----- +* Add a library dependency on the `doctests` test suite + +0.4.1 +----- +* Revamp `Setup.hs` to use `cabal-doctest`. This makes it build + with `Cabal-2.0`, and makes the `doctest`s work with `cabal new-build` and + sandboxes. +* Drop (unused) `hashable-extras` dependency +* Add `NFData` instance for `HyperLogLog` +* Require GHC 7.8 or later + +0.4.0.4 +------- +* Support `cereal` 0.5 and `safecopy` 0.9. + +0.4.0.3 +------- +* Fixed doctest issues caused by `vector` 0.11 +* Unfortunately the `herbie` changes turned out to be flawed (due to issue mikeizbicki/HerbiePlugin#8). Rolling them back for now. + +0.4.0.2 +------- +* Fixed a haddock issue caused by the comments in the herbie code. + +0.4.0.1 +------- +* Added `vector` 0.11 support. +* Incorporated some changes suggested by the HerbiePlugin. + +0.3.4 +----- +* Support `generic-deriving` 1.8. We no longer incur a `generic-deriving` requirement at all except on GHC < 7.6. + +0.3.3.1 +------- +* Support `reflection` 2 + +0.3.3 +----- +* Added `bytes` and `binary` instances. +* Compiles warning-free on GHC 7.10. + +0.3.2 +----- +* Simplified `reifyConfig` internals. + +0.3.1 +----- +* Added `insertHash`. This enables users of the 0.2 + era version of `hyperloglog` to manually pick the + hash used and load their old data. +* Builds warning-free on GHC 7.10 + +0.3.0.1 +--- +* Constraint bumps for `lens` and `generic-deriving` + +0.3 +--- +* Switched to `SipHash`, so the package actually works. + +0.2.3.2 +------- +* More `#ifdef` bugfixes + +0.2.3.1 +------- +* `#ifdef` bugfix + +0.2.3 +----- +* GHC 7.8 compatibility +* Bumped `cereal` dependency. + +0.2.1 +----- +* Exported `insert` from `Data.HyperLogLog`. + +0.2 +--- +* Made compatible with `lens` 4 + +0.1 +--- +* Ported `Data.Analytics.Approximate.HyperLogLog` from [analytics](http://github.com/analytics) into a separate package.
LICENSE view
@@ -1,30 +1,30 @@-Copyright 2013-2015 Edward Kmett--All rights reserved.--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.--3. Neither the name of the author nor the names of his contributors- may be used to endorse or promote products derived from this software- without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.+Copyright 2013-2015 Edward Kmett + +All rights reserved. + +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. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.markdown view
@@ -1,15 +1,15 @@-hyperloglog-===========--[](https://hackage.haskell.org/package/hyperloglog) [](https://github.com/ekmett/hyperloglog/actions?query=workflow%3AHaskell-CI)--This package provides a working implementation of HyperLogLog.--Contact Information----------------------Contributions and bug reports are welcome!--Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.---Edward Kmett+hyperloglog +=========== + +[](https://hackage.haskell.org/package/hyperloglog) [](https://github.com/ekmett/hyperloglog/actions?query=workflow%3AHaskell-CI) + +This package provides a working implementation of HyperLogLog. + +Contact Information +------------------- + +Contributions and bug reports are welcome! + +Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. + +-Edward Kmett
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/runhaskell-> module Main (main) where--> import Distribution.Simple--> main :: IO ()-> main = defaultMain+#!/usr/bin/runhaskell +> module Main (main) where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain
hyperloglog.cabal view
@@ -1,87 +1,92 @@-name: hyperloglog-category: Numeric-version: 0.4.6-license: BSD3-cabal-version: >= 1.10-license-file: LICENSE-author: Edward A. Kmett-maintainer: Edward A. Kmett <ekmett@gmail.com>-stability: provisional-homepage: http://github.com/analytics/hyperloglog-bug-reports: http://github.com/analytics/hyperloglog/issues-copyright: Copyright (C) 2013-2015 Edward A. Kmett-build-type: Simple-tested-with: GHC == 8.0.2- , GHC == 8.2.2- , GHC == 8.4.4- , GHC == 8.6.5- , GHC == 8.8.4- , GHC == 8.10.7- , GHC == 9.0.2- , GHC == 9.2.2-synopsis: An approximate streaming (constant space) unique object counter-description:- This package provides an approximate streaming (constant space) unique object counter.- .- See the original paper for details:- <http://algo.inria.fr/flajolet/Publications/FlFuGaMe07.pdf>- .- Notably it can be used to approximate a set of several billion elements with 1-2% inaccuracy- in around 1.5k of memory.--extra-source-files:- .ghci- .gitignore- .vim.custom- AUTHORS.markdown- README.markdown- CHANGELOG.markdown--source-repository head- type: git- location: git://github.com/analytics/hyperloglog.git--flag herbie- default: False- manual: True--library- build-depends:- approximate >= 0.2.1 && < 1,- base >= 4.9 && < 5,- binary >= 0.5 && < 0.9,- bits >= 0.2 && < 1,- bytes >= 0.7 && < 1,- cereal >= 0.3.5 && < 0.6,- cereal-vector >= 0.2 && < 0.3,- comonad >= 4 && < 6,- deepseq >= 1.3 && < 1.5,- distributive >= 0.3 && < 1,- hashable >= 1.1.2.3 && < 1.5,- lens >= 4 && < 6,- reflection >= 1.3 && < 3,- semigroupoids >= 4 && < 6,- semigroups >= 0.8.4 && < 1,- tagged >= 0.4.5 && < 1,- vector >= 0.9 && < 0.13-- if flag(herbie)- build-depends: HerbiePlugin >= 0.1 && < 0.2- cpp-options: -DHERBIE- ghc-options: -fplugin=Herbie-- exposed-modules:- Data.HyperLogLog- Data.HyperLogLog.Config- Data.HyperLogLog.Type-- other-modules:- Crypto.MAC.SipHash- -- Only needed for Crypto.MAC.SipHash- build-depends:- bytestring >= 0.9 && < 0.12,- cpu >= 0.1 && < 0.2-- ghc-options: -Wall -Wtabs -O2- hs-source-dirs: src- default-language: Haskell2010+name: hyperloglog +category: Numeric +version: 0.5 +license: BSD3 +cabal-version: >= 1.10 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett <ekmett@gmail.com> +stability: provisional +homepage: http://github.com/analytics/hyperloglog +bug-reports: http://github.com/analytics/hyperloglog/issues +copyright: Copyright (C) 2013-2015 Edward A. Kmett +build-type: Simple +tested-with: GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.6 + , GHC == 9.8.2 + , GHC == 9.10.1 +synopsis: An approximate streaming (constant space) unique object counter +description: + This package provides an approximate streaming (constant space) unique object counter. + . + See the original paper for details: + <http://algo.inria.fr/flajolet/Publications/FlFuGaMe07.pdf> + . + Notably it can be used to approximate a set of several billion elements with 1-2% inaccuracy + in around 1.5k of memory. + +extra-source-files: + .ghci + .gitignore + .vim.custom + AUTHORS.markdown + README.markdown + CHANGELOG.markdown + +source-repository head + type: git + location: git://github.com/analytics/hyperloglog.git + +flag herbie + default: False + manual: True + +library + build-depends: + approximate >= 0.2.1 && < 1, + base >= 4.10 && < 5, + binary >= 0.5 && < 0.9, + bits >= 0.2 && < 1, + bytes >= 0.7 && < 1, + cereal >= 0.3.5 && < 0.6, + cereal-vector >= 0.2 && < 0.3, + comonad >= 4 && < 6, + deepseq >= 1.3 && < 1.6, + distributive >= 0.3 && < 1, + entropy >= 0.4 && < 0.5, + ghc-prim, + hashable >= 1.1.2.3 && < 1.6, + lens >= 4 && < 6, + reflection >= 1.3 && < 3, + semigroupoids >= 4 && < 7, + semigroups >= 0.8.4 && < 1, + tagged >= 0.4.5 && < 1, + vector >= 0.9 && < 0.14 + + if flag(herbie) + build-depends: HerbiePlugin >= 0.1 && < 0.2 + cpp-options: -DHERBIE + ghc-options: -fplugin=Herbie + + exposed-modules: + Data.HyperLogLog + Data.HyperLogLog.Config + Data.HyperLogLog.Type + + other-modules: + Crypto.MAC.SipHash + -- Only needed for Crypto.MAC.SipHash + build-depends: + bytestring >= 0.9 && < 0.13, + cpu >= 0.1 && < 0.2 + + ghc-options: -Wall -Wtabs -O2 + hs-source-dirs: src + default-language: Haskell2010
src/Crypto/MAC/SipHash.hs view
@@ -1,166 +1,167 @@--- |--- Module : Crypto.MAC.SipHash--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : good------ provide the SipHash algorithm.--- reference: <http://131002.net/siphash/siphash.pdf>------ This is a copy of the code from the @siphash@ library, which is licensed--- under the 3-Clause BSD License. Unfortunately, @siphash@ no longer compiles--- on GHC 9.2 or later, and since @siphash@ is deprecated, it is unlikely that--- it will receive future updates. For the time being, we have opted to--- internalize the code in the @hyperloglog@ library, as it is relatively--- self-contained. In the future, we may want to consider offering this code as--- a standalone library.-{-# LANGUAGE BangPatterns #-}-module Crypto.MAC.SipHash- ( SipKey(..)- , SipHash(..)- , hash- , hashWith- ) where--import Data.Word-import Data.Bits-import Data.ByteString.Internal-import Control.Monad--import Foreign.ForeignPtr-import Foreign.Ptr-import Foreign.Storable-import System.Endian (fromLE64)-import System.IO.Unsafe (unsafeDupablePerformIO)---- | SigHash Key-data SipKey = SipKey {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64---- | Siphash tag value-newtype SipHash = SipHash Word64- deriving (Show,Eq)--data InternalState = InternalState {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64---- | produce a siphash with a key and a bytestring.-hash :: SipKey -> ByteString -> SipHash-hash = hashWith 2 4---- | same as 'hash', except also specifies the number of sipround iterations for compression and digest.-hashWith :: Int -> Int -> SipKey -> ByteString -> SipHash-hashWith c d key (PS ps s fl) = unsafeDupablePerformIO $ withForeignPtr ps (\ptr -> runHash (initSip key) (ptr `plusPtr` s) fl)- where runHash !st !ptr l- | l > 7 = fromLE64 `fmap` peek (castPtr ptr) >>= \v -> runHash (process st v) (ptr `plusPtr` 8) (l-8)- | otherwise = do- let !lengthBlock = (fromIntegral fl `mod` 256) `unsafeShiftL` 56- (finish . process st) `fmap` case l of- 0 -> do return lengthBlock- 1 -> do v0 <- peekByteOff ptr 0- return (lengthBlock .|. to64 v0)- 2 -> do (v0,v1) <- liftM2 (,) (peekByteOff ptr 0) (peekByteOff ptr 1)- return (lengthBlock- .|. (to64 v1 `unsafeShiftL` 8)- .|. to64 v0)- 3 -> do (v0,v1,v2) <- liftM3 (,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2)- return ( lengthBlock- .|. (to64 v2 `unsafeShiftL` 16)- .|. (to64 v1 `unsafeShiftL` 8)- .|. to64 v0)- 4 -> do (v0,v1,v2,v3) <- liftM4 (,,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2)- (peekByteOff ptr 3)- return ( lengthBlock- .|. (to64 v3 `unsafeShiftL` 24)- .|. (to64 v2 `unsafeShiftL` 16)- .|. (to64 v1 `unsafeShiftL` 8)- .|. to64 v0)- 5 -> do (v0,v1,v2,v3,v4) <- liftM5 (,,,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2)- (peekByteOff ptr 3) (peekByteOff ptr 4)- return ( lengthBlock- .|. (to64 v4 `unsafeShiftL` 32)- .|. (to64 v3 `unsafeShiftL` 24)- .|. (to64 v2 `unsafeShiftL` 16)- .|. (to64 v1 `unsafeShiftL` 8)- .|. to64 v0)- 6 -> do v0 <- peekByteOff ptr 0- v1 <- peekByteOff ptr 1- v2 <- peekByteOff ptr 2- v3 <- peekByteOff ptr 3- v4 <- peekByteOff ptr 4- v5 <- peekByteOff ptr 5- return ( lengthBlock- .|. (to64 v5 `unsafeShiftL` 40)- .|. (to64 v4 `unsafeShiftL` 32)- .|. (to64 v3 `unsafeShiftL` 24)- .|. (to64 v2 `unsafeShiftL` 16)- .|. (to64 v1 `unsafeShiftL` 8)- .|. to64 v0)- 7 -> do v0 <- peekByteOff ptr 0- v1 <- peekByteOff ptr 1- v2 <- peekByteOff ptr 2- v3 <- peekByteOff ptr 3- v4 <- peekByteOff ptr 4- v5 <- peekByteOff ptr 5- v6 <- peekByteOff ptr 6- return ( lengthBlock- .|. (to64 v6 `unsafeShiftL` 48)- .|. (to64 v5 `unsafeShiftL` 40)- .|. (to64 v4 `unsafeShiftL` 32)- .|. (to64 v3 `unsafeShiftL` 24)- .|. (to64 v2 `unsafeShiftL` 16)- .|. (to64 v1 `unsafeShiftL` 8)- .|. to64 v0)- _ -> error "siphash: internal error: cannot happen"-- {-# INLINE to64 #-}- to64 :: Word8 -> Word64- to64 = fromIntegral-- {-# INLINE process #-}- process istate m = newState- where newState = postInject $! runRoundsCompression $! preInject istate- preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 v2 (v3 `xor` m)- postInject (InternalState v0 v1 v2 v3) = InternalState (v0 `xor` m) v1 v2 v3-- {-# INLINE finish #-}- finish istate = getDigest $! runRoundsDigest $! preInject istate- where getDigest (InternalState v0 v1 v2 v3) = SipHash (v0 `xor` v1 `xor` v2 `xor` v3)- preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 (v2 `xor` 0xff) v3-- {-# INLINE doRound #-}- doRound (InternalState v0 v1 v2 v3) =- let !v0' = v0 + v1- !v2' = v2 + v3- !v1' = v1 `rotateL` 13- !v3' = v3 `rotateL` 16- !v1'' = v1' `xor` v0'- !v3'' = v3' `xor` v2'- !v0'' = v0' `rotateL` 32- !v2'' = v2' + v1''- !v0''' = v0'' + v3''- !v1''' = v1'' `rotateL` 17- !v3''' = v3'' `rotateL` 21- !v1'''' = v1''' `xor` v2''- !v3'''' = v3''' `xor` v0'''- !v2''' = v2'' `rotateL` 32- in InternalState v0''' v1'''' v2''' v3''''-- {-# INLINE runRoundsCompression #-}- runRoundsCompression st- | c == 2 = doRound $! doRound st- | otherwise = loopRounds c st-- {-# INLINE runRoundsDigest #-}- runRoundsDigest st- | d == 4 = doRound $! doRound $! doRound $! doRound st- | otherwise = loopRounds d st-- {-# INLINE loopRounds #-}- loopRounds 1 !v = doRound v- loopRounds n !v = loopRounds (n-1) (doRound v)-- {-# INLINE initSip #-}- initSip (SipKey k0 k1) = InternalState (k0 `xor` 0x736f6d6570736575)- (k1 `xor` 0x646f72616e646f6d)- (k0 `xor` 0x6c7967656e657261)- (k1 `xor` 0x7465646279746573)+-- | +-- Module : Crypto.MAC.SipHash +-- License : BSD-style +-- Maintainer : Vincent Hanquez <vincent@snarc.org> +-- Stability : experimental +-- Portability : good +-- +-- provide the SipHash algorithm. +-- reference: <http://131002.net/siphash/siphash.pdf> +-- +-- This is a copy of the code from the @siphash@ library, which is licensed +-- under the 3-Clause BSD License. Unfortunately, @siphash@ no longer compiles +-- on GHC 9.2 or later, and since @siphash@ is deprecated, it is unlikely that +-- it will receive future updates. For the time being, we have opted to +-- internalize the code in the @hyperloglog@ library, as it is relatively +-- self-contained. In the future, we may want to consider offering this code as +-- a standalone library. +{-# LANGUAGE BangPatterns #-} +module Crypto.MAC.SipHash + ( SipKey(..) + , SipHash(..) + , hash + , hashWith + ) where + +import Data.Word +import Data.Bits +import Data.ByteString.Internal +import Control.Monad + +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable +import System.Endian (fromLE64) +import System.IO.Unsafe (unsafeDupablePerformIO) + +-- | SigHash Key +data SipKey = SipKey {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + deriving (Show,Read,Eq,Ord) + +-- | Siphash tag value +newtype SipHash = SipHash Word64 + deriving (Show,Eq) + +data InternalState = InternalState {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + +-- | produce a siphash with a key and a bytestring. +hash :: SipKey -> ByteString -> SipHash +hash = hashWith 2 4 + +-- | same as 'hash', except also specifies the number of sipround iterations for compression and digest. +hashWith :: Int -> Int -> SipKey -> ByteString -> SipHash +hashWith c d key (PS ps s fl) = unsafeDupablePerformIO $ withForeignPtr ps (\ptr -> runHash (initSip key) (ptr `plusPtr` s) fl) + where runHash !st !ptr l + | l > 7 = fromLE64 `fmap` peek (castPtr ptr) >>= \v -> runHash (process st v) (ptr `plusPtr` 8) (l-8) + | otherwise = do + let !lengthBlock = (fromIntegral fl `mod` 256) `unsafeShiftL` 56 + (finish . process st) `fmap` case l of + 0 -> do return lengthBlock + 1 -> do v0 <- peekByteOff ptr 0 + return (lengthBlock .|. to64 v0) + 2 -> do (v0,v1) <- liftM2 (,) (peekByteOff ptr 0) (peekByteOff ptr 1) + return (lengthBlock + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 3 -> do (v0,v1,v2) <- liftM3 (,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2) + return ( lengthBlock + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 4 -> do (v0,v1,v2,v3) <- liftM4 (,,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2) + (peekByteOff ptr 3) + return ( lengthBlock + .|. (to64 v3 `unsafeShiftL` 24) + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 5 -> do (v0,v1,v2,v3,v4) <- liftM5 (,,,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2) + (peekByteOff ptr 3) (peekByteOff ptr 4) + return ( lengthBlock + .|. (to64 v4 `unsafeShiftL` 32) + .|. (to64 v3 `unsafeShiftL` 24) + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 6 -> do v0 <- peekByteOff ptr 0 + v1 <- peekByteOff ptr 1 + v2 <- peekByteOff ptr 2 + v3 <- peekByteOff ptr 3 + v4 <- peekByteOff ptr 4 + v5 <- peekByteOff ptr 5 + return ( lengthBlock + .|. (to64 v5 `unsafeShiftL` 40) + .|. (to64 v4 `unsafeShiftL` 32) + .|. (to64 v3 `unsafeShiftL` 24) + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 7 -> do v0 <- peekByteOff ptr 0 + v1 <- peekByteOff ptr 1 + v2 <- peekByteOff ptr 2 + v3 <- peekByteOff ptr 3 + v4 <- peekByteOff ptr 4 + v5 <- peekByteOff ptr 5 + v6 <- peekByteOff ptr 6 + return ( lengthBlock + .|. (to64 v6 `unsafeShiftL` 48) + .|. (to64 v5 `unsafeShiftL` 40) + .|. (to64 v4 `unsafeShiftL` 32) + .|. (to64 v3 `unsafeShiftL` 24) + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + _ -> error "siphash: internal error: cannot happen" + + {-# INLINE to64 #-} + to64 :: Word8 -> Word64 + to64 = fromIntegral + + {-# INLINE process #-} + process istate m = newState + where newState = postInject $! runRoundsCompression $! preInject istate + preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 v2 (v3 `xor` m) + postInject (InternalState v0 v1 v2 v3) = InternalState (v0 `xor` m) v1 v2 v3 + + {-# INLINE finish #-} + finish istate = getDigest $! runRoundsDigest $! preInject istate + where getDigest (InternalState v0 v1 v2 v3) = SipHash (v0 `xor` v1 `xor` v2 `xor` v3) + preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 (v2 `xor` 0xff) v3 + + {-# INLINE doRound #-} + doRound (InternalState v0 v1 v2 v3) = + let !v0' = v0 + v1 + !v2' = v2 + v3 + !v1' = v1 `rotateL` 13 + !v3' = v3 `rotateL` 16 + !v1'' = v1' `xor` v0' + !v3'' = v3' `xor` v2' + !v0'' = v0' `rotateL` 32 + !v2'' = v2' + v1'' + !v0''' = v0'' + v3'' + !v1''' = v1'' `rotateL` 17 + !v3''' = v3'' `rotateL` 21 + !v1'''' = v1''' `xor` v2'' + !v3'''' = v3''' `xor` v0''' + !v2''' = v2'' `rotateL` 32 + in InternalState v0''' v1'''' v2''' v3'''' + + {-# INLINE runRoundsCompression #-} + runRoundsCompression st + | c == 2 = doRound $! doRound st + | otherwise = loopRounds c st + + {-# INLINE runRoundsDigest #-} + runRoundsDigest st + | d == 4 = doRound $! doRound $! doRound $! doRound st + | otherwise = loopRounds d st + + {-# INLINE loopRounds #-} + loopRounds 1 !v = doRound v + loopRounds n !v = loopRounds (n-1) (doRound v) + + {-# INLINE initSip #-} + initSip (SipKey k0 k1) = InternalState (k0 `xor` 0x736f6d6570736575) + (k1 `xor` 0x646f72616e646f6d) + (k0 `xor` 0x6c7967656e657261) + (k1 `xor` 0x7465646279746573)
src/Data/HyperLogLog.hs view
@@ -1,25 +1,25 @@------------------------------------------------------------------------ |--- Copyright : (c) Edward Kmett 2013-2015--- License : BSD3--- Maintainer: Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability: non-portable------ See the original paper for details:--- <http://algo.inria.fr/flajolet/Publications/FlFuGaMe07.pdf>----------------------------------------------------------------------module Data.HyperLogLog- (- -- * HyperLogLog- HyperLogLog- , HasHyperLogLog(..)- , size- , intersectionSize- , insert- , insertHash- , cast- , coerceConfig- ) where--import Data.HyperLogLog.Type+-------------------------------------------------------------------- +-- | +-- Copyright : (c) Edward Kmett 2013-2015 +-- License : BSD3 +-- Maintainer: Edward Kmett <ekmett@gmail.com> +-- Stability : experimental +-- Portability: non-portable +-- +-- See the original paper for details: +-- <http://algo.inria.fr/flajolet/Publications/FlFuGaMe07.pdf> +-------------------------------------------------------------------- +module Data.HyperLogLog + ( + -- * HyperLogLog + HyperLogLog + , HasHyperLogLog(..) + , size + , intersectionSize + , insert + , insertHash + , cast + , coerceConfig + ) where + +import Data.HyperLogLog.Type
src/Data/HyperLogLog/Config.hs view
@@ -1,84 +1,84 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-cse #-}-{-# OPTIONS_GHC -fno-full-laziness #-}-{-# OPTIONS_GHC -fno-float-in #-}-{-# OPTIONS_GHC -Wno-unused-binds #-}------------------------------------------------------------------------- |--- Copyright : (c) Edward Kmett 2013-2015--- License : BSD3--- Maintainer: Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability: non-portable-------------------------------------------------------------------------module Data.HyperLogLog.Config- (- -- * Config- numBuckets- , smallRange- , interRange- , rawFact- , alpha- , bucketMask- -- * Rank- , Rank- , calcBucket- , calcRank- , lim32- ) where--import Data.Binary-import Data.Bits-import Data.Bits.Extras-import Data.Vector.Serialize ()-import GHC.Int--type Rank = Int8----------------------------------------------------------------------------------- Config---------------------------------------------------------------------------------lim32 :: Double-lim32 = fromInteger (bit 32)-{-# INLINE lim32 #-}--numBuckets :: Integer -> Int-numBuckets b = unsafeShiftL 1 (fromIntegral b)-{-# INLINE numBuckets #-}--smallRange :: Integer -> Double-smallRange b = 5/2 * fromIntegral (numBuckets b)-{-# INLINE smallRange #-}--interRange :: Double-interRange = lim32 / 30-{-# INLINE interRange #-}--rawFact :: Integer -> Double-rawFact b = alpha b * m * m where- m = fromIntegral (numBuckets b)-{-# INLINE rawFact #-}--alpha :: Integer -> Double-alpha b = 0.7213 / (1 + 1.079 / fromIntegral (numBuckets b))-{-# INLINE alpha #-}--bucketMask :: Integer -> Word32-bucketMask b = fromIntegral (numBuckets b) - 1----------------------------------------------------------------------------------- Util---------------------------------------------------------------------------------calcBucket :: Integer -> Word32 -> Int-calcBucket t w = fromIntegral (w .&. bucketMask t)-{-# INLINE calcBucket #-}--calcRank :: Integer -> Word32 -> Int8-calcRank t w = fromIntegral $ rank $ shiftR w $ fromIntegral t-{-# INLINE calcRank #-}+{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-cse #-} +{-# OPTIONS_GHC -fno-full-laziness #-} +{-# OPTIONS_GHC -fno-float-in #-} +{-# OPTIONS_GHC -Wno-unused-binds #-} + +-------------------------------------------------------------------- +-- | +-- Copyright : (c) Edward Kmett 2013-2015 +-- License : BSD3 +-- Maintainer: Edward Kmett <ekmett@gmail.com> +-- Stability : experimental +-- Portability: non-portable +-- +-------------------------------------------------------------------- +module Data.HyperLogLog.Config + ( + -- * Config + numBuckets + , smallRange + , interRange + , rawFact + , alpha + , bucketMask + -- * Rank + , Rank + , calcBucket + , calcRank + , lim32 + ) where + +import Data.Binary +import Data.Bits +import Data.Bits.Extras +import Data.Vector.Serialize () +import GHC.Int + +type Rank = Int8 + +------------------------------------------------------------------------------ +-- Config +------------------------------------------------------------------------------ + +lim32 :: Double +lim32 = fromInteger (bit 32) +{-# INLINE lim32 #-} + +numBuckets :: Integer -> Int +numBuckets b = unsafeShiftL 1 (fromIntegral b) +{-# INLINE numBuckets #-} + +smallRange :: Integer -> Double +smallRange b = 5/2 * fromIntegral (numBuckets b) +{-# INLINE smallRange #-} + +interRange :: Double +interRange = lim32 / 30 +{-# INLINE interRange #-} + +rawFact :: Integer -> Double +rawFact b = alpha b * m * m where + m = fromIntegral (numBuckets b) +{-# INLINE rawFact #-} + +alpha :: Integer -> Double +alpha b = 0.7213 / (1 + 1.079 / fromIntegral (numBuckets b)) +{-# INLINE alpha #-} + +bucketMask :: Integer -> Word32 +bucketMask b = fromIntegral (numBuckets b) - 1 + +------------------------------------------------------------------------------ +-- Util +------------------------------------------------------------------------------ + +calcBucket :: Integer -> Word32 -> Int +calcBucket t w = fromIntegral (w .&. bucketMask t) +{-# INLINE calcBucket #-} + +calcRank :: Integer -> Word32 -> Int8 +calcRank t w = fromIntegral $ rank $ shiftR w $ fromIntegral t +{-# INLINE calcRank #-}
src/Data/HyperLogLog/Type.hs view
@@ -1,212 +1,275 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving#-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MonoLocalBinds #-}-{-# OPTIONS_GHC -fno-cse #-}-{-# OPTIONS_GHC -fno-full-laziness #-}-{-# OPTIONS_GHC -fno-float-in #-}-{-# OPTIONS_GHC -Wno-unused-binds #-}------------------------------------------------------------------------- |--- Copyright : (c) Edward Kmett 2013-2015--- License : BSD3--- Maintainer: Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability: non-portable------ This package provides an approximate streaming (constant space)--- unique object counter.------ See the original paper for details:--- <http://algo.inria.fr/flajolet/Publications/FlFuGaMe07.pdf>----------------------------------------------------------------------module Data.HyperLogLog.Type- (- -- * HyperLogLog- HyperLogLog(..)- , HasHyperLogLog(..)- , size- , insert- , insertHash- , intersectionSize- , cast- , coerceConfig- ) where--import Control.DeepSeq (NFData (..))-import Control.Lens-import Control.Monad-import Crypto.MAC.SipHash-import Data.Approximate.Type-import Data.Bits.Extras-import qualified Data.Binary as Binary-import Data.Binary-import Data.Bytes.Put (runPutS)-import Data.Bytes.Serial-import Data.HyperLogLog.Config-import Data.Proxy-import Data.Reflection-import Data.Serialize as Serialize-import Data.Type.Coercion (Coercion(..))-import qualified Data.Vector.Unboxed as V-import qualified Data.Vector.Unboxed.Mutable as MV-import GHC.Generics hiding (D, to)-import GHC.Int--#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup (Semigroup(..))-#endif---- $setup--- >>> :set -XTemplateHaskell--- >>> :set -XDataKinds--- >>> import Data.HyperLogLog--- >>> import Control.Lens--- >>> import Data.Reflection--- >>> import Data.Monoid--- >>> import qualified Data.Vector.Unboxed as V----------------------------------------------------------------------------------- HyperLogLog----------------------------------------------------------------------------------- |------ Initialize a new counter:------ >>> runHyperLogLog (mempty :: HyperLogLog 3) == V.fromList [0,0,0,0,0,0,0,0]--- True------ Please note how you specify a counter size with the @n@--- invocation. Sizes of up to 16 are valid, with 7 being a--- likely good minimum for decent accuracy.------ Let's count a list of unique items and get the latest estimate:------ >>> size (foldr insert mempty [1..10] :: HyperLogLog 4)--- Approximate {_confidence = 0.9972, _lo = 2, _estimate = 9, _hi = 17}------ Note how 'insert' can be used to add new observations to the--- approximate counter.-newtype HyperLogLog p = HyperLogLog { runHyperLogLog :: V.Vector Rank }- deriving (Eq, Show, Generic, NFData)-type role HyperLogLog nominal---- | If two types @p@ and @q@ reify the same configuration, then we can coerce--- between @'HyperLogLog' p@ and @'HyperLogLog' q@. We do this by building--- a hole in the @nominal@ role for the configuration parameter.-coerceConfig :: forall p q . (Reifies p Integer, Reifies q Integer) => Maybe (Coercion (HyperLogLog p) (HyperLogLog q))-coerceConfig | reflect (Proxy :: Proxy p) == reflect (Proxy :: Proxy q) = Just Coercion- | otherwise = Nothing--instance Serialize (HyperLogLog p)--instance Serial (HyperLogLog p) where- serialize (HyperLogLog v) = serialize (V.toList v)- deserialize = liftM (HyperLogLog . V.fromList) deserialize--instance Binary (HyperLogLog p) where- put (HyperLogLog v) = Binary.put (V.toList v)- get = fmap (HyperLogLog . V.fromList) Binary.get--class HasHyperLogLog a p | a -> p where- hyperLogLog :: Lens' a (HyperLogLog p)--instance HasHyperLogLog (HyperLogLog p) p where- hyperLogLog = id---- TODO: prism to ensure the sizes are right-_HyperLogLog :: Iso' (HyperLogLog p) (V.Vector Rank)-_HyperLogLog = iso runHyperLogLog HyperLogLog-{-# INLINE _HyperLogLog #-}--instance Semigroup (HyperLogLog p) where- HyperLogLog a <> HyperLogLog b = HyperLogLog (V.zipWith max a b)- {-# INLINE (<>) #-}---- The 'Monoid' instance \"should\" just work. Give me two estimators and I--- can give you an estimator for the union set of the two.-instance Reifies p Integer => Monoid (HyperLogLog p) where- mempty = HyperLogLog $ V.replicate (numBuckets (reflect (Proxy :: Proxy p))) 0- {-# INLINE mempty #-}- mappend = (<>)- {-# INLINE mappend #-}--sipKey :: SipKey-sipKey = SipKey 4 7--siphash :: Serial a => a -> Word64-siphash a = h- where !bs = runPutS (serialize a)- (SipHash !h) = hash sipKey bs-{-# INLINE siphash #-}--insert :: (Reifies s Integer, Serial a) => a -> HyperLogLog s -> HyperLogLog s-insert = insertHash . w32 . siphash-{-# INLINE insert #-}---- | Insert a value that has already been hashed by whatever user defined hash function you want.-insertHash :: Reifies s Integer => Word32 -> HyperLogLog s -> HyperLogLog s-insertHash h m@(HyperLogLog v) = HyperLogLog $ V.modify (\x -> do- old <- MV.read x bk- when (rnk > old) $ MV.write x bk rnk- ) v where- !n = reflect m- !bk = calcBucket n h- !rnk = calcRank n h-{-# INLINE insertHash #-}---- | Approximate size of our set-size :: Reifies p Integer => HyperLogLog p -> Approximate Int64-size m@(HyperLogLog bs) = Approximate 0.9972 l expected h where- n = reflect m- m' = fromIntegral (numBuckets n)- numZeros = fromIntegral . V.length . V.filter (== 0) $ bs- res = case raw < smallRange n of- True | numZeros > 0 -> m' * log (m' / numZeros) -- 13.47 bits max error- -- numZeros > 0 -> m' / 1 / (log m' - log numZeros) -- 6.47 bits max error- | otherwise -> raw- False | raw <= interRange -> raw- -- otherwise -> -1 * lim32 * log (1 - raw / lim32) -- 44 bits max error- -- raw / lim32 < -1.7563532969399233e-6 -> - log (1 - (raw / lim32)) * lim32 -- 5.39 bits max error- | otherwise -> raw + (raw / lim32) * raw-- raw = rawFact n * (1 / sm)- sm = V.sum $ V.map (\x -> 1 / (2 ^^ x)) bs- expected = round res- sd = 1.04 / sqrt m'- l = floor $ max (res*(1-3*sd)) 0- h = ceiling $ res*(1+3*sd)-{-# INLINE size #-}-#ifdef HERBIE-{-# ANN size "NoHerbie" #-}-#endif--intersectionSize :: Reifies p Integer => [HyperLogLog p] -> Approximate Int64-intersectionSize [] = 0-intersectionSize (x:xs) = withMin 0 $ size x + intersectionSize xs - intersectionSize (mappend x <$> xs)-{-# INLINE intersectionSize #-}--cast :: forall p q. (Reifies p Integer, Reifies q Integer) => HyperLogLog p -> Maybe (HyperLogLog q)-cast old- | newBuckets <= oldBuckets = Just $ over _HyperLogLog ?? mempty $ V.modify $ \m ->- V.forM_ (V.indexed $ old^._HyperLogLog) $ \ (i,o) -> do- let j = mod i newBuckets- a <- MV.read m j- MV.write m j (max o a)- | otherwise = Nothing -- TODO?- where- newBuckets = numBuckets (reflect (Proxy :: Proxy q))- oldBuckets = numBuckets (reflect old)-{-# INLINE cast #-}+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving#-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# OPTIONS_GHC -fno-cse #-} +{-# OPTIONS_GHC -fno-full-laziness #-} +{-# OPTIONS_GHC -fno-float-in #-} +{-# OPTIONS_GHC -Wno-unused-binds #-} + +-------------------------------------------------------------------- +-- | +-- Copyright : (c) Edward Kmett 2013-2025 +-- License : BSD3 +-- Maintainer: Edward Kmett <ekmett@gmail.com> +-- Stability : experimental +-- Portability: non-portable +-- +-- This package provides an approximate streaming (constant space) +-- unique object counter. +-- +-- See the original paper for details: +-- <http://algo.inria.fr/flajolet/Publications/FlFuGaMe07.pdf> +-------------------------------------------------------------------- +module Data.HyperLogLog.Type + ( + -- * HyperLogLog + DefaultSipKey + , DefaultHyperLogLog + , SipKey + , reifySipKey + , HyperLogLog(..) + , generateHyperLogLog + , HasHyperLogLog(..) + , size + , insert + , insertHash + , intersectionSize + , cast + , coerceConfig + ) where + +import Control.DeepSeq (NFData (..)) +import Control.Lens +import Control.Monad +import Crypto.MAC.SipHash +import Data.Approximate.Type +import Data.Bits.Extras +import qualified Data.Binary as Binary +import Data.Binary +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Bytes.Get as Bytes (getWord64host, runGetL) +import Data.Bytes.Put (runPutS) +import Data.Bytes.Serial +import Data.HyperLogLog.Config +import Data.Proxy +import Data.Reflection +import Data.Serialize as Serialize +import Data.Type.Coercion (Coercion(..)) +import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Unboxed.Mutable as MV +import GHC.Generics hiding (D, to) +import GHC.Int +import GHC.Types (Type) +import System.Entropy (getEntropy) + +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup (Semigroup(..)) +#endif + +-- $setup +-- >>> :set -XScopedTypeVariables +-- >>> :set -XTemplateHaskell +-- >>> :set -XDataKinds +-- >>> import Data.HyperLogLog +-- >>> import Control.Lens +-- >>> import Data.Reflection +-- >>> import Data.Monoid +-- >>> import qualified Data.Vector.Unboxed as V + +------------------------------------------------------------------------------ +-- HyperLogLog +------------------------------------------------------------------------------ + +-- | +-- +-- Initialize a new counter: +-- +-- >>> runHyperLogLog (mempty :: DefaultHyperLogLog 3) == V.fromList [0,0,0,0,0,0,0,0] +-- True +-- +-- Please note how you specify a counter size with the @n@ +-- invocation. Sizes of up to 16 are valid, with 7 being a +-- likely good minimum for decent accuracy. +-- +-- Let's count a list of unique items and get the latest estimate: +-- +-- >>> size (foldr insert mempty [1..10] :: DefaultHyperLogLog 4) +-- Approximate {_confidence = 0.9972, _lo = 2, _estimate = 9, _hi = 17} +-- +-- Note how 'insert' can be used to add new observations to the +-- approximate counter. +-- +-- The @s@ type parameter configures the 'SipKey' that is passed to the hash +-- function when 'insert'ing a new value. Note that if cryptographic security is +-- a primary consideration, it is recommended that you create 'HyperLogLog' +-- values using 'generateHyperLogLog' so that the 'SipKey' is randomly +-- generated using system entropy. In contrast, the 'HyperLogLog' data +-- constructor and the 'mempty' method allow constructing 'HyperLogLog' values +-- with fixed 'SipKey's, which can result in exponentially inaccurate estimates +-- if exploited by an adversary. (See <https://eprint.iacr.org/2021/1139>.) +newtype HyperLogLog s p = + -- | Construct a 'HyperLogLog' value directly from a 'V.Vector'. + -- + -- Note that using this data constructor directly permits the @s@ type + -- parameter to be a fixed 'SipKey', which can have cryptographic security + -- implications. See the Haddocks for 'HyperLogLog' for more details. + HyperLogLog { runHyperLogLog :: V.Vector Rank } + deriving (Eq, Show, Generic, NFData) +type role HyperLogLog nominal nominal + +data DefaultSipKey = DefaultSipKey + +instance Reifies DefaultSipKey SipKey where + reflect _ = SipKey 4 7 + +type DefaultHyperLogLog = HyperLogLog DefaultSipKey + +-- | Promote a 'SipKey' to the type level for use as part of a 'HyperLogLog' +-- type. +reifySipKey :: Word64 -> Word64 -> (forall (s :: Type). Reifies s SipKey => Proxy s -> r) -> r +reifySipKey m n k = reify (SipKey m n) k + +-- | Generate a fresh 'HyperLogLog' value using a randomly generated 'SipKey': +-- +-- >>> generateHyperLogLog $ \(m :: HyperLogLog s 3) -> pure (runHyperLogLog m == V.fromList [0,0,0,0,0,0,0,0]) +-- True +-- +-- +-- The 'SipKey' is generated using system entropy, so if cryptographic security +-- is a primary consideration, use this function to create a 'HyperLogLog' +-- value instead of manually building one (e.g., by using the 'HyperLogLog' +-- data constructor or by using 'mempty'). +generateHyperLogLog :: Reifies p Integer => (forall (s :: Type). HyperLogLog s p -> IO r) -> IO r +generateHyperLogLog k = do + m <- generateWord64 + n <- generateWord64 + reifySipKey m n $ \(_ :: Proxy s) -> + k @s mempty + where + generateWord64 :: IO Word64 + generateWord64 = do + bs <- BSL.fromStrict <$> getEntropy 8 + pure $ Bytes.runGetL Bytes.getWord64host bs + +-- | If the two types @p@ and @q@ reify the same configuration, and if the two +-- types @r@ and @s@ reify the same 'SipKey', then we can coerce between +-- @'HyperLogLog' r p@ and @'HyperLogLog' s q@. We do this by building a hole in +-- the @nominal@ role for the configuration parameter. +coerceConfig :: forall p q r s. (Reifies p Integer, Reifies q Integer, Reifies r SipKey, Reifies s SipKey) => Maybe (Coercion (HyperLogLog r p) (HyperLogLog s q)) +coerceConfig | reflect (Proxy :: Proxy p) == reflect (Proxy :: Proxy q) + , reflect (Proxy :: Proxy r) == reflect (Proxy :: Proxy s) = Just Coercion + | otherwise = Nothing + +instance Serialize (HyperLogLog s p) + +instance Serial (HyperLogLog s p) where + serialize (HyperLogLog v) = serialize (V.toList v) + deserialize = liftM (HyperLogLog . V.fromList) deserialize + +instance Binary (HyperLogLog s p) where + put (HyperLogLog v) = Binary.put (V.toList v) + get = fmap (HyperLogLog . V.fromList) Binary.get + +class HasHyperLogLog a s p | a -> s p where + hyperLogLog :: Lens' a (HyperLogLog s p) + +instance HasHyperLogLog (HyperLogLog s p) s p where + hyperLogLog = id + +-- TODO: prism to ensure the sizes are right +_HyperLogLog :: Iso' (HyperLogLog s p) (V.Vector Rank) +_HyperLogLog = iso runHyperLogLog HyperLogLog +{-# INLINE _HyperLogLog #-} + +instance Semigroup (HyperLogLog s p) where + HyperLogLog a <> HyperLogLog b = HyperLogLog (V.zipWith max a b) + {-# INLINE (<>) #-} + +-- | The 'Monoid' instance \"should\" just work. Give me two estimators and I +-- can give you an estimator for the union set of the two. +-- +-- Note that using 'mempty' permits the @s@ type parameter to be a fixed +-- 'SipKey', which can have cryptographic security implications. See the +-- Haddocks for 'HyperLogLog' for more details. +instance Reifies p Integer => Monoid (HyperLogLog s p) where + mempty = HyperLogLog $ V.replicate (numBuckets (reflect (Proxy :: Proxy p))) 0 + {-# INLINE mempty #-} + mappend = (<>) + {-# INLINE mappend #-} + +siphash :: Serial a => SipKey -> a -> Word64 +siphash k a = h + where !bs = runPutS (serialize a) + (SipHash !h) = hash k bs +{-# INLINE siphash #-} + +insert :: forall s p a. (Reifies s SipKey, Reifies p Integer, Serial a) => a -> HyperLogLog s p -> HyperLogLog s p +insert = insertHash . w32 . siphash (reflect (Proxy :: Proxy s)) +{-# INLINE insert #-} + +-- | Insert a value that has already been hashed by whatever user defined hash function you want. +insertHash :: Reifies p Integer => Word32 -> HyperLogLog s p -> HyperLogLog s p +insertHash h m@(HyperLogLog v) = HyperLogLog $ V.modify (\x -> do + old <- MV.read x bk + when (rnk > old) $ MV.write x bk rnk + ) v where + !n = reflect m + !bk = calcBucket n h + !rnk = calcRank n h +{-# INLINE insertHash #-} + +-- | Approximate size of our set +size :: Reifies p Integer => HyperLogLog s p -> Approximate Int64 +size m@(HyperLogLog bs) = Approximate 0.9972 l expected h where + n = reflect m + m' = fromIntegral (numBuckets n) + numZeros = fromIntegral . V.length . V.filter (== 0) $ bs + res = case raw < smallRange n of + True | numZeros > 0 -> m' * log (m' / numZeros) -- 13.47 bits max error + -- numZeros > 0 -> m' / 1 / (log m' - log numZeros) -- 6.47 bits max error + | otherwise -> raw + False | raw <= interRange -> raw + -- otherwise -> -1 * lim32 * log (1 - raw / lim32) -- 44 bits max error + -- raw / lim32 < -1.7563532969399233e-6 -> - log (1 - (raw / lim32)) * lim32 -- 5.39 bits max error + | otherwise -> raw + (raw / lim32) * raw + + raw = rawFact n * (1 / sm) + sm = V.sum $ V.map (\x -> 1 / (2 ^^ x)) bs + expected = round res + sd = 1.04 / sqrt m' + l = floor $ max (res*(1-3*sd)) 0 + h = ceiling $ res*(1+3*sd) +{-# INLINE size #-} +#ifdef HERBIE +{-# ANN size "NoHerbie" #-} +#endif + +intersectionSize :: Reifies p Integer => [HyperLogLog s p] -> Approximate Int64 +intersectionSize [] = 0 +intersectionSize (x:xs) = withMin 0 $ size x + intersectionSize xs - intersectionSize (mappend x <$> xs) +{-# INLINE intersectionSize #-} + +cast :: forall p q s. (Reifies p Integer, Reifies q Integer) => HyperLogLog s p -> Maybe (HyperLogLog s q) +cast old + | newBuckets <= oldBuckets = Just $ over _HyperLogLog ?? mempty $ V.modify $ \m -> + V.forM_ (V.indexed $ old^._HyperLogLog) $ \ (i,o) -> do + let j = mod i newBuckets + a <- MV.read m j + MV.write m j (max o a) + | otherwise = Nothing -- TODO? + where + newBuckets = numBuckets (reflect (Proxy :: Proxy q)) + oldBuckets = numBuckets (reflect old) +{-# INLINE cast #-}