diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,1 @@ +:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h -optP-Iincludes diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,13 @@ +dist +docs +wiki +TAGS +tags +wip +.DS_Store +.*.swp +.*.swo +*.o +*.hi +*~ +*# diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,26 @@ +language: haskell +before_install: + # Uncomment whenever hackage is down. + # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update + - cabal update + + # Try installing some of the build-deps with apt-get for speed. + - travis/cabal-apt-install $mode + +install: + - cabal configure -flib-Werror $mode + - cabal build + +script: + - $script && hlint src --cpp-define HLINT + +notifications: + irc: + channels: + - "irc.freenode.org#haskell-lens" + skip_join: true + template: + - "\x0313hyperloglog\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" + +env: + - mode="--enable-tests" script="cabal test --show-details=always" diff --git a/.vim.custom b/.vim.custom new file mode 100644 --- /dev/null +++ b/.vim.custom @@ -0,0 +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" diff --git a/AUTHORS.markdown b/AUTHORS.markdown new file mode 100644 --- /dev/null +++ b/AUTHORS.markdown @@ -0,0 +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 diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,3 @@ +0.1 +--- +* Ported `Data.Analytics.Approximate.HyperLogLog` from [analytics](http://github.com/analytics) into a separate package. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright 2013 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 new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,55 @@ +#!/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} diff --git a/hyperloglog.cabal b/hyperloglog.cabal new file mode 100644 --- /dev/null +++ b/hyperloglog.cabal @@ -0,0 +1,102 @@ +name: hyperloglog +category: Numeric +version: 0.1 +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 Edward A. Kmett +build-type: Custom +tested-with: GHC == 7.4.1, GHC == 7.6.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 + +flag lib-Werror + default: False + manual: True + +library + build-depends: + approximate >= 0.1 && < 1, + base >= 4.3 && < 5, + binary >= 0.5 && < 0.8, + bits >= 0.2 && < 1, + bytes >= 0.7 && < 1, + cereal >= 0.3.5 && < 0.4, + cereal-vector >= 0.2 && < 0.3, + comonad >= 3 && < 4, + deepseq >= 1.3 && < 1.5, + distributive >= 0.3 && < 1, + generic-deriving >= 1.4 && < 1.6, + hashable >= 1.1.2.3 && < 1.3, + hashable-extras >= 0.1 && < 1, + lens >= 3.9 && < 4, + reflection >= 1.3 && < 2, + semigroupoids >= 3.0.2 && < 4, + semigroups >= 0.8.4 && < 1, + safecopy >= 0.8.1 && < 0.9, + tagged >= 0.4.5 && < 1, + vector >= 0.9 && < 0.11 + + exposed-modules: + Data.HyperLogLog + Data.HyperLogLog.Config + Data.HyperLogLog.Type + + if flag(lib-Werror) + ghc-options: -Werror + + 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 + + if impl(ghc<7.6.1) + ghc-options: -Werror diff --git a/src/Data/HyperLogLog.hs b/src/Data/HyperLogLog.hs new file mode 100644 --- /dev/null +++ b/src/Data/HyperLogLog.hs @@ -0,0 +1,29 @@ +-------------------------------------------------------------------- +-- | +-- Copyright : (c) Edward Kmett 2013 +-- License : BSD3 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +-- See the original paper for details: +-- +-------------------------------------------------------------------- +module Data.HyperLogLog + ( + -- * HyperLogLog + HyperLogLog + , HasHyperLogLog(..) + , size + , intersectionSize + , cast + -- * Config + , Config + , hll + -- * ReifiesConfig + , ReifiesConfig + , reifyConfig + ) where + +import Data.HyperLogLog.Config +import Data.HyperLogLog.Type diff --git a/src/Data/HyperLogLog/Config.hs b/src/Data/HyperLogLog/Config.hs new file mode 100644 --- /dev/null +++ b/src/Data/HyperLogLog/Config.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +#define USE_TYPE_LITS 1 +#endif + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +-------------------------------------------------------------------- +-- | +-- Copyright : (c) Edward Kmett 2013 +-- License : BSD3 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +-------------------------------------------------------------------- +module Data.HyperLogLog.Config + ( + -- * Config + Config + , HasConfig(..) + , hll + , numBits, numBuckets, smallRange, interRange, rawFact, alpha, bucketMask + -- * ReifiesConfig + , ReifiesConfig(..) + , reifyConfig + -- * Rank + , Rank + , calcBucket + , calcRank + , lim32 + ) where + +import Control.Lens +import Data.Bits +import Data.Bits.Extras +import Data.Proxy +import Data.Reflection +import Data.Serialize +import Data.Vector.Serialize () +import GHC.Int +import GHC.Word +import Generics.Deriving hiding (to, D) +#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 + +makeLensesWith ?? ''Config $ classyRules + & generateSignatures .~ False + & createClass .~ False + & createInstance .~ False + +instance HasConfig Config where + config = id + {-# INLINE config #-} + +instance Serialize Config -- serialize as a number? + +-- | 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_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 :: Reifies o Config => (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 #-} diff --git a/src/Data/HyperLogLog/Type.hs b/src/Data/HyperLogLog/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/HyperLogLog/Type.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif + +-------------------------------------------------------------------- +-- | +-- Copyright : (c) Edward Kmett 2013 +-- 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 + , intersectionSize + , cast + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad +import Data.Approximate.Type +import Data.Bits +import Data.Bits.Extras +import Data.Hashable +import Data.HyperLogLog.Config +import Data.Proxy +import Data.Semigroup +import Data.Serialize +import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Unboxed.Mutable as MV +import Generics.Deriving hiding (D, to) +import GHC.Int + +-- $setup +-- >>> :set -XTemplateHaskell +-- >>> :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 cons mempty [1..10] :: HyperLogLog $(4)) +-- Approximate {_confidence = 0.9972, _lo = 2, _estimate = 11, _hi = 20} +-- +-- Note how 'cons' can be used to add new observations to the +-- approximate counter. +newtype HyperLogLog p = HyperLogLog { runHyperLogLog :: V.Vector Rank } + deriving (Eq, Show, Generic) + +instance Serialize (HyperLogLog p) + +makeClassy ''HyperLogLog + +_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 #-} + +instance (Profunctor p, Bifunctor p, Functor f, ReifiesConfig s, Hashable a, s ~ t, a ~ b) => Cons p f (HyperLogLog s) (HyperLogLog t) a b where + _Cons = unto go where + go (a,m@(HyperLogLog v)) = HyperLogLog $ V.modify (\x -> do old <- MV.read x bk; when (rnk > old) $ MV.write x bk rnk) v where + !h = w32 (hash a) + !bk = calcBucket m h + !rnk = calcRank m h + {-# INLINE _Cons #-} + +instance (Profunctor p, Bifunctor p, Functor f, ReifiesConfig s, Hashable a, s ~ t, a ~ b) => Snoc p f (HyperLogLog s) (HyperLogLog t) a b where + _Snoc = unto go where + go (m@(HyperLogLog v), a) = HyperLogLog $ V.modify (\x -> do old <- MV.read x bk; when (rnk > old) $ MV.write x bk rnk) v where + !h = w32 (hash a) + !bk = calcBucket m h + !rnk = calcRank m h + {-# INLINE _Snoc #-} + +-- | 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 #-} diff --git a/tests/doctests.hsc b/tests/doctests.hsc new file mode 100644 --- /dev/null +++ b/tests/doctests.hsc @@ -0,0 +1,79 @@ +{-# 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) +import Control.Applicative +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 +import Control.Applicative +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 new file mode 100644 --- /dev/null +++ b/travis/cabal-apt-install @@ -0,0 +1,27 @@ +#! /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 new file mode 100644 --- /dev/null +++ b/travis/config @@ -0,0 +1,16 @@ +-- 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