From 518774502ddc2caf9c04bcf72046a874a5b56b12 Mon Sep 17 00:00:00 2001
From: Taylor Fausak <taylor@fausak.me>
Date: Sat, 8 Jan 2022 16:18:24 +0000
Subject: [PATCH] Update everything for 2022

---
 .devcontainer.json                            |   4 +
 .github/workflows/brittany.yaml               |  10 +
 .github/workflows/ci.yaml                     |  77 +-
 .github/workflows/hlint.yaml                  |  10 +
 .gitignore                                    |   5 +-
 .vscode/extensions.json                       |   5 +
 .vscode/settings.json                         |   6 +
 CHANGELOG.markdown                            |  31 +-
 LICENSE.txt => LICENSE.markdown               |   2 +-
 caerbannog.cabal                              |  53 +-
 config/brittany.yaml                          |   4 +
 config/hlint.yaml                             |   5 +
 .../library}/Data/Binary/Bits.hs              |   4 +-
 .../library}/Data/Binary/Bits/Get.hs          | 341 ++++-----
 source/library/Data/Binary/Bits/Put.hs        | 180 +++++
 source/test-suite/Main.hs                     | 660 ++++++++++++++++++
 src/lib/Data/Binary/Bits/Put.hs               | 160 -----
 src/test/Main.hs                              | 485 -------------
 18 files changed, 1170 insertions(+), 872 deletions(-)
 create mode 100644 .devcontainer.json
 create mode 100644 .github/workflows/brittany.yaml
 create mode 100644 .github/workflows/hlint.yaml
 create mode 100644 .vscode/extensions.json
 create mode 100644 .vscode/settings.json
 rename LICENSE.txt => LICENSE.markdown (96%)
 create mode 100644 config/brittany.yaml
 create mode 100644 config/hlint.yaml
 rename {src/lib => source/library}/Data/Binary/Bits.hs (93%)
 rename {src/lib => source/library}/Data/Binary/Bits/Get.hs (56%)
 create mode 100644 source/library/Data/Binary/Bits/Put.hs
 create mode 100644 source/test-suite/Main.hs
 delete mode 100644 src/lib/Data/Binary/Bits/Put.hs
 delete mode 100644 src/test/Main.hs

diff --git a/.devcontainer.json b/.devcontainer.json
new file mode 100644
index 0000000..9301c68
--- /dev/null
+++ b/.devcontainer.json
@@ -0,0 +1,4 @@
+{
+  "image": "ghcr.io/tfausak/haskell-codespace:ghc-9.2",
+  "postCreateCommand": "cabal update"
+}
diff --git a/.github/workflows/brittany.yaml b/.github/workflows/brittany.yaml
new file mode 100644
index 0000000..b3898e6
--- /dev/null
+++ b/.github/workflows/brittany.yaml
@@ -0,0 +1,10 @@
+name: Brittany
+on: push
+jobs:
+  brittany:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v2
+      - uses: tfausak/brittany-action@v1
+        with:
+          config: config/brittany.yaml
diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml
index 0af2d4b..3dbc240 100644
--- a/.github/workflows/ci.yaml
+++ b/.github/workflows/ci.yaml
@@ -10,37 +10,76 @@ on:
     types:
       - created
 jobs:
-  build:
+  ci:
     strategy:
       matrix:
         include:
-          - { os: ubuntu-18.04, ghc: 9.0.1, cabal: 3.4.0.0 }
-          - { os: ubuntu-18.04, ghc: 8.10.3, cabal: 3.2.0.0 }
-          - { os: macos-10.15, ghc: 8.10.3, cabal: 3.2.0.0 }
-          - { os: windows-2019, ghc: 8.10.3, cabal: 3.2.0.0 }
-          - { os: ubuntu-18.04, ghc: 8.8.4, cabal: 3.0.0.0 }
-    runs-on: ${{ matrix.os }}
+          - { platform: ubuntu, ghc: 9.2.1 }
+          - { platform: macos, ghc: 9.2.1 }
+          - { platform: windows, ghc: 9.2.1, extension: .exe }
+          - { platform: ubuntu, ghc: 9.0.2 }
+          - { platform: ubuntu, ghc: 8.10.7 }
+    runs-on: ${{ matrix.platform }}-latest
+    name: GHC ${{ matrix.ghc }} on ${{ matrix.platform }}
     steps:
+
       - uses: actions/checkout@v2
+
+      - id: artifact
+        run: |
+          mkdir artifact
+          mkdir artifact/${{ matrix.platform }}
+          mkdir artifact/${{ matrix.platform }}/${{ matrix.ghc }}
+          echo '::set-output name=directory::artifact/${{ matrix.platform }}/${{ matrix.ghc }}'
+
       - id: setup-haskell
         uses: haskell/actions/setup@v1
         with:
           ghc-version: ${{ matrix.ghc }}
-          cabal-version: ${{ matrix.cabal }}
-      - run: cabal freeze && cat cabal.project.freeze
+
+      - run: cabal configure --enable-tests --flags pedantic --jobs
+
+      - run: cabal freeze
+
+      - run: cat cabal.project.freeze
+
       - uses: actions/cache@v2
         with:
           path: ${{ steps.setup-haskell.outputs.cabal-store }}
-          key: ${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}-${{ hashFiles('cabal.project.freeze') }}
-          restore-keys: |
-            ${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}-
-            ${{ matrix.os }}-${{ matrix.ghc }}-
+          key: ${{ matrix.platform }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
+          restore-keys: ${{ matrix.platform }}-${{ matrix.ghc }}-
+
+      - run: cabal build
+
       - run: cabal test --test-show-details direct
-      - run: cabal sdist
+
+      - run: cabal check
+
+      - run: cabal sdist --output-dir ${{ steps.artifact.outputs.directory }}
+
       - uses: actions/upload-artifact@v2
         with:
-          path: dist-newstyle/sdist/caerbannog-*.tar.gz
-          name: caerbannog-${{ github.sha }}.tar.gz
-      - run: cabal check
-      - if: github.event_name == 'release' && matrix.os == 'ubuntu-18.04' && matrix.ghc == '9.0.1'
-        run: cabal upload --publish --username '${{ secrets.HACKAGE_USERNAME }}' --password '${{ secrets.HACKAGE_PASSWORD }}' dist-newstyle/sdist/caerbannog-*.tar.gz
+          path: artifact
+          name: caerbannog-${{ github.sha }}
+
+  release:
+    needs: ci
+    if: github.event_name == 'release'
+    runs-on: ubuntu-latest
+    steps:
+
+      - uses: actions/download-artifact@v2
+        with:
+          name: caerbannog-${{ github.sha }}
+          path: artifact
+
+      - uses: actions/upload-release-asset@v1
+        env:
+          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+        with:
+          asset_content_type: application/gzip
+          asset_name: caerbannog-${{ github.event.release.tag_name }}.tar.gz
+          asset_path: artifact/ubuntu/9.2.1/caerbannog-${{ github.event.release.tag_name }}.tar.gz
+          upload_url: ${{ github.event.release.upload_url }}
+
+      - run: cabal upload --publish --username '${{ secrets.HACKAGE_USERNAME }}' --password '${{ secrets.HACKAGE_PASSWORD }}' artifact/ubuntu/9.2.1/caerbannog-${{ github.event.release.tag_name }}.tar.gz
diff --git a/.github/workflows/hlint.yaml b/.github/workflows/hlint.yaml
new file mode 100644
index 0000000..aa85604
--- /dev/null
+++ b/.github/workflows/hlint.yaml
@@ -0,0 +1,10 @@
+name: HLint
+on: push
+jobs:
+  hlint:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v2
+      - uses: tfausak/hlint-action@v1
+        with:
+          config: config/hlint.yaml
diff --git a/.gitignore b/.gitignore
index bc4f860..cdd1392 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,2 +1,5 @@
-/.stack-work
+/.stack-work/
+/cabal.project.freeze
+/cabal.project.local*
+/dist-newstyle/
 /stack.yaml.lock
diff --git a/.vscode/extensions.json b/.vscode/extensions.json
new file mode 100644
index 0000000..c089f68
--- /dev/null
+++ b/.vscode/extensions.json
@@ -0,0 +1,5 @@
+{
+  "recommendations": [
+    "taylorfausak.purple-yolk"
+  ]
+}
diff --git a/.vscode/settings.json b/.vscode/settings.json
new file mode 100644
index 0000000..8b1060f
--- /dev/null
+++ b/.vscode/settings.json
@@ -0,0 +1,6 @@
+{
+  "purple-yolk.brittany.command": "brittany --config-file config/brittany.yaml --write-mode inplace",
+  "purple-yolk.ghci.command": "cabal repl --repl-options -ddump-json",
+  "purple-yolk.hlint.command": "hlint --hint config/hlint.yaml --json --no-exit-code",
+  "purple-yolk.hlint.onSave": true
+}
diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown
index 570cf7d..5c1b00d 100644
--- a/CHANGELOG.markdown
+++ b/CHANGELOG.markdown
@@ -1,31 +1,4 @@
 # Change log
 
-## 0.6.0.3
-
-- Released on 2020-08-04.
-- Improved package documentation.
-
-## 0.6.0.2
-
-- Released on 2020-08-03.
-- First `caerbannog` release on Hackage.
-
-## 0.5
-
-- Released on 2015-01-09.
-
-## 0.4
-
-- Released on 2015-01-09.
-
-## 0.3
-
-- Released on 2013-03-14.
-
-## 0.2
-
-- Released on 2012-10-28.
-
-## 0.1
-
-- Initially released on 2011-10-22.
+Caerbannog follows the [Package Versioning Policy](https://pvp.haskell.org).
+You can find release notes [on GitHub](https://github.com/tfausak/caerbannog/releases).
diff --git a/LICENSE.txt b/LICENSE.markdown
similarity index 96%
rename from LICENSE.txt
rename to LICENSE.markdown
index 97392a6..f7ac1d3 100644
--- a/LICENSE.txt
+++ b/LICENSE.markdown
@@ -1,4 +1,4 @@
-Copyright (c) Lennart Kolmodin
+Copyright (c) Lennart Kolmodin, Taylor Fausak
 
 All rights reserved.
 
diff --git a/caerbannog.cabal b/caerbannog.cabal
index 5c4e2f0..082eb92 100644
--- a/caerbannog.cabal
+++ b/caerbannog.cabal
@@ -1,7 +1,8 @@
-cabal-version: >= 1.10
+cabal-version: 2.2
 
 name: caerbannog
 version: 0.6.1.0
+
 synopsis: That rabbit's got a vicious streak a mile wide!
 description:
   Caerbannog is a drop in replacement for the @binary-bits@ package. Unlike
@@ -22,41 +23,57 @@ description:
 author: Lennart Kolmodin
 build-type: Simple
 category: Data, Parsing
-extra-source-files:
-  CHANGELOG.markdown
-  README.markdown
-license-file: LICENSE.txt
-license: BSD3
+extra-source-files: CHANGELOG.markdown README.markdown
+license-file: LICENSE.markdown
+license: BSD-3-Clause
 maintainer: Taylor Fausak
 
 source-repository head
   location: https://github.com/tfausak/caerbannog
   type: git
 
-library
+flag pedantic
+  default: False
+  description: Enables @-Werror@, which turns warnings into errors.
+  manual: True
+
+common library
   build-depends:
-    base >= 4.13.0 && < 4.16
+    , base >= 4.13.0 && < 4.17
     , binary >= 0.8.7 && < 0.9
-    , bytestring >= 0.10.10 && < 0.11
+    , bytestring >= 0.10.10 && < 0.12
   default-language: Haskell98
+  ghc-options:
+    -Wall
+
+  if flag(pedantic)
+    ghc-options: -Werror
+
+common executable
+  import: library
+
+  build-depends: caerbannog
+  ghc-options:
+    -rtsopts
+    -threaded
+    -Wno-unused-packages
+
+library
+  import: library
+
   exposed-modules:
     Data.Binary.Bits
     Data.Binary.Bits.Get
     Data.Binary.Bits.Put
-  ghc-options:
-    -Wall
-  hs-source-dirs: src/lib
+  hs-source-dirs: source/library
 
 test-suite test
+  import: executable
+
   build-depends:
-    base
-    , binary
-    , caerbannog
-    , bytestring
     , hspec >= 2.7.6 && < 2.9
     , QuickCheck >= 2.13.2 && < 2.15
     , random >= 1.1 && < 1.3
-  default-language: Haskell98
-  hs-source-dirs: src/test
+  hs-source-dirs: source/test-suite
   main-is: Main.hs
   type: exitcode-stdio-1.0
diff --git a/config/brittany.yaml b/config/brittany.yaml
new file mode 100644
index 0000000..5cd9d88
--- /dev/null
+++ b/config/brittany.yaml
@@ -0,0 +1,4 @@
+conf_layout:
+  lconfig_cols: 79
+  lconfig_columnAlignMode: { tag: ColumnAlignModeDisabled }
+  lconfig_indentPolicy: IndentPolicyLeft
diff --git a/config/hlint.yaml b/config/hlint.yaml
new file mode 100644
index 0000000..0f43e72
--- /dev/null
+++ b/config/hlint.yaml
@@ -0,0 +1,5 @@
+- group: { name: dollar, enabled: true }
+- group: { name: generalise, enabled: true }
+- ignore: { name: Use lambda-case }
+- ignore: { name: Use list comprehension }
+- ignore: { name: Use tuple-section }
diff --git a/src/lib/Data/Binary/Bits.hs b/source/library/Data/Binary/Bits.hs
similarity index 93%
rename from src/lib/Data/Binary/Bits.hs
rename to source/library/Data/Binary/Bits.hs
index 5711a95..48e5d54 100644
--- a/src/lib/Data/Binary/Bits.hs
+++ b/source/library/Data/Binary/Bits.hs
@@ -2,7 +2,9 @@
 -- style, or more efficiently, using the 'Applicative' style. Writing is
 -- monadic style only. See "Data.Binary.Bits.Get" and "Data.Binary.Bits.Put",
 -- respectively.
-module Data.Binary.Bits ( BinaryBit(putBits, getBits) ) where
+module Data.Binary.Bits
+  ( BinaryBit(getBits, putBits)
+  ) where
 
 import qualified Data.Binary.Bits.Get as Get
 import qualified Data.Binary.Bits.Put as Put
diff --git a/src/lib/Data/Binary/Bits/Get.hs b/source/library/Data/Binary/Bits/Get.hs
similarity index 56%
rename from src/lib/Data/Binary/Bits/Get.hs
rename to source/library/Data/Binary/Bits/Get.hs
index dd17e74..448337d 100644
--- a/src/lib/Data/Binary/Bits/Get.hs
+++ b/source/library/Data/Binary/Bits/Get.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, CPP #-}
+{-# LANGUAGE BangPatterns #-}
 
 -- | Parse bits easily. Parsing can be done either in a monadic style, or more
 -- efficiently, using the 'Applicative' style.
@@ -38,52 +38,46 @@
 -- 'runBitGet'.
 
 module Data.Binary.Bits.Get
-            (
-            -- * BitGet monad
-
-            -- $bitget
-
-              BitGet
-            , runBitGet
+  ( BitGet
+  , runBitGet
 
             -- ** Get bytes
-            , getBool
-            , getWord8
-            , getWord16be
-            , getWord32be
-            , getWord64be
+  , getBool
+  , getWord8
+  , getWord16be
+  , getWord32be
+  , getWord64be
 
             -- * Blocks
 
             -- $blocks
-            , Block
-            , block
+  , Block
+  , block
 
             -- ** Read in Blocks
-            , bool
-            , word8
-            , word16be
-            , word32be
-            , word64be
-            , byteString
-            , Data.Binary.Bits.Get.getByteString
-            , Data.Binary.Bits.Get.getLazyByteString
-            , Data.Binary.Bits.Get.isEmpty
-
-            ) where
+  , bool
+  , word8
+  , word16be
+  , word32be
+  , word64be
+  , byteString
+  , Data.Binary.Bits.Get.getByteString
+  , Data.Binary.Bits.Get.getLazyByteString
+  , Data.Binary.Bits.Get.isEmpty
+  ) where
 
 import qualified Control.Monad.Fail as Fail
 
-import Data.Binary.Get as B ( Get, getLazyByteString, isEmpty )
-import Data.Binary.Get.Internal as B ( get, put, ensureN )
+import Data.Binary.Get as B (Get, getLazyByteString, isEmpty)
+import Data.Binary.Get.Internal as B (ensureN, get, put)
 
 import Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 import Data.ByteString.Unsafe
 
+import Control.Applicative as Appl
 import Data.Bits
 import Data.Word
-import Control.Applicative as Appl
 
 import Prelude as P
 
@@ -134,22 +128,21 @@ import Prelude as P
 --ipv6Header = 'runBitGet' ('block' ipv6headerblock)
 -- @
 
-data S = S {-# UNPACK #-} !ByteString -- Input
-           {-# UNPACK #-} !Int -- Bit offset (0-7)
-          deriving (Show)
+data S = S {-# UNPACK #-} !ByteString {-# UNPACK #-} !Int -- Bit offset (0-7)
+  deriving Show
 
 -- | A block that will be read with only one boundry check. Needs to know the
 -- number of bits in advance.
 data Block a = Block Int (S -> a)
 
 instance Functor Block where
-  fmap f (Block i p) = Block i (\s -> f (p s))
+  fmap f (Block i p) = Block i (f . p)
 
 instance Applicative Block where
-  pure a = Block 0 (\_ -> a)
-  (Block i p) <*> (Block j q) = Block (i+j) (\s -> p s $ q (incS i s))
-  (Block i _)  *> (Block j q) = Block (i+j) (q . incS i)
-  (Block i p) <*  (Block j _) = Block (i+j) p
+  pure a = Block 0 (const a)
+  (Block i p) <*> (Block j q) = Block (i + j) (\s -> p s $ q (incS i s))
+  (Block i _) *> (Block j q) = Block (i + j) (q . incS i)
+  (Block i p) <* (Block j _) = Block (i + j) p
 
 -- | Get a block. Will be read with one single boundry check, and
 -- therefore requires a statically known number of bits.
@@ -159,183 +152,212 @@ block :: Block a -> BitGet a
 block (Block i p) = do
   ensureBits i
   s <- getState
-  putState $! (incS i s)
+  putState $! incS i s
   return $! p s
 
 incS :: Int -> S -> S
 incS o (S bs n) =
-  let !o' = (n+o)
-      !d = o' `shiftR` 3
-      !n' = o' .&. make_mask 3
+  let
+    !o' = (n + o)
+    !d = o' `shiftR` 3
+    !n' = o' .&. makeMask 3
   in S (unsafeDrop d bs) n'
 
--- | make_mask 3 = 00000111
-make_mask :: (Bits a, Num a) => Int -> a
-make_mask n = (1 `shiftL` fromIntegral n) - 1
-{-# SPECIALIZE make_mask :: Int -> Int #-}
-{-# SPECIALIZE make_mask :: Int -> Word #-}
-{-# SPECIALIZE make_mask :: Int -> Word8 #-}
-{-# SPECIALIZE make_mask :: Int -> Word16 #-}
-{-# SPECIALIZE make_mask :: Int -> Word32 #-}
-{-# SPECIALIZE make_mask :: Int -> Word64 #-}
+-- | makeMask 3 = 00000111
+makeMask :: (Bits a, Num a) => Int -> a
+makeMask n = (1 `shiftL` fromIntegral n) - 1
+{-# SPECIALIZE makeMask :: Int -> Int #-}
+{-# SPECIALIZE makeMask :: Int -> Word #-}
+{-# SPECIALIZE makeMask :: Int -> Word8 #-}
+{-# SPECIALIZE makeMask :: Int -> Word16 #-}
+{-# SPECIALIZE makeMask :: Int -> Word32 #-}
+{-# SPECIALIZE makeMask :: Int -> Word64 #-}
 
-bit_offset :: Int -> Int
-bit_offset n = make_mask 3 .&. n
+bitOffset :: Int -> Int
+bitOffset n = makeMask 3 .&. n
 
-byte_offset :: Int -> Int
-byte_offset n = n `shiftR` 3
+byteOffset :: Int -> Int
+byteOffset n = n `shiftR` 3
 
 readBool :: S -> Bool
-readBool (S bs n) = testBit (unsafeHead bs) (7-n)
+readBool (S bs n) = testBit (unsafeHead bs) (7 - n)
 
 {-# INLINE readWord8 #-}
 readWord8 :: Int -> S -> Word8
 readWord8 n (S bs o)
+  |
   -- no bits at all, return 0
-  | n == 0 = 0
+    n == 0
+  = 0
+  |
 
   -- all bits are in the same byte
   -- we just need to shift and mask them right
-  | n <= 8 - o = let w = unsafeHead bs
-                     m = make_mask n
-                     w' = (w `shiftr_w8` (8 - o - n)) .&. m
-                 in w'
+    n <= 8 - o
+  = let
+      w = unsafeHead bs
+      m = makeMask n
+      w' = (w `shiftr_w8` (8 - o - n)) .&. m
+    in w'
+  |
 
   -- the bits are in two different bytes
   -- make a word16 using both bytes, and then shift and mask
-  | n <= 8 = let w = (fromIntegral (unsafeHead bs) `shiftl_w16` 8) .|.
-                     (fromIntegral (unsafeIndex bs 1))
-                 m = make_mask n
-                 w' = (w `shiftr_w16` (16 - o - n)) .&. m
-             in fromIntegral w'
-  | otherwise = error "readWord8: tried to read more than 8 bits"
+    n <= 8
+  = let
+      w = (fromIntegral (unsafeHead bs) `shiftl_w16` 8)
+        .|. fromIntegral (unsafeIndex bs 1)
+      m = makeMask n
+      w' = (w `shiftr_w16` (16 - o - n)) .&. m
+    in fromIntegral w'
+  | otherwise
+  = error "readWord8: tried to read more than 8 bits"
 
 {-# INLINE readWord16be #-}
 readWord16be :: Int -> S -> Word16
 readWord16be n s@(S bs o)
+  |
 
   -- 8 or fewer bits, use readWord8
-  | n <= 8 = fromIntegral (readWord8 n s)
+    n <= 8
+  = fromIntegral (readWord8 n s)
+  |
 
   -- handle 9 or more bits, stored in two bytes
 
   -- no offset, plain and simple 16 bytes
-  | o == 0 && n == 16 = let msb = fromIntegral (unsafeHead bs)
-                            lsb = fromIntegral (unsafeIndex bs 1)
-                            w = (msb `shiftl_w16` 8) .|. lsb
-                        in w
+    o == 0 && n == 16
+  = let
+      msb = fromIntegral (unsafeHead bs)
+      lsb = fromIntegral (unsafeIndex bs 1)
+      w = (msb `shiftl_w16` 8) .|. lsb
+    in w
+  |
 
   -- no offset, but not full 16 bytes
-  | o == 0 = let msb = fromIntegral (unsafeHead bs)
-                 lsb = fromIntegral (unsafeIndex bs 1)
-                 w = (msb `shiftl_w16` (n-8)) .|. (lsb `shiftr_w16` (16-n))
-             in w
+    o == 0
+  = let
+      msb = fromIntegral (unsafeHead bs)
+      lsb = fromIntegral (unsafeIndex bs 1)
+      w = (msb `shiftl_w16` (n - 8)) .|. (lsb `shiftr_w16` (16 - n))
+    in w
+  |
 
   -- with offset, and n=9-16
-  | n <= 16 = readWithOffset s shiftl_w16 shiftr_w16 n
-
-  | otherwise = error "readWord16be: tried to read more than 16 bits"
+    n <= 16
+  = readWithOffset s shiftl_w16 shiftr_w16 n
+  | otherwise
+  = error "readWord16be: tried to read more than 16 bits"
 
 {-# INLINE readWord32be #-}
 readWord32be :: Int -> S -> Word32
 readWord32be n s@(S _ o)
+  |
   -- 8 or fewer bits, use readWord8
-  | n <= 8 = fromIntegral (readWord8 n s)
+    n <= 8 = fromIntegral (readWord8 n s)
+  |
 
   -- 16 or fewer bits, use readWord16be
-  | n <= 16 = fromIntegral (readWord16be n s)
-
+    n <= 16 = fromIntegral (readWord16be n s)
   | o == 0 = readWithoutOffset s shiftl_w32 shiftr_w32 n
-
   | n <= 32 = readWithOffset s shiftl_w32 shiftr_w32 n
-
   | otherwise = error "readWord32be: tried to read more than 32 bits"
 
 
 {-# INLINE readWord64be #-}
 readWord64be :: Int -> S -> Word64
 readWord64be n s@(S _ o)
+  |
   -- 8 or fewer bits, use readWord8
-  | n <= 8 = fromIntegral (readWord8 n s)
+    n <= 8 = fromIntegral (readWord8 n s)
+  |
 
   -- 16 or fewer bits, use readWord16be
-  | n <= 16 = fromIntegral (readWord16be n s)
-
+    n <= 16 = fromIntegral (readWord16be n s)
   | o == 0 = readWithoutOffset s shiftl_w64 shiftr_w64 n
-
   | n <= 64 = readWithOffset s shiftl_w64 shiftr_w64 n
-
   | otherwise = error "readWord64be: tried to read more than 64 bits"
 
 
 readByteString :: Int -> S -> ByteString
 readByteString n s@(S bs o)
+  |
   -- no offset, easy.
-  | o == 0 = unsafeTake n bs
+    o == 0 = unsafeTake n bs
+  |
   -- offset. ugg. this is really naive and slow. but also pretty easy :)
-  | otherwise = B.pack (P.map (readWord8 8) (P.take n (iterate (incS 8) s)))
+    otherwise = B.pack (fmap (readWord8 8) (P.take n (iterate (incS 8) s)))
 
-readWithoutOffset :: (Bits a, Num a)
-                  => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> a
+readWithoutOffset
+  :: (Bits a, Num a) => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> a
 readWithoutOffset (S bs o) shifterL shifterR n
-  | o /= 0 = error "readWithoutOffset: there is an offset"
-
-  | bit_offset n == 0 && byte_offset n <= 4 =
-              let segs = byte_offset n
-                  bn 0 = fromIntegral (unsafeHead bs)
-                  bn x = (bn (x-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs x)
-
-              in bn (segs-1)
-
-  | n <= 64 = let segs = byte_offset n
-                  o' = bit_offset (n - 8 + o)
-
-                  bn 0 = fromIntegral (unsafeHead bs)
-                  bn x = (bn (x-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs x)
-
-                  msegs = bn (segs-1) `shifterL` o'
-
-                  lst = (fromIntegral (unsafeIndex bs segs)) `shifterR` (8 - o')
-
-                  w = msegs .|. lst
-              in w
-  | otherwise = error "readWithoutOffset: tried to read more than 64 bits"
-
-readWithOffset :: (Bits a, Num a)
-         => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> a
+  | o /= 0
+  = error "readWithoutOffset: there is an offset"
+  | bitOffset n == 0 && byteOffset n <= 4
+  = let
+      segs = byteOffset n
+      bn 0 = fromIntegral (unsafeHead bs)
+      bn x = (bn (x - 1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs x)
+    in bn (segs - 1)
+  | n <= 64
+  = let
+      segs = byteOffset n
+      o' = bitOffset (n - 8 + o)
+
+      bn 0 = fromIntegral (unsafeHead bs)
+      bn x = (bn (x - 1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs x)
+
+      msegs = bn (segs - 1) `shifterL` o'
+
+      lst = fromIntegral (unsafeIndex bs segs) `shifterR` (8 - o')
+
+      w = msegs .|. lst
+    in w
+  | otherwise
+  = error "readWithoutOffset: tried to read more than 64 bits"
+
+readWithOffset
+  :: (Bits a, Num a) => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> a
 readWithOffset (S bs o) shifterL shifterR n
-  | n <= 64 = let bits_in_msb = 8 - o
-                  (n',top) = (n - bits_in_msb
-                             , (fromIntegral (unsafeHead bs) .&. make_mask bits_in_msb) `shifterL` n')
+  | n <= 64
+  = let
+      bits_in_msb = 8 - o
+      (n', top) =
+        ( n - bits_in_msb
+        , (fromIntegral (unsafeHead bs) .&. makeMask bits_in_msb) `shifterL` n'
+        )
 
-                  segs = byte_offset n'
+      segs = byteOffset n'
 
-                  bn 0 = 0
-                  bn x = (bn (x-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs x)
+      bn 0 = 0
+      bn x = (bn (x - 1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs x)
 
-                  o' = bit_offset n'
+      o' = bitOffset n'
 
-                  mseg = bn segs `shifterL` o'
+      mseg = bn segs `shifterL` o'
 
-                  lst | o' > 0 = (fromIntegral (unsafeIndex bs (segs + 1))) `shifterR` (8 - o')
-                       | otherwise = 0
+      lst
+        | o' > 0
+        = fromIntegral (unsafeIndex bs (segs + 1)) `shifterR` (8 - o')
+        | otherwise
+        = 0
 
-                  w = top .|. mseg .|. lst
-              in w
-  | otherwise = error "readWithOffset: tried to read more than 64 bits"
+      w = top .|. mseg .|. lst
+    in w
+  | otherwise
+  = error "readWithOffset: tried to read more than 64 bits"
 
 -- | 'BitGet' is a monad, applicative and a functor. See 'runBitGet'
 -- for how to run it.
+--
+-- $bitget
 newtype BitGet a = B { runState :: S -> Get (S,a) }
 
 instance Monad BitGet where
   return = pure
-  (B f) >>= g = B $ \s -> do (s',a) <- f s
-                             runState (g a) s'
-
-#if !MIN_VERSION_GLASGOW_HASKELL(8, 8, 1, 0)
-  fail = Fail.fail
-#endif
+  (B f) >>= g = B $ \s -> do
+    (s', a) <- f s
+    runState (g a) s'
 
 instance Fail.MonadFail BitGet where
   fail str = B $ \(S inp n) -> putBackState inp n >> fail str
@@ -344,7 +366,7 @@ instance Functor BitGet where
   fmap f m = m >>= \a -> return (f a)
 
 instance Applicative BitGet where
-  pure x = B $ \s -> return (s,x)
+  pure x = B $ \s -> return (s, x)
   fm <*> m = fm >>= \f -> m >>= \v -> return (f v)
 
 instance Alternative BitGet where
@@ -356,7 +378,7 @@ instance Alternative BitGet where
 runBitGet :: BitGet a -> Get a
 runBitGet bg = do
   s <- mkInitState
-  ((S str' n),a) <- runState bg s
+  (S str' n, a) <- runState bg s
   putBackState str' n
   return a
 
@@ -368,14 +390,14 @@ mkInitState = do
 
 putBackState :: B.ByteString -> Int -> Get ()
 putBackState bs n = do
- remaining <- get
- put (B.drop (if n==0 then 0 else 1) bs `B.append` remaining)
+  remaining <- get
+  put (B.drop (if n == 0 then 0 else 1) bs `B.append` remaining)
 
 getState :: BitGet S
-getState = B $ \s -> return (s,s)
+getState = B $ \s -> return (s, s)
 
 putState :: S -> BitGet ()
-putState s = B $ \_ -> return (s,())
+putState s = B $ \_ -> return (s, ())
 
 -- | Make sure there are at least @n@ bits.
 ensureBits :: Int -> BitGet ()
@@ -383,12 +405,14 @@ ensureBits n = do
   (S bs o) <- getState
   if n <= (B.length bs * 8 - o)
     then return ()
-    else do let currentBits = B.length bs * 8 - o
-            let byteCount = (n - currentBits + 7) `div` 8
-            B $ \_ -> do B.ensureN byteCount
-                         bs' <- B.get
-                         put B.empty
-                         return (S (bs`append`bs') o, ())
+    else do
+      let currentBits = B.length bs * 8 - o
+      let byteCount = (n - currentBits + 7) `div` 8
+      B $ \_ -> do
+        B.ensureN byteCount
+        bs' <- B.get
+        put B.empty
+        return (S (bs `append` bs') o, ())
 
 -- | Get 1 bit as a 'Bool'.
 getBool :: BitGet Bool
@@ -419,18 +443,18 @@ getLazyByteString :: Int -> BitGet L.ByteString
 getLazyByteString n = do
   (S _ o) <- getState
   case o of
-    0 -> B $ \ (S bs o') -> do
-            putBackState bs o'
-            lbs <- B.getLazyByteString (fromIntegral n)
-            return (S B.empty 0, lbs)
-    _ -> L.fromChunks . (:[]) <$> Data.Binary.Bits.Get.getByteString n
+    0 -> B $ \(S bs o') -> do
+      putBackState bs o'
+      lbs <- B.getLazyByteString (fromIntegral n)
+      return (S B.empty 0, lbs)
+    _ -> L.fromChunks . (: []) <$> Data.Binary.Bits.Get.getByteString n
 
 -- | Test whether all input has been consumed, i.e. there are no remaining
 -- undecoded bytes.
 isEmpty :: BitGet Bool
-isEmpty = B $ \ (S bs o) -> if B.null bs
-                               then B.isEmpty >>= \e -> return (S bs o, e)
-                               else return (S bs o, False)
+isEmpty = B $ \(S bs o) -> if B.null bs
+  then B.isEmpty >>= \e -> return (S bs o, e)
+  else return (S bs o, False)
 
 -- | Read a 1 bit 'Bool'.
 bool :: Block Bool
@@ -454,8 +478,9 @@ word64be n = Block n (readWord64be n)
 
 -- | Read @n@ bytes as a 'ByteString'.
 byteString :: Int -> Block ByteString
-byteString n | n > 0 = Block (n*8) (readByteString n)
-             | otherwise = Block 0 (\_ -> B.empty)
+byteString n
+  | n > 0 = Block (n * 8) (readByteString n)
+  | otherwise = Block 0 (const B.empty)
 
 -- Unchecked shifts, from the package binary
 
diff --git a/source/library/Data/Binary/Bits/Put.hs b/source/library/Data/Binary/Bits/Put.hs
new file mode 100644
index 0000000..1fb1d2f
--- /dev/null
+++ b/source/library/Data/Binary/Bits/Put.hs
@@ -0,0 +1,180 @@
+-- | Put bits easily.
+
+module Data.Binary.Bits.Put
+  ( BitPut
+  , runBitPut
+  , joinPut
+
+          -- * Data types
+          -- ** Bool
+  , putBool
+
+          -- ** Words
+  , putWord8
+  , putWord16be
+  , putWord32be
+  , putWord64be
+
+          -- ** ByteString
+  , putByteString
+  ) where
+
+import Data.Bits ((.&.), (.|.))
+
+import qualified Data.Binary.Builder as B
+import qualified Data.Binary.Put as Put
+import qualified Data.Bits as Bits
+import qualified Data.ByteString as ByteString
+import qualified Data.Word as Word
+
+newtype BitPut a = BitPut
+  { run :: S -> PairS a
+  }
+
+data PairS a = PairS a {-# UNPACK #-} !S
+
+data S = S !B.Builder !Word.Word8 !Int
+
+-- | Put a 1 bit 'Bool'.
+putBool :: Bool -> BitPut ()
+putBool b = putWord8 1 (if b then 0xff else 0x00)
+
+-- | makeMask 3 = 00000111
+makeMask :: (Bits.Bits a, Num a) => Int -> a
+makeMask n = (1 `Bits.shiftL` fromIntegral n) - 1
+{-# SPECIALIZE makeMask :: Int -> Int #-}
+{-# SPECIALIZE makeMask :: Int -> Word #-}
+{-# SPECIALIZE makeMask :: Int -> Word.Word8 #-}
+{-# SPECIALIZE makeMask :: Int -> Word.Word16 #-}
+{-# SPECIALIZE makeMask :: Int -> Word.Word32 #-}
+{-# SPECIALIZE makeMask :: Int -> Word.Word64 #-}
+
+-- | Put the @n@ lower bits of a 'Word8'.
+putWord8 :: Int -> Word.Word8 -> BitPut ()
+putWord8 n w = BitPut $ \s ->
+  PairS ()
+    $ let w' = makeMask n .&. w
+      in
+        case s of
+                    -- a whole word8, no offset
+          (S b t o)
+            | n == 8 && o == 0
+            -> flush $ S b w n
+            |
+                      -- less than a word8, will fit in the current word8
+              n <= 8 - o
+            -> flush $ S b (t .|. (w' `Bits.shiftL` (8 - n - o))) (o + n)
+            |
+                      -- will finish this word8, and spill into the next one
+              otherwise
+            -> flush
+              $ let
+                  o' = o + n - 8
+                  b' = t .|. (w' `Bits.shiftR` o')
+                  t' = w `Bits.shiftL` (8 - o')
+                in S (b `mappend` B.singleton b') t' o'
+
+-- | Put the @n@ lower bits of a 'Word16'.
+putWord16be :: Int -> Word.Word16 -> BitPut ()
+putWord16be n w
+  | n <= 8 = putWord8 n (fromIntegral w)
+  | otherwise = BitPut $ \s ->
+    PairS ()
+      $ let w' = makeMask n .&. w
+        in
+          case s of
+          -- as n>=9, it's too big to fit into one single byte
+          -- it'll either use 2 or 3 bytes
+                                     -- it'll fit in 2 bytes
+            (S b t o)
+              | o + n <= 16
+              -> flush
+                $ let
+                    o' = o + n - 8
+                    b' = t .|. fromIntegral (w' `Bits.shiftR` o')
+                    t' = fromIntegral (w `Bits.shiftL` (8 - o'))
+                  in S (b `mappend` B.singleton b') t' o'
+              |
+                                     -- 3 bytes required
+                otherwise
+              -> flush
+                $ let
+                    o' = o + n - 16
+                    b' = t .|. fromIntegral (w' `Bits.shiftR` (o' + 8))
+                    b'' = fromIntegral ((w `Bits.shiftR` o') .&. 0xff)
+                    t' = fromIntegral (w `Bits.shiftL` (8 - o'))
+                  in S
+                    (b `mappend` B.singleton b' `mappend` B.singleton b'')
+                    t'
+                    o'
+
+-- | Put the @n@ lower bits of a 'Word32'.
+putWord32be :: Int -> Word.Word32 -> BitPut ()
+putWord32be n w
+  | n <= 16 = putWord16be n (fromIntegral w)
+  | otherwise = do
+    putWord32be (n - 16) (w `Bits.shiftR` 16)
+    putWord32be 16 (w .&. 0x0000ffff)
+
+-- | Put the @n@ lower bits of a 'Word64'.
+putWord64be :: Int -> Word.Word64 -> BitPut ()
+putWord64be n w
+  | n <= 32 = putWord32be n (fromIntegral w)
+  | otherwise = do
+    putWord64be (n - 32) (w `Bits.shiftR` 32)
+    putWord64be 32 (w .&. 0xffffffff)
+
+-- | Put a 'ByteString'.
+putByteString :: ByteString.ByteString -> BitPut ()
+putByteString bs = do
+  offset <- hasOffset
+  if offset
+    then mapM_ (putWord8 8) (ByteString.unpack bs) -- naive
+    else joinPut (Put.putByteString bs)
+  where hasOffset = BitPut $ \s@(S _ _ o) -> PairS (o /= 0) s
+
+-- | Run a 'Put' inside 'BitPut'. Any partially written bytes will be flushed
+-- before 'Put' executes to ensure byte alignment.
+joinPut :: Put.Put -> BitPut ()
+joinPut m = BitPut $ \s0 ->
+  PairS ()
+    $ let
+        (S b0 _ _) = flushIncomplete s0
+        b = Put.execPut m
+      in S (b0 `mappend` b) 0 0
+
+flush :: S -> S
+flush s@(S b w o)
+  | o > 8 = error "flush: offset > 8"
+  | o == 8 = S (b `mappend` B.singleton w) 0 0
+  | otherwise = s
+
+flushIncomplete :: S -> S
+flushIncomplete s@(S b w o)
+  | o == 0 = s
+  | otherwise = S (b `mappend` B.singleton w) 0 0
+
+-- | Run the 'BitPut' monad inside 'Put'.
+runBitPut :: BitPut () -> Put.Put
+runBitPut m = Put.putBuilder b
+ where
+  PairS _ s = run m (S mempty 0 0)
+  (S b _ _) = flushIncomplete s
+
+instance Functor BitPut where
+  fmap f (BitPut k) = BitPut $ \s -> let PairS x s' = k s in PairS (f x) s'
+
+instance Applicative BitPut where
+  pure a = BitPut (PairS a)
+  (BitPut f) <*> (BitPut g) = BitPut $ \s ->
+    let
+      PairS a s' = f s
+      PairS b s'' = g s'
+    in PairS (a b) s''
+
+instance Monad BitPut where
+  m >>= k = BitPut $ \s ->
+    let
+      PairS a s' = run m s
+      PairS b s'' = run (k a) s'
+    in PairS b s''
diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs
new file mode 100644
index 0000000..1d05127
--- /dev/null
+++ b/source/test-suite/Main.hs
@@ -0,0 +1,660 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+
+module Main
+  ( main
+  ) where
+
+import Data.Bits ((.|.))
+import Test.QuickCheck ((==>))
+
+import qualified Control.Applicative as Appl
+import qualified Data.Binary as Binary
+import qualified Data.Binary.Bits as BB
+import qualified Data.Binary.Bits.Get as BB
+import qualified Data.Binary.Bits.Put as BB
+import qualified Data.Binary.Get as Binary
+import qualified Data.Binary.Put as Binary
+import qualified Data.Bits as Bits
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Word as Word
+import qualified Foreign
+import qualified Test.Hspec as Hspec
+import qualified Test.QuickCheck as QC
+
+main :: IO ()
+main = Hspec.hspec $ do
+  Hspec.describe "Internal test functions" $ do
+    Hspec.it "prop_bitreq" $ QC.property prop_bitreq
+
+  Hspec.describe "Custom test cases" $ do
+    Hspec.it "prop_composite_case" $ QC.property prop_composite_case
+
+  Hspec.describe "getByteString" $ do
+    Hspec.it "prop_getByteString_negative"
+      $ QC.property prop_getByteString_negative
+
+  Hspec.describe "getLazyByteString" $ do
+    Hspec.it "getLazyByteString == getByteString"
+      $ QC.property prop_getLazyByteString_equal_to_ByteString
+    Hspec.it "getLazyByteString == getByteString (with shift)"
+      $ QC.property prop_getLazyByteString_equal_to_ByteString2
+
+  Hspec.describe "isEmpty" $ do
+    Hspec.it "prop_isEmptyOfEmptyEmpty" $ QC.property prop_isEmptyOfEmptyEmpty
+    Hspec.it "prop_isEmptyOfNonEmptyEmpty"
+      $ QC.property prop_isEmptyOfNonEmptyEmpty
+    Hspec.it "prop_isEmptyOfConsumedEmpty"
+      $ QC.property prop_isEmptyOfConsumedEmpty
+    Hspec.it "prop_isEmptyOfNotConsumedNotEmpty"
+      $ QC.property prop_isEmptyOfNotConsumedNotEmpty
+
+  Hspec.describe "Fail" $ do
+    Hspec.it "monadic fail" $ QC.property prop_fail
+
+  Hspec.describe "Applicative" $ do
+    Hspec.it "left identity" $ QC.property prop_alternativeLeftIdentity
+    Hspec.it "right identity" $ QC.property prop_alternativeRightIdentity
+
+  Hspec.describe "prop_bitput_with_get_from_binary" $ do
+    Hspec.it "Word8" $ QC.property
+      (prop_bitput_with_get_from_binary :: W [Word.Word8] -> QC.Property)
+    Hspec.it "Word16" $ QC.property
+      (prop_bitput_with_get_from_binary :: W [Word.Word16] -> QC.Property)
+    Hspec.it "Word32" $ QC.property
+      (prop_bitput_with_get_from_binary :: W [Word.Word32] -> QC.Property)
+    Hspec.it "Word64" $ QC.property
+      (prop_bitput_with_get_from_binary :: W [Word.Word64] -> QC.Property)
+
+  Hspec.describe "prop_bitget_with_put_from_binary" $ do
+    Hspec.it "Word8" $ QC.property
+      (prop_bitget_with_put_from_binary :: W [Word.Word8] -> QC.Property)
+    Hspec.it "Word16" $ QC.property
+      (prop_bitget_with_put_from_binary :: W [Word.Word16] -> QC.Property)
+    Hspec.it "Word32" $ QC.property
+      (prop_bitget_with_put_from_binary :: W [Word.Word32] -> QC.Property)
+    Hspec.it "Word64" $ QC.property
+      (prop_bitget_with_put_from_binary :: W [Word.Word64] -> QC.Property)
+
+  Hspec.describe "prop_compare_put_with_naive" $ do
+    Hspec.it "Word8" $ QC.property
+      (prop_compare_put_with_naive :: W [Word.Word8] -> QC.Property)
+    Hspec.it "Word16" $ QC.property
+      (prop_compare_put_with_naive :: W [Word.Word16] -> QC.Property)
+    Hspec.it "Word32" $ QC.property
+      (prop_compare_put_with_naive :: W [Word.Word32] -> QC.Property)
+    Hspec.it "Word64" $ QC.property
+      (prop_compare_put_with_naive :: W [Word.Word64] -> QC.Property)
+
+  Hspec.describe "prop_compare_get_with_naive" $ do
+    Hspec.it "Word8" $ QC.property
+      (prop_compare_get_with_naive :: W [Word.Word8] -> QC.Property)
+    Hspec.it "Word16" $ QC.property
+      (prop_compare_get_with_naive :: W [Word.Word16] -> QC.Property)
+    Hspec.it "Word32" $ QC.property
+      (prop_compare_get_with_naive :: W [Word.Word32] -> QC.Property)
+    Hspec.it "Word64" $ QC.property
+      (prop_compare_get_with_naive :: W [Word.Word64] -> QC.Property)
+
+  Hspec.describe "prop_put_with_bitreq" $ do
+    Hspec.it "Word8"
+      $ QC.property (prop_putget_with_bitreq :: W Word.Word8 -> QC.Property)
+    Hspec.it "Word16"
+      $ QC.property (prop_putget_with_bitreq :: W Word.Word16 -> QC.Property)
+    Hspec.it "Word32"
+      $ QC.property (prop_putget_with_bitreq :: W Word.Word32 -> QC.Property)
+    Hspec.it "Word64"
+      $ QC.property (prop_putget_with_bitreq :: W Word.Word64 -> QC.Property)
+
+  Hspec.describe "prop_putget_list_simple" $ do
+    Hspec.it "Bool"
+      $ QC.property (prop_putget_list_simple :: W [Bool] -> QC.Property)
+    Hspec.it "Word8" $ QC.property
+      (prop_putget_list_simple :: W [Word.Word8] -> QC.Property)
+    Hspec.it "Word16" $ QC.property
+      (prop_putget_list_simple :: W [Word.Word16] -> QC.Property)
+    Hspec.it "Word32" $ QC.property
+      (prop_putget_list_simple :: W [Word.Word32] -> QC.Property)
+    Hspec.it "Word64" $ QC.property
+      (prop_putget_list_simple :: W [Word.Word64] -> QC.Property)
+
+  Hspec.describe "prop_putget_applicative_with_bitreq" $ do
+    Hspec.it "Word8" $ QC.property
+      (prop_putget_applicative_with_bitreq :: W
+          [(Word.Word8, Word.Word8, Word.Word8)]
+        -> QC.Property
+      )
+    Hspec.it "Word16" $ QC.property
+      (prop_putget_applicative_with_bitreq :: W
+          [(Word.Word16, Word.Word16, Word.Word16)]
+        -> QC.Property
+      )
+    Hspec.it "Word32" $ QC.property
+      (prop_putget_applicative_with_bitreq :: W
+          [(Word.Word32, Word.Word32, Word.Word32)]
+        -> QC.Property
+      )
+    Hspec.it "Word64" $ QC.property
+      (prop_putget_applicative_with_bitreq :: W
+          [(Word.Word64, Word.Word64, Word.Word64)]
+        -> QC.Property
+      )
+
+  Hspec.describe "prop_putget_list_with_bitreq" $ do
+    Hspec.it "Word8" $ QC.property
+      (prop_putget_list_with_bitreq :: W [Word.Word8] -> QC.Property)
+    Hspec.it "Word16" $ QC.property
+      (prop_putget_list_with_bitreq :: W [Word.Word16] -> QC.Property)
+    Hspec.it "Word32" $ QC.property
+      (prop_putget_list_with_bitreq :: W [Word.Word32] -> QC.Property)
+    Hspec.it "Word64" $ QC.property
+      (prop_putget_list_with_bitreq :: W [Word.Word64] -> QC.Property)
+  Hspec.describe "prop_bitget_bytestring_interspersed" $ do
+    Hspec.it "Word8" $ QC.property
+      (prop_bitget_bytestring_interspersed :: W Word.Word8
+        -> [B.ByteString]
+        -> QC.Property
+      )
+    Hspec.it "Word16" $ QC.property
+      (prop_bitget_bytestring_interspersed :: W Word.Word16
+        -> [B.ByteString]
+        -> QC.Property
+      )
+    Hspec.it "Word32" $ QC.property
+      (prop_bitget_bytestring_interspersed :: W Word.Word32
+        -> [B.ByteString]
+        -> QC.Property
+      )
+    Hspec.it "Word64" $ QC.property
+      (prop_bitget_bytestring_interspersed :: W Word.Word64
+        -> [B.ByteString]
+        -> QC.Property
+      )
+  Hspec.describe "Simulate programs" $ do
+    Hspec.it "primitive" $ QC.property prop_primitive
+    Hspec.it "many primitives in sequence" $ QC.property prop_program
+
+prop_isEmptyOfEmptyEmpty :: Bool
+prop_isEmptyOfEmptyEmpty = Binary.runGet (BB.runBitGet BB.isEmpty) L.empty
+
+prop_isEmptyOfNonEmptyEmpty :: L.ByteString -> QC.Property
+prop_isEmptyOfNonEmptyEmpty bs =
+  not (L.null bs) ==> not (Binary.runGet (BB.runBitGet BB.isEmpty) bs)
+
+prop_isEmptyOfConsumedEmpty :: L.ByteString -> QC.Property
+prop_isEmptyOfConsumedEmpty bs =
+  not (L.null bs)
+    ==> Binary.runGet (BB.runBitGet (BB.getByteString n >> BB.isEmpty)) bs
+  where n = fromIntegral $ L.length bs
+
+prop_isEmptyOfNotConsumedNotEmpty :: L.ByteString -> Int -> QC.Property
+prop_isEmptyOfNotConsumedNotEmpty bs n =
+  fromIntegral n < L.length bs && not (L.null bs) ==> not
+    (Binary.runGet (BB.runBitGet (BB.getByteString n >> BB.isEmpty)) bs)
+
+prop_getLazyByteString_equal_to_ByteString
+  :: L.ByteString -> Int -> QC.Property
+prop_getLazyByteString_equal_to_ByteString bs n =
+  fromIntegral n
+    <= L.length bs
+    ==> Binary.runGet (BB.runBitGet (BB.getLazyByteString (fromIntegral n))) bs
+    == (L.fromChunks . (: []) $ Binary.runGet
+         (BB.runBitGet (BB.getByteString n))
+         bs
+       )
+
+prop_getLazyByteString_equal_to_ByteString2
+  :: L.ByteString -> Int -> QC.Property
+prop_getLazyByteString_equal_to_ByteString2 bs n =
+  (L.length bs > 1)
+    && fromIntegral n
+    < L.length bs
+    ==> Binary.runGet
+          (BB.runBitGet
+            (BB.getWord8 2 >> BB.getLazyByteString (fromIntegral n))
+          )
+          bs
+    == (L.fromChunks . (: []) $ Binary.runGet
+         (BB.runBitGet (BB.getWord8 2 >> BB.getByteString n))
+         bs
+       )
+
+prop_getByteString_negative :: Int -> QC.Property
+prop_getByteString_negative n =
+  n
+    < 1
+    ==> Binary.runGet (BB.runBitGet (BB.getByteString n)) L.empty
+    == B.empty
+
+prop_putget_with_bitreq
+  :: (BB.BinaryBit a, Num a, Bits.Bits a, Ord a) => W a -> QC.Property
+prop_putget_with_bitreq (W w) =
+  QC.property
+    $
+  -- write all words with as many bits as it's required
+      let
+        p = BB.putBits (bitreq w) w
+        g = BB.getBits (bitreq w)
+        lbs = Binary.runPut (BB.runBitPut p)
+        w' = Binary.runGet (BB.runBitGet g) lbs
+      in w == w'
+
+-- | Write a list of items. Each item is written with the maximum amount of
+-- bits, i.e. 8 for Word8, 16 for Word16, etc.
+prop_putget_list_simple
+  :: (BB.BinaryBit a, Eq a, Foreign.Storable a) => W [a] -> QC.Property
+prop_putget_list_simple (W ws) =
+  QC.property
+    $ let
+        s = Foreign.sizeOf (head ws) * 8
+        p = mapM_ (BB.putBits s) ws
+        g = mapM (const (BB.getBits s)) ws
+        lbs = Binary.runPut (BB.runBitPut p)
+        ws' = Binary.runGet (BB.runBitGet g) lbs
+      in ws == ws'
+
+-- | Write a list of items. Each item is written with exactly as many bits
+-- as required. Then read it back.
+prop_putget_list_with_bitreq
+  :: (BB.BinaryBit a, Num a, Bits.Bits a, Ord a) => W [a] -> QC.Property
+prop_putget_list_with_bitreq (W ws) =
+  QC.property
+    $
+  -- write all words with as many bits as it's required
+      let
+        p = mapM_ (\v -> BB.putBits (bitreq v) v) ws
+        g = mapM BB.getBits bitlist
+        lbs = Binary.runPut (BB.runBitPut p)
+        ws' = Binary.runGet (BB.runBitGet g) lbs
+      in ws == ws'
+  where bitlist = fmap bitreq ws
+
+prop_putget_applicative_with_bitreq
+  :: (BB.BinaryBit a, Num a, Bits.Bits a, Ord a)
+  => W [(a, a, a)]
+  -> QC.Property
+prop_putget_applicative_with_bitreq (W ts) =
+  QC.property
+    $ let
+        p = mapM_
+          (\(a, b, c) -> do
+            BB.putBits (bitreq a) a
+            BB.putBits (bitreq b) b
+            BB.putBits (bitreq c) c
+          )
+          ts
+        g = mapM
+          (\(a, b, c) ->
+            (,,) <$> BB.getBits a <*> BB.getBits b <*> BB.getBits c
+          )
+          bitlist
+        lbs = Binary.runPut (BB.runBitPut p)
+        ts' = Binary.runGet (BB.runBitGet g) lbs
+      in ts == ts'
+  where bitlist = fmap (\(a, b, c) -> (bitreq a, bitreq b, bitreq c)) ts
+
+-- | Write bits using this library, and read them back using the binary
+-- library.
+prop_bitput_with_get_from_binary
+  :: (BB.BinaryBit a, Binary.Binary a, Foreign.Storable a, Eq a)
+  => W [a]
+  -> QC.Property
+prop_bitput_with_get_from_binary (W ws) =
+  QC.property
+    $ let
+        s = Foreign.sizeOf (head ws) * 8
+        p = mapM_ (BB.putBits s) ws
+        g = mapM (const Binary.get) ws
+        lbs = Binary.runPut (BB.runBitPut p)
+        ws' = Binary.runGet g lbs
+      in ws == ws'
+
+-- | Write bits using the binary library, and read them back using this
+-- library.
+prop_bitget_with_put_from_binary
+  :: (BB.BinaryBit a, Binary.Binary a, Foreign.Storable a, Eq a)
+  => W [a]
+  -> QC.Property
+prop_bitget_with_put_from_binary (W ws) =
+  QC.property
+    $ let
+        s = Foreign.sizeOf (head ws) * 8
+        p = mapM_ Binary.put ws
+        g = mapM (const (BB.getBits s)) ws
+        lbs = Binary.runPut p
+        ws' = Binary.runGet (BB.runBitGet g) lbs
+      in ws == ws'
+
+-- | Write each 'ByteString' with a variable sized value as a separator.
+prop_bitget_bytestring_interspersed
+  :: (BB.BinaryBit a, Binary.Binary a, Num a, Ord a, Bits.Bits a)
+  => W a
+  -> [B.ByteString]
+  -> QC.Property
+prop_bitget_bytestring_interspersed (W ws) bss =
+  QC.property
+    $ let
+        p =
+          mapM_ (\bs -> BB.putBits (bitreq ws) ws >> BB.putByteString bs) bss
+        g = mapM
+          (\bs ->
+            (,) <$> BB.getBits (bitreq ws) <*> BB.getByteString (B.length bs)
+          )
+          bss
+        lbs = Binary.runPut (BB.runBitPut p)
+        r = Binary.runGet (BB.runBitGet g) lbs
+      in fmap ((,) ws) bss == r
+
+-- | Test failing.
+prop_fail :: L.ByteString -> String -> QC.Property
+prop_fail lbs errMsg0 = QC.forAll (QC.choose (0, 8 * L.length lbs)) $ \len ->
+  let
+    (bytes, bits) = len `divMod` 8
+    expectedBytesConsumed
+      | bits == 0 = bytes
+      | otherwise = bytes + 1
+    p = do
+      _ <- BB.getByteString (fromIntegral bytes)
+      _ <- BB.getBits (fromIntegral bits) :: BB.BitGet Word.Word8
+      fail errMsg0
+    r = Binary.runGetIncremental (BB.runBitGet p) `Binary.pushChunks` lbs
+  in case r of
+    Binary.Fail remainingBS pos errMsg ->
+      (L.fromChunks [remainingBS] == L.drop expectedBytesConsumed lbs)
+        && (pos == expectedBytesConsumed)
+        && (errMsg == errMsg0)
+    _ -> False
+
+{- hlint ignore prop_alternativeLeftIdentity "Alternative law, left identity" -}
+-- | Test Alternative instance.
+prop_alternativeLeftIdentity :: L.ByteString -> QC.Property
+prop_alternativeLeftIdentity lbs =
+  QC.property
+    $ Binary.runGet
+        (BB.runBitGet (Appl.empty Appl.<|> BB.getLazyByteString n))
+        lbs
+    == lbs
+  where n = fromIntegral $ L.length lbs
+
+{- hlint ignore prop_alternativeRightIdentity "Alternative law, right identity" -}
+prop_alternativeRightIdentity :: L.ByteString -> QC.Property
+prop_alternativeRightIdentity lbs =
+  QC.property
+    $ Binary.runGet
+        (BB.runBitGet (BB.getLazyByteString n Appl.<|> Appl.empty))
+        lbs
+    == lbs
+  where n = fromIntegral $ L.length lbs
+
+-- | number of bits required to write @v@
+bitreq :: (Num b, Num a, Bits.Bits a, Ord a) => a -> b
+bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
+
+bittable :: (Bits.Bits a, Num a) => [(Integer, a)]
+bittable = [ (fromIntegral x, (1 `Bits.shiftL` x) - 1) | x <- [1 .. 64] ]
+
+prop_bitreq :: W Word.Word64 -> QC.Property
+prop_bitreq (W w) =
+  QC.property
+    $ (w == 0 && bitreq w == (1 :: Integer))
+    || bitreq w
+    == bitreq (w `Bits.shiftR` 1)
+    + (1 :: Integer)
+
+prop_composite_case :: Bool -> W Word.Word16 -> QC.Property
+prop_composite_case b (W w) =
+  w
+    < 0x8000
+    ==> let
+          p = do
+            BB.putBool b
+            BB.putWord16be 15 w
+          g = do
+            v <- BB.getBool
+            if v
+              then BB.getWord16be 15
+              else do
+                msb <- BB.getWord8 7
+                lsb <- BB.getWord8 8
+                return
+                  ((fromIntegral msb `Bits.shiftL` 8) .|. fromIntegral lsb)
+          lbs = Binary.runPut (BB.runBitPut p)
+          w' = Binary.runGet (BB.runBitGet g) lbs
+        in w == w'
+
+prop_compare_put_with_naive
+  :: (Bits.Bits a, BB.BinaryBit a, Ord a, Num a) => W [a] -> QC.Property
+prop_compare_put_with_naive (W ws) =
+  QC.property
+    $ let
+        pn = mapM_ (\v -> naivePut (bitreq v) v) ws
+        p = mapM_ (\v -> BB.putBits (bitreq v) v) ws
+        lbs_n = Binary.runPut (BB.runBitPut pn)
+        lbs = Binary.runPut (BB.runBitPut p)
+      in lbs_n == lbs
+
+prop_compare_get_with_naive
+  :: (Bits.Bits a, BB.BinaryBit a, Ord a, Num a) => W [a] -> QC.Property
+prop_compare_get_with_naive (W ws) =
+  QC.property
+    $ let
+        gn = mapM (naiveGet . bitreq) ws
+        g = mapM (BB.getBits . bitreq) ws
+        p = mapM_ (\v -> naivePut (bitreq v) v) ws
+        lbs = Binary.runPut (BB.runBitPut p)
+        rn = Binary.runGet (BB.runBitGet gn) lbs
+        r = Binary.runGet (BB.runBitGet g) lbs
+        -- we must help our compiler to resolve the types of 'gn' and 'g'
+        _types = rn == ws && r == ws
+      in rn == r
+
+-- | Write one bit at a time until the full word has been written
+naivePut :: (Bits.Bits a) => Int -> a -> BB.BitPut ()
+naivePut n w = mapM_ (BB.putBool . Bits.testBit w) [n - 1, n - 2 .. 0]
+
+-- | Read one bit at a time until we've reconstructed the whole word
+naiveGet :: (Bits.Bits a, Num a) => Int -> BB.BitGet a
+naiveGet n0 =
+  let
+    loop 0 acc = return acc
+    loop n acc = do
+      b <- BB.getBool
+      if b
+        then loop (n - 1) ((acc `Bits.shiftL` 1) + 1)
+        else loop (n - 1) (acc `Bits.shiftL` 1)
+  in loop n0 0
+
+shrinker :: (Num a, Ord a, Bits.Bits a) => a -> [a]
+shrinker 0 = []
+shrinker w =
+  [w `Bits.shiftR` 1 -- try to make everything roughly half size
+                    ]
+    <> [ w' -- flip bits to zero, left->right
+       | m <- [n, n - 1 .. 1]
+       , let w' = w `Bits.clearBit` m
+       , w /= w'
+       ]
+    <> [w - 1] -- just make it a little smaller
+  where n = bitreq w
+
+newtype W a = W
+  { unW :: a
+  }
+  deriving (Show, Eq, Ord)
+
+arbitraryW :: (QC.Arbitrary (W a)) => QC.Gen a
+arbitraryW = unW <$> QC.arbitrary
+
+shrinkW :: (QC.Arbitrary (W a)) => a -> [a]
+shrinkW x = unW <$> QC.shrink (W x)
+
+instance QC.Arbitrary (W Bool) where
+  arbitrary = W <$> QC.arbitrary
+  shrink = fmap W <$> QC.shrink . unW
+
+instance QC.Arbitrary (W Word.Word8) where
+  arbitrary = W <$> QC.choose (minBound, maxBound)
+  shrink = fmap W . shrinker . unW
+
+instance QC.Arbitrary (W Word.Word16) where
+  arbitrary = W <$> QC.choose (minBound, maxBound)
+  shrink = fmap W . shrinker . unW
+
+instance QC.Arbitrary (W Word.Word32) where
+  arbitrary = W <$> QC.choose (minBound, maxBound)
+  shrink = fmap W . shrinker . unW
+
+instance QC.Arbitrary (W Word.Word64) where
+  arbitrary = W <$> QC.choose (minBound, maxBound)
+  shrink = fmap W . shrinker . unW
+
+instance QC.Arbitrary B.ByteString where
+  arbitrary = B.pack <$> QC.arbitrary
+  shrink bs = B.pack <$> QC.shrink (B.unpack bs)
+
+instance QC.Arbitrary L.ByteString where
+  arbitrary = L.fromChunks <$> QC.arbitrary
+  shrink bs = L.fromChunks <$> QC.shrink (L.toChunks bs)
+
+instance (QC.Arbitrary (W a)) => QC.Arbitrary (W [a]) where
+  arbitrary = W . fmap unW <$> QC.arbitrary
+  shrink = fmap (W . fmap unW) <$> mapM QC.shrink . fmap W . unW
+
+instance (QC.Arbitrary (W a), QC.Arbitrary (W b)) => QC.Arbitrary (W (a,b)) where
+  arbitrary = (W .) . (,) <$> arbitraryW <*> arbitraryW
+  shrink (W (a, b)) = (W .) . (,) <$> shrinkW a <*> shrinkW b
+
+instance (QC.Arbitrary (W a), QC.Arbitrary (W b), QC.Arbitrary (W c)) => QC.Arbitrary (W (a,b,c)) where
+  arbitrary = ((W .) .) . (,,) <$> arbitraryW <*> arbitraryW <*> arbitraryW
+  shrink (W (a, b, c)) =
+    ((W .) .) . (,,) <$> shrinkW a <*> shrinkW b <*> shrinkW c
+
+data Primitive
+  = Bool Bool
+  | W8  Int Word.Word8
+  | W16 Int Word.Word16
+  | W32 Int Word.Word32
+  | W64 Int Word.Word64
+  | BS  Int B.ByteString
+  | LBS Int L.ByteString
+  | IsEmpty
+  deriving (Eq, Show)
+
+type Program = [Primitive]
+
+instance QC.Arbitrary Primitive where
+  arbitrary = do
+    let
+      gen c = do
+        let
+          (maxBits, _) =
+            (\w -> (Bits.finiteBitSize w, c undefined w)) undefined
+        bits <- QC.choose (0, maxBits)
+        n <- QC.choose (0, fromIntegral (2 ^ bits - 1 :: Integer))
+        return (c bits n)
+    QC.oneof
+      [ Bool <$> QC.arbitrary
+      , gen W8
+      , gen W16
+      , gen W32
+      , gen W64
+      , do
+        n <- QC.choose (0, 10)
+        cs <- QC.vector n
+        return (BS n (B.pack cs))
+      , do
+        n <- QC.choose (0, 10)
+        cs <- QC.vector n
+        return (LBS n (L.pack cs))
+      , return IsEmpty
+      ]
+  shrink p =
+    let snk c x = fmap (\x' -> c (bitreq x') x') (shrinker x)
+    in
+      case p of
+        Bool b -> if b then [Bool False] else []
+        W8 _ x -> snk W8 x
+        W16 _ x -> snk W16 x
+        W32 _ x -> snk W32 x
+        W64 _ x -> snk W64 x
+        BS _ bs ->
+          let ws = B.unpack bs
+          in fmap (\ws' -> BS (length ws') (B.pack ws')) (QC.shrink ws)
+        LBS _ lbs ->
+          let ws = L.unpack lbs
+          in fmap (\ws' -> LBS (length ws') (L.pack ws')) (QC.shrink ws)
+        IsEmpty -> []
+
+prop_primitive :: Primitive -> QC.Property
+prop_primitive prim =
+  QC.property
+    $ let
+        p = putPrimitive prim
+        g = getPrimitive prim
+        lbs = Binary.runPut (BB.runBitPut p)
+        r = Binary.runGet (BB.runBitGet g) lbs
+      in r == prim
+
+prop_program :: Program -> QC.Property
+prop_program program =
+  QC.property
+    $ let
+        p = mapM_ putPrimitive program
+        g = verifyProgram (8 * fromIntegral (L.length lbs)) program
+        lbs = Binary.runPut (BB.runBitPut p)
+        r = Binary.runGet (BB.runBitGet g) lbs
+      in r
+
+putPrimitive :: Primitive -> BB.BitPut ()
+putPrimitive p = case p of
+  Bool b -> BB.putBool b
+  W8 n x -> BB.putWord8 n x
+  W16 n x -> BB.putWord16be n x
+  W32 n x -> BB.putWord32be n x
+  W64 n x -> BB.putWord64be n x
+  BS _ bs -> BB.putByteString bs
+  LBS _ lbs -> mapM_ BB.putByteString (L.toChunks lbs)
+  IsEmpty -> return ()
+
+getPrimitive :: Primitive -> BB.BitGet Primitive
+getPrimitive p = case p of
+  Bool _ -> Bool <$> BB.getBool
+  W8 n _ -> W8 n <$> BB.getWord8 n
+  W16 n _ -> W16 n <$> BB.getWord16be n
+  W32 n _ -> W32 n <$> BB.getWord32be n
+  W64 n _ -> W64 n <$> BB.getWord64be n
+  BS n _ -> BS n <$> BB.getByteString n
+  LBS n _ -> LBS n <$> BB.getLazyByteString n
+  IsEmpty -> BB.isEmpty >> return IsEmpty
+
+
+verifyProgram :: Int -> Program -> BB.BitGet Bool
+verifyProgram totalLength = go 0
+ where
+  go _ [] = return True
+  go pos (p : ps) = case p of
+    Bool x -> check x BB.getBool >> go (pos + 1) ps
+    W8 n x -> check x (BB.getWord8 n) >> go (pos + n) ps
+    W16 n x -> check x (BB.getWord16be n) >> go (pos + n) ps
+    W32 n x -> check x (BB.getWord32be n) >> go (pos + n) ps
+    W64 n x -> check x (BB.getWord64be n) >> go (pos + n) ps
+    BS n x -> check x (BB.getByteString n) >> go (pos + (8 * n)) ps
+    LBS n x -> check x (BB.getLazyByteString n) >> go (pos + (8 * n)) ps
+    IsEmpty -> do
+      let expected = pos == totalLength
+      actual <- BB.isEmpty
+      if expected == actual
+        then go pos ps
+        else
+          error
+          $ "isEmpty returned wrong value, expected "
+          <> show expected
+          <> " but got "
+          <> show actual
+  check x g = do
+    y <- g
+    if x == y
+      then return ()
+      else
+        error $ "Roundtrip error: Expected " <> show x <> " but got " <> show y
diff --git a/src/lib/Data/Binary/Bits/Put.hs b/src/lib/Data/Binary/Bits/Put.hs
deleted file mode 100644
index 6b693cb..0000000
--- a/src/lib/Data/Binary/Bits/Put.hs
+++ /dev/null
@@ -1,160 +0,0 @@
--- | Put bits easily.
-
-module Data.Binary.Bits.Put
-          ( BitPut
-          , runBitPut
-          , joinPut
-
-          -- * Data types
-          -- ** Bool
-          , putBool
-
-          -- ** Words
-          , putWord8
-          , putWord16be
-          , putWord32be
-          , putWord64be
-
-          -- ** ByteString
-          , putByteString
-          )
-          where
-
-import Data.Bits ((.&.), (.|.))
-
-import qualified Data.Binary.Builder as B
-import qualified Data.Binary.Put as Put
-import qualified Data.Bits as Bits
-import qualified Data.ByteString as ByteString
-import qualified Data.Word as Word
-
-data BitPut a = BitPut { run :: (S -> PairS a) }
-
-data PairS a = PairS a {-# UNPACK #-} !S
-
-data S = S !B.Builder !Word.Word8 !Int
-
--- | Put a 1 bit 'Bool'.
-putBool :: Bool -> BitPut ()
-putBool b = putWord8 1 (if b then 0xff else 0x00)
-
--- | make_mask 3 = 00000111
-make_mask :: (Bits.Bits a, Num a) => Int -> a
-make_mask n = (1 `Bits.shiftL` fromIntegral n) - 1
-{-# SPECIALIZE make_mask :: Int -> Int #-}
-{-# SPECIALIZE make_mask :: Int -> Word #-}
-{-# SPECIALIZE make_mask :: Int -> Word.Word8 #-}
-{-# SPECIALIZE make_mask :: Int -> Word.Word16 #-}
-{-# SPECIALIZE make_mask :: Int -> Word.Word32 #-}
-{-# SPECIALIZE make_mask :: Int -> Word.Word64 #-}
-
--- | Put the @n@ lower bits of a 'Word8'.
-putWord8 :: Int -> Word.Word8 -> BitPut ()
-putWord8 n w = BitPut $ \s -> PairS () $
-  let w' = make_mask n .&. w in
-  case s of
-                -- a whole word8, no offset
-    (S b t o) | n == 8 && o == 0 -> flush $ S b w n
-                -- less than a word8, will fit in the current word8
-              | n <= 8 - o       -> flush $ S b (t .|. (w' `Bits.shiftL` (8 - n - o))) (o+n)
-                -- will finish this word8, and spill into the next one
-              | otherwise -> flush $
-                              let o' = o + n - 8
-                                  b' = t .|. (w' `Bits.shiftR` o')
-                                  t' = w `Bits.shiftL` (8 - o')
-                              in S (b `mappend` B.singleton b') t' o'
-
--- | Put the @n@ lower bits of a 'Word16'.
-putWord16be :: Int -> Word.Word16 -> BitPut ()
-putWord16be n w
-  | n <= 8 = putWord8 n (fromIntegral w)
-  | otherwise =
-      BitPut $ \s -> PairS () $
-        let w' = make_mask n .&. w in
-        case s of
-          -- as n>=9, it's too big to fit into one single byte
-          -- it'll either use 2 or 3 bytes
-                                     -- it'll fit in 2 bytes
-          (S b t o) | o + n <= 16 -> flush $
-                        let o' = o + n - 8
-                            b' = t .|. fromIntegral (w' `Bits.shiftR` o')
-                            t' = fromIntegral (w `Bits.shiftL` (8-o'))
-                        in (S (b `mappend` B.singleton b') t' o')
-                                   -- 3 bytes required
-                    | otherwise -> flush $
-                        let o'  = o + n - 16
-                            b'  = t .|. fromIntegral (w' `Bits.shiftR` (o' + 8))
-                            b'' = fromIntegral ((w `Bits.shiftR` o') .&. 0xff)
-                            t'  = fromIntegral (w `Bits.shiftL` (8-o'))
-                        in (S (b `mappend` B.singleton b' `mappend` B.singleton b'') t' o')
-
--- | Put the @n@ lower bits of a 'Word32'.
-putWord32be :: Int -> Word.Word32 -> BitPut ()
-putWord32be n w
-  | n <= 16 = putWord16be n (fromIntegral w)
-  | otherwise = do
-      putWord32be (n-16) (w`Bits.shiftR`16)
-      putWord32be    16  (w .&. 0x0000ffff)
-
--- | Put the @n@ lower bits of a 'Word64'.
-putWord64be :: Int -> Word.Word64 -> BitPut ()
-putWord64be n w
-  | n <= 32 = putWord32be n (fromIntegral w)
-  | otherwise = do
-      putWord64be (n-32) (w`Bits.shiftR`32)
-      putWord64be    32  (w .&. 0xffffffff)
-
--- | Put a 'ByteString'.
-putByteString :: ByteString.ByteString -> BitPut ()
-putByteString bs = do
-  offset <- hasOffset
-  if offset
-    then mapM_ (putWord8 8) (ByteString.unpack bs) -- naive
-    else joinPut (Put.putByteString bs)
-  where
-    hasOffset = BitPut $ \ s@(S _ _ o) -> PairS (o /= 0) s
-
--- | Run a 'Put' inside 'BitPut'. Any partially written bytes will be flushed
--- before 'Put' executes to ensure byte alignment.
-joinPut :: Put.Put -> BitPut ()
-joinPut m = BitPut $ \s0 -> PairS () $
-  let (S b0 _ _) = flushIncomplete s0
-      b = Put.execPut m
-  in (S (b0`mappend`b) 0 0)
-
-flush :: S -> S
-flush s@(S b w o)
-  | o > 8 = error "flush: offset > 8"
-  | o == 8 = S (b `mappend` B.singleton w) 0 0
-  | otherwise = s
-
-flushIncomplete :: S -> S
-flushIncomplete s@(S b w o)
-  | o == 0 = s
-  | otherwise = (S (b `mappend` B.singleton w) 0 0)
-
--- | Run the 'BitPut' monad inside 'Put'.
-runBitPut :: BitPut () -> Put.Put
-runBitPut m = Put.putBuilder b
-  where
-  PairS _ s = run m (S mempty 0 0)
-  (S b _ _) = flushIncomplete s
-
-instance Functor BitPut where
-  fmap f (BitPut k) = BitPut $ \s ->
-    let PairS x s' = k s
-    in PairS (f x) s'
-
-instance Applicative BitPut where
-  pure a = BitPut (\s -> PairS a s)
-  (BitPut f) <*> (BitPut g) = BitPut $ \s ->
-    let PairS a s' = f s
-        PairS b s'' = g s'
-    in PairS (a b) s''
-
-instance Monad BitPut where
-  m >>= k = BitPut $ \s ->
-    let PairS a s'  = run m s
-        PairS b s'' = run (k a) s'
-    in PairS b s''
-  return x = BitPut $ \s -> PairS x s
diff --git a/src/test/Main.hs b/src/test/Main.hs
deleted file mode 100644
index 91adb5f..0000000
--- a/src/test/Main.hs
+++ /dev/null
@@ -1,485 +0,0 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
-
-module Main ( main ) where
-
-import Data.Bits ((.|.))
-import Test.QuickCheck ((==>))
-
-import qualified Control.Applicative as Appl
-import qualified Data.Binary as Binary
-import qualified Data.Binary.Bits as BB
-import qualified Data.Binary.Bits.Get as BB
-import qualified Data.Binary.Bits.Put as BB
-import qualified Data.Binary.Get as Binary
-import qualified Data.Binary.Put as Binary
-import qualified Data.Bits as Bits
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as L
-import qualified Data.Word as Word
-import qualified Foreign
-import qualified Test.Hspec as Hspec
-import qualified Test.QuickCheck as QC
-
-main :: IO ()
-main = Hspec.hspec $ do
-  Hspec.describe "Internal test functions" $ do
-      Hspec.it "prop_bitreq" $ QC.property prop_bitreq
-
-  Hspec.describe "Custom test cases" $ do
-      Hspec.it "prop_composite_case" $ QC.property prop_composite_case
-
-  Hspec.describe "getByteString" $ do
-      Hspec.it "prop_getByteString_negative" $ QC.property prop_getByteString_negative
-
-  Hspec.describe "getLazyByteString" $ do
-      Hspec.it "getLazyByteString == getByteString" $ QC.property
-                     prop_getLazyByteString_equal_to_ByteString
-      Hspec.it "getLazyByteString == getByteString (with shift)" $ QC.property
-                     prop_getLazyByteString_equal_to_ByteString2
-
-  Hspec.describe "isEmpty" $ do
-      Hspec.it "prop_isEmptyOfEmptyEmpty" $ QC.property prop_isEmptyOfEmptyEmpty
-      Hspec.it "prop_isEmptyOfNonEmptyEmpty" $ QC.property prop_isEmptyOfNonEmptyEmpty
-      Hspec.it "prop_isEmptyOfConsumedEmpty" $ QC.property prop_isEmptyOfConsumedEmpty
-      Hspec.it "prop_isEmptyOfNotConsumedNotEmpty" $ QC.property prop_isEmptyOfNotConsumedNotEmpty
-
-  Hspec.describe "Fail" $ do
-      Hspec.it "monadic fail" $ QC.property prop_fail
-
-  Hspec.describe "Applicative" $ do
-      Hspec.it "left identity" $ QC.property prop_alternativeLeftIdentity
-      Hspec.it "right identity" $ QC.property prop_alternativeRightIdentity
-
-  Hspec.describe "prop_bitput_with_get_from_binary" $ do
-      Hspec.it "Word8" $ QC.property  (prop_bitput_with_get_from_binary :: W [Word.Word8]  -> QC.Property)
-      Hspec.it "Word16" $ QC.property (prop_bitput_with_get_from_binary :: W [Word.Word16] -> QC.Property)
-      Hspec.it "Word32" $ QC.property (prop_bitput_with_get_from_binary :: W [Word.Word32] -> QC.Property)
-      Hspec.it "Word64" $ QC.property (prop_bitput_with_get_from_binary :: W [Word.Word64] -> QC.Property)
-
-  Hspec.describe "prop_bitget_with_put_from_binary" $ do
-      Hspec.it "Word8" $ QC.property  (prop_bitget_with_put_from_binary :: W [Word.Word8]  -> QC.Property)
-      Hspec.it "Word16" $ QC.property (prop_bitget_with_put_from_binary :: W [Word.Word16] -> QC.Property)
-      Hspec.it "Word32" $ QC.property (prop_bitget_with_put_from_binary :: W [Word.Word32] -> QC.Property)
-      Hspec.it "Word64" $ QC.property (prop_bitget_with_put_from_binary :: W [Word.Word64] -> QC.Property)
-
-  Hspec.describe "prop_compare_put_with_naive" $ do
-      Hspec.it "Word8" $ QC.property  (prop_compare_put_with_naive :: W [Word.Word8]  -> QC.Property)
-      Hspec.it "Word16" $ QC.property (prop_compare_put_with_naive :: W [Word.Word16] -> QC.Property)
-      Hspec.it "Word32" $ QC.property (prop_compare_put_with_naive :: W [Word.Word32] -> QC.Property)
-      Hspec.it "Word64" $ QC.property (prop_compare_put_with_naive :: W [Word.Word64] -> QC.Property)
-
-  Hspec.describe "prop_compare_get_with_naive" $ do
-      Hspec.it "Word8" $ QC.property  (prop_compare_get_with_naive:: W [Word.Word8]  -> QC.Property)
-      Hspec.it "Word16" $ QC.property (prop_compare_get_with_naive:: W [Word.Word16] -> QC.Property)
-      Hspec.it "Word32" $ QC.property (prop_compare_get_with_naive:: W [Word.Word32] -> QC.Property)
-      Hspec.it "Word64" $ QC.property (prop_compare_get_with_naive:: W [Word.Word64] -> QC.Property)
-
-  Hspec.describe "prop_put_with_bitreq" $ do
-      Hspec.it "Word8" $ QC.property  (prop_putget_with_bitreq :: W Word.Word8  -> QC.Property)
-      Hspec.it "Word16" $ QC.property (prop_putget_with_bitreq :: W Word.Word16 -> QC.Property)
-      Hspec.it "Word32" $ QC.property (prop_putget_with_bitreq :: W Word.Word32 -> QC.Property)
-      Hspec.it "Word64" $ QC.property (prop_putget_with_bitreq :: W Word.Word64 -> QC.Property)
-
-  Hspec.describe "prop_putget_list_simple" $ do
-      Hspec.it "Bool" $ QC.property  (prop_putget_list_simple :: W [Bool]   -> QC.Property)
-      Hspec.it "Word8" $ QC.property (prop_putget_list_simple :: W [Word.Word8]  -> QC.Property)
-      Hspec.it "Word16" $ QC.property (prop_putget_list_simple :: W [Word.Word16] -> QC.Property)
-      Hspec.it "Word32" $ QC.property (prop_putget_list_simple :: W [Word.Word32] -> QC.Property)
-      Hspec.it "Word64" $ QC.property (prop_putget_list_simple :: W [Word.Word64] -> QC.Property)
-
-  Hspec.describe "prop_putget_applicative_with_bitreq" $ do
-      Hspec.it "Word8" $ QC.property (prop_putget_applicative_with_bitreq :: W [(Word.Word8,Word.Word8,Word.Word8)]  -> QC.Property)
-      Hspec.it "Word16" $ QC.property (prop_putget_applicative_with_bitreq :: W [(Word.Word16,Word.Word16,Word.Word16)] -> QC.Property)
-      Hspec.it "Word32" $ QC.property (prop_putget_applicative_with_bitreq :: W [(Word.Word32,Word.Word32,Word.Word32)] -> QC.Property)
-      Hspec.it "Word64" $ QC.property (prop_putget_applicative_with_bitreq :: W [(Word.Word64,Word.Word64,Word.Word64)] -> QC.Property)
-
-  Hspec.describe "prop_putget_list_with_bitreq" $ do
-      Hspec.it "Word8" $ QC.property  (prop_putget_list_with_bitreq :: W [Word.Word8]  -> QC.Property)
-      Hspec.it "Word16" $ QC.property (prop_putget_list_with_bitreq :: W [Word.Word16] -> QC.Property)
-      Hspec.it "Word32" $ QC.property (prop_putget_list_with_bitreq :: W [Word.Word32] -> QC.Property)
-      Hspec.it "Word64" $ QC.property (prop_putget_list_with_bitreq :: W [Word.Word64] -> QC.Property)
-  Hspec.describe "prop_bitget_bytestring_interspersed" $ do
-      Hspec.it "Word8" $ QC.property  (prop_bitget_bytestring_interspersed :: W Word.Word8  -> [B.ByteString] -> QC.Property)
-      Hspec.it "Word16" $ QC.property (prop_bitget_bytestring_interspersed :: W Word.Word16 -> [B.ByteString] -> QC.Property)
-      Hspec.it "Word32" $ QC.property (prop_bitget_bytestring_interspersed :: W Word.Word32 -> [B.ByteString] -> QC.Property)
-      Hspec.it "Word64" $ QC.property (prop_bitget_bytestring_interspersed :: W Word.Word64 -> [B.ByteString] -> QC.Property)
-  Hspec.describe "Simulate programs" $ do
-      Hspec.it "primitive" $ QC.property prop_primitive
-      Hspec.it "many primitives in sequence" $ QC.property prop_program
-
-prop_isEmptyOfEmptyEmpty :: Bool
-prop_isEmptyOfEmptyEmpty = Binary.runGet (BB.runBitGet BB.isEmpty) L.empty
-
-prop_isEmptyOfNonEmptyEmpty :: L.ByteString -> QC.Property
-prop_isEmptyOfNonEmptyEmpty bs =
-  not (L.null bs) ==> not (Binary.runGet (BB.runBitGet BB.isEmpty) bs)
-
-prop_isEmptyOfConsumedEmpty :: L.ByteString -> QC.Property
-prop_isEmptyOfConsumedEmpty bs =
-  not (L.null bs) ==>
-    Binary.runGet (BB.runBitGet (BB.getByteString n >> BB.isEmpty)) bs
-    where n = fromIntegral $ L.length bs
-
-prop_isEmptyOfNotConsumedNotEmpty :: L.ByteString -> Int -> QC.Property
-prop_isEmptyOfNotConsumedNotEmpty bs n =
-  (fromIntegral n) < L.length bs && not (L.null bs) ==>
-    not (Binary.runGet (BB.runBitGet (BB.getByteString n >> BB.isEmpty)) bs)
-
-prop_getLazyByteString_equal_to_ByteString :: L.ByteString -> Int -> QC.Property
-prop_getLazyByteString_equal_to_ByteString bs n =
-  (fromIntegral n) <= L.length bs ==>
-    Binary.runGet (BB.runBitGet (BB.getLazyByteString (fromIntegral n))) bs ==
-            (L.fromChunks . (:[]) $ Binary.runGet (BB.runBitGet (BB.getByteString n)) bs)
-
-prop_getLazyByteString_equal_to_ByteString2 :: L.ByteString -> Int -> QC.Property
-prop_getLazyByteString_equal_to_ByteString2 bs n =
-  (L.length bs > 1) && (fromIntegral n) < L.length bs ==>
-    Binary.runGet (BB.runBitGet (BB.getWord8 2 >> BB.getLazyByteString (fromIntegral n))) bs ==
-            (L.fromChunks . (:[]) $ Binary.runGet (BB.runBitGet (BB.getWord8 2 >> BB.getByteString n)) bs)
-
-prop_getByteString_negative :: Int -> QC.Property
-prop_getByteString_negative n =
-  n < 1 ==>
-    Binary.runGet (BB.runBitGet (BB.getByteString n)) L.empty == B.empty
-
-prop_putget_with_bitreq :: (BB.BinaryBit a, Num a, Bits.Bits a, Ord a) => W a -> QC.Property
-prop_putget_with_bitreq (W w) = QC.property $
-  -- write all words with as many bits as it's required
-  let p = BB.putBits (bitreq w) w
-      g = BB.getBits (bitreq w)
-      lbs = Binary.runPut (BB.runBitPut p)
-      w' = Binary.runGet (BB.runBitGet g) lbs
-  in w == w'
-
--- | Write a list of items. Each item is written with the maximum amount of
--- bits, i.e. 8 for Word8, 16 for Word16, etc.
-prop_putget_list_simple :: (BB.BinaryBit a, Eq a, Foreign.Storable a) => W [a] -> QC.Property
-prop_putget_list_simple (W ws) = QC.property $
-  let s = Foreign.sizeOf (head ws) * 8
-      p = mapM_ (BB.putBits s) ws
-      g = mapM  (const (BB.getBits s)) ws
-      lbs = Binary.runPut (BB.runBitPut p)
-      ws' = Binary.runGet (BB.runBitGet g) lbs
-  in ws == ws'
-
--- | Write a list of items. Each item is written with exactly as many bits
--- as required. Then read it back.
-prop_putget_list_with_bitreq :: (BB.BinaryBit a, Num a, Bits.Bits a, Ord a) => W [a] -> QC.Property
-prop_putget_list_with_bitreq (W ws) = QC.property $
-  -- write all words with as many bits as it's required
-  let p = mapM_ (\v -> BB.putBits (bitreq v) v) ws
-      g = mapM BB.getBits bitlist
-      lbs = Binary.runPut (BB.runBitPut p)
-      ws' = Binary.runGet (BB.runBitGet g) lbs
-  in ws == ws'
-  where
-    bitlist = map bitreq ws
-
-prop_putget_applicative_with_bitreq :: (BB.BinaryBit a, Num a, Bits.Bits a, Ord a) => W [(a,a,a)] -> QC.Property
-prop_putget_applicative_with_bitreq (W ts) = QC.property $
-  let p = mapM_ (\(a,b,c) -> do BB.putBits (bitreq a) a
-                                BB.putBits (bitreq b) b
-                                BB.putBits (bitreq c) c) ts
-      g = mapM (\(a,b,c) -> (,,) <$> BB.getBits a <*> BB.getBits b <*> BB.getBits c) bitlist
-      lbs = Binary.runPut (BB.runBitPut p)
-      ts' = Binary.runGet (BB.runBitGet g) lbs
-  in ts == ts'
-  where
-    bitlist = map (\(a,b,c) -> (bitreq a, bitreq b, bitreq c)) ts
-
--- | Write bits using this library, and read them back using the binary
--- library.
-prop_bitput_with_get_from_binary :: (BB.BinaryBit a, Binary.Binary a, Foreign.Storable a, Eq a) => W [a] -> QC.Property
-prop_bitput_with_get_from_binary (W ws) = QC.property $
-  let s = Foreign.sizeOf (head ws) * 8
-      p = mapM_ (BB.putBits s) ws
-      g = mapM (const Binary.get) ws
-      lbs = Binary.runPut (BB.runBitPut p)
-      ws' = Binary.runGet g lbs
-  in ws == ws'
-
--- | Write bits using the binary library, and read them back using this
--- library.
-prop_bitget_with_put_from_binary :: (BB.BinaryBit a, Binary.Binary a, Foreign.Storable a, Eq a) => W [a] -> QC.Property
-prop_bitget_with_put_from_binary (W ws) = QC.property $
-  let s = Foreign.sizeOf (head ws) * 8
-      p = mapM_ Binary.put ws
-      g = mapM (const (BB.getBits s)) ws
-      lbs = Binary.runPut p
-      ws' = Binary.runGet (BB.runBitGet g) lbs
-  in ws == ws'
-
--- | Write each 'ByteString' with a variable sized value as a separator.
-prop_bitget_bytestring_interspersed :: (BB.BinaryBit a, Binary.Binary a, Num a, Ord a, Bits.Bits a) => W a -> [B.ByteString] -> QC.Property
-prop_bitget_bytestring_interspersed (W ws) bss = QC.property $
-  let p = mapM_ (\bs -> BB.putBits (bitreq ws) ws >> BB.putByteString bs) bss
-      g = mapM (\bs -> (,) <$> BB.getBits (bitreq ws) <*> BB.getByteString (B.length bs)) bss
-      lbs = Binary.runPut (BB.runBitPut p)
-      r = Binary.runGet (BB.runBitGet g) lbs
-  in map ((,) ws) bss == r
-
--- | Test failing.
-prop_fail :: L.ByteString -> String -> QC.Property
-prop_fail lbs errMsg0 = QC.forAll (QC.choose (0, 8 * L.length lbs)) $ \len ->
-  let (bytes,bits) = len `divMod` 8
-      expectedBytesConsumed
-        | bits == 0 = bytes
-        | otherwise = bytes + 1
-      p = do _ <- BB.getByteString (fromIntegral bytes)
-             _ <- BB.getBits (fromIntegral bits) :: BB.BitGet Word.Word8
-             fail errMsg0
-      r = Binary.runGetIncremental (BB.runBitGet p) `Binary.pushChunks` lbs
-  in case r of
-       Binary.Fail remainingBS pos errMsg ->
-         and [ L.fromChunks [remainingBS] == L.drop expectedBytesConsumed lbs
-             , pos == expectedBytesConsumed
-             , errMsg == errMsg0
-             ]
-       _ -> False
-
--- | Test Alternative instance.
-prop_alternativeLeftIdentity :: L.ByteString -> QC.Property
-prop_alternativeLeftIdentity lbs = QC.property $
-  Binary.runGet (BB.runBitGet (Appl.empty Appl.<|> BB.getLazyByteString n)) lbs == lbs
-  where n = fromIntegral $ L.length lbs
-
-prop_alternativeRightIdentity :: L.ByteString -> QC.Property
-prop_alternativeRightIdentity lbs = QC.property $
-  Binary.runGet (BB.runBitGet (BB.getLazyByteString n Appl.<|> Appl.empty)) lbs == lbs
-  where n = fromIntegral $ L.length lbs
-
--- | number of bits required to write @v@
-bitreq :: (Num b, Num a, Bits.Bits a, Ord a) => a -> b
-bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
-
-bittable :: (Bits.Bits a, Num a) => [(Integer, a)]
-bittable = [ (fromIntegral x, (1 `Bits.shiftL` x) - 1) | x <- [1..64] ]
-
-prop_bitreq :: W Word.Word64 -> QC.Property
-prop_bitreq (W w) = QC.property $
-  ( w == 0 && bitreq w == (1 :: Integer) )
-    || bitreq w == bitreq (w `Bits.shiftR` 1) + (1 :: Integer)
-
-prop_composite_case :: Bool -> W Word.Word16 -> QC.Property
-prop_composite_case b (W w) = w < 0x8000 ==>
-  let p = do BB.putBool b
-             BB.putWord16be 15 w
-      g = do v <- BB.getBool
-             case v of
-              True -> BB.getWord16be 15
-              False -> do
-                msb <- BB.getWord8 7
-                lsb <- BB.getWord8 8
-                return ((fromIntegral msb `Bits.shiftL` 8) .|. fromIntegral lsb)
-      lbs = Binary.runPut (BB.runBitPut p)
-      w' = Binary.runGet (BB.runBitGet g) lbs
-  in w == w'
-
-prop_compare_put_with_naive :: (Bits.Bits a, BB.BinaryBit a, Ord a, Num a) => W [a] -> QC.Property
-prop_compare_put_with_naive (W ws) = QC.property $
-  let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
-      p  = mapM_ (\v -> BB.putBits   (bitreq v) v) ws
-      lbs_n = Binary.runPut (BB.runBitPut pn)
-      lbs   = Binary.runPut (BB.runBitPut p)
-  in lbs_n == lbs
-
-prop_compare_get_with_naive :: (Bits.Bits a, BB.BinaryBit a, Ord a, Num a) => W [a] -> QC.Property
-prop_compare_get_with_naive (W ws) = QC.property $
-  let gn = mapM  (\v -> naive_get (bitreq v)) ws
-      g  = mapM  (\v -> BB.getBits   (bitreq v)) ws
-      p  = mapM_ (\v -> naive_put (bitreq v) v) ws
-      lbs = Binary.runPut (BB.runBitPut p)
-      rn = Binary.runGet (BB.runBitGet gn) lbs
-      r  = Binary.runGet (BB.runBitGet g ) lbs
-      -- we must help our compiler to resolve the types of 'gn' and 'g'
-      _types = rn == ws && r == ws
-  in rn == r
-
--- | Write one bit at a time until the full word has been written
-naive_put :: (Bits.Bits a) => Int -> a -> BB.BitPut ()
-naive_put n w = mapM_ (\b -> BB.putBool (Bits.testBit w b)) [n-1,n-2..0]
-
--- | Read one bit at a time until we've reconstructed the whole word
-naive_get :: (Bits.Bits a, Num a) => Int -> BB.BitGet a
-naive_get n0 =
-  let loop 0 acc = return acc
-      loop n acc = do
-        b <- BB.getBool
-        case b of
-          False -> loop (n-1) (acc `Bits.shiftL` 1)
-          True  -> loop (n-1) ((acc `Bits.shiftL` 1) + 1)
-  in loop n0 0
-
-shrinker :: (Num a, Ord a, Bits.Bits a) => a -> [a]
-shrinker 0 = []
-shrinker w = [ w `Bits.shiftR` 1 -- try to make everything roughly half size
-             ] ++ [ w' -- flip bits to zero, left->right
-                  | m <- [n, n-1..1]
-                  , let w' = w `Bits.clearBit` m
-                  , w /= w'
-                  ] ++ [w-1] -- just make it a little smaller
-  where
-    n = bitreq w
-
-data W a = W { unW :: a } deriving (Show, Eq, Ord)
-
-arbitraryW :: (QC.Arbitrary (W a)) => QC.Gen a
-arbitraryW = unW <$> QC.arbitrary
-
-shrinkW :: (QC.Arbitrary (W a)) => a -> [a]
-shrinkW x = unW <$> QC.shrink (W x)
-
-instance QC.Arbitrary (W Bool) where
-    arbitrary       = W <$> QC.arbitrary
-    shrink          = map W <$> QC.shrink . unW
-
-instance QC.Arbitrary (W Word.Word8) where
-    arbitrary       = W <$> QC.choose (minBound, maxBound)
-    shrink          = map W . shrinker . unW
-
-instance QC.Arbitrary (W Word.Word16) where
-    arbitrary       = W <$> QC.choose (minBound, maxBound)
-    shrink          = map W . shrinker . unW
-
-instance QC.Arbitrary (W Word.Word32) where
-    arbitrary       = W <$> QC.choose (minBound, maxBound)
-    shrink          = map W . shrinker . unW
-
-instance QC.Arbitrary (W Word.Word64) where
-    arbitrary       = W <$> QC.choose (minBound, maxBound)
-    shrink          = map W . shrinker . unW
-
-instance QC.Arbitrary B.ByteString where
-    arbitrary       = B.pack <$> QC.arbitrary
-    shrink bs       = B.pack <$> QC.shrink (B.unpack bs)
-
-instance QC.Arbitrary L.ByteString where
-    arbitrary       = L.fromChunks <$> QC.arbitrary
-    shrink bs       = L.fromChunks <$> QC.shrink (L.toChunks bs)
-
-instance (QC.Arbitrary (W a)) => QC.Arbitrary (W [a]) where
-    arbitrary       = W . map unW <$> QC.arbitrary
-    shrink          = map (W . map unW) <$> mapM QC.shrink . map W . unW
-
-instance (QC.Arbitrary (W a), QC.Arbitrary (W b)) => QC.Arbitrary (W (a,b)) where
-    arbitrary        = (W .) . (,) <$> arbitraryW <*> arbitraryW
-    shrink (W (a,b)) = (W .) . (,) <$> shrinkW a <*> shrinkW b
-
-instance (QC.Arbitrary (W a), QC.Arbitrary (W b), QC.Arbitrary (W c)) => QC.Arbitrary (W (a,b,c)) where
-    arbitrary          = ((W .) .) . (,,) <$> arbitraryW <*> arbitraryW <*> arbitraryW
-    shrink (W (a,b,c)) = ((W .) .) . (,,) <$> shrinkW a <*> shrinkW b <*> shrinkW c
-
-data Primitive
-  = Bool Bool
-  | W8  Int Word.Word8
-  | W16 Int Word.Word16
-  | W32 Int Word.Word32
-  | W64 Int Word.Word64
-  | BS  Int B.ByteString
-  | LBS Int L.ByteString
-  | IsEmpty
-  deriving (Eq, Show)
-
-type Program = [Primitive]
-
-instance QC.Arbitrary Primitive where
-  arbitrary = do
-    let gen c = do
-          let (maxBits, _) = (\w -> (Bits.finiteBitSize w, c undefined w)) undefined
-          bits <- QC.choose (0, maxBits)
-          n <- QC.choose (0, fromIntegral (2^bits-1 :: Integer))
-          return (c bits n)
-    QC.oneof
-      [ Bool <$> QC.arbitrary
-      , gen W8
-      , gen W16
-      , gen W32
-      , gen W64
-      , do n <- QC.choose (0,10)
-           cs <- QC.vector n
-           return (BS n (B.pack cs))
-      , do n <- QC.choose (0,10)
-           cs <- QC.vector n
-           return (LBS n (L.pack cs))
-      , return IsEmpty
-      ]
-  shrink p =
-    let snk c x = map (\x' -> c (bitreq x') x') (shrinker x) in
-    case p of
-      Bool b -> if b then [Bool False] else []
-      W8 _ x -> snk W8 x
-      W16 _ x -> snk W16 x
-      W32 _ x -> snk W32 x
-      W64 _ x -> snk W64 x
-      BS _ bs -> let ws = B.unpack bs in map (\ws' -> BS (length ws') (B.pack ws')) (QC.shrink ws)
-      LBS _ lbs -> let ws = L.unpack lbs in map (\ws' -> LBS (length ws') (L.pack ws')) (QC.shrink ws)
-      IsEmpty -> []
-
-prop_primitive :: Primitive -> QC.Property
-prop_primitive prim = QC.property $
-  let p = putPrimitive prim
-      g = getPrimitive prim
-      lbs = Binary.runPut (BB.runBitPut p)
-      r = Binary.runGet (BB.runBitGet g) lbs
-  in r == prim
-
-prop_program :: Program -> QC.Property
-prop_program program = QC.property $
-  let p = mapM_ putPrimitive program
-      g = verifyProgram (8 * fromIntegral (L.length lbs)) program
-      lbs = Binary.runPut (BB.runBitPut p)
-      r = Binary.runGet (BB.runBitGet g) lbs
-  in r
-
-putPrimitive :: Primitive -> BB.BitPut ()
-putPrimitive p =
-  case p of
-    Bool b -> BB.putBool b
-    W8 n x -> BB.putWord8 n x
-    W16 n x -> BB.putWord16be n x
-    W32 n x -> BB.putWord32be n x
-    W64 n x -> BB.putWord64be n x
-    BS _ bs -> BB.putByteString bs
-    LBS _ lbs -> mapM_ BB.putByteString (L.toChunks lbs)
-    IsEmpty -> return ()
-
-getPrimitive :: Primitive -> BB.BitGet Primitive
-getPrimitive p =
-  case p of
-    Bool _ -> Bool <$> BB.getBool
-    W8 n _ -> W8 n <$> BB.getWord8 n
-    W16 n _ -> W16 n <$> BB.getWord16be n
-    W32 n _ -> W32 n <$> BB.getWord32be n
-    W64 n _ -> W64 n <$> BB.getWord64be n
-    BS n _ -> BS n <$> BB.getByteString n
-    LBS n _ -> LBS n <$> BB.getLazyByteString n
-    IsEmpty -> BB.isEmpty >> return IsEmpty
-
-
-verifyProgram :: Int -> Program -> BB.BitGet Bool
-verifyProgram totalLength ps0 = go 0 ps0
-  where
-    go _ [] = return True
-    go pos (p:ps) =
-      case p of
-        Bool x -> check x BB.getBool >> go (pos+1) ps
-        W8 n x ->  check x (BB.getWord8 n) >> go (pos+n) ps
-        W16 n x -> check x (BB.getWord16be n) >> go (pos+n) ps
-        W32 n x -> check x (BB.getWord32be n) >> go (pos+n) ps
-        W64 n x -> check x (BB.getWord64be n) >> go (pos+n) ps
-        BS n x -> check x (BB.getByteString n) >> go (pos+(8*n)) ps
-        LBS n x -> check x (BB.getLazyByteString n) >> go (pos+(8*n)) ps
-        IsEmpty -> do
-          let expected = pos == totalLength
-          actual <- BB.isEmpty
-          if expected == actual
-            then go pos ps
-            else error $ "isEmpty returned wrong value, expected "
-                          ++ show expected ++ " but got " ++ show actual
-    check x g = do
-      y <- g
-      if x == y
-        then return ()
-        else error $ "Roundtrip error: Expected "
-                     ++ show x ++ " but got " ++ show y