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,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.* diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -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}" 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,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. 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 -=========== - -[![Build Status](https://secure.travis-ci.org/ekmett/hyperloglog.png?branch=master)](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 +=========== + +[![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,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 diff --git a/hyperloglog.cabal b/hyperloglog.cabal --- a/hyperloglog.cabal +++ b/hyperloglog.cabal @@ -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 -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: - - . - 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 +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 new file mode 100644 --- /dev/null +++ b/src/Crypto/MAC/SipHash.hs @@ -0,0 +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 + 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,31 +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 - -- * 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 +-- 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,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 --- 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 +-- 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,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 --- 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 - ) 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 +-- 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 #-} diff --git a/tests/doctests.hsc b/tests/doctests.hsc deleted file mode 100644 --- a/tests/doctests.hsc +++ /dev/null @@ -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 --- 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 diff --git a/travis/cabal-apt-install b/travis/cabal-apt-install deleted file mode 100644 --- a/travis/cabal-apt-install +++ /dev/null @@ -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 - diff --git a/travis/config b/travis/config deleted file mode 100644 --- a/travis/config +++ /dev/null @@ -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