diff --git a/data-flags.cabal b/data-flags.cabal --- a/data-flags.cabal +++ b/data-flags.cabal @@ -1,5 +1,5 @@ Name: data-flags -Version: 0.0.3.1 +Version: 0.0.3.2 Category: Data Stability: experimental Synopsis: A package for working with bit masks and flags in general. @@ -7,6 +7,9 @@ This package provides type classes for flags and corresponding instances for standard numeric types viewed as bit masks. +Homepage: https://github.com/mvv/data-flags +Bug-Reports: https://github.com/mvv/data-flags/issues + Author: Mikhail Vorozhtsov Maintainer: Mikhail Vorozhtsov Copyright: 2010 Mikhail Vorozhtsov @@ -16,6 +19,10 @@ Cabal-Version: >= 1.6.0 Build-Type: Simple +Source-Repository head + Type: git + Location: https://github.com/mvv/data-flags.git + Library Build-Depends: base < 5, template-haskell Hs-Source-Dirs: src @@ -25,4 +32,3 @@ Data.Flags.TH Other-Modules: Data.Flags.Base - diff --git a/src/Data/Flags.hs b/src/Data/Flags.hs --- a/src/Data/Flags.hs +++ b/src/Data/Flags.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_ghc -fno-warn-orphans #-} @@ -30,16 +31,16 @@ -- And then use it like this: -- -- > f $ myFlag1 .+. myFlag3 -module Data.Flags ( - Flags(..), - (.+.), (.-.), (.*.), +module Data.Flags + ( Flags(..) + , (.+.), (.-.), (.*.) - BoundedFlags(..), - allBut, + , BoundedFlags(..) + , allBut - containsAll, (.<=.), (.>=.), - containsSome, (.~.), - containsNone, (./~.), + , containsAll, (.<=.), (.>=.) + , containsSome, (.~.) + , containsNone, (./~.) ) where import Data.Bits () @@ -58,47 +59,47 @@ infix 4 .<=., .>=., `containsAll`, .~., `containsSome`, ./~., `containsNone` -- | Alias for 'andFlags'. -(.+.) :: Flags a => a -> a -> a +(.+.) ∷ Flags α ⇒ α → α → α (.+.) = andFlags -- | Alias for 'butFlags'. -(.-.) :: Flags a => a -> a -> a +(.-.) ∷ Flags α ⇒ α → α → α (.-.) = butFlags -- | Alias for 'commonFlags'. -(.*.) :: Flags a => a -> a -> a +(.*.) ∷ Flags α ⇒ α → α → α (.*.) = commonFlags -- | Shorthand for 'allFlags' '.-.' /x/. -allBut :: BoundedFlags a => a -> a +allBut ∷ BoundedFlags α ⇒ α → α allBut = (allFlags .-.) -- | Test if the first flag set contains all flags from the second. -containsAll :: Flags a => a -> a -> Bool +containsAll ∷ Flags α ⇒ α → α → Bool containsAll flags subflags = flags .*. subflags == subflags -- | Alias for 'containsAll'. -(.>=.) :: Flags a => a -> a -> Bool +(.>=.) ∷ Flags α ⇒ α → α → Bool (.>=.) = containsAll -- | Shorthand for 'flip' 'containsAll'. -(.<=.) :: Flags a => a -> a -> Bool +(.<=.) ∷ Flags α ⇒ α → α → Bool (.<=.) = flip containsAll -- | Test if two flag sets intersect. -containsSome :: Flags a => a -> a -> Bool +containsSome ∷ Flags α ⇒ α → α → Bool containsSome flags subflags = flags .*. subflags /= noFlags -- | Alias for 'containsSome'. -(.~.) :: Flags a => a -> a -> Bool +(.~.) ∷ Flags α ⇒ α → α → Bool (.~.) = containsSome -- | Test if two flag sets do not intersect. -containsNone :: Flags a => a -> a -> Bool +containsNone ∷ Flags α ⇒ α → α → Bool containsNone flags subflags = flags .*. subflags == noFlags -- | Alias for 'containsNone'. -(./~.) :: Flags a => a -> a -> Bool +(./~.) ∷ Flags α ⇒ α → α → Bool (./~.) = containsNone $(dataBitsAsFlags ''Integer) @@ -125,4 +126,3 @@ $(dataBitsAsBoundedFlags ''CULong) $(dataBitsAsBoundedFlags ''CLLong) $(dataBitsAsBoundedFlags ''CULLong) - diff --git a/src/Data/Flags/Base.hs b/src/Data/Flags/Base.hs --- a/src/Data/Flags/Base.hs +++ b/src/Data/Flags/Base.hs @@ -1,30 +1,31 @@ -module Data.Flags.Base ( - Flags(..), - BoundedFlags(..), +{-# LANGUAGE UnicodeSyntax #-} + +module Data.Flags.Base + ( Flags(..) + , BoundedFlags(..) ) where infixl 7 `commonFlags` infixl 6 `andFlags` infixl 5 `butFlags` -class Eq a => Flags a where +class Eq α ⇒ Flags α where -- | The empty set of flags. - noFlags :: a + noFlags ∷ α -- | Union of two flag sets. - andFlags :: a -> a -> a + andFlags ∷ α -> α -> α -- | Difference between two flag sets. - butFlags :: a -> a -> a + butFlags ∷ α -> α -> α -- | Intersection of two flag sets. - commonFlags :: a -> a -> a + commonFlags ∷ α -> α -> α f1 `commonFlags` f2 = (f1 `andFlags` f2) `butFlags` (f1 `butFlags` f2) `butFlags` (f2 `butFlags` f1) -- | Use this class when the set of flags is fixed and not likely -- to change in the future. -class Flags a => BoundedFlags a where +class Flags α ⇒ BoundedFlags α where -- | Set of all flags. - allFlags :: a + allFlags ∷ α -- | List the individual flags. - enumFlags :: a -> [a] - + enumFlags ∷ α -> [α] diff --git a/src/Data/Flags/TH.hs b/src/Data/Flags/TH.hs --- a/src/Data/Flags/TH.hs +++ b/src/Data/Flags/TH.hs @@ -1,16 +1,21 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} -- | Template Haskell utils for declaring flags instances. -module Data.Flags.TH ( - dataBitsAsFlags, - dataBitsAsBoundedFlags, - bitmaskWrapper, - enumADT +module Data.Flags.TH + ( dataBitsAsFlags + , dataBitsAsBoundedFlags + , bitmaskWrapper + , enumADT ) where import Language.Haskell.TH import Data.Bits (Bits(..)) +#if MIN_VERSION_base(4,7,0) +import Data.Bits (FiniteBits(..)) +#endif import Data.Maybe (isJust) import Data.List (find, union, intercalate) import Foreign.Storable (Storable(..)) @@ -19,20 +24,29 @@ import Data.Flags.Base -inst :: Name -> Name -> [Dec] -> Dec -inst className typeName = InstanceD [] (AppT (ConT className) (ConT typeName)) +#if !MIN_VERSION_base(4,7,0) +finiteBitSize ∷ Bits α ⇒ α → Int +finiteBitSize = bitSize +#endif -fun :: Name -> Exp -> Dec +inst ∷ Name → Name → [Dec] → Dec +inst className typeName = InstanceD +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + [] (AppT (ConT className) (ConT typeName)) + +fun ∷ Name → Exp → Dec fun name expr = FunD name [Clause [] (NormalB expr) []] -- | Produces 'Data.Flags.Base.Flags' instance declaration for the specified -- instance of 'Data.Bits.Bits'. -dataBitsAsFlags :: Name -> Q [Dec] +dataBitsAsFlags ∷ Name → Q [Dec] dataBitsAsFlags typeName = do - noFlagsE <- appE (varE 'fromInteger) (litE $ IntegerL 0) - andFlagsE <- [| (.|.) |] - commonFlagsE <- [| (.&.) |] - butFlagsE <- [| \x -> \y -> x .&. (complement y) |] + noFlagsE ← appE (varE 'fromInteger) (litE $ IntegerL 0) + andFlagsE ← [| (.|.) |] + commonFlagsE ← [| (.&.) |] + butFlagsE ← [| \x → \y → x .&. (complement y) |] return [inst ''Flags typeName [fun 'noFlags noFlagsE, fun 'andFlags andFlagsE, @@ -41,45 +55,58 @@ -- | Produces 'Data.Flags.Base.Flags' and 'Data.Flags.Base.BoundedFlags' -- instances declarations for the specified instance of 'Data.Bits.Bits'. -dataBitsAsBoundedFlags :: Name -> Q [Dec] +dataBitsAsBoundedFlags ∷ Name → Q [Dec] dataBitsAsBoundedFlags typeName = do - allFlagsE <- appE (varE 'fromInteger) (litE $ IntegerL (-1)) - enumFlagsE <- [| \x -> map (setBit 0) $ - filter (testBit x) [0 .. bitSize x - 1] |] + allFlagsE ← appE (varE 'fromInteger) (litE $ IntegerL (-1)) + enumFlagsE ← [| \x → map (setBit 0) $ + filter (testBit x) [0 .. finiteBitSize x - 1] |] (++ [inst ''BoundedFlags typeName [fun 'allFlags allFlagsE, fun 'enumFlags enumFlagsE]]) <$> dataBitsAsFlags typeName - + -- | Declare a newtype wrapper around the specified integral type and make -- it an instance of 'Data.Flags.Base.BoundedFlags'. For each individual -- flag declare a constant. If a 'Show' instance wasn't requested for -- automatic derivation, declare one with -- -- > show flags = "WrappingTypeName [IndividualFlags in flags]" -bitmaskWrapper :: String -- ^ Wrapping type name. - -> Name -- ^ Wrapped type name. - -> [Name] -- ^ Types to derive automatically. - -> [(String, Integer)] -- ^ Individual flags. - -> Q [Dec] +bitmaskWrapper ∷ String -- ^ Wrapping type name. + → Name -- ^ Wrapped type name. + → [Name] -- ^ Types to derive automatically. + → [(String, Integer)] -- ^ Individual flags. + → Q [Dec] bitmaskWrapper typeNameS wrappedName derives elems = do - typeName <- return $ mkName typeNameS - showE <- [| \flags -> $(stringE $ typeNameS ++ " [") ++ - (intercalate ", " $ map snd $ - filter ((noFlags /=) . commonFlags flags . fst) $ - $(listE $ - map (\(name, _) -> - tupE [varE $ mkName name, - stringE name]) - elems)) ++ "]" |] - allFlagsE <- [| foldl andFlags noFlags - $(listE $ map (varE . mkName . fst) elems) |] - enumFlagsE <- [| \flags -> filter ((noFlags /=) . commonFlags flags) $ - $(listE $ map (varE . mkName . fst) elems) |] - return $ [NewtypeD [] typeName [] - (NormalC typeName [(NotStrict, ConT wrappedName)]) - (union [''Eq, ''Flags] derives)] ++ - (concatMap (\(nameS, value) -> - let name = mkName nameS in + typeName ← return $ mkName typeNameS + showE ← [| \flags → $(stringE $ typeNameS ++ " [") ++ + (intercalate ", " $ map snd $ + filter ((noFlags /=) . commonFlags flags . fst) $ + $(listE $ + map (\(name, _) → + tupE [varE $ mkName name, + stringE name]) + elems)) ++ "]" |] + allFlagsE ← [| foldl andFlags noFlags + $(listE $ map (varE . mkName . fst) elems) |] + enumFlagsE ← [| \flags → filter ((noFlags /=) . commonFlags flags) $ + $(listE $ map (varE . mkName . fst) elems) |] + let strictness = +#if MIN_VERSION_template_haskell(2,11,0) + Bang NoSourceUnpackedness NoSourceStrictness +#else + NotStrict +#endif + return $ [ NewtypeD [] typeName [] +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + (NormalC typeName [(strictness, ConT wrappedName)]) +#if MIN_VERSION_template_haskell(2,10,0) + . fmap ConT $ +#endif + (union [''Eq, ''Flags] derives) + ] ++ + (concatMap (\(nameS, value) → + let name = mkName nameS in [SigD name (ConT typeName), FunD name [Clause [] (NormalB $ @@ -95,38 +122,44 @@ -- | Declare an ADT with the specified constructors and make it an instance -- of 'Eq', 'Ord', 'Show' and 'Foreign.Storable.Storable'. -enumADT :: String -- ^ Type name. - -> Name -- Numeric type name. - -> [(String, Integer)] -- ^ Enumeration elements. - -> Q [Dec] +enumADT ∷ String -- ^ Type name. + → Name -- Numeric type name. + → [(String, Integer)] -- ^ Enumeration elements. + → Q [Dec] enumADT typeNameS numName elems = do let typeName = mkName typeNameS wrap i = caseE (varE i) $ - (map (\(name, value) -> + (map (\(name, value) → match (litP $ IntegerL value) (normalB $ appE (conE 'Just) (conE $ mkName name)) []) elems) ++ [match wildP (normalB $ conE 'Nothing) []] unwrap w = caseE (varE w) - (map (\(name, value) -> + (map (\(name, value) → match (conP (mkName name) []) (normalB $ litE $ IntegerL value) []) elems) in do - alignmentE <- [| \_ -> alignment (undefined :: $(conT numName)) |] - sizeOfE <- [| \_ -> sizeOf (undefined :: $(conT numName)) |] - peekE <- [| \p -> do - i <- peek (castPtr p :: Ptr $(conT numName)) - case $(wrap 'i) of - Just w -> return w - Nothing -> fail $ "Invalid value for " ++ typeNameS |] - pokeE <- [| \p -> \v -> poke (castPtr p :: Ptr $(conT numName)) - $(unwrap 'v) |] - return [DataD [] typeName [] (map ((`NormalC` []) . mkName . fst) elems) + alignmentE ← [| \_ → alignment (undefined ∷ $(conT numName)) |] + sizeOfE ← [| \_ → sizeOf (undefined ∷ $(conT numName)) |] + peekE ← [| \p → do + i ← peek (castPtr p ∷ Ptr $(conT numName)) + case $(wrap 'i) of + Just w -> return w + Nothing -> fail $ "Invalid value for " ++ typeNameS |] + pokeE ← [| \p → \v → poke (castPtr p ∷ Ptr $(conT numName)) + $(unwrap 'v) |] + return [DataD [] typeName [] +#if MIN_VERSION_template_haskell(2,11,0) + Nothing +#endif + (map ((`NormalC` []) . mkName . fst) elems) +#if MIN_VERSION_template_haskell(2,10,0) + . fmap ConT $ +#endif [''Eq, ''Ord, ''Show], inst ''Storable typeName [fun 'alignment alignmentE, fun 'sizeOf sizeOfE, fun 'peek peekE, fun 'poke pokeE]] -