diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,2 @@ +:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h -optP-Iincludes +:set -v0 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,24 @@ +language: haskell +before_install: + # Uncomment whenever hackage is down. + # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update + - cabal update + - 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: + - "\x0313bits\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. + +`bits` was spun out of work that was being done on the `analytics` repository in bitwise encodings for compression schemes. + +You can watch contributors carry on the quest for bragging rights in the [contributors graph](https://github.com/analytics/bits/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 +--- +* Repository initialized 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 @@ +bits +===== + +[![Build Status](https://secure.travis-ci.org/analytics/bits.png)](http://travis-ci.org/analytics/bits) + +This package provides a number of tools that are useful for dealing with files or data on a bitwise basis. + +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/bits.cabal b/bits.cabal new file mode 100644 --- /dev/null +++ b/bits.cabal @@ -0,0 +1,76 @@ +name: bits +category: Data, Serialization +version: 0.1 +license: BSD3 +cabal-version: >= 1.8 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett +stability: experimental +homepage: http://github.com/analytics/bits +bug-reports: http://github.com/analytics/bits/issues +copyright: Copyright (C) 2013 Edward A. Kmett +build-type: Custom +tested-with: GHC == 7.4.1, GHC == 7.6.1 +synopsis: Various bit twiddling and bitwise serialization primitives +description: Various bit twiddling and bitwise serialization primitives + +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/bits.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: + base >= 4.3 && < 5, + bytes >= 0.1 && < 1, + mtl >= 2.0 && < 2.2, + transformers >= 0.2 && < 0.4 + + exposed-modules: + Data.Bits.Coding + Data.Bits.Extras + + if flag(lib-Werror) + ghc-options: -Werror + + c-sources: cbits/debruijn.c + 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 >= 1.2 + + if impl(ghc<7.6.1) + ghc-options: -Werror diff --git a/cbits/debruijn.c b/cbits/debruijn.c new file mode 100644 --- /dev/null +++ b/cbits/debruijn.c @@ -0,0 +1,39 @@ +// A 64 bit deBruijn multiplication table for calculating the the value of a single bit in a word64 +const unsigned char debruijn_lsb64[] = { + 63, 0, 58, 1, 59, 47, 53, 2, + 60, 39, 48, 27, 54, 33, 42, 3, + 61, 51, 37, 40, 49, 18, 28, 20, + 55, 30, 34, 11, 43, 14, 22, 4, + 62, 57, 46, 52, 38, 26, 32, 41, + 50, 36, 17, 19, 29, 10, 13, 21, + 56, 45, 25, 31, 35, 16, 9, 12, + 44, 24, 15, 8, 23, 7, 6, 5 +}; + +// A 32 bit deBruijn multiplication table for (n * 0x077CB531U) >> 27 +const unsigned char debruijn_lsb32[] = { + 0, 1, 28, 2, 29, 14, 24, 3, + 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, + 26, 12, 18, 6, 11, 5, 10, 9 +}; + +// Frigo's algorithm from http://stackoverflow.com/questions/7365562/de-bruijn-like-sequence-for-2n-1-how-is-it-constructed +const unsigned char debruijn_rank32[] = { + 32, -1, 2, -1, 3, -1, -1, -1, + -1, 4, -1, 17, 13, -1, -1, 7, + 0, -1, -1, 5, -1, -1, 27, 18, + 29, 14, 24, -1, -1, 20, 8, -1, + 31, 1, -1, -1, -1, 16, 12, 6, + -1, -1, -1, 26, 28, 23, 19, -1, + 30, -1, 15, 11, -1, 25, 22, -1, + -1, 10, -1, 21, 9, -1, -1, -1 +}; + +// A 32 bit deBruijn multiplication table for calculating log_2 based on first rounding down to 1 less than a power of 2 +const unsigned char debruijn_log32[] = { + 0, 9, 1, 10, 13, 21, 2, 29, + 11, 14, 16, 18, 22, 25, 3, 30, + 8, 12, 20, 28, 15, 17, 24, 7, + 19, 27, 23, 6, 26, 5, 4, 31 +}; diff --git a/src/Data/Bits/Coding.hs b/src/Data/Bits/Coding.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bits/Coding.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------- +-- | +-- Copyright : (c) Edward Kmett 2013 +-- License : BSD3 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +-------------------------------------------------------------------- +module Data.Bits.Coding + ( Coding(..) + -- * Get + , getAligned, getBit + -- * Put + , putAligned, putBit + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.State.Class +import Control.Monad.Reader.Class +import Control.Monad.Trans +import Data.Bits +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Word + +{-# ANN module "hlint: ignore Redundant $!" #-} + +------------------------------------------------------------------------------ +-- Coding +------------------------------------------------------------------------------ + +newtype Coding m a = Coding + { runCoding :: forall r. (a -> Int -> Word8 -> m r) -> Int -> Word8 -> m r + } + +instance Functor (Coding m) where + fmap f (Coding m) = Coding $ \ k -> m (k . f) + {-# INLINE fmap #-} + +instance Monad m => Applicative (Coding m) where + pure a = Coding $ \k -> k a + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +instance Monad m => Monad (Coding m) where + return a = Coding $ \ k -> k a + {-# INLINE return #-} + Coding m >>= f = Coding $ \ k -> m $ \a -> runCoding (f a) k + {-# INLINE (>>=) #-} + fail e = Coding $ \_ _ _ -> fail e + {-# INLINE fail #-} + +-- Binary.Get is strangely missing MonadPlus +instance (Monad m, Alternative m) => Alternative (Coding m) where + empty = Coding $ \_ _ _ -> empty + {-# INLINE empty #-} + Coding m <|> Coding n = Coding $ \k i b -> do + (a,i',b') <- m (\a i' b' -> pure (a,i',b')) i b <|> n (\a i' b' -> pure (a,i',b')) i b + k a i' b' + {-# INLINE (<|>) #-} + +instance MonadPlus m => MonadPlus (Coding m) where + mzero = Coding $ \_ _ _ -> mzero + {-# INLINE mzero #-} + mplus (Coding m) (Coding n) = Coding $ \k i b -> do + (a,i',b') <- m (\a i' b' -> return (a,i',b')) i b `mplus` n (\a i' b' -> return (a,i',b')) i b + k a i' b' + {-# INLINE mplus #-} + + +instance MonadTrans Coding where + lift m = Coding $ \k i w -> do + a <- m + k a i w + {-# INLINE lift #-} + +instance MonadState s m => MonadState s (Coding m) where + get = lift get + {-# INLINE get #-} + put = lift . put + {-# INLINE put #-} + +instance MonadReader e m => MonadReader e (Coding m) where + ask = lift ask + {-# INLINE ask #-} + local f (Coding m) = Coding $ \k i b -> do + (a,i',b') <- local f $ m (\a i' b' -> return (a, i', b')) i b + k a i' b' + {-# INLINE local #-} + +------------------------------------------------------------------------------ +-- Get +------------------------------------------------------------------------------ + +-- | 'Get' something from byte-aligned storage, starting on the next byte +-- and discarding any left over bits in the buffer. +-- +-- /NB:/ Using any operation from 'MonadGet' other than checking 'remaining' or +-- 'isEmpty' will implicitly perform this operation. +getAligned :: MonadGet m => m a -> Coding m a +getAligned m = Coding $ \k _ _ -> m >>= \ a -> k a 0 0 +{-# INLINE getAligned #-} + +-- | 'Get' a single bit, consuming an entire 'byte' if the bit buffer is empty +getBit :: MonadGet m => Coding m Bool +getBit = Coding $ \ k i b -> + if i == 0 + then getWord8 >>= \b' -> ((k $! testBit b' 7) $! 7) $! shiftR b' 1 + else ((k $! testBit b 7) $! i - 1) $! shiftR b 1 +{-# INLINE getBit #-} + +instance MonadGet m => MonadGet (Coding m) where + type Unchecked (Coding m) = Unchecked m + type Bytes (Coding m) = Bytes m + skip = getAligned . skip + {-# INLINE skip #-} + uncheckedSkip = getAligned . uncheckedSkip + {-# INLINE uncheckedSkip #-} + lookAhead (Coding m) = Coding $ \k i b -> lookAhead (m k i b) + {-# INLINE lookAhead #-} + lookAheadM (Coding m) = Coding $ \k i b -> do + emm <- lookAheadE $ m (\ma i' b' -> return $ maybe (Left (k Nothing i b)) (\a -> Right (k (Just a) i' b')) ma) i b + either id id emm + {-# INLINE lookAheadM #-} + lookAheadE (Coding m) = Coding $ \k i b -> do + emm <- lookAheadE $ m (\ea i' b' -> return $ either (\a -> Left (k (Left a) i b)) (\a -> Right (k (Right a) i' b')) ea) i b + either id id emm + {-# INLINE lookAheadE #-} + uncheckedLookAhead = getAligned . uncheckedLookAhead + {-# INLINE uncheckedLookAhead #-} + getBytes = getAligned . getBytes + {-# INLINE getBytes #-} + remaining = lift remaining + {-# INLINE remaining #-} + isEmpty = lift isEmpty + {-# INLINE isEmpty #-} + getWord8 = getAligned getWord8 + {-# INLINE getWord8 #-} + getByteString = getAligned . getByteString + {-# INLINE getByteString #-} + getLazyByteString = getAligned . getLazyByteString + {-# INLINE getLazyByteString #-} + getWord16le = getAligned getWord16le + {-# INLINE getWord16le #-} + getWord32le = getAligned getWord32le + {-# INLINE getWord32le #-} + getWord64le = getAligned getWord64le + {-# INLINE getWord64le #-} + getWord16be = getAligned getWord16be + {-# INLINE getWord16be #-} + getWord32be = getAligned getWord32be + {-# INLINE getWord32be #-} + getWord64be = getAligned getWord64be + {-# INLINE getWord64be #-} + getWord16host = getAligned getWord16host + {-# INLINE getWord16host #-} + getWord32host = getAligned getWord32host + {-# INLINE getWord32host #-} + getWord64host = getAligned getWord64host + {-# INLINE getWord64host #-} + getWordhost = getAligned getWordhost + {-# INLINE getWordhost #-} + +------------------------------------------------------------------------------ +-- Put +------------------------------------------------------------------------------ + +-- | Emit any remaining contents from the bit buffer. +-- +-- Any use of the combinators from 'MonadPut' (including 'flush') will cause +-- this to happen. +putAligned :: MonadPut m => m a -> Coding m a +putAligned m = Coding $ \ k i b -> + if i == 0 + then do + a <- m + k a 0 0 + else do + putWord8 b + a <- m + k a 0 0 + +-- | 'Put' a single bit, emitting an entire 'byte' if the bit buffer is full +putBit :: MonadPut m => Bool -> Coding m () +putBit v = Coding $ \k i b -> + if i == 7 + then do + putWord8 (pushBit b v) + k () 0 0 + else (k () $! i + 1) $! pushBit b v + where + pushBit w False = shiftL w 1 + pushBit w True = shiftL w 1 .|. 1 +{-# INLINE putBit #-} + +instance MonadPut m => MonadPut (Coding m) where + putWord8 = putAligned . putWord8 + {-# INLINE putWord8 #-} + putByteString = putAligned . putByteString + {-# INLINE putByteString #-} + putLazyByteString = putAligned . putLazyByteString + {-# INLINE putLazyByteString #-} + flush = putAligned flush + {-# INLINE flush #-} + putWord16le = putAligned . putWord16le + {-# INLINE putWord16le #-} + putWord32le = putAligned . putWord32le + {-# INLINE putWord32le #-} + putWord64le = putAligned . putWord64le + {-# INLINE putWord64le #-} + putWord16be = putAligned . putWord16be + {-# INLINE putWord16be #-} + putWord32be = putAligned . putWord32be + {-# INLINE putWord32be #-} + putWord64be = putAligned . putWord64be + {-# INLINE putWord64be #-} + putWord16host = putAligned . putWord16host + {-# INLINE putWord16host #-} + putWord32host = putAligned . putWord32host + {-# INLINE putWord32host #-} + putWord64host = putAligned . putWord64host + {-# INLINE putWord64host #-} + putWordhost = putAligned . putWordhost + {-# INLINE putWordhost #-} diff --git a/src/Data/Bits/Extras.hs b/src/Data/Bits/Extras.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bits/Extras.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface, MagicHash, UnboxedTuples, BangPatterns #-} +-------------------------------------------------------------------- +-- | +-- Copyright : (c) Edward Kmett 2013 +-- License : BSD3 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +-- Calculate a number of fiddly bit operations using fast de Bruijn +-- multiplication tables. +-------------------------------------------------------------------- +module Data.Bits.Extras + ( Ranked(..) + , log2 + , w8 + , w16 + , w32 + , w64 + ) where + +import Data.Bits +import Data.Int +import Data.Word +import Foreign.Ptr +import Foreign.Storable +import GHC.Base + +-- TODO: generalize to 64 bits, etc. +log2 :: Word32 -> Int +log2 !n0 = fromIntegral $ go (shiftR (n5 * 0x7C4ACDD) 27) where + go :: Word32 -> Word8 + go !i = inlinePerformIO $ peekElemOff debruijn_log32 (fromIntegral i) + !n1 = n0 .|. shiftR n0 1 + !n2 = n1 .|. shiftR n1 2 + !n3 = n2 .|. shiftR n2 4 + !n4 = n3 .|. shiftR n3 8 + !n5 = n4 .|. shiftR n4 16 +{-# INLINE log2 #-} + +class (Num t, Bits t) => Ranked t where + -- | Calculate the least significant set bit using a debruijn multiplication table. + -- /NB:/ The result of this function is undefined when given 0. + lsb :: t -> Int + lsb n = rank n - 1 + {-# INLINE lsb #-} + + -- | Calculate the number of trailing 0 bits. + rank :: t -> Int + rank 0 = 0 + rank n = lsb n + 1 + {-# INLINE rank #-} + + -- | Calculate the number of leading zeros. + nlz :: t -> Int + +instance Ranked Word64 where + lsb n = fromIntegral $ go (shiftR ((n .&. (-n)) * 0x07EDD5E59A4E28C2) 58) where + go :: Word64 -> Word8 + go i = inlinePerformIO $ peekElemOff debruijn_lsb64 (fromIntegral i) + {-# INLINE lsb #-} + + nlz x0 = popCount (complement x6) where + x1 = x0 .|. shiftR x0 1 + x2 = x1 .|. shiftR x1 2 + x3 = x2 .|. shiftR x2 4 + x4 = x3 .|. shiftR x3 8 + x5 = x4 .|. shiftR x4 16 + x6 = x5 .|. shiftR x5 32 + {-# INLINE nlz #-} + +instance Ranked Word32 where + lsb n = fromIntegral $ go (shiftR ((n .&. (-n)) * 0x077CB531) 27) where + go :: Word32 -> Word8 + go i = inlinePerformIO $ peekElemOff debruijn_lsb32 (fromIntegral i) + {-# INLINE lsb #-} + +{- + rank n = fromIntegral $ go (shiftR ((n .&. (-n)) * 0x4279976B) 26) where + go :: Word32 -> Word8 + go i = inlinePerformIO $ peekElemOff debruijn_rank32 (fromIntegral i) + {-# INLINE rank #-} +-} + + nlz x0 = popCount (complement x5) where + x1 = x0 .|. shiftR x0 1 + x2 = x1 .|. shiftR x1 2 + x3 = x2 .|. shiftR x2 4 + x4 = x3 .|. shiftR x3 8 + x5 = x4 .|. shiftR x4 16 + {-# INLINE nlz #-} + + +instance Ranked Word16 where + lsb = lsb . w32 + {-# INLINE lsb #-} + + rank = rank . w32 + {-# INLINE rank #-} + + nlz x0 = popCount (complement x4) where + x1 = x0 .|. shiftR x0 1 + x2 = x1 .|. shiftR x1 2 + x3 = x2 .|. shiftR x2 4 + x4 = x3 .|. shiftR x3 8 + {-# INLINE nlz #-} + +instance Ranked Word8 where + lsb = lsb . w32 + {-# INLINE lsb #-} + + rank = rank . w32 + {-# INLINE rank #-} + + nlz x0 = popCount (complement x3) where + x1 = x0 .|. shiftR x0 1 + x2 = x1 .|. shiftR x1 2 + x3 = x2 .|. shiftR x2 4 + {-# INLINE nlz #-} + +instance Ranked Int64 where + lsb = lsb . w64 + {-# INLINE lsb #-} + + rank = rank . w64 + {-# INLINE rank #-} + + nlz = nlz . w64 + {-# INLINE nlz #-} + +instance Ranked Int32 where + lsb = lsb . w32 + {-# INLINE lsb #-} + + rank = rank . w32 + {-# INLINE rank #-} + + nlz = nlz . w32 + {-# INLINE nlz #-} + +instance Ranked Int16 where + lsb = lsb . w32 + {-# INLINE lsb #-} + + rank = rank . w32 + {-# INLINE rank #-} + + nlz = nlz . w16 + {-# INLINE nlz #-} + +instance Ranked Int8 where + lsb = lsb . w32 + {-# INLINE lsb #-} + + rank = rank . w32 + {-# INLINE rank #-} + + nlz = nlz . w8 + {-# INLINE nlz #-} + +------------------------------------------------------------------------------ +-- Util +------------------------------------------------------------------------------ + +w8 :: Integral a => a -> Word8 +w8 = fromIntegral +{-# INLINE w8 #-} + +w16 :: Integral a => a -> Word16 +w16 = fromIntegral +{-# INLINE w16 #-} + +w32 :: Integral a => a -> Word32 +w32 = fromIntegral +{-# INLINE w32 #-} + +w64 :: Integral a => a -> Word64 +w64 = fromIntegral +{-# INLINE w64 #-} + +------------------------------------------------------------------------------ +-- de Bruijn Multiplication Tables +------------------------------------------------------------------------------ + +foreign import ccall "static &debruijn_lsb64" debruijn_lsb64 :: Ptr Word8 +foreign import ccall "static &debruijn_lsb32" debruijn_lsb32 :: Ptr Word8 +-- foreign import ccall "static &debruijn_rank32" debruijn_rank32 :: Ptr Word8 +foreign import ccall "static &debruijn_log32" debruijn_log32 :: Ptr Word8 + +#ifndef HLINT +inlinePerformIO :: IO a -> a +inlinePerformIO (IO m) = case m realWorld# of + (# _, r #) -> r +{-# INLINE inlinePerformIO #-} +#endif diff --git a/tests/doctests.hsc b/tests/doctests.hsc new file mode 100644 --- /dev/null +++ b/tests/doctests.hsc @@ -0,0 +1,74 @@ +{-# 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 + +##if defined(mingw32_HOST_OS) +##if defined(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" + : "-optP-include" + : "-optPdist/build/autogen/cabal_macros.h" + : "-hide-all-packages" + : "-Iincludes" + : 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