Utils/Containers/Internal/BitQueue.hs

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE BangPatterns #-}

    #include "containers.h"

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Utils.Containers.Internal.BitQueue
    -- Copyright   :  (c) David Feuer 2016
    -- License     :  BSD-style
    -- Maintainer  :  libraries@haskell.org
    -- Portability :  portable
    --
    -- = WARNING
    --
    -- This module is considered __internal__.
    --
    -- The Package Versioning Policy __does not apply__.
    --
    -- This contents of this module may change __in any way whatsoever__
    -- and __without any warning__ between minor versions of this package.
    --
    -- Authors importing this module are expected to track development
    -- closely.
    --
    -- = Description
    --
    -- An extremely light-weight, fast, and limited representation of a string of
    -- up to (2*WORDSIZE - 2) bits. In fact, there are two representations,
    -- misleadingly named bit queue builder and bit queue. The builder supports
    -- only `emptyQB`, creating an empty builder, and `snocQB`, enqueueing a bit.
    -- The bit queue builder is then turned into a bit queue using `buildQ`, after
    -- which bits can be removed one by one using `unconsQ`. If the size limit is
    -- exceeded, further operations will silently produce nonsense.
    -----------------------------------------------------------------------------

    module Utils.Containers.Internal.BitQueue
        ( BitQueue
        , BitQueueB
        , emptyQB
        , snocQB
        , buildQ
        , unconsQ
        , toListQ
        ) where

    #if !MIN_VERSION_base(4,8,0)
    import Data.Word (Word)
    #endif
    import Utils.Containers.Internal.BitUtil (shiftLL, shiftRL, wordSize)
    import Data.Bits ((.|.), (.&.), testBit)
    #if MIN_VERSION_base(4,8,0)
    import Data.Bits (countTrailingZeros)
    #elif MIN_VERSION_base(4,5,0)
    import Data.Bits (popCount)
    #endif

    #if !MIN_VERSION_base(4,5,0)
    -- We could almost certainly improve this fall-back (copied straight from the
    -- default definition in Data.Bits), but it hardly seems worth the trouble
    -- to speed things up on GHC 7.4 and below.
    countTrailingZeros :: Word -> Int
    countTrailingZeros x = go 0
          where
            go i | i >= wordSize      = i
                 | testBit x i = i
                 | otherwise   = go (i+1)

    #elif !MIN_VERSION_base(4,8,0)
    countTrailingZeros :: Word -> Int
    countTrailingZeros x = popCount ((x .&. (-x)) - 1)
    {-# INLINE countTrailingZeros #-}
    #endif

    -- A bit queue builder. We represent a double word using two words
    -- because we don't currently have access to proper double words.
    data BitQueueB = BQB {-# UNPACK #-} !Word
                         {-# UNPACK #-} !Word

    newtype BitQueue = BQ BitQueueB deriving Show

    -- Intended for debugging.
    instance Show BitQueueB where
      show (BQB hi lo) = "BQ"++
        show (map (testBit hi) [(wordSize - 1),(wordSize - 2)..0]
                ++ map (testBit lo) [(wordSize - 1),(wordSize - 2)..0])

    -- | Create an empty bit queue builder. This is represented as a single guard
    -- bit in the most significant position.
    emptyQB :: BitQueueB
    emptyQB = BQB (1 `shiftLL` (wordSize - 1)) 0
    {-# INLINE emptyQB #-}

    -- Shift the double word to the right by one bit.
    shiftQBR1 :: BitQueueB -> BitQueueB
    shiftQBR1 (BQB hi lo) = BQB hi' lo' where
      lo' = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1))
      hi' = hi `shiftRL` 1
    {-# INLINE shiftQBR1 #-}

    -- | Enqueue a bit. This works by shifting the queue right one bit,
    -- then setting the most significant bit as requested.
    {-# INLINE snocQB #-}
    snocQB :: BitQueueB -> Bool -> BitQueueB
    snocQB bq b = case shiftQBR1 bq of
      BQB hi lo -> BQB (hi .|. (fromIntegral (fromEnum b) `shiftLL` (wordSize - 1))) lo

    -- | Convert a bit queue builder to a bit queue. This shifts in a new
    -- guard bit on the left, and shifts right until the old guard bit falls
    -- off.
    {-# INLINE buildQ #-}
    buildQ :: BitQueueB -> BitQueue
    buildQ (BQB hi 0) = BQ (BQB 0 lo') where
      zeros = countTrailingZeros hi
      lo' = ((hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))) `shiftRL` zeros
    buildQ (BQB hi lo) = BQ (BQB hi' lo') where
      zeros = countTrailingZeros lo
      lo1 = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1))
      hi1 = (hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))
      lo' = (lo1 `shiftRL` zeros) .|. (hi1 `shiftLL` (wordSize - zeros))
      hi' = hi1 `shiftRL` zeros

    -- Test if the queue is empty, which occurs when theres
    -- nothing left but a guard bit in the least significant
    -- place.
    nullQ :: BitQueue -> Bool
    nullQ (BQ (BQB 0 1)) = True
    nullQ _ = False
    {-# INLINE nullQ #-}

    -- | Dequeue an element, or discover the queue is empty.
    unconsQ :: BitQueue -> Maybe (Bool, BitQueue)
    unconsQ q | nullQ q = Nothing
    unconsQ (BQ bq@(BQB _ lo)) = Just (hd, BQ tl)
      where
        !hd = (lo .&. 1) /= 0
        !tl = shiftQBR1 bq
    {-# INLINE unconsQ #-}

    -- | Convert a bit queue to a list of bits by unconsing.
    -- This is used to test that the queue functions properly.
    toListQ :: BitQueue -> [Bool]
    toListQ bq = case unconsQ bq of
          Nothing -> []
          Just (hd, tl) -> hd : toListQ tl