packages feed

bitmasks (empty) → 0

raw patch · 10 files changed

+668/−0 lines, 10 filesdep +QuickCheckdep +basedep +bitmaskssetup-changed

Dependencies added: QuickCheck, base, bitmasks, hspec

Files

+ CHANGELOG.md view
@@ -0,0 +1,12 @@+# Changelog for `bitmasks`
+
+All notable changes to this project will be documented in this file.
+
+The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
+and this project adheres to the
+[Haskell Package Versioning Policy](https://pvp.haskell.org/).
+
+
+## 0 - 2025-09-17
+
+* Bitmask data types with API and tests.
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License
+
+Copyright (c) 2025, Alice Rixte
+
+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 copyright holder nor the names of its
+   contributors may be used to endorse or promote products derived from
+   this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT HOLDER 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.
+ README.md view
@@ -0,0 +1,89 @@+# Bitmasks
+
+Bitmasks for boolean flags.
+
+## Usage
+
+Define your flags as an enumeration:
+
+```haskell
+import Data.Word
+import Data.Bitmask
+
+data PizzaTopping =
+    Cheese
+  | Mushrooms
+  | Pineapple
+  | Ham
+  deriving (Show, Eq, Bounded, Enum)
+
+-- We only need 8 bits since there are only 4 toppings
+type PizzaMask = Bitmask8 PizzaTopping
+```
+
+### Creating bitmasks
+
+```haskell
+-- A Margherita pizza (cheese only)
+margherita :: PizzaMask
+margherita = fromFlags [Cheese]
+
+veggie :: PizzaMask
+veggie = fromExceptFlags [Ham]
+
+```
+
+### Access and modify flags
+
+Use `getFlag` to check if a pizza has a specific topping:
+
+```haskell
+>>> getFlag Cheese funghi
+True
+>>> getFlag Pineapple funghi
+False
+```
+
+Add toppings to a pizza:
+
+```haskell
+>>> hawaiian = addFlags [Pineapple, Ham] margherita
+>>> getFlags [Pineapple, Mushroom] hawaiian
+True
+```
+
+Make any pizza vegetarian (bitwise AND):
+
+```haskell
+>>> veggieHawaiian = veggie .&. hawaiian
+>>> getFlag Ham veggieHawaiian
+```
+
+Toggle (I have no idea what I'm talking about) the toppings :
+
+```haskell
+>>> funghi = flipFlags [Pineapple, Mushroom] veggieHawaiian
+>>> toFlags funghi
+[Cheese,Mushrooms]
+```
+
+Remove a topping:
+
+```haskell
+>>> margherita == deleteFlag Mushroom funghi
+True
+```
+
+### Convert to lists
+
+```haskell
+-- Get all toppings as a list
+>>> toFlags funghi
+[Cheese,Mushrooms]
+>>> toFlags hawaiian
+[Cheese,Pineapple,Ham]
+
+-- Convert to association lists
+>>> toFlagsBool funghi
+[(Cheese,True),(Mushrooms,True),(Pineapple,False),(Ham,False)]
+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain
+ bitmasks.cabal view
@@ -0,0 +1,61 @@+cabal-version: 2.2
++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           bitmasks+version:        0+synopsis:       Bitmasks for efficient storing of boolean flags+description:    Please see the README on GitHub at <https://github.com/AliceRixte/bitmasks#readme>+category:       data+homepage:       https://github.com/AliceRixte/bitmasks#readme+bug-reports:    https://github.com/AliceRixte/bitmasks/issues+author:         Alice Rixte+maintainer:     alice.rixte@u-bordeaux.fr+copyright:      (c) Alice Rixte 2025+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+extra-doc-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/AliceRixte/bitmasks++library+  exposed-modules:+      Data.Bitmask+      Data.Bitmask.Internal+  other-modules:+      Paths_bitmasks+  autogen-modules:+      Paths_bitmasks+  hs-source-dirs:+      src+  ghc-options: -Wall -threaded+  build-depends:+      base >=4.18 && <5+  default-language: Haskell2010++test-suite bitmasks-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Data.BitmaskSpec+      Data.Pizza+      Paths_bitmasks+  autogen-modules:+      Paths_bitmasks+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck >=2.14+    , base >=4.18 && <5+    , bitmasks+    , hspec >=2.11+  default-language: Haskell2010
+ src/Data/Bitmask.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE GHC2021#-}
+
+--------------------------------------------------------------------------------
+-- |
+--
+-- Module      :  Data.Bitmask
+-- Description :  Bitmasks
+-- Copyright   :  (c) Alice Rixte 2025
+-- License     :  BSD 3
+-- Maintainer  :  alice.rixte@u-bordeaux.fr
+-- Stability   :  stable
+-- Portability :  portable
+--
+-- Bitmasks for efficient storing of boolean flags
+--
+--------------------------------------------------------------------------------
+
+module Data.Bitmask
+  ( Bitmask
+  , Bitmask8
+  , Bitmask16
+  , Bitmask32
+  , Bitmask64
+  -- ** Conversion to and from bits
+  , fromBits
+  , toBits
+  -- ** Check bitmask validity
+  , checkBitmask
+  -- ** Bitmask creation
+  , noFlag
+  , allFlags
+  , fromFlags
+  , toFlags
+  , fromExceptFlags
+  , toExceptFlags
+  , fromFlagsBool
+  , toFlagsBool
+  -- ** Flag querying
+  , getFlag
+  , getFlags
+  -- ** Flag modification
+  , addFlag
+  , addFlags
+  , deleteFlag
+  , deleteFlags
+  , flipFlag
+  , flipFlags
+  , setFlag
+  , setFlags
+  , modifyFlag
+  , modifyFlags
+  -- ** Re-exports from "Data.Bits"
+  , (.&.)
+  , (.|.)
+  , xor
+  , complement
+  )
+  where
+
+import Data.Bits
+import Data.Bitmask.Internal
+
+ src/Data/Bitmask/Internal.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE GHC2021#-}
+
+--------------------------------------------------------------------------------
+-- |
+--
+-- Module      :  Data.Bitmask.Internal
+-- Description :  Bitmasks
+-- Copyright   :  (c) Alice Rixte 2025
+-- License     :  BSD 3
+-- Maintainer  :  alice.rixte@u-bordeaux.fr
+-- Stability   :  stable
+-- Portability :  portable
+--
+--
+-- Bitmasks for efficient storing of boolean flags
+--
+-- = WARNING
+--
+-- This module is considered __internal__.
+--
+-- The Package Versioning Policy __does not apply__.
+--
+-- The 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.
+--
+--------------------------------------------------------------------------------
+
+module Data.Bitmask.Internal
+  ( Bitmask(..)
+  , Bitmask8
+  , Bitmask16
+  , Bitmask32
+  , Bitmask64
+  -- ** Conversion to and from bits
+  , fromBits
+  , toBits
+  -- ** Check bitmask validity
+  , checkBitmask
+  -- ** Bitmask creation
+  , noFlag
+  , allFlags
+  , fromFlags
+  , toFlags
+  , fromExceptFlags
+  , toExceptFlags
+  , fromFlagsBool
+  , toFlagsBool
+  -- ** Flag querying
+  , getFlag
+  , getFlags
+  -- ** Flag modification
+  , addFlag
+  , addFlags
+  , deleteFlag
+  , deleteFlags
+  , flipFlag
+  , flipFlags
+  , setFlag
+  , setFlags
+  , modifyFlag
+  , modifyFlags
+  ) where
+
+import Data.Word
+import Data.Bits
+
+
+-- | A bitmask that contains boolean flags
+--
+-- * The 'flag' type should be an enumeration type (i.e. an instance of 'Enum').
+--
+-- * The 'w' type should be an integral type (e.g. 'Word8', 'Word32', etc.) that
+-- supports bitwise operations.
+--
+-- * The number of bits in 'w' must be at least as many as the number of
+-- constructors in 'flag'.
+--
+-- [Usage:]
+--
+-- @
+-- data PizzaTopping =
+--    Cheese
+--  | Mushrooms
+--  | Pineapple
+--  | Ham
+--  deriving (Show, Eq, Bounded, Enum)
+--
+--  type PizzaMask = Bitmask8 PizzaTopping Word8
+-- @
+--
+newtype Bitmask w flag = Bitmask w
+  deriving (Eq, Ord, Show, Bits)
+
+type Bitmask8 = Bitmask Word8
+type Bitmask16 = Bitmask Word16
+type Bitmask32 = Bitmask Word32
+type Bitmask64 = Bitmask Word64
+
+-- | Create a bitmask from raw bits.
+--
+fromBits :: w -> Bitmask w flag
+fromBits = Bitmask
+
+-- | Convert a bitmask to raw bits.
+--
+toBits :: Bitmask w flag -> w
+toBits (Bitmask w) = w
+
+-- | Check that a bitmask can represent all flags.
+--
+-- >>> checkBitmask (allFlags :: Bitmask8 PizzaTopping)
+-- True
+--
+checkBitmask :: forall flag w. (FiniteBits w, Enum flag, Bounded flag)
+  => Bitmask w flag -> Bool
+checkBitmask (Bitmask w) =
+  finiteBitSize w >= (fromEnum (maxBound :: flag) + 1)
+
+---------------------- Creation and conversion to lists ----------------------
+
+-- | A bitmask with all flags set to 'False'.
+--
+-- >>> getFlag Mushrooms (noFlag :: PizzaMask)
+-- False
+--
+noFlag :: Bits w => Bitmask w flag
+noFlag = Bitmask zeroBits
+
+-- | A bitmask with all flags set to 'True'.
+--
+-- >>> getFlag Mushrooms (allFlags :: PizzaMask)
+-- True
+--
+allFlags :: (FiniteBits w, Enum flag) => Bitmask w flag
+allFlags = Bitmask oneBits
+
+-- | Create a bitmask from a list of flags to set to 'True'.
+--
+-- >>> hawaiian = fromFlags [Pineapple, Ham, Cheese] :: PizzaMask
+--
+fromFlags :: (Bits w, Enum flag) => [flag] -> Bitmask w flag
+fromFlags = foldr addFlag noFlag
+
+-- | Convert a bitmask to a list of flags that are set to 'True'.
+--
+-- >>> toFlags hawaiian
+-- [Cheese,Pineapple,Ham]
+--
+toFlags :: forall flag w. (FiniteBits w, Enum flag, Bounded flag)
+  => Bitmask w flag -> [flag]
+toFlags bm@(Bitmask w) =
+  let n = finiteBitSize w in
+  filter (`getFlag` bm)
+    [toEnum i | i <- [0 .. min (n - 1) (fromEnum (maxBound :: flag))]]
+
+-- | Create a bitmask from a list of flags to set to 'False'
+--
+-- >>> veggie = fromExceptFlags [Ham] :: PizzaMask
+--
+fromExceptFlags :: (FiniteBits w, Enum flag) => [flag] -> Bitmask w flag
+fromExceptFlags = foldr deleteFlag allFlags
+
+-- | Convert a bitmask to a list of flags that are set to 'False'.
+--
+-- >>> toExceptFlags veggie
+-- [Ham]
+toExceptFlags :: forall flag w. (FiniteBits w, Enum flag, Bounded flag)
+  => Bitmask w flag -> [flag]
+toExceptFlags bm@(Bitmask w) =
+  let n = finiteBitSize w in
+  filter (not . (`getFlag` bm))
+    [toEnum i | i <- [0 .. min (n - 1) (fromEnum (maxBound :: flag))]]
+
+-- | Convert an association list of flags and boolean values to a bitmask.
+--
+-- >>> funghi = fromFlagsBool [(Cheese, True), (Ham, False), (Mushrooms, True)] :: PizzaMask
+fromFlagsBool :: forall flag w. (Bits w, Enum flag)
+  => [(flag, Bool)] -> Bitmask w flag
+fromFlagsBool = foldr (uncurry setFlag) noFlag
+
+-- | Convert a bitmask to an association list of flags and boolean values.
+--
+-- >>> toFlagsBool funghi
+-- [(Cheese,True),(Mushrooms,True),(Pineapple,False),(Ham,False)]
+--
+toFlagsBool :: forall flag w. (FiniteBits w, Enum flag, Bounded flag)
+  => Bitmask w flag -> [(flag, Bool)]
+toFlagsBool bm@(Bitmask w) =
+  let n = finiteBitSize w in
+  [(toEnum i, getFlag (toEnum i) bm)
+    | i <- [0 .. min (n - 1) (fromEnum (maxBound :: flag))]]
+
+---------------------- Querying and modifying flags ----------------------
+
+-- | Get a flag from a bitmask.
+--
+-- >>> getFlag Mushrooms hawaiian
+-- False
+--
+getFlag :: (Bits w, Enum flag) => flag -> Bitmask w flag -> Bool
+getFlag flag (Bitmask w) = testBit w (fromEnum flag)
+
+-- | Get multiple flags from a bitmask.
+--
+-- >>> getFlags [Cheese, Mushrooms] hawaiian
+-- [True,False]
+--
+getFlags :: (Bits w, Enum flag) => [flag] -> Bitmask w flag -> [Bool]
+getFlags fs bm = map (`getFlag` bm) fs
+
+-- | Add a flag to a bitmask (set it to 'True').
+--
+-- >>> margherita = addFlag Cheese (noFlag :: PizzaMask)
+--
+addFlag :: (Bits w, Enum flag) =>
+  flag -> Bitmask w flag -> Bitmask w flag
+addFlag f = setFlag f True
+
+-- | Add multiple flags to a bitmask (set them to 'True').
+--
+-- >>> hawaiian = addFlags [Pineapple, Ham] margherita
+--
+addFlags :: (Bits w, Enum flag)
+  => [flag] -> Bitmask w flag -> Bitmask w flag
+addFlags fs bm = foldr addFlag bm fs
+
+-- | Remove a flag from a bitmask (set it to 'False').
+--
+-- >>> veggie = deleteFlag Ham (allFlags :: PizzaMask)
+--
+deleteFlag :: (Bits w, Enum flag) =>
+  flag -> Bitmask w flag -> Bitmask w flag
+deleteFlag f = setFlag f False
+
+-- | Remove multiple flags from a bitmask (set them to 'False').
+--
+-- >>> picky = deleteFlags [Pineapple, Ham] (allFlags :: PizzaMask)
+--
+deleteFlags :: (Bits w, Enum flag)
+  => [flag] -> Bitmask w flag -> Bitmask w flag
+deleteFlags fs bm = foldr deleteFlag bm fs
+
+-- | Set a flag in a bitmask.
+--
+-- >>> funghi = setFlag Mushrooms True margherita
+setFlag :: (Bits w, Enum flag) =>
+  flag -> Bool -> Bitmask w flag -> Bitmask w flag
+setFlag flag value (Bitmask w) = Bitmask $
+  if value then
+    setBit w (fromEnum flag)
+  else
+    clearBit w (fromEnum flag)
+
+-- | Set multiple flags in a bitmask.
+--
+-- >>> hawaiian = setFlags [(Ham, True), (Pineapple, True)] margherita
+--
+setFlags :: (Bits w, Enum flag) =>
+  [(flag, Bool)] -> Bitmask w flag -> Bitmask w flag
+setFlags fs bm = foldr (uncurry setFlag) bm fs
+
+-- | Flip a flag in a bitmask.
+--
+-- >>> margherita = flipFlag Cheese (noFlag :: PizzaMask)
+flipFlag :: (Bits w, Enum flag) =>
+  flag -> Bitmask w flag -> Bitmask w flag
+flipFlag flag (Bitmask w) = Bitmask $ complementBit w (fromEnum flag)
+
+-- | Flip multiple flags in a bitmask.
+--
+-- >>> funghi = flipFlags [Mushrooms, Ham, Pineapple] hawaiian
+flipFlags :: (Bits w, Enum flag) =>
+  [flag] -> Bitmask w flag -> Bitmask w flag
+flipFlags fs bm = foldr flipFlag bm fs
+
+-- | Modify a flag in a bitmask.
+--
+-- >>> veggie = modifyFlag Ham not (allFlags :: PizzaMask)
+--
+modifyFlag :: (Bits w, Enum flag) =>
+  flag -> (Bool -> Bool) -> Bitmask w flag -> Bitmask w flag
+modifyFlag flag f (Bitmask w) = Bitmask $
+  if f (testBit w (fromEnum flag)) then
+    setBit w (fromEnum flag)
+  else
+    clearBit w (fromEnum flag)
+
+-- | Modify multiple flags in a bitmask.
+--
+-- >>> picky = modifyFlags [Pineapple, Ham] not (allFlags :: PizzaMask)
+--
+modifyFlags :: (Bits w, Enum flag) =>
+  [flag] -> (Bool -> Bool) -> Bitmask w flag -> Bitmask w flag
+modifyFlags fs f bm = foldr (`modifyFlag` f) bm fs
+ test/Data/BitmaskSpec.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-orphans #-} -- arbitrary instance
+{-# OPTIONS_GHC -Wno-x-partial #-} -- to use head
+
+module Data.BitmaskSpec where
+
+import Data.Word
+import Data.List (group, sort)
+
+import Test.Hspec
+import Test.QuickCheck
+
+import Data.Bitmask.Internal
+import Data.Pizza
+
+instance Arbitrary w => Arbitrary (Bitmask w flag) where
+  arbitrary = Bitmask <$> arbitrary
+
+maxPizza :: Word8
+maxPizza = 2 ^ (fromEnum (maxBound :: PizzaTopping) + 1) - 1
+
+rmDups :: (Ord a) => [a] -> [a]
+rmDups = map head . group . sort
+
+getAll :: Property
+getAll = property $ \(flag :: PizzaTopping) ->
+  getFlag flag (allFlags :: PizzaMask) == True
+
+getNone :: Property
+getNone = property $ \(flag :: PizzaTopping) ->
+  getFlag flag (noFlag :: PizzaMask) == False
+
+fromToFlags :: Property
+fromToFlags = property $ \(flags :: [PizzaTopping])->
+  toFlags (fromFlags flags :: PizzaMask) == rmDups flags
+
+toFromFlags :: Property
+toFromFlags = property $ \bm@(Bitmask w :: PizzaMask) ->
+  w > maxPizza || fromFlags (toFlags bm) == bm
+
+fromToExcept :: Property
+fromToExcept = property $ \(flags :: [PizzaTopping])->
+    toExceptFlags (fromExceptFlags flags :: PizzaMask) == rmDups flags
+
+
+fromToFlagsBool :: Property
+fromToFlagsBool = property $ \(flagsBool :: [(PizzaTopping, Bool)]) ->
+  toFlagsBool (fromFlagsBool flagsBool :: PizzaMask) == rmDups flagsBool
+
+getAdd :: Property
+getAdd = property $ \(flag :: PizzaTopping) (bm :: PizzaMask) ->
+  getFlag flag (addFlag flag bm) == True
+
+getAdds :: Property
+getAdds = property $ \(flags :: [PizzaTopping]) (bm :: PizzaMask) ->
+  all id $ getFlags flags (addFlags flags bm)
+
+getDelete :: Property
+getDelete = property $ \(flag :: PizzaTopping) (bm :: PizzaMask) ->
+  getFlag flag (deleteFlag flag bm) == False
+
+getDeletes :: Property
+getDeletes = property $ \(flags :: [PizzaTopping]) (bm :: PizzaMask) ->
+  all not $ getFlags flags (deleteFlags flags bm)
+
+
+flipModifs :: Property
+flipModifs = property $ \(flags :: [PizzaTopping]) (bm :: PizzaMask) ->
+  modifyFlags flags not bm == flipFlags flags bm
+
+spec :: Spec
+spec = do
+  describe "Bitmask" $ do
+    it "checkBitmask allFlags == True" $ property $
+      checkBitmask (allFlags :: PizzaMask)
+    it "fromToFlags" $ property fromToFlags
+    it "toFromFlags" $ property toFromFlags
+    it "fromToExcept" $ property fromToExcept
+    it "getFlag flag allFlags == True" $ property getAll
+    it "getFlag flag noFlag == False" $ property getNone
+    it "getFlag flag (addFlag flag bm) == True" $ property getAdd
+    it "all id (getFlags flags (addFlags flags bm))" $ property getAdds
+    it "getFlag flag (deleteFlag flag bm) == False" $ property getDelete
+    it "all not (getFlags flags (deleteFlags flags bm))" $ property getDeletes
+    it "modifyFlags not flags bm == flipFlags flags bm" $ property flipModifs
+ test/Data/Pizza.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DerivingVia #-}
+
+module Data.Pizza where
+
+import Data.Bitmask
+
+import Test.QuickCheck
+
+-- Pizza toppings enumeration
+
+data PizzaTopping =
+    Cheese
+  | Mushrooms
+  | Pineapple
+  | Ham
+  deriving (Show, Eq, Ord, Bounded, Enum)
+
+instance Arbitrary PizzaTopping where
+  arbitrary = chooseEnum (minBound :: PizzaTopping, maxBound :: PizzaTopping)
+
+type PizzaMask = Bitmask8 PizzaTopping
+
+-- Pizza examples
+margherita :: PizzaMask
+margherita = fromFlags [Cheese]
+
+veggie :: PizzaMask
+veggie = fromExceptFlags [Ham]
+
+hawaiian :: PizzaMask
+hawaiian = addFlags [Pineapple, Ham] margherita
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}