data-flags 0.0.1 → 0.0.2
raw patch · 4 files changed
+125/−47 lines, 4 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Data.Flags.TH: bitmaskWrapper :: String -> Name -> [Name] -> Bool -> [(String, Integer)] -> Q [Dec]
Files
- data-flags.cabal +4/−2
- src/Data/Flags.hs +16/−23
- src/Data/Flags/Base.hs +30/−0
- src/Data/Flags/TH.hs +75/−22
data-flags.cabal view
@@ -1,5 +1,5 @@ Name: data-flags-Version: 0.0.1+Version: 0.0.2 Category: Data Stability: experimental Synopsis: A package for working with bit masks and flags in general.@@ -17,11 +17,13 @@ Build-Type: Simple Library- Build-Depends: base == 4.*, template-haskell+ Build-Depends: base < 5, template-haskell Extensions: TemplateHaskell Hs-Source-Dirs: src GHC-Options: -Wall Exposed-Modules: Data.Flags Data.Flags.TH+ Other-Modules:+ Data.Flags.Base
src/Data/Flags.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_ghc -fno-warn-orphans #-} -- | This module provides type classes for working with sets of flags. -- In particular, with wrappers around bit masks:@@ -16,6 +17,16 @@ -- > f :: MyFlags -> IO () -- > f = ... --+-- Or, using Template Haskell:+--+-- > import Data.Flags.TH+-- >+-- > $(bitmaskWrapper "MyFlags" ''CInt [] False+-- > [("myFlag1", #{const C_FLAG1}),+-- > ("myFlag2", #{const C_FLAG2}),+-- > ("myFlag3", #{const C_FLAG3})])+-- >+-- -- And then use it like this: -- -- > f $ myFlag1 .+. myFlag3@@ -38,23 +49,13 @@ import Foreign.C.Types (CChar, CSChar, CUChar, CShort, CUShort, CInt, CUInt, CLong, CULong, CLLong, CULLong) +import Data.Flags.Base import Data.Flags.TH -infixl 8 .<=., .>=., `containsAll`, .~., `containsSome`, ./~., `containsNone`-infixl 7 .-., `butFlags`-infixl 6 .+., `andFlags`-infixl 5 .*., `commonFlags`--class Eq a => Flags a where- -- | The empty set of flags.- noFlags :: a- -- | Union of two flag sets.- andFlags :: a -> a -> a- -- | Difference between two flag sets.- butFlags :: a -> a -> a- -- | Intersection of two flag sets.- commonFlags :: a -> a -> a- f1 `commonFlags` f2 = (f1 .+. f2) .-. (f1 .-. f2) .-. (f2 .-. f1)+infixl 7 .*.+infixl 6 .+.+infixl 5 .-.+infix 4 .<=., .>=., `containsAll`, .~., `containsSome`, ./~., `containsNone` -- | Alias for 'andFlags'. (.+.) :: Flags a => a -> a -> a@@ -67,14 +68,6 @@ -- | Alias for 'commonFlags'. (.*.) :: Flags a => a -> a -> a (.*.) = commonFlags---- | Use this class when the set of flags is fixed and not likely--- to change in the future.-class Flags a => BoundedFlags a where- -- | Set of all flags.- allFlags :: a- -- | List the individual flags.- enumFlags :: a -> [a] -- | Shorthand for 'allFlags' '.-.' /x/. allBut :: BoundedFlags a => a -> a
+ src/Data/Flags/Base.hs view
@@ -0,0 +1,30 @@+module Data.Flags.Base (+ Flags(..),+ BoundedFlags(..),+ ) where++infixl 7 `commonFlags`+infixl 6 `andFlags`+infixl 5 `butFlags`++class Eq a => Flags a where+ -- | The empty set of flags.+ noFlags :: a+ -- | Union of two flag sets.+ andFlags :: a -> a -> a+ -- | Difference between two flag sets.+ butFlags :: a -> a -> a+ -- | Intersection of two flag sets.+ commonFlags :: a -> a -> a+ 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+ -- | Set of all flags.+ allFlags :: a+ -- | List the individual flags.+ enumFlags :: a -> [a]+
src/Data/Flags/TH.hs view
@@ -3,41 +3,94 @@ -- | Template Haskell utils for declaring flags instances. module Data.Flags.TH ( dataBitsAsFlags,- dataBitsAsBoundedFlags+ dataBitsAsBoundedFlags,+ bitmaskWrapper ) where import Language.Haskell.TH import Data.Bits (Bits(..))+import Data.Maybe (isJust)+import Data.List (find, union, intercalate) import Control.Applicative ((<$>)) -inst :: String -> Name -> [Dec] -> Dec-inst name typeName = InstanceD [] (AppT (ConT $ mkName name) (ConT typeName))+import Data.Flags.Base -fun :: String -> Exp -> Dec-fun name expr = FunD (mkName name) [Clause [] (NormalB expr) []]+inst :: Name -> Name -> [Dec] -> Dec+inst className typeName = InstanceD [] (AppT (ConT className) (ConT typeName)) --- | Produces a 'Data.Flags.Flags' instance declaration for the specified+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 typeName = do- noneE <- [| fromInteger 0 |]- unionE <- [| (.|.) |]- intersectionE <- [| (.&.) |] - differenceE <- [| \x -> \y -> x .&. (complement y) |]- return [inst "Flags" typeName- [fun "noFlags" noneE,- fun "andFlags" unionE,- fun "commonFlags" intersectionE,- fun "butFlags" differenceE]]+ noFlagsE <- [| fromInteger 0 |]+ andFlagsE <- [| (.|.) |]+ commonFlagsE <- [| (.&.) |] + butFlagsE <- [| \x -> \y -> x .&. (complement y) |]+ return [inst ''Flags typeName+ [fun 'noFlags noFlagsE,+ fun 'andFlags andFlagsE,+ fun 'commonFlags commonFlagsE,+ fun 'butFlags butFlagsE]] --- | Produces 'Data.Flags.Flags' and 'Data.Flags.BoundedFlags' instances--- declarations for the specified instance of 'Data.Bits.Bits'.+-- | 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 typeName = do- allE <- [| fromInteger (-1) |]- enumE <- [| \x -> map (setBit 0) $ filter (testBit x) [0 .. bitSize x - 1] |]- (++ [inst "BoundedFlags" typeName- [fun "allFlags" allE,- fun "enumFlags" enumE]]) <$> dataBitsAsFlags typeName+ allFlagsE <- [| fromInteger (-1) |]+ enumFlagsE <- [| \x -> map (setBit 0) $+ filter (testBit x) [0 .. bitSize x - 1] |]+ (++ [inst ''BoundedFlags typeName+ [fun 'allFlags allFlagsE,+ fun 'enumFlags enumFlagsE]]) <$> dataBitsAsFlags typeName +-- | Declare a newtype wrapper around the specified integral type and make+-- the wrapper an instance of 'Data.Flags.Base.Flags' (and optionally+-- '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.+ -> Bool -- ^ Whether to declare BoundedFlags instance.+ -> [(String, Integer)] -- ^ Individual flags.+ -> Q [Dec]+bitmaskWrapper typeNameS wrappedName derives bounded 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 . fst) $+ $(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 + [SigD name (ConT typeName),+ FunD name+ [Clause [] (NormalB $+ AppE (ConE typeName)+ (LitE $ IntegerL value))+ []]]) elems) +++ (if bounded+ then [inst ''BoundedFlags typeName+ [fun 'allFlags allFlagsE,+ fun 'enumFlags enumFlagsE]]+ else []) +++ (if (isJust $ find (''Show ==) derives)+ then []+ else [inst ''Show typeName [fun 'show showE]])+