diff --git a/.ghci b/.ghci --- a/.ghci +++ b/.ghci @@ -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 diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -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.* diff --git a/.vim.custom b/.vim.custom --- a/.vim.custom +++ b/.vim.custom @@ -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 :exec ":!hasktags -x -c --ignore src" - -" 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 :exec ":!hasktags -x -c --ignore src" + +" 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" diff --git a/AUTHORS.markdown b/AUTHORS.markdown --- a/AUTHORS.markdown +++ b/AUTHORS.markdown @@ -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 diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,15 +1,15 @@ -hyperloglog -=========== - -[![Hackage](https://img.shields.io/hackage/v/hyperloglog.svg)](https://hackage.haskell.org/package/hyperloglog) [![Build Status](https://github.com/ekmett/hyperloglog/workflows/Haskell-CI/badge.svg)](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 +=========== + +[![Hackage](https://img.shields.io/hackage/v/hyperloglog.svg)](https://hackage.haskell.org/package/hyperloglog) [![Build Status](https://github.com/ekmett/hyperloglog/workflows/Haskell-CI/badge.svg)](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 diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -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 diff --git a/hyperloglog.cabal b/hyperloglog.cabal --- a/hyperloglog.cabal +++ b/hyperloglog.cabal @@ -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 -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: - - . - 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 +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: + + . + 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 diff --git a/src/Crypto/MAC/SipHash.hs b/src/Crypto/MAC/SipHash.hs --- a/src/Crypto/MAC/SipHash.hs +++ b/src/Crypto/MAC/SipHash.hs @@ -1,166 +1,167 @@ --- | --- Module : Crypto.MAC.SipHash --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : good --- --- provide the SipHash algorithm. --- reference: --- --- 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 +-- Stability : experimental +-- Portability : good +-- +-- provide the SipHash algorithm. +-- reference: +-- +-- 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) diff --git a/src/Data/HyperLogLog.hs b/src/Data/HyperLogLog.hs --- a/src/Data/HyperLogLog.hs +++ b/src/Data/HyperLogLog.hs @@ -1,25 +1,25 @@ --------------------------------------------------------------------- --- | --- Copyright : (c) Edward Kmett 2013-2015 --- License : BSD3 --- Maintainer: Edward Kmett --- Stability : experimental --- Portability: non-portable --- --- See the original paper for details: --- --------------------------------------------------------------------- -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 +-- Stability : experimental +-- Portability: non-portable +-- +-- See the original paper for details: +-- +-------------------------------------------------------------------- +module Data.HyperLogLog + ( + -- * HyperLogLog + HyperLogLog + , HasHyperLogLog(..) + , size + , intersectionSize + , insert + , insertHash + , cast + , coerceConfig + ) where + +import Data.HyperLogLog.Type diff --git a/src/Data/HyperLogLog/Config.hs b/src/Data/HyperLogLog/Config.hs --- a/src/Data/HyperLogLog/Config.hs +++ b/src/Data/HyperLogLog/Config.hs @@ -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 --- 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 +-- 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 #-} diff --git a/src/Data/HyperLogLog/Type.hs b/src/Data/HyperLogLog/Type.hs --- a/src/Data/HyperLogLog/Type.hs +++ b/src/Data/HyperLogLog/Type.hs @@ -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 --- Stability : experimental --- Portability: non-portable --- --- This package provides an approximate streaming (constant space) --- unique object counter. --- --- See the original paper for details: --- --------------------------------------------------------------------- -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 +-- Stability : experimental +-- Portability: non-portable +-- +-- This package provides an approximate streaming (constant space) +-- unique object counter. +-- +-- See the original paper for details: +-- +-------------------------------------------------------------------- +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 .) +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 #-}