hyperloglog 0.3.4 → 0.5
raw patch · 17 files changed
Files
- .ghci +1/−1
- .gitignore +32/−13
- .travis.yml +0/−63
- .vim.custom +31/−31
- AUTHORS.markdown +11/−11
- CHANGELOG.markdown +129/−56
- LICENSE +30/−30
- README.markdown +15/−15
- Setup.lhs +7/−55
- hyperloglog.cabal +92/−95
- src/Crypto/MAC/SipHash.hs +167/−0
- src/Data/HyperLogLog.hs +25/−31
- src/Data/HyperLogLog/Config.hs +84/−206
- src/Data/HyperLogLog/Type.hs +275/−214
- tests/doctests.hsc +0/−83
- travis/cabal-apt-install +0/−27
- travis/config +0/−16
.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,13 +1,32 @@-dist-docs-wiki-TAGS-tags-wip-.DS_Store-.*.swp-.*.swo-*.o-*.hi-*~-*#+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.*
− .travis.yml
@@ -1,63 +0,0 @@-# NB: don't set `language: haskell` here--# See also https://github.com/hvr/multi-ghc-travis for more information-env:- # we have to use CABALVER=1.16 for GHC<7.6 as well, as there's- # no package for earlier cabal versions in the PPA- - GHCVER=7.4.2 CABALVER=1.16- - GHCVER=7.6.3 CABALVER=1.16- - GHCVER=7.8.4 CABALVER=1.18- - GHCVER=7.10.1 CABALVER=1.22- - GHCVER=head CABALVER=head--matrix:- allow_failures:- - env: GHCVER=head CABALVER=head--# Note: the distinction between `before_install` and `install` is not-# important.-before_install:- - travis_retry sudo add-apt-repository -y ppa:hvr/ghc- - travis_retry sudo apt-get update- - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH- - export CABAL=cabal-$CABALVER- - $CABAL --version--install:- - travis_retry cabal update- - $CABAL install --only-dependencies --enable-tests--# Here starts the actual work to be performed for the package under-# test; any command which exits with a non-zero exit code causes the-# build to fail.-script:- # -v2 provides useful information for debugging- - $CABAL clean- - $CABAL configure -v2 --enable-tests-- # this builds all libraries and executables- # (including tests/benchmarks)- - $CABAL build- - $CABAL test-- # tests that a source-distribution can be generated- - $CABAL sdist-- # check that the generated source-distribution can be built & installed- - export SRC_TGZ=$($CABAL info . | awk '{print $2 ".tar.gz";exit}') ;- cd dist/;- if [ -f "$SRC_TGZ" ]; then- $CABAL install --force-reinstalls "$SRC_TGZ";- else- echo "expected '$SRC_TGZ' not found";- exit 1;- fi--notifications:- irc:- channels:- - "irc.freenode.org#haskell-lens"- skip_join: true- template:- - "\x0313hyperloglog\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
.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,56 +1,129 @@-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-===========--[](http://travis-ci.org/ekmett/hyperloglog)--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,55 +1,7 @@-#!/usr/bin/runhaskell-\begin{code}-{-# OPTIONS_GHC -Wall #-}-module Main (main) where--import Data.List ( nub )-import Data.Version ( showVersion )-import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )-import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )-import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )-import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )-import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))-import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )-import Distribution.Text ( display )-import Distribution.Verbosity ( Verbosity, normal )-import System.FilePath ( (</>) )--main :: IO ()-main = defaultMainWithHooks simpleUserHooks- { buildHook = \pkg lbi hooks flags -> do- generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi- buildHook simpleUserHooks pkg lbi hooks flags- , postHaddock = \args flags pkg lbi -> do- copyFiles normal (haddockOutputDir flags pkg) []- postHaddock simpleUserHooks args flags pkg lbi- }--haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath-haddockOutputDir flags pkg = destDir where- baseDir = case haddockDistPref flags of- NoFlag -> "."- Flag x -> x- destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)--generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-generateBuildModule verbosity pkg lbi = do- let dir = autogenModulesDir lbi- createDirectoryIfMissingVerbose verbosity True dir- withLibLBI pkg lbi $ \_ libcfg -> do- withTestLBI pkg lbi $ \suite suitecfg -> do- rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines- [ "module Build_" ++ testName suite ++ " where"- , "deps :: [String]"- , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))- ]- where- formatdeps = map (formatone . snd)- formatone p = case packageName p of- PackageName n -> n ++ "-" ++ showVersion (packageVersion p)--testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys--\end{code}+#!/usr/bin/runhaskell +> module Main (main) where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain
hyperloglog.cabal view
@@ -1,95 +1,92 @@-name: hyperloglog-category: Numeric-version: 0.3.4-license: BSD3-cabal-version: >= 1.8-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: Custom-tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.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:- .travis.yml- .ghci- .gitignore- .vim.custom- travis/cabal-apt-install- travis/config- AUTHORS.markdown- README.markdown- CHANGELOG.markdown--source-repository head- type: git- location: git://github.com/analytics/hyperloglog.git---- You can disable the doctests test suite with -f-test-doctests-flag test-doctests- default: True- manual: True--library- build-depends:- approximate >= 0.2.1 && < 1,- base >= 4.3 && < 5,- binary >= 0.5 && < 0.8,- bits >= 0.2 && < 1,- bytes >= 0.7 && < 1,- cereal >= 0.3.5 && < 0.5,- cereal-vector >= 0.2 && < 0.3,- comonad >= 4 && < 5,- deepseq >= 1.3 && < 1.5,- distributive >= 0.3 && < 1,- hashable >= 1.1.2.3 && < 1.3,- hashable-extras >= 0.1 && < 1,- lens >= 4 && < 5,- reflection >= 1.3 && < 3,- semigroupoids >= 4 && < 6,- semigroups >= 0.8.4 && < 1,- safecopy >= 0.8.1 && < 0.9,- siphash >= 1.0.3 && < 2,- tagged >= 0.4.5 && < 1,- vector >= 0.9 && < 0.11-- if impl(ghc < 7.6)- build-depends: generic-deriving >= 1.4 && < 1.9-- exposed-modules:- Data.HyperLogLog- Data.HyperLogLog.Config- Data.HyperLogLog.Type-- ghc-options: -Wall -fwarn-tabs -O2- hs-source-dirs: src--test-suite doctests- type: exitcode-stdio-1.0- main-is: doctests.hs- ghc-options: -Wall -threaded- hs-source-dirs: tests-- if !flag(test-doctests)- buildable: False- else- build-depends:- base,- directory >= 1.0,- doctest >= 0.9.1,- filepath,- generic-deriving,- semigroups >= 0.9,- simple-reflect >= 0.3.1+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
@@ -0,0 +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 + 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,31 +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- -- * Config- , Config- , hll- -- * ReifiesConfig- , ReifiesConfig- , reifyConfig- ) where--import Data.HyperLogLog.Config-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,206 +1,84 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-cse #-}-{-# OPTIONS_GHC -fno-full-laziness #-}-{-# OPTIONS_GHC -fno-float-in #-}-{-# OPTIONS_GHC -fno-warn-unused-binds #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 705-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-#define USE_TYPE_LITS 1-#endif--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707-#define USE_NEW_TYPE_LITS 1-#endif--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 705 && __GLASGOW_HASKELL__ < 707-#define USE_OLD_TYPE_LITS 1-#endif--{-# OPTIONS_GHC -fno-warn-missing-signatures #-}------------------------------------------------------------------------ |--- Copyright : (c) Edward Kmett 2013-2015--- License : BSD3--- Maintainer: Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability: non-portable-------------------------------------------------------------------------module Data.HyperLogLog.Config- (- -- * Config- Config- , HasConfig(..)- , hll- -- * ReifiesConfig- , ReifiesConfig(..)- , reifyConfig- -- * Rank- , Rank- , calcBucket- , calcRank- , lim32- ) where--import Control.Lens-import Data.Binary-import Data.Bits-import Data.Bits.Extras-import Data.Bytes.Serial-import Data.Proxy-import Data.Reflection-import Data.Serialize-import Data.Vector.Serialize ()-import GHC.Int-#if __GLASGOW_HASKELL__ < 710-import GHC.Word-#endif-#if __GLASGOW_HASKELL__ < 706-import Generics.Deriving hiding (to, D)-#else-import GHC.Generics hiding (to, D)-#endif-#ifdef USE_TYPE_LITS-import GHC.TypeLits-#endif--type Rank = Int8----------------------------------------------------------------------------------- Config----------------------------------------------------------------------------------- | Constants required for a bucketing factor b-data Config = Config- { _numBits :: {-# UNPACK #-} !Int- , _numBuckets :: {-# UNPACK #-} !Int- , _smallRange :: {-# UNPACK #-} !Double- , _interRange :: {-# UNPACK #-} !Double- , _rawFact :: {-# UNPACK #-} !Double- , _alpha :: {-# UNPACK #-} !Double- , _bucketMask :: {-# UNPACK #-} !Word32- } deriving (Eq, Show, Generic)--class HasConfig t where- config :: Getter t Config-- numBits :: Getter t Int- numBits = config . to _numBits-- numBuckets :: Getter t Int- numBuckets = config . to _numBuckets-- smallRange :: Getter t Double- smallRange = config . to _smallRange-- interRange :: Getter t Double- interRange = config . to _interRange-- rawFact :: Getter t Double- rawFact = config . to _rawFact-- alpha :: Getter t Double- alpha = config . to _alpha-- bucketMask :: Getter t Word32- bucketMask = config . to _bucketMask--instance HasConfig Config where- config = id- {-# INLINE config #-}--instance Serialize Config -- serialize as a number?--instance Binary Config where- put = serialize- get = deserialize--instance Serial Config---- | Precalculate constants for a given bucketing factor b-hll :: Int -> Config-hll b = Config- { _numBits = b- , _numBuckets = m- , _smallRange = 5/2 * m'- , _interRange = lim32 / 30- , _rawFact = a * m' * m'- , _alpha = a- , _bucketMask = bit b - 1- } where- m = bit b- m' = fromIntegral m- a = 0.7213 / (1 + 1.079 / m')-{-# INLINE hll #-}----------------------------------------------------------------------------------- ReifiesConfig---------------------------------------------------------------------------------class ReifiesConfig o where- reflectConfig :: p o -> Config--#ifdef USE_NEW_TYPE_LITS-instance KnownNat n => ReifiesConfig (n :: Nat) where- reflectConfig _ = hll $ fromInteger $ natVal (Proxy :: Proxy n)- {-# INLINE reflectConfig #-}-#endif--#ifdef USE_OLD_TYPE_LITS-instance SingRep n Integer => ReifiesConfig (n :: Nat) where- reflectConfig _ = hll $ fromInteger $ withSing $ \(x :: Sing n) -> fromSing x- {-# INLINE reflectConfig #-}-#endif--data ReifiedConfig (s :: *)--retagReifiedConfig :: (Proxy s -> a) -> proxy (ReifiedConfig s) -> a-retagReifiedConfig f _ = f Proxy-{-# INLINE retagReifiedConfig #-}--instance Reifies s Config => ReifiesConfig (ReifiedConfig s) where- reflectConfig = retagReifiedConfig reflect- {-# INLINE reflectConfig #-}--reifyConfig :: Int -> (forall (o :: *). ReifiesConfig o => Proxy o -> r) -> r-reifyConfig i f = reify (hll i) (go f) where- go :: (Proxy (ReifiedConfig o) -> a) -> proxy o -> a- go g _ = g Proxy-{-# INLINE reifyConfig #-}--instance Reifies n Int => ReifiesConfig (D n) where- reflectConfig = hll . reflect- {-# INLINE reflectConfig #-}---- this way we only get instances for positive natural numbers-instance Reifies n Int => ReifiesConfig (SD n) where- reflectConfig = hll . reflect- {-# INLINE reflectConfig #-}----------------------------------------------------------------------------------- Util---------------------------------------------------------------------------------calcBucket :: HasConfig t => t -> Word32 -> Int-calcBucket t w = fromIntegral (w .&. t^.bucketMask)-{-# INLINE calcBucket #-}--calcRank :: HasConfig t => t -> Word32 -> Int8-calcRank t w = fromIntegral $ rank $ shiftR w $ t^.numBits-{-# INLINE calcRank #-}--lim32 :: Double-lim32 = fromInteger (bit 32)-{-# INLINE lim32 #-}+{-# 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,214 +1,275 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-cse #-}-{-# OPTIONS_GHC -fno-full-laziness #-}-{-# OPTIONS_GHC -fno-float-in #-}-{-# OPTIONS_GHC -fno-warn-unused-binds #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE RoleAnnotations #-}-#endif------------------------------------------------------------------------- |--- 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- ) where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif--import Control.Lens-import Control.Monad-import Crypto.MAC.SipHash-import Data.Approximate.Type-import Data.Bits-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.Semigroup-import Data.Serialize as Serialize-import qualified Data.Vector.Unboxed as V-import qualified Data.Vector.Unboxed.Mutable as MV-#if __GLASGOW_HASKELL__ < 710-import Data.Word-#endif-#if __GLASGOW_HASKELL__ < 706-import Generics.Deriving hiding (D, to)-#else-import GHC.Generics hiding (D, to)-#endif-import GHC.Int---- $setup--- >>> :set -XTemplateHaskell--- >>> :set -XDataKinds--- >>> :load Data.HyperLogLog--- >>> import Control.Lens--- >>> import Data.Reflection--- >>> import Data.Monoid----------------------------------------------------------------------------------- HyperLogLog----------------------------------------------------------------------------------- |------ Initialize a new counter:------ >>> mempty :: HyperLogLog $(3)--- HyperLogLog {runHyperLogLog = fromList [0,0,0,0,0,0,0,0]}------ 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)--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707-type role HyperLogLog nominal-#endif--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--_HyperLogLog :: Iso' (HyperLogLog p) (V.Vector Rank)-_HyperLogLog = iso runHyperLogLog HyperLogLog-{-# INLINE _HyperLogLog #-}--instance ReifiesConfig p => HasConfig (HyperLogLog p) where- config = to reflectConfig- {-# INLINE config #-}--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 ReifiesConfig p => Monoid (HyperLogLog p) where- mempty = HyperLogLog $ V.replicate (reflectConfig (Proxy :: Proxy p) ^. numBuckets) 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 :: (ReifiesConfig s, 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 :: ReifiesConfig s => 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- !bk = calcBucket m h- !rnk = calcRank m h-{-# INLINE insertHash #-}---- | Approximate size of our set-size :: ReifiesConfig p => HyperLogLog p -> Approximate Int64-size m@(HyperLogLog bs) = Approximate 0.9972 l expected h where- m' = fromIntegral (m^.numBuckets)- numZeros = fromIntegral . V.length . V.filter (== 0) $ bs- res = case raw < m^.smallRange of- True | numZeros > 0 -> m' * log (m' / numZeros)- | otherwise -> raw- False | raw <= m^.interRange -> raw- | otherwise -> -1 * lim32 * log (1 - raw / lim32)- raw = m^.rawFact * (1 / sm)- sm = V.sum $ V.map (\x -> 1 / (2 ^^ x)) bs- expected = round res- sd = err (m^.numBits)- err n = 1.04 / sqrt (fromInteger (bit n))- l = floor $ max (res*(1-3*sd)) 0- h = ceiling $ res*(1+3*sd)-{-# INLINE size #-}--intersectionSize :: ReifiesConfig p => [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. (ReifiesConfig p, ReifiesConfig q) => 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- newConfig = reflectConfig (Proxy :: Proxy q)- newBuckets = newConfig^.numBuckets- oldBuckets = old^.numBuckets-{-# 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 #-}
− tests/doctests.hsc
@@ -1,83 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}--------------------------------------------------------------------------------- |--- Module : Main (doctests)--- Copyright : (C) 2012-13 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ This module provides doctests for a project based on the actual versions--- of the packages it was built with. It requires a corresponding Setup.lhs--- to be added to the project-------------------------------------------------------------------------------module Main where--import Build_doctests (deps)-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Control.Monad-import Data.List-import System.Directory-import System.FilePath-import Test.DocTest--##ifdef mingw32_HOST_OS-##ifdef i386_HOST_ARCH-##define USE_CP-import Control.Applicative-import Control.Exception-import Foreign.C.Types-foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool-foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt-##elif defined(x86_64_HOST_ARCH)-##define USE_CP-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Control.Exception-import Foreign.C.Types-foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool-foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt-##endif-##endif---- | Run in a modified codepage where we can print UTF-8 values on Windows.-withUnicode :: IO a -> IO a-##ifdef USE_CP-withUnicode m = do- cp <- c_GetConsoleCP- (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp-##else-withUnicode m = m-##endif--main :: IO ()-main = withUnicode $ getSources >>= \sources -> doctest $- "-isrc"- : "-idist/build/autogen"- : "-idist/build"- : "-optP-include"- : "-optPdist/build/autogen/cabal_macros.h"- : "dist/build/cbits/crc32.o"- : "dist/build/cbits/debruijn.o"- : "dist/build/cbits/fast.o"- : "dist/build/cbits/rolling.o"- : "dist/build/cbits/storage.o"- : "-hide-all-packages"- : map ("-package="++) deps ++ sources--getSources :: IO [FilePath]-getSources = filter (isSuffixOf ".hs") <$> go "src"- where- go dir = do- (dirs, files) <- getFilesAndDirectories dir- (files ++) . concat <$> mapM go dirs--getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])-getFilesAndDirectories dir = do- c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir- (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
− travis/cabal-apt-install
@@ -1,27 +0,0 @@-#! /bin/bash-set -eu--APT="sudo apt-get -q -y"-CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall"--$APT update-$APT install dctrl-tools--# Find potential system packages to satisfy cabal dependencies-deps()-{- local M='^\([^ ]\+\)-[0-9.]\+ (.*$'- local G=' -o ( -FPackage -X libghc-\L\1\E-dev )'- local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \- | sed -ne "s/$M/$G/p" | sort -u)"- grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u-}--$APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special-$CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage--if ! $APT install hlint ; then- $APT install $(deps hlint)- cabal install hlint-fi-
− travis/config
@@ -1,16 +0,0 @@--- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix------ This is particularly useful for travis-ci to get it to stop complaining--- about a broken build when everything is still correct on our end.------ This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead------ To enable this, uncomment the before_script in .travis.yml--remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive-remote-repo-cache: ~/.cabal/packages-world-file: ~/.cabal/world-build-summary: ~/.cabal/logs/build.log-remote-build-reporting: anonymous-install-dirs user-install-dirs global